/* Subroutine */ int dlacn2_(integer *n, doublereal *v, doublereal *x,
integer *isgn, doublereal *est, integer *kase, integer *isave)
{
/* System generated locals */
integer i__1;
doublereal d__1;
/* Local variables */
integer i__;
doublereal temp;
integer jlast;
doublereal altsgn, estold;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DLACN2 estimates the 1-norm of a square, real matrix A. */
/* Reverse communication is used for evaluating matrix-vector products. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix. N >= 1. */
/* V (workspace) DOUBLE PRECISION array, dimension (N) */
/* On the final return, V = A*W, where EST = norm(V)/norm(W) */
/* (W is not returned). */
/* X (input/output) DOUBLE PRECISION array, dimension (N) */
/* On an intermediate return, X should be overwritten by */
/* A * X, if KASE=1, */
/* A' * X, if KASE=2, */
/* and DLACN2 must be re-called with all the other parameters */
/* unchanged. */
/* ISGN (workspace) INTEGER array, dimension (N) */
/* EST (input/output) DOUBLE PRECISION */
/* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be */
/* unchanged from the previous call to DLACN2. */
/* On exit, EST is an estimate (a lower bound) for norm(A). */
/* KASE (input/output) INTEGER */
/* On the initial call to DLACN2, KASE should be 0. */
/* On an intermediate return, KASE will be 1 or 2, indicating */
/* whether X should be overwritten by A * X or A' * X. */
/* On the final return from DLACN2, KASE will again be 0. */
/* ISAVE (input/output) INTEGER array, dimension (3) */
/* ISAVE is used to save variables between calls to DLACN2 */
/* Further Details */
/* ======= ======= */
/* Contributed by Nick Higham, University of Manchester. */
/* Originally named SONEST, dated March 16, 1988. */
/* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */
/* a real or complex matrix, with applications to condition estimation", */
/* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */
/* This is a thread safe version of DLACON, which uses the array ISAVE */
/* in place of a SAVE statement, as follows: */
/* DLACON DLACN2 */
/* JUMP ISAVE(1) */
/* J ISAVE(2) */
/* ITER ISAVE(3) */
/* ===================================================================== */
/* Parameter adjustments */
--isave;
--isgn;
--x;
--v;
/* Function Body */
if (*kase == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = 1. / (doublereal) (*n);
}
*kase = 1;
isave[1] = 1;
return 0;
}
switch (isave[1]) {
case 1: goto L20;
case 2: goto L40;
case 3: goto L70;
case 4: goto L110;
case 5: goto L140;
}
/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */
L20:
if (*n == 1) {
v[1] = x[1];
*est = abs(v[1]);
goto L150;
}
*est = dasum_(n, &x[1], &c__1);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = d_sign(&c_b11, &x[i__]);
isgn[i__] = i_dnnt(&x[i__]);
}
*kase = 2;
isave[1] = 2;
return 0;
/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
L40:
isave[2] = idamax_(n, &x[1], &c__1);
isave[3] = 2;
L50:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = 0.;
}
x[isave[2]] = 1.;
*kase = 1;
isave[1] = 3;
return 0;
/* X HAS BEEN OVERWRITTEN BY A*X. */
L70:
dcopy_(n, &x[1], &c__1, &v[1], &c__1);
estold = *est;
*est = dasum_(n, &v[1], &c__1);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__1 = d_sign(&c_b11, &x[i__]);
if (i_dnnt(&d__1) != isgn[i__]) {
goto L90;
}
}
/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
goto L120;
L90:
/* TEST FOR CYCLING. */
if (*est <= estold) {
goto L120;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = d_sign(&c_b11, &x[i__]);
isgn[i__] = i_dnnt(&x[i__]);
}
*kase = 2;
isave[1] = 4;
return 0;
/* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
L110:
jlast = isave[2];
isave[2] = idamax_(n, &x[1], &c__1);
if (x[jlast] != (d__1 = x[isave[2]], abs(d__1)) && isave[3] < 5) {
++isave[3];
goto L50;
}
/* ITERATION COMPLETE. FINAL STAGE. */
L120:
altsgn = 1.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) +
1.);
altsgn = -altsgn;
}
*kase = 1;
isave[1] = 5;
return 0;
/* X HAS BEEN OVERWRITTEN BY A*X. */
L140:
temp = dasum_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.;
if (temp > *est) {
dcopy_(n, &x[1], &c__1, &v[1], &c__1);
*est = temp;
}
L150:
*kase = 0;
return 0;
/* End of DLACN2 */
} /* dlacn2_ */
/* Subroutine */
int dlalsd_(char *uplo, integer *smlsiz, integer *n, integer *nrhs, doublereal *d__, doublereal *e, doublereal *b, integer *ldb, doublereal *rcond, integer *rank, doublereal *work, integer *iwork, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double log(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
integer c__, i__, j, k;
doublereal r__;
integer s, u, z__;
doublereal cs;
integer bx;
doublereal sn;
integer st, vt, nm1, st1;
doublereal eps;
integer iwk;
doublereal tol;
integer difl, difr;
doublereal rcnd;
integer perm, nsub;
extern /* Subroutine */
int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *);
integer nlvl, sqre, bxst;
extern /* Subroutine */
int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *), dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
integer poles, sizei, nsize, nwork, icmpq1, icmpq2;
extern doublereal dlamch_(char *);
extern /* Subroutine */
int dlasda_(integer *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, integer *), dlalsa_(integer *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, integer *), dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */
int dlasdq_(char *, integer *, integer *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *), dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *), dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
integer givcol;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */
int dlasrt_(char *, integer *, doublereal *, integer *);
doublereal orgnrm;
integer givnum, givptr, smlszp;
/* -- LAPACK computational routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
if (*n < 0)
{
*info = -3;
}
else if (*nrhs < 1)
{
*info = -4;
}
else if (*ldb < 1 || *ldb < *n)
{
*info = -8;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DLALSD", &i__1);
return 0;
}
eps = dlamch_("Epsilon");
/* Set up the tolerance. */
if (*rcond <= 0. || *rcond >= 1.)
{
rcnd = eps;
}
else
{
rcnd = *rcond;
}
*rank = 0;
/* Quick return if possible. */
if (*n == 0)
{
return 0;
}
else if (*n == 1)
{
if (d__[1] == 0.)
{
dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb);
}
else
{
*rank = 1;
dlascl_("G", &c__0, &c__0, &d__[1], &c_b11, &c__1, nrhs, &b[ b_offset], ldb, info);
d__[1] = abs(d__[1]);
}
return 0;
}
/* Rotate the matrix if it is lower bidiagonal. */
if (*(unsigned char *)uplo == 'L')
{
i__1 = *n - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
if (*nrhs == 1)
{
drot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], & c__1, &cs, &sn);
}
else
{
work[(i__ << 1) - 1] = cs;
work[i__ * 2] = sn;
}
/* L10: */
}
if (*nrhs > 1)
{
i__1 = *nrhs;
for (i__ = 1;
i__ <= i__1;
++i__)
{
i__2 = *n - 1;
for (j = 1;
j <= i__2;
++j)
{
cs = work[(j << 1) - 1];
sn = work[j * 2];
drot_(&c__1, &b[j + i__ * b_dim1], &c__1, &b[j + 1 + i__ * b_dim1], &c__1, &cs, &sn);
/* L20: */
}
/* L30: */
}
}
}
/* Scale. */
nm1 = *n - 1;
orgnrm = dlanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.)
{
dlaset_("A", n, nrhs, &c_b6, &c_b6, &b[b_offset], ldb);
return 0;
}
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, &c__1, &d__[1], n, info);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, &nm1, &c__1, &e[1], &nm1, info);
/* If N is smaller than the minimum divide size SMLSIZ, then solve */
/* the problem with another solver. */
if (*n <= *smlsiz)
{
nwork = *n * *n + 1;
dlaset_("A", n, n, &c_b6, &c_b11, &work[1], n);
dlasdq_("U", &c__0, n, n, &c__0, nrhs, &d__[1], &e[1], &work[1], n, & work[1], n, &b[b_offset], ldb, &work[nwork], info);
if (*info != 0)
{
return 0;
}
tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1));
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if (d__[i__] <= tol)
{
dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[i__ + b_dim1], ldb);
}
else
{
dlascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &b[ i__ + b_dim1], ldb, info);
++(*rank);
}
/* L40: */
}
dgemm_("T", "N", n, nrhs, n, &c_b11, &work[1], n, &b[b_offset], ldb, & c_b6, &work[nwork], n);
dlacpy_("A", n, nrhs, &work[nwork], n, &b[b_offset], ldb);
/* Unscale. */
dlascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info);
dlasrt_("D", n, &d__[1], info);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb, info);
return 0;
}
/* Book-keeping and setting up some constants. */
nlvl = (integer) (log((doublereal) (*n) / (doublereal) (*smlsiz + 1)) / log(2.)) + 1;
smlszp = *smlsiz + 1;
u = 1;
vt = *smlsiz * *n + 1;
difl = vt + smlszp * *n;
difr = difl + nlvl * *n;
z__ = difr + (nlvl * *n << 1);
c__ = z__ + nlvl * *n;
s = c__ + *n;
poles = s + *n;
givnum = poles + (nlvl << 1) * *n;
bx = givnum + (nlvl << 1) * *n;
nwork = bx + *n * *nrhs;
sizei = *n + 1;
k = sizei + *n;
givptr = k + *n;
perm = givptr + *n;
givcol = perm + nlvl * *n;
iwk = givcol + (nlvl * *n << 1);
st = 1;
sqre = 0;
icmpq1 = 1;
icmpq2 = 0;
nsub = 0;
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if ((d__1 = d__[i__], abs(d__1)) < eps)
{
d__[i__] = d_sign(&eps, &d__[i__]);
}
/* L50: */
}
i__1 = nm1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1)
{
++nsub;
iwork[nsub] = st;
/* Subproblem found. First determine its size and then */
/* apply divide and conquer on it. */
if (i__ < nm1)
{
/* A subproblem with E(I) small for I < NM1. */
nsize = i__ - st + 1;
iwork[sizei + nsub - 1] = nsize;
}
else if ((d__1 = e[i__], abs(d__1)) >= eps)
{
/* A subproblem with E(NM1) not too small but I = NM1. */
nsize = *n - st + 1;
iwork[sizei + nsub - 1] = nsize;
}
else
{
/* A subproblem with E(NM1) small. This implies an */
/* 1-by-1 subproblem at D(N), which is not solved */
/* explicitly. */
nsize = i__ - st + 1;
iwork[sizei + nsub - 1] = nsize;
++nsub;
iwork[nsub] = *n;
iwork[sizei + nsub - 1] = 1;
dcopy_(nrhs, &b[*n + b_dim1], ldb, &work[bx + nm1], n);
}
st1 = st - 1;
if (nsize == 1)
{
/* This is a 1-by-1 subproblem and is not solved */
/* explicitly. */
dcopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n);
}
else if (nsize <= *smlsiz)
{
/* This is a small subproblem and is solved by DLASDQ. */
dlaset_("A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1], n);
dlasdq_("U", &c__0, &nsize, &nsize, &c__0, nrhs, &d__[st], &e[ st], &work[vt + st1], n, &work[nwork], n, &b[st + b_dim1], ldb, &work[nwork], info);
if (*info != 0)
{
return 0;
}
dlacpy_("A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n);
}
else
{
/* A large problem. Solve it using divide and conquer. */
dlasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], & work[u + st1], n, &work[vt + st1], &iwork[k + st1], & work[difl + st1], &work[difr + st1], &work[z__ + st1], &work[poles + st1], &iwork[givptr + st1], &iwork[ givcol + st1], n, &iwork[perm + st1], &work[givnum + st1], &work[c__ + st1], &work[s + st1], &work[nwork], &iwork[iwk], info);
if (*info != 0)
{
return 0;
}
bxst = bx + st1;
dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, & work[bxst], n, &work[u + st1], n, &work[vt + st1], & iwork[k + st1], &work[difl + st1], &work[difr + st1], &work[z__ + st1], &work[poles + st1], &iwork[givptr + st1], &iwork[givcol + st1], n, &iwork[perm + st1], & work[givnum + st1], &work[c__ + st1], &work[s + st1], &work[nwork], &iwork[iwk], info);
if (*info != 0)
{
return 0;
}
}
st = i__ + 1;
}
/* L60: */
}
/* Apply the singular values and treat the tiny ones as zero. */
tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1));
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
/* Some of the elements in D can be negative because 1-by-1 */
/* subproblems were not solved explicitly. */
if ((d__1 = d__[i__], abs(d__1)) <= tol)
{
dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n);
}
else
{
++(*rank);
dlascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[ bx + i__ - 1], n, info);
}
d__[i__] = (d__1 = d__[i__], abs(d__1));
/* L70: */
}
/* Now apply back the right singular vectors. */
icmpq2 = 1;
i__1 = nsub;
for (i__ = 1;
i__ <= i__1;
++i__)
{
st = iwork[i__];
st1 = st - 1;
nsize = iwork[sizei + i__ - 1];
bxst = bx + st1;
if (nsize == 1)
{
dcopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb);
}
else if (nsize <= *smlsiz)
{
dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b11, &work[vt + st1], n, &work[bxst], n, &c_b6, &b[st + b_dim1], ldb);
}
else
{
dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st + b_dim1], ldb, &work[u + st1], n, &work[vt + st1], &iwork[ k + st1], &work[difl + st1], &work[difr + st1], &work[z__ + st1], &work[poles + st1], &iwork[givptr + st1], &iwork[ givcol + st1], n, &iwork[perm + st1], &work[givnum + st1], &work[c__ + st1], &work[s + st1], &work[nwork], &iwork[ iwk], info);
if (*info != 0)
{
return 0;
}
}
/* L80: */
}
/* Unscale and sort the singular values. */
dlascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info);
dlasrt_("D", n, &d__[1], info);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb, info);
return 0;
/* End of DLALSD */
}
/* Subroutine */ int dlarfg_(integer *n, doublereal *alpha, doublereal *x,
integer *incx, doublereal *tau)
{
/* System generated locals */
integer i__1;
doublereal d__1;
/* Local variables */
integer j, knt;
doublereal beta;
doublereal xnorm;
doublereal safmin, rsafmn;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DLARFG generates a real elementary reflector H of order n, such */
/* that */
/* H * ( alpha ) = ( beta ), H' * H = I. */
/* ( x ) ( 0 ) */
/* where alpha and beta are scalars, and x is an (n-1)-element real */
/* vector. H is represented in the form */
/* H = I - tau * ( 1 ) * ( 1 v' ) , */
/* ( v ) */
/* where tau is a real scalar and v is a real (n-1)-element */
/* vector. */
/* If the elements of x are all zero, then tau = 0 and H is taken to be */
/* the unit matrix. */
/* Otherwise 1 <= tau <= 2. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the elementary reflector. */
/* ALPHA (input/output) DOUBLE PRECISION */
/* On entry, the value alpha. */
/* On exit, it is overwritten with the value beta. */
/* X (input/output) DOUBLE PRECISION array, dimension */
/* (1+(N-2)*abs(INCX)) */
/* On entry, the vector x. */
/* On exit, it is overwritten with the vector v. */
/* INCX (input) INTEGER */
/* The increment between elements of X. INCX > 0. */
/* TAU (output) DOUBLE PRECISION */
/* The value tau. */
/* ===================================================================== */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 1) {
*tau = 0.;
return 0;
}
i__1 = *n - 1;
xnorm = dnrm2_(&i__1, &x[1], incx);
if (xnorm == 0.) {
/* H = I */
*tau = 0.;
} else {
/* general case */
d__1 = dlapy2_(alpha, &xnorm);
beta = -d_sign(&d__1, alpha);
safmin = dlamch_("S") / dlamch_("E");
knt = 0;
if (abs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute them */
rsafmn = 1. / safmin;
L10:
++knt;
i__1 = *n - 1;
dscal_(&i__1, &rsafmn, &x[1], incx);
beta *= rsafmn;
*alpha *= rsafmn;
if (abs(beta) < safmin) {
goto L10;
}
/* New BETA is at most 1, at least SAFMIN */
i__1 = *n - 1;
xnorm = dnrm2_(&i__1, &x[1], incx);
d__1 = dlapy2_(alpha, &xnorm);
beta = -d_sign(&d__1, alpha);
}
*tau = (beta - *alpha) / beta;
i__1 = *n - 1;
d__1 = 1. / (*alpha - beta);
dscal_(&i__1, &d__1, &x[1], incx);
/* If ALPHA is subnormal, it may lose relative accuracy */
i__1 = knt;
for (j = 1; j <= i__1; ++j) {
beta *= safmin;
}
*alpha = beta;
}
return 0;
/* End of DLARFG */
} /* dlarfg_ */
/* Subroutine */ int dlanv2_(doublereal *a, doublereal *b, doublereal *c__,
doublereal *d__, doublereal *rt1r, doublereal *rt1i, doublereal *rt2r,
doublereal *rt2i, doublereal *cs, doublereal *sn)
{
/* System generated locals */
doublereal d__1;
/* Builtin functions */
double d_sign(doublereal *, doublereal *), sqrt(doublereal);
/* Local variables */
static doublereal p, aa, bb, cc, dd, cs1, sn1, sab, sac, tau, temp, sigma;
extern doublereal dlapy2_(doublereal *, doublereal *);
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric */
/* matrix in standard form: */
/* [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] */
/* [ C D ] [ SN CS ] [ CC DD ] [-SN CS ] */
/* where either */
/* 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or */
/* 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex */
/* conjugate eigenvalues. */
/* Arguments */
/* ========= */
/* A (input/output) DOUBLE PRECISION */
/* B (input/output) DOUBLE PRECISION */
/* C (input/output) DOUBLE PRECISION */
/* D (input/output) DOUBLE PRECISION */
/* On entry, the elements of the input matrix. */
/* On exit, they are overwritten by the elements of the */
/* standardised Schur form. */
/* RT1R (output) DOUBLE PRECISION */
/* RT1I (output) DOUBLE PRECISION */
/* RT2R (output) DOUBLE PRECISION */
/* RT2I (output) DOUBLE PRECISION */
/* The real and imaginary parts of the eigenvalues. If the */
/* eigenvalues are both real, abs(RT1R) >= abs(RT2R); if the */
/* eigenvalues are a complex conjugate pair, RT1I > 0. */
/* CS (output) DOUBLE PRECISION */
/* SN (output) DOUBLE PRECISION */
/* Parameters of the rotation matrix. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Initialize CS and SN */
*cs = 1.;
*sn = 0.;
if (*c__ == 0.) {
goto L10;
} else if (*b == 0.) {
/* Swap rows and columns */
*cs = 0.;
*sn = 1.;
temp = *d__;
*d__ = *a;
*a = temp;
*b = -(*c__);
*c__ = 0.;
goto L10;
} else if (*a - *d__ == 0. && d_sign(&c_b3, b) != d_sign(&c_b3, c__)) {
goto L10;
} else {
/* Make diagonal elements equal */
temp = *a - *d__;
p = temp * .5;
sigma = *b + *c__;
tau = dlapy2_(&sigma, &temp);
cs1 = sqrt((abs(sigma) / tau + 1.) * .5);
sn1 = -(p / (tau * cs1)) * d_sign(&c_b3, &sigma);
/* Compute [ AA BB ] = [ A B ] [ CS1 -SN1 ] */
/* [ CC DD ] [ C D ] [ SN1 CS1 ] */
aa = *a * cs1 + *b * sn1;
bb = -(*a) * sn1 + *b * cs1;
cc = *c__ * cs1 + *d__ * sn1;
dd = -(*c__) * sn1 + *d__ * cs1;
/* Compute [ A B ] = [ CS1 SN1 ] [ AA BB ] */
/* [ C D ] [-SN1 CS1 ] [ CC DD ] */
*a = aa * cs1 + cc * sn1;
*b = bb * cs1 + dd * sn1;
*c__ = -aa * sn1 + cc * cs1;
*d__ = -bb * sn1 + dd * cs1;
/* Accumulate transformation */
temp = *cs * cs1 - *sn * sn1;
*sn = *cs * sn1 + *sn * cs1;
*cs = temp;
temp = (*a + *d__) * .5;
*a = temp;
*d__ = temp;
if (*c__ != 0.) {
if (*b != 0.) {
if (d_sign(&c_b3, b) == d_sign(&c_b3, c__)) {
/* Real eigenvalues: reduce to upper triangular form */
sab = sqrt((abs(*b)));
sac = sqrt((abs(*c__)));
d__1 = sab * sac;
p = d_sign(&d__1, c__);
tau = 1. / sqrt((d__1 = *b + *c__, abs(d__1)));
*a = temp + p;
*d__ = temp - p;
*b -= *c__;
*c__ = 0.;
cs1 = sab * tau;
sn1 = sac * tau;
temp = *cs * cs1 - *sn * sn1;
*sn = *cs * sn1 + *sn * cs1;
*cs = temp;
}
} else {
*b = -(*c__);
*c__ = 0.;
temp = *cs;
*cs = -(*sn);
*sn = temp;
}
}
}
L10:
/* Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). */
*rt1r = *a;
*rt2r = *d__;
if (*c__ == 0.) {
*rt1i = 0.;
*rt2i = 0.;
} else {
*rt1i = sqrt((abs(*b))) * sqrt((abs(*c__)));
*rt2i = -(*rt1i);
}
return 0;
/* End of DLANV2 */
} /* dlanv2_ */
/* Subroutine */ int brlzon_(doublereal *fmatrx, doublereal *fmat2d, integer *
n3, complex *sec, complex *vec, doublereal *b, integer *mono3,
doublereal *step, integer *mode)
{
/* System generated locals */
integer fmat2d_dim1, fmat2d_offset, b_dim1, b_offset, sec_dim1,
sec_offset, vec_dim1, vec_offset, i__1, i__2, i__3, i__4, i__5,
i__6, i__7, i__8;
doublereal d__1, d__2, d__3;
doublecomplex z__1, z__2, z__3, z__4, z__5;
/* Builtin functions */
double acos(doublereal);
void z_sqrt(doublecomplex *, doublecomplex *), z_exp(doublecomplex *,
doublecomplex *);
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
static doublereal c__;
static integer i__, j, k, m, ii, jj;
static doublereal ri;
static integer iii;
static doublereal cay, top, fact;
static real eigs[360];
extern /* Subroutine */ int dofs_(doublereal *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
static integer loop;
extern /* Subroutine */ int cdiag_(complex *, real *, complex *, integer *
, integer *);
static complex phase;
static doublereal twopi;
static integer ncells;
static doublereal bottom;
/* Fortran I/O blocks */
static cilist io___19 = { 0, 6, 0, "(//,A,F6.3,/)", 0 };
static cilist io___20 = { 0, 6, 0, "(/,A,I4,/)", 0 };
static cilist io___21 = { 0, 6, 0, "(6(F6.3,F7.1))", 0 };
static cilist io___22 = { 0, 6, 0, "(//,A,F6.3,/)", 0 };
static cilist io___23 = { 0, 6, 0, "(A,/,A,I4,/,A)", 0 };
static cilist io___24 = { 0, 6, 0, "(6(F6.3,F7.2))", 0 };
/* COMDECK SIZES */
/* *********************************************************************** */
/* THIS FILE CONTAINS ALL THE ARRAY SIZES FOR USE IN MOPAC. */
/* THERE ARE ONLY 5 PARAMETERS THAT THE PROGRAMMER NEED SET: */
/* MAXHEV = MAXIMUM NUMBER OF HEAVY ATOMS (HEAVY: NON-HYDROGEN ATOMS) */
/* MAXLIT = MAXIMUM NUMBER OF HYDROGEN ATOMS. */
/* MAXTIM = DEFAULT TIME FOR A JOB. (SECONDS) */
/* MAXDMP = DEFAULT TIME FOR AUTOMATIC RESTART FILE GENERATION (SECS) */
/* ISYBYL = 1 IF MOPAC IS TO BE USED IN THE SYBYL PACKAGE, =0 OTHERWISE */
/* SEE ALSO NMECI, NPULAY AND MESP AT THE END OF THIS FILE */
/* *********************************************************************** */
/* THE FOLLOWING CODE DOES NOT NEED TO BE ALTERED BY THE PROGRAMMER */
/* *********************************************************************** */
/* ALL OTHER PARAMETERS ARE DERIVED FUNCTIONS OF THESE TWO PARAMETERS */
/* NAME DEFINITION */
/* NUMATM MAXIMUM NUMBER OF ATOMS ALLOWED. */
/* MAXORB MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXPAR MAXIMUM NUMBER OF PARAMETERS FOR OPTIMISATION. */
/* N2ELEC MAXIMUM NUMBER OF TWO ELECTRON INTEGRALS ALLOWED. */
/* MPACK AREA OF LOWER HALF TRIANGLE OF DENSITY MATRIX. */
/* MORB2 SQUARE OF THE MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXHES AREA OF HESSIAN MATRIX */
/* MAXALL LARGER THAN MAXORB OR MAXPAR. */
/* *********************************************************************** */
/* *********************************************************************** */
/* DECK MOPAC */
/* ********************************************************************** */
/* IF MODE IS 1 THEN */
/* BRLZON COMPUTES THE PHONON SPECTRUM OF A LINEAR POLYMER GIVEN */
/* THE WEIGHTED HESSIAN MATRIX. */
/* IF MODE IS 2 THEN */
/* BRLZON COMPUTES THE ELECTRONIC ENERGY BAND STRUCTURE OF A LINEAR */
/* POLYMER GIVEN THE FOCK MATRIX. */
/* ON INPUT */
/* IF MODE IS 1 THEN */
/* FMATRX IS THE MASS-WEIGHTED HESSIAN MATRIX, PACKED LOWER */
/* HALF TRIANGLE */
/* N3 IS 3*(NUMBER OF ATOMS IN UNIT CELL) = SIZE OF FMATRX */
/* MONO3 IS 3*(NUMBER OF ATOMS IN PRIMITIVE UNIT CELL) */
/* FMAT2D, SEC, VEC ARE SCRATCH ARRAYS */
/* IF MODE IS 2 THEN */
/* FMATRX IS THE FOCK MATRIX, PACKED LOWER HALF TRIANGLE */
/* N3 IS NUMBER OF ATOMIC ORBITALS IN SYSTEM = SIZE OF FMATRX */
/* MONO3 IS NUMBER OF ATOMIC ORBITALS IN FUNDAMENTAL UNIT CELL */
/* FMAT2D, SEC, VEC ARE SCRATCH ARRAYS */
/* ********************************************************************** */
/* Parameter adjustments */
fmat2d_dim1 = *n3;
fmat2d_offset = 1 + fmat2d_dim1 * 1;
fmat2d -= fmat2d_offset;
--fmatrx;
b_dim1 = *mono3;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
vec_dim1 = *mono3;
vec_offset = 1 + vec_dim1 * 1;
vec -= vec_offset;
sec_dim1 = *mono3;
sec_offset = 1 + sec_dim1 * 1;
sec -= sec_offset;
/* Function Body */
fact = 6.023e23;
c__ = 2.998e10;
twopi = acos(-1.) * 2.;
/* NCELLS IS THE NUMBER OF PRIMITIVE UNIT CELLS IN THE UNIT CELL */
ncells = *n3 / *mono3;
/* PUT THE ENERGY MATRIX INTO SQUARE MATRIX FORM */
k = 0;
i__1 = *n3;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
++k;
/* L10: */
fmat2d[i__ + j * fmat2d_dim1] = fmatrx[k];
}
}
/* STEP IS THE STEP SIZE IN THE BRILLOUIN ZONE (BOUNDARIES: 0.0 - 0.5), */
/* THERE ARE M OF THESE. */
/* MONO3 IS THE SIZE OF ONE MER (MONOMERIC UNIT) */
m = (integer) (.5 / *step + 1);
i__2 = m;
for (loop = 1; loop <= i__2; ++loop) {
i__1 = *mono3;
for (i__ = 1; i__ <= i__1; ++i__) {
i__3 = *mono3;
for (j = 1; j <= i__3; ++j) {
/* L20: */
i__4 = i__ + j * sec_dim1;
sec[i__4].r = 0.f, sec[i__4].i = 0.f;
}
}
cay = (loop - 1) * *step;
i__4 = *n3;
i__3 = *mono3;
for (i__ = 1; i__3 < 0 ? i__ >= i__4 : i__ <= i__4; i__ += i__3) {
ri = (doublereal) ((i__ - 1) / *mono3);
/* IF THE PRIMITIVE UNIT CELL IS MORE THAN HALF WAY ACROSS THE UNIT CELL, */
/* CONSIDER IT AS BEING LESS THAN HALF WAY ACROSS, BUT IN THE OPPOSITE */
/* DIRECTION. */
if (ri > (doublereal) (ncells / 2)) {
ri -= ncells;
}
/* PHASE IS THE COMPLEX PHASE EXP(I.K.R(I)*(2PI)) */
z_sqrt(&z__5, &c_b6);
z__4.r = cay * z__5.r, z__4.i = cay * z__5.i;
z__3.r = ri * z__4.r, z__3.i = ri * z__4.i;
z__2.r = twopi * z__3.r, z__2.i = twopi * z__3.i;
z_exp(&z__1, &z__2);
phase.r = z__1.r, phase.i = z__1.i;
i__1 = *mono3;
for (ii = 1; ii <= i__1; ++ii) {
iii = ii + i__ - 1;
i__5 = ii;
for (jj = 1; jj <= i__5; ++jj) {
/* L30: */
i__6 = ii + jj * sec_dim1;
i__7 = ii + jj * sec_dim1;
i__8 = iii + jj * fmat2d_dim1;
z__2.r = fmat2d[i__8] * phase.r, z__2.i = fmat2d[i__8] *
phase.i;
z__1.r = sec[i__7].r + z__2.r, z__1.i = sec[i__7].i +
z__2.i;
sec[i__6].r = z__1.r, sec[i__6].i = z__1.i;
}
}
/* L40: */
}
cdiag_(&sec[sec_offset], eigs, &vec[vec_offset], mono3, &c__0);
if (*mode == 1) {
/* CONVERT INTO RECIPRICAL CENTIMETERS */
i__3 = *mono3;
for (i__ = 1; i__ <= i__3; ++i__) {
/* L50: */
d__2 = sqrt(fact * (d__1 = eigs[i__ - 1] * 1e5, abs(d__1))) /
(c__ * twopi);
d__3 = (doublereal) eigs[i__ - 1];
b[i__ + loop * b_dim1] = d_sign(&d__2, &d__3);
}
} else {
i__3 = *mono3;
for (i__ = 1; i__ <= i__3; ++i__) {
/* L60: */
b[i__ + loop * b_dim1] = eigs[i__ - 1];
}
}
/* L70: */
}
bottom = 1e6;
top = -1e6;
i__2 = *mono3;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = m;
for (j = 1; j <= i__3; ++j) {
/* Computing MIN */
d__1 = bottom, d__2 = b[i__ + j * b_dim1];
bottom = min(d__1,d__2);
/* L80: */
/* Computing MAX */
d__1 = top, d__2 = b[i__ + j * b_dim1];
top = max(d__1,d__2);
}
}
if (*mode == 1) {
s_wsfe(&io___19);
do_fio(&c__1, " FREQUENCIES IN CM(-1) FOR PHONON SPECTRUM ACROSS BRI"
"LLOUIN ZONE", (ftnlen)64);
e_wsfe();
i__3 = *mono3;
for (i__ = 1; i__ <= i__3; ++i__) {
s_wsfe(&io___20);
do_fio(&c__1, " BAND:", (ftnlen)7);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
e_wsfe();
/* L90: */
s_wsfe(&io___21);
i__2 = m;
for (j = 1; j <= i__2; ++j) {
d__1 = (j - 1) * *step;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&b[i__ + j * b_dim1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
}
s_stop("", (ftnlen)0);
} else {
s_wsfe(&io___22);
do_fio(&c__1, " ENERGIES (IN EV) OF ELECTRONIC BANDS IN BAND STRUCTU"
"RE", (ftnlen)55);
e_wsfe();
i__2 = *mono3;
for (i__ = 1; i__ <= i__2; ++i__) {
s_wsfe(&io___23);
do_fio(&c__1, " .", (ftnlen)3);
do_fio(&c__1, " CURVE", (ftnlen)7);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, "CURVE DATA ARE", (ftnlen)14);
e_wsfe();
/* L100: */
s_wsfe(&io___24);
i__3 = m;
for (j = 1; j <= i__3; ++j) {
d__1 = (j - 1) * *step;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&b[i__ + j * b_dim1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
}
}
dofs_(&b[b_offset], mono3, &m, &fmat2d[fmat2d_offset], &c__500, &bottom, &
top);
return 0;
} /* brlzon_ */
/* Subroutine */ int
dhhpr(integer k, integer j, integer n, doublereal *x, integer incx, doublereal *beta, doublereal *v)
{
/* Local variables */
static integer iend, jmkp1;
static integer i, l;
static doublereal m, alpha;
static integer istart;
/* IMPLICIT UNDEFINED (A-Z,a-z) */
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DHHPR computes a Householder Plane Rotation (G&vL Alg. 3.3-1) */
/* defined by v and beta. */
/* (I - beta v vt) * x is such that x_i = 0 for i=k+1 to j. */
/* Parameters */
/* ========== */
/* K - INTEGER. */
/* On entry, K specifies that the K+1st entry of X */
/* be the first to be zeroed. */
/* K must be at least one. */
/* Unchanged on exit. */
/* J - INTEGER. */
/* On entry, J specifies the last entry of X to be zeroed. */
/* J must be >= K and <= N. */
/* Unchanged on exit. */
/* N - INTEGER. */
/* On entry, N specifies the (logical) length of X. */
/* Unchanged on exit. */
/* X - DOUBLE PRECISION array of DIMENSION at least */
/* ( 1 + ( N - 1 )*abs( INCX ) ). */
/* On entry, X specifies the vector to be (partially) zeroed. */
/* Unchanged on exit. */
/* INCX - INTEGER. */
/* On entry, INCX specifies the increment for the elements of */
/* X. INCX must be > zero. If X represents part of a matrix, */
/* then use INCX = 1 if a column vector is being zeroed and */
/* INCX = NDIM if a row vector is being zeroed. */
/* Unchanged on exit. */
/* BETA - DOUBLE PRECISION. */
/* BETA specifies the scalar beta. (see pg. 40 of G and v.L.) */
/* V - DOUBLE PRECISION array of DIMENSION at least n. */
/* Is updated to be the appropriate Householder vector for */
/* the given problem. (Note: space for the implicit zeroes is */
/* assumed to be present. Will save on time for index translation
.)*/
/* -- Written by Tom Fairgrieve, */
/* Department of Computer Science, */
/* University of Toronto, */
/* Toronto, Ontario CANADA M5S 1A4 */
/* .. Local Scalars .. */
/* .. External Functions from BLAS .. */
/* .. External Subroutines from BLAS .. */
/* .. Intrinsic Functions .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
/*--v;*/
/*--x;*/
if (k < 1 || k > j) {
fprintf(fp9,"Domain error for K in DHHPR\n");
exit(0);
}
if (j > n) {
fprintf(fp9,"Domain error for J in DHHPR\n");
exit(0);
}
if (incx < 1) {
fprintf(fp9,"Domain error for INCX in DHHPR\n");
exit(0);
}
/* Number of potential non-zero elements in V. */
jmkp1 = j - k + 1;
/* Find M := max{ |x_k|, ... , |x_j| } */
m = fabs(x[-1 + idamax(&jmkp1, &x[-1 + k], &incx)]);
/* alpha := 0 */
/* For i = k to j */
/* v_i = x_i / m */
/* alpha := alpha + v_i^2 (i.e. alpha = vtv) */
/* End For */
/* alpha := sqrt( alpha ) */
/* Copy X(K)/M, ... , X(J)/M to V(K), ... , V(J) */
if (incx == 1) {
for (i = k - 1; i < j; ++i) {
v[i] = x[i] / m;
}
} else {
iend = jmkp1 * incx;
istart = (k - 1) * incx + 1;
l = k;
for (i = istart; incx < 0 ? i >= iend : i <= iend; i += incx)
{
v[-1 + l] = x[-1 + i] / m;
++l;
}
}
/* Compute alpha */
{
/* This is here since I don't want to change the calling sequence of the
BLAS routines. */
integer tmp = 1;
alpha = dnrm2(&jmkp1, &v[-1 + k], &tmp);
}
/* beta := 1/(alpha(alpha + |V_k|)) */
*beta = 1. / (alpha * (alpha + fabs(v[-1 + k])));
/* v_k := v_k + sign(v_k)*alpha */
v[-1 + k] += d_sign(1.0, v[-1 + k]) * alpha;
/* Done ! */
return 0;
/* End of DHHPR. */
} /* dhhpr_ */
/* $Procedure ZZEDTERM ( Ellipsoid terminator ) */
/* Subroutine */ int zzedterm_(char *type__, doublereal *a, doublereal *b,
doublereal *c__, doublereal *srcrad, doublereal *srcpos, integer *
npts, doublereal *trmpts, ftnlen type_len)
{
/* System generated locals */
integer trmpts_dim2, i__1, i__2;
doublereal d__1, d__2, d__3;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
double asin(doublereal);
integer s_rnge(char *, integer, char *, integer);
double d_sign(doublereal *, doublereal *);
/* Local variables */
extern /* Subroutine */ int vadd_(doublereal *, doublereal *, doublereal *
);
doublereal rmin, rmax;
extern /* Subroutine */ int vscl_(doublereal *, doublereal *, doublereal *
);
extern doublereal vdot_(doublereal *, doublereal *), vsep_(doublereal *,
doublereal *);
integer nitr;
extern /* Subroutine */ int vsub_(doublereal *, doublereal *, doublereal *
), vequ_(doublereal *, doublereal *);
doublereal d__, e[3];
integer i__;
doublereal s, angle, v[3], x[3], delta, y[3], z__[3], inang;
extern /* Subroutine */ int chkin_(char *, ftnlen), frame_(doublereal *,
doublereal *, doublereal *);
doublereal plane[4];
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen),
errch_(char *, char *, ftnlen, ftnlen), vpack_(doublereal *,
doublereal *, doublereal *, doublereal *);
doublereal theta;
extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen);
doublereal trans[9] /* was [3][3] */, srcpt[3], vtemp[3];
extern doublereal vnorm_(doublereal *), twopi_(void);
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen),
pl2nvc_(doublereal *, doublereal *, doublereal *);
doublereal lambda;
extern /* Subroutine */ int nvp2pl_(doublereal *, doublereal *,
doublereal *);
extern doublereal halfpi_(void);
doublereal minrad;
extern /* Subroutine */ int latrec_(doublereal *, doublereal *,
doublereal *, doublereal *);
doublereal maxrad, angerr;
logical umbral;
extern doublereal touchd_(doublereal *);
doublereal offset[3], prvdif;
extern /* Subroutine */ int sigerr_(char *, ftnlen);
doublereal outang, plcons, prvang;
extern /* Subroutine */ int chkout_(char *, ftnlen), setmsg_(char *,
ftnlen), errint_(char *, integer *, ftnlen);
char loctyp[50];
extern logical return_(void);
extern /* Subroutine */ int vminus_(doublereal *, doublereal *);
doublereal dir[3];
extern /* Subroutine */ int mxv_(doublereal *, doublereal *, doublereal *)
;
doublereal vtx[3];
/* $ Abstract */
/* SPICE Private routine intended solely for the support of SPICE */
/* routines. Users should not call this routine directly due */
/* to the volatile nature of this routine. */
/* Compute a set of points on the umbral or penumbral terminator of */
/* a specified ellipsoid, given a spherical light source. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* ELLIPSES */
/* $ Keywords */
/* BODY */
/* GEOMETRY */
/* MATH */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* TYPE I Terminator type. */
/* A I Length of ellipsoid semi-axis lying on the x-axis. */
/* B I Length of ellipsoid semi-axis lying on the y-axis. */
/* C I Length of ellipsoid semi-axis lying on the z-axis. */
/* SRCRAD I Radius of light source. */
/* SRCPOS I Position of center of light source. */
/* NPTS I Number of points in terminator point set. */
/* TRMPTS O Terminator point set. */
/* $ Detailed_Input */
/* TYPE is a string indicating the type of terminator to */
/* compute: umbral or penumbral. The umbral */
/* terminator is the boundary of the portion of the */
/* ellipsoid surface in total shadow. The penumbral */
/* terminator is the boundary of the portion of the */
/* surface that is completely illuminated. Possible */
/* values of TYPE are */
/* 'UMBRAL' */
/* 'PENUMBRAL' */
/* Case and leading or trailing blanks in TYPE are */
/* not significant. */
/* A, */
/* B, */
/* C are the lengths of the semi-axes of a triaxial */
/* ellipsoid. The ellipsoid is centered at the */
/* origin and oriented so that its axes lie on the */
/* x, y and z axes. A, B, and C are the lengths of */
/* the semi-axes that point in the x, y, and z */
/* directions respectively. */
/* Length units associated with A, B, and C must */
/* match those associated with SRCRAD, SRCPOS, */
/* and the output TRMPTS. */
/* SRCRAD is the radius of the spherical light source. */
/* SRCPOS is the position of the center of the light source */
/* relative to the center of the ellipsoid. */
/* NPTS is the number of terminator points to compute. */
/* $ Detailed_Output */
/* TRMPTS is an array of points on the umbral or penumbral */
/* terminator of the ellipsoid, as specified by the */
/* input argument TYPE. The Ith point is contained */
/* in the array elements */
/* TRMPTS(J,I), J = 1, 2, 3 */
/* The terminator points are expressed in the */
/* body-fixed reference frame associated with the */
/* ellipsoid. Units are those associated with */
/* the input axis lengths. */
/* Each terminator point is the point of tangency of */
/* a plane that is also tangent to the light source. */
/* These associated points of tangency on the light */
/* source have uniform distribution in longitude when */
/* expressed in a cylindrical coordinate system whose */
/* Z-axis is SRCPOS. The magnitude of the separation */
/* in longitude between these tangency points on the */
/* light source is */
/* 2*Pi / NPTS */
/* If the target is spherical, the terminator points */
/* also are uniformly distributed in longitude in the */
/* cylindrical system described above. If the target */
/* is non-spherical, the longitude distribution of */
/* the points generally is not uniform. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the terminator type is not recognized, the error */
/* SPICE(NOTSUPPORTED) is signaled. */
/* 2) If the set size NPTS is not at least 1, the error */
/* SPICE(INVALIDSIZE) is signaled. */
/* 3) If any of the ellipsoid's semi-axis lengths is non-positive, */
/* the error SPICE(INVALIDAXISLENGTH) is signaled. */
/* 4) If the light source has non-positive radius, the error */
/* SPICE(INVALIDRADIUS) is signaled. */
/* 5) If the light source intersects the smallest sphere */
/* centered at the origin and containing the ellipsoid, the */
/* error SPICE(OBJECTSTOOCLOSE) is signaled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine models the boundaries of shadow regions on an */
/* ellipsoid "illuminated" by a spherical light source. Light rays */
/* are assumed to travel along straight lines; refraction is not */
/* modeled. */
/* Points on the ellipsoid at which the entire cap of the light */
/* source is visible are considered to be completely illuminated. */
/* Points on the ellipsoid at which some portion (or all) of the cap */
/* of the light source are blocked are considered to be in partial */
/* (or total) shadow. */
/* In this routine, we use the term "umbral terminator" to denote */
/* the curve ususally called the "terminator": this curve is the */
/* boundary of the portion of the surface that lies in total shadow. */
/* We use the term "penumbral terminator" to denote the boundary of */
/* the completely illuminated portion of the surface. */
/* In general, the terminator on an ellipsoid is a more complicated */
/* curve than the limb (which is always an ellipse). Aside from */
/* various special cases, the terminator does not lie in a plane. */
/* However, the condition for a point X on the ellipsoid to lie on */
/* the terminator is simple: a plane tangent to the ellipsoid at X */
/* must also be tangent to the light source. If this tangent plane */
/* does not intersect the vector from the center of the ellipsoid to */
/* the center of the light source, then X lies on the umbral */
/* terminator; otherwise X lies on the penumbral terminator. */
/* $ Examples */
/* See the SPICELIB routine EDTERM. */
/* $ Restrictions */
/* This is a private SPICELIB routine. User applications should not */
/* call this routine. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.0, 24-APR-2012 (NJB) */
/* Deleted computations of unused quantities */
/* MAXANG and MINANG. */
/* - SPICELIB Version 1.0.0, 03-FEB-2007 (NJB) */
/* -& */
/* $ Index_Entries */
/* find terminator on ellipsoid */
/* find umbral terminator on ellipsoid */
/* find penumbral terminator on ellipsoid */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICELIB error handling. */
/* Parameter adjustments */
trmpts_dim2 = *npts;
/* Function Body */
if (return_()) {
return 0;
}
chkin_("ZZEDTERM", (ftnlen)8);
/* Check the terminator type. */
ljust_(type__, loctyp, type_len, (ftnlen)50);
ucase_(loctyp, loctyp, (ftnlen)50, (ftnlen)50);
if (s_cmp(loctyp, "UMBRAL", (ftnlen)50, (ftnlen)6) == 0) {
umbral = TRUE_;
} else if (s_cmp(loctyp, "PENUMBRAL", (ftnlen)50, (ftnlen)9) == 0) {
umbral = FALSE_;
} else {
setmsg_("Terminator type must be UMBRAL or PENUMBRAL but was actuall"
"y #.", (ftnlen)63);
errch_("#", type__, (ftnlen)1, type_len);
sigerr_("SPICE(NOTSUPPORTED)", (ftnlen)19);
chkout_("ZZEDTERM", (ftnlen)8);
return 0;
}
/* Check the terminator set dimension. */
if (*npts < 1) {
setmsg_("Set must contain at least one point; NPTS = #.", (ftnlen)47)
;
errint_("#", npts, (ftnlen)1);
sigerr_("SPICE(INVALIDSIZE)", (ftnlen)18);
chkout_("ZZEDTERM", (ftnlen)8);
return 0;
}
/* The ellipsoid semi-axes must have positive length. */
if (*a <= 0. || *b <= 0. || *c__ <= 0.) {
setmsg_("Semi-axis lengths: A = #, B = #, C = #. ", (ftnlen)41);
errdp_("#", a, (ftnlen)1);
errdp_("#", b, (ftnlen)1);
errdp_("#", c__, (ftnlen)1);
sigerr_("SPICE(INVALIDAXISLENGTH)", (ftnlen)24);
chkout_("ZZEDTERM", (ftnlen)8);
return 0;
}
/* Check the input light source radius. */
if (*srcrad <= 0.) {
setmsg_("Light source must have positive radius; actual radius was #."
, (ftnlen)60);
errdp_("#", srcrad, (ftnlen)1);
sigerr_("SPICE(INVALIDRADIUS)", (ftnlen)20);
chkout_("ZZEDTERM", (ftnlen)8);
return 0;
}
/* The light source must not intersect the outer bounding */
/* sphere of the ellipsoid. */
d__ = vnorm_(srcpos);
/* Computing MAX */
d__1 = max(*a,*b);
rmax = max(d__1,*c__);
/* Computing MIN */
d__1 = min(*a,*b);
rmin = min(d__1,*c__);
if (*srcrad + rmax >= d__) {
/* The light source is too close. */
setmsg_("Light source intersects outer bounding sphere of the ellips"
"oid. Light source radius = #; ellipsoid's longest axis = #;"
" sum = #; distance between centers = #.", (ftnlen)158);
errdp_("#", srcrad, (ftnlen)1);
errdp_("#", &rmax, (ftnlen)1);
d__1 = *srcrad + rmax;
errdp_("#", &d__1, (ftnlen)1);
errdp_("#", &d__, (ftnlen)1);
sigerr_("SPICE(OBJECTSTOOCLOSE)", (ftnlen)22);
chkout_("ZZEDTERM", (ftnlen)8);
return 0;
}
/* Let the negative of the ellipsoid-light source vector be the */
/* Z-axis of a frame we'll use to generate the terminator set. */
vminus_(srcpos, z__);
frame_(z__, x, y);
/* Create the rotation matrix required to convert vectors */
/* from the source-centered frame back to the target body-fixed */
/* frame. */
vequ_(x, trans);
vequ_(y, &trans[3]);
vequ_(z__, &trans[6]);
/* Find the maximum and minimum target radii. */
/* Computing MAX */
d__1 = max(*a,*b);
maxrad = max(d__1,*c__);
/* Computing MIN */
d__1 = min(*a,*b);
minrad = min(d__1,*c__);
if (umbral) {
/* Compute the angular offsets from the axis of rays tangent to */
/* both the source and the bounding spheres of the target, where */
/* the tangency points lie in a half-plane bounded by the line */
/* containing the origin and SRCPOS. (We'll call this line */
/* the "axis.") */
/* OUTANG corresponds to the target's outer bounding sphere; */
/* INANG to the inner bounding sphere. */
outang = asin((*srcrad - maxrad) / d__);
inang = asin((*srcrad - minrad) / d__);
} else {
/* Compute the angular offsets from the axis of rays tangent to */
/* both the source and the bounding spheres of the target, where */
/* the tangency points lie in opposite half-planes bounded by the */
/* axis (compare the case above). */
/* OUTANG corresponds to the target's outer bounding sphere; */
/* INANG to the inner bounding sphere. */
outang = asin((*srcrad + maxrad) / d__);
inang = asin((*srcrad + minrad) / d__);
}
/* Compute the angular delta we'll use for generating */
/* terminator points. */
delta = twopi_() / *npts;
/* Generate the terminator points. */
i__1 = *npts;
for (i__ = 1; i__ <= i__1; ++i__) {
theta = (i__ - 1) * delta;
/* Let SRCPT be the surface point on the source lying in */
/* the X-Y plane of the frame produced by FRAME */
/* and corresponding to the angle THETA. */
latrec_(srcrad, &theta, &c_b30, srcpt);
/* Now solve for the angle by which SRCPT must be rotated (toward */
/* +Z in the umbral case, away from +Z in the penumbral case) */
/* so that a plane tangent to the source at SRCPT is also tangent */
/* to the target. The rotation is bracketed by OUTANG on the low */
/* side and INANG on the high side in the umbral case; the */
/* bracketing values are reversed in the penumbral case. */
if (umbral) {
angle = outang;
} else {
angle = inang;
}
prvdif = twopi_();
prvang = angle + halfpi_();
nitr = 0;
for(;;) { /* while(complicated condition) */
d__2 = (d__1 = angle - prvang, abs(d__1));
if (!(nitr <= 10 && touchd_(&d__2) < prvdif))
break;
++nitr;
d__2 = (d__1 = angle - prvang, abs(d__1));
prvdif = touchd_(&d__2);
prvang = angle;
/* Find the closest point on the ellipsoid to the plane */
/* corresponding to "ANGLE". */
/* The tangent point on the source is obtained by rotating */
/* SRCPT by ANGLE towards +Z. The plane's normal vector is */
/* parallel to VTX in the source-centered frame. */
latrec_(srcrad, &theta, &angle, vtx);
vequ_(vtx, dir);
/* VTX and DIR are expressed in the source-centered frame. We */
/* must translate VTX to the target frame and rotate both */
/* vectors into that frame. */
mxv_(trans, vtx, vtemp);
vadd_(srcpos, vtemp, vtx);
mxv_(trans, dir, vtemp);
vequ_(vtemp, dir);
/* Create the plane defined by VTX and DIR. */
nvp2pl_(dir, vtx, plane);
/* Find the closest point on the ellipsoid to the plane. At */
/* the point we seek, the outward normal on the ellipsoid is */
/* parallel to the choice of plane normal that points away */
/* from the origin. We can always obtain this choice from */
/* PL2NVC. */
pl2nvc_(plane, dir, &plcons);
/* At the point */
/* E = (x, y, z) */
/* on the ellipsoid's surface, an outward normal */
/* is */
/* N = ( x/A**2, y/B**2, z/C**2 ) */
/* which is also */
/* lambda * ( DIR(1), DIR(2), DIR(3) ) */
/* Equating components in the normal vectors yields */
/* E = lambda * ( DIR(1)*A**2, DIR(2)*B**2, DIR(3)*C**2 ) */
/* Taking the inner product with the point E itself and */
/* applying the ellipsoid equation, we find */
/* lambda * <DIR, E> = < N, E > = 1 */
/* The first term above is */
/* lambda**2 * || ( A*DIR(1), B*DIR(2), C*DIR(3) ) ||**2 */
/* So the positive root lambda is */
/* 1 / || ( A*DIR(1), B*DIR(2), C*DIR(3) ) || */
/* Having lambda we can compute E. */
d__1 = *a * dir[0];
d__2 = *b * dir[1];
d__3 = *c__ * dir[2];
vpack_(&d__1, &d__2, &d__3, v);
lambda = 1. / vnorm_(v);
d__1 = *a * v[0];
d__2 = *b * v[1];
d__3 = *c__ * v[2];
vpack_(&d__1, &d__2, &d__3, e);
vscl_(&lambda, e, &trmpts[(i__2 = i__ * 3 - 3) < trmpts_dim2 * 3
&& 0 <= i__2 ? i__2 : s_rnge("trmpts", i__2, "zzedterm_",
(ftnlen)582)]);
/* Make a new estimate of the plane rotation required to touch */
/* the target. */
vsub_(&trmpts[(i__2 = i__ * 3 - 3) < trmpts_dim2 * 3 && 0 <= i__2
? i__2 : s_rnge("trmpts", i__2, "zzedterm_", (ftnlen)588)]
, vtx, offset);
/* Let ANGERR be an estimate of the magnitude of angular error */
/* between the plane and the terminator. */
angerr = vsep_(dir, offset) - halfpi_();
/* Let S indicate the sign of the altitude error: where */
/* S is positive, the plane is above E. */
d__1 = vdot_(e, dir);
s = d_sign(&c_b35, &d__1);
if (umbral) {
/* If the plane is above the target, increase the */
/* rotation angle; otherwise decrease the angle. */
angle += s * angerr;
} else {
/* This is the penumbral case; decreasing the angle */
/* "lowers" the plane toward the target. */
angle -= s * angerr;
}
}
}
chkout_("ZZEDTERM", (ftnlen)8);
return 0;
} /* zzedterm_ */
/* Subroutine */ int dlalsd_(char *uplo, integer *smlsiz, integer *n, integer
*nrhs, doublereal *d__, doublereal *e, doublereal *b, integer *ldb,
doublereal *rcond, integer *rank, doublereal *work, integer *iwork,
integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double log(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
static integer difl, difr, perm, nsub;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
static integer nlvl, sqre, bxst, c__, i__, j, k;
static doublereal r__;
static integer s, u;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
static integer z__;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer poles, sizei, nsize, nwork, icmpq1, icmpq2;
static doublereal cs;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlasda_(integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *);
static integer bx;
extern /* Subroutine */ int dlalsa_(integer *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *);
static doublereal sn;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
static integer st;
extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer
*, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *);
static integer vt;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), dlaset_(char *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *), xerbla_(char *,
integer *);
static integer givcol;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *);
static doublereal orgnrm;
static integer givnum, givptr, nm1, smlszp, st1;
static doublereal eps;
static integer iwk;
static doublereal tol;
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1999
Purpose
=======
DLALSD uses the singular value decomposition of A to solve the least
squares problem of finding X to minimize the Euclidean norm of each
column of A*X-B, where A is N-by-N upper bidiagonal, and X and B
are N-by-NRHS. The solution X overwrites B.
The singular values of A smaller than RCOND times the largest
singular value are treated as zero in solving the least squares
problem; in this case a minimum norm solution is returned.
The actual singular values are returned in D in ascending order.
This code makes very mild assumptions about floating point
arithmetic. It will work on machines with a guard digit in
add/subtract, or on those binary machines without guard digits
which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
It could conceivably fail on hexadecimal or decimal machines
without guard digits, but we know of none.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': D and E define an upper bidiagonal matrix.
= 'L': D and E define a lower bidiagonal matrix.
SMLSIZ (input) INTEGER
The maximum size of the subproblems at the bottom of the
computation tree.
N (input) INTEGER
The dimension of the bidiagonal matrix. N >= 0.
NRHS (input) INTEGER
The number of columns of B. NRHS must be at least 1.
D (input/output) DOUBLE PRECISION array, dimension (N)
On entry D contains the main diagonal of the bidiagonal
matrix. On exit, if INFO = 0, D contains its singular values.
E (input) DOUBLE PRECISION array, dimension (N-1)
Contains the super-diagonal entries of the bidiagonal matrix.
On exit, E has been destroyed.
B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
On input, B contains the right hand sides of the least
squares problem. On output, B contains the solution X.
LDB (input) INTEGER
The leading dimension of B in the calling subprogram.
LDB must be at least max(1,N).
RCOND (input) DOUBLE PRECISION
The singular values of A less than or equal to RCOND times
the largest singular value are treated as zero in solving
the least squares problem. If RCOND is negative,
machine precision is used instead.
For example, if diag(S)*X=B were the least squares problem,
where diag(S) is a diagonal matrix of singular values, the
solution would be X(i) = B(i) / S(i) if S(i) is greater than
RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to
RCOND*max(S).
RANK (output) INTEGER
The number of singular values of A greater than RCOND times
the largest singular value.
WORK (workspace) DOUBLE PRECISION array, dimension at least
(9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),
where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).
IWORK (workspace) INTEGER array, dimension at least
(3*N*NLVL + 11*N)
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: The algorithm failed to compute an singular value while
working on the submatrix lying in rows and columns
INFO/(N+1) through MOD(INFO,N+1).
Further Details
===============
Based on contributions by
Ming Gu and Ren-Cang Li, Computer Science Division, University of
California at Berkeley, USA
Osni Marques, LBNL/NERSC, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--e;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -3;
} else if (*nrhs < 1) {
*info = -4;
} else if (*ldb < 1 || *ldb < *n) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLALSD", &i__1);
return 0;
}
eps = dlamch_("Epsilon");
/* Set up the tolerance. */
if (*rcond <= 0. || *rcond >= 1.) {
*rcond = eps;
}
*rank = 0;
/* Quick return if possible. */
if (*n == 0) {
return 0;
} else if (*n == 1) {
if (d__[1] == 0.) {
dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb);
} else {
*rank = 1;
dlascl_("G", &c__0, &c__0, &d__[1], &c_b11, &c__1, nrhs, &b[
b_offset], ldb, info);
d__[1] = abs(d__[1]);
}
return 0;
}
/* Rotate the matrix if it is lower bidiagonal. */
if (*(unsigned char *)uplo == 'L') {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
if (*nrhs == 1) {
drot_(&c__1, &b_ref(i__, 1), &c__1, &b_ref(i__ + 1, 1), &c__1,
&cs, &sn);
} else {
work[(i__ << 1) - 1] = cs;
work[i__ * 2] = sn;
}
/* L10: */
}
if (*nrhs > 1) {
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n - 1;
for (j = 1; j <= i__2; ++j) {
cs = work[(j << 1) - 1];
sn = work[j * 2];
drot_(&c__1, &b_ref(j, i__), &c__1, &b_ref(j + 1, i__), &
c__1, &cs, &sn);
/* L20: */
}
/* L30: */
}
}
}
/* Scale. */
nm1 = *n - 1;
orgnrm = dlanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.) {
dlaset_("A", n, nrhs, &c_b6, &c_b6, &b[b_offset], ldb);
return 0;
}
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, &c__1, &d__[1], n, info);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, &nm1, &c__1, &e[1], &nm1,
info);
/* If N is smaller than the minimum divide size SMLSIZ, then solve
the problem with another solver. */
if (*n <= *smlsiz) {
nwork = *n * *n + 1;
dlaset_("A", n, n, &c_b6, &c_b11, &work[1], n);
dlasdq_("U", &c__0, n, n, &c__0, nrhs, &d__[1], &e[1], &work[1], n, &
work[1], n, &b[b_offset], ldb, &work[nwork], info);
if (*info != 0) {
return 0;
}
tol = *rcond * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1));
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] <= tol) {
dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b_ref(i__, 1), ldb);
} else {
dlascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &
b_ref(i__, 1), ldb, info);
++(*rank);
}
/* L40: */
}
dgemm_("T", "N", n, nrhs, n, &c_b11, &work[1], n, &b[b_offset], ldb, &
c_b6, &work[nwork], n);
dlacpy_("A", n, nrhs, &work[nwork], n, &b[b_offset], ldb);
/* Unscale. */
dlascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n,
info);
dlasrt_("D", n, &d__[1], info);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset],
ldb, info);
return 0;
}
/* Book-keeping and setting up some constants. */
nlvl = (integer) (log((doublereal) (*n) / (doublereal) (*smlsiz + 1)) /
log(2.)) + 1;
smlszp = *smlsiz + 1;
u = 1;
vt = *smlsiz * *n + 1;
difl = vt + smlszp * *n;
difr = difl + nlvl * *n;
z__ = difr + (nlvl * *n << 1);
c__ = z__ + nlvl * *n;
s = c__ + *n;
poles = s + *n;
givnum = poles + (nlvl << 1) * *n;
bx = givnum + (nlvl << 1) * *n;
nwork = bx + *n * *nrhs;
sizei = *n + 1;
k = sizei + *n;
givptr = k + *n;
perm = givptr + *n;
givcol = perm + nlvl * *n;
iwk = givcol + (nlvl * *n << 1);
st = 1;
sqre = 0;
icmpq1 = 1;
icmpq2 = 0;
nsub = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = d__[i__], abs(d__1)) < eps) {
d__[i__] = d_sign(&eps, &d__[i__]);
}
/* L50: */
}
i__1 = nm1;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) {
++nsub;
iwork[nsub] = st;
/* Subproblem found. First determine its size and then
apply divide and conquer on it. */
if (i__ < nm1) {
/* A subproblem with E(I) small for I < NM1. */
nsize = i__ - st + 1;
iwork[sizei + nsub - 1] = nsize;
} else if ((d__1 = e[i__], abs(d__1)) >= eps) {
/* A subproblem with E(NM1) not too small but I = NM1. */
nsize = *n - st + 1;
iwork[sizei + nsub - 1] = nsize;
} else {
/* A subproblem with E(NM1) small. This implies an
1-by-1 subproblem at D(N), which is not solved
explicitly. */
nsize = i__ - st + 1;
iwork[sizei + nsub - 1] = nsize;
++nsub;
iwork[nsub] = *n;
iwork[sizei + nsub - 1] = 1;
dcopy_(nrhs, &b_ref(*n, 1), ldb, &work[bx + nm1], n);
}
st1 = st - 1;
if (nsize == 1) {
/* This is a 1-by-1 subproblem and is not solved
explicitly. */
dcopy_(nrhs, &b_ref(st, 1), ldb, &work[bx + st1], n);
} else if (nsize <= *smlsiz) {
/* This is a small subproblem and is solved by DLASDQ. */
dlaset_("A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1],
n);
dlasdq_("U", &c__0, &nsize, &nsize, &c__0, nrhs, &d__[st], &e[
st], &work[vt + st1], n, &work[nwork], n, &b_ref(st,
1), ldb, &work[nwork], info);
if (*info != 0) {
return 0;
}
dlacpy_("A", &nsize, nrhs, &b_ref(st, 1), ldb, &work[bx + st1]
, n);
} else {
/* A large problem. Solve it using divide and conquer. */
dlasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], &
work[u + st1], n, &work[vt + st1], &iwork[k + st1], &
work[difl + st1], &work[difr + st1], &work[z__ + st1],
&work[poles + st1], &iwork[givptr + st1], &iwork[
givcol + st1], n, &iwork[perm + st1], &work[givnum +
st1], &work[c__ + st1], &work[s + st1], &work[nwork],
&iwork[iwk], info);
if (*info != 0) {
return 0;
}
bxst = bx + st1;
dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b_ref(st, 1), ldb, &
work[bxst], n, &work[u + st1], n, &work[vt + st1], &
iwork[k + st1], &work[difl + st1], &work[difr + st1],
&work[z__ + st1], &work[poles + st1], &iwork[givptr +
st1], &iwork[givcol + st1], n, &iwork[perm + st1], &
work[givnum + st1], &work[c__ + st1], &work[s + st1],
&work[nwork], &iwork[iwk], info);
if (*info != 0) {
return 0;
}
}
st = i__ + 1;
}
/* L60: */
}
/* Apply the singular values and treat the tiny ones as zero. */
tol = *rcond * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1));
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Some of the elements in D can be negative because 1-by-1
subproblems were not solved explicitly. */
if ((d__1 = d__[i__], abs(d__1)) <= tol) {
dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n);
} else {
++(*rank);
dlascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[
bx + i__ - 1], n, info);
}
d__[i__] = (d__1 = d__[i__], abs(d__1));
/* L70: */
}
/* Now apply back the right singular vectors. */
icmpq2 = 1;
i__1 = nsub;
for (i__ = 1; i__ <= i__1; ++i__) {
st = iwork[i__];
st1 = st - 1;
nsize = iwork[sizei + i__ - 1];
bxst = bx + st1;
if (nsize == 1) {
dcopy_(nrhs, &work[bxst], n, &b_ref(st, 1), ldb);
} else if (nsize <= *smlsiz) {
dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b11, &work[vt + st1], n,
&work[bxst], n, &c_b6, &b_ref(st, 1), ldb);
} else {
dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b_ref(st,
1), ldb, &work[u + st1], n, &work[vt + st1], &iwork[k +
st1], &work[difl + st1], &work[difr + st1], &work[z__ +
st1], &work[poles + st1], &iwork[givptr + st1], &iwork[
givcol + st1], n, &iwork[perm + st1], &work[givnum + st1],
&work[c__ + st1], &work[s + st1], &work[nwork], &iwork[
iwk], info);
if (*info != 0) {
return 0;
}
}
/* L80: */
}
/* Unscale and sort the singular values. */
dlascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info);
dlasrt_("D", n, &d__[1], info);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb,
info);
return 0;
/* End of DLALSD */
} /* dlalsd_ */
/* Subroutine */ int dlarfp_(integer *n, doublereal *alpha, doublereal *x,
integer *incx, doublereal *tau)
{
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
double d_sign(doublereal *, doublereal *);
/* Local variables */
integer j, knt;
doublereal beta;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
doublereal xnorm;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
doublereal safmin, rsafmn;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLARFP generates a real elementary reflector H of order n, such */
/* that */
/* H * ( alpha ) = ( beta ), H' * H = I. */
/* ( x ) ( 0 ) */
/* where alpha and beta are scalars, beta is non-negative, and x is */
/* an (n-1)-element real vector. H is represented in the form */
/* H = I - tau * ( 1 ) * ( 1 v' ) , */
/* ( v ) */
/* where tau is a real scalar and v is a real (n-1)-element */
/* vector. */
/* If the elements of x are all zero, then tau = 0 and H is taken to be */
/* the unit matrix. */
/* Otherwise 1 <= tau <= 2. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the elementary reflector. */
/* ALPHA (input/output) DOUBLE PRECISION */
/* On entry, the value alpha. */
/* On exit, it is overwritten with the value beta. */
/* X (input/output) DOUBLE PRECISION array, dimension */
/* (1+(N-2)*abs(INCX)) */
/* On entry, the vector x. */
/* On exit, it is overwritten with the vector v. */
/* INCX (input) INTEGER */
/* The increment between elements of X. INCX > 0. */
/* TAU (output) DOUBLE PRECISION */
/* The value tau. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 0) {
*tau = 0.;
return 0;
}
i__1 = *n - 1;
xnorm = dnrm2_(&i__1, &x[1], incx);
if (xnorm == 0.) {
/* H = [+/-1, 0; I], sign chosen so ALPHA >= 0 */
if (*alpha >= 0.) {
/* When TAU.eq.ZERO, the vector is special-cased to be */
/* all zeros in the application routines. We do not need */
/* to clear it. */
*tau = 0.;
} else {
/* However, the application routines rely on explicit */
/* zero checks when TAU.ne.ZERO, and we must clear X. */
*tau = 2.;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
x[(j - 1) * *incx + 1] = 0.;
}
*alpha = -(*alpha);
}
} else {
/* general case */
d__1 = dlapy2_(alpha, &xnorm);
beta = d_sign(&d__1, alpha);
safmin = dlamch_("S") / dlamch_("E");
knt = 0;
if (abs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute them */
rsafmn = 1. / safmin;
L10:
++knt;
i__1 = *n - 1;
dscal_(&i__1, &rsafmn, &x[1], incx);
beta *= rsafmn;
*alpha *= rsafmn;
if (abs(beta) < safmin) {
goto L10;
}
/* New BETA is at most 1, at least SAFMIN */
i__1 = *n - 1;
xnorm = dnrm2_(&i__1, &x[1], incx);
d__1 = dlapy2_(alpha, &xnorm);
beta = d_sign(&d__1, alpha);
}
*alpha += beta;
if (beta < 0.) {
beta = -beta;
*tau = -(*alpha) / beta;
} else {
*alpha = xnorm * (xnorm / *alpha);
*tau = *alpha / beta;
*alpha = -(*alpha);
}
i__1 = *n - 1;
d__1 = 1. / *alpha;
dscal_(&i__1, &d__1, &x[1], incx);
/* If BETA is subnormal, it may lose relative accuracy */
i__1 = knt;
for (j = 1; j <= i__1; ++j) {
beta *= safmin;
/* L20: */
}
*alpha = beta;
}
return 0;
/* End of DLARFP */
} /* dlarfp_ */
/* DECK DFZERO */
/* Subroutine */ int dfzero_(D_fp f, doublereal *b, doublereal *c__,
doublereal *r__, doublereal *re, doublereal *ae, integer *iflag)
{
/* System generated locals */
doublereal d__1, d__2;
/* Local variables */
static doublereal a, p, q, t, z__, fa, fb, fc;
static integer ic;
static doublereal aw, er, fx, fz, rw, cmb, tol, acmb, acbs;
extern doublereal d1mach_(integer *);
static integer kount;
/* ***BEGIN PROLOGUE DFZERO */
/* ***PURPOSE Search for a zero of a function F(X) in a given interval */
/* (B,C). It is designed primarily for problems where F(B) */
/* and F(C) have opposite signs. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY F1B */
/* ***TYPE DOUBLE PRECISION (FZERO-S, DFZERO-D) */
/* ***KEYWORDS BISECTION, NONLINEAR, ROOTS, ZEROS */
/* ***AUTHOR Shampine, L. F., (SNLA) */
/* Watts, H. A., (SNLA) */
/* ***DESCRIPTION */
/* DFZERO searches for a zero of a DOUBLE PRECISION function F(X) */
/* between the given DOUBLE PRECISION values B and C until the width */
/* of the interval (B,C) has collapsed to within a tolerance */
/* specified by the stopping criterion, */
/* ABS(B-C) .LE. 2.*(RW*ABS(B)+AE). */
/* The method used is an efficient combination of bisection and the */
/* secant rule and is due to T. J. Dekker. */
/* Description Of Arguments */
/* F :EXT - Name of the DOUBLE PRECISION external function. This */
/* name must be in an EXTERNAL statement in the calling */
/* program. F must be a function of one DOUBLE */
/* PRECISION argument. */
/* B :INOUT - One end of the DOUBLE PRECISION interval (B,C). The */
/* value returned for B usually is the better */
/* approximation to a zero of F. */
/* C :INOUT - The other end of the DOUBLE PRECISION interval (B,C) */
/* R :IN - A (better) DOUBLE PRECISION guess of a zero of F */
/* which could help in speeding up convergence. If F(B) */
/* and F(R) have opposite signs, a root will be found in */
/* the interval (B,R); if not, but F(R) and F(C) have */
/* opposite signs, a root will be found in the interval */
/* (R,C); otherwise, the interval (B,C) will be */
/* searched for a possible root. When no better guess */
/* is known, it is recommended that R be set to B or C, */
/* since if R is not interior to the interval (B,C), it */
/* will be ignored. */
/* RE :IN - Relative error used for RW in the stopping criterion. */
/* If the requested RE is less than machine precision, */
/* then RW is set to approximately machine precision. */
/* AE :IN - Absolute error used in the stopping criterion. If */
/* the given interval (B,C) contains the origin, then a */
/* nonzero value should be chosen for AE. */
/* IFLAG :OUT - A status code. User must check IFLAG after each */
/* call. Control returns to the user from DFZERO in all */
/* cases. */
/* 1 B is within the requested tolerance of a zero. */
/* The interval (B,C) collapsed to the requested */
/* tolerance, the function changes sign in (B,C), and */
/* F(X) decreased in magnitude as (B,C) collapsed. */
/* 2 F(B) = 0. However, the interval (B,C) may not have */
/* collapsed to the requested tolerance. */
/* 3 B may be near a singular point of F(X). */
/* The interval (B,C) collapsed to the requested tol- */
/* erance and the function changes sign in (B,C), but */
/* F(X) increased in magnitude as (B,C) collapsed, i.e. */
/* ABS(F(B out)) .GT. MAX(ABS(F(B in)),ABS(F(C in))) */
/* 4 No change in sign of F(X) was found although the */
/* interval (B,C) collapsed to the requested tolerance. */
/* The user must examine this case and decide whether */
/* B is near a local minimum of F(X), or B is near a */
/* zero of even multiplicity, or neither of these. */
/* 5 Too many (.GT. 500) function evaluations used. */
/* ***REFERENCES L. F. Shampine and H. A. Watts, FZERO, a root-solving */
/* code, Report SC-TM-70-631, Sandia Laboratories, */
/* September 1970. */
/* T. J. Dekker, Finding a zero by means of successive */
/* linear interpolation, Constructive Aspects of the */
/* Fundamental Theorem of Algebra, edited by B. Dejon */
/* and P. Henrici, Wiley-Interscience, 1969. */
/* ***ROUTINES CALLED D1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 700901 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890531 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE DFZERO */
/* ***FIRST EXECUTABLE STATEMENT DFZERO */
/* ER is two times the computer unit roundoff value which is defined */
/* here by the function D1MACH. */
er = d1mach_(&c__4) * 2.;
/* Initialize. */
z__ = *r__;
if (*r__ <= min(*b,*c__) || *r__ >= max(*b,*c__)) {
z__ = *c__;
}
rw = max(*re,er);
aw = max(*ae,0.);
ic = 0;
t = z__;
fz = (*f)(&t);
fc = fz;
t = *b;
fb = (*f)(&t);
kount = 2;
if (d_sign(&c_b3, &fz) == d_sign(&c_b3, &fb)) {
goto L1;
}
*c__ = z__;
goto L2;
L1:
if (z__ == *c__) {
goto L2;
}
t = *c__;
fc = (*f)(&t);
kount = 3;
if (d_sign(&c_b3, &fz) == d_sign(&c_b3, &fc)) {
goto L2;
}
*b = z__;
fb = fz;
L2:
a = *c__;
fa = fc;
acbs = (d__1 = *b - *c__, abs(d__1));
/* Computing MAX */
d__1 = abs(fb), d__2 = abs(fc);
fx = max(d__1,d__2);
L3:
if (abs(fc) >= abs(fb)) {
goto L4;
}
/* Perform interchange. */
a = *b;
fa = fb;
*b = *c__;
fb = fc;
*c__ = a;
fc = fa;
L4:
cmb = (*c__ - *b) * .5;
acmb = abs(cmb);
tol = rw * abs(*b) + aw;
/* Test stopping criterion and function count. */
if (acmb <= tol) {
goto L10;
}
if (fb == 0.) {
goto L11;
}
if (kount >= 500) {
goto L14;
}
/* Calculate new iterate implicitly as B+P/Q, where we arrange */
/* P .GE. 0. The implicit form is used to prevent overflow. */
p = (*b - a) * fb;
q = fa - fb;
if (p >= 0.) {
goto L5;
}
p = -p;
q = -q;
/* Update A and check for satisfactory reduction in the size of the */
/* bracketing interval. If not, perform bisection. */
L5:
a = *b;
fa = fb;
++ic;
if (ic < 4) {
goto L6;
}
if (acmb * 8. >= acbs) {
goto L8;
}
ic = 0;
acbs = acmb;
/* Test for too small a change. */
L6:
if (p > abs(q) * tol) {
goto L7;
}
/* Increment by TOLerance. */
*b += d_sign(&tol, &cmb);
goto L9;
/* Root ought to be between B and (C+B)/2. */
L7:
if (p >= cmb * q) {
goto L8;
}
/* Use secant rule. */
*b += p / q;
goto L9;
/* Use bisection (C+B)/2. */
L8:
*b += cmb;
/* Have completed computation for new iterate B. */
L9:
t = *b;
fb = (*f)(&t);
++kount;
/* Decide whether next step is interpolation or extrapolation. */
if (d_sign(&c_b3, &fb) != d_sign(&c_b3, &fc)) {
goto L3;
}
*c__ = a;
fc = fa;
goto L3;
/* Finished. Process results for proper setting of IFLAG. */
L10:
if (d_sign(&c_b3, &fb) == d_sign(&c_b3, &fc)) {
goto L13;
}
if (abs(fb) > fx) {
goto L12;
}
*iflag = 1;
return 0;
L11:
*iflag = 2;
return 0;
L12:
*iflag = 3;
return 0;
L13:
*iflag = 4;
return 0;
L14:
*iflag = 5;
return 0;
} /* dfzero_ */
/* Subroutine */
int dggbal_(char *job, integer *n, doublereal *a, integer * lda, doublereal *b, integer *ldb, integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale, doublereal *work, integer * info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double d_lg10(doublereal *), d_sign(doublereal *, doublereal *), pow_di( doublereal *, integer *);
/* Local variables */
integer i__, j, k, l, m;
doublereal t;
integer jc;
doublereal ta, tb, tc;
integer ir;
doublereal ew;
integer it, nr, ip1, jp1, lm1;
doublereal cab, rab, ewc, cor, sum;
integer nrp2, icab, lcab;
doublereal beta, coef;
integer irab, lrab;
doublereal basl, cmax;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *);
doublereal coef2, coef5, gamma, alpha;
extern /* Subroutine */
int dscal_(integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
doublereal sfmin, sfmax;
extern /* Subroutine */
int dswap_(integer *, doublereal *, integer *, doublereal *, integer *);
integer iflow;
extern /* Subroutine */
int daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *);
integer kount;
extern doublereal dlamch_(char *);
doublereal pgamma;
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */
int xerbla_(char *, integer *);
integer lsfmin, lsfmax;
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--lscale;
--rscale;
--work;
/* Function Body */
*info = 0;
if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S") && ! lsame_(job, "B"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*lda < max(1,*n))
{
*info = -4;
}
else if (*ldb < max(1,*n))
{
*info = -6;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DGGBAL", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
*ilo = 1;
*ihi = *n;
return 0;
}
if (*n == 1)
{
*ilo = 1;
*ihi = *n;
lscale[1] = 1.;
rscale[1] = 1.;
return 0;
}
if (lsame_(job, "N"))
{
*ilo = 1;
*ihi = *n;
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
lscale[i__] = 1.;
rscale[i__] = 1.;
/* L10: */
}
return 0;
}
k = 1;
l = *n;
if (lsame_(job, "S"))
{
goto L190;
}
goto L30;
/* Permute the matrices A and B to isolate the eigenvalues. */
/* Find row with one nonzero in columns 1 through L */
L20:
l = lm1;
if (l != 1)
{
goto L30;
}
rscale[1] = 1.;
lscale[1] = 1.;
goto L190;
L30:
lm1 = l - 1;
for (i__ = l;
i__ >= 1;
--i__)
{
i__1 = lm1;
for (j = 1;
j <= i__1;
++j)
{
jp1 = j + 1;
if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.)
{
goto L50;
}
/* L40: */
}
j = l;
goto L70;
L50:
i__1 = l;
for (j = jp1;
j <= i__1;
++j)
{
if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.)
{
goto L80;
}
/* L60: */
}
j = jp1 - 1;
L70:
m = l;
iflow = 1;
goto L160;
L80:
;
}
goto L100;
/* Find column with one nonzero in rows K through N */
L90:
++k;
L100:
i__1 = l;
for (j = k;
j <= i__1;
++j)
{
i__2 = lm1;
for (i__ = k;
i__ <= i__2;
++i__)
{
ip1 = i__ + 1;
if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.)
{
goto L120;
}
/* L110: */
}
i__ = l;
goto L140;
L120:
i__2 = l;
for (i__ = ip1;
i__ <= i__2;
++i__)
{
if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.)
{
goto L150;
}
/* L130: */
}
i__ = ip1 - 1;
L140:
m = k;
iflow = 2;
goto L160;
L150:
;
}
goto L190;
/* Permute rows M and I */
L160:
lscale[m] = (doublereal) i__;
if (i__ == m)
{
goto L170;
}
i__1 = *n - k + 1;
dswap_(&i__1, &a[i__ + k * a_dim1], lda, &a[m + k * a_dim1], lda);
i__1 = *n - k + 1;
dswap_(&i__1, &b[i__ + k * b_dim1], ldb, &b[m + k * b_dim1], ldb);
/* Permute columns M and J */
L170:
rscale[m] = (doublereal) j;
if (j == m)
{
goto L180;
}
dswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
dswap_(&l, &b[j * b_dim1 + 1], &c__1, &b[m * b_dim1 + 1], &c__1);
L180:
switch (iflow)
{
case 1:
goto L20;
case 2:
goto L90;
}
L190:
*ilo = k;
*ihi = l;
if (lsame_(job, "P"))
{
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
lscale[i__] = 1.;
rscale[i__] = 1.;
/* L195: */
}
return 0;
}
if (*ilo == *ihi)
{
return 0;
}
/* Balance the submatrix in rows ILO to IHI. */
nr = *ihi - *ilo + 1;
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
rscale[i__] = 0.;
lscale[i__] = 0.;
work[i__] = 0.;
work[i__ + *n] = 0.;
work[i__ + (*n << 1)] = 0.;
work[i__ + *n * 3] = 0.;
work[i__ + (*n << 2)] = 0.;
work[i__ + *n * 5] = 0.;
/* L200: */
}
/* Compute right side vector in resulting linear equations */
basl = d_lg10(&c_b35);
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
i__2 = *ihi;
for (j = *ilo;
j <= i__2;
++j)
{
tb = b[i__ + j * b_dim1];
ta = a[i__ + j * a_dim1];
if (ta == 0.)
{
goto L210;
}
d__1 = f2c_abs(ta);
ta = d_lg10(&d__1) / basl;
L210:
if (tb == 0.)
{
goto L220;
}
d__1 = f2c_abs(tb);
tb = d_lg10(&d__1) / basl;
L220:
work[i__ + (*n << 2)] = work[i__ + (*n << 2)] - ta - tb;
work[j + *n * 5] = work[j + *n * 5] - ta - tb;
/* L230: */
}
/* L240: */
}
coef = 1. / (doublereal) (nr << 1);
coef2 = coef * coef;
coef5 = coef2 * .5;
nrp2 = nr + 2;
beta = 0.;
it = 1;
/* Start generalized conjugate gradient iteration */
L250:
gamma = ddot_(&nr, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + (*n << 2)] , &c__1) + ddot_(&nr, &work[*ilo + *n * 5], &c__1, &work[*ilo + * n * 5], &c__1);
ew = 0.;
ewc = 0.;
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
ew += work[i__ + (*n << 2)];
ewc += work[i__ + *n * 5];
/* L260: */
}
/* Computing 2nd power */
d__1 = ew;
/* Computing 2nd power */
d__2 = ewc;
/* Computing 2nd power */
d__3 = ew - ewc;
gamma = coef * gamma - coef2 * (d__1 * d__1 + d__2 * d__2) - coef5 * ( d__3 * d__3);
if (gamma == 0.)
{
goto L350;
}
if (it != 1)
{
beta = gamma / pgamma;
}
t = coef5 * (ewc - ew * 3.);
tc = coef5 * (ew - ewc * 3.);
dscal_(&nr, &beta, &work[*ilo], &c__1);
dscal_(&nr, &beta, &work[*ilo + *n], &c__1);
daxpy_(&nr, &coef, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + *n], & c__1);
daxpy_(&nr, &coef, &work[*ilo + *n * 5], &c__1, &work[*ilo], &c__1);
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
work[i__] += tc;
work[i__ + *n] += t;
/* L270: */
}
/* Apply matrix to vector */
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
kount = 0;
sum = 0.;
i__2 = *ihi;
for (j = *ilo;
j <= i__2;
++j)
{
if (a[i__ + j * a_dim1] == 0.)
{
goto L280;
}
++kount;
sum += work[j];
L280:
if (b[i__ + j * b_dim1] == 0.)
{
goto L290;
}
++kount;
sum += work[j];
L290:
;
}
work[i__ + (*n << 1)] = (doublereal) kount * work[i__ + *n] + sum;
/* L300: */
}
i__1 = *ihi;
for (j = *ilo;
j <= i__1;
++j)
{
kount = 0;
sum = 0.;
i__2 = *ihi;
for (i__ = *ilo;
i__ <= i__2;
++i__)
{
if (a[i__ + j * a_dim1] == 0.)
{
goto L310;
}
++kount;
sum += work[i__ + *n];
L310:
if (b[i__ + j * b_dim1] == 0.)
{
goto L320;
}
++kount;
sum += work[i__ + *n];
L320:
;
}
work[j + *n * 3] = (doublereal) kount * work[j] + sum;
/* L330: */
}
sum = ddot_(&nr, &work[*ilo + *n], &c__1, &work[*ilo + (*n << 1)], &c__1) + ddot_(&nr, &work[*ilo], &c__1, &work[*ilo + *n * 3], &c__1);
alpha = gamma / sum;
/* Determine correction to current iteration */
cmax = 0.;
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
cor = alpha * work[i__ + *n];
if (f2c_abs(cor) > cmax)
{
cmax = f2c_abs(cor);
}
lscale[i__] += cor;
cor = alpha * work[i__];
if (f2c_abs(cor) > cmax)
{
cmax = f2c_abs(cor);
}
rscale[i__] += cor;
/* L340: */
}
if (cmax < .5)
{
goto L350;
}
d__1 = -alpha;
daxpy_(&nr, &d__1, &work[*ilo + (*n << 1)], &c__1, &work[*ilo + (*n << 2)] , &c__1);
d__1 = -alpha;
daxpy_(&nr, &d__1, &work[*ilo + *n * 3], &c__1, &work[*ilo + *n * 5], & c__1);
pgamma = gamma;
++it;
if (it <= nrp2)
{
goto L250;
}
/* End generalized conjugate gradient iteration */
L350:
sfmin = dlamch_("S");
sfmax = 1. / sfmin;
lsfmin = (integer) (d_lg10(&sfmin) / basl + 1.);
lsfmax = (integer) (d_lg10(&sfmax) / basl);
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
i__2 = *n - *ilo + 1;
irab = idamax_(&i__2, &a[i__ + *ilo * a_dim1], lda);
rab = (d__1 = a[i__ + (irab + *ilo - 1) * a_dim1], f2c_abs(d__1));
i__2 = *n - *ilo + 1;
irab = idamax_(&i__2, &b[i__ + *ilo * b_dim1], ldb);
/* Computing MAX */
d__2 = rab;
d__3 = (d__1 = b[i__ + (irab + *ilo - 1) * b_dim1], f2c_abs( d__1)); // , expr subst
rab = max(d__2,d__3);
d__1 = rab + sfmin;
lrab = (integer) (d_lg10(&d__1) / basl + 1.);
ir = (integer) (lscale[i__] + d_sign(&c_b71, &lscale[i__]));
/* Computing MIN */
i__2 = max(ir,lsfmin);
i__2 = min(i__2,lsfmax);
i__3 = lsfmax - lrab; // ; expr subst
ir = min(i__2,i__3);
lscale[i__] = pow_di(&c_b35, &ir);
icab = idamax_(ihi, &a[i__ * a_dim1 + 1], &c__1);
cab = (d__1 = a[icab + i__ * a_dim1], f2c_abs(d__1));
icab = idamax_(ihi, &b[i__ * b_dim1 + 1], &c__1);
/* Computing MAX */
d__2 = cab;
d__3 = (d__1 = b[icab + i__ * b_dim1], f2c_abs(d__1)); // , expr subst
cab = max(d__2,d__3);
d__1 = cab + sfmin;
lcab = (integer) (d_lg10(&d__1) / basl + 1.);
jc = (integer) (rscale[i__] + d_sign(&c_b71, &rscale[i__]));
/* Computing MIN */
i__2 = max(jc,lsfmin);
i__2 = min(i__2,lsfmax);
i__3 = lsfmax - lcab; // ; expr subst
jc = min(i__2,i__3);
rscale[i__] = pow_di(&c_b35, &jc);
/* L360: */
}
/* Row scaling of matrices A and B */
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
i__2 = *n - *ilo + 1;
dscal_(&i__2, &lscale[i__], &a[i__ + *ilo * a_dim1], lda);
i__2 = *n - *ilo + 1;
dscal_(&i__2, &lscale[i__], &b[i__ + *ilo * b_dim1], ldb);
/* L370: */
}
/* Column scaling of matrices A and B */
i__1 = *ihi;
for (j = *ilo;
j <= i__1;
++j)
{
dscal_(ihi, &rscale[j], &a[j * a_dim1 + 1], &c__1);
dscal_(ihi, &rscale[j], &b[j * b_dim1 + 1], &c__1);
/* L380: */
}
return 0;
/* End of DGGBAL */
}
int
slacon_(int *n, float *v, float *x, int *isgn, float *est, int *kase)
{
/*
Purpose
=======
SLACON estimates the 1-norm of a square matrix A.
Reverse communication is used for evaluating matrix-vector products.
Arguments
=========
N (input) INT
The order of the matrix. N >= 1.
V (workspace) FLOAT PRECISION array, dimension (N)
On the final return, V = A*W, where EST = norm(V)/norm(W)
(W is not returned).
X (input/output) FLOAT PRECISION array, dimension (N)
On an intermediate return, X should be overwritten by
A * X, if KASE=1,
A' * X, if KASE=2,
and SLACON must be re-called with all the other parameters
unchanged.
ISGN (workspace) INT array, dimension (N)
EST (output) FLOAT PRECISION
An estimate (a lower bound) for norm(A).
KASE (input/output) INT
On the initial call to SLACON, KASE should be 0.
On an intermediate return, KASE will be 1 or 2, indicating
whether X should be overwritten by A * X or A' * X.
On the final return from SLACON, KASE will again be 0.
Further Details
======= =======
Contributed by Nick Higham, University of Manchester.
Originally named CONEST, dated March 16, 1988.
Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
a real or complex matrix, with applications to condition estimation",
ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
=====================================================================
*/
/* Table of constant values */
int c__1 = 1;
float zero = 0.0;
float one = 1.0;
/* Local variables */
static int iter;
static int jump, jlast;
static float altsgn, estold;
static int i, j;
float temp;
#ifdef _CRAY
extern int ISAMAX(int *, float *, int *);
extern float SASUM(int *, float *, int *);
extern int SCOPY(int *, float *, int *, float *, int *);
#else
extern int isamax_(int *, float *, int *);
extern float sasum_(int *, float *, int *);
extern int scopy_(int *, float *, int *, float *, int *);
#endif
#define d_sign(a, b) (b >= 0 ? fabs(a) : -fabs(a)) /* Copy sign */
#define i_dnnt(a) \
( a>=0 ? floor(a+.5) : -floor(.5-a) ) /* Round to nearest integer */
if ( *kase == 0 ) {
for (i = 0; i < *n; ++i) {
x[i] = 1. / (float) (*n);
}
*kase = 1;
jump = 1;
return 0;
}
switch (jump) {
case 1: goto L20;
case 2: goto L40;
case 3: goto L70;
case 4: goto L110;
case 5: goto L140;
}
/* ................ ENTRY (JUMP = 1)
FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */
L20:
if (*n == 1) {
v[0] = x[0];
*est = fabs(v[0]);
/* ... QUIT */
goto L150;
}
#ifdef _CRAY
*est = SASUM(n, x, &c__1);
#else
*est = sasum_(n, x, &c__1);
#endif
for (i = 0; i < *n; ++i) {
x[i] = d_sign(one, x[i]);
isgn[i] = i_dnnt(x[i]);
}
*kase = 2;
jump = 2;
return 0;
/* ................ ENTRY (JUMP = 2)
FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
L40:
#ifdef _CRAY
j = ISAMAX(n, &x[0], &c__1);
#else
j = isamax_(n, &x[0], &c__1);
#endif
--j;
iter = 2;
/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */
L50:
for (i = 0; i < *n; ++i) x[i] = zero;
x[j] = one;
*kase = 1;
jump = 3;
return 0;
/* ................ ENTRY (JUMP = 3)
X HAS BEEN OVERWRITTEN BY A*X. */
L70:
#ifdef _CRAY
SCOPY(n, x, &c__1, v, &c__1);
#else
scopy_(n, x, &c__1, v, &c__1);
#endif
estold = *est;
#ifdef _CRAY
*est = SASUM(n, v, &c__1);
#else
*est = sasum_(n, v, &c__1);
#endif
for (i = 0; i < *n; ++i)
if (i_dnnt(d_sign(one, x[i])) != isgn[i])
goto L90;
/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
goto L120;
L90:
/* TEST FOR CYCLING. */
if (*est <= estold) goto L120;
for (i = 0; i < *n; ++i) {
x[i] = d_sign(one, x[i]);
isgn[i] = i_dnnt(x[i]);
}
*kase = 2;
jump = 4;
return 0;
/* ................ ENTRY (JUMP = 4)
X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. */
L110:
jlast = j;
#ifdef _CRAY
j = ISAMAX(n, &x[0], &c__1);
#else
j = isamax_(n, &x[0], &c__1);
#endif
--j;
if (x[jlast] != fabs(x[j]) && iter < 5) {
++iter;
goto L50;
}
/* ITERATION COMPLETE. FINAL STAGE. */
L120:
altsgn = 1.;
for (i = 1; i <= *n; ++i) {
x[i-1] = altsgn * ((float)(i - 1) / (float)(*n - 1) + 1.);
altsgn = -altsgn;
}
*kase = 1;
jump = 5;
return 0;
/* ................ ENTRY (JUMP = 5)
X HAS BEEN OVERWRITTEN BY A*X. */
L140:
#ifdef _CRAY
temp = SASUM(n, x, &c__1) / (float)(*n * 3) * 2.;
#else
temp = sasum_(n, x, &c__1) / (float)(*n * 3) * 2.;
#endif
if (temp > *est) {
#ifdef _CRAY
SCOPY(n, &x[0], &c__1, &v[0], &c__1);
#else
scopy_(n, &x[0], &c__1, &v[0], &c__1);
#endif
*est = temp;
}
L150:
*kase = 0;
return 0;
} /* slacon_ */
/* Subroutine */ int ddrges_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
doublereal *a, integer *lda, doublereal *b, doublereal *s, doublereal
*t, doublereal *q, integer *ldq, doublereal *z__, doublereal *alphar,
doublereal *alphai, doublereal *beta, doublereal *work, integer *
lwork, doublereal *result, logical *bwork, integer *info)
{
/* Initialized data */
static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
2,2,2,3 };
static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
2,3,2,1 };
static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
1,1,1,1 };
static integer iasign[26] = { 0,0,0,0,0,0,2,0,2,2,0,0,2,2,2,0,2,0,0,0,2,2,
2,2,2,0 };
static integer ibsign[26] = { 0,0,0,0,0,0,0,2,0,0,2,2,0,0,2,0,2,0,0,0,0,0,
0,0,0,0 };
static integer kz1[6] = { 0,1,2,1,3,3 };
static integer kz2[6] = { 0,0,1,2,1,1 };
static integer kadd[6] = { 0,0,0,0,3,2 };
static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
4,4,4,0 };
static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
8,8,8,8,8,0 };
static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
3,3,3,1 };
static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
4,4,4,1 };
static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
3,3,2,1 };
/* Format strings */
static char fmt_9999[] = "(\002 DDRGES: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,4(i4,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 DDRGES: DGET53 returned INFO=\002,i1,"
"\002 for eigenvalue \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JT"
"YPE=\002,i6,\002, ISEED=(\002,4(i4,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(\002 DDRGES: S not in Schur form at eigenvalu"
"e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, "
"ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9996[] = "(/1x,a3,\002 -- Real Generalized Schur form dr"
"iver\002)";
static char fmt_9995[] = "(\002 Matrix types (see DDRGES for details):"
" \002)";
static char fmt_9994[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
"osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
"onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
"I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
"arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
"(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
"=(D, reversed D)\002)";
static char fmt_9993[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
"atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
" 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
"ha&beta \002,\002 20=arithmetic alpha, beta=0,"
"1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
"=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
"/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
"l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
".\002)";
static char fmt_9992[] = "(/\002 Tests performed: (S is Schur, T is tri"
"angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002l and r "
"are the appropriate left and right\002,/19x,\002eigenvectors, re"
"sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a,"
"\002.)\002,/\002 Without ordering: \002,/\002 1 = | A - Q S "
"Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T Z\002,a,\002 |"
" / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,\002 | / ( n ulp "
") 4 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 5"
" = A is in Schur form S\002,/\002 6 = difference between (alpha"
",beta)\002,\002 and diagonals of (S,T)\002,/\002 With ordering:"
" \002,/\002 7 = | (A,B) - Q (S,T) Z\002,a,\002 | / ( |(A,B)| n "
"ulp ) \002,/\002 8 = | I - QQ\002,a,\002 | / ( n ulp ) "
" 9 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 10 = A is in"
" Schur form S\002,/\002 11 = difference between (alpha,beta) and"
" diagonals\002,\002 of (S,T)\002,/\002 12 = SDIM is the correct "
"number of \002,\002selected eigenvalues\002,/)";
static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",0p,f8.2)";
static char fmt_9990[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",1p,d10.3)";
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1,
s_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2, i__3,
i__4;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10;
/* Builtin functions */
double d_sign(doublereal *, doublereal *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer iadd, sdim, ierr, nmax, rsub;
static char sort[1];
static doublereal temp1, temp2;
static integer i__, j, n;
static logical badnn;
extern /* Subroutine */ int dget51_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *), dget53_(
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *), dget54_(
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *),
dgges_(char *, char *, char *, L_fp, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, logical *, integer *);
static integer iinfo;
static doublereal rmagn[4];
static integer nmats, jsize, nerrs, i1, jtype, ntest, n1, isort;
extern /* Subroutine */ int dlatm4_(integer *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *, doublereal *, integer *), dorm2r_(char *,
char *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *), dlabad_(doublereal *, doublereal *);
static logical ilabad;
static integer jc, nb, in;
extern doublereal dlamch_(char *);
static integer jr;
extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *);
extern doublereal dlarnd_(integer *, integer *);
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *);
static doublereal safmin;
static integer ioldsd[4];
static doublereal safmax;
static integer knteig;
extern logical dlctes_(doublereal *, doublereal *, doublereal *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *);
static integer minwrk, maxwrk;
static doublereal ulpinv;
static integer mtypes, ntestt;
static doublereal ulp;
/* Fortran I/O blocks */
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___60 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___61 = { 0, 0, 0, fmt_9990, 0 };
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
#define s_ref(a_1,a_2) s[(a_2)*s_dim1 + a_1]
#define t_ref(a_1,a_2) t[(a_2)*t_dim1 + a_1]
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
DDRGES checks the nonsymmetric generalized eigenvalue (Schur form)
problem driver DGGES.
DGGES factors A and B as Q S Z' and Q T Z' , where ' means
transpose, T is upper triangular, S is in generalized Schur form
(block upper triangular, with 1x1 and 2x2 blocks on the diagonal,
the 2x2 blocks corresponding to complex conjugate pairs of
generalized eigenvalues), and Q and Z are orthogonal. It also
computes the generalized eigenvalues (alpha(j),beta(j)), j=1,...,n,
Thus, w(j) = alpha(j)/beta(j) is a root of the characteristic
equation
det( A - w(j) B ) = 0
Optionally it also reorder the eigenvalues so that a selected
cluster of eigenvalues appears in the leading diagonal block of the
Schur forms.
When DDRGES is called, a number of matrix "sizes" ("N's") and a
number of matrix "TYPES" are specified. For each size ("N")
and each TYPE of matrix, a pair of matrices (A, B) will be generated
and used for testing. For each matrix pair, the following 13 tests
will be performed and compared with the threshhold THRESH except
the tests (5), (11) and (13).
(1) | A - Q S Z' | / ( |A| n ulp ) (no sorting of eigenvalues)
(2) | B - Q T Z' | / ( |B| n ulp ) (no sorting of eigenvalues)
(3) | I - QQ' | / ( n ulp ) (no sorting of eigenvalues)
(4) | I - ZZ' | / ( n ulp ) (no sorting of eigenvalues)
(5) if A is in Schur form (i.e. quasi-triangular form)
(no sorting of eigenvalues)
(6) if eigenvalues = diagonal blocks of the Schur form (S, T),
i.e., test the maximum over j of D(j) where:
if alpha(j) is real:
|alpha(j) - S(j,j)| |beta(j) - T(j,j)|
D(j) = ------------------------ + -----------------------
max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
if alpha(j) is complex:
| det( s S - w T ) |
D(j) = ---------------------------------------------------
ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
and S and T are here the 2 x 2 diagonal blocks of S and T
corresponding to the j-th and j+1-th eigenvalues.
(no sorting of eigenvalues)
(7) | (A,B) - Q (S,T) Z' | / ( | (A,B) | n ulp )
(with sorting of eigenvalues).
(8) | I - QQ' | / ( n ulp ) (with sorting of eigenvalues).
(9) | I - ZZ' | / ( n ulp ) (with sorting of eigenvalues).
(10) if A is in Schur form (i.e. quasi-triangular form)
(with sorting of eigenvalues).
(11) if eigenvalues = diagonal blocks of the Schur form (S, T),
i.e. test the maximum over j of D(j) where:
if alpha(j) is real:
|alpha(j) - S(j,j)| |beta(j) - T(j,j)|
D(j) = ------------------------ + -----------------------
max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
if alpha(j) is complex:
| det( s S - w T ) |
D(j) = ---------------------------------------------------
ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
and S and T are here the 2 x 2 diagonal blocks of S and T
corresponding to the j-th and j+1-th eigenvalues.
(with sorting of eigenvalues).
(12) if sorting worked and SDIM is the number of eigenvalues
which were SELECTed.
Test Matrices
=============
The sizes of the test matrices are specified by an array
NN(1:NSIZES); the value of each element NN(j) specifies one size.
The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
Currently, the list of possible types is:
(1) ( 0, 0 ) (a pair of zero matrices)
(2) ( I, 0 ) (an identity and a zero matrix)
(3) ( 0, I ) (an identity and a zero matrix)
(4) ( I, I ) (a pair of identity matrices)
t t
(5) ( J , J ) (a pair of transposed Jordan blocks)
t ( I 0 )
(6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
( 0 I ) ( 0 J )
and I is a k x k identity and J a (k+1)x(k+1)
Jordan block; k=(N-1)/2
(7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
matrix with those diagonal entries.)
(8) ( I, D )
(9) ( big*D, small*I ) where "big" is near overflow and small=1/big
(10) ( small*D, big*I )
(11) ( big*I, small*D )
(12) ( small*I, big*D )
(13) ( big*D, big*I )
(14) ( small*D, small*I )
(15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
t t
(16) Q ( J , J ) Z where Q and Z are random orthogonal matrices.
(17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices
with random O(1) entries above the diagonal
and diagonal entries diag(T1) =
( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
( 0, N-3, N-4,..., 1, 0, 0 )
(18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
s = machine precision.
(19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
N-5
(20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
(21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
where r1,..., r(N-4) are random.
(22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular
matrices.
Arguments
=========
NSIZES (input) INTEGER
The number of sizes of matrices to use. If it is zero,
DDRGES does nothing. NSIZES >= 0.
NN (input) INTEGER array, dimension (NSIZES)
An array containing the sizes to be used for the matrices.
Zero values will be skipped. NN >= 0.
NTYPES (input) INTEGER
The number of elements in DOTYPE. If it is zero, DDRGES
does nothing. It must be at least zero. If it is MAXTYP+1
and NSIZES is 1, then an additional type, MAXTYP+1 is
defined, which is to use whatever matrix is in A on input.
This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
DOTYPE(MAXTYP+1) is .TRUE. .
DOTYPE (input) LOGICAL array, dimension (NTYPES)
If DOTYPE(j) is .TRUE., then for each size in NN a
matrix of that size and of type j will be generated.
If NTYPES is smaller than the maximum number of types
defined (PARAMETER MAXTYP), then types NTYPES+1 through
MAXTYP will not be generated. If NTYPES is larger
than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
will be ignored.
ISEED (input/output) INTEGER array, dimension (4)
On entry ISEED specifies the seed of the random number
generator. The array elements should be between 0 and 4095;
if not they will be reduced mod 4096. Also, ISEED(4) must
be odd. The random number generator uses a linear
congruential sequence limited to small integers, and so
should produce machine independent random numbers. The
values of ISEED are changed on exit, and can be used in the
next call to DDRGES to continue the same random number
sequence.
THRESH (input) DOUBLE PRECISION
A test will count as "failed" if the "error", computed as
described above, exceeds THRESH. Note that the error is
scaled to be O(1), so THRESH should be a reasonably small
multiple of 1, e.g., 10 or 100. In particular, it should
not depend on the precision (single vs. double) or the size
of the matrix. THRESH >= 0.
NOUNIT (input) INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns IINFO not equal to 0.)
A (input/workspace) DOUBLE PRECISION array,
dimension(LDA, max(NN))
Used to hold the original A matrix. Used as input only
if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
DOTYPE(MAXTYP+1)=.TRUE.
LDA (input) INTEGER
The leading dimension of A, B, S, and T.
It must be at least 1 and at least max( NN ).
B (input/workspace) DOUBLE PRECISION array,
dimension(LDA, max(NN))
Used to hold the original B matrix. Used as input only
if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
DOTYPE(MAXTYP+1)=.TRUE.
S (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
The Schur form matrix computed from A by DGGES. On exit, S
contains the Schur form matrix corresponding to the matrix
in A.
T (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
The upper triangular matrix computed from B by DGGES.
Q (workspace) DOUBLE PRECISION array, dimension (LDQ, max(NN))
The (left) orthogonal matrix computed by DGGES.
LDQ (input) INTEGER
The leading dimension of Q and Z. It must
be at least 1 and at least max( NN ).
Z (workspace) DOUBLE PRECISION array, dimension( LDQ, max(NN) )
The (right) orthogonal matrix computed by DGGES.
ALPHAR (workspace) DOUBLE PRECISION array, dimension (max(NN))
ALPHAI (workspace) DOUBLE PRECISION array, dimension (max(NN))
BETA (workspace) DOUBLE PRECISION array, dimension (max(NN))
The generalized eigenvalues of (A,B) computed by DGGES.
( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th
generalized eigenvalue of A and B.
WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK.
LWORK >= MAX( 10*(N+1), 3*N*N ), where N is the largest
matrix dimension.
RESULT (output) DOUBLE PRECISION array, dimension (15)
The values computed by the tests described above.
The values are currently limited to 1/ulp, to avoid overflow.
BWORK (workspace) LOGICAL array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: A routine returned an error code. INFO is the
absolute value of the INFO value returned.
=====================================================================
Parameter adjustments */
--nn;
--dotype;
--iseed;
t_dim1 = *lda;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
s_dim1 = *lda;
s_offset = 1 + s_dim1 * 1;
s -= s_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
z_dim1 = *ldq;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
--alphar;
--alphai;
--beta;
--work;
--result;
--bwork;
/* Function Body
Check for errors */
*info = 0;
badnn = FALSE_;
nmax = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -9;
} else if (*ldq <= 1 || *ldq < nmax) {
*info = -14;
}
/* Compute workspace
(Note: Comments in the code beginning "Workspace:" describe the
minimal amount of workspace needed at that point in the code,
as well as the preferred amount for good performance.
NB refers to the optimal block size for the immediately
following subroutine, as returned by ILAENV. */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
/* Computing MAX */
i__1 = (nmax + 1) * 10, i__2 = nmax * 3 * nmax;
minwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "DGEQRF", " ", &nmax, &nmax, &c_n1, &
c_n1, (ftnlen)6, (ftnlen)1), i__1 = max(i__1,i__2), i__2 =
ilaenv_(&c__1, "DORMQR", "LT", &nmax, &nmax, &nmax, &c_n1, (
ftnlen)6, (ftnlen)2), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
c__1, "DORGQR", " ", &nmax, &nmax, &nmax, &c_n1, (ftnlen)6, (
ftnlen)1);
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = (nmax + 1) * 10, i__2 = (nmax << 1) + nmax * nb, i__1 = max(
i__1,i__2), i__2 = nmax * 3 * nmax;
maxwrk = max(i__1,i__2);
work[1] = (doublereal) maxwrk;
}
if (*lwork < minwrk) {
*info = -20;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DDRGES", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
safmin = dlamch_("Safe minimum");
ulp = dlamch_("Epsilon") * dlamch_("Base");
safmin /= ulp;
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
ulpinv = 1. / ulp;
/* The values RMAGN(2:3) depend on N, see below. */
rmagn[0] = 0.;
rmagn[1] = 1.;
/* Loop over matrix sizes */
ntestt = 0;
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
n1 = max(1,n);
rmagn[2] = safmax * ulp / (doublereal) n1;
rmagn[3] = safmin * ulpinv * (doublereal) n1;
if (*nsizes != 1) {
mtypes = min(26,*ntypes);
} else {
mtypes = min(27,*ntypes);
}
/* Loop over matrix types */
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L180;
}
++nmats;
ntest = 0;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Initialize RESULT */
for (j = 1; j <= 13; ++j) {
result[j] = 0.;
/* L30: */
}
/* Generate test matrices A and B
Description of control parameters:
KZLASS: =1 means w/o rotation, =2 means w/ rotation,
=3 means random.
KATYPE: the "type" to be passed to DLATM4 for computing A.
KAZERO: the pattern of zeros on the diagonal for A:
=1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
=4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
=6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
non-zero entries.)
KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
=2: large, =3: small.
IASIGN: 1 if the diagonal elements of A are to be
multiplied by a random magnitude 1 number, =2 if
randomly chosen diagonal blocks are to be rotated
to form 2x2 blocks.
KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B.
KTRIAN: =0: don't fill in the upper triangle, =1: do.
KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
RMAGN: used to implement KAMAGN and KBMAGN. */
if (mtypes > 26) {
goto L110;
}
iinfo = 0;
if (kclass[jtype - 1] < 3) {
/* Generate A (w/o rotation) */
if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
dlaset_("Full", &n, &n, &c_b26, &c_b26, &a[a_offset],
lda);
}
} else {
in = n;
}
dlatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
&kz2[kazero[jtype - 1] - 1], &iasign[jtype - 1], &
rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
a_offset], lda);
iadd = kadd[kazero[jtype - 1] - 1];
if (iadd > 0 && iadd <= n) {
a_ref(iadd, iadd) = 1.;
}
/* Generate B (w/o rotation) */
if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
dlaset_("Full", &n, &n, &c_b26, &c_b26, &b[b_offset],
lda);
}
} else {
in = n;
}
dlatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
&kz2[kbzero[jtype - 1] - 1], &ibsign[jtype - 1], &
rmagn[kbmagn[jtype - 1]], &c_b32, &rmagn[ktrian[jtype
- 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
b_offset], lda);
iadd = kadd[kbzero[jtype - 1] - 1];
if (iadd != 0 && iadd <= n) {
b_ref(iadd, iadd) = 1.;
}
if (kclass[jtype - 1] == 2 && n > 0) {
/* Include rotations
Generate Q, Z as Householder transformations times
a diagonal matrix. */
i__3 = n - 1;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = jc; jr <= i__4; ++jr) {
q_ref(jr, jc) = dlarnd_(&c__3, &iseed[1]);
z___ref(jr, jc) = dlarnd_(&c__3, &iseed[1]);
/* L40: */
}
i__4 = n + 1 - jc;
dlarfg_(&i__4, &q_ref(jc, jc), &q_ref(jc + 1, jc), &
c__1, &work[jc]);
work[(n << 1) + jc] = d_sign(&c_b32, &q_ref(jc, jc));
q_ref(jc, jc) = 1.;
i__4 = n + 1 - jc;
dlarfg_(&i__4, &z___ref(jc, jc), &z___ref(jc + 1, jc),
&c__1, &work[n + jc]);
work[n * 3 + jc] = d_sign(&c_b32, &z___ref(jc, jc));
z___ref(jc, jc) = 1.;
/* L50: */
}
q_ref(n, n) = 1.;
work[n] = 0.;
d__1 = dlarnd_(&c__2, &iseed[1]);
work[n * 3] = d_sign(&c_b32, &d__1);
z___ref(n, n) = 1.;
work[n * 2] = 0.;
d__1 = dlarnd_(&c__2, &iseed[1]);
work[n * 4] = d_sign(&c_b32, &d__1);
/* Apply the diagonal matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
a_ref(jr, jc) = work[(n << 1) + jr] * work[n * 3
+ jc] * a_ref(jr, jc);
b_ref(jr, jc) = work[(n << 1) + jr] * work[n * 3
+ jc] * b_ref(jr, jc);
/* L60: */
}
/* L70: */
}
i__3 = n - 1;
dorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &a[a_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
dorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &a[a_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
dorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &b[b_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
dorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &b[b_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
}
} else {
/* Random matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
a_ref(jr, jc) = rmagn[kamagn[jtype - 1]] * dlarnd_(&
c__2, &iseed[1]);
b_ref(jr, jc) = rmagn[kbmagn[jtype - 1]] * dlarnd_(&
c__2, &iseed[1]);
/* L80: */
}
/* L90: */
}
}
L100:
if (iinfo != 0) {
io___40.ciunit = *nounit;
s_wsfe(&io___40);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L110:
for (i__ = 1; i__ <= 13; ++i__) {
result[i__] = -1.;
/* L120: */
}
/* Test with and without sorting of eigenvalues */
for (isort = 0; isort <= 1; ++isort) {
if (isort == 0) {
*(unsigned char *)sort = 'N';
rsub = 0;
} else {
*(unsigned char *)sort = 'S';
rsub = 5;
}
/* Call DGGES to compute H, T, Q, Z, alpha, and beta. */
dlacpy_("Full", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
dlacpy_("Full", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
ntest = rsub + 1 + isort;
result[rsub + 1 + isort] = ulpinv;
dgges_("V", "V", sort, (L_fp)dlctes_, &n, &s[s_offset], lda, &
t[t_offset], lda, &sdim, &alphar[1], &alphai[1], &
beta[1], &q[q_offset], ldq, &z__[z_offset], ldq, &
work[1], lwork, &bwork[1], &iinfo);
if (iinfo != 0 && iinfo != n + 2) {
result[rsub + 1 + isort] = ulpinv;
io___46.ciunit = *nounit;
s_wsfe(&io___46);
do_fio(&c__1, "DGGES", (ftnlen)5);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L160;
}
ntest = rsub + 4;
/* Do tests 1--4 (or tests 7--9 when reordering ) */
if (isort == 0) {
dget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &
q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
result[1]);
dget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &
q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
result[2]);
} else {
dget54_(&n, &a[a_offset], lda, &b[b_offset], lda, &s[
s_offset], lda, &t[t_offset], lda, &q[q_offset],
ldq, &z__[z_offset], ldq, &work[1], &result[7]);
}
dget51_(&c__3, &n, &a[a_offset], lda, &t[t_offset], lda, &q[
q_offset], ldq, &q[q_offset], ldq, &work[1], &result[
rsub + 3]);
dget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
z_offset], ldq, &z__[z_offset], ldq, &work[1], &
result[rsub + 4]);
/* Do test 5 and 6 (or Tests 10 and 11 when reordering):
check Schur form of A and compare eigenvalues with
diagonals. */
ntest = rsub + 6;
temp1 = 0.;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
ilabad = FALSE_;
if (alphai[j] == 0.) {
/* Computing MAX */
d__7 = safmin, d__8 = (d__2 = alphar[j], abs(d__2)),
d__7 = max(d__7,d__8), d__8 = (d__3 = s_ref(j,
j), abs(d__3));
/* Computing MAX */
d__9 = safmin, d__10 = (d__5 = beta[j], abs(d__5)),
d__9 = max(d__9,d__10), d__10 = (d__6 = t_ref(
j, j), abs(d__6));
temp2 = ((d__1 = alphar[j] - s_ref(j, j), abs(d__1)) /
max(d__7,d__8) + (d__4 = beta[j] - t_ref(j,
j), abs(d__4)) / max(d__9,d__10)) / ulp;
if (j < n) {
if (s_ref(j + 1, j) != 0.) {
ilabad = TRUE_;
result[rsub + 5] = ulpinv;
}
}
if (j > 1) {
if (s_ref(j, j - 1) != 0.) {
ilabad = TRUE_;
result[rsub + 5] = ulpinv;
}
}
} else {
if (alphai[j] > 0.) {
i1 = j;
} else {
i1 = j - 1;
}
if (i1 <= 0 || i1 >= n) {
ilabad = TRUE_;
} else if (i1 < n - 1) {
if (s_ref(i1 + 2, i1 + 1) != 0.) {
ilabad = TRUE_;
result[rsub + 5] = ulpinv;
}
} else if (i1 > 1) {
if (s_ref(i1, i1 - 1) != 0.) {
ilabad = TRUE_;
result[rsub + 5] = ulpinv;
}
}
if (! ilabad) {
dget53_(&s_ref(i1, i1), lda, &t_ref(i1, i1), lda,
&beta[j], &alphar[j], &alphai[j], &temp2,
&ierr);
if (ierr >= 3) {
io___52.ciunit = *nounit;
s_wsfe(&io___52);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)
sizeof(integer));
e_wsfe();
*info = abs(ierr);
}
} else {
temp2 = ulpinv;
}
}
temp1 = max(temp1,temp2);
if (ilabad) {
io___53.ciunit = *nounit;
s_wsfe(&io___53);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
e_wsfe();
}
/* L130: */
}
result[rsub + 6] = temp1;
if (isort >= 1) {
/* Do test 12 */
ntest = 12;
result[12] = 0.;
knteig = 0;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
d__1 = -alphai[i__];
if (dlctes_(&alphar[i__], &alphai[i__], &beta[i__]) ||
dlctes_(&alphar[i__], &d__1, &beta[i__])) {
++knteig;
}
if (i__ < n) {
d__1 = -alphai[i__ + 1];
d__2 = -alphai[i__];
if ((dlctes_(&alphar[i__ + 1], &alphai[i__ + 1], &
beta[i__ + 1]) || dlctes_(&alphar[i__ + 1]
, &d__1, &beta[i__ + 1])) && ! (dlctes_(&
alphar[i__], &alphai[i__], &beta[i__]) ||
dlctes_(&alphar[i__], &d__2, &beta[i__]))
&& iinfo != n + 2) {
result[12] = ulpinv;
}
}
/* L140: */
}
if (sdim != knteig) {
result[12] = ulpinv;
}
}
/* L150: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L160:
ntestt += ntest;
/* Print out tests which fail. */
i__3 = ntest;
for (jr = 1; jr <= i__3; ++jr) {
if (result[jr] >= *thresh) {
/* If this is the first test to fail,
print a header to the data file. */
if (nerrs == 0) {
io___55.ciunit = *nounit;
s_wsfe(&io___55);
do_fio(&c__1, "DGS", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___56.ciunit = *nounit;
s_wsfe(&io___56);
e_wsfe();
io___57.ciunit = *nounit;
s_wsfe(&io___57);
e_wsfe();
io___58.ciunit = *nounit;
s_wsfe(&io___58);
do_fio(&c__1, "Orthogonal", (ftnlen)10);
e_wsfe();
/* Tests performed */
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, "orthogonal", (ftnlen)10);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (j = 1; j <= 8; ++j) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[jr] < 1e4) {
io___60.ciunit = *nounit;
s_wsfe(&io___60);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
} else {
io___61.ciunit = *nounit;
s_wsfe(&io___61);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
}
/* L170: */
}
L180:
;
}
/* L190: */
}
/* Summary */
alasvm_("DGS", nounit, &nerrs, &ntestt, &c__0);
work[1] = (doublereal) maxwrk;
return 0;
/* End of DDRGES */
} /* ddrges_ */
/* Subroutine */ int dsvdc_(doublereal *x, integer *ldx, integer *n, integer *
p, doublereal *s, doublereal *e, doublereal *u, integer *ldu,
doublereal *v, integer *ldv, doublereal *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;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7;
/* Builtin functions */
double d_sign(doublereal *, doublereal *), sqrt(doublereal);
/* Local variables */
static doublereal b, c__, f, g;
static integer i__, j, k, l, m;
static doublereal t, t1, el;
static integer kk;
static doublereal cs;
static integer ll, mm, ls;
static doublereal sl;
static integer lu;
static doublereal sm, sn;
static integer lm1, mm1, lp1, mp1, nct, ncu, lls, nrt;
static doublereal emm1, smm1;
static integer kase;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static integer jobu, iter;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
static doublereal test;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static integer nctp1, nrtp1;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal scale, shift;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *), drotg_(doublereal *, doublereal *,
doublereal *, doublereal *);
static integer maxit;
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static logical wantu, wantv;
static doublereal ztest;
/* dsvdc is a subroutine to reduce a double precision nxp matrix x */
/* by orthogonal 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 double precision(ldx,p), where ldx.ge.n. */
/* x contains the matrix whose singular value */
/* decomposition is to be computed. x is */
/* destroyed by dsvdc. */
/* 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 double precision(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 return the first min(n,p) 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 double precision(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 double precision(p), */
/* e ordinarily contains zeros. however see the */
/* discussion of info for exceptions. */
/* u double precision(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.eq.2, then u may be identified with x */
/* in the subroutine call. */
/* v double precision(ldv,p), where ldv.ge.p. */
/* v contains the matrix of right singular vectors. */
/* v is not referenced if job.eq.0. if p.le.n, */
/* then v may be identified with 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 = trans(u)*x*v is the bidiagonal matrix */
/* with the elements of s on its diagonal and the */
/* elements of e on its super-diagonal (trans(u) */
/* is the transpose of u). thus the singular */
/* values of x and b are the same. */
/* linpack. this version dated 08/14/78 . */
/* correction made to shift 2/84. */
/* g.w. stewart, university of maryland, argonne national lab. */
/* dsvdc uses the following functions and subprograms. */
/* external drot */
/* blas daxpy,ddot,dscal,dswap,dnrm2,drotg */
/* fortran dabs,dmax1,max0,min0,mod,dsqrt */
/* internal variables */
/* set the maximum number of iterations. */
/* 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 = 30;
/* determine what is to be computed. */
wantu = FALSE_;
wantv = FALSE_;
jobu = *job % 100 / 10;
ncu = *n;
if (jobu > 1) {
ncu = min(*n,*p);
}
if (jobu != 0) {
wantu = 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;
/* Computing MIN */
i__1 = *n - 1;
nct = min(i__1,*p);
/* Computing MAX */
/* Computing MIN */
i__3 = *p - 2;
i__1 = 0, i__2 = min(i__3,*n);
nrt = max(i__1,i__2);
lu = max(nct,nrt);
if (lu < 1) {
goto L170;
}
i__1 = lu;
for (l = 1; l <= i__1; ++l) {
lp1 = l + 1;
if (l > nct) {
goto L20;
}
/* compute the transformation for the l-th column and */
/* place the l-th diagonal in s(l). */
i__2 = *n - l + 1;
s[l] = dnrm2_(&i__2, &x[l + l * x_dim1], &c__1);
if (s[l] == 0.) {
goto L10;
}
if (x[l + l * x_dim1] != 0.) {
s[l] = d_sign(&s[l], &x[l + l * x_dim1]);
}
i__2 = *n - l + 1;
d__1 = 1. / s[l];
dscal_(&i__2, &d__1, &x[l + l * x_dim1], &c__1);
x[l + l * x_dim1] += 1.;
L10:
s[l] = -s[l];
L20:
if (*p < lp1) {
goto L50;
}
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
if (l > nct) {
goto L30;
}
if (s[l] == 0.) {
goto L30;
}
/* apply the transformation. */
i__3 = *n - l + 1;
t = -ddot_(&i__3, &x[l + l * x_dim1], &c__1, &x[l + j * x_dim1], &
c__1) / x[l + l * x_dim1];
i__3 = *n - l + 1;
daxpy_(&i__3, &t, &x[l + l * x_dim1], &c__1, &x[l + j * x_dim1], &
c__1);
L30:
/* place the l-th row of x into e for the */
/* subsequent calculation of the row transformation. */
e[j] = x[l + j * x_dim1];
/* L40: */
}
L50:
if (! wantu || l > nct) {
goto L70;
}
/* place the transformation in u for subsequent back */
/* multiplication. */
i__2 = *n;
for (i__ = l; i__ <= i__2; ++i__) {
u[i__ + l * u_dim1] = x[i__ + l * x_dim1];
/* L60: */
}
L70:
if (l > nrt) {
goto L150;
}
/* compute the l-th row transformation and place the */
/* l-th super-diagonal in e(l). */
i__2 = *p - l;
e[l] = dnrm2_(&i__2, &e[lp1], &c__1);
if (e[l] == 0.) {
goto L80;
}
if (e[lp1] != 0.) {
e[l] = d_sign(&e[l], &e[lp1]);
}
i__2 = *p - l;
d__1 = 1. / e[l];
dscal_(&i__2, &d__1, &e[lp1], &c__1);
e[lp1] += 1.;
L80:
e[l] = -e[l];
if (lp1 > *n || e[l] == 0.) {
goto L120;
}
/* apply the transformation. */
i__2 = *n;
for (i__ = lp1; i__ <= i__2; ++i__) {
work[i__] = 0.;
/* L90: */
}
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
i__3 = *n - l;
daxpy_(&i__3, &e[j], &x[lp1 + j * x_dim1], &c__1, &work[lp1], &
c__1);
/* L100: */
}
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
i__3 = *n - l;
d__1 = -e[j] / e[lp1];
daxpy_(&i__3, &d__1, &work[lp1], &c__1, &x[lp1 + j * x_dim1], &
c__1);
/* L110: */
}
L120:
if (! wantv) {
goto L140;
}
/* place the transformation in v for subsequent */
/* back multiplication. */
i__2 = *p;
for (i__ = lp1; i__ <= i__2; ++i__) {
v[i__ + l * v_dim1] = e[i__];
/* L130: */
}
L140:
L150:
/* L160: */
;
}
L170:
/* set up the final bidiagonal matrix or order m. */
/* Computing MIN */
i__1 = *p, i__2 = *n + 1;
m = min(i__1,i__2);
nctp1 = nct + 1;
nrtp1 = nrt + 1;
if (nct < *p) {
s[nctp1] = x[nctp1 + nctp1 * x_dim1];
}
if (*n < m) {
s[m] = 0.;
}
if (nrtp1 < m) {
e[nrtp1] = x[nrtp1 + m * x_dim1];
}
e[m] = 0.;
/* if required, generate u. */
if (! wantu) {
goto L300;
}
if (ncu < nctp1) {
goto L200;
}
i__1 = ncu;
for (j = nctp1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
u[i__ + j * u_dim1] = 0.;
/* L180: */
}
u[j + j * u_dim1] = 1.;
/* L190: */
}
L200:
if (nct < 1) {
goto L290;
}
i__1 = nct;
for (ll = 1; ll <= i__1; ++ll) {
l = nct - ll + 1;
if (s[l] == 0.) {
goto L250;
}
lp1 = l + 1;
if (ncu < lp1) {
goto L220;
}
i__2 = ncu;
for (j = lp1; j <= i__2; ++j) {
i__3 = *n - l + 1;
t = -ddot_(&i__3, &u[l + l * u_dim1], &c__1, &u[l + j * u_dim1], &
c__1) / u[l + l * u_dim1];
i__3 = *n - l + 1;
daxpy_(&i__3, &t, &u[l + l * u_dim1], &c__1, &u[l + j * u_dim1], &
c__1);
/* L210: */
}
L220:
i__2 = *n - l + 1;
dscal_(&i__2, &c_b44, &u[l + l * u_dim1], &c__1);
u[l + l * u_dim1] += 1.;
lm1 = l - 1;
if (lm1 < 1) {
goto L240;
}
i__2 = lm1;
for (i__ = 1; i__ <= i__2; ++i__) {
u[i__ + l * u_dim1] = 0.;
/* L230: */
}
L240:
goto L270;
L250:
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
u[i__ + l * u_dim1] = 0.;
/* L260: */
}
u[l + l * u_dim1] = 1.;
L270:
/* L280: */
;
}
L290:
L300:
/* if it is required, generate v. */
if (! wantv) {
goto L350;
}
i__1 = *p;
for (ll = 1; ll <= i__1; ++ll) {
l = *p - ll + 1;
lp1 = l + 1;
if (l > nrt) {
goto L320;
}
if (e[l] == 0.) {
goto L320;
}
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
i__3 = *p - l;
t = -ddot_(&i__3, &v[lp1 + l * v_dim1], &c__1, &v[lp1 + j *
v_dim1], &c__1) / v[lp1 + l * v_dim1];
i__3 = *p - l;
daxpy_(&i__3, &t, &v[lp1 + l * v_dim1], &c__1, &v[lp1 + j *
v_dim1], &c__1);
/* L310: */
}
L320:
i__2 = *p;
for (i__ = 1; i__ <= i__2; ++i__) {
v[i__ + l * v_dim1] = 0.;
/* L330: */
}
v[l + l * v_dim1] = 1.;
/* L340: */
}
L350:
/* main iteration loop for the singular values. */
mm = m;
iter = 0;
L360:
/* quit if all the singular values have been found. */
/* ...exit */
if (m == 0) {
goto L620;
}
/* if too many iterations have been performed, set */
/* flag and return. */
if (iter < maxit) {
goto L370;
}
*info = m;
/* ......exit */
goto L620;
L370:
/* 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). */
i__1 = m;
for (ll = 1; ll <= i__1; ++ll) {
l = m - ll;
/* ...exit */
if (l == 0) {
goto L400;
}
test = (d__1 = s[l], abs(d__1)) + (d__2 = s[l + 1], abs(d__2));
ztest = test + (d__1 = e[l], abs(d__1));
if (ztest != test) {
goto L380;
}
e[l] = 0.;
/* ......exit */
goto L400;
L380:
/* L390: */
;
}
L400:
if (l != m - 1) {
goto L410;
}
kase = 4;
goto L480;
L410:
lp1 = l + 1;
mp1 = m + 1;
i__1 = mp1;
for (lls = lp1; lls <= i__1; ++lls) {
ls = m - lls + lp1;
/* ...exit */
if (ls == l) {
goto L440;
}
test = 0.;
if (ls != m) {
test += (d__1 = e[ls], abs(d__1));
}
if (ls != l + 1) {
test += (d__1 = e[ls - 1], abs(d__1));
}
ztest = test + (d__1 = s[ls], abs(d__1));
if (ztest != test) {
goto L420;
}
s[ls] = 0.;
/* ......exit */
goto L440;
L420:
/* L430: */
;
}
L440:
if (ls != l) {
goto L450;
}
kase = 3;
goto L470;
L450:
if (ls != m) {
goto L460;
}
kase = 1;
goto L470;
L460:
kase = 2;
l = ls;
L470:
L480:
++l;
/* perform the task indicated by kase. */
switch (kase) {
case 1: goto L490;
case 2: goto L520;
case 3: goto L540;
case 4: goto L570;
}
/* deflate negligible s(m). */
L490:
mm1 = m - 1;
f = e[m - 1];
e[m - 1] = 0.;
i__1 = mm1;
for (kk = l; kk <= i__1; ++kk) {
k = mm1 - kk + l;
t1 = s[k];
drotg_(&t1, &f, &cs, &sn);
s[k] = t1;
if (k == l) {
goto L500;
}
f = -sn * e[k - 1];
e[k - 1] = cs * e[k - 1];
L500:
if (wantv) {
drot_(p, &v[k * v_dim1 + 1], &c__1, &v[m * v_dim1 + 1], &c__1, &
cs, &sn);
}
/* L510: */
}
goto L610;
/* split at negligible s(l). */
L520:
f = e[l - 1];
e[l - 1] = 0.;
i__1 = m;
for (k = l; k <= i__1; ++k) {
t1 = s[k];
drotg_(&t1, &f, &cs, &sn);
s[k] = t1;
f = -sn * e[k];
e[k] = cs * e[k];
if (wantu) {
drot_(n, &u[k * u_dim1 + 1], &c__1, &u[(l - 1) * u_dim1 + 1], &
c__1, &cs, &sn);
}
/* L530: */
}
goto L610;
/* perform one qr step. */
L540:
/* calculate the shift. */
/* Computing MAX */
d__6 = (d__1 = s[m], abs(d__1)), d__7 = (d__2 = s[m - 1], abs(d__2)),
d__6 = max(d__6,d__7), d__7 = (d__3 = e[m - 1], abs(d__3)), d__6 =
max(d__6,d__7), d__7 = (d__4 = s[l], abs(d__4)), d__6 = max(d__6,
d__7), d__7 = (d__5 = e[l], abs(d__5));
scale = max(d__6,d__7);
sm = s[m] / scale;
smm1 = s[m - 1] / scale;
emm1 = e[m - 1] / scale;
sl = s[l] / scale;
el = e[l] / scale;
/* Computing 2nd power */
d__1 = emm1;
b = ((smm1 + sm) * (smm1 - sm) + d__1 * d__1) / 2.;
/* Computing 2nd power */
d__1 = sm * emm1;
c__ = d__1 * d__1;
shift = 0.;
if (b == 0. && c__ == 0.) {
goto L550;
}
/* Computing 2nd power */
d__1 = b;
shift = sqrt(d__1 * d__1 + c__);
if (b < 0.) {
shift = -shift;
}
shift = c__ / (b + shift);
L550:
f = (sl + sm) * (sl - sm) + shift;
g = sl * el;
/* chase zeros. */
mm1 = m - 1;
i__1 = mm1;
for (k = l; k <= i__1; ++k) {
drotg_(&f, &g, &cs, &sn);
if (k != l) {
e[k - 1] = f;
}
f = cs * s[k] + sn * e[k];
e[k] = cs * e[k] - sn * s[k];
g = sn * s[k + 1];
s[k + 1] = cs * s[k + 1];
if (wantv) {
drot_(p, &v[k * v_dim1 + 1], &c__1, &v[(k + 1) * v_dim1 + 1], &
c__1, &cs, &sn);
}
drotg_(&f, &g, &cs, &sn);
s[k] = f;
f = cs * e[k] + sn * s[k + 1];
s[k + 1] = -sn * e[k] + cs * s[k + 1];
g = sn * e[k + 1];
e[k + 1] = cs * e[k + 1];
if (wantu && k < *n) {
drot_(n, &u[k * u_dim1 + 1], &c__1, &u[(k + 1) * u_dim1 + 1], &
c__1, &cs, &sn);
}
/* L560: */
}
e[m - 1] = f;
++iter;
goto L610;
/* convergence. */
L570:
/* make the singular value positive. */
if (s[l] >= 0.) {
goto L580;
}
s[l] = -s[l];
if (wantv) {
dscal_(p, &c_b44, &v[l * v_dim1 + 1], &c__1);
}
L580:
/* order the singular value. */
L590:
if (l == mm) {
goto L600;
}
/* ...exit */
if (s[l] >= s[l + 1]) {
goto L600;
}
t = s[l];
s[l] = s[l + 1];
s[l + 1] = t;
if (wantv && l < *p) {
dswap_(p, &v[l * v_dim1 + 1], &c__1, &v[(l + 1) * v_dim1 + 1], &c__1);
}
if (wantu && l < *n) {
dswap_(n, &u[l * u_dim1 + 1], &c__1, &u[(l + 1) * u_dim1 + 1], &c__1);
}
++l;
goto L590;
L600:
iter = 0;
--m;
L610:
goto L360;
L620:
return 0;
} /* dsvdc_ */
/* Subroutine */ int dlasv2_(doublereal *f, doublereal *g, doublereal *h__,
doublereal *ssmin, doublereal *ssmax, doublereal *snr, doublereal *
csr, doublereal *snl, doublereal *csl)
{
/* System generated locals */
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
doublereal a, d__, l, m, r__, s, t, fa, ga, ha, ft, gt, ht, mm, tt, clt,
crt, slt, srt;
integer pmax;
doublereal temp;
logical swap;
doublereal tsign;
extern doublereal dlamch_(char *);
logical gasmal;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASV2 computes the singular value decomposition of a 2-by-2 */
/* triangular matrix */
/* [ F G ] */
/* [ 0 H ]. */
/* On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the */
/* smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and */
/* right singular vectors for abs(SSMAX), giving the decomposition */
/* [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] */
/* [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. */
/* Arguments */
/* ========= */
/* F (input) DOUBLE PRECISION */
/* The (1,1) element of the 2-by-2 matrix. */
/* G (input) DOUBLE PRECISION */
/* The (1,2) element of the 2-by-2 matrix. */
/* H (input) DOUBLE PRECISION */
/* The (2,2) element of the 2-by-2 matrix. */
/* SSMIN (output) DOUBLE PRECISION */
/* abs(SSMIN) is the smaller singular value. */
/* SSMAX (output) DOUBLE PRECISION */
/* abs(SSMAX) is the larger singular value. */
/* SNL (output) DOUBLE PRECISION */
/* CSL (output) DOUBLE PRECISION */
/* The vector (CSL, SNL) is a unit left singular vector for the */
/* singular value abs(SSMAX). */
/* SNR (output) DOUBLE PRECISION */
/* CSR (output) DOUBLE PRECISION */
/* The vector (CSR, SNR) is a unit right singular vector for the */
/* singular value abs(SSMAX). */
/* Further Details */
/* =============== */
/* Any input parameter may be aliased with any output parameter. */
/* Barring over/underflow and assuming a guard digit in subtraction, all */
/* output quantities are correct to within a few units in the last */
/* place (ulps). */
/* In IEEE arithmetic, the code works correctly if one matrix element is */
/* infinite. */
/* Overflow will not occur unless the largest singular value itself */
/* overflows or is within a few ulps of overflow. (On machines with */
/* partial overflow, like the Cray, overflow may occur if the largest */
/* singular value is within a factor of 2 of overflow.) */
/* Underflow is harmless if underflow is gradual. Otherwise, results */
/* may correspond to a matrix modified by perturbations of size near */
/* the underflow threshold. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
ft = *f;
fa = abs(ft);
ht = *h__;
ha = abs(*h__);
/* PMAX points to the maximum absolute element of matrix */
/* PMAX = 1 if F largest in absolute values */
/* PMAX = 2 if G largest in absolute values */
/* PMAX = 3 if H largest in absolute values */
pmax = 1;
swap = ha > fa;
if (swap) {
pmax = 3;
temp = ft;
ft = ht;
ht = temp;
temp = fa;
fa = ha;
ha = temp;
/* Now FA .ge. HA */
}
gt = *g;
ga = abs(gt);
if (ga == 0.) {
/* Diagonal matrix */
*ssmin = ha;
*ssmax = fa;
clt = 1.;
crt = 1.;
slt = 0.;
srt = 0.;
} else {
gasmal = TRUE_;
if (ga > fa) {
pmax = 2;
if (fa / ga < dlamch_("EPS")) {
/* Case of very large GA */
gasmal = FALSE_;
*ssmax = ga;
if (ha > 1.) {
*ssmin = fa / (ga / ha);
} else {
*ssmin = fa / ga * ha;
}
clt = 1.;
slt = ht / gt;
srt = 1.;
crt = ft / gt;
}
}
if (gasmal) {
/* Normal case */
d__ = fa - ha;
if (d__ == fa) {
/* Copes with infinite F or H */
l = 1.;
} else {
l = d__ / fa;
}
/* Note that 0 .le. L .le. 1 */
m = gt / ft;
/* Note that abs(M) .le. 1/macheps */
t = 2. - l;
/* Note that T .ge. 1 */
mm = m * m;
tt = t * t;
s = sqrt(tt + mm);
/* Note that 1 .le. S .le. 1 + 1/macheps */
if (l == 0.) {
r__ = abs(m);
} else {
r__ = sqrt(l * l + mm);
}
/* Note that 0 .le. R .le. 1 + 1/macheps */
a = (s + r__) * .5;
/* Note that 1 .le. A .le. 1 + abs(M) */
*ssmin = ha / a;
*ssmax = fa * a;
if (mm == 0.) {
/* Note that M is very tiny */
if (l == 0.) {
t = d_sign(&c_b3, &ft) * d_sign(&c_b4, >);
} else {
t = gt / d_sign(&d__, &ft) + m / t;
}
} else {
t = (m / (s + t) + m / (r__ + l)) * (a + 1.);
}
l = sqrt(t * t + 4.);
crt = 2. / l;
srt = t / l;
clt = (crt + srt * m) / a;
slt = ht / ft * srt / a;
}
}
if (swap) {
*csl = srt;
*snl = crt;
*csr = slt;
*snr = clt;
} else {
*csl = clt;
*snl = slt;
*csr = crt;
*snr = srt;
}
/* Correct signs of SSMAX and SSMIN */
if (pmax == 1) {
tsign = d_sign(&c_b4, csr) * d_sign(&c_b4, csl) * d_sign(&c_b4, f);
}
if (pmax == 2) {
tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, csl) * d_sign(&c_b4, g);
}
if (pmax == 3) {
tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, snl) * d_sign(&c_b4, h__);
}
*ssmax = d_sign(ssmax, &tsign);
d__1 = tsign * d_sign(&c_b4, f) * d_sign(&c_b4, h__);
*ssmin = d_sign(ssmin, &d__1);
return 0;
/* End of DLASV2 */
} /* dlasv2_ */
/* Subroutine */ int zla_gbamv__(integer *trans, integer *m, integer *n,
integer *kl, integer *ku, doublereal *alpha, doublecomplex *ab,
integer *ldab, doublecomplex *x, integer *incx, doublereal *beta,
doublereal *y, integer *incy)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
/* Local variables */
integer i__, j;
logical symb_zero__;
integer kd, iy, jx, kx, ky, info;
doublereal temp;
integer lenx, leny;
doublereal safe1;
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* Purpose */
/* ======= */
/* DLA_GEAMV performs one of the matrix-vector operations */
/* y := alpha*abs(A)*abs(x) + beta*abs(y), */
/* or y := alpha*abs(A)'*abs(x) + beta*abs(y), */
/* where alpha and beta are scalars, x and y are vectors and A is an */
/* m by n matrix. */
/* This function is primarily used in calculating error bounds. */
/* To protect against underflow during evaluation, components in */
/* the resulting vector are perturbed away from zero by (N+1) */
/* times the underflow threshold. To prevent unnecessarily large */
/* errors for block-structure embedded in general matrices, */
/* "symbolically" zero components are not perturbed. A zero */
/* entry is considered "symbolic" if all multiplications involved */
/* in computing that entry have at least one zero multiplicand. */
/* Parameters */
/* ========== */
/* TRANS - INTEGER */
/* On entry, TRANS specifies the operation to be performed as */
/* follows: */
/* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) */
/* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) */
/* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) */
/* Unchanged on exit. */
/* M - INTEGER */
/* On entry, M specifies the number of rows of the matrix A. */
/* M must be at least zero. */
/* Unchanged on exit. */
/* N - INTEGER */
/* On entry, N specifies the number of columns of the matrix A. */
/* N must be at least zero. */
/* Unchanged on exit. */
/* KL - INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU - INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* ALPHA - DOUBLE PRECISION */
/* On entry, ALPHA specifies the scalar alpha. */
/* Unchanged on exit. */
/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ) */
/* Before entry, the leading m by n part of the array A must */
/* contain the matrix of coefficients. */
/* Unchanged on exit. */
/* LDA - INTEGER */
/* On entry, LDA specifies the first dimension of A as declared */
/* in the calling (sub) program. LDA must be at least */
/* max( 1, m ). */
/* Unchanged on exit. */
/* X - DOUBLE PRECISION array of DIMENSION at least */
/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
/* and at least */
/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
/* Before entry, the incremented array X must contain the */
/* vector x. */
/* Unchanged on exit. */
/* INCX - INTEGER */
/* On entry, INCX specifies the increment for the elements of */
/* X. INCX must not be zero. */
/* Unchanged on exit. */
/* BETA - DOUBLE PRECISION */
/* On entry, BETA specifies the scalar beta. When BETA is */
/* supplied as zero then Y need not be set on input. */
/* Unchanged on exit. */
/* Y - DOUBLE PRECISION array of DIMENSION at least */
/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
/* and at least */
/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
/* Before entry with BETA non-zero, the incremented array Y */
/* must contain the vector y. On exit, Y is overwritten by the */
/* updated vector y. */
/* INCY - INTEGER */
/* On entry, INCY specifies the increment for the elements of */
/* Y. INCY must not be zero. */
/* Unchanged on exit. */
/* Level 2 Blas routine. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--x;
--y;
/* Function Body */
info = 0;
if (! (*trans == ilatrans_("N") || *trans == ilatrans_("T") || *trans == ilatrans_("C"))) {
info = 1;
} else if (*m < 0) {
info = 2;
} else if (*n < 0) {
info = 3;
} else if (*kl < 0) {
info = 4;
} else if (*ku < 0) {
info = 5;
} else if (*ldab < *kl + *ku + 1) {
info = 6;
} else if (*incx == 0) {
info = 8;
} else if (*incy == 0) {
info = 11;
}
if (info != 0) {
xerbla_("ZLA_GBAMV ", &info);
return 0;
}
/* Quick return if possible. */
if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) {
return 0;
}
/* Set LENX and LENY, the lengths of the vectors x and y, and set */
/* up the start points in X and Y. */
if (*trans == ilatrans_("N")) {
lenx = *n;
leny = *m;
} else {
lenx = *m;
leny = *n;
}
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (lenx - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (leny - 1) * *incy;
}
/* Set SAFE1 essentially to be the underflow threshold times the */
/* number of additions in each row. */
safe1 = dlamch_("Safe minimum");
safe1 = (*n + 1) * safe1;
/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */
/* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to */
/* the inexact flag. Still doesn't help change the iteration order */
/* to per-column. */
kd = *ku + 1;
iy = ky;
if (*incx == 1) {
i__1 = leny;
for (i__ = 1; i__ <= i__1; ++i__) {
if (*beta == 0.) {
symb_zero__ = TRUE_;
y[iy] = 0.;
} else if (y[iy] == 0.) {
symb_zero__ = TRUE_;
} else {
symb_zero__ = FALSE_;
y[iy] = *beta * (d__1 = y[iy], abs(d__1));
}
if (*alpha != 0.) {
/* Computing MAX */
i__2 = i__ - *ku;
/* Computing MIN */
i__4 = i__ + *kl;
i__3 = min(i__4,lenx);
for (j = max(i__2,1); j <= i__3; ++j) {
if (*trans == ilatrans_("N")) {
i__2 = kd + i__ - j + j * ab_dim1;
temp = (d__1 = ab[i__2].r, abs(d__1)) + (d__2 =
d_imag(&ab[kd + i__ - j + j * ab_dim1]), abs(
d__2));
} else {
i__2 = j + (kd + i__ - j) * ab_dim1;
temp = (d__1 = ab[i__2].r, abs(d__1)) + (d__2 =
d_imag(&ab[j + (kd + i__ - j) * ab_dim1]),
abs(d__2));
}
i__2 = j;
symb_zero__ = symb_zero__ && (x[i__2].r == 0. && x[i__2]
.i == 0. || temp == 0.);
i__2 = j;
y[iy] += *alpha * ((d__1 = x[i__2].r, abs(d__1)) + (d__2 =
d_imag(&x[j]), abs(d__2))) * temp;
}
}
if (! symb_zero__) {
y[iy] += d_sign(&safe1, &y[iy]);
}
iy += *incy;
}
} else {
i__1 = leny;
for (i__ = 1; i__ <= i__1; ++i__) {
if (*beta == 0.) {
symb_zero__ = TRUE_;
y[iy] = 0.;
} else if (y[iy] == 0.) {
symb_zero__ = TRUE_;
} else {
symb_zero__ = FALSE_;
y[iy] = *beta * (d__1 = y[iy], abs(d__1));
}
if (*alpha != 0.) {
jx = kx;
/* Computing MAX */
i__3 = i__ - *ku;
/* Computing MIN */
i__4 = i__ + *kl;
i__2 = min(i__4,lenx);
for (j = max(i__3,1); j <= i__2; ++j) {
if (*trans == ilatrans_("N")) {
i__3 = kd + i__ - j + j * ab_dim1;
temp = (d__1 = ab[i__3].r, abs(d__1)) + (d__2 =
d_imag(&ab[kd + i__ - j + j * ab_dim1]), abs(
d__2));
} else {
i__3 = j + (kd + i__ - j) * ab_dim1;
temp = (d__1 = ab[i__3].r, abs(d__1)) + (d__2 =
d_imag(&ab[j + (kd + i__ - j) * ab_dim1]),
abs(d__2));
}
i__3 = jx;
symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[i__3]
.i == 0. || temp == 0.);
i__3 = jx;
y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + (d__2 =
d_imag(&x[jx]), abs(d__2))) * temp;
jx += *incx;
}
}
if (! symb_zero__) {
y[iy] += d_sign(&safe1, &y[iy]);
}
iy += *incy;
}
}
return 0;
/* End of ZLA_GBAMV */
} /* zla_gbamv__ */
/* Subroutine */ int zlarfg_(integer *n, doublecomplex *alpha, doublecomplex *
x, integer *incx, doublecomplex *tau)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZLARFG generates a complex elementary reflector H of order n, such
that
H' * ( alpha ) = ( beta ), H' * H = I.
( x ) ( 0 )
where alpha and beta are scalars, with beta real, and x is an
(n-1)-element complex vector. H is represented in the form
H = I - tau * ( 1 ) * ( 1 v' ) ,
( v )
where tau is a complex scalar and v is a complex (n-1)-element
vector. Note that H is not hermitian.
If the elements of x are all zero and alpha is real, then tau = 0
and H is taken to be the unit matrix.
Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .
Arguments
=========
N (input) INTEGER
The order of the elementary reflector.
ALPHA (input/output) COMPLEX*16
On entry, the value alpha.
On exit, it is overwritten with the value beta.
X (input/output) COMPLEX*16 array, dimension
(1+(N-2)*abs(INCX))
On entry, the vector x.
On exit, it is overwritten with the vector v.
INCX (input) INTEGER
The increment between elements of X. INCX > 0.
TAU (output) COMPLEX*16
The value tau.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b5 = {1.,0.};
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *), d_sign(doublereal *, doublereal *);
/* Local variables */
static doublereal beta;
static integer j;
static doublereal alphi, alphr;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static doublereal xnorm;
extern doublereal dlapy3_(doublereal *, doublereal *, doublereal *),
dznrm2_(integer *, doublecomplex *, integer *), dlamch_(char *);
static doublereal safmin;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
static doublereal rsafmn;
extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
doublecomplex *);
static integer knt;
--x;
/* Function Body */
if (*n <= 0) {
tau->r = 0., tau->i = 0.;
return 0;
}
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
alphr = alpha->r;
alphi = d_imag(alpha);
if (xnorm == 0. && alphi == 0.) {
/* H = I */
tau->r = 0., tau->i = 0.;
} else {
/* general case */
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = -d_sign(&d__1, &alphr);
safmin = dlamch_("S") / dlamch_("E");
rsafmn = 1. / safmin;
if (abs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute them */
knt = 0;
L10:
++knt;
i__1 = *n - 1;
zdscal_(&i__1, &rsafmn, &x[1], incx);
beta *= rsafmn;
alphi *= rsafmn;
alphr *= rsafmn;
if (abs(beta) < safmin) {
goto L10;
}
/* New BETA is at most 1, at least SAFMIN */
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
z__1.r = alphr, z__1.i = alphi;
alpha->r = z__1.r, alpha->i = z__1.i;
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = -d_sign(&d__1, &alphr);
d__1 = (beta - alphr) / beta;
d__2 = -alphi / beta;
z__1.r = d__1, z__1.i = d__2;
tau->r = z__1.r, tau->i = z__1.i;
z__2.r = alpha->r - beta, z__2.i = alpha->i;
zladiv_(&z__1, &c_b5, &z__2);
alpha->r = z__1.r, alpha->i = z__1.i;
i__1 = *n - 1;
zscal_(&i__1, alpha, &x[1], incx);
/* If ALPHA is subnormal, it may lose relative accuracy */
alpha->r = beta, alpha->i = 0.;
i__1 = knt;
for (j = 1; j <= i__1; ++j) {
z__1.r = safmin * alpha->r, z__1.i = safmin * alpha->i;
alpha->r = z__1.r, alpha->i = z__1.i;
/* L20: */
}
} else {
d__1 = (beta - alphr) / beta;
d__2 = -alphi / beta;
z__1.r = d__1, z__1.i = d__2;
tau->r = z__1.r, tau->i = z__1.i;
z__2.r = alpha->r - beta, z__2.i = alpha->i;
zladiv_(&z__1, &c_b5, &z__2);
alpha->r = z__1.r, alpha->i = z__1.i;
i__1 = *n - 1;
zscal_(&i__1, alpha, &x[1], incx);
alpha->r = beta, alpha->i = 0.;
}
}
return 0;
/* End of ZLARFG */
} /* zlarfg_ */
int dbdsdc_(char *uplo, char *compq, int *n, double *
d__, double *e, double *u, int *ldu, double *vt,
int *ldvt, double *q, int *iq, double *work, int *
iwork, int *info)
{
/* System generated locals */
int u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2;
double d__1;
/* Builtin functions */
double d_sign(double *, double *), log(double);
/* Local variables */
int i__, j, k;
double p, r__;
int z__, ic, ii, kk;
double cs;
int is, iu;
double sn;
int nm1;
double eps;
int ivt, difl, difr, ierr, perm, mlvl, sqre;
extern int lsame_(char *, char *);
extern int dlasr_(char *, char *, char *, int *,
int *, double *, double *, double *, int *), dcopy_(int *, double *, int *
, double *, int *), dswap_(int *, double *,
int *, double *, int *);
int poles, iuplo, nsize, start;
extern int dlasd0_(int *, int *, double *,
double *, double *, int *, double *, int *,
int *, int *, double *, int *);
extern double dlamch_(char *);
extern int dlasda_(int *, int *, int *,
int *, double *, double *, double *, int *,
double *, int *, double *, double *, double *,
double *, int *, int *, int *, int *,
double *, double *, double *, double *, int *,
int *), dlascl_(char *, int *, int *, double *,
double *, int *, int *, double *, int *,
int *), dlasdq_(char *, int *, int *, int
*, int *, int *, double *, double *, double *,
int *, double *, int *, double *, int *,
double *, int *), dlaset_(char *, int *,
int *, double *, double *, double *, int *), dlartg_(double *, double *, double *,
double *, double *);
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
extern int xerbla_(char *, int *);
int givcol;
extern double dlanst_(char *, int *, double *, double *);
int icompq;
double orgnrm;
int givnum, givptr, qstart, smlsiz, wstart, smlszp;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DBDSDC computes the singular value decomposition (SVD) of a float */
/* N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT, */
/* using a divide and conquer method, where S is a diagonal matrix */
/* with non-negative diagonal elements (the singular values of B), and */
/* U and VT are orthogonal matrices of left and right singular vectors, */
/* respectively. DBDSDC can be used to compute all singular values, */
/* and optionally, singular vectors or singular vectors in compact form. */
/* This code makes very mild assumptions about floating point */
/* arithmetic. It will work on machines with a guard digit in */
/* add/subtract, or on those binary machines without guard digits */
/* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */
/* It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. See DLASD3 for details. */
/* The code currently calls DLASDQ if singular values only are desired. */
/* However, it can be slightly modified to compute singular values */
/* using the divide and conquer method. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': B is upper bidiagonal. */
/* = 'L': B is lower bidiagonal. */
/* COMPQ (input) CHARACTER*1 */
/* Specifies whether singular vectors are to be computed */
/* as follows: */
/* = 'N': Compute singular values only; */
/* = 'P': Compute singular values and compute singular */
/* vectors in compact form; */
/* = 'I': Compute singular values and singular vectors. */
/* N (input) INTEGER */
/* The order of the matrix B. N >= 0. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the n diagonal elements of the bidiagonal matrix B. */
/* On exit, if INFO=0, the singular values of B. */
/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
/* On entry, the elements of E contain the offdiagonal */
/* elements of the bidiagonal matrix whose SVD is desired. */
/* On exit, E has been destroyed. */
/* U (output) DOUBLE PRECISION array, dimension (LDU,N) */
/* If COMPQ = 'I', then: */
/* On exit, if INFO = 0, U contains the left singular vectors */
/* of the bidiagonal matrix. */
/* For other values of COMPQ, U is not referenced. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= 1. */
/* If singular vectors are desired, then LDU >= MAX( 1, N ). */
/* VT (output) DOUBLE PRECISION array, dimension (LDVT,N) */
/* If COMPQ = 'I', then: */
/* On exit, if INFO = 0, VT' contains the right singular */
/* vectors of the bidiagonal matrix. */
/* For other values of COMPQ, VT is not referenced. */
/* LDVT (input) INTEGER */
/* The leading dimension of the array VT. LDVT >= 1. */
/* If singular vectors are desired, then LDVT >= MAX( 1, N ). */
/* Q (output) DOUBLE PRECISION array, dimension (LDQ) */
/* If COMPQ = 'P', then: */
/* On exit, if INFO = 0, Q and IQ contain the left */
/* and right singular vectors in a compact form, */
/* requiring O(N log N) space instead of 2*N**2. */
/* In particular, Q contains all the DOUBLE PRECISION data in */
/* LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1)))) */
/* words of memory, where SMLSIZ is returned by ILAENV and */
/* is equal to the maximum size of the subproblems at the */
/* bottom of the computation tree (usually about 25). */
/* For other values of COMPQ, Q is not referenced. */
/* IQ (output) INTEGER array, dimension (LDIQ) */
/* If COMPQ = 'P', then: */
/* On exit, if INFO = 0, Q and IQ contain the left */
/* and right singular vectors in a compact form, */
/* requiring O(N log N) space instead of 2*N**2. */
/* In particular, IQ contains all INTEGER data in */
/* LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1)))) */
/* words of memory, where SMLSIZ is returned by ILAENV and */
/* is equal to the maximum size of the subproblems at the */
/* bottom of the computation tree (usually about 25). */
/* For other values of COMPQ, IQ is not referenced. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* If COMPQ = 'N' then LWORK >= (4 * N). */
/* If COMPQ = 'P' then LWORK >= (6 * N). */
/* If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N). */
/* IWORK (workspace) INTEGER array, dimension (8*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: The algorithm failed to compute an singular value. */
/* The update process of divide and conquer failed. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Huan Ren, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* Changed dimension statement in comment describing E from (N) to */
/* (N-1). Sven, 17 Feb 05. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
--q;
--iq;
--work;
--iwork;
/* Function Body */
*info = 0;
iuplo = 0;
if (lsame_(uplo, "U")) {
iuplo = 1;
}
if (lsame_(uplo, "L")) {
iuplo = 2;
}
if (lsame_(compq, "N")) {
icompq = 0;
} else if (lsame_(compq, "P")) {
icompq = 1;
} else if (lsame_(compq, "I")) {
icompq = 2;
} else {
icompq = -1;
}
if (iuplo == 0) {
*info = -1;
} else if (icompq < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ldu < 1 || icompq == 2 && *ldu < *n) {
*info = -7;
} else if (*ldvt < 1 || icompq == 2 && *ldvt < *n) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DBDSDC", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
smlsiz = ilaenv_(&c__9, "DBDSDC", " ", &c__0, &c__0, &c__0, &c__0);
if (*n == 1) {
if (icompq == 1) {
q[1] = d_sign(&c_b15, &d__[1]);
q[smlsiz * *n + 1] = 1.;
} else if (icompq == 2) {
u[u_dim1 + 1] = d_sign(&c_b15, &d__[1]);
vt[vt_dim1 + 1] = 1.;
}
d__[1] = ABS(d__[1]);
return 0;
}
nm1 = *n - 1;
/* If matrix lower bidiagonal, rotate to be upper bidiagonal */
/* by applying Givens rotations on the left */
wstart = 1;
qstart = 3;
if (icompq == 1) {
dcopy_(n, &d__[1], &c__1, &q[1], &c__1);
i__1 = *n - 1;
dcopy_(&i__1, &e[1], &c__1, &q[*n + 1], &c__1);
}
if (iuplo == 2) {
qstart = 5;
wstart = (*n << 1) - 1;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
if (icompq == 1) {
q[i__ + (*n << 1)] = cs;
q[i__ + *n * 3] = sn;
} else if (icompq == 2) {
work[i__] = cs;
work[nm1 + i__] = -sn;
}
/* L10: */
}
}
/* If ICOMPQ = 0, use DLASDQ to compute the singular values. */
if (icompq == 0) {
dlasdq_("U", &c__0, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[
vt_offset], ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[
wstart], info);
goto L40;
}
/* If N is smaller than the minimum divide size SMLSIZ, then solve */
/* the problem with another solver. */
if (*n <= smlsiz) {
if (icompq == 2) {
dlaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu);
dlaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt);
dlasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &vt[vt_offset]
, ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[
wstart], info);
} else if (icompq == 1) {
iu = 1;
ivt = iu + *n;
dlaset_("A", n, n, &c_b29, &c_b15, &q[iu + (qstart - 1) * *n], n);
dlaset_("A", n, n, &c_b29, &c_b15, &q[ivt + (qstart - 1) * *n], n);
dlasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &q[ivt + (
qstart - 1) * *n], n, &q[iu + (qstart - 1) * *n], n, &q[
iu + (qstart - 1) * *n], n, &work[wstart], info);
}
goto L40;
}
if (icompq == 2) {
dlaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu);
dlaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt);
}
/* Scale. */
orgnrm = dlanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.) {
return 0;
}
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b15, n, &c__1, &d__[1], n, &ierr);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b15, &nm1, &c__1, &e[1], &nm1, &
ierr);
eps = dlamch_("Epsilon");
mlvl = (int) (log((double) (*n) / (double) (smlsiz + 1)) /
log(2.)) + 1;
smlszp = smlsiz + 1;
if (icompq == 1) {
iu = 1;
ivt = smlsiz + 1;
difl = ivt + smlszp;
difr = difl + mlvl;
z__ = difr + (mlvl << 1);
ic = z__ + mlvl;
is = ic + 1;
poles = is + 1;
givnum = poles + (mlvl << 1);
k = 1;
givptr = 2;
perm = 3;
givcol = perm + mlvl;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = d__[i__], ABS(d__1)) < eps) {
d__[i__] = d_sign(&eps, &d__[i__]);
}
/* L20: */
}
start = 1;
sqre = 0;
i__1 = nm1;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = e[i__], ABS(d__1)) < eps || i__ == nm1) {
/* Subproblem found. First determine its size and then */
/* apply divide and conquer on it. */
if (i__ < nm1) {
/* A subproblem with E(I) small for I < NM1. */
nsize = i__ - start + 1;
} else if ((d__1 = e[i__], ABS(d__1)) >= eps) {
/* A subproblem with E(NM1) not too small but I = NM1. */
nsize = *n - start + 1;
} else {
/* A subproblem with E(NM1) small. This implies an */
/* 1-by-1 subproblem at D(N). Solve this 1-by-1 problem */
/* first. */
nsize = i__ - start + 1;
if (icompq == 2) {
u[*n + *n * u_dim1] = d_sign(&c_b15, &d__[*n]);
vt[*n + *n * vt_dim1] = 1.;
} else if (icompq == 1) {
q[*n + (qstart - 1) * *n] = d_sign(&c_b15, &d__[*n]);
q[*n + (smlsiz + qstart - 1) * *n] = 1.;
}
d__[*n] = (d__1 = d__[*n], ABS(d__1));
}
if (icompq == 2) {
dlasd0_(&nsize, &sqre, &d__[start], &e[start], &u[start +
start * u_dim1], ldu, &vt[start + start * vt_dim1],
ldvt, &smlsiz, &iwork[1], &work[wstart], info);
} else {
dlasda_(&icompq, &smlsiz, &nsize, &sqre, &d__[start], &e[
start], &q[start + (iu + qstart - 2) * *n], n, &q[
start + (ivt + qstart - 2) * *n], &iq[start + k * *n],
&q[start + (difl + qstart - 2) * *n], &q[start + (
difr + qstart - 2) * *n], &q[start + (z__ + qstart -
2) * *n], &q[start + (poles + qstart - 2) * *n], &iq[
start + givptr * *n], &iq[start + givcol * *n], n, &
iq[start + perm * *n], &q[start + (givnum + qstart -
2) * *n], &q[start + (ic + qstart - 2) * *n], &q[
start + (is + qstart - 2) * *n], &work[wstart], &
iwork[1], info);
if (*info != 0) {
return 0;
}
}
start = i__ + 1;
}
/* L30: */
}
/* Unscale */
dlascl_("G", &c__0, &c__0, &c_b15, &orgnrm, n, &c__1, &d__[1], n, &ierr);
L40:
/* Use Selection Sort to minimize swaps of singular vectors */
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
i__ = ii - 1;
kk = i__;
p = d__[i__];
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
if (d__[j] > p) {
kk = j;
p = d__[j];
}
/* L50: */
}
if (kk != i__) {
d__[kk] = d__[i__];
d__[i__] = p;
if (icompq == 1) {
iq[i__] = kk;
} else if (icompq == 2) {
dswap_(n, &u[i__ * u_dim1 + 1], &c__1, &u[kk * u_dim1 + 1], &
c__1);
dswap_(n, &vt[i__ + vt_dim1], ldvt, &vt[kk + vt_dim1], ldvt);
}
} else if (icompq == 1) {
iq[i__] = i__;
}
/* L60: */
}
/* If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO */
if (icompq == 1) {
if (iuplo == 1) {
iq[*n] = 1;
} else {
iq[*n] = 0;
}
}
/* If B is lower bidiagonal, update U by those Givens rotations */
/* which rotated B to be upper bidiagonal */
if (iuplo == 2 && icompq == 2) {
dlasr_("L", "V", "B", n, n, &work[1], &work[*n], &u[u_offset], ldu);
}
return 0;
/* End of DBDSDC */
} /* dbdsdc_ */
/*< subroutine dstqrb ( n, d, e, z, work, info ) >*/
/* Subroutine */ int dstqrb_(integer *n, doublereal *d__, doublereal *e,
doublereal *z__, doublereal *work, integer *info)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
doublereal b, c__, f, g;
integer i__, j, k, l, m;
doublereal p, r__, s;
integer l1, ii, mm, lm1, mm1, nm1;
doublereal rt1, rt2, eps;
integer lsv;
doublereal tst, eps2;
integer lend, jtot;
extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *), dlasr_(char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, ftnlen, ftnlen, ftnlen);
doublereal anorm;
extern /* Subroutine */ int dlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
integer lendm1, lendp1;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *,
ftnlen);
integer iscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, ftnlen);
doublereal safmin;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
doublereal safmax;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *,
ftnlen);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *, ftnlen);
integer lendsv, nmaxit, icompz;
doublereal ssfmax, ssfmin;
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/*< integer info, n >*/
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/*< >*/
/* .. parameters .. */
/*< >*/
/*< >*/
/*< integer maxit >*/
/*< parameter ( maxit = 30 ) >*/
/* .. */
/* .. local scalars .. */
/*< >*/
/*< >*/
/* .. */
/* .. external functions .. */
/*< logical lsame >*/
/*< >*/
/*< external lsame, dlamch, dlanst, dlapy2 >*/
/* .. */
/* .. external subroutines .. */
/*< >*/
/* .. */
/* .. intrinsic functions .. */
/*< intrinsic abs, max, sign, sqrt >*/
/* .. */
/* .. executable statements .. */
/* test the input parameters. */
/*< info = 0 >*/
/* Parameter adjustments */
--work;
--z__;
--e;
--d__;
/* Function Body */
*info = 0;
/* $$$ IF( LSAME( COMPZ, 'N' ) ) THEN */
/* $$$ ICOMPZ = 0 */
/* $$$ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN */
/* $$$ ICOMPZ = 1 */
/* $$$ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN */
/* $$$ ICOMPZ = 2 */
/* $$$ ELSE */
/* $$$ ICOMPZ = -1 */
/* $$$ END IF */
/* $$$ IF( ICOMPZ.LT.0 ) THEN */
/* $$$ INFO = -1 */
/* $$$ ELSE IF( N.LT.0 ) THEN */
/* $$$ INFO = -2 */
/* $$$ ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, */
/* $$$ $ N ) ) ) THEN */
/* $$$ INFO = -6 */
/* $$$ END IF */
/* $$$ IF( INFO.NE.0 ) THEN */
/* $$$ CALL XERBLA( 'SSTEQR', -INFO ) */
/* $$$ RETURN */
/* $$$ END IF */
/* *** New starting with version 2.5 *** */
/*< icompz = 2 >*/
icompz = 2;
/* ************************************* */
/* quick return if possible */
/*< >*/
if (*n == 0) {
return 0;
}
/*< if( n.eq.1 ) then >*/
if (*n == 1) {
/*< if( icompz.eq.2 ) z( 1 ) = one >*/
if (icompz == 2) {
z__[1] = 1.;
}
/*< return >*/
return 0;
/*< end if >*/
}
/* determine the unit roundoff and over/underflow thresholds. */
/*< eps = dlamch( 'e' ) >*/
eps = dlamch_("e", (ftnlen)1);
/*< eps2 = eps**2 >*/
/* Computing 2nd power */
d__1 = eps;
eps2 = d__1 * d__1;
/*< safmin = dlamch( 's' ) >*/
safmin = dlamch_("s", (ftnlen)1);
/*< safmax = one / safmin >*/
safmax = 1. / safmin;
/*< ssfmax = sqrt( safmax ) / three >*/
ssfmax = sqrt(safmax) / 3.;
/*< ssfmin = sqrt( safmin ) / eps2 >*/
ssfmin = sqrt(safmin) / eps2;
/* compute the eigenvalues and eigenvectors of the tridiagonal */
/* matrix. */
/* $$ if( icompz.eq.2 ) */
/* $$$ $ call dlaset( 'full', n, n, zero, one, z, ldz ) */
/* *** New starting with version 2.5 *** */
/*< if ( icompz .eq. 2 ) then >*/
if (icompz == 2) {
/*< do 5 j = 1, n-1 >*/
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/*< z(j) = zero >*/
z__[j] = 0.;
/*< 5 continue >*/
/* L5: */
}
/*< z( n ) = one >*/
z__[*n] = 1.;
/*< end if >*/
}
/* ************************************* */
/*< nmaxit = n*maxit >*/
nmaxit = *n * 30;
/*< jtot = 0 >*/
jtot = 0;
/* determine where the matrix splits and choose ql or qr iteration */
/* for each block, according to whether top or bottom diagonal */
/* element is smaller. */
/*< l1 = 1 >*/
l1 = 1;
/*< nm1 = n - 1 >*/
nm1 = *n - 1;
/*< 10 continue >*/
L10:
/*< >*/
if (l1 > *n) {
goto L160;
}
/*< >*/
if (l1 > 1) {
e[l1 - 1] = 0.;
}
/*< if( l1.le.nm1 ) then >*/
if (l1 <= nm1) {
/*< do 20 m = l1, nm1 >*/
i__1 = nm1;
for (m = l1; m <= i__1; ++m) {
/*< tst = abs( e( m ) ) >*/
tst = (d__1 = e[m], abs(d__1));
/*< >*/
if (tst == 0.) {
goto L30;
}
/*< >*/
if (tst <= sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m
+ 1], abs(d__2))) * eps) {
/*< e( m ) = zero >*/
e[m] = 0.;
/*< go to 30 >*/
goto L30;
/*< end if >*/
}
/*< 20 continue >*/
/* L20: */
}
/*< end if >*/
}
/*< m = n >*/
m = *n;
/*< 30 continue >*/
L30:
/*< l = l1 >*/
l = l1;
/*< lsv = l >*/
lsv = l;
/*< lend = m >*/
lend = m;
/*< lendsv = lend >*/
lendsv = lend;
/*< l1 = m + 1 >*/
l1 = m + 1;
/*< >*/
if (lend == l) {
goto L10;
}
/* scale submatrix in rows and columns l to lend */
/*< anorm = dlanst( 'i', lend-l+1, d( l ), e( l ) ) >*/
i__1 = lend - l + 1;
anorm = dlanst_("i", &i__1, &d__[l], &e[l], (ftnlen)1);
/*< iscale = 0 >*/
iscale = 0;
/*< >*/
if (anorm == 0.) {
goto L10;
}
/*< if( anorm.gt.ssfmax ) then >*/
if (anorm > ssfmax) {
/*< iscale = 1 >*/
iscale = 1;
/*< >*/
i__1 = lend - l + 1;
dlascl_("g", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
info, (ftnlen)1);
/*< >*/
i__1 = lend - l;
dlascl_("g", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
info, (ftnlen)1);
/*< else if( anorm.lt.ssfmin ) then >*/
} else if (anorm < ssfmin) {
/*< iscale = 2 >*/
iscale = 2;
/*< >*/
i__1 = lend - l + 1;
dlascl_("g", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
info, (ftnlen)1);
/*< >*/
i__1 = lend - l;
dlascl_("g", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
info, (ftnlen)1);
/*< end if >*/
}
/* choose between ql and qr iteration */
/*< if( abs( d( lend ) ).lt.abs( d( l ) ) ) then >*/
if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) {
/*< lend = lsv >*/
lend = lsv;
/*< l = lendsv >*/
l = lendsv;
/*< end if >*/
}
/*< if( lend.gt.l ) then >*/
if (lend > l) {
/* ql iteration */
/* look for small subdiagonal element. */
/*< 40 continue >*/
L40:
/*< if( l.ne.lend ) then >*/
if (l != lend) {
/*< lendm1 = lend - 1 >*/
lendm1 = lend - 1;
/*< do 50 m = l, lendm1 >*/
i__1 = lendm1;
for (m = l; m <= i__1; ++m) {
/*< tst = abs( e( m ) )**2 >*/
/* Computing 2nd power */
d__2 = (d__1 = e[m], abs(d__1));
tst = d__2 * d__2;
/*< >*/
if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
+ 1], abs(d__2)) + safmin) {
goto L60;
}
/*< 50 continue >*/
/* L50: */
}
/*< end if >*/
}
/*< m = lend >*/
m = lend;
/*< 60 continue >*/
L60:
/*< >*/
if (m < lend) {
e[m] = 0.;
}
/*< p = d( l ) >*/
p = d__[l];
/*< >*/
if (m == l) {
goto L80;
}
/* if remaining matrix is 2-by-2, use dlae2 or dlaev2 */
/* to compute its eigensystem. */
/*< if( m.eq.l+1 ) then >*/
if (m == l + 1) {
/*< if( icompz.gt.0 ) then >*/
if (icompz > 0) {
/*< call dlaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s ) >*/
dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
/*< work( l ) = c >*/
work[l] = c__;
/*< work( n-1+l ) = s >*/
work[*n - 1 + l] = s;
/* $$$ call dlasr( 'r', 'v', 'b', n, 2, work( l ), */
/* $$$ $ work( n-1+l ), z( 1, l ), ldz ) */
/* *** New starting with version 2.5 *** */
/*< tst = z(l+1) >*/
tst = z__[l + 1];
/*< z(l+1) = c*tst - s*z(l) >*/
z__[l + 1] = c__ * tst - s * z__[l];
/*< z(l) = s*tst + c*z(l) >*/
z__[l] = s * tst + c__ * z__[l];
/* ************************************* */
/*< else >*/
} else {
/*< call dlae2( d( l ), e( l ), d( l+1 ), rt1, rt2 ) >*/
dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
/*< end if >*/
}
/*< d( l ) = rt1 >*/
d__[l] = rt1;
/*< d( l+1 ) = rt2 >*/
d__[l + 1] = rt2;
/*< e( l ) = zero >*/
e[l] = 0.;
/*< l = l + 2 >*/
l += 2;
/*< >*/
if (l <= lend) {
goto L40;
}
/*< go to 140 >*/
goto L140;
/*< end if >*/
}
/*< >*/
if (jtot == nmaxit) {
goto L140;
}
/*< jtot = jtot + 1 >*/
++jtot;
/* form shift. */
/*< g = ( d( l+1 )-p ) / ( two*e( l ) ) >*/
g = (d__[l + 1] - p) / (e[l] * 2.);
/*< r = dlapy2( g, one ) >*/
r__ = dlapy2_(&g, &c_b31);
/*< g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) ) >*/
g = d__[m] - p + e[l] / (g + d_sign(&r__, &g));
/*< s = one >*/
s = 1.;
/*< c = one >*/
c__ = 1.;
/*< p = zero >*/
p = 0.;
/* inner loop */
/*< mm1 = m - 1 >*/
mm1 = m - 1;
/*< do 70 i = mm1, l, -1 >*/
i__1 = l;
for (i__ = mm1; i__ >= i__1; --i__) {
/*< f = s*e( i ) >*/
f = s * e[i__];
/*< b = c*e( i ) >*/
b = c__ * e[i__];
/*< call dlartg( g, f, c, s, r ) >*/
dlartg_(&g, &f, &c__, &s, &r__);
/*< >*/
if (i__ != m - 1) {
e[i__ + 1] = r__;
}
/*< g = d( i+1 ) - p >*/
g = d__[i__ + 1] - p;
/*< r = ( d( i )-g )*s + two*c*b >*/
r__ = (d__[i__] - g) * s + c__ * 2. * b;
/*< p = s*r >*/
p = s * r__;
/*< d( i+1 ) = g + p >*/
d__[i__ + 1] = g + p;
/*< g = c*r - b >*/
g = c__ * r__ - b;
/* if eigenvectors are desired, then save rotations. */
/*< if( icompz.gt.0 ) then >*/
if (icompz > 0) {
/*< work( i ) = c >*/
work[i__] = c__;
/*< work( n-1+i ) = -s >*/
work[*n - 1 + i__] = -s;
/*< end if >*/
}
/*< 70 continue >*/
/* L70: */
}
/* if eigenvectors are desired, then apply saved rotations. */
/*< if( icompz.gt.0 ) then >*/
if (icompz > 0) {
/*< mm = m - l + 1 >*/
mm = m - l + 1;
/* $$$ call dlasr( 'r', 'v', 'b', n, mm, work( l ), work( n-1+l ), */
/* $$$ $ z( 1, l ), ldz ) */
/* *** New starting with version 2.5 *** */
/*< >*/
dlasr_("r", "v", "b", &c__1, &mm, &work[l], &work[*n - 1 + l], &
z__[l], &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
/* ************************************* */
/*< end if >*/
}
/*< d( l ) = d( l ) - p >*/
d__[l] -= p;
/*< e( l ) = g >*/
e[l] = g;
/*< go to 40 >*/
goto L40;
/* eigenvalue found. */
/*< 80 continue >*/
L80:
/*< d( l ) = p >*/
d__[l] = p;
/*< l = l + 1 >*/
++l;
/*< >*/
if (l <= lend) {
goto L40;
}
/*< go to 140 >*/
goto L140;
/*< else >*/
} else {
/* qr iteration */
/* look for small superdiagonal element. */
/*< 90 continue >*/
L90:
/*< if( l.ne.lend ) then >*/
if (l != lend) {
/*< lendp1 = lend + 1 >*/
lendp1 = lend + 1;
/*< do 100 m = l, lendp1, -1 >*/
i__1 = lendp1;
for (m = l; m >= i__1; --m) {
/*< tst = abs( e( m-1 ) )**2 >*/
/* Computing 2nd power */
d__2 = (d__1 = e[m - 1], abs(d__1));
tst = d__2 * d__2;
/*< >*/
if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
- 1], abs(d__2)) + safmin) {
goto L110;
}
/*< 100 continue >*/
/* L100: */
}
/*< end if >*/
}
/*< m = lend >*/
m = lend;
/*< 110 continue >*/
L110:
/*< >*/
if (m > lend) {
e[m - 1] = 0.;
}
/*< p = d( l ) >*/
p = d__[l];
/*< >*/
if (m == l) {
goto L130;
}
/* if remaining matrix is 2-by-2, use dlae2 or dlaev2 */
/* to compute its eigensystem. */
/*< if( m.eq.l-1 ) then >*/
if (m == l - 1) {
/*< if( icompz.gt.0 ) then >*/
if (icompz > 0) {
/*< call dlaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s ) >*/
dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
;
/* $$$ work( m ) = c */
/* $$$ work( n-1+m ) = s */
/* $$$ call dlasr( 'r', 'v', 'f', n, 2, work( m ), */
/* $$$ $ work( n-1+m ), z( 1, l-1 ), ldz ) */
/* *** New starting with version 2.5 *** */
/*< tst = z(l) >*/
tst = z__[l];
/*< z(l) = c*tst - s*z(l-1) >*/
z__[l] = c__ * tst - s * z__[l - 1];
/*< z(l-1) = s*tst + c*z(l-1) >*/
z__[l - 1] = s * tst + c__ * z__[l - 1];
/* ************************************* */
/*< else >*/
} else {
/*< call dlae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 ) >*/
dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
/*< end if >*/
}
/*< d( l-1 ) = rt1 >*/
d__[l - 1] = rt1;
/*< d( l ) = rt2 >*/
d__[l] = rt2;
/*< e( l-1 ) = zero >*/
e[l - 1] = 0.;
/*< l = l - 2 >*/
l += -2;
/*< >*/
if (l >= lend) {
goto L90;
}
/*< go to 140 >*/
goto L140;
/*< end if >*/
}
/*< >*/
if (jtot == nmaxit) {
goto L140;
}
/*< jtot = jtot + 1 >*/
++jtot;
/* form shift. */
/*< g = ( d( l-1 )-p ) / ( two*e( l-1 ) ) >*/
g = (d__[l - 1] - p) / (e[l - 1] * 2.);
/*< r = dlapy2( g, one ) >*/
r__ = dlapy2_(&g, &c_b31);
/*< g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) ) >*/
g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g));
/*< s = one >*/
s = 1.;
/*< c = one >*/
c__ = 1.;
/*< p = zero >*/
p = 0.;
/* inner loop */
/*< lm1 = l - 1 >*/
lm1 = l - 1;
/*< do 120 i = m, lm1 >*/
i__1 = lm1;
for (i__ = m; i__ <= i__1; ++i__) {
/*< f = s*e( i ) >*/
f = s * e[i__];
/*< b = c*e( i ) >*/
b = c__ * e[i__];
/*< call dlartg( g, f, c, s, r ) >*/
dlartg_(&g, &f, &c__, &s, &r__);
/*< >*/
if (i__ != m) {
e[i__ - 1] = r__;
}
/*< g = d( i ) - p >*/
g = d__[i__] - p;
/*< r = ( d( i+1 )-g )*s + two*c*b >*/
r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b;
/*< p = s*r >*/
p = s * r__;
/*< d( i ) = g + p >*/
d__[i__] = g + p;
/*< g = c*r - b >*/
g = c__ * r__ - b;
/* if eigenvectors are desired, then save rotations. */
/*< if( icompz.gt.0 ) then >*/
if (icompz > 0) {
/*< work( i ) = c >*/
work[i__] = c__;
/*< work( n-1+i ) = s >*/
work[*n - 1 + i__] = s;
/*< end if >*/
}
/*< 120 continue >*/
/* L120: */
}
/* if eigenvectors are desired, then apply saved rotations. */
/*< if( icompz.gt.0 ) then >*/
if (icompz > 0) {
/*< mm = l - m + 1 >*/
mm = l - m + 1;
/* $$$ call dlasr( 'r', 'v', 'f', n, mm, work( m ), work( n-1+m ), */
/* $$$ $ z( 1, m ), ldz ) */
/* *** New starting with version 2.5 *** */
/*< >*/
dlasr_("r", "v", "f", &c__1, &mm, &work[m], &work[*n - 1 + m], &
z__[m], &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
/* ************************************* */
/*< end if >*/
}
/*< d( l ) = d( l ) - p >*/
d__[l] -= p;
/*< e( lm1 ) = g >*/
e[lm1] = g;
/*< go to 90 >*/
goto L90;
/* eigenvalue found. */
/*< 130 continue >*/
L130:
/*< d( l ) = p >*/
d__[l] = p;
/*< l = l - 1 >*/
--l;
/*< >*/
if (l >= lend) {
goto L90;
}
/*< go to 140 >*/
goto L140;
/*< end if >*/
}
/* undo scaling if necessary */
/*< 140 continue >*/
L140:
/*< if( iscale.eq.1 ) then >*/
if (iscale == 1) {
/*< >*/
i__1 = lendsv - lsv + 1;
dlascl_("g", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
n, info, (ftnlen)1);
/*< >*/
i__1 = lendsv - lsv;
dlascl_("g", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
info, (ftnlen)1);
/*< else if( iscale.eq.2 ) then >*/
} else if (iscale == 2) {
/*< >*/
i__1 = lendsv - lsv + 1;
dlascl_("g", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
n, info, (ftnlen)1);
/*< >*/
i__1 = lendsv - lsv;
dlascl_("g", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n,
info, (ftnlen)1);
/*< end if >*/
}
/* check for no convergence to an eigenvalue after a total */
/* of n*maxit iterations. */
/*< >*/
if (jtot < nmaxit) {
goto L10;
}
/*< do 150 i = 1, n - 1 >*/
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< >*/
if (e[i__] != 0.) {
++(*info);
}
/*< 150 continue >*/
/* L150: */
}
/*< go to 190 >*/
goto L190;
/* order eigenvalues and eigenvectors. */
/*< 160 continue >*/
L160:
/*< if( icompz.eq.0 ) then >*/
if (icompz == 0) {
/* use quick sort */
/*< call dlasrt( 'i', n, d, info ) >*/
dlasrt_("i", n, &d__[1], info, (ftnlen)1);
/*< else >*/
} else {
/* use selection sort to minimize swaps of eigenvectors */
/*< do 180 ii = 2, n >*/
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
/*< i = ii - 1 >*/
i__ = ii - 1;
/*< k = i >*/
k = i__;
/*< p = d( i ) >*/
p = d__[i__];
/*< do 170 j = ii, n >*/
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
/*< if( d( j ).lt.p ) then >*/
if (d__[j] < p) {
/*< k = j >*/
k = j;
/*< p = d( j ) >*/
p = d__[j];
/*< end if >*/
}
/*< 170 continue >*/
/* L170: */
}
/*< if( k.ne.i ) then >*/
if (k != i__) {
/*< d( k ) = d( i ) >*/
d__[k] = d__[i__];
/*< d( i ) = p >*/
d__[i__] = p;
/* $$$ call dswap( n, z( 1, i ), 1, z( 1, k ), 1 ) */
/* *** New starting with version 2.5 *** */
/*< p = z(k) >*/
p = z__[k];
/*< z(k) = z(i) >*/
z__[k] = z__[i__];
/*< z(i) = p >*/
z__[i__] = p;
/* ************************************* */
/*< end if >*/
}
/*< 180 continue >*/
/* L180: */
}
/*< end if >*/
}
/*< 190 continue >*/
L190:
/*< return >*/
return 0;
/* %---------------% */
/* | End of dstqrb | */
/* %---------------% */
/*< end >*/
} /* dstqrb_ */
/* DECK ZACON */
/* Subroutine */ int zacon_(doublereal *zr, doublereal *zi, doublereal *fnu,
integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *
yi, integer *nz, doublereal *rl, doublereal *fnul, doublereal *tol,
doublereal *elim, doublereal *alim)
{
/* Initialized data */
static doublereal pi = 3.14159265358979324;
static doublereal zeror = 0.;
static doublereal coner = 1.;
/* System generated locals */
integer i__1;
/* Local variables */
static integer i__;
static doublereal fn;
static integer nn, nw;
static doublereal yy, c1i, c2i, c1m, as2, c1r, c2r, s1i, s2i, s1r, s2r,
cki, arg, ckr, cpn;
static integer iuf;
static doublereal cyi[2], fmr, csr, azn, sgn;
static integer inu;
static doublereal bry[3], cyr[2], pti, spn, sti, zni, rzi, ptr, str, znr,
rzr, sc1i, sc2i, sc1r, sc2r, cscl, cscr;
extern doublereal zabs_(doublereal *, doublereal *);
static doublereal csrr[3], cssr[3], razn;
extern /* Subroutine */ int zs1s2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *), zmlt_(doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
static integer kflag;
static doublereal ascle, bscle, csgni, csgnr, cspni, cspnr;
extern /* Subroutine */ int zbinu_(doublereal *, doublereal *, doublereal
*, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), zbknu_(doublereal *, doublereal *, doublereal *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *);
extern doublereal d1mach_(integer *);
/* ***BEGIN PROLOGUE ZACON */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to ZBESH and ZBESK */
/* ***LIBRARY SLATEC */
/* ***TYPE ALL (CACON-A, ZACON-A) */
/* ***AUTHOR Amos, D. E., (SNL) */
/* ***DESCRIPTION */
/* ZACON APPLIES THE ANALYTIC CONTINUATION FORMULA */
/* K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) */
/* MP=PI*MR*CMPLX(0.0,1.0) */
/* TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT */
/* HALF Z PLANE */
/* ***SEE ALSO ZBESH, ZBESK */
/* ***ROUTINES CALLED D1MACH, ZABS, ZBINU, ZBKNU, ZMLT, ZS1S2 */
/* ***REVISION HISTORY (YYMMDD) */
/* 830501 DATE WRITTEN */
/* 910415 Prologue converted to Version 4.0 format. (BAB) */
/* ***END PROLOGUE ZACON */
/* COMPLEX CK,CONE,CSCL,CSCR,CSGN,CSPN,CY,CZERO,C1,C2,RZ,SC1,SC2,ST, */
/* *S1,S2,Y,Z,ZN */
/* Parameter adjustments */
--yi;
--yr;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT ZACON */
*nz = 0;
znr = -(*zr);
zni = -(*zi);
nn = *n;
zbinu_(&znr, &zni, fnu, kode, &nn, &yr[1], &yi[1], &nw, rl, fnul, tol,
elim, alim);
if (nw < 0) {
goto L90;
}
/* ----------------------------------------------------------------------- */
/* ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION */
/* ----------------------------------------------------------------------- */
nn = min(2,*n);
zbknu_(&znr, &zni, fnu, kode, &nn, cyr, cyi, &nw, tol, elim, alim);
if (nw != 0) {
goto L90;
}
s1r = cyr[0];
s1i = cyi[0];
fmr = (doublereal) (*mr);
sgn = -d_sign(&pi, &fmr);
csgnr = zeror;
csgni = sgn;
if (*kode == 1) {
goto L10;
}
yy = -zni;
cpn = cos(yy);
spn = sin(yy);
zmlt_(&csgnr, &csgni, &cpn, &spn, &csgnr, &csgni);
L10:
/* ----------------------------------------------------------------------- */
/* CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE */
/* WHEN FNU IS LARGE */
/* ----------------------------------------------------------------------- */
inu = (integer) (*fnu);
arg = (*fnu - inu) * sgn;
cpn = cos(arg);
spn = sin(arg);
cspnr = cpn;
cspni = spn;
if (inu % 2 == 0) {
goto L20;
}
cspnr = -cspnr;
cspni = -cspni;
L20:
iuf = 0;
c1r = s1r;
c1i = s1i;
c2r = yr[1];
c2i = yi[1];
ascle = d1mach_(&c__1) * 1e3 / *tol;
if (*kode == 1) {
goto L30;
}
zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
*nz += nw;
sc1r = c1r;
sc1i = c1i;
L30:
zmlt_(&cspnr, &cspni, &c1r, &c1i, &str, &sti);
zmlt_(&csgnr, &csgni, &c2r, &c2i, &ptr, &pti);
yr[1] = str + ptr;
yi[1] = sti + pti;
if (*n == 1) {
return 0;
}
cspnr = -cspnr;
cspni = -cspni;
s2r = cyr[1];
s2i = cyi[1];
c1r = s2r;
c1i = s2i;
c2r = yr[2];
c2i = yi[2];
if (*kode == 1) {
goto L40;
}
zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
*nz += nw;
sc2r = c1r;
sc2i = c1i;
L40:
zmlt_(&cspnr, &cspni, &c1r, &c1i, &str, &sti);
zmlt_(&csgnr, &csgni, &c2r, &c2i, &ptr, &pti);
yr[2] = str + ptr;
yi[2] = sti + pti;
if (*n == 2) {
return 0;
}
cspnr = -cspnr;
cspni = -cspni;
azn = zabs_(&znr, &zni);
razn = 1. / azn;
str = znr * razn;
sti = -zni * razn;
rzr = (str + str) * razn;
rzi = (sti + sti) * razn;
fn = *fnu + 1.;
ckr = fn * rzr;
cki = fn * rzi;
/* ----------------------------------------------------------------------- */
/* SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS */
/* ----------------------------------------------------------------------- */
cscl = 1. / *tol;
cscr = *tol;
cssr[0] = cscl;
cssr[1] = coner;
cssr[2] = cscr;
csrr[0] = cscr;
csrr[1] = coner;
csrr[2] = cscl;
bry[0] = ascle;
bry[1] = 1. / ascle;
bry[2] = d1mach_(&c__2);
as2 = zabs_(&s2r, &s2i);
kflag = 2;
if (as2 > bry[0]) {
goto L50;
}
kflag = 1;
goto L60;
L50:
if (as2 < bry[1]) {
goto L60;
}
kflag = 3;
L60:
bscle = bry[kflag - 1];
s1r *= cssr[kflag - 1];
s1i *= cssr[kflag - 1];
s2r *= cssr[kflag - 1];
s2i *= cssr[kflag - 1];
csr = csrr[kflag - 1];
i__1 = *n;
for (i__ = 3; i__ <= i__1; ++i__) {
str = s2r;
sti = s2i;
s2r = ckr * str - cki * sti + s1r;
s2i = ckr * sti + cki * str + s1i;
s1r = str;
s1i = sti;
c1r = s2r * csr;
c1i = s2i * csr;
str = c1r;
sti = c1i;
c2r = yr[i__];
c2i = yi[i__];
if (*kode == 1) {
goto L70;
}
if (iuf < 0) {
goto L70;
}
zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
*nz += nw;
sc1r = sc2r;
sc1i = sc2i;
sc2r = c1r;
sc2i = c1i;
if (iuf != 3) {
goto L70;
}
iuf = -4;
s1r = sc1r * cssr[kflag - 1];
s1i = sc1i * cssr[kflag - 1];
s2r = sc2r * cssr[kflag - 1];
s2i = sc2i * cssr[kflag - 1];
str = sc2r;
sti = sc2i;
L70:
ptr = cspnr * c1r - cspni * c1i;
pti = cspnr * c1i + cspni * c1r;
yr[i__] = ptr + csgnr * c2r - csgni * c2i;
yi[i__] = pti + csgnr * c2i + csgni * c2r;
ckr += rzr;
cki += rzi;
cspnr = -cspnr;
cspni = -cspni;
if (kflag >= 3) {
goto L80;
}
ptr = abs(c1r);
pti = abs(c1i);
c1m = max(ptr,pti);
if (c1m <= bscle) {
goto L80;
}
++kflag;
bscle = bry[kflag - 1];
s1r *= csr;
s1i *= csr;
s2r = str;
s2i = sti;
s1r *= cssr[kflag - 1];
s1i *= cssr[kflag - 1];
s2r *= cssr[kflag - 1];
s2i *= cssr[kflag - 1];
csr = csrr[kflag - 1];
L80:
;
}
return 0;
L90:
*nz = -1;
if (nw == -2) {
*nz = -2;
}
return 0;
} /* zacon_ */
/* Subroutine */ int dbdsqr_(char *uplo, integer *n, integer *ncvt, integer *
nru, integer *ncc, doublereal *d__, doublereal *e, doublereal *vt,
integer *ldvt, doublereal *u, integer *ldu, doublereal *c__, integer *
ldc, doublereal *work, integer *info)
{
/* System generated locals */
integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
i__2;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *), sqrt(doublereal), d_sign(
doublereal *, doublereal *);
/* Local variables */
static doublereal abse;
static integer idir;
static doublereal abss;
static integer oldm;
static doublereal cosl;
static integer isub, iter;
static doublereal unfl, sinl, cosr, smin, smax, sinr;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *), dlas2_(
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
static doublereal f, g, h__;
static integer i__, j, m;
static doublereal r__;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
static doublereal oldcs;
extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *);
static integer oldll;
static doublereal shift, sigmn, oldsn;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer maxit;
static doublereal sminl, sigmx;
static logical lower;
extern /* Subroutine */ int dlasq1_(integer *, doublereal *, doublereal *,
doublereal *, integer *), dlasv2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
static doublereal cs;
static integer ll;
extern doublereal dlamch_(char *);
static doublereal sn, mu;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *), xerbla_(char *,
integer *);
static doublereal sminoa, thresh;
static logical rotate;
static doublereal sminlo;
static integer nm1;
static doublereal tolmul;
static integer nm12, nm13, lll;
static doublereal eps, sll, tol;
#define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1]
#define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1]
#define vt_ref(a_1,a_2) vt[(a_2)*vt_dim1 + a_1]
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1999
Purpose
=======
DBDSQR computes the singular value decomposition (SVD) of a real
N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P'
denotes the transpose of P), where S is a diagonal matrix with
non-negative diagonal elements (the singular values of B), and Q
and P are orthogonal matrices.
The routine computes S, and optionally computes U * Q, P' * VT,
or Q' * C, for given real input matrices U, VT, and C.
See "Computing Small Singular Values of Bidiagonal Matrices With
Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
no. 5, pp. 873-912, Sept 1990) and
"Accurate singular values and differential qd algorithms," by
B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
Department, University of California at Berkeley, July 1992
for a detailed description of the algorithm.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': B is upper bidiagonal;
= 'L': B is lower bidiagonal.
N (input) INTEGER
The order of the matrix B. N >= 0.
NCVT (input) INTEGER
The number of columns of the matrix VT. NCVT >= 0.
NRU (input) INTEGER
The number of rows of the matrix U. NRU >= 0.
NCC (input) INTEGER
The number of columns of the matrix C. NCC >= 0.
D (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the n diagonal elements of the bidiagonal matrix B.
On exit, if INFO=0, the singular values of B in decreasing
order.
E (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the elements of E contain the
offdiagonal elements of the bidiagonal matrix whose SVD
is desired. On normal exit (INFO = 0), E is destroyed.
If the algorithm does not converge (INFO > 0), D and E
will contain the diagonal and superdiagonal elements of a
bidiagonal matrix orthogonally equivalent to the one given
as input. E(N) is used for workspace.
VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)
On entry, an N-by-NCVT matrix VT.
On exit, VT is overwritten by P' * VT.
VT is not referenced if NCVT = 0.
LDVT (input) INTEGER
The leading dimension of the array VT.
LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
U (input/output) DOUBLE PRECISION array, dimension (LDU, N)
On entry, an NRU-by-N matrix U.
On exit, U is overwritten by U * Q.
U is not referenced if NRU = 0.
LDU (input) INTEGER
The leading dimension of the array U. LDU >= max(1,NRU).
C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)
On entry, an N-by-NCC matrix C.
On exit, C is overwritten by Q' * C.
C is not referenced if NCC = 0.
LDC (input) INTEGER
The leading dimension of the array C.
LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
INFO (output) INTEGER
= 0: successful exit
< 0: If INFO = -i, the i-th argument had an illegal value
> 0: the algorithm did not converge; D and E contain the
elements of a bidiagonal matrix which is orthogonally
similar to the input matrix B; if INFO = i, i
elements of E have not converged to zero.
Internal Parameters
===================
TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))
TOLMUL controls the convergence criterion of the QR loop.
If it is positive, TOLMUL*EPS is the desired relative
precision in the computed singular values.
If it is negative, abs(TOLMUL*EPS*sigma_max) is the
desired absolute accuracy in the computed singular
values (corresponds to relative accuracy
abs(TOLMUL*EPS) in the largest singular value.
abs(TOLMUL) should be between 1 and 1/EPS, and preferably
between 10 (for fast convergence) and .1/EPS
(for there to be some accuracy in the results).
Default is to lose at either one eighth or 2 of the
available decimal digits in each computed singular value
(whichever is smaller).
MAXITR INTEGER, default = 6
MAXITR controls the maximum number of passes of the
algorithm through its inner loop. The algorithms stops
(and so fails to converge) if the number of passes
through the inner loop exceeds MAXITR*N**2.
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--e;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1 * 1;
vt -= vt_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
lower = lsame_(uplo, "L");
if (! lsame_(uplo, "U") && ! lower) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ncvt < 0) {
*info = -3;
} else if (*nru < 0) {
*info = -4;
} else if (*ncc < 0) {
*info = -5;
} else if ((*ncvt == 0 && *ldvt < 1) ||
(*ncvt > 0 && *ldvt < max(1,*n))) {
*info = -9;
} else if (*ldu < max(1,*nru)) {
*info = -11;
} else if ((*ncc == 0 && *ldc < 1) ||
(*ncc > 0 && *ldc < max(1,*n))) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DBDSQR", &i__1);
return 0;
}
if (*n == 0) {
return 0;
}
if (*n == 1) {
goto L160;
}
/* ROTATE is true if any singular vectors desired, false otherwise */
rotate = *ncvt > 0 || *nru > 0 || *ncc > 0;
/* If no singular vectors desired, use qd algorithm */
if (! rotate) {
dlasq1_(n, &d__[1], &e[1], &work[1], info);
return 0;
}
nm1 = *n - 1;
nm12 = nm1 + nm1;
nm13 = nm12 + nm1;
idir = 0;
/* Get machine constants */
eps = dlamch_("Epsilon");
unfl = dlamch_("Safe minimum");
/* If matrix lower bidiagonal, rotate to be upper bidiagonal
by applying Givens rotations on the left */
if (lower) {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
work[i__] = cs;
work[nm1 + i__] = sn;
/* L10: */
}
/* Update singular vectors if desired */
if (*nru > 0) {
dlasr_("R", "V", "F", nru, n, &work[1], &work[*n], &u[u_offset],
ldu);
}
if (*ncc > 0) {
dlasr_("L", "V", "F", n, ncc, &work[1], &work[*n], &c__[c_offset],
ldc);
}
}
/* Compute singular values to relative accuracy TOL
(By setting TOL to be negative, algorithm will compute
singular values to absolute accuracy ABS(TOL)*norm(input matrix))
Computing MAX
Computing MIN */
d__3 = 100., d__4 = pow_dd(&eps, &c_b15);
d__1 = 10., d__2 = min(d__3,d__4);
tolmul = max(d__1,d__2);
tol = tolmul * eps;
/* Compute approximate maximum, minimum singular values */
smax = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = smax, d__3 = (d__1 = d__[i__], abs(d__1));
smax = max(d__2,d__3);
/* L20: */
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = smax, d__3 = (d__1 = e[i__], abs(d__1));
smax = max(d__2,d__3);
/* L30: */
}
sminl = 0.;
if (tol >= 0.) {
/* Relative accuracy desired */
sminoa = abs(d__[1]);
if (sminoa == 0.) {
goto L50;
}
mu = sminoa;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
mu = (d__2 = d__[i__], abs(d__2)) * (mu / (mu + (d__1 = e[i__ - 1]
, abs(d__1))));
sminoa = min(sminoa,mu);
if (sminoa == 0.) {
goto L50;
}
/* L40: */
}
L50:
sminoa /= sqrt((doublereal) (*n));
/* Computing MAX */
d__1 = tol * sminoa, d__2 = *n * 6 * *n * unfl;
thresh = max(d__1,d__2);
} else {
/* Absolute accuracy desired
Computing MAX */
d__1 = abs(tol) * smax, d__2 = *n * 6 * *n * unfl;
thresh = max(d__1,d__2);
}
/* Prepare for main iteration loop for the singular values
(MAXIT is the maximum number of passes through the inner
loop permitted before nonconvergence signalled.) */
maxit = *n * 6 * *n;
iter = 0;
oldll = -1;
oldm = -1;
/* M points to last element of unconverged part of matrix */
m = *n;
/* Begin main iteration loop */
L60:
/* Check for convergence or exceeding iteration count */
if (m <= 1) {
goto L160;
}
if (iter > maxit) {
goto L200;
}
/* Find diagonal block of matrix to work on */
if (tol < 0. && (d__1 = d__[m], abs(d__1)) <= thresh) {
d__[m] = 0.;
}
smax = (d__1 = d__[m], abs(d__1));
smin = smax;
i__1 = m - 1;
for (lll = 1; lll <= i__1; ++lll) {
ll = m - lll;
abss = (d__1 = d__[ll], abs(d__1));
abse = (d__1 = e[ll], abs(d__1));
if (tol < 0. && abss <= thresh) {
d__[ll] = 0.;
}
if (abse <= thresh) {
goto L80;
}
smin = min(smin,abss);
/* Computing MAX */
d__1 = max(smax,abss);
smax = max(d__1,abse);
/* L70: */
}
ll = 0;
goto L90;
L80:
e[ll] = 0.;
/* Matrix splits since E(LL) = 0 */
if (ll == m - 1) {
/* Convergence of bottom singular value, return to top of loop */
--m;
goto L60;
}
L90:
++ll;
/* E(LL) through E(M-1) are nonzero, E(LL-1) is zero */
if (ll == m - 1) {
/* 2 by 2 block, handle separately */
dlasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr,
&sinl, &cosl);
d__[m - 1] = sigmx;
e[m - 1] = 0.;
d__[m] = sigmn;
/* Compute singular vectors, if desired */
if (*ncvt > 0) {
drot_(ncvt, &vt_ref(m - 1, 1), ldvt, &vt_ref(m, 1), ldvt, &cosr, &
sinr);
}
if (*nru > 0) {
drot_(nru, &u_ref(1, m - 1), &c__1, &u_ref(1, m), &c__1, &cosl, &
sinl);
}
if (*ncc > 0) {
drot_(ncc, &c___ref(m - 1, 1), ldc, &c___ref(m, 1), ldc, &cosl, &
sinl);
}
m += -2;
goto L60;
}
/* If working on new submatrix, choose shift direction
(from larger end diagonal element towards smaller) */
if (ll > oldm || m < oldll) {
if ((d__1 = d__[ll], abs(d__1)) >= (d__2 = d__[m], abs(d__2))) {
/* Chase bulge from top (big end) to bottom (small end) */
idir = 1;
} else {
/* Chase bulge from bottom (big end) to top (small end) */
idir = 2;
}
}
/* Apply convergence tests */
if (idir == 1) {
/* Run convergence test in forward direction
First apply standard test to bottom of matrix */
if (((d__2 = e[m - 1], abs(d__2)) <=
abs(tol) * (d__1 = d__[m], abs(d__1))) ||
(tol < 0. && (d__3 = e[m - 1], abs(d__3)) <= thresh))
{
e[m - 1] = 0.;
goto L60;
}
if (tol >= 0.) {
/* If relative accuracy desired,
apply convergence criterion forward */
mu = (d__1 = d__[ll], abs(d__1));
sminl = mu;
i__1 = m - 1;
for (lll = ll; lll <= i__1; ++lll) {
if ((d__1 = e[lll], abs(d__1)) <= tol * mu) {
e[lll] = 0.;
goto L60;
}
sminlo = sminl;
mu = (d__2 = d__[lll + 1], abs(d__2)) * (mu / (mu + (d__1 = e[
lll], abs(d__1))));
sminl = min(sminl,mu);
/* L100: */
}
}
} else {
/* Run convergence test in backward direction
First apply standard test to top of matrix */
if ((d__2 = e[ll], abs(d__2)) <= abs(tol) * (d__1 = d__[ll], abs(d__1)
) ||
(tol < 0. && (d__3 = e[ll], abs(d__3)) <= thresh)) {
e[ll] = 0.;
goto L60;
}
if (tol >= 0.) {
/* If relative accuracy desired,
apply convergence criterion backward */
mu = (d__1 = d__[m], abs(d__1));
sminl = mu;
i__1 = ll;
for (lll = m - 1; lll >= i__1; --lll) {
if ((d__1 = e[lll], abs(d__1)) <= tol * mu) {
e[lll] = 0.;
goto L60;
}
sminlo = sminl;
mu = (d__2 = d__[lll], abs(d__2)) * (mu / (mu + (d__1 = e[lll]
, abs(d__1))));
sminl = min(sminl,mu);
/* L110: */
}
}
}
oldll = ll;
oldm = m;
/* Compute shift. First, test if shifting would ruin relative
accuracy, and if so set the shift to zero.
Computing MAX */
d__1 = eps, d__2 = tol * .01;
if (tol >= 0. && *n * tol * (sminl / smax) <= max(d__1,d__2)) {
/* Use a zero shift to avoid loss of relative accuracy */
shift = 0.;
} else {
/* Compute the shift from 2-by-2 block at end of matrix */
if (idir == 1) {
sll = (d__1 = d__[ll], abs(d__1));
dlas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__);
} else {
sll = (d__1 = d__[m], abs(d__1));
dlas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__);
}
/* Test if shift negligible, and if so set to zero */
if (sll > 0.) {
/* Computing 2nd power */
d__1 = shift / sll;
if (d__1 * d__1 < eps) {
shift = 0.;
}
}
}
/* Increment iteration count */
iter = iter + m - ll;
/* If SHIFT = 0, do simplified QR iteration */
if (shift == 0.) {
if (idir == 1) {
/* Chase bulge from top to bottom
Save cosines and sines for later singular vector updates */
cs = 1.;
oldcs = 1.;
i__1 = m - 1;
for (i__ = ll; i__ <= i__1; ++i__) {
d__1 = d__[i__] * cs;
dlartg_(&d__1, &e[i__], &cs, &sn, &r__);
if (i__ > ll) {
e[i__ - 1] = oldsn * r__;
}
d__1 = oldcs * r__;
d__2 = d__[i__ + 1] * sn;
dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
work[i__ - ll + 1] = cs;
work[i__ - ll + 1 + nm1] = sn;
work[i__ - ll + 1 + nm12] = oldcs;
work[i__ - ll + 1 + nm13] = oldsn;
/* L120: */
}
h__ = d__[m] * cs;
d__[m] = h__ * oldcs;
e[m - 1] = h__ * oldsn;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &
vt_ref(ll, 1), ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
dlasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13
+ 1], &u_ref(1, ll), ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13
+ 1], &c___ref(ll, 1), ldc);
}
/* Test convergence */
if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
e[m - 1] = 0.;
}
} else {
/* Chase bulge from bottom to top
Save cosines and sines for later singular vector updates */
cs = 1.;
oldcs = 1.;
i__1 = ll + 1;
for (i__ = m; i__ >= i__1; --i__) {
d__1 = d__[i__] * cs;
dlartg_(&d__1, &e[i__ - 1], &cs, &sn, &r__);
if (i__ < m) {
e[i__] = oldsn * r__;
}
d__1 = oldcs * r__;
d__2 = d__[i__ - 1] * sn;
dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
work[i__ - ll] = cs;
work[i__ - ll + nm1] = -sn;
work[i__ - ll + nm12] = oldcs;
work[i__ - ll + nm13] = -oldsn;
/* L130: */
}
h__ = d__[ll] * cs;
d__[ll] = h__ * oldcs;
e[ll] = h__ * oldsn;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[
nm13 + 1], &vt_ref(ll, 1), ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
dlasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u_ref(
1, ll), ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &
c___ref(ll, 1), ldc);
}
/* Test convergence */
if ((d__1 = e[ll], abs(d__1)) <= thresh) {
e[ll] = 0.;
}
}
} else {
/* Use nonzero shift */
if (idir == 1) {
/* Chase bulge from top to bottom
Save cosines and sines for later singular vector updates */
f = ((d__1 = d__[ll], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[
ll]) + shift / d__[ll]);
g = e[ll];
i__1 = m - 1;
for (i__ = ll; i__ <= i__1; ++i__) {
dlartg_(&f, &g, &cosr, &sinr, &r__);
if (i__ > ll) {
e[i__ - 1] = r__;
}
f = cosr * d__[i__] + sinr * e[i__];
e[i__] = cosr * e[i__] - sinr * d__[i__];
g = sinr * d__[i__ + 1];
d__[i__ + 1] = cosr * d__[i__ + 1];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[i__] = r__;
f = cosl * e[i__] + sinl * d__[i__ + 1];
d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__];
if (i__ < m - 1) {
g = sinl * e[i__ + 1];
e[i__ + 1] = cosl * e[i__ + 1];
}
work[i__ - ll + 1] = cosr;
work[i__ - ll + 1 + nm1] = sinr;
work[i__ - ll + 1 + nm12] = cosl;
work[i__ - ll + 1 + nm13] = sinl;
/* L140: */
}
e[m - 1] = f;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &
vt_ref(ll, 1), ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
dlasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13
+ 1], &u_ref(1, ll), ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13
+ 1], &c___ref(ll, 1), ldc);
}
/* Test convergence */
if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
e[m - 1] = 0.;
}
} else {
/* Chase bulge from bottom to top
Save cosines and sines for later singular vector updates */
f = ((d__1 = d__[m], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[m]
) + shift / d__[m]);
g = e[m - 1];
i__1 = ll + 1;
for (i__ = m; i__ >= i__1; --i__) {
dlartg_(&f, &g, &cosr, &sinr, &r__);
if (i__ < m) {
e[i__] = r__;
}
f = cosr * d__[i__] + sinr * e[i__ - 1];
e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__];
g = sinr * d__[i__ - 1];
d__[i__ - 1] = cosr * d__[i__ - 1];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[i__] = r__;
f = cosl * e[i__ - 1] + sinl * d__[i__ - 1];
d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1];
if (i__ > ll + 1) {
g = sinl * e[i__ - 2];
e[i__ - 2] = cosl * e[i__ - 2];
}
work[i__ - ll] = cosr;
work[i__ - ll + nm1] = -sinr;
work[i__ - ll + nm12] = cosl;
work[i__ - ll + nm13] = -sinl;
/* L150: */
}
e[ll] = f;
/* Test convergence */
if ((d__1 = e[ll], abs(d__1)) <= thresh) {
e[ll] = 0.;
}
/* Update singular vectors if desired */
if (*ncvt > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[
nm13 + 1], &vt_ref(ll, 1), ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
dlasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u_ref(
1, ll), ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &
c___ref(ll, 1), ldc);
}
}
}
/* QR iteration finished, go back and check convergence */
goto L60;
/* All singular values converged, so make them positive */
L160:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] < 0.) {
d__[i__] = -d__[i__];
/* Change sign of singular vectors, if desired */
if (*ncvt > 0) {
dscal_(ncvt, &c_b72, &vt_ref(i__, 1), ldvt);
}
}
/* L170: */
}
/* Sort the singular values into decreasing order (insertion sort on
singular values, but only one transposition per singular vector) */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Scan for smallest D(I) */
isub = 1;
smin = d__[1];
i__2 = *n + 1 - i__;
for (j = 2; j <= i__2; ++j) {
if (d__[j] <= smin) {
isub = j;
smin = d__[j];
}
/* L180: */
}
if (isub != *n + 1 - i__) {
/* Swap singular values and vectors */
d__[isub] = d__[*n + 1 - i__];
d__[*n + 1 - i__] = smin;
if (*ncvt > 0) {
dswap_(ncvt, &vt_ref(isub, 1), ldvt, &vt_ref(*n + 1 - i__, 1),
ldvt);
}
if (*nru > 0) {
dswap_(nru, &u_ref(1, isub), &c__1, &u_ref(1, *n + 1 - i__), &
c__1);
}
if (*ncc > 0) {
dswap_(ncc, &c___ref(isub, 1), ldc, &c___ref(*n + 1 - i__, 1),
ldc);
}
}
/* L190: */
}
goto L220;
/* Maximum number of iterations exceeded, failure to converge */
L200:
*info = 0;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.) {
++(*info);
}
/* L210: */
}
L220:
return 0;
/* End of DBDSQR */
} /* dbdsqr_ */
/* Subroutine */ int dlacon_(integer *n, doublereal *v, doublereal *x,
integer *isgn, doublereal *est, integer *kase)
{
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
double d_sign(doublereal *, doublereal *);
integer i_dnnt(doublereal *);
/* Local variables */
static integer i__, j, iter;
static doublereal temp;
static integer jump;
extern doublereal dasum_(integer *, doublereal *, integer *);
static integer jlast;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
static doublereal altsgn, estold;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLACON estimates the 1-norm of a square, real matrix A. */
/* Reverse communication is used for evaluating matrix-vector products. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix. N >= 1. */
/* V (workspace) DOUBLE PRECISION array, dimension (N) */
/* On the final return, V = A*W, where EST = norm(V)/norm(W) */
/* (W is not returned). */
/* X (input/output) DOUBLE PRECISION array, dimension (N) */
/* On an intermediate return, X should be overwritten by */
/* A * X, if KASE=1, */
/* A' * X, if KASE=2, */
/* and DLACON must be re-called with all the other parameters */
/* unchanged. */
/* ISGN (workspace) INTEGER array, dimension (N) */
/* EST (input/output) DOUBLE PRECISION */
/* On entry with KASE = 1 or 2 and JUMP = 3, EST should be */
/* unchanged from the previous call to DLACON. */
/* On exit, EST is an estimate (a lower bound) for norm(A). */
/* KASE (input/output) INTEGER */
/* On the initial call to DLACON, KASE should be 0. */
/* On an intermediate return, KASE will be 1 or 2, indicating */
/* whether X should be overwritten by A * X or A' * X. */
/* On the final return from DLACON, KASE will again be 0. */
/* Further Details */
/* ======= ======= */
/* Contributed by Nick Higham, University of Manchester. */
/* Originally named SONEST, dated March 16, 1988. */
/* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */
/* a real or complex matrix, with applications to condition estimation", */
/* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Save statement .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--isgn;
--x;
--v;
/* Function Body */
if (*kase == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = 1. / (doublereal) (*n);
/* L10: */
}
*kase = 1;
jump = 1;
return 0;
}
switch (jump) {
case 1: goto L20;
case 2: goto L40;
case 3: goto L70;
case 4: goto L110;
case 5: goto L140;
}
/* ................ ENTRY (JUMP = 1) */
/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */
L20:
if (*n == 1) {
v[1] = x[1];
*est = abs(v[1]);
/* ... QUIT */
goto L150;
}
*est = dasum_(n, &x[1], &c__1);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = d_sign(&c_b11, &x[i__]);
isgn[i__] = i_dnnt(&x[i__]);
/* L30: */
}
*kase = 2;
jump = 2;
return 0;
/* ................ ENTRY (JUMP = 2) */
/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
L40:
j = idamax_(n, &x[1], &c__1);
iter = 2;
/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */
L50:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = 0.;
/* L60: */
}
x[j] = 1.;
*kase = 1;
jump = 3;
return 0;
/* ................ ENTRY (JUMP = 3) */
/* X HAS BEEN OVERWRITTEN BY A*X. */
L70:
dcopy_(n, &x[1], &c__1, &v[1], &c__1);
estold = *est;
*est = dasum_(n, &v[1], &c__1);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__1 = d_sign(&c_b11, &x[i__]);
if (i_dnnt(&d__1) != isgn[i__]) {
goto L90;
}
/* L80: */
}
/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
goto L120;
L90:
/* TEST FOR CYCLING. */
if (*est <= estold) {
goto L120;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = d_sign(&c_b11, &x[i__]);
isgn[i__] = i_dnnt(&x[i__]);
/* L100: */
}
*kase = 2;
jump = 4;
return 0;
/* ................ ENTRY (JUMP = 4) */
/* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
L110:
jlast = j;
j = idamax_(n, &x[1], &c__1);
if (x[jlast] != (d__1 = x[j], abs(d__1)) && iter < 5) {
++iter;
goto L50;
}
/* ITERATION COMPLETE. FINAL STAGE. */
L120:
altsgn = 1.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) +
1.);
altsgn = -altsgn;
/* L130: */
}
*kase = 1;
jump = 5;
return 0;
/* ................ ENTRY (JUMP = 5) */
/* X HAS BEEN OVERWRITTEN BY A*X. */
L140:
temp = dasum_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.;
if (temp > *est) {
dcopy_(n, &x[1], &c__1, &v[1], &c__1);
*est = temp;
}
L150:
*kase = 0;
return 0;
/* End of DLACON */
} /* dlacon_ */
/* DECK DOHTRL */
/* Subroutine */ int dohtrl_(doublereal *q, integer *n, integer *nrda,
doublereal *diag, integer *irank, doublereal *div, doublereal *td)
{
/* System generated locals */
integer q_dim1, q_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
/* Local variables */
static integer j, k, l;
static doublereal dd, qs, sig;
static integer kir;
static doublereal sqd;
static integer irp;
static doublereal tdv;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static integer kirm, nmir;
static doublereal diagk;
/* ***BEGIN PROLOGUE DOHTRL */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DBVSUP and DSUDS */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (OHTROL-S, DOHTRL-D) */
/* ***AUTHOR Watts, H. A., (SNLA) */
/* ***DESCRIPTION */
/* For a rank deficient problem, additional orthogonal */
/* HOUSEHOLDER transformations are applied to the left side */
/* of Q to further reduce the triangular form. */
/* Thus, after application of the routines DORTHR and DOHTRL */
/* to the original matrix, the result is a nonsingular */
/* triangular matrix while the remainder of the matrix */
/* has been zeroed out. */
/* ***SEE ALSO DBVSUP, DSUDS */
/* ***ROUTINES CALLED DDOT */
/* ***REVISION HISTORY (YYMMDD) */
/* 750601 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900328 Added TYPE section. (WRB) */
/* 910722 Updated AUTHOR section. (ALS) */
/* ***END PROLOGUE DOHTRL */
/* ***FIRST EXECUTABLE STATEMENT DOHTRL */
/* Parameter adjustments */
q_dim1 = *nrda;
q_offset = 1 + q_dim1;
q -= q_offset;
--diag;
--div;
--td;
/* Function Body */
nmir = *n - *irank;
irp = *irank + 1;
i__1 = *irank;
for (k = 1; k <= i__1; ++k) {
kir = irp - k;
diagk = diag[kir];
sig = diagk * diagk + ddot_(&nmir, &q[irp + kir * q_dim1], &c__1, &q[
irp + kir * q_dim1], &c__1);
d__1 = sqrt(sig);
d__2 = -diagk;
dd = d_sign(&d__1, &d__2);
div[kir] = dd;
tdv = diagk - dd;
td[kir] = tdv;
if (k == *irank) {
goto L30;
}
kirm = kir - 1;
sqd = dd * diagk - sig;
i__2 = kirm;
for (j = 1; j <= i__2; ++j) {
qs = (tdv * q[kir + j * q_dim1] + ddot_(&nmir, &q[irp + j *
q_dim1], &c__1, &q[irp + kir * q_dim1], &c__1)) / sqd;
q[kir + j * q_dim1] += qs * tdv;
i__3 = *n;
for (l = irp; l <= i__3; ++l) {
q[l + j * q_dim1] += qs * q[l + kir * q_dim1];
/* L10: */
}
/* L20: */
}
L30:
/* L40: */
;
}
return 0;
} /* dohtrl_ */
/*< subroutine tqlrat(n,d,e2,ierr) >*/
/* Subroutine */ int tqlrat_(integer *n, doublereal *d__, doublereal *e2,
integer *ierr)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
doublereal b=0, c__=0, f, g, h__;
integer i__, j, l, m;
doublereal p, r__, s, t;
integer l1, ii, mml;
extern doublereal pythag_(doublereal *, doublereal *), epslon_(doublereal
*);
/*< integer i,j,l,m,n,ii,l1,mml,ierr >*/
/*< double precision d(n),e2(n) >*/
/*< double precision b,c,f,g,h,p,r,s,t,epslon,pythag >*/
/* this subroutine is a translation of the algol procedure tqlrat, */
/* algorithm 464, comm. acm 16, 689(1973) by reinsch. */
/* this subroutine finds the eigenvalues of a symmetric */
/* tridiagonal matrix by the rational ql method. */
/* on input */
/* n is the order of the matrix. */
/* d contains the diagonal elements of the input matrix. */
/* e2 contains the squares of the subdiagonal elements of the */
/* input matrix in its last n-1 positions. e2(1) is arbitrary. */
/* on output */
/* d contains the eigenvalues in ascending order. if an */
/* error exit is made, the eigenvalues are correct and */
/* ordered for indices 1,2,...ierr-1, but may not be */
/* the smallest eigenvalues. */
/* e2 has been destroyed. */
/* ierr is set to */
/* zero for normal return, */
/* j if the j-th eigenvalue has not been */
/* determined after 30 iterations. */
/* calls pythag for dsqrt(a*a + b*b) . */
/* questions and comments should be directed to burton s. garbow, */
/* mathematics and computer science div, argonne national laboratory */
/* this version dated august 1983. */
/* ------------------------------------------------------------------ */
/*< ierr = 0 >*/
/* Parameter adjustments */
--e2;
--d__;
/* Function Body */
*ierr = 0;
/*< if (n .eq. 1) go to 1001 >*/
if (*n == 1) {
goto L1001;
}
/*< do 100 i = 2, n >*/
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
/*< 100 e2(i-1) = e2(i) >*/
/* L100: */
e2[i__ - 1] = e2[i__];
}
/*< f = 0.0d0 >*/
f = 0.;
/*< t = 0.0d0 >*/
t = 0.;
/*< e2(n) = 0.0d0 >*/
e2[*n] = 0.;
/*< do 290 l = 1, n >*/
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
/*< j = 0 >*/
j = 0;
/*< h = dabs(d(l)) + dsqrt(e2(l)) >*/
h__ = (d__1 = d__[l], abs(d__1)) + sqrt(e2[l]);
/*< if (t .gt. h) go to 105 >*/
if (t > h__) {
goto L105;
}
/*< t = h >*/
t = h__;
/*< b = epslon(t) >*/
b = epslon_(&t);
/*< c = b * b >*/
c__ = b * b;
/* .......... look for small squared sub-diagonal element .......... */
/*< 105 do 110 m = l, n >*/
L105:
i__2 = *n;
for (m = l; m <= i__2; ++m) {
/*< if (e2(m) .le. c) go to 120 >*/
if (e2[m] <= c__) {
goto L120;
}
/* .......... e2(n) is always zero, so there is no exit */
/* through the bottom of the loop .......... */
/*< 110 continue >*/
/* L110: */
}
/*< 120 if (m .eq. l) go to 210 >*/
L120:
if (m == l) {
goto L210;
}
/*< 130 if (j .eq. 30) go to 1000 >*/
L130:
if (j == 30) {
goto L1000;
}
/*< j = j + 1 >*/
++j;
/* .......... form shift .......... */
/*< l1 = l + 1 >*/
l1 = l + 1;
/*< s = dsqrt(e2(l)) >*/
s = sqrt(e2[l]);
/*< g = d(l) >*/
g = d__[l];
/*< p = (d(l1) - g) / (2.0d0 * s) >*/
p = (d__[l1] - g) / (s * 2.);
/*< r = pythag(p,1.0d0) >*/
r__ = pythag_(&p, &c_b11);
/*< d(l) = s / (p + dsign(r,p)) >*/
d__[l] = s / (p + d_sign(&r__, &p));
/*< h = g - d(l) >*/
h__ = g - d__[l];
/*< do 140 i = l1, n >*/
i__2 = *n;
for (i__ = l1; i__ <= i__2; ++i__) {
/*< 140 d(i) = d(i) - h >*/
/* L140: */
d__[i__] -= h__;
}
/*< f = f + h >*/
f += h__;
/* .......... rational ql transformation .......... */
/*< g = d(m) >*/
g = d__[m];
/*< if (g .eq. 0.0d0) g = b >*/
if (g == 0.) {
g = b;
}
/*< h = g >*/
h__ = g;
/*< s = 0.0d0 >*/
s = 0.;
/*< mml = m - l >*/
mml = m - l;
/* .......... for i=m-1 step -1 until l do -- .......... */
/*< do 200 ii = 1, mml >*/
i__2 = mml;
for (ii = 1; ii <= i__2; ++ii) {
/*< i = m - ii >*/
i__ = m - ii;
/*< p = g * h >*/
p = g * h__;
/*< r = p + e2(i) >*/
r__ = p + e2[i__];
/*< e2(i+1) = s * r >*/
e2[i__ + 1] = s * r__;
/*< s = e2(i) / r >*/
s = e2[i__] / r__;
/*< d(i+1) = h + s * (h + d(i)) >*/
d__[i__ + 1] = h__ + s * (h__ + d__[i__]);
/*< g = d(i) - e2(i) / g >*/
g = d__[i__] - e2[i__] / g;
/*< if (g .eq. 0.0d0) g = b >*/
if (g == 0.) {
g = b;
}
/*< h = g * p / r >*/
h__ = g * p / r__;
/*< 200 continue >*/
/* L200: */
}
/*< e2(l) = s * g >*/
e2[l] = s * g;
/*< d(l) = h >*/
d__[l] = h__;
/* .......... guard against underflow in convergence test .......... */
/*< if (h .eq. 0.0d0) go to 210 >*/
if (h__ == 0.) {
goto L210;
}
/*< if (dabs(e2(l)) .le. dabs(c/h)) go to 210 >*/
if ((d__1 = e2[l], abs(d__1)) <= (d__2 = c__ / h__, abs(d__2))) {
goto L210;
}
/*< e2(l) = h * e2(l) >*/
e2[l] = h__ * e2[l];
/*< if (e2(l) .ne. 0.0d0) go to 130 >*/
if (e2[l] != 0.) {
goto L130;
}
/*< 210 p = d(l) + f >*/
L210:
p = d__[l] + f;
/* .......... order eigenvalues .......... */
/*< if (l .eq. 1) go to 250 >*/
if (l == 1) {
goto L250;
}
/* .......... for i=l step -1 until 2 do -- .......... */
/*< do 230 ii = 2, l >*/
i__2 = l;
for (ii = 2; ii <= i__2; ++ii) {
/*< i = l + 2 - ii >*/
i__ = l + 2 - ii;
/*< if (p .ge. d(i-1)) go to 270 >*/
if (p >= d__[i__ - 1]) {
goto L270;
}
/*< d(i) = d(i-1) >*/
d__[i__] = d__[i__ - 1];
/*< 230 continue >*/
/* L230: */
}
/*< 250 i = 1 >*/
L250:
i__ = 1;
/*< 270 d(i) = p >*/
L270:
d__[i__] = p;
/*< 290 continue >*/
/* L290: */
}
/*< go to 1001 >*/
goto L1001;
/* .......... set error -- no convergence to an */
/* eigenvalue after 30 iterations .......... */
/*< 1000 ierr = l >*/
L1000:
*ierr = l;
/*< 1001 return >*/
L1001:
return 0;
/*< end >*/
} /* tqlrat_ */
int
slacon2_(int *n, float *v, float *x, int *isgn, float *est, int *kase, int isave[3])
{
/* Table of constant values */
int c__1 = 1;
float zero = 0.0;
float one = 1.0;
/* Local variables */
int jlast;
float altsgn, estold;
int i;
float temp;
#ifdef _CRAY
extern int ISAMAX(int *, float *, int *);
extern float SASUM(int *, float *, int *);
extern int SCOPY(int *, float *, int *, float *, int *);
#else
extern int isamax_(int *, float *, int *);
extern float sasum_(int *, float *, int *);
extern int scopy_(int *, float *, int *, float *, int *);
#endif
#define d_sign(a, b) (b >= 0 ? fabs(a) : -fabs(a)) /* Copy sign */
#define i_dnnt(a) \
( a>=0 ? floor(a+.5) : -floor(.5-a) ) /* Round to nearest integer */
if ( *kase == 0 ) {
for (i = 0; i < *n; ++i) {
x[i] = 1. / (float) (*n);
}
*kase = 1;
isave[0] = 1; /* jump = 1; */
return 0;
}
switch (isave[0]) {
case 1: goto L20;
case 2: goto L40;
case 3: goto L70;
case 4: goto L110;
case 5: goto L140;
}
/* ................ ENTRY (isave[0] = 1)
FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */
L20:
if (*n == 1) {
v[0] = x[0];
*est = fabs(v[0]);
/* ... QUIT */
goto L150;
}
#ifdef _CRAY
*est = SASUM(n, x, &c__1);
#else
*est = sasum_(n, x, &c__1);
#endif
for (i = 0; i < *n; ++i) {
x[i] = d_sign(one, x[i]);
isgn[i] = i_dnnt(x[i]);
}
*kase = 2;
isave[0] = 2; /* jump = 2; */
return 0;
/* ................ ENTRY (isave[0] = 2)
FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
L40:
#ifdef _CRAY
isave[1] = ISAMAX(n, &x[0], &c__1); /* j */
#else
isave[1] = idamax_(n, &x[0], &c__1); /* j */
#endif
--isave[1]; /* --j; */
isave[2] = 2; /* iter = 2; */
/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */
L50:
for (i = 0; i < *n; ++i) x[i] = zero;
x[isave[1]] = one;
*kase = 1;
isave[0] = 3; /* jump = 3; */
return 0;
/* ................ ENTRY (isave[0] = 3)
X HAS BEEN OVERWRITTEN BY A*X. */
L70:
#ifdef _CRAY
SCOPY(n, x, &c__1, v, &c__1);
#else
scopy_(n, x, &c__1, v, &c__1);
#endif
estold = *est;
#ifdef _CRAY
*est = SASUM(n, v, &c__1);
#else
*est = sasum_(n, v, &c__1);
#endif
for (i = 0; i < *n; ++i)
if (i_dnnt(d_sign(one, x[i])) != isgn[i])
goto L90;
/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
goto L120;
L90:
/* TEST FOR CYCLING. */
if (*est <= estold) goto L120;
for (i = 0; i < *n; ++i) {
x[i] = d_sign(one, x[i]);
isgn[i] = i_dnnt(x[i]);
}
*kase = 2;
isave[0] = 4; /* jump = 4; */
return 0;
/* ................ ENTRY (isave[0] = 4)
X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. */
L110:
jlast = isave[1]; /* j; */
#ifdef _CRAY
isave[1] = ISAMAX(n, &x[0], &c__1); /* j */
#else
isave[1] = isamax_(n, &x[0], &c__1); /* j */
#endif
isave[1] = isave[1] - 1; /* --j; */
if (x[jlast] != fabs(x[isave[1]]) && isave[2] < 5) {
isave[2] = isave[2] + 1; /* ++iter; */
goto L50;
}
/* ITERATION COMPLETE. FINAL STAGE. */
L120:
altsgn = 1.;
for (i = 1; i <= *n; ++i) {
x[i-1] = altsgn * ((float)(i - 1) / (float)(*n - 1) + 1.);
altsgn = -altsgn;
}
*kase = 1;
isave[0] = 5; /* jump = 5; */
return 0;
/* ................ ENTRY (isave[0] = 5)
X HAS BEEN OVERWRITTEN BY A*X. */
L140:
#ifdef _CRAY
temp = SASUM(n, x, &c__1) / (float)(*n * 3) * 2.;
#else
temp = sasum_(n, x, &c__1) / (float)(*n * 3) * 2.;
#endif
if (temp > *est) {
#ifdef _CRAY
SCOPY(n, &x[0], &c__1, &v[0], &c__1);
#else
scopy_(n, &x[0], &c__1, &v[0], &c__1);
#endif
*est = temp;
}
L150:
*kase = 0;
return 0;
} /* slacon_ */
/* Subroutine */ int dlagsy_(integer *n, integer *k, doublereal *d,
doublereal *a, integer *lda, integer *iseed, doublereal *work,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
/* Builtin functions */
double d_sign(doublereal *, doublereal *);
/* Local variables */
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *), dnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer i, j;
static doublereal alpha;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dgemv_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *), dsymv_(char *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
static doublereal wa, wb, wn;
extern /* Subroutine */ int xerbla_(char *, integer *), dlarnv_(
integer *, integer *, integer *, doublereal *);
static doublereal tau;
/* -- LAPACK auxiliary test routine (version 2.0)
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DLAGSY generates a real symmetric matrix A, by pre- and post-
multiplying a real diagonal matrix D with a random orthogonal matrix:
A = U*D*U'. The semi-bandwidth may then be reduced to k by additional
orthogonal transformations.
Arguments
=========
N (input) INTEGER
The order of the matrix A. N >= 0.
K (input) INTEGER
The number of nonzero subdiagonals within the band of A.
0 <= K <= N-1.
D (input) DOUBLE PRECISION array, dimension (N)
The diagonal elements of the diagonal matrix D.
A (output) DOUBLE PRECISION array, dimension (LDA,N)
The generated n by n symmetric matrix A (the full matrix is
stored).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= N.
ISEED (input/output) INTEGER array, dimension (4)
On entry, the seed of the random number generator; the array
elements must be between 0 and 4095, and ISEED(4) must be
odd.
On exit, the seed is updated.
WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
--d;
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*k < 0 || *k > *n - 1) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("DLAGSY", &i__1);
return 0;
}
/* initialize lower triangle of A to diagonal matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i = j + 1; i <= i__2; ++i) {
a[i + j * a_dim1] = 0.;
/* L10: */
}
/* L20: */
}
i__1 = *n;
for (i = 1; i <= i__1; ++i) {
a[i + i * a_dim1] = d[i];
/* L30: */
}
/* Generate lower triangle of symmetric matrix */
for (i = *n - 1; i >= 1; --i) {
/* generate random reflection */
i__1 = *n - i + 1;
dlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i + 1;
wn = dnrm2_(&i__1, &work[1], &c__1);
wa = d_sign(&wn, &work[1]);
if (wn == 0.) {
tau = 0.;
} else {
wb = work[1] + wa;
i__1 = *n - i;
d__1 = 1. / wb;
dscal_(&i__1, &d__1, &work[2], &c__1);
work[1] = 1.;
tau = wb / wa;
}
/* apply random reflection to A(i:n,i:n) from the left
and the right
compute y := tau * A * u */
i__1 = *n - i + 1;
dsymv_("Lower", &i__1, &tau, &a[i + i * a_dim1], lda, &work[1], &c__1,
&c_b12, &work[*n + 1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
i__1 = *n - i + 1;
alpha = tau * -.5 * ddot_(&i__1, &work[*n + 1], &c__1, &work[1], &
c__1);
i__1 = *n - i + 1;
daxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
/* apply the transformation as a rank-2 update to A(i:n,i:n) */
i__1 = *n - i + 1;
dsyr2_("Lower", &i__1, &c_b19, &work[1], &c__1, &work[*n + 1], &c__1,
&a[i + i * a_dim1], lda);
/* L40: */
}
/* Reduce number of subdiagonals to K */
i__1 = *n - 1 - *k;
for (i = 1; i <= i__1; ++i) {
/* generate reflection to annihilate A(k+i+1:n,i) */
i__2 = *n - *k - i + 1;
wn = dnrm2_(&i__2, &a[*k + i + i * a_dim1], &c__1);
wa = d_sign(&wn, &a[*k + i + i * a_dim1]);
if (wn == 0.) {
tau = 0.;
} else {
wb = a[*k + i + i * a_dim1] + wa;
i__2 = *n - *k - i;
d__1 = 1. / wb;
dscal_(&i__2, &d__1, &a[*k + i + 1 + i * a_dim1], &c__1);
a[*k + i + i * a_dim1] = 1.;
tau = wb / wa;
}
/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */
i__2 = *n - *k - i + 1;
i__3 = *k - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b26, &a[*k + i + (i + 1) *
a_dim1], lda, &a[*k + i + i * a_dim1], &c__1, &c_b12, &work[1]
, &c__1);
i__2 = *n - *k - i + 1;
i__3 = *k - 1;
d__1 = -tau;
dger_(&i__2, &i__3, &d__1, &a[*k + i + i * a_dim1], &c__1, &work[1], &
c__1, &a[*k + i + (i + 1) * a_dim1], lda);
/* apply reflection to A(k+i:n,k+i:n) from the left and the rig
ht
compute y := tau * A * u */
i__2 = *n - *k - i + 1;
dsymv_("Lower", &i__2, &tau, &a[*k + i + (*k + i) * a_dim1], lda, &a[*
k + i + i * a_dim1], &c__1, &c_b12, &work[1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
i__2 = *n - *k - i + 1;
alpha = tau * -.5 * ddot_(&i__2, &work[1], &c__1, &a[*k + i + i *
a_dim1], &c__1);
i__2 = *n - *k - i + 1;
daxpy_(&i__2, &alpha, &a[*k + i + i * a_dim1], &c__1, &work[1], &c__1)
;
/* apply symmetric rank-2 update to A(k+i:n,k+i:n) */
i__2 = *n - *k - i + 1;
dsyr2_("Lower", &i__2, &c_b19, &a[*k + i + i * a_dim1], &c__1, &work[
1], &c__1, &a[*k + i + (*k + i) * a_dim1], lda);
a[*k + i + i * a_dim1] = -wa;
i__2 = *n;
for (j = *k + i + 1; j <= i__2; ++j) {
a[j + i * a_dim1] = 0.;
/* L50: */
}
/* L60: */
}
/* Store full symmetric matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i = j + 1; i <= i__2; ++i) {
a[j + i * a_dim1] = a[i + j * a_dim1];
/* L70: */
}
/* L80: */
}
return 0;
/* End of DLAGSY */
} /* dlagsy_ */
/*< SUBROUTINE DORTQR(NZ, N, NBLOCK, Z, B) >*/
/* Subroutine */ int dortqr_(integer *nz, integer *n, integer *nblock,
doublereal *z__, doublereal *b)
{
/* System generated locals */
integer z_dim1, z_offset, b_dim1, b_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double d_sign(doublereal *, doublereal *);
/* Local variables */
integer i__, j, k, m;
doublereal tau;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
doublereal temp;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
doublereal sigma;
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
integer length;
/*< INTEGER NZ, N, NBLOCK >*/
/*< DOUBLE PRECISION Z(NZ,1), B(NBLOCK,1) >*/
/* THIS SUBROUTINE COMPUTES THE QR FACTORIZATION OF THE N X NBLOCK */
/* MATRIX Z. Q IS FORMED IN PLACE AND RETURNED IN Z. R IS */
/* RETURNED IN B. */
/*< INTEGER I, J, K, LENGTH, M >*/
/*< DOUBLE PRECISION SIGMA, TAU, TEMP, DDOT, DNRM2, DSIGN >*/
/*< EXTERNAL DAXPY, DDOT, DNRM2, DSCAL >*/
/* THIS SECTION REDUCES Z TO TRIANGULAR FORM. */
/*< DO 30 I=1,NBLOCK >*/
/* Parameter adjustments */
z_dim1 = *nz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
b_dim1 = *nblock;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
i__1 = *nblock;
for (i__ = 1; i__ <= i__1; ++i__) {
/* THIS FORMS THE ITH REFLECTION. */
/*< LENGTH = N - I + 1 >*/
length = *n - i__ + 1;
/*< SIGMA = DSIGN(DNRM2(LENGTH,Z(I,I),1),Z(I,I)) >*/
d__1 = dnrm2_(&length, &z__[i__ + i__ * z_dim1], &c__1);
sigma = d_sign(&d__1, &z__[i__ + i__ * z_dim1]);
/*< B(I,I) = -SIGMA >*/
b[i__ + i__ * b_dim1] = -sigma;
/*< Z(I,I) = Z(I,I) + SIGMA >*/
z__[i__ + i__ * z_dim1] += sigma;
/*< TAU = SIGMA*Z(I,I) >*/
tau = sigma * z__[i__ + i__ * z_dim1];
/*< IF (I.EQ.NBLOCK) GO TO 30 >*/
if (i__ == *nblock) {
goto L30;
}
/*< J = I + 1 >*/
j = i__ + 1;
/* THIS APPLIES THE ROTATION TO THE REST OF THE COLUMNS. */
/*< DO 20 K=J,NBLOCK >*/
i__2 = *nblock;
for (k = j; k <= i__2; ++k) {
/*< IF (TAU.EQ.0.0D0) GO TO 10 >*/
if (tau == 0.) {
goto L10;
}
/*< TEMP = -DDOT(LENGTH,Z(I,I),1,Z(I,K),1)/TAU >*/
temp = -ddot_(&length, &z__[i__ + i__ * z_dim1], &c__1, &z__[i__
+ k * z_dim1], &c__1) / tau;
/*< CALL DAXPY(LENGTH, TEMP, Z(I,I), 1, Z(I,K), 1) >*/
daxpy_(&length, &temp, &z__[i__ + i__ * z_dim1], &c__1, &z__[i__
+ k * z_dim1], &c__1);
/*< 10 B(I,K) = Z(I,K) >*/
L10:
b[i__ + k * b_dim1] = z__[i__ + k * z_dim1];
/*< Z(I,K) = 0.0D0 >*/
z__[i__ + k * z_dim1] = 0.;
/*< 20 CONTINUE >*/
/* L20: */
}
/*< 30 CONTINUE >*/
L30:
;
}
/* THIS ACCUMULATES THE REFLECTIONS IN REVERSE ORDER. */
/*< DO 70 M=1,NBLOCK >*/
i__1 = *nblock;
for (m = 1; m <= i__1; ++m) {
/* THIS RECREATES THE ITH = NBLOCK-M+1)TH REFLECTION. */
/*< I = NBLOCK + 1 - M >*/
i__ = *nblock + 1 - m;
/*< SIGMA = -B(I,I) >*/
sigma = -b[i__ + i__ * b_dim1];
/*< TAU = Z(I,I)*SIGMA >*/
tau = z__[i__ + i__ * z_dim1] * sigma;
/*< IF (TAU.EQ.0.0D0) GO TO 60 >*/
if (tau == 0.) {
goto L60;
}
/*< LENGTH = N - NBLOCK + M >*/
length = *n - *nblock + m;
/*< IF (I.EQ.NBLOCK) GO TO 50 >*/
if (i__ == *nblock) {
goto L50;
}
/*< J = I + 1 >*/
j = i__ + 1;
/* THIS APPLIES IT TO THE LATER COLUMNS. */
/*< DO 40 K=J,NBLOCK >*/
i__2 = *nblock;
for (k = j; k <= i__2; ++k) {
/*< TEMP = -DDOT(LENGTH,Z(I,I),1,Z(I,K),1)/TAU >*/
temp = -ddot_(&length, &z__[i__ + i__ * z_dim1], &c__1, &z__[i__
+ k * z_dim1], &c__1) / tau;
/*< CALL DAXPY(LENGTH, TEMP, Z(I,I), 1, Z(I,K), 1) >*/
daxpy_(&length, &temp, &z__[i__ + i__ * z_dim1], &c__1, &z__[i__
+ k * z_dim1], &c__1);
/*< 40 CONTINUE >*/
/* L40: */
}
/*< 50 CALL DSCAL(LENGTH, -1.0D0/SIGMA, Z(I,I), 1) >*/
L50:
d__1 = -1. / sigma;
dscal_(&length, &d__1, &z__[i__ + i__ * z_dim1], &c__1);
/*< 60 Z(I,I) = 1.0D0 + Z(I,I) >*/
L60:
z__[i__ + i__ * z_dim1] += 1.;
/*< 70 CONTINUE >*/
/* L70: */
}
/*< RETURN >*/
return 0;
/*< END >*/
} /* dortqr_ */
/* Subroutine */ int dbdsdc_(char *uplo, char *compq, integer *n, doublereal *
d__, doublereal *e, doublereal *u, integer *ldu, doublereal *vt,
integer *ldvt, doublereal *q, integer *iq, doublereal *work, integer *
iwork, integer *info)
{
/* System generated locals */
integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double d_sign(doublereal *, doublereal *), log(doublereal);
/* Local variables */
static integer difl, difr, ierr, perm, mlvl, sqre, i__, j, k;
static doublereal p, r__;
static integer z__;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *), dcopy_(integer *, doublereal *, integer *
, doublereal *, integer *), dswap_(integer *, doublereal *,
integer *, doublereal *, integer *);
static integer poles, iuplo, nsize, start;
extern /* Subroutine */ int dlasd0_(integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
integer *, integer *, doublereal *, integer *);
static integer ic, ii, kk;
static doublereal cs;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlasda_(integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *);
static integer is, iu;
static doublereal sn;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlasdq_(char *, integer *, integer
*, integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *), dlaset_(char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *), dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *);
static integer givcol;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
static integer icompq;
static doublereal orgnrm;
static integer givnum, givptr, nm1, qstart, smlsiz, wstart, smlszp;
static doublereal eps;
static integer ivt;
#define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1]
#define vt_ref(a_1,a_2) vt[(a_2)*vt_dim1 + a_1]
/* -- LAPACK routine (instrumented to count ops, version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1999
Purpose
=======
DBDSDC computes the singular value decomposition (SVD) of a real
N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT,
using a divide and conquer method, where S is a diagonal matrix
with non-negative diagonal elements (the singular values of B), and
U and VT are orthogonal matrices of left and right singular vectors,
respectively. DBDSDC can be used to compute all singular values,
and optionally, singular vectors or singular vectors in compact form.
This code makes very mild assumptions about floating point
arithmetic. It will work on machines with a guard digit in
add/subtract, or on those binary machines without guard digits
which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
It could conceivably fail on hexadecimal or decimal machines
without guard digits, but we know of none. See DLASD3 for details.
The code currently call DLASDQ if singular values only are desired.
However, it can be slightly modified to compute singular values
using the divide and conquer method.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': B is upper bidiagonal.
= 'L': B is lower bidiagonal.
COMPQ (input) CHARACTER*1
Specifies whether singular vectors are to be computed
as follows:
= 'N': Compute singular values only;
= 'P': Compute singular values and compute singular
vectors in compact form;
= 'I': Compute singular values and singular vectors.
N (input) INTEGER
The order of the matrix B. N >= 0.
D (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the n diagonal elements of the bidiagonal matrix B.
On exit, if INFO=0, the singular values of B.
E (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the elements of E contain the offdiagonal
elements of the bidiagonal matrix whose SVD is desired.
On exit, E has been destroyed.
U (output) DOUBLE PRECISION array, dimension (LDU,N)
If COMPQ = 'I', then:
On exit, if INFO = 0, U contains the left singular vectors
of the bidiagonal matrix.
For other values of COMPQ, U is not referenced.
LDU (input) INTEGER
The leading dimension of the array U. LDU >= 1.
If singular vectors are desired, then LDU >= max( 1, N ).
VT (output) DOUBLE PRECISION array, dimension (LDVT,N)
If COMPQ = 'I', then:
On exit, if INFO = 0, VT' contains the right singular
vectors of the bidiagonal matrix.
For other values of COMPQ, VT is not referenced.
LDVT (input) INTEGER
The leading dimension of the array VT. LDVT >= 1.
If singular vectors are desired, then LDVT >= max( 1, N ).
Q (output) DOUBLE PRECISION array, dimension (LDQ)
If COMPQ = 'P', then:
On exit, if INFO = 0, Q and IQ contain the left
and right singular vectors in a compact form,
requiring O(N log N) space instead of 2*N**2.
In particular, Q contains all the DOUBLE PRECISION data in
LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))
words of memory, where SMLSIZ is returned by ILAENV and
is equal to the maximum size of the subproblems at the
bottom of the computation tree (usually about 25).
For other values of COMPQ, Q is not referenced.
IQ (output) INTEGER array, dimension (LDIQ)
If COMPQ = 'P', then:
On exit, if INFO = 0, Q and IQ contain the left
and right singular vectors in a compact form,
requiring O(N log N) space instead of 2*N**2.
In particular, IQ contains all INTEGER data in
LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))
words of memory, where SMLSIZ is returned by ILAENV and
is equal to the maximum size of the subproblems at the
bottom of the computation tree (usually about 25).
For other values of COMPQ, IQ is not referenced.
WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
If COMPQ = 'N' then LWORK >= (4 * N).
If COMPQ = 'P' then LWORK >= (6 * N).
If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).
IWORK (workspace) INTEGER array, dimension (7*N)
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: The algorithm failed to compute an singular value.
The update process of divide and conquer failed.
Further Details
===============
Based on contributions by
Ming Gu and Huan Ren, Computer Science Division, University of
California at Berkeley, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1 * 1;
vt -= vt_offset;
--q;
--iq;
--work;
--iwork;
/* Function Body */
*info = 0;
iuplo = 0;
if (lsame_(uplo, "U")) {
iuplo = 1;
}
if (lsame_(uplo, "L")) {
iuplo = 2;
}
if (lsame_(compq, "N")) {
icompq = 0;
} else if (lsame_(compq, "P")) {
icompq = 1;
} else if (lsame_(compq, "I")) {
icompq = 2;
} else {
icompq = -1;
}
if (iuplo == 0) {
*info = -1;
} else if (icompq < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ldu < 1 || icompq == 2 && *ldu < *n) {
*info = -7;
} else if (*ldvt < 1 || icompq == 2 && *ldvt < *n) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DBDSDC", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
smlsiz = ilaenv_(&c__9, "DBDSDC", " ", &c__0, &c__0, &c__0, &c__0, (
ftnlen)6, (ftnlen)1);
if (*n == 1) {
if (icompq == 1) {
q[1] = d_sign(&c_b15, &d__[1]);
q[smlsiz * *n + 1] = 1.;
} else if (icompq == 2) {
u_ref(1, 1) = d_sign(&c_b15, &d__[1]);
vt_ref(1, 1) = 1.;
}
d__[1] = abs(d__[1]);
return 0;
}
nm1 = *n - 1;
/* If matrix lower bidiagonal, rotate to be upper bidiagonal
by applying Givens rotations on the left */
wstart = 1;
qstart = 3;
if (icompq == 1) {
dcopy_(n, &d__[1], &c__1, &q[1], &c__1);
i__1 = *n - 1;
dcopy_(&i__1, &e[1], &c__1, &q[*n + 1], &c__1);
}
if (iuplo == 2) {
qstart = 5;
wstart = (*n << 1) - 1;
latime_1.ops += (doublereal) (*n - 1 << 3);
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
if (icompq == 1) {
q[i__ + (*n << 1)] = cs;
q[i__ + *n * 3] = sn;
} else if (icompq == 2) {
work[i__] = cs;
work[nm1 + i__] = -sn;
}
/* L10: */
}
}
/* If ICOMPQ = 0, use DLASDQ to compute the singular values. */
if (icompq == 0) {
dlasdq_("U", &c__0, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[
vt_offset], ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[
wstart], info);
goto L40;
}
/* If N is smaller than the minimum divide size SMLSIZ, then solve
the problem with another solver. */
if (*n <= smlsiz) {
if (icompq == 2) {
dlaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu);
dlaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt);
dlasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &vt[vt_offset]
, ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[
wstart], info);
} else if (icompq == 1) {
iu = 1;
ivt = iu + *n;
dlaset_("A", n, n, &c_b29, &c_b15, &q[iu + (qstart - 1) * *n], n);
dlaset_("A", n, n, &c_b29, &c_b15, &q[ivt + (qstart - 1) * *n], n);
dlasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &q[ivt + (
qstart - 1) * *n], n, &q[iu + (qstart - 1) * *n], n, &q[
iu + (qstart - 1) * *n], n, &work[wstart], info);
}
goto L40;
}
if (icompq == 2) {
dlaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu);
dlaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt);
}
/* Scale. */
orgnrm = dlanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.) {
return 0;
}
latime_1.ops += (doublereal) (*n + nm1);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b15, n, &c__1, &d__[1], n, &ierr);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b15, &nm1, &c__1, &e[1], &nm1, &
ierr);
eps = dlamch_("Epsilon");
mlvl = (integer) (log((doublereal) (*n) / (doublereal) (smlsiz + 1)) /
log(2.)) + 1;
smlszp = smlsiz + 1;
if (icompq == 1) {
iu = 1;
ivt = smlsiz + 1;
difl = ivt + smlszp;
difr = difl + mlvl;
z__ = difr + (mlvl << 1);
ic = z__ + mlvl;
is = ic + 1;
poles = is + 1;
givnum = poles + (mlvl << 1);
k = 1;
givptr = 2;
perm = 3;
givcol = perm + mlvl;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = d__[i__], abs(d__1)) < eps) {
d__[i__] = d_sign(&eps, &d__[i__]);
}
/* L20: */
}
start = 1;
sqre = 0;
i__1 = nm1;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) {
/* Subproblem found. First determine its size and then
apply divide and conquer on it. */
if (i__ < nm1) {
/* A subproblem with E(I) small for I < NM1. */
nsize = i__ - start + 1;
} else if ((d__1 = e[i__], abs(d__1)) >= eps) {
/* A subproblem with E(NM1) not too small but I = NM1. */
nsize = *n - start + 1;
} else {
/* A subproblem with E(NM1) small. This implies an
1-by-1 subproblem at D(N). Solve this 1-by-1 problem
first. */
nsize = i__ - start + 1;
if (icompq == 2) {
u_ref(*n, *n) = d_sign(&c_b15, &d__[*n]);
vt_ref(*n, *n) = 1.;
} else if (icompq == 1) {
q[*n + (qstart - 1) * *n] = d_sign(&c_b15, &d__[*n]);
q[*n + (smlsiz + qstart - 1) * *n] = 1.;
}
d__[*n] = (d__1 = d__[*n], abs(d__1));
}
if (icompq == 2) {
dlasd0_(&nsize, &sqre, &d__[start], &e[start], &u_ref(start,
start), ldu, &vt_ref(start, start), ldvt, &smlsiz, &
iwork[1], &work[wstart], info);
} else {
dlasda_(&icompq, &smlsiz, &nsize, &sqre, &d__[start], &e[
start], &q[start + (iu + qstart - 2) * *n], n, &q[
start + (ivt + qstart - 2) * *n], &iq[start + k * *n],
&q[start + (difl + qstart - 2) * *n], &q[start + (
difr + qstart - 2) * *n], &q[start + (z__ + qstart -
2) * *n], &q[start + (poles + qstart - 2) * *n], &iq[
start + givptr * *n], &iq[start + givcol * *n], n, &
iq[start + perm * *n], &q[start + (givnum + qstart -
2) * *n], &q[start + (ic + qstart - 2) * *n], &q[
start + (is + qstart - 2) * *n], &work[wstart], &
iwork[1], info);
if (*info != 0) {
return 0;
}
}
start = i__ + 1;
}
/* L30: */
}
/* Unscale */
latime_1.ops += (doublereal) (*n);
dlascl_("G", &c__0, &c__0, &c_b15, &orgnrm, n, &c__1, &d__[1], n, &ierr);
L40:
/* Use Selection Sort to minimize swaps of singular vectors */
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
i__ = ii - 1;
kk = i__;
p = d__[i__];
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
if (d__[j] > p) {
kk = j;
p = d__[j];
}
/* L50: */
}
if (kk != i__) {
d__[kk] = d__[i__];
d__[i__] = p;
if (icompq == 1) {
iq[i__] = kk;
} else if (icompq == 2) {
dswap_(n, &u_ref(1, i__), &c__1, &u_ref(1, kk), &c__1);
dswap_(n, &vt_ref(i__, 1), ldvt, &vt_ref(kk, 1), ldvt);
}
} else if (icompq == 1) {
iq[i__] = i__;
}
/* L60: */
}
/* If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO */
if (icompq == 1) {
if (iuplo == 1) {
iq[*n] = 1;
} else {
iq[*n] = 0;
}
}
/* If B is lower bidiagonal, update U by those Givens rotations
which rotated B to be upper bidiagonal */
if (iuplo == 2 && icompq == 2) {
latime_1.ops += (doublereal) ((*n - 1) * 6 * *n);
dlasr_("L", "V", "B", n, n, &work[1], &work[*n], &u[u_offset], ldu);
}
return 0;
/* End of DBDSDC */
} /* dbdsdc_ */
/* Subroutine */ int zlarfp_(integer *n, doublecomplex *alpha, doublecomplex *
x, integer *incx, doublecomplex *tau)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Local variables */
integer j, knt;
doublereal beta, alphi, alphr;
doublereal xnorm;
doublereal safmin;
doublereal rsafmn;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZLARFP generates a complex elementary reflector H of order n, such */
/* that */
/* H' * ( alpha ) = ( beta ), H' * H = I. */
/* ( x ) ( 0 ) */
/* where alpha and beta are scalars, beta is real and non-negative, and */
/* x is an (n-1)-element complex vector. H is represented in the form */
/* H = I - tau * ( 1 ) * ( 1 v' ) , */
/* ( v ) */
/* where tau is a complex scalar and v is a complex (n-1)-element */
/* vector. Note that H is not hermitian. */
/* If the elements of x are all zero and alpha is real, then tau = 0 */
/* and H is taken to be the unit matrix. */
/* Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the elementary reflector. */
/* ALPHA (input/output) COMPLEX*16 */
/* On entry, the value alpha. */
/* On exit, it is overwritten with the value beta. */
/* X (input/output) COMPLEX*16 array, dimension */
/* (1+(N-2)*abs(INCX)) */
/* On entry, the vector x. */
/* On exit, it is overwritten with the vector v. */
/* INCX (input) INTEGER */
/* The increment between elements of X. INCX > 0. */
/* TAU (output) COMPLEX*16 */
/* The value tau. */
/* ===================================================================== */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 0) {
tau->r = 0., tau->i = 0.;
return 0;
}
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
alphr = alpha->r;
alphi = d_imag(alpha);
if (xnorm == 0. && alphi == 0.) {
/* H = [1-alpha/abs(alpha) 0; 0 I], sign chosen so ALPHA >= 0. */
if (alphi == 0.) {
if (alphr >= 0.) {
/* When TAU.eq.ZERO, the vector is special-cased to be */
/* all zeros in the application routines. We do not need */
/* to clear it. */
tau->r = 0., tau->i = 0.;
} else {
/* However, the application routines rely on explicit */
/* zero checks when TAU.ne.ZERO, and we must clear X. */
tau->r = 2., tau->i = 0.;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0., x[i__2].i = 0.;
}
z__1.r = -alpha->r, z__1.i = -alpha->i;
alpha->r = z__1.r, alpha->i = z__1.i;
}
} else {
/* Only "reflecting" the diagonal entry to be real and non-negative. */
xnorm = dlapy2_(&alphr, &alphi);
d__1 = 1. - alphr / xnorm;
d__2 = -alphi / xnorm;
z__1.r = d__1, z__1.i = d__2;
tau->r = z__1.r, tau->i = z__1.i;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0., x[i__2].i = 0.;
}
alpha->r = xnorm, alpha->i = 0.;
}
} else {
/* general case */
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = d_sign(&d__1, &alphr);
safmin = dlamch_("S") / dlamch_("E");
rsafmn = 1. / safmin;
knt = 0;
if (abs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute them */
L10:
++knt;
i__1 = *n - 1;
zdscal_(&i__1, &rsafmn, &x[1], incx);
beta *= rsafmn;
alphi *= rsafmn;
alphr *= rsafmn;
if (abs(beta) < safmin) {
goto L10;
}
/* New BETA is at most 1, at least SAFMIN */
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
z__1.r = alphr, z__1.i = alphi;
alpha->r = z__1.r, alpha->i = z__1.i;
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = d_sign(&d__1, &alphr);
}
z__1.r = alpha->r + beta, z__1.i = alpha->i;
alpha->r = z__1.r, alpha->i = z__1.i;
if (beta < 0.) {
beta = -beta;
z__2.r = -alpha->r, z__2.i = -alpha->i;
z__1.r = z__2.r / beta, z__1.i = z__2.i / beta;
tau->r = z__1.r, tau->i = z__1.i;
} else {
alphr = alphi * (alphi / alpha->r);
alphr += xnorm * (xnorm / alpha->r);
d__1 = alphr / beta;
d__2 = -alphi / beta;
z__1.r = d__1, z__1.i = d__2;
tau->r = z__1.r, tau->i = z__1.i;
d__1 = -alphr;
z__1.r = d__1, z__1.i = alphi;
alpha->r = z__1.r, alpha->i = z__1.i;
}
zladiv_(&z__1, &c_b5, alpha);
alpha->r = z__1.r, alpha->i = z__1.i;
i__1 = *n - 1;
zscal_(&i__1, alpha, &x[1], incx);
/* If BETA is subnormal, it may lose relative accuracy */
i__1 = knt;
for (j = 1; j <= i__1; ++j) {
beta *= safmin;
}
alpha->r = beta, alpha->i = 0.;
}
return 0;
/* End of ZLARFP */
} /* zlarfp_ */
/* Subroutine */ int dsteqr_(char *compz, integer *n, doublereal *d__,
doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
doublereal b, c__, f, g;
integer i__, j, k, l, m;
doublereal p, r__, s;
integer l1, ii, mm, lm1, mm1, nm1;
doublereal rt1, rt2, eps;
integer lsv;
doublereal tst, eps2;
integer lend, jtot;
extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *);
doublereal anorm;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *), dlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
integer lendm1, lendp1;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
integer iscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlaset_(char *, integer *, integer
*, doublereal *, doublereal *, doublereal *, integer *);
doublereal safmin;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
doublereal safmax;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *);
integer lendsv;
doublereal ssfmin;
integer nmaxit, icompz;
doublereal ssfmax;
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSTEQR computes all eigenvalues and, optionally, eigenvectors of a */
/* symmetric tridiagonal matrix using the implicit QL or QR method. */
/* The eigenvectors of a full or band symmetric matrix can also be found */
/* if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to */
/* tridiagonal form. */
/* Arguments */
/* ========= */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only. */
/* = 'V': Compute eigenvalues and eigenvectors of the original */
/* symmetric matrix. On entry, Z must contain the */
/* orthogonal matrix used to reduce the original matrix */
/* to tridiagonal form. */
/* = 'I': Compute eigenvalues and eigenvectors of the */
/* tridiagonal matrix. Z is initialized to the identity */
/* matrix. */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the diagonal elements of the tridiagonal matrix. */
/* On exit, if INFO = 0, the eigenvalues in ascending order. */
/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
/* matrix. */
/* On exit, E has been destroyed. */
/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) */
/* On entry, if COMPZ = 'V', then Z contains the orthogonal */
/* matrix used in the reduction to tridiagonal form. */
/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */
/* orthonormal eigenvectors of the original symmetric matrix, */
/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */
/* of the symmetric tridiagonal matrix. */
/* If COMPZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* eigenvectors are desired, then LDZ >= max(1,N). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) */
/* If COMPZ = 'N', then WORK is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: the algorithm has failed to find all the eigenvalues in */
/* a total of 30*N iterations; if INFO = i, then i */
/* elements of E have not converged to zero; on exit, D */
/* and E contain the elements of a symmetric tridiagonal */
/* matrix which is orthogonally similar to the original */
/* matrix. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
if (lsame_(compz, "N")) {
icompz = 0;
} else if (lsame_(compz, "V")) {
icompz = 1;
} else if (lsame_(compz, "I")) {
icompz = 2;
} else {
icompz = -1;
}
if (icompz < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSTEQR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz == 2) {
z__[z_dim1 + 1] = 1.;
}
return 0;
}
/* Determine the unit roundoff and over/underflow thresholds. */
eps = dlamch_("E");
/* Computing 2nd power */
d__1 = eps;
eps2 = d__1 * d__1;
safmin = dlamch_("S");
safmax = 1. / safmin;
ssfmax = sqrt(safmax) / 3.;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues and eigenvectors of the tridiagonal */
/* matrix. */
if (icompz == 2) {
dlaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz);
}
nmaxit = *n * 30;
jtot = 0;
/* Determine where the matrix splits and choose QL or QR iteration */
/* for each block, according to whether top or bottom diagonal */
/* element is smaller. */
l1 = 1;
nm1 = *n - 1;
L10:
if (l1 > *n) {
goto L160;
}
if (l1 > 1) {
e[l1 - 1] = 0.;
}
if (l1 <= nm1) {
i__1 = nm1;
for (m = l1; m <= i__1; ++m) {
tst = (d__1 = e[m], abs(d__1));
if (tst == 0.) {
goto L30;
}
if (tst <= sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m
+ 1], abs(d__2))) * eps) {
e[m] = 0.;
goto L30;
}
/* L20: */
}
}
m = *n;
L30:
l = l1;
lsv = l;
lend = m;
lendsv = lend;
l1 = m + 1;
if (lend == l) {
goto L10;
}
/* Scale submatrix in rows and columns L to LEND */
i__1 = lend - l + 1;
anorm = dlanst_("I", &i__1, &d__[l], &e[l]);
iscale = 0;
if (anorm == 0.) {
goto L10;
}
if (anorm > ssfmax) {
iscale = 1;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
info);
} else if (anorm < ssfmin) {
iscale = 2;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
info);
}
/* Choose between QL and QR iteration */
if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) {
lend = lsv;
l = lendsv;
}
if (lend > l) {
/* QL Iteration */
/* Look for small subdiagonal element. */
L40:
if (l != lend) {
lendm1 = lend - 1;
i__1 = lendm1;
for (m = l; m <= i__1; ++m) {
/* Computing 2nd power */
d__2 = (d__1 = e[m], abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
+ 1], abs(d__2)) + safmin) {
goto L60;
}
/* L50: */
}
}
m = lend;
L60:
if (m < lend) {
e[m] = 0.;
}
p = d__[l];
if (m == l) {
goto L80;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */
/* to compute its eigensystem. */
if (m == l + 1) {
if (icompz > 0) {
dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
work[l] = c__;
work[*n - 1 + l] = s;
dlasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], &
z__[l * z_dim1 + 1], ldz);
} else {
dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
}
d__[l] = rt1;
d__[l + 1] = rt2;
e[l] = 0.;
l += 2;
if (l <= lend) {
goto L40;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l + 1] - p) / (e[l] * 2.);
r__ = dlapy2_(&g, &c_b10);
g = d__[m] - p + e[l] / (g + d_sign(&r__, &g));
s = 1.;
c__ = 1.;
p = 0.;
/* Inner loop */
mm1 = m - 1;
i__1 = l;
for (i__ = mm1; i__ >= i__1; --i__) {
f = s * e[i__];
b = c__ * e[i__];
dlartg_(&g, &f, &c__, &s, &r__);
if (i__ != m - 1) {
e[i__ + 1] = r__;
}
g = d__[i__ + 1] - p;
r__ = (d__[i__] - g) * s + c__ * 2. * b;
p = s * r__;
d__[i__ + 1] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
work[i__] = c__;
work[*n - 1 + i__] = -s;
}
/* L70: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = m - l + 1;
dlasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l
* z_dim1 + 1], ldz);
}
d__[l] -= p;
e[l] = g;
goto L40;
/* Eigenvalue found. */
L80:
d__[l] = p;
++l;
if (l <= lend) {
goto L40;
}
goto L140;
} else {
/* QR Iteration */
/* Look for small superdiagonal element. */
L90:
if (l != lend) {
lendp1 = lend + 1;
i__1 = lendp1;
for (m = l; m >= i__1; --m) {
/* Computing 2nd power */
d__2 = (d__1 = e[m - 1], abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
- 1], abs(d__2)) + safmin) {
goto L110;
}
/* L100: */
}
}
m = lend;
L110:
if (m > lend) {
e[m - 1] = 0.;
}
p = d__[l];
if (m == l) {
goto L130;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */
/* to compute its eigensystem. */
if (m == l - 1) {
if (icompz > 0) {
dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
;
work[m] = c__;
work[*n - 1 + m] = s;
dlasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], &
z__[(l - 1) * z_dim1 + 1], ldz);
} else {
dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
}
d__[l - 1] = rt1;
d__[l] = rt2;
e[l - 1] = 0.;
l += -2;
if (l >= lend) {
goto L90;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l - 1] - p) / (e[l - 1] * 2.);
r__ = dlapy2_(&g, &c_b10);
g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g));
s = 1.;
c__ = 1.;
p = 0.;
/* Inner loop */
lm1 = l - 1;
i__1 = lm1;
for (i__ = m; i__ <= i__1; ++i__) {
f = s * e[i__];
b = c__ * e[i__];
dlartg_(&g, &f, &c__, &s, &r__);
if (i__ != m) {
e[i__ - 1] = r__;
}
g = d__[i__] - p;
r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b;
p = s * r__;
d__[i__] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
work[i__] = c__;
work[*n - 1 + i__] = s;
}
/* L120: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = l - m + 1;
dlasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m
* z_dim1 + 1], ldz);
}
d__[l] -= p;
e[lm1] = g;
goto L90;
/* Eigenvalue found. */
L130:
d__[l] = p;
--l;
if (l >= lend) {
goto L90;
}
goto L140;
}
/* Undo scaling if necessary */
L140:
if (iscale == 1) {
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
info);
} else if (iscale == 2) {
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n,
info);
}
/* Check for no convergence to an eigenvalue after a total */
/* of N*MAXIT iterations. */
if (jtot < nmaxit) {
goto L10;
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.) {
++(*info);
}
/* L150: */
}
goto L190;
/* Order eigenvalues and eigenvectors. */
L160:
if (icompz == 0) {
/* Use Quick Sort */
dlasrt_("I", n, &d__[1], info);
} else {
/* Use Selection Sort to minimize swaps of eigenvectors */
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
i__ = ii - 1;
k = i__;
p = d__[i__];
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
if (d__[j] < p) {
k = j;
p = d__[j];
}
/* L170: */
}
if (k != i__) {
d__[k] = d__[i__];
d__[i__] = p;
dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1],
&c__1);
}
/* L180: */
}
}
L190:
return 0;
/* End of DSTEQR */
} /* dsteqr_ */
