/*
* ===========================================================================
* Prototypes for level 0 BLAS routines
* ===========================================================================
*/
int
f2c_srotg(real* a,
real* b,
real* c,
real* s)
{
srotg_(a, b, c, s);
return 0;
}
/*< subroutine csvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info) >*/
/* Subroutine */ int csvdc_(complex *x, integer *ldx, integer *n, integer *p,
complex *s, complex *e, complex *u, integer *ldu, complex *v, integer
*ldv, complex *work, integer *job, integer *info)
{
/* System generated locals */
integer x_dim1, x_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
i__3, i__4;
real r__1, r__2, r__3, r__4;
complex q__1, q__2, q__3;
/* Builtin functions */
double r_imag(complex *), c_abs(complex *);
void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
double sqrt(doublereal);
/* Local variables */
real b, c__, f, g;
integer i__, j, k, l=0, m;
complex r__, t;
real t1, el;
integer kk;
real cs;
integer ll, mm, ls=0;
real sl;
integer lu;
real sm, sn;
integer lm1, mm1, lp1, mp1, nct, ncu, lls, nrt;
real emm1, smm1;
integer kase, jobu, iter;
real test;
integer nctp1, nrtp1;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
real scale;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
real shift;
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
integer maxit;
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *), csrot_(integer *, complex *,
integer *, complex *, integer *, real *, real *);
logical wantu, wantv;
extern /* Subroutine */ int srotg_(real *, real *, real *, real *);
real ztest;
extern doublereal scnrm2_(integer *, complex *, integer *);
/*< integer ldx,n,p,ldu,ldv,job,info >*/
/*< complex x(ldx,1),s(1),e(1),u(ldu,1),v(ldv,1),work(1) >*/
/* csvdc is a subroutine to reduce a complex nxp matrix x by */
/* unitary transformations u and v to diagonal form. the */
/* diagonal elements s(i) are the singular values of x. the */
/* columns of u are the corresponding left singular vectors, */
/* and the columns of v the right singular vectors. */
/* on entry */
/* x complex(ldx,p), where ldx.ge.n. */
/* x contains the matrix whose singular value */
/* decomposition is to be computed. x is */
/* destroyed by csvdc. */
/* ldx integer. */
/* ldx is the leading dimension of the array x. */
/* n integer. */
/* n is the number of rows of the matrix x. */
/* p integer. */
/* p is the number of columns of the matrix x. */
/* ldu integer. */
/* ldu is the leading dimension of the array u */
/* (see below). */
/* ldv integer. */
/* ldv is the leading dimension of the array v */
/* (see below). */
/* work complex(n). */
/* work is a scratch array. */
/* job integer. */
/* job controls the computation of the singular */
/* vectors. it has the decimal expansion ab */
/* with the following meaning */
/* a.eq.0 do not compute the left singular */
/* vectors. */
/* a.eq.1 return the n left singular vectors */
/* in u. */
/* a.ge.2 returns the first min(n,p) */
/* left singular vectors in u. */
/* b.eq.0 do not compute the right singular */
/* vectors. */
/* b.eq.1 return the right singular vectors */
/* in v. */
/* on return */
/* s complex(mm), where mm=min(n+1,p). */
/* the first min(n,p) entries of s contain the */
/* singular values of x arranged in descending */
/* order of magnitude. */
/* e complex(p). */
/* e ordinarily contains zeros. however see the */
/* discussion of info for exceptions. */
/* u complex(ldu,k), where ldu.ge.n. if joba.eq.1 then */
/* k.eq.n, if joba.ge.2 then */
/* k.eq.min(n,p). */
/* u contains the matrix of left singular vectors. */
/* u is not referenced if joba.eq.0. if n.le.p */
/* or if joba.gt.2, then u may be identified with x */
/* in the subroutine call. */
/* v complex(ldv,p), where ldv.ge.p. */
/* v contains the matrix of right singular vectors. */
/* v is not referenced if jobb.eq.0. if p.le.n, */
/* then v may be identified whth x in the */
/* subroutine call. */
/* info integer. */
/* the singular values (and their corresponding */
/* singular vectors) s(info+1),s(info+2),...,s(m) */
/* are correct (here m=min(n,p)). thus if */
/* info.eq.0, all the singular values and their */
/* vectors are correct. in any event, the matrix */
/* b = ctrans(u)*x*v is the bidiagonal matrix */
/* with the elements of s on its diagonal and the */
/* elements of e on its super-diagonal (ctrans(u) */
/* is the conjugate-transpose of u). thus the */
/* singular values of x and b are the same. */
/* linpack. this version dated 03/19/79 . */
/* correction to shift calculation made 2/85. */
/* g.w. stewart, university of maryland, argonne national lab. */
/* csvdc uses the following functions and subprograms. */
/* external csrot */
/* blas caxpy,cdotc,cscal,cswap,scnrm2,srotg */
/* fortran abs,aimag,amax1,cabs,cmplx */
/* fortran conjg,max0,min0,mod,real,sqrt */
/* internal variables */
/*< >*/
/*< complex cdotc,t,r >*/
/*< >*/
/*< logical wantu,wantv >*/
/*< complex csign,zdum,zdum1,zdum2 >*/
/*< real cabs1 >*/
/*< cabs1(zdum) = abs(real(zdum)) + abs(aimag(zdum)) >*/
/*< csign(zdum1,zdum2) = cabs(zdum1)*(zdum2/cabs(zdum2)) >*/
/* set the maximum number of iterations. */
/*< maxit = 1000 >*/
/* Parameter adjustments */
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--s;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--work;
/* Function Body */
maxit = 1000;
/* determine what is to be computed. */
/*< wantu = .false. >*/
wantu = FALSE_;
/*< wantv = .false. >*/
wantv = FALSE_;
/*< jobu = mod(job,100)/10 >*/
jobu = *job % 100 / 10;
/*< ncu = n >*/
ncu = *n;
/*< if (jobu .gt. 1) ncu = min0(n,p) >*/
if (jobu > 1) {
ncu = min(*n,*p);
}
/*< if (jobu .ne. 0) wantu = .true. >*/
if (jobu != 0) {
wantu = TRUE_;
}
/*< if (mod(job,10) .ne. 0) wantv = .true. >*/
if (*job % 10 != 0) {
wantv = TRUE_;
}
/* reduce x to bidiagonal form, storing the diagonal elements */
/* in s and the super-diagonal elements in e. */
/*< info = 0 >*/
*info = 0;
/*< nct = min0(n-1,p) >*/
/* Computing MIN */
i__1 = *n - 1;
nct = min(i__1,*p);
/*< nrt = max0(0,min0(p-2,n)) >*/
/* Computing MAX */
/* Computing MIN */
i__3 = *p - 2;
i__1 = 0, i__2 = min(i__3,*n);
nrt = max(i__1,i__2);
/*< lu = max0(nct,nrt) >*/
lu = max(nct,nrt);
/*< if (lu .lt. 1) go to 170 >*/
if (lu < 1) {
goto L170;
}
/*< do 160 l = 1, lu >*/
i__1 = lu;
for (l = 1; l <= i__1; ++l) {
/*< lp1 = l + 1 >*/
lp1 = l + 1;
/*< if (l .gt. nct) go to 20 >*/
if (l > nct) {
goto L20;
}
/* compute the transformation for the l-th column and */
/* place the l-th diagonal in s(l). */
/*< s(l) = cmplx(scnrm2(n-l+1,x(l,l),1),0.0e0) >*/
i__2 = l;
i__3 = *n - l + 1;
r__1 = scnrm2_(&i__3, &x[l + l * x_dim1], &c__1);
q__1.r = r__1, q__1.i = (float)0.;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< if (cabs1(s(l)) .eq. 0.0e0) go to 10 >*/
i__2 = l;
if ((r__1 = s[i__2].r, dabs(r__1)) + (r__2 = r_imag(&s[l]), dabs(r__2)
) == (float)0.) {
goto L10;
}
/*< if (cabs1(x(l,l)) .ne. 0.0e0) s(l) = csign(s(l),x(l,l)) >*/
i__2 = l + l * x_dim1;
if ((r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x[l + l * x_dim1]
), dabs(r__2)) != (float)0.) {
i__3 = l;
r__3 = c_abs(&s[l]);
i__4 = l + l * x_dim1;
r__4 = c_abs(&x[l + l * x_dim1]);
q__2.r = x[i__4].r / r__4, q__2.i = x[i__4].i / r__4;
q__1.r = r__3 * q__2.r, q__1.i = r__3 * q__2.i;
s[i__3].r = q__1.r, s[i__3].i = q__1.i;
}
/*< call cscal(n-l+1,1.0e0/s(l),x(l,l),1) >*/
i__2 = *n - l + 1;
c_div(&q__1, &c_b8, &s[l]);
cscal_(&i__2, &q__1, &x[l + l * x_dim1], &c__1);
/*< x(l,l) = (1.0e0,0.0e0) + x(l,l) >*/
i__2 = l + l * x_dim1;
i__3 = l + l * x_dim1;
q__1.r = x[i__3].r + (float)1., q__1.i = x[i__3].i + (float)0.;
x[i__2].r = q__1.r, x[i__2].i = q__1.i;
/*< 10 continue >*/
L10:
/*< s(l) = -s(l) >*/
i__2 = l;
i__3 = l;
q__1.r = -s[i__3].r, q__1.i = -s[i__3].i;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< 20 continue >*/
L20:
/*< if (p .lt. lp1) go to 50 >*/
if (*p < lp1) {
goto L50;
}
/*< do 40 j = lp1, p >*/
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
/*< if (l .gt. nct) go to 30 >*/
if (l > nct) {
goto L30;
}
/*< if (cabs1(s(l)) .eq. 0.0e0) go to 30 >*/
i__3 = l;
if ((r__1 = s[i__3].r, dabs(r__1)) + (r__2 = r_imag(&s[l]), dabs(
r__2)) == (float)0.) {
goto L30;
}
/* apply the transformation. */
/*< t = -cdotc(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) >*/
i__3 = *n - l + 1;
cdotc_(&q__3, &i__3, &x[l + l * x_dim1], &c__1, &x[l + j * x_dim1]
, &c__1);
q__2.r = -q__3.r, q__2.i = -q__3.i;
c_div(&q__1, &q__2, &x[l + l * x_dim1]);
t.r = q__1.r, t.i = q__1.i;
/*< call caxpy(n-l+1,t,x(l,l),1,x(l,j),1) >*/
i__3 = *n - l + 1;
caxpy_(&i__3, &t, &x[l + l * x_dim1], &c__1, &x[l + j * x_dim1], &
c__1);
/*< 30 continue >*/
L30:
/* place the l-th row of x into e for the */
/* subsequent calculation of the row transformation. */
/*< e(j) = conjg(x(l,j)) >*/
i__3 = j;
r_cnjg(&q__1, &x[l + j * x_dim1]);
e[i__3].r = q__1.r, e[i__3].i = q__1.i;
/*< 40 continue >*/
/* L40: */
}
/*< 50 continue >*/
L50:
/*< if (.not.wantu .or. l .gt. nct) go to 70 >*/
if (! wantu || l > nct) {
goto L70;
}
/* place the transformation in u for subsequent back */
/* multiplication. */
/*< do 60 i = l, n >*/
i__2 = *n;
for (i__ = l; i__ <= i__2; ++i__) {
/*< u(i,l) = x(i,l) >*/
i__3 = i__ + l * u_dim1;
i__4 = i__ + l * x_dim1;
u[i__3].r = x[i__4].r, u[i__3].i = x[i__4].i;
/*< 60 continue >*/
/* L60: */
}
/*< 70 continue >*/
L70:
/*< if (l .gt. nrt) go to 150 >*/
if (l > nrt) {
goto L150;
}
/* compute the l-th row transformation and place the */
/* l-th super-diagonal in e(l). */
/*< e(l) = cmplx(scnrm2(p-l,e(lp1),1),0.0e0) >*/
i__2 = l;
i__3 = *p - l;
r__1 = scnrm2_(&i__3, &e[lp1], &c__1);
q__1.r = r__1, q__1.i = (float)0.;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< if (cabs1(e(l)) .eq. 0.0e0) go to 80 >*/
i__2 = l;
if ((r__1 = e[i__2].r, dabs(r__1)) + (r__2 = r_imag(&e[l]), dabs(r__2)
) == (float)0.) {
goto L80;
}
/*< if (cabs1(e(lp1)) .ne. 0.0e0) e(l) = csign(e(l),e(lp1)) >*/
i__2 = lp1;
if ((r__1 = e[i__2].r, dabs(r__1)) + (r__2 = r_imag(&e[lp1]), dabs(
r__2)) != (float)0.) {
i__3 = l;
r__3 = c_abs(&e[l]);
i__4 = lp1;
r__4 = c_abs(&e[lp1]);
q__2.r = e[i__4].r / r__4, q__2.i = e[i__4].i / r__4;
q__1.r = r__3 * q__2.r, q__1.i = r__3 * q__2.i;
e[i__3].r = q__1.r, e[i__3].i = q__1.i;
}
/*< call cscal(p-l,1.0e0/e(l),e(lp1),1) >*/
i__2 = *p - l;
c_div(&q__1, &c_b8, &e[l]);
cscal_(&i__2, &q__1, &e[lp1], &c__1);
/*< e(lp1) = (1.0e0,0.0e0) + e(lp1) >*/
i__2 = lp1;
i__3 = lp1;
q__1.r = e[i__3].r + (float)1., q__1.i = e[i__3].i + (float)0.;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< 80 continue >*/
L80:
/*< e(l) = -conjg(e(l)) >*/
i__2 = l;
r_cnjg(&q__2, &e[l]);
q__1.r = -q__2.r, q__1.i = -q__2.i;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< if (lp1 .gt. n .or. cabs1(e(l)) .eq. 0.0e0) go to 120 >*/
i__2 = l;
if (lp1 > *n || (r__1 = e[i__2].r, dabs(r__1)) + (r__2 = r_imag(&e[l])
, dabs(r__2)) == (float)0.) {
goto L120;
}
/* apply the transformation. */
/*< do 90 i = lp1, n >*/
i__2 = *n;
for (i__ = lp1; i__ <= i__2; ++i__) {
/*< work(i) = (0.0e0,0.0e0) >*/
i__3 = i__;
work[i__3].r = (float)0., work[i__3].i = (float)0.;
/*< 90 continue >*/
/* L90: */
}
/*< do 100 j = lp1, p >*/
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
/*< call caxpy(n-l,e(j),x(lp1,j),1,work(lp1),1) >*/
i__3 = *n - l;
caxpy_(&i__3, &e[j], &x[lp1 + j * x_dim1], &c__1, &work[lp1], &
c__1);
/*< 100 continue >*/
/* L100: */
}
/*< do 110 j = lp1, p >*/
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
/*< >*/
i__3 = *n - l;
i__4 = j;
q__3.r = -e[i__4].r, q__3.i = -e[i__4].i;
c_div(&q__2, &q__3, &e[lp1]);
r_cnjg(&q__1, &q__2);
caxpy_(&i__3, &q__1, &work[lp1], &c__1, &x[lp1 + j * x_dim1], &
c__1);
/*< 110 continue >*/
/* L110: */
}
/*< 120 continue >*/
L120:
/*< if (.not.wantv) go to 140 >*/
if (! wantv) {
goto L140;
}
/* place the transformation in v for subsequent */
/* back multiplication. */
/*< do 130 i = lp1, p >*/
i__2 = *p;
for (i__ = lp1; i__ <= i__2; ++i__) {
/*< v(i,l) = e(i) >*/
i__3 = i__ + l * v_dim1;
i__4 = i__;
v[i__3].r = e[i__4].r, v[i__3].i = e[i__4].i;
/*< 130 continue >*/
/* L130: */
}
/*< 140 continue >*/
L140:
/*< 150 continue >*/
L150:
/*< 160 continue >*/
/* L160: */
;
}
/*< 170 continue >*/
L170:
/* set up the final bidiagonal matrix or order m. */
/*< m = min0(p,n+1) >*/
/* Computing MIN */
i__1 = *p, i__2 = *n + 1;
m = min(i__1,i__2);
/*< nctp1 = nct + 1 >*/
nctp1 = nct + 1;
/*< nrtp1 = nrt + 1 >*/
nrtp1 = nrt + 1;
/*< if (nct .lt. p) s(nctp1) = x(nctp1,nctp1) >*/
if (nct < *p) {
i__1 = nctp1;
i__2 = nctp1 + nctp1 * x_dim1;
s[i__1].r = x[i__2].r, s[i__1].i = x[i__2].i;
}
/*< if (n .lt. m) s(m) = (0.0e0,0.0e0) >*/
if (*n < m) {
i__1 = m;
s[i__1].r = (float)0., s[i__1].i = (float)0.;
}
/*< if (nrtp1 .lt. m) e(nrtp1) = x(nrtp1,m) >*/
if (nrtp1 < m) {
i__1 = nrtp1;
i__2 = nrtp1 + m * x_dim1;
e[i__1].r = x[i__2].r, e[i__1].i = x[i__2].i;
}
/*< e(m) = (0.0e0,0.0e0) >*/
i__1 = m;
e[i__1].r = (float)0., e[i__1].i = (float)0.;
/* if required, generate u. */
/*< if (.not.wantu) go to 300 >*/
if (! wantu) {
goto L300;
}
/*< if (ncu .lt. nctp1) go to 200 >*/
if (ncu < nctp1) {
goto L200;
}
/*< do 190 j = nctp1, ncu >*/
i__1 = ncu;
for (j = nctp1; j <= i__1; ++j) {
/*< do 180 i = 1, n >*/
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< u(i,j) = (0.0e0,0.0e0) >*/
i__3 = i__ + j * u_dim1;
u[i__3].r = (float)0., u[i__3].i = (float)0.;
/*< 180 continue >*/
/* L180: */
}
/*< u(j,j) = (1.0e0,0.0e0) >*/
i__2 = j + j * u_dim1;
u[i__2].r = (float)1., u[i__2].i = (float)0.;
/*< 190 continue >*/
/* L190: */
}
/*< 200 continue >*/
L200:
/*< if (nct .lt. 1) go to 290 >*/
if (nct < 1) {
goto L290;
}
/*< do 280 ll = 1, nct >*/
i__1 = nct;
for (ll = 1; ll <= i__1; ++ll) {
/*< l = nct - ll + 1 >*/
l = nct - ll + 1;
/*< if (cabs1(s(l)) .eq. 0.0e0) go to 250 >*/
i__2 = l;
if ((r__1 = s[i__2].r, dabs(r__1)) + (r__2 = r_imag(&s[l]), dabs(r__2)
) == (float)0.) {
goto L250;
}
/*< lp1 = l + 1 >*/
lp1 = l + 1;
/*< if (ncu .lt. lp1) go to 220 >*/
if (ncu < lp1) {
goto L220;
}
/*< do 210 j = lp1, ncu >*/
i__2 = ncu;
for (j = lp1; j <= i__2; ++j) {
/*< t = -cdotc(n-l+1,u(l,l),1,u(l,j),1)/u(l,l) >*/
i__3 = *n - l + 1;
cdotc_(&q__3, &i__3, &u[l + l * u_dim1], &c__1, &u[l + j * u_dim1]
, &c__1);
q__2.r = -q__3.r, q__2.i = -q__3.i;
c_div(&q__1, &q__2, &u[l + l * u_dim1]);
t.r = q__1.r, t.i = q__1.i;
/*< call caxpy(n-l+1,t,u(l,l),1,u(l,j),1) >*/
i__3 = *n - l + 1;
caxpy_(&i__3, &t, &u[l + l * u_dim1], &c__1, &u[l + j * u_dim1], &
c__1);
/*< 210 continue >*/
/* L210: */
}
/*< 220 continue >*/
L220:
/*< call cscal(n-l+1,(-1.0e0,0.0e0),u(l,l),1) >*/
i__2 = *n - l + 1;
cscal_(&i__2, &c_b53, &u[l + l * u_dim1], &c__1);
/*< u(l,l) = (1.0e0,0.0e0) + u(l,l) >*/
i__2 = l + l * u_dim1;
i__3 = l + l * u_dim1;
q__1.r = u[i__3].r + (float)1., q__1.i = u[i__3].i + (float)0.;
u[i__2].r = q__1.r, u[i__2].i = q__1.i;
/*< lm1 = l - 1 >*/
lm1 = l - 1;
/*< if (lm1 .lt. 1) go to 240 >*/
if (lm1 < 1) {
goto L240;
}
/*< do 230 i = 1, lm1 >*/
i__2 = lm1;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< u(i,l) = (0.0e0,0.0e0) >*/
i__3 = i__ + l * u_dim1;
u[i__3].r = (float)0., u[i__3].i = (float)0.;
/*< 230 continue >*/
/* L230: */
}
/*< 240 continue >*/
L240:
/*< go to 270 >*/
goto L270;
/*< 250 continue >*/
L250:
/*< do 260 i = 1, n >*/
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< u(i,l) = (0.0e0,0.0e0) >*/
i__3 = i__ + l * u_dim1;
u[i__3].r = (float)0., u[i__3].i = (float)0.;
/*< 260 continue >*/
/* L260: */
}
/*< u(l,l) = (1.0e0,0.0e0) >*/
i__2 = l + l * u_dim1;
u[i__2].r = (float)1., u[i__2].i = (float)0.;
/*< 270 continue >*/
L270:
/*< 280 continue >*/
/* L280: */
;
}
/*< 290 continue >*/
L290:
/*< 300 continue >*/
L300:
/* if it is required, generate v. */
/*< if (.not.wantv) go to 350 >*/
if (! wantv) {
goto L350;
}
/*< do 340 ll = 1, p >*/
i__1 = *p;
for (ll = 1; ll <= i__1; ++ll) {
/*< l = p - ll + 1 >*/
l = *p - ll + 1;
/*< lp1 = l + 1 >*/
lp1 = l + 1;
/*< if (l .gt. nrt) go to 320 >*/
if (l > nrt) {
goto L320;
}
/*< if (cabs1(e(l)) .eq. 0.0e0) go to 320 >*/
i__2 = l;
if ((r__1 = e[i__2].r, dabs(r__1)) + (r__2 = r_imag(&e[l]), dabs(r__2)
) == (float)0.) {
goto L320;
}
/*< do 310 j = lp1, p >*/
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
/*< t = -cdotc(p-l,v(lp1,l),1,v(lp1,j),1)/v(lp1,l) >*/
i__3 = *p - l;
cdotc_(&q__3, &i__3, &v[lp1 + l * v_dim1], &c__1, &v[lp1 + j *
v_dim1], &c__1);
q__2.r = -q__3.r, q__2.i = -q__3.i;
c_div(&q__1, &q__2, &v[lp1 + l * v_dim1]);
t.r = q__1.r, t.i = q__1.i;
/*< call caxpy(p-l,t,v(lp1,l),1,v(lp1,j),1) >*/
i__3 = *p - l;
caxpy_(&i__3, &t, &v[lp1 + l * v_dim1], &c__1, &v[lp1 + j *
v_dim1], &c__1);
/*< 310 continue >*/
/* L310: */
}
/*< 320 continue >*/
L320:
/*< do 330 i = 1, p >*/
i__2 = *p;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< v(i,l) = (0.0e0,0.0e0) >*/
i__3 = i__ + l * v_dim1;
v[i__3].r = (float)0., v[i__3].i = (float)0.;
/*< 330 continue >*/
/* L330: */
}
/*< v(l,l) = (1.0e0,0.0e0) >*/
i__2 = l + l * v_dim1;
v[i__2].r = (float)1., v[i__2].i = (float)0.;
/*< 340 continue >*/
/* L340: */
}
/*< 350 continue >*/
L350:
/* transform s and e so that they are real. */
/*< do 380 i = 1, m >*/
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< if (cabs1(s(i)) .eq. 0.0e0) go to 360 >*/
i__2 = i__;
if ((r__1 = s[i__2].r, dabs(r__1)) + (r__2 = r_imag(&s[i__]), dabs(
r__2)) == (float)0.) {
goto L360;
}
/*< t = cmplx(cabs(s(i)),0.0e0) >*/
r__1 = c_abs(&s[i__]);
q__1.r = r__1, q__1.i = (float)0.;
t.r = q__1.r, t.i = q__1.i;
/*< r = s(i)/t >*/
c_div(&q__1, &s[i__], &t);
r__.r = q__1.r, r__.i = q__1.i;
/*< s(i) = t >*/
i__2 = i__;
s[i__2].r = t.r, s[i__2].i = t.i;
/*< if (i .lt. m) e(i) = e(i)/r >*/
if (i__ < m) {
i__2 = i__;
c_div(&q__1, &e[i__], &r__);
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
}
/*< if (wantu) call cscal(n,r,u(1,i),1) >*/
if (wantu) {
cscal_(n, &r__, &u[i__ * u_dim1 + 1], &c__1);
}
/*< 360 continue >*/
L360:
/* ...exit */
/*< if (i .eq. m) go to 390 >*/
if (i__ == m) {
goto L390;
}
/*< if (cabs1(e(i)) .eq. 0.0e0) go to 370 >*/
i__2 = i__;
if ((r__1 = e[i__2].r, dabs(r__1)) + (r__2 = r_imag(&e[i__]), dabs(
r__2)) == (float)0.) {
goto L370;
}
/*< t = cmplx(cabs(e(i)),0.0e0) >*/
r__1 = c_abs(&e[i__]);
q__1.r = r__1, q__1.i = (float)0.;
t.r = q__1.r, t.i = q__1.i;
/*< r = t/e(i) >*/
c_div(&q__1, &t, &e[i__]);
r__.r = q__1.r, r__.i = q__1.i;
/*< e(i) = t >*/
i__2 = i__;
e[i__2].r = t.r, e[i__2].i = t.i;
/*< s(i+1) = s(i+1)*r >*/
i__2 = i__ + 1;
i__3 = i__ + 1;
q__1.r = s[i__3].r * r__.r - s[i__3].i * r__.i, q__1.i = s[i__3].r *
r__.i + s[i__3].i * r__.r;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< if (wantv) call cscal(p,r,v(1,i+1),1) >*/
if (wantv) {
cscal_(p, &r__, &v[(i__ + 1) * v_dim1 + 1], &c__1);
}
/*< 370 continue >*/
L370:
/*< 380 continue >*/
/* L380: */
;
}
/*< 390 continue >*/
L390:
/* main iteration loop for the singular values. */
/*< mm = m >*/
mm = m;
/*< iter = 0 >*/
iter = 0;
/*< 400 continue >*/
L400:
/* quit if all the singular values have been found. */
/* ...exit */
/*< if (m .eq. 0) go to 660 >*/
if (m == 0) {
goto L660;
}
/* if too many iterations have been performed, set */
/* flag and return. */
/*< if (iter .lt. maxit) go to 410 >*/
if (iter < maxit) {
goto L410;
}
/*< info = m >*/
*info = m;
/* ......exit */
/*< go to 660 >*/
goto L660;
/*< 410 continue >*/
L410:
/* this section of the program inspects for */
/* negligible elements in the s and e arrays. on */
/* completion the variables kase and l are set as follows. */
/* kase = 1 if s(m) and e(l-1) are negligible and l.lt.m */
/* kase = 2 if s(l) is negligible and l.lt.m */
/* kase = 3 if e(l-1) is negligible, l.lt.m, and */
/* s(l), ..., s(m) are not negligible (qr step). */
/* kase = 4 if e(m-1) is negligible (convergence). */
/*< do 430 ll = 1, m >*/
i__1 = m;
for (ll = 1; ll <= i__1; ++ll) {
/*< l = m - ll >*/
l = m - ll;
/* ...exit */
/*< if (l .eq. 0) go to 440 >*/
if (l == 0) {
goto L440;
}
/*< test = cabs(s(l)) + cabs(s(l+1)) >*/
test = c_abs(&s[l]) + c_abs(&s[l + 1]);
/*< ztest = test + cabs(e(l)) >*/
ztest = test + c_abs(&e[l]);
/*< if (ztest .ne. test) go to 420 >*/
if (ztest != test) {
goto L420;
}
/*< e(l) = (0.0e0,0.0e0) >*/
i__2 = l;
e[i__2].r = (float)0., e[i__2].i = (float)0.;
/* ......exit */
/*< go to 440 >*/
goto L440;
/*< 420 continue >*/
L420:
/*< 430 continue >*/
/* L430: */
;
}
/*< 440 continue >*/
L440:
/*< if (l .ne. m - 1) go to 450 >*/
if (l != m - 1) {
goto L450;
}
/*< kase = 4 >*/
kase = 4;
/*< go to 520 >*/
goto L520;
/*< 450 continue >*/
L450:
/*< lp1 = l + 1 >*/
lp1 = l + 1;
/*< mp1 = m + 1 >*/
mp1 = m + 1;
/*< do 470 lls = lp1, mp1 >*/
i__1 = mp1;
for (lls = lp1; lls <= i__1; ++lls) {
/*< ls = m - lls + lp1 >*/
ls = m - lls + lp1;
/* ...exit */
/*< if (ls .eq. l) go to 480 >*/
if (ls == l) {
goto L480;
}
/*< test = 0.0e0 >*/
test = (float)0.;
/*< if (ls .ne. m) test = test + cabs(e(ls)) >*/
if (ls != m) {
test += c_abs(&e[ls]);
}
/*< if (ls .ne. l + 1) test = test + cabs(e(ls-1)) >*/
if (ls != l + 1) {
test += c_abs(&e[ls - 1]);
}
/*< ztest = test + cabs(s(ls)) >*/
ztest = test + c_abs(&s[ls]);
/*< if (ztest .ne. test) go to 460 >*/
if (ztest != test) {
goto L460;
}
/*< s(ls) = (0.0e0,0.0e0) >*/
i__2 = ls;
s[i__2].r = (float)0., s[i__2].i = (float)0.;
/* ......exit */
/*< go to 480 >*/
goto L480;
/*< 460 continue >*/
L460:
/*< 470 continue >*/
/* L470: */
;
}
/*< 480 continue >*/
L480:
/*< if (ls .ne. l) go to 490 >*/
if (ls != l) {
goto L490;
}
/*< kase = 3 >*/
kase = 3;
/*< go to 510 >*/
goto L510;
/*< 490 continue >*/
L490:
/*< if (ls .ne. m) go to 500 >*/
if (ls != m) {
goto L500;
}
/*< kase = 1 >*/
kase = 1;
/*< go to 510 >*/
goto L510;
/*< 500 continue >*/
L500:
/*< kase = 2 >*/
kase = 2;
/*< l = ls >*/
l = ls;
/*< 510 continue >*/
L510:
/*< 520 continue >*/
L520:
/*< l = l + 1 >*/
++l;
/* perform the task indicated by kase. */
/*< go to (530, 560, 580, 610), kase >*/
switch (kase) {
case 1: goto L530;
case 2: goto L560;
case 3: goto L580;
case 4: goto L610;
}
/* deflate negligible s(m). */
/*< 530 continue >*/
L530:
/*< mm1 = m - 1 >*/
mm1 = m - 1;
/*< f = real(e(m-1)) >*/
i__1 = m - 1;
f = e[i__1].r;
/*< e(m-1) = (0.0e0,0.0e0) >*/
i__1 = m - 1;
e[i__1].r = (float)0., e[i__1].i = (float)0.;
/*< do 550 kk = l, mm1 >*/
i__1 = mm1;
for (kk = l; kk <= i__1; ++kk) {
/*< k = mm1 - kk + l >*/
k = mm1 - kk + l;
/*< t1 = real(s(k)) >*/
i__2 = k;
t1 = s[i__2].r;
/*< call srotg(t1,f,cs,sn) >*/
srotg_(&t1, &f, &cs, &sn);
/*< s(k) = cmplx(t1,0.0e0) >*/
i__2 = k;
q__1.r = t1, q__1.i = (float)0.;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< if (k .eq. l) go to 540 >*/
if (k == l) {
goto L540;
}
/*< f = -sn*real(e(k-1)) >*/
i__2 = k - 1;
f = -sn * e[i__2].r;
/*< e(k-1) = cs*e(k-1) >*/
i__2 = k - 1;
i__3 = k - 1;
q__1.r = cs * e[i__3].r, q__1.i = cs * e[i__3].i;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< 540 continue >*/
L540:
/*< if (wantv) call csrot(p,v(1,k),1,v(1,m),1,cs,sn) >*/
if (wantv) {
csrot_(p, &v[k * v_dim1 + 1], &c__1, &v[m * v_dim1 + 1], &c__1, &
cs, &sn);
}
/*< 550 continue >*/
/* L550: */
}
/*< go to 650 >*/
goto L650;
/* split at negligible s(l). */
/*< 560 continue >*/
L560:
/*< f = real(e(l-1)) >*/
i__1 = l - 1;
f = e[i__1].r;
/*< e(l-1) = (0.0e0,0.0e0) >*/
i__1 = l - 1;
e[i__1].r = (float)0., e[i__1].i = (float)0.;
/*< do 570 k = l, m >*/
i__1 = m;
for (k = l; k <= i__1; ++k) {
/*< t1 = real(s(k)) >*/
i__2 = k;
t1 = s[i__2].r;
/*< call srotg(t1,f,cs,sn) >*/
srotg_(&t1, &f, &cs, &sn);
/*< s(k) = cmplx(t1,0.0e0) >*/
i__2 = k;
q__1.r = t1, q__1.i = (float)0.;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< f = -sn*real(e(k)) >*/
i__2 = k;
f = -sn * e[i__2].r;
/*< e(k) = cs*e(k) >*/
i__2 = k;
i__3 = k;
q__1.r = cs * e[i__3].r, q__1.i = cs * e[i__3].i;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< if (wantu) call csrot(n,u(1,k),1,u(1,l-1),1,cs,sn) >*/
if (wantu) {
csrot_(n, &u[k * u_dim1 + 1], &c__1, &u[(l - 1) * u_dim1 + 1], &
c__1, &cs, &sn);
}
/*< 570 continue >*/
/* L570: */
}
/*< go to 650 >*/
goto L650;
/* perform one qr step. */
/*< 580 continue >*/
L580:
/* calculate the shift. */
/*< >*/
/* Computing MAX */
r__1 = c_abs(&s[m]), r__2 = c_abs(&s[m - 1]), r__1 = max(r__1,r__2), r__2
= c_abs(&e[m - 1]), r__1 = max(r__1,r__2), r__2 = c_abs(&s[l]),
r__1 = max(r__1,r__2), r__2 = c_abs(&e[l]);
scale = dmax(r__1,r__2);
/*< sm = real(s(m))/scale >*/
i__1 = m;
sm = s[i__1].r / scale;
/*< smm1 = real(s(m-1))/scale >*/
i__1 = m - 1;
smm1 = s[i__1].r / scale;
/*< emm1 = real(e(m-1))/scale >*/
i__1 = m - 1;
emm1 = e[i__1].r / scale;
/*< sl = real(s(l))/scale >*/
i__1 = l;
sl = s[i__1].r / scale;
/*< el = real(e(l))/scale >*/
i__1 = l;
el = e[i__1].r / scale;
/*< b = ((smm1 + sm)*(smm1 - sm) + emm1**2)/2.0e0 >*/
/* Computing 2nd power */
r__1 = emm1;
b = ((smm1 + sm) * (smm1 - sm) + r__1 * r__1) / (float)2.;
/*< c = (sm*emm1)**2 >*/
/* Computing 2nd power */
r__1 = sm * emm1;
c__ = r__1 * r__1;
/*< shift = 0.0e0 >*/
shift = (float)0.;
/*< if (b .eq. 0.0e0 .and. c .eq. 0.0e0) go to 590 >*/
if (b == (float)0. && c__ == (float)0.) {
goto L590;
}
/*< shift = sqrt(b**2+c) >*/
/* Computing 2nd power */
r__1 = b;
shift = sqrt(r__1 * r__1 + c__);
/*< if (b .lt. 0.0e0) shift = -shift >*/
if (b < (float)0.) {
shift = -shift;
}
/*< shift = c/(b + shift) >*/
shift = c__ / (b + shift);
/*< 590 continue >*/
L590:
/*< f = (sl + sm)*(sl - sm) + shift >*/
f = (sl + sm) * (sl - sm) + shift;
/*< g = sl*el >*/
g = sl * el;
/* chase zeros. */
/*< mm1 = m - 1 >*/
mm1 = m - 1;
/*< do 600 k = l, mm1 >*/
i__1 = mm1;
for (k = l; k <= i__1; ++k) {
/*< call srotg(f,g,cs,sn) >*/
srotg_(&f, &g, &cs, &sn);
/*< if (k .ne. l) e(k-1) = cmplx(f,0.0e0) >*/
if (k != l) {
i__2 = k - 1;
q__1.r = f, q__1.i = (float)0.;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
}
/*< f = cs*real(s(k)) + sn*real(e(k)) >*/
i__2 = k;
i__3 = k;
f = cs * s[i__2].r + sn * e[i__3].r;
/*< e(k) = cs*e(k) - sn*s(k) >*/
i__2 = k;
i__3 = k;
q__2.r = cs * e[i__3].r, q__2.i = cs * e[i__3].i;
i__4 = k;
q__3.r = sn * s[i__4].r, q__3.i = sn * s[i__4].i;
q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< g = sn*real(s(k+1)) >*/
i__2 = k + 1;
g = sn * s[i__2].r;
/*< s(k+1) = cs*s(k+1) >*/
i__2 = k + 1;
i__3 = k + 1;
q__1.r = cs * s[i__3].r, q__1.i = cs * s[i__3].i;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< if (wantv) call csrot(p,v(1,k),1,v(1,k+1),1,cs,sn) >*/
if (wantv) {
csrot_(p, &v[k * v_dim1 + 1], &c__1, &v[(k + 1) * v_dim1 + 1], &
c__1, &cs, &sn);
}
/*< call srotg(f,g,cs,sn) >*/
srotg_(&f, &g, &cs, &sn);
/*< s(k) = cmplx(f,0.0e0) >*/
i__2 = k;
q__1.r = f, q__1.i = (float)0.;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< f = cs*real(e(k)) + sn*real(s(k+1)) >*/
i__2 = k;
i__3 = k + 1;
f = cs * e[i__2].r + sn * s[i__3].r;
/*< s(k+1) = -sn*e(k) + cs*s(k+1) >*/
i__2 = k + 1;
r__1 = -sn;
i__3 = k;
q__2.r = r__1 * e[i__3].r, q__2.i = r__1 * e[i__3].i;
i__4 = k + 1;
q__3.r = cs * s[i__4].r, q__3.i = cs * s[i__4].i;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< g = sn*real(e(k+1)) >*/
i__2 = k + 1;
g = sn * e[i__2].r;
/*< e(k+1) = cs*e(k+1) >*/
i__2 = k + 1;
i__3 = k + 1;
q__1.r = cs * e[i__3].r, q__1.i = cs * e[i__3].i;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< >*/
if (wantu && k < *n) {
csrot_(n, &u[k * u_dim1 + 1], &c__1, &u[(k + 1) * u_dim1 + 1], &
c__1, &cs, &sn);
}
/*< 600 continue >*/
/* L600: */
}
/*< e(m-1) = cmplx(f,0.0e0) >*/
i__1 = m - 1;
q__1.r = f, q__1.i = (float)0.;
e[i__1].r = q__1.r, e[i__1].i = q__1.i;
/*< iter = iter + 1 >*/
++iter;
/*< go to 650 >*/
goto L650;
/* convergence. */
/*< 610 continue >*/
L610:
/* make the singular value positive */
/*< if (real(s(l)) .ge. 0.0e0) go to 620 >*/
i__1 = l;
if (s[i__1].r >= (float)0.) {
goto L620;
}
/*< s(l) = -s(l) >*/
i__1 = l;
i__2 = l;
q__1.r = -s[i__2].r, q__1.i = -s[i__2].i;
s[i__1].r = q__1.r, s[i__1].i = q__1.i;
/*< if (wantv) call cscal(p,(-1.0e0,0.0e0),v(1,l),1) >*/
if (wantv) {
cscal_(p, &c_b53, &v[l * v_dim1 + 1], &c__1);
}
/*< 620 continue >*/
L620:
/* order the singular value. */
/*< 630 if (l .eq. mm) go to 640 >*/
L630:
if (l == mm) {
goto L640;
}
/* ...exit */
/*< if (real(s(l)) .ge. real(s(l+1))) go to 640 >*/
i__1 = l;
i__2 = l + 1;
if (s[i__1].r >= s[i__2].r) {
goto L640;
}
/*< t = s(l) >*/
i__1 = l;
t.r = s[i__1].r, t.i = s[i__1].i;
/*< s(l) = s(l+1) >*/
i__1 = l;
i__2 = l + 1;
s[i__1].r = s[i__2].r, s[i__1].i = s[i__2].i;
/*< s(l+1) = t >*/
i__1 = l + 1;
s[i__1].r = t.r, s[i__1].i = t.i;
/*< >*/
if (wantv && l < *p) {
cswap_(p, &v[l * v_dim1 + 1], &c__1, &v[(l + 1) * v_dim1 + 1], &c__1);
}
/*< >*/
if (wantu && l < *n) {
cswap_(n, &u[l * u_dim1 + 1], &c__1, &u[(l + 1) * u_dim1 + 1], &c__1);
}
/*< l = l + 1 >*/
++l;
/*< go to 630 >*/
goto L630;
/*< 640 continue >*/
L640:
/*< iter = 0 >*/
iter = 0;
/*< m = m - 1 >*/
--m;
/*< 650 continue >*/
L650:
/*< go to 400 >*/
goto L400;
/*< 660 continue >*/
L660:
/*< return >*/
return 0;
/*< end >*/
} /* csvdc_ */
void srotg(float *A, float *B, float *C, float *S)
{
srotg_(A, B, C, S);
}
GURLS_EXPORT void rotg(float *a, float *b, float *c, float *s)
{
srotg_(a, b, c, s);
}
/* Subroutine */ int check0_(real *sfac)
{
/* Initialized data */
static real ds1[8] = { .8f,.6f,.8f,-.6f,.8f,0.f,1.f,0.f };
static real datrue[8] = { .5f,.5f,.5f,-.5f,-.5f,0.f,1.f,1.f };
static real dbtrue[8] = { 0.f,.6f,0.f,-.6f,0.f,0.f,1.f,0.f };
static real da1[8] = { .3f,.4f,-.3f,-.4f,-.3f,0.f,0.f,1.f };
static real db1[8] = { .4f,.3f,.4f,.3f,-.4f,0.f,1.f,0.f };
static real dc1[8] = { .6f,.8f,-.6f,.8f,.6f,1.f,0.f,1.f };
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
integer k;
real sa, sb, sc, ss;
extern /* Subroutine */ int srotg_(real *, real *, real *, real *),
stest1_(real *, real *, real *, real *);
/* Fortran I/O blocks */
static cilist io___19 = { 0, 6, 0, 0, 0 };
/* .. Parameters .. */
/* .. Scalar Arguments .. */
/* .. Scalars in Common .. */
/* .. Local Scalars .. */
/* .. Local Arrays .. */
/* .. External Subroutines .. */
/* .. Common blocks .. */
/* .. Data statements .. */
/* .. Executable Statements .. */
/* Compute true values which cannot be prestored */
/* in decimal notation */
dbtrue[0] = 1.6666666666666667f;
dbtrue[2] = -1.6666666666666667f;
dbtrue[4] = 1.6666666666666667f;
for (k = 1; k <= 8; ++k) {
/* .. Set N=K for identification in output if any .. */
combla_1.n = k;
if (combla_1.icase == 3) {
/* .. SROTG .. */
if (k > 8) {
goto L40;
}
sa = da1[k - 1];
sb = db1[k - 1];
srotg_(&sa, &sb, &sc, &ss);
stest1_(&sa, &datrue[k - 1], &datrue[k - 1], sfac);
stest1_(&sb, &dbtrue[k - 1], &dbtrue[k - 1], sfac);
stest1_(&sc, &dc1[k - 1], &dc1[k - 1], sfac);
stest1_(&ss, &ds1[k - 1], &ds1[k - 1], sfac);
} else {
s_wsle(&io___19);
do_lio(&c__9, &c__1, " Shouldn't be here in CHECK0", (ftnlen)28);
e_wsle();
s_stop("", (ftnlen)0);
}
/* L20: */
}
L40:
return 0;
} /* check0_ */
void cblas_srotg( float *a, float *b, float *c, float *s)
{
srotg_(a,b,c,s);
}
/* Subroutine */ int slattp_(integer *imat, char *uplo, char *trans, char *
diag, integer *iseed, integer *n, real *a, real *b, real *work,
integer *info)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
doublereal d__1, d__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double pow_dd(doublereal *, doublereal *), sqrt(doublereal), r_sign(real *
, real *);
/* Local variables */
real c__;
integer i__, j;
real s, t, x, y, z__;
integer jc;
real ra;
integer jj;
real rb;
integer jl, kl, jr, ku, iy, jx;
real ulp, sfac;
integer mode;
char path[3], dist[1];
real unfl, rexp;
char type__[1];
real texp;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
real star1, plus1, plus2, bscal;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real tscal, anorm, bnorm, tleft, stemp;
logical upper;
extern /* Subroutine */ int srotg_(real *, real *, real *, real *),
slatb4_(char *, integer *, integer *, integer *, char *, integer *
, integer *, real *, integer *, real *, char *), slabad_(real *, real *);
extern doublereal slamch_(char *);
char packit[1];
real bignum;
extern integer isamax_(integer *, real *, integer *);
extern doublereal slarnd_(integer *, integer *);
real cndnum;
integer jcnext, jcount;
extern /* Subroutine */ int slatms_(integer *, integer *, char *, integer
*, char *, real *, integer *, real *, real *, integer *, integer *
, char *, real *, integer *, real *, integer *), slarnv_(integer *, integer *, integer *, real *);
real smlnum;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLATTP generates a triangular test matrix in packed storage. */
/* IMAT and UPLO uniquely specify the properties of the test */
/* matrix, which is returned in the array AP. */
/* Arguments */
/* ========= */
/* IMAT (input) INTEGER */
/* An integer key describing which matrix to generate for this */
/* path. */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A will be upper or lower */
/* triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies whether the matrix or its transpose will be used. */
/* = 'N': No transpose */
/* = 'T': Transpose */
/* = 'C': Conjugate transpose (= Transpose) */
/* DIAG (output) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* The seed vector for the random number generator (used in */
/* SLATMS). Modified on exit. */
/* N (input) INTEGER */
/* The order of the matrix to be generated. */
/* A (output) REAL array, dimension (N*(N+1)/2) */
/* The upper or lower triangular matrix A, packed columnwise in */
/* a linear array. The j-th column of A is stored in the array */
/* AP as follows: */
/* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', */
/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
/* B (output) REAL array, dimension (N) */
/* The right hand side vector, if IMAT > 10. */
/* WORK (workspace) REAL array, dimension (3*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--work;
--b;
--a;
--iseed;
/* Function Body */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "TP", (ftnlen)2, (ftnlen)2);
unfl = slamch_("Safe minimum");
ulp = slamch_("Epsilon") * slamch_("Base");
smlnum = unfl;
bignum = (1.f - ulp) / smlnum;
slabad_(&smlnum, &bignum);
if (*imat >= 7 && *imat <= 10 || *imat == 18) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
*info = 0;
/* Quick return if N.LE.0. */
if (*n <= 0) {
return 0;
}
/* Call SLATB4 to set parameters for SLATMS. */
upper = lsame_(uplo, "U");
if (upper) {
slatb4_(path, imat, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
dist);
*(unsigned char *)packit = 'C';
} else {
i__1 = -(*imat);
slatb4_(path, &i__1, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
dist);
*(unsigned char *)packit = 'R';
}
/* IMAT <= 6: Non-unit triangular matrix */
if (*imat <= 6) {
slatms_(n, n, dist, &iseed[1], type__, &b[1], &mode, &cndnum, &anorm,
&kl, &ku, packit, &a[1], n, &work[1], info);
/* IMAT > 6: Unit triangular matrix */
/* The diagonal is deliberately set to something other than 1. */
/* IMAT = 7: Matrix is the identity */
} else if (*imat == 7) {
if (upper) {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
a[jc + i__ - 1] = 0.f;
/* L10: */
}
a[jc + j - 1] = (real) j;
jc += j;
/* L20: */
}
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
a[jc] = (real) j;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
a[jc + i__ - j] = 0.f;
/* L30: */
}
jc = jc + *n - j + 1;
/* L40: */
}
}
/* IMAT > 7: Non-trivial unit triangular matrix */
/* Generate a unit triangular matrix T with condition CNDNUM by */
/* forming a triangular matrix with known singular values and */
/* filling in the zero entries with Givens rotations. */
} else if (*imat <= 10) {
if (upper) {
jc = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
a[jc + i__] = 0.f;
/* L50: */
}
a[jc + j] = (real) j;
jc += j;
/* L60: */
}
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
a[jc] = (real) j;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
a[jc + i__ - j] = 0.f;
/* L70: */
}
jc = jc + *n - j + 1;
/* L80: */
}
}
/* Since the trace of a unit triangular matrix is 1, the product */
/* of its singular values must be 1. Let s = sqrt(CNDNUM), */
/* x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2. */
/* The following triangular matrix has singular values s, 1, 1, */
/* ..., 1, 1/s: */
/* 1 y y y ... y y z */
/* 1 0 0 ... 0 0 y */
/* 1 0 ... 0 0 y */
/* . ... . . . */
/* . . . . */
/* 1 0 y */
/* 1 y */
/* 1 */
/* To fill in the zeros, we first multiply by a matrix with small */
/* condition number of the form */
/* 1 0 0 0 0 ... */
/* 1 + * 0 0 ... */
/* 1 + 0 0 0 */
/* 1 + * 0 0 */
/* 1 + 0 0 */
/* ... */
/* 1 + 0 */
/* 1 0 */
/* 1 */
/* Each element marked with a '*' is formed by taking the product */
/* of the adjacent elements marked with '+'. The '*'s can be */
/* chosen freely, and the '+'s are chosen so that the inverse of */
/* T will have elements of the same magnitude as T. If the *'s in */
/* both T and inv(T) have small magnitude, T is well conditioned. */
/* The two offdiagonals of T are stored in WORK. */
/* The product of these two matrices has the form */
/* 1 y y y y y . y y z */
/* 1 + * 0 0 . 0 0 y */
/* 1 + 0 0 . 0 0 y */
/* 1 + * . . . . */
/* 1 + . . . . */
/* . . . . . */
/* . . . . */
/* 1 + y */
/* 1 y */
/* 1 */
/* Now we multiply by Givens rotations, using the fact that */
/* [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ] */
/* [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ] */
/* and */
/* [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ] */
/* [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ] */
/* where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4). */
star1 = .25f;
sfac = .5f;
plus1 = sfac;
i__1 = *n;
for (j = 1; j <= i__1; j += 2) {
plus2 = star1 / plus1;
work[j] = plus1;
work[*n + j] = star1;
if (j + 1 <= *n) {
work[j + 1] = plus2;
work[*n + j + 1] = 0.f;
plus1 = star1 / plus2;
rexp = slarnd_(&c__2, &iseed[1]);
d__1 = (doublereal) sfac;
d__2 = (doublereal) rexp;
star1 *= pow_dd(&d__1, &d__2);
if (rexp < 0.f) {
d__1 = (doublereal) sfac;
d__2 = (doublereal) (1.f - rexp);
star1 = -pow_dd(&d__1, &d__2);
} else {
d__1 = (doublereal) sfac;
d__2 = (doublereal) (rexp + 1.f);
star1 = pow_dd(&d__1, &d__2);
}
}
/* L90: */
}
x = sqrt(cndnum) - 1.f / sqrt(cndnum);
if (*n > 2) {
y = sqrt(2.f / (real) (*n - 2)) * x;
} else {
y = 0.f;
}
z__ = x * x;
if (upper) {
/* Set the upper triangle of A with a unit triangular matrix */
/* of known condition number. */
jc = 1;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
a[jc + 1] = y;
if (j > 2) {
a[jc + j - 1] = work[j - 2];
}
if (j > 3) {
a[jc + j - 2] = work[*n + j - 3];
}
jc += j;
/* L100: */
}
jc -= *n;
a[jc + 1] = z__;
i__1 = *n - 1;
for (j = 2; j <= i__1; ++j) {
a[jc + j] = y;
/* L110: */
}
} else {
/* Set the lower triangle of A with a unit triangular matrix */
/* of known condition number. */
i__1 = *n - 1;
for (i__ = 2; i__ <= i__1; ++i__) {
a[i__] = y;
/* L120: */
}
a[*n] = z__;
jc = *n + 1;
i__1 = *n - 1;
for (j = 2; j <= i__1; ++j) {
a[jc + 1] = work[j - 1];
if (j < *n - 1) {
a[jc + 2] = work[*n + j - 1];
}
a[jc + *n - j] = y;
jc = jc + *n - j + 1;
/* L130: */
}
}
/* Fill in the zeros using Givens rotations */
if (upper) {
jc = 1;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
jcnext = jc + j;
ra = a[jcnext + j - 1];
rb = 2.f;
srotg_(&ra, &rb, &c__, &s);
/* Multiply by [ c s; -s c] on the left. */
if (*n > j + 1) {
jx = jcnext + j;
i__2 = *n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
stemp = c__ * a[jx + j] + s * a[jx + j + 1];
a[jx + j + 1] = -s * a[jx + j] + c__ * a[jx + j + 1];
a[jx + j] = stemp;
jx += i__;
/* L140: */
}
}
/* Multiply by [-c -s; s -c] on the right. */
if (j > 1) {
i__2 = j - 1;
r__1 = -c__;
r__2 = -s;
srot_(&i__2, &a[jcnext], &c__1, &a[jc], &c__1, &r__1, &
r__2);
}
/* Negate A(J,J+1). */
a[jcnext + j - 1] = -a[jcnext + j - 1];
jc = jcnext;
/* L150: */
}
} else {
jc = 1;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
jcnext = jc + *n - j + 1;
ra = a[jc + 1];
rb = 2.f;
srotg_(&ra, &rb, &c__, &s);
/* Multiply by [ c -s; s c] on the right. */
if (*n > j + 1) {
i__2 = *n - j - 1;
r__1 = -s;
srot_(&i__2, &a[jcnext + 1], &c__1, &a[jc + 2], &c__1, &
c__, &r__1);
}
/* Multiply by [-c s; -s -c] on the left. */
if (j > 1) {
jx = 1;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
stemp = -c__ * a[jx + j - i__] + s * a[jx + j - i__ +
1];
a[jx + j - i__ + 1] = -s * a[jx + j - i__] - c__ * a[
jx + j - i__ + 1];
a[jx + j - i__] = stemp;
jx = jx + *n - i__ + 1;
/* L160: */
}
}
/* Negate A(J+1,J). */
a[jc + 1] = -a[jc + 1];
jc = jcnext;
/* L170: */
}
}
/* IMAT > 10: Pathological test cases. These triangular matrices */
/* are badly scaled or badly conditioned, so when used in solving a */
/* triangular system they may cause overflow in the solution vector. */
} else if (*imat == 11) {
/* Type 11: Generate a triangular matrix with elements between */
/* -1 and 1. Give the diagonal norm 2 to make it well-conditioned. */
/* Make the right hand side large so that it requires scaling. */
if (upper) {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
slarnv_(&c__2, &iseed[1], &j, &a[jc]);
a[jc + j - 1] = r_sign(&c_b36, &a[jc + j - 1]);
jc += j;
/* L180: */
}
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j + 1;
slarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
a[jc] = r_sign(&c_b36, &a[jc]);
jc = jc + *n - j + 1;
/* L190: */
}
}
/* Set the right hand side so that the largest value is BIGNUM. */
slarnv_(&c__2, &iseed[1], n, &b[1]);
iy = isamax_(n, &b[1], &c__1);
bnorm = (r__1 = b[iy], dabs(r__1));
bscal = bignum / dmax(1.f,bnorm);
sscal_(n, &bscal, &b[1], &c__1);
} else if (*imat == 12) {
/* Type 12: Make the first diagonal element in the solve small to */
/* cause immediate overflow when dividing by T(j,j). */
/* In type 12, the offdiagonal elements are small (CNORM(j) < 1). */
slarnv_(&c__2, &iseed[1], n, &b[1]);
/* Computing MAX */
r__1 = 1.f, r__2 = (real) (*n - 1);
tscal = 1.f / dmax(r__1,r__2);
if (upper) {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
slarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
i__2 = j - 1;
sscal_(&i__2, &tscal, &a[jc], &c__1);
r__1 = slarnd_(&c__2, &iseed[1]);
a[jc + j - 1] = r_sign(&c_b48, &r__1);
jc += j;
/* L200: */
}
a[*n * (*n + 1) / 2] = smlnum;
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
slarnv_(&c__2, &iseed[1], &i__2, &a[jc + 1]);
i__2 = *n - j;
sscal_(&i__2, &tscal, &a[jc + 1], &c__1);
r__1 = slarnd_(&c__2, &iseed[1]);
a[jc] = r_sign(&c_b48, &r__1);
jc = jc + *n - j + 1;
/* L210: */
}
a[1] = smlnum;
}
} else if (*imat == 13) {
/* Type 13: Make the first diagonal element in the solve small to */
/* cause immediate overflow when dividing by T(j,j). */
/* In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1). */
slarnv_(&c__2, &iseed[1], n, &b[1]);
if (upper) {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
slarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
r__1 = slarnd_(&c__2, &iseed[1]);
a[jc + j - 1] = r_sign(&c_b48, &r__1);
jc += j;
/* L220: */
}
a[*n * (*n + 1) / 2] = smlnum;
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
slarnv_(&c__2, &iseed[1], &i__2, &a[jc + 1]);
r__1 = slarnd_(&c__2, &iseed[1]);
a[jc] = r_sign(&c_b48, &r__1);
jc = jc + *n - j + 1;
/* L230: */
}
a[1] = smlnum;
}
} else if (*imat == 14) {
/* Type 14: T is diagonal with small numbers on the diagonal to */
/* make the growth factor underflow, but a small right hand side */
/* chosen so that the solution does not overflow. */
if (upper) {
jcount = 1;
jc = (*n - 1) * *n / 2 + 1;
for (j = *n; j >= 1; --j) {
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
a[jc + i__ - 1] = 0.f;
/* L240: */
}
if (jcount <= 2) {
a[jc + j - 1] = smlnum;
} else {
a[jc + j - 1] = 1.f;
}
++jcount;
if (jcount > 4) {
jcount = 1;
}
jc = jc - j + 1;
/* L250: */
}
} else {
jcount = 1;
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
a[jc + i__ - j] = 0.f;
/* L260: */
}
if (jcount <= 2) {
a[jc] = smlnum;
} else {
a[jc] = 1.f;
}
++jcount;
if (jcount > 4) {
jcount = 1;
}
jc = jc + *n - j + 1;
/* L270: */
}
}
/* Set the right hand side alternately zero and small. */
if (upper) {
b[1] = 0.f;
for (i__ = *n; i__ >= 2; i__ += -2) {
b[i__] = 0.f;
b[i__ - 1] = smlnum;
/* L280: */
}
} else {
b[*n] = 0.f;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; i__ += 2) {
b[i__] = 0.f;
b[i__ + 1] = smlnum;
/* L290: */
}
}
} else if (*imat == 15) {
/* Type 15: Make the diagonal elements small to cause gradual */
/* overflow when dividing by T(j,j). To control the amount of */
/* scaling needed, the matrix is bidiagonal. */
/* Computing MAX */
r__1 = 1.f, r__2 = (real) (*n - 1);
texp = 1.f / dmax(r__1,r__2);
d__1 = (doublereal) smlnum;
d__2 = (doublereal) texp;
tscal = pow_dd(&d__1, &d__2);
slarnv_(&c__2, &iseed[1], n, &b[1]);
if (upper) {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 2;
for (i__ = 1; i__ <= i__2; ++i__) {
a[jc + i__ - 1] = 0.f;
/* L300: */
}
if (j > 1) {
a[jc + j - 2] = -1.f;
}
a[jc + j - 1] = tscal;
jc += j;
/* L310: */
}
b[*n] = 1.f;
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
a[jc + i__ - j] = 0.f;
/* L320: */
}
if (j < *n) {
a[jc + 1] = -1.f;
}
a[jc] = tscal;
jc = jc + *n - j + 1;
/* L330: */
}
b[1] = 1.f;
}
} else if (*imat == 16) {
/* Type 16: One zero diagonal element. */
iy = *n / 2 + 1;
if (upper) {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
slarnv_(&c__2, &iseed[1], &j, &a[jc]);
if (j != iy) {
a[jc + j - 1] = r_sign(&c_b36, &a[jc + j - 1]);
} else {
a[jc + j - 1] = 0.f;
}
jc += j;
/* L340: */
}
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j + 1;
slarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
if (j != iy) {
a[jc] = r_sign(&c_b36, &a[jc]);
} else {
a[jc] = 0.f;
}
jc = jc + *n - j + 1;
/* L350: */
}
}
slarnv_(&c__2, &iseed[1], n, &b[1]);
sscal_(n, &c_b36, &b[1], &c__1);
} else if (*imat == 17) {
/* Type 17: Make the offdiagonal elements large to cause overflow */
/* when adding a column of T. In the non-transposed case, the */
/* matrix is constructed to cause overflow when adding a column in */
/* every other step. */
tscal = unfl / ulp;
tscal = (1.f - ulp) / tscal;
i__1 = *n * (*n + 1) / 2;
for (j = 1; j <= i__1; ++j) {
a[j] = 0.f;
/* L360: */
}
texp = 1.f;
if (upper) {
jc = (*n - 1) * *n / 2 + 1;
for (j = *n; j >= 2; j += -2) {
a[jc] = -tscal / (real) (*n + 1);
a[jc + j - 1] = 1.f;
b[j] = texp * (1.f - ulp);
jc = jc - j + 1;
a[jc] = -(tscal / (real) (*n + 1)) / (real) (*n + 2);
a[jc + j - 2] = 1.f;
b[j - 1] = texp * (real) (*n * *n + *n - 1);
texp *= 2.f;
jc = jc - j + 2;
/* L370: */
}
b[1] = (real) (*n + 1) / (real) (*n + 2) * tscal;
} else {
jc = 1;
i__1 = *n - 1;
for (j = 1; j <= i__1; j += 2) {
a[jc + *n - j] = -tscal / (real) (*n + 1);
a[jc] = 1.f;
b[j] = texp * (1.f - ulp);
jc = jc + *n - j + 1;
a[jc + *n - j - 1] = -(tscal / (real) (*n + 1)) / (real) (*n
+ 2);
a[jc] = 1.f;
b[j + 1] = texp * (real) (*n * *n + *n - 1);
texp *= 2.f;
jc = jc + *n - j;
/* L380: */
}
b[*n] = (real) (*n + 1) / (real) (*n + 2) * tscal;
}
} else if (*imat == 18) {
/* Type 18: Generate a unit triangular matrix with elements */
/* between -1 and 1, and make the right hand side large so that it */
/* requires scaling. */
if (upper) {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
slarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
a[jc + j - 1] = 0.f;
jc += j;
/* L390: */
}
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < *n) {
i__2 = *n - j;
slarnv_(&c__2, &iseed[1], &i__2, &a[jc + 1]);
}
a[jc] = 0.f;
jc = jc + *n - j + 1;
/* L400: */
}
}
/* Set the right hand side so that the largest value is BIGNUM. */
slarnv_(&c__2, &iseed[1], n, &b[1]);
iy = isamax_(n, &b[1], &c__1);
bnorm = (r__1 = b[iy], dabs(r__1));
bscal = bignum / dmax(1.f,bnorm);
sscal_(n, &bscal, &b[1], &c__1);
} else if (*imat == 19) {
/* Type 19: Generate a triangular matrix with elements between */
/* BIGNUM/(n-1) and BIGNUM so that at least one of the column */
/* norms will exceed BIGNUM. */
/* Computing MAX */
r__1 = 1.f, r__2 = (real) (*n - 1);
tleft = bignum / dmax(r__1,r__2);
/* Computing MAX */
r__1 = 1.f, r__2 = (real) (*n);
tscal = bignum * ((real) (*n - 1) / dmax(r__1,r__2));
if (upper) {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
slarnv_(&c__2, &iseed[1], &j, &a[jc]);
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
a[jc + i__ - 1] = r_sign(&tleft, &a[jc + i__ - 1]) +
tscal * a[jc + i__ - 1];
/* L410: */
}
jc += j;
/* L420: */
}
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j + 1;
slarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
a[jc + i__ - j] = r_sign(&tleft, &a[jc + i__ - j]) +
tscal * a[jc + i__ - j];
/* L430: */
}
jc = jc + *n - j + 1;
/* L440: */
}
}
slarnv_(&c__2, &iseed[1], n, &b[1]);
sscal_(n, &c_b36, &b[1], &c__1);
}
/* Flip the matrix across its counter-diagonal if the transpose will */
/* be used. */
if (! lsame_(trans, "N")) {
if (upper) {
jj = 1;
jr = *n * (*n + 1) / 2;
i__1 = *n / 2;
for (j = 1; j <= i__1; ++j) {
jl = jj;
i__2 = *n - j;
for (i__ = j; i__ <= i__2; ++i__) {
t = a[jr - i__ + j];
a[jr - i__ + j] = a[jl];
a[jl] = t;
jl += i__;
/* L450: */
}
jj = jj + j + 1;
jr -= *n - j + 1;
/* L460: */
}
} else {
jl = 1;
jj = *n * (*n + 1) / 2;
i__1 = *n / 2;
for (j = 1; j <= i__1; ++j) {
jr = jj;
i__2 = *n - j;
for (i__ = j; i__ <= i__2; ++i__) {
t = a[jl + i__ - j];
a[jl + i__ - j] = a[jr];
a[jr] = t;
jr -= i__;
/* L470: */
}
jl = jl + *n - j + 1;
jj = jj - j - 1;
/* L480: */
}
}
}
return 0;
/* End of SLATTP */
} /* slattp_ */
