/* Subroutine */ int ssterf_(integer *n, real *d__, real *e, integer *info)
{
/* System generated locals */
integer i__1;
real r__1, r__2, r__3;
/* Builtin functions */
double sqrt(doublereal), r_sign(real *, real *);
/* Local variables */
real c__;
integer i__, l, m;
real p, r__, s;
integer l1;
real bb, rt1, rt2, eps, rte;
integer lsv;
real eps2, oldc;
integer lend, jtot;
extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *)
;
real gamma, alpha, sigma, anorm;
extern doublereal slapy2_(real *, real *);
integer iscale;
real oldgam;
extern doublereal slamch_(char *);
real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
real safmax;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
integer lendsv;
real ssfmin;
integer nmaxit;
real ssfmax;
extern doublereal slanst_(char *, integer *, real *, real *);
extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SSTERF computes all eigenvalues of a symmetric tridiagonal matrix */
/* using the Pal-Walker-Kahan variant of the QL or QR algorithm. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* D (input/output) REAL array, dimension (N) */
/* On entry, the n diagonal elements of the tridiagonal matrix. */
/* On exit, if INFO = 0, the eigenvalues in ascending order. */
/* E (input/output) REAL array, dimension (N-1) */
/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
/* matrix. */
/* On exit, E has been destroyed. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: the algorithm failed to find all of the eigenvalues in */
/* a total of 30*N iterations; if INFO = i, then i */
/* elements of E have not converged to zero. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--e;
--d__;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n < 0) {
*info = -1;
i__1 = -(*info);
xerbla_("SSTERF", &i__1);
return 0;
}
if (*n <= 1) {
return 0;
}
/* Determine the unit roundoff for this environment. */
eps = slamch_("E");
/* Computing 2nd power */
r__1 = eps;
eps2 = r__1 * r__1;
safmin = slamch_("S");
safmax = 1.f / safmin;
ssfmax = sqrt(safmax) / 3.f;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues of the tridiagonal matrix. */
nmaxit = *n * 30;
sigma = 0.f;
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;
L10:
if (l1 > *n) {
goto L170;
}
if (l1 > 1) {
e[l1 - 1] = 0.f;
}
i__1 = *n - 1;
for (m = l1; m <= i__1; ++m) {
if ((r__3 = e[m], dabs(r__3)) <= sqrt((r__1 = d__[m], dabs(r__1))) *
sqrt((r__2 = d__[m + 1], dabs(r__2))) * eps) {
e[m] = 0.f;
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 = slanst_("I", &i__1, &d__[l], &e[l]);
iscale = 0;
if (anorm > ssfmax) {
iscale = 1;
i__1 = lend - l + 1;
slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
slascl_("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;
slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
info);
}
i__1 = lend - 1;
for (i__ = l; i__ <= i__1; ++i__) {
/* Computing 2nd power */
r__1 = e[i__];
e[i__] = r__1 * r__1;
/* L40: */
}
/* Choose between QL and QR iteration */
if ((r__1 = d__[lend], dabs(r__1)) < (r__2 = d__[l], dabs(r__2))) {
lend = lsv;
l = lendsv;
}
if (lend >= l) {
/* QL Iteration */
/* Look for small subdiagonal element. */
L50:
if (l != lend) {
i__1 = lend - 1;
for (m = l; m <= i__1; ++m) {
if ((r__2 = e[m], dabs(r__2)) <= eps2 * (r__1 = d__[m] * d__[
m + 1], dabs(r__1))) {
goto L70;
}
/* L60: */
}
}
m = lend;
L70:
if (m < lend) {
e[m] = 0.f;
}
p = d__[l];
if (m == l) {
goto L90;
}
/* If remaining matrix is 2 by 2, use SLAE2 to compute its */
/* eigenvalues. */
if (m == l + 1) {
rte = sqrt(e[l]);
slae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2);
d__[l] = rt1;
d__[l + 1] = rt2;
e[l] = 0.f;
l += 2;
if (l <= lend) {
goto L50;
}
goto L150;
}
if (jtot == nmaxit) {
goto L150;
}
++jtot;
/* Form shift. */
rte = sqrt(e[l]);
sigma = (d__[l + 1] - p) / (rte * 2.f);
r__ = slapy2_(&sigma, &c_b32);
sigma = p - rte / (sigma + r_sign(&r__, &sigma));
c__ = 1.f;
s = 0.f;
gamma = d__[m] - sigma;
p = gamma * gamma;
/* Inner loop */
i__1 = l;
for (i__ = m - 1; i__ >= i__1; --i__) {
bb = e[i__];
r__ = p + bb;
if (i__ != m - 1) {
e[i__ + 1] = s * r__;
}
oldc = c__;
c__ = p / r__;
s = bb / r__;
oldgam = gamma;
alpha = d__[i__];
gamma = c__ * (alpha - sigma) - s * oldgam;
d__[i__ + 1] = oldgam + (alpha - gamma);
if (c__ != 0.f) {
p = gamma * gamma / c__;
} else {
p = oldc * bb;
}
/* L80: */
}
e[l] = s * p;
d__[l] = sigma + gamma;
goto L50;
/* Eigenvalue found. */
L90:
d__[l] = p;
++l;
if (l <= lend) {
goto L50;
}
goto L150;
} else {
/* QR Iteration */
/* Look for small superdiagonal element. */
L100:
i__1 = lend + 1;
for (m = l; m >= i__1; --m) {
if ((r__2 = e[m - 1], dabs(r__2)) <= eps2 * (r__1 = d__[m] * d__[
m - 1], dabs(r__1))) {
goto L120;
}
/* L110: */
}
m = lend;
L120:
if (m > lend) {
e[m - 1] = 0.f;
}
p = d__[l];
if (m == l) {
goto L140;
}
/* If remaining matrix is 2 by 2, use SLAE2 to compute its */
/* eigenvalues. */
if (m == l - 1) {
rte = sqrt(e[l - 1]);
slae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2);
d__[l] = rt1;
d__[l - 1] = rt2;
e[l - 1] = 0.f;
l += -2;
if (l >= lend) {
goto L100;
}
goto L150;
}
if (jtot == nmaxit) {
goto L150;
}
++jtot;
/* Form shift. */
rte = sqrt(e[l - 1]);
sigma = (d__[l - 1] - p) / (rte * 2.f);
r__ = slapy2_(&sigma, &c_b32);
sigma = p - rte / (sigma + r_sign(&r__, &sigma));
c__ = 1.f;
s = 0.f;
gamma = d__[m] - sigma;
p = gamma * gamma;
/* Inner loop */
i__1 = l - 1;
for (i__ = m; i__ <= i__1; ++i__) {
bb = e[i__];
r__ = p + bb;
if (i__ != m) {
e[i__ - 1] = s * r__;
}
oldc = c__;
c__ = p / r__;
s = bb / r__;
oldgam = gamma;
alpha = d__[i__ + 1];
gamma = c__ * (alpha - sigma) - s * oldgam;
d__[i__] = oldgam + (alpha - gamma);
if (c__ != 0.f) {
p = gamma * gamma / c__;
} else {
p = oldc * bb;
}
/* L130: */
}
e[l - 1] = s * p;
d__[l] = sigma + gamma;
goto L100;
/* Eigenvalue found. */
L140:
d__[l] = p;
--l;
if (l >= lend) {
goto L100;
}
goto L150;
}
/* Undo scaling if necessary */
L150:
if (iscale == 1) {
i__1 = lendsv - lsv + 1;
slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
}
if (iscale == 2) {
i__1 = lendsv - lsv + 1;
slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[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.f) {
++(*info);
}
/* L160: */
}
goto L180;
/* Sort eigenvalues in increasing order. */
L170:
slasrt_("I", n, &d__[1], info);
L180:
return 0;
/* End of SSTERF */
} /* ssterf_ */
/* Subroutine */ int slasq1_(integer *n, real *d__, real *e, real *work,
integer *info)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2, r__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__;
real eps;
extern /* Subroutine */ int slas2_(real *, real *, real *, real *, real *)
;
real scale;
integer iinfo;
real sigmn, sigmx;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), slasq2_(integer *, real *, integer *);
extern doublereal slamch_(char *);
real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), slascl_(
char *, integer *, integer *, real *, real *, integer *, integer *
, real *, integer *, integer *), slasrt_(char *, integer *
, real *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
/* -- Berkeley -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLASQ1 computes the singular values of a real N-by-N bidiagonal */
/* matrix with diagonal D and off-diagonal E. The singular values */
/* are computed to high relative accuracy, in the absence of */
/* denormalization, underflow and overflow. The algorithm was first */
/* presented in */
/* "Accurate singular values and differential qd algorithms" by K. V. */
/* Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230, */
/* 1994, */
/* and the present implementation is described in "An implementation of */
/* the dqds Algorithm (Positive Case)", LAPACK Working Note. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of rows and columns in the matrix. N >= 0. */
/* D (input/output) REAL array, dimension (N) */
/* On entry, D contains the diagonal elements of the */
/* bidiagonal matrix whose SVD is desired. On normal exit, */
/* D contains the singular values in decreasing order. */
/* E (input/output) REAL array, dimension (N) */
/* On entry, elements E(1:N-1) contain the off-diagonal elements */
/* of the bidiagonal matrix whose SVD is desired. */
/* On exit, E is overwritten. */
/* WORK (workspace) REAL 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 failed */
/* = 1, a split was marked by a positive value in E */
/* = 2, current block of Z not diagonalized after 30*N */
/* iterations (in inner while loop) */
/* = 3, termination criterion of outer while loop not met */
/* (program created more than N unreduced blocks) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--work;
--e;
--d__;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -2;
i__1 = -(*info);
xerbla_("SLASQ1", &i__1);
return 0;
} else if (*n == 0) {
return 0;
} else if (*n == 1) {
d__[1] = dabs(d__[1]);
return 0;
} else if (*n == 2) {
slas2_(&d__[1], &e[1], &d__[2], &sigmn, &sigmx);
d__[1] = sigmx;
d__[2] = sigmn;
return 0;
}
/* Estimate the largest singular value. */
sigmx = 0.f;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = (r__1 = d__[i__], dabs(r__1));
/* Computing MAX */
r__2 = sigmx, r__3 = (r__1 = e[i__], dabs(r__1));
sigmx = dmax(r__2,r__3);
/* L10: */
}
d__[*n] = (r__1 = d__[*n], dabs(r__1));
/* Early return if SIGMX is zero (matrix is already diagonal). */
if (sigmx == 0.f) {
slasrt_("D", n, &d__[1], &iinfo);
return 0;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__1 = sigmx, r__2 = d__[i__];
sigmx = dmax(r__1,r__2);
/* L20: */
}
/* Copy D and E into WORK (in the Z format) and scale (squaring the */
/* input data makes scaling by a power of the radix pointless). */
eps = slamch_("Precision");
safmin = slamch_("Safe minimum");
scale = sqrt(eps / safmin);
scopy_(n, &d__[1], &c__1, &work[1], &c__2);
i__1 = *n - 1;
scopy_(&i__1, &e[1], &c__1, &work[2], &c__2);
i__1 = (*n << 1) - 1;
i__2 = (*n << 1) - 1;
slascl_("G", &c__0, &c__0, &sigmx, &scale, &i__1, &c__1, &work[1], &i__2,
&iinfo);
/* Compute the q's and e's. */
i__1 = (*n << 1) - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing 2nd power */
r__1 = work[i__];
work[i__] = r__1 * r__1;
/* L30: */
}
work[*n * 2] = 0.f;
slasq2_(n, &work[1], info);
if (*info == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = sqrt(work[i__]);
/* L40: */
}
slascl_("G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, &
iinfo);
}
return 0;
/* End of SLASQ1 */
} /* slasq1_ */
/* Subroutine */ int ssteqr_(char *compz, integer *n, real *d__, real *e,
real *z__, integer *ldz, real *work, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
real r__1, r__2;
/* Local variables */
real b, c__, f, g;
integer i__, j, k, l, m;
real p, r__, s;
integer l1, ii, mm, lm1, mm1, nm1;
real rt1, rt2, eps;
integer lsv;
real tst, eps2;
integer lend, jtot;
real anorm;
integer lendm1, lendp1;
integer iscale;
real safmin;
real safmax;
integer lendsv;
real ssfmin;
integer nmaxit, icompz;
real ssfmax;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SSTEQR 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 SSYTRD or SSPTRD or SSBTRD 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) REAL 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) REAL array, dimension (N-1) */
/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
/* matrix. */
/* On exit, E has been destroyed. */
/* Z (input/output) REAL 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) REAL 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. */
/* ===================================================================== */
/* 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_("SSTEQR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz == 2) {
z__[z_dim1 + 1] = 1.f;
}
return 0;
}
/* Determine the unit roundoff and over/underflow thresholds. */
eps = slamch_("E");
/* Computing 2nd power */
r__1 = eps;
eps2 = r__1 * r__1;
safmin = slamch_("S");
safmax = 1.f / safmin;
ssfmax = sqrt(safmax) / 3.f;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues and eigenvectors of the tridiagonal */
/* matrix. */
if (icompz == 2) {
slaset_("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.f;
}
if (l1 <= nm1) {
i__1 = nm1;
for (m = l1; m <= i__1; ++m) {
tst = (r__1 = e[m], dabs(r__1));
if (tst == 0.f) {
goto L30;
}
if (tst <= sqrt((r__1 = d__[m], dabs(r__1))) * sqrt((r__2 = d__[m
+ 1], dabs(r__2))) * eps) {
e[m] = 0.f;
goto L30;
}
}
}
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 = slanst_("I", &i__1, &d__[l], &e[l]);
iscale = 0;
if (anorm == 0.f) {
goto L10;
}
if (anorm > ssfmax) {
iscale = 1;
i__1 = lend - l + 1;
slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
slascl_("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;
slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
info);
}
/* Choose between QL and QR iteration */
if ((r__1 = d__[lend], dabs(r__1)) < (r__2 = d__[l], dabs(r__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 */
r__2 = (r__1 = e[m], dabs(r__1));
tst = r__2 * r__2;
if (tst <= eps2 * (r__1 = d__[m], dabs(r__1)) * (r__2 = d__[m
+ 1], dabs(r__2)) + safmin) {
goto L60;
}
}
}
m = lend;
L60:
if (m < lend) {
e[m] = 0.f;
}
p = d__[l];
if (m == l) {
goto L80;
}
/* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2 */
/* to compute its eigensystem. */
if (m == l + 1) {
if (icompz > 0) {
slaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
work[l] = c__;
work[*n - 1 + l] = s;
slasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], &
z__[l * z_dim1 + 1], ldz);
} else {
slae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
}
d__[l] = rt1;
d__[l + 1] = rt2;
e[l] = 0.f;
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.f);
r__ = slapy2_(&g, &c_b10);
g = d__[m] - p + e[l] / (g + r_sign(&r__, &g));
s = 1.f;
c__ = 1.f;
p = 0.f;
/* Inner loop */
mm1 = m - 1;
i__1 = l;
for (i__ = mm1; i__ >= i__1; --i__) {
f = s * e[i__];
b = c__ * e[i__];
slartg_(&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.f * 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;
}
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = m - l + 1;
slasr_("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 */
r__2 = (r__1 = e[m - 1], dabs(r__1));
tst = r__2 * r__2;
if (tst <= eps2 * (r__1 = d__[m], dabs(r__1)) * (r__2 = d__[m
- 1], dabs(r__2)) + safmin) {
goto L110;
}
}
}
m = lend;
L110:
if (m > lend) {
e[m - 1] = 0.f;
}
p = d__[l];
if (m == l) {
goto L130;
}
/* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2 */
/* to compute its eigensystem. */
if (m == l - 1) {
if (icompz > 0) {
slaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
;
work[m] = c__;
work[*n - 1 + m] = s;
slasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], &
z__[(l - 1) * z_dim1 + 1], ldz);
} else {
slae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
}
d__[l - 1] = rt1;
d__[l] = rt2;
e[l - 1] = 0.f;
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.f);
r__ = slapy2_(&g, &c_b10);
g = d__[m] - p + e[l - 1] / (g + r_sign(&r__, &g));
s = 1.f;
c__ = 1.f;
p = 0.f;
/* Inner loop */
lm1 = l - 1;
i__1 = lm1;
for (i__ = m; i__ <= i__1; ++i__) {
f = s * e[i__];
b = c__ * e[i__];
slartg_(&g, &f, &c__, &s, &r__);
if (i__ != m) {
e[i__ - 1] = r__;
}
g = d__[i__] - p;
r__ = (d__[i__ + 1] - g) * s + c__ * 2.f * 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;
}
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = l - m + 1;
slasr_("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;
slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
i__1 = lendsv - lsv;
slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
info);
} else if (iscale == 2) {
i__1 = lendsv - lsv + 1;
slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
i__1 = lendsv - lsv;
slascl_("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.f) {
++(*info);
}
}
goto L190;
/* Order eigenvalues and eigenvectors. */
L160:
if (icompz == 0) {
/* Use Quick Sort */
slasrt_("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];
}
}
if (k != i__) {
d__[k] = d__[i__];
d__[i__] = p;
sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1],
&c__1);
}
}
}
L190:
return 0;
/* End of SSTEQR */
} /* ssteqr_ */
/* Subroutine */ int sstedc_(char *compz, integer *n, real *d__, real *e,
real *z__, integer *ldz, real *work, integer *lwork, integer *iwork,
integer *liwork, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double log(doublereal);
integer pow_ii(integer *, integer *);
double sqrt(doublereal);
/* Local variables */
integer i__, j, k, m;
real p;
integer ii, lgn;
real eps, tiny;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
integer lwmin, start;
extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
integer *), slaed0_(integer *, integer *, integer *, real *, real
*, real *, integer *, real *, integer *, real *, integer *,
integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
integer finish;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *,
real *, integer *), slaset_(char *, integer *, integer *,
real *, real *, real *, integer *);
integer liwmin, icompz;
real orgnrm;
extern doublereal slanst_(char *, integer *, real *, real *);
extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *),
slasrt_(char *, integer *, real *, integer *);
logical lquery;
integer smlsiz;
extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *,
real *, integer *, real *, integer *);
integer storez, strtrw;
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SSTEDC computes all eigenvalues and, optionally, eigenvectors of a */
/* symmetric tridiagonal matrix using the divide and conquer method. */
/* The eigenvectors of a full or band real symmetric matrix can also be */
/* found if SSYTRD or SSPTRD or SSBTRD has been used to reduce this */
/* matrix to tridiagonal 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 SLAED3 for details. */
/* Arguments */
/* ========= */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only. */
/* = 'I': Compute eigenvectors of tridiagonal matrix also. */
/* = 'V': Compute eigenvectors of original dense symmetric */
/* matrix also. On entry, Z contains the orthogonal */
/* matrix used to reduce the original matrix to */
/* tridiagonal form. */
/* N (input) INTEGER */
/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
/* D (input/output) REAL 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) REAL array, dimension (N-1) */
/* On entry, the subdiagonal elements of the tridiagonal matrix. */
/* On exit, E has been destroyed. */
/* Z (input/output) REAL 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. */
/* If eigenvectors are desired, then LDZ >= max(1,N). */
/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* If COMPZ = 'N' or N <= 1 then LWORK must be at least 1. */
/* If COMPZ = 'V' and N > 1 then LWORK must be at least */
/* ( 1 + 3*N + 2*N*lg N + 3*N**2 ), */
/* where lg( N ) = smallest integer k such */
/* that 2**k >= N. */
/* If COMPZ = 'I' and N > 1 then LWORK must be at least */
/* ( 1 + 4*N + N**2 ). */
/* Note that for COMPZ = 'I' or 'V', then if N is less than or */
/* equal to the minimum divide size, usually 25, then LWORK need */
/* only be max(1,2*(N-1)). */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. */
/* If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1. */
/* If COMPZ = 'V' and N > 1 then LIWORK must be at least */
/* ( 6 + 6*N + 5*N*lg N ). */
/* If COMPZ = 'I' and N > 1 then LIWORK must be at least */
/* ( 3 + 5*N ). */
/* Note that for COMPZ = 'I' or 'V', then if N is less than or */
/* equal to the minimum divide size, usually 25, then LIWORK */
/* need only be 1. */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal size of the IWORK array, */
/* returns this value as the first entry of the IWORK array, and */
/* no error message related to LIWORK is issued by XERBLA. */
/* 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 eigenvalue while */
/* working on the submatrix lying in rows and columns */
/* INFO/(N+1) through mod(INFO,N+1). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Jeff Rutter, Computer Science Division, University of California */
/* at Berkeley, USA */
/* Modified by Francoise Tisseur, University of Tennessee. */
/* ===================================================================== */
/* .. 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;
--iwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1 || *liwork == -1;
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) {
/* Compute the workspace requirements */
smlsiz = ilaenv_(&c__9, "SSTEDC", " ", &c__0, &c__0, &c__0, &c__0);
if (*n <= 1 || icompz == 0) {
liwmin = 1;
lwmin = 1;
} else if (*n <= smlsiz) {
liwmin = 1;
lwmin = *n - 1 << 1;
} else {
lgn = (integer) (log((real) (*n)) / log(2.f));
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (icompz == 1) {
/* Computing 2nd power */
i__1 = *n;
lwmin = *n * 3 + 1 + (*n << 1) * lgn + i__1 * i__1 * 3;
liwmin = *n * 6 + 6 + *n * 5 * lgn;
} else if (icompz == 2) {
/* Computing 2nd power */
i__1 = *n;
lwmin = (*n << 2) + 1 + i__1 * i__1;
liwmin = *n * 5 + 3;
}
}
work[1] = (real) lwmin;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -8;
} else if (*liwork < liwmin && ! lquery) {
*info = -10;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSTEDC", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz != 0) {
z__[z_dim1 + 1] = 1.f;
}
return 0;
}
/* If the following conditional clause is removed, then the routine */
/* will use the Divide and Conquer routine to compute only the */
/* eigenvalues, which requires (3N + 3N**2) real workspace and */
/* (2 + 5N + 2N lg(N)) integer workspace. */
/* Since on many architectures SSTERF is much faster than any other */
/* algorithm for finding eigenvalues only, it is used here */
/* as the default. If the conditional clause is removed, then */
/* information on the size of workspace needs to be changed. */
/* If COMPZ = 'N', use SSTERF to compute the eigenvalues. */
if (icompz == 0) {
ssterf_(n, &d__[1], &e[1], info);
goto L50;
}
/* If N is smaller than the minimum divide size (SMLSIZ+1), then */
/* solve the problem with another solver. */
if (*n <= smlsiz) {
ssteqr_(compz, n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], info);
} else {
/* If COMPZ = 'V', the Z matrix must be stored elsewhere for later */
/* use. */
if (icompz == 1) {
storez = *n * *n + 1;
} else {
storez = 1;
}
if (icompz == 2) {
slaset_("Full", n, n, &c_b17, &c_b18, &z__[z_offset], ldz);
}
/* Scale. */
orgnrm = slanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.f) {
goto L50;
}
eps = slamch_("Epsilon");
start = 1;
/* while ( START <= N ) */
L10:
if (start <= *n) {
/* Let FINISH be the position of the next subdiagonal entry */
/* such that E( FINISH ) <= TINY or FINISH = N if no such */
/* subdiagonal exists. The matrix identified by the elements */
/* between START and FINISH constitutes an independent */
/* sub-problem. */
finish = start;
L20:
if (finish < *n) {
tiny = eps * sqrt((r__1 = d__[finish], dabs(r__1))) * sqrt((
r__2 = d__[finish + 1], dabs(r__2)));
if ((r__1 = e[finish], dabs(r__1)) > tiny) {
++finish;
goto L20;
}
}
/* (Sub) Problem determined. Compute its size and solve it. */
m = finish - start + 1;
if (m == 1) {
start = finish + 1;
goto L10;
}
if (m > smlsiz) {
/* Scale. */
orgnrm = slanst_("M", &m, &d__[start], &e[start]);
slascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &m, &c__1, &d__[
start], &m, info);
i__1 = m - 1;
i__2 = m - 1;
slascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &i__1, &c__1, &e[
start], &i__2, info);
if (icompz == 1) {
strtrw = 1;
} else {
strtrw = start;
}
slaed0_(&icompz, n, &m, &d__[start], &e[start], &z__[strtrw +
start * z_dim1], ldz, &work[1], n, &work[storez], &
iwork[1], info);
if (*info != 0) {
*info = (*info / (m + 1) + start - 1) * (*n + 1) + *info %
(m + 1) + start - 1;
goto L50;
}
/* Scale back. */
slascl_("G", &c__0, &c__0, &c_b18, &orgnrm, &m, &c__1, &d__[
start], &m, info);
} else {
if (icompz == 1) {
/* Since QR won't update a Z matrix which is larger than */
/* the length of D, we must solve the sub-problem in a */
/* workspace and then multiply back into Z. */
ssteqr_("I", &m, &d__[start], &e[start], &work[1], &m, &
work[m * m + 1], info);
slacpy_("A", n, &m, &z__[start * z_dim1 + 1], ldz, &work[
storez], n);
sgemm_("N", "N", n, &m, &m, &c_b18, &work[storez], n, &
work[1], &m, &c_b17, &z__[start * z_dim1 + 1],
ldz);
} else if (icompz == 2) {
ssteqr_("I", &m, &d__[start], &e[start], &z__[start +
start * z_dim1], ldz, &work[1], info);
} else {
ssterf_(&m, &d__[start], &e[start], info);
}
if (*info != 0) {
*info = start * (*n + 1) + finish;
goto L50;
}
}
start = finish + 1;
goto L10;
}
/* endwhile */
/* If the problem split any number of times, then the eigenvalues */
/* will not be properly ordered. Here we permute the eigenvalues */
/* (and the associated eigenvectors) into ascending order. */
if (m != *n) {
if (icompz == 0) {
/* Use Quick Sort */
slasrt_("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];
}
/* L30: */
}
if (k != i__) {
d__[k] = d__[i__];
d__[i__] = p;
sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k *
z_dim1 + 1], &c__1);
}
/* L40: */
}
}
}
}
L50:
work[1] = (real) lwmin;
iwork[1] = liwmin;
return 0;
/* End of SSTEDC */
} /* sstedc_ */
/* Subroutine */ int slalsd_(char *uplo, integer *smlsiz, integer *n, integer
*nrhs, real *d__, real *e, real *b, integer *ldb, real *rcond,
integer *rank, real *work, integer *iwork, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2;
real r__1;
/* Builtin functions */
double log(doublereal), r_sign(real *, real *);
/* Local variables */
static integer difl, difr, perm, nsub, nlvl, sqre, bxst;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
static integer c__, i__, j, k;
static real r__;
static integer s, u, z__;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
static integer poles, sizei, nsize;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static integer nwork, icmpq1, icmpq2;
extern doublereal sopbl3_(char *, integer *, integer *, integer *)
;
static real cs;
static integer bx;
static real sn;
static integer st;
extern /* Subroutine */ int slasda_(integer *, integer *, integer *,
integer *, real *, real *, real *, integer *, real *, integer *,
real *, real *, real *, real *, integer *, integer *, integer *,
integer *, real *, real *, real *, real *, integer *, integer *);
extern doublereal slamch_(char *);
static integer vt;
extern /* Subroutine */ int xerbla_(char *, integer *), slalsa_(
integer *, integer *, integer *, integer *, real *, integer *,
real *, integer *, real *, integer *, real *, integer *, real *,
real *, real *, real *, integer *, integer *, integer *, integer *
, real *, real *, real *, real *, integer *, integer *), slascl_(
char *, integer *, integer *, real *, real *, integer *, integer *
, real *, integer *, integer *);
static integer givcol;
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */ int slasdq_(char *, integer *, integer *, integer
*, integer *, integer *, real *, real *, real *, integer *, real *
, integer *, real *, integer *, real *, integer *),
slacpy_(char *, integer *, integer *, real *, integer *, real *,
integer *), slartg_(real *, real *, real *, real *, real *
), slaset_(char *, integer *, integer *, real *, real *, real *,
integer *);
static real orgnrm;
static integer givnum;
extern doublereal slanst_(char *, integer *, real *, real *);
extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *);
static integer givptr, nm1, smlszp, st1;
static real eps;
static integer iwk;
static real tol;
#define b_ref(a_1,a_2) b[(a_2)*b_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
=======
SLALSD 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) REAL 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) REAL array, dimension (N-1)
Contains the super-diagonal entries of the bidiagonal matrix.
On exit, E has been destroyed.
B (input/output) REAL 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) REAL
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) REAL 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).
=====================================================================
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_("SLALSD", &i__1);
return 0;
}
eps = slamch_("Epsilon");
/* Set up the tolerance. */
if (*rcond <= 0.f || *rcond >= 1.f) {
*rcond = eps;
}
*rank = 0;
/* Quick return if possible. */
if (*n == 0) {
return 0;
} else if (*n == 1) {
if (d__[1] == 0.f) {
slaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb);
} else {
*rank = 1;
latime_1.ops += (real) (*nrhs << 1);
slascl_("G", &c__0, &c__0, &d__[1], &c_b11, &c__1, nrhs, &b[
b_offset], ldb, info);
d__[1] = dabs(d__[1]);
}
return 0;
}
/* Rotate the matrix if it is lower bidiagonal. */
if (*(unsigned char *)uplo == 'L') {
latime_1.ops += (real) ((*n - 1) * 6);
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
slartg_(&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) {
latime_1.ops += 6.f;
srot_(&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) {
latime_1.ops += (real) ((*n - 1) * 6 * *nrhs);
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];
srot_(&c__1, &b_ref(j, i__), &c__1, &b_ref(j + 1, i__), &
c__1, &cs, &sn);
/* L20: */
}
/* L30: */
}
}
}
/* Scale. */
nm1 = *n - 1;
orgnrm = slanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.f) {
slaset_("A", n, nrhs, &c_b6, &c_b6, &b[b_offset], ldb);
return 0;
}
latime_1.ops += (real) (*n + nm1);
slascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, &c__1, &d__[1], n, info);
slascl_("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;
slaset_("A", n, n, &c_b6, &c_b11, &work[1], n);
slasdq_("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;
}
latime_1.ops += 1.f;
tol = *rcond * (r__1 = d__[isamax_(n, &d__[1], &c__1)], dabs(r__1));
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] <= tol) {
slaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b_ref(i__, 1), ldb);
} else {
latime_1.ops += (real) (*nrhs);
slascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &
b_ref(i__, 1), ldb, info);
++(*rank);
}
/* L40: */
}
latime_1.ops += sopbl3_("SGEMM ", n, nrhs, n);
sgemm_("T", "N", n, nrhs, n, &c_b11, &work[1], n, &b[b_offset], ldb, &
c_b6, &work[nwork], n);
slacpy_("A", n, nrhs, &work[nwork], n, &b[b_offset], ldb);
/* Unscale. */
latime_1.ops += (real) (*n + *n * *nrhs);
slascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n,
info);
slasrt_("D", n, &d__[1], info);
slascl_("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((real) (*n) / (real) (*smlsiz + 1)) / log(2.f)) + 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 ((r__1 = d__[i__], dabs(r__1)) < eps) {
d__[i__] = r_sign(&eps, &d__[i__]);
}
/* L50: */
}
i__1 = nm1;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((r__1 = e[i__], dabs(r__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 ((r__1 = e[i__], dabs(r__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;
scopy_(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. */
scopy_(nrhs, &b_ref(st, 1), ldb, &work[bx + st1], n);
} else if (nsize <= *smlsiz) {
/* This is a small subproblem and is solved by SLASDQ. */
slaset_("A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1],
n);
slasdq_("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;
}
slacpy_("A", &nsize, nrhs, &b_ref(st, 1), ldb, &work[bx + st1]
, n);
} else {
/* A large problem. Solve it using divide and conquer. */
slasda_(&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;
slalsa_(&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 * (r__1 = d__[isamax_(n, &d__[1], &c__1)], dabs(r__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 ((r__1 = d__[i__], dabs(r__1)) <= tol) {
slaset_("A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n);
} else {
++(*rank);
latime_1.ops += (real) (*nrhs);
slascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[
bx + i__ - 1], n, info);
}
d__[i__] = (r__1 = d__[i__], dabs(r__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) {
scopy_(nrhs, &work[bxst], n, &b_ref(st, 1), ldb);
} else if (nsize <= *smlsiz) {
latime_1.ops += sopbl3_("SGEMM ", &nsize, nrhs, &nsize)
;
sgemm_("T", "N", &nsize, nrhs, &nsize, &c_b11, &work[vt + st1], n,
&work[bxst], n, &c_b6, &b_ref(st, 1), ldb);
} else {
slalsa_(&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. */
latime_1.ops += (real) (*n + *n * *nrhs);
slascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info);
slasrt_("D", n, &d__[1], info);
slascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb,
info);
return 0;
/* End of SLALSD */
} /* slalsd_ */
/* Subroutine */ int slasq2_(integer *n, real *z__, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
real d__, e;
integer k;
real s, t;
integer i0, i4, n0;
real dn;
integer pp;
real dn1, dn2, eps, tau, tol;
integer ipn4;
real tol2;
logical ieee;
integer nbig;
real dmin__, emin, emax;
integer ndiv, iter;
real qmin, temp, qmax, zmax;
integer splt;
real dmin1, dmin2;
integer nfail;
real desig, trace, sigma;
integer iinfo, ttype;
extern /* Subroutine */ int slazq3_(integer *, integer *, real *, integer
*, real *, real *, real *, real *, integer *, integer *, integer *
, logical *, integer *, real *, real *, real *, real *, real *,
real *);
extern doublereal slamch_(char *);
integer iwhila, iwhilb;
real oldemn, safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call SLAZQ3 in place of SLASQ3, 13 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLASQ2 computes all the eigenvalues of the symmetric positive */
/* definite tridiagonal matrix associated with the qd array Z to high */
/* relative accuracy are computed to high relative accuracy, in the */
/* absence of denormalization, underflow and overflow. */
/* To see the relation of Z to the tridiagonal matrix, let L be a */
/* unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and */
/* let U be an upper bidiagonal matrix with 1's above and diagonal */
/* Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the */
/* symmetric tridiagonal to which it is similar. */
/* Note : SLASQ2 defines a logical variable, IEEE, which is true */
/* on machines which follow ieee-754 floating-point standard in their */
/* handling of infinities and NaNs, and false otherwise. This variable */
/* is passed to SLAZQ3. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of rows and columns in the matrix. N >= 0. */
/* Z (workspace) REAL array, dimension (4*N) */
/* On entry Z holds the qd array. On exit, entries 1 to N hold */
/* the eigenvalues in decreasing order, Z( 2*N+1 ) holds the */
/* trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If */
/* N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 ) */
/* holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of */
/* shifts that failed. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if the i-th argument is a scalar and had an illegal */
/* value, then INFO = -i, if the i-th argument is an */
/* array and the j-entry had an illegal value, then */
/* INFO = -(i*100+j) */
/* > 0: the algorithm failed */
/* = 1, a split was marked by a positive value in E */
/* = 2, current block of Z not diagonalized after 30*N */
/* iterations (in inner while loop) */
/* = 3, termination criterion of outer while loop not met */
/* (program created more than N unreduced blocks) */
/* Further Details */
/* =============== */
/* Local Variables: I0:N0 defines a current unreduced segment of Z. */
/* The shifts are accumulated in SIGMA. Iteration count is in ITER. */
/* Ping-pong is controlled by PP (alternates between 0 and 1). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments. */
/* (in case SLASQ2 is not called by SLASQ1) */
/* Parameter adjustments */
--z__;
/* Function Body */
*info = 0;
eps = slamch_("Precision");
safmin = slamch_("Safe minimum");
tol = eps * 100.f;
/* Computing 2nd power */
r__1 = tol;
tol2 = r__1 * r__1;
if (*n < 0) {
*info = -1;
xerbla_("SLASQ2", &c__1);
return 0;
} else if (*n == 0) {
return 0;
} else if (*n == 1) {
/* 1-by-1 case. */
if (z__[1] < 0.f) {
*info = -201;
xerbla_("SLASQ2", &c__2);
}
return 0;
} else if (*n == 2) {
/* 2-by-2 case. */
if (z__[2] < 0.f || z__[3] < 0.f) {
*info = -2;
xerbla_("SLASQ2", &c__2);
return 0;
} else if (z__[3] > z__[1]) {
d__ = z__[3];
z__[3] = z__[1];
z__[1] = d__;
}
z__[5] = z__[1] + z__[2] + z__[3];
if (z__[2] > z__[3] * tol2) {
t = (z__[1] - z__[3] + z__[2]) * .5f;
s = z__[3] * (z__[2] / t);
if (s <= t) {
s = z__[3] * (z__[2] / (t * (sqrt(s / t + 1.f) + 1.f)));
} else {
s = z__[3] * (z__[2] / (t + sqrt(t) * sqrt(t + s)));
}
t = z__[1] + (s + z__[2]);
z__[3] *= z__[1] / t;
z__[1] = t;
}
z__[2] = z__[3];
z__[6] = z__[2] + z__[1];
return 0;
}
/* Check for negative data and compute sums of q's and e's. */
z__[*n * 2] = 0.f;
emin = z__[2];
qmax = 0.f;
zmax = 0.f;
d__ = 0.f;
e = 0.f;
i__1 = *n - 1 << 1;
for (k = 1; k <= i__1; k += 2) {
if (z__[k] < 0.f) {
*info = -(k + 200);
xerbla_("SLASQ2", &c__2);
return 0;
} else if (z__[k + 1] < 0.f) {
*info = -(k + 201);
xerbla_("SLASQ2", &c__2);
return 0;
}
d__ += z__[k];
e += z__[k + 1];
/* Computing MAX */
r__1 = qmax, r__2 = z__[k];
qmax = dmax(r__1,r__2);
/* Computing MIN */
r__1 = emin, r__2 = z__[k + 1];
emin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = max(qmax,zmax), r__2 = z__[k + 1];
zmax = dmax(r__1,r__2);
/* L10: */
}
if (z__[(*n << 1) - 1] < 0.f) {
*info = -((*n << 1) + 199);
xerbla_("SLASQ2", &c__2);
return 0;
}
d__ += z__[(*n << 1) - 1];
/* Computing MAX */
r__1 = qmax, r__2 = z__[(*n << 1) - 1];
qmax = dmax(r__1,r__2);
zmax = dmax(qmax,zmax);
/* Check for diagonality. */
if (e == 0.f) {
i__1 = *n;
for (k = 2; k <= i__1; ++k) {
z__[k] = z__[(k << 1) - 1];
/* L20: */
}
slasrt_("D", n, &z__[1], &iinfo);
z__[(*n << 1) - 1] = d__;
return 0;
}
trace = d__ + e;
/* Check for zero data. */
if (trace == 0.f) {
z__[(*n << 1) - 1] = 0.f;
return 0;
}
/* Check whether the machine is IEEE conformable. */
ieee = ilaenv_(&c__10, "SLASQ2", "N", &c__1, &c__2, &c__3, &c__4) == 1 && ilaenv_(&c__11, "SLASQ2", "N", &c__1, &c__2,
&c__3, &c__4) == 1;
/* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). */
for (k = *n << 1; k >= 2; k += -2) {
z__[k * 2] = 0.f;
z__[(k << 1) - 1] = z__[k];
z__[(k << 1) - 2] = 0.f;
z__[(k << 1) - 3] = z__[k - 1];
/* L30: */
}
i0 = 1;
n0 = *n;
/* Reverse the qd-array, if warranted. */
if (z__[(i0 << 2) - 3] * 1.5f < z__[(n0 << 2) - 3]) {
ipn4 = i0 + n0 << 2;
i__1 = i0 + n0 - 1 << 1;
for (i4 = i0 << 2; i4 <= i__1; i4 += 4) {
temp = z__[i4 - 3];
z__[i4 - 3] = z__[ipn4 - i4 - 3];
z__[ipn4 - i4 - 3] = temp;
temp = z__[i4 - 1];
z__[i4 - 1] = z__[ipn4 - i4 - 5];
z__[ipn4 - i4 - 5] = temp;
/* L40: */
}
}
/* Initial split checking via dqd and Li's test. */
pp = 0;
for (k = 1; k <= 2; ++k) {
d__ = z__[(n0 << 2) + pp - 3];
i__1 = (i0 << 2) + pp;
for (i4 = (n0 - 1 << 2) + pp; i4 >= i__1; i4 += -4) {
if (z__[i4 - 1] <= tol2 * d__) {
z__[i4 - 1] = -0.f;
d__ = z__[i4 - 3];
} else {
d__ = z__[i4 - 3] * (d__ / (d__ + z__[i4 - 1]));
}
/* L50: */
}
/* dqd maps Z to ZZ plus Li's test. */
emin = z__[(i0 << 2) + pp + 1];
d__ = z__[(i0 << 2) + pp - 3];
i__1 = (n0 - 1 << 2) + pp;
for (i4 = (i0 << 2) + pp; i4 <= i__1; i4 += 4) {
z__[i4 - (pp << 1) - 2] = d__ + z__[i4 - 1];
if (z__[i4 - 1] <= tol2 * d__) {
z__[i4 - 1] = -0.f;
z__[i4 - (pp << 1) - 2] = d__;
z__[i4 - (pp << 1)] = 0.f;
d__ = z__[i4 + 1];
} else if (safmin * z__[i4 + 1] < z__[i4 - (pp << 1) - 2] &&
safmin * z__[i4 - (pp << 1) - 2] < z__[i4 + 1]) {
temp = z__[i4 + 1] / z__[i4 - (pp << 1) - 2];
z__[i4 - (pp << 1)] = z__[i4 - 1] * temp;
d__ *= temp;
} else {
z__[i4 - (pp << 1)] = z__[i4 + 1] * (z__[i4 - 1] / z__[i4 - (
pp << 1) - 2]);
d__ = z__[i4 + 1] * (d__ / z__[i4 - (pp << 1) - 2]);
}
/* Computing MIN */
r__1 = emin, r__2 = z__[i4 - (pp << 1)];
emin = dmin(r__1,r__2);
/* L60: */
}
z__[(n0 << 2) - pp - 2] = d__;
/* Now find qmax. */
qmax = z__[(i0 << 2) - pp - 2];
i__1 = (n0 << 2) - pp - 2;
for (i4 = (i0 << 2) - pp + 2; i4 <= i__1; i4 += 4) {
/* Computing MAX */
r__1 = qmax, r__2 = z__[i4];
qmax = dmax(r__1,r__2);
/* L70: */
}
/* Prepare for the next iteration on K. */
pp = 1 - pp;
/* L80: */
}
/* Initialise variables to pass to SLAZQ3 */
ttype = 0;
dmin1 = 0.f;
dmin2 = 0.f;
dn = 0.f;
dn1 = 0.f;
dn2 = 0.f;
tau = 0.f;
iter = 2;
nfail = 0;
ndiv = n0 - i0 << 1;
i__1 = *n + 1;
for (iwhila = 1; iwhila <= i__1; ++iwhila) {
if (n0 < 1) {
goto L150;
}
/* While array unfinished do */
/* E(N0) holds the value of SIGMA when submatrix in I0:N0 */
/* splits from the rest of the array, but is negated. */
desig = 0.f;
if (n0 == *n) {
sigma = 0.f;
} else {
sigma = -z__[(n0 << 2) - 1];
}
if (sigma < 0.f) {
*info = 1;
return 0;
}
/* Find last unreduced submatrix's top index I0, find QMAX and */
/* EMIN. Find Gershgorin-type bound if Q's much greater than E's. */
emax = 0.f;
if (n0 > i0) {
emin = (r__1 = z__[(n0 << 2) - 5], dabs(r__1));
} else {
emin = 0.f;
}
qmin = z__[(n0 << 2) - 3];
qmax = qmin;
for (i4 = n0 << 2; i4 >= 8; i4 += -4) {
if (z__[i4 - 5] <= 0.f) {
goto L100;
}
if (qmin >= emax * 4.f) {
/* Computing MIN */
r__1 = qmin, r__2 = z__[i4 - 3];
qmin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = emax, r__2 = z__[i4 - 5];
emax = dmax(r__1,r__2);
}
/* Computing MAX */
r__1 = qmax, r__2 = z__[i4 - 7] + z__[i4 - 5];
qmax = dmax(r__1,r__2);
/* Computing MIN */
r__1 = emin, r__2 = z__[i4 - 5];
emin = dmin(r__1,r__2);
/* L90: */
}
i4 = 4;
L100:
i0 = i4 / 4;
/* Store EMIN for passing to SLAZQ3. */
z__[(n0 << 2) - 1] = emin;
/* Put -(initial shift) into DMIN. */
/* Computing MAX */
r__1 = 0.f, r__2 = qmin - sqrt(qmin) * 2.f * sqrt(emax);
dmin__ = -dmax(r__1,r__2);
/* Now I0:N0 is unreduced. PP = 0 for ping, PP = 1 for pong. */
pp = 0;
nbig = (n0 - i0 + 1) * 30;
i__2 = nbig;
for (iwhilb = 1; iwhilb <= i__2; ++iwhilb) {
if (i0 > n0) {
goto L130;
}
/* While submatrix unfinished take a good dqds step. */
slazq3_(&i0, &n0, &z__[1], &pp, &dmin__, &sigma, &desig, &qmax, &
nfail, &iter, &ndiv, &ieee, &ttype, &dmin1, &dmin2, &dn, &
dn1, &dn2, &tau);
pp = 1 - pp;
/* When EMIN is very small check for splits. */
if (pp == 0 && n0 - i0 >= 3) {
if (z__[n0 * 4] <= tol2 * qmax || z__[(n0 << 2) - 1] <= tol2 *
sigma) {
splt = i0 - 1;
qmax = z__[(i0 << 2) - 3];
emin = z__[(i0 << 2) - 1];
oldemn = z__[i0 * 4];
i__3 = n0 - 3 << 2;
for (i4 = i0 << 2; i4 <= i__3; i4 += 4) {
if (z__[i4] <= tol2 * z__[i4 - 3] || z__[i4 - 1] <=
tol2 * sigma) {
z__[i4 - 1] = -sigma;
splt = i4 / 4;
qmax = 0.f;
emin = z__[i4 + 3];
oldemn = z__[i4 + 4];
} else {
/* Computing MAX */
r__1 = qmax, r__2 = z__[i4 + 1];
qmax = dmax(r__1,r__2);
/* Computing MIN */
r__1 = emin, r__2 = z__[i4 - 1];
emin = dmin(r__1,r__2);
/* Computing MIN */
r__1 = oldemn, r__2 = z__[i4];
oldemn = dmin(r__1,r__2);
}
/* L110: */
}
z__[(n0 << 2) - 1] = emin;
z__[n0 * 4] = oldemn;
i0 = splt + 1;
}
}
/* L120: */
}
*info = 2;
return 0;
/* end IWHILB */
L130:
/* L140: */
;
}
*info = 3;
return 0;
/* end IWHILA */
L150:
/* Move q's to the front. */
i__1 = *n;
for (k = 2; k <= i__1; ++k) {
z__[k] = z__[(k << 2) - 3];
/* L160: */
}
/* Sort and compute sum of eigenvalues. */
slasrt_("D", n, &z__[1], &iinfo);
e = 0.f;
for (k = *n; k >= 1; --k) {
e += z__[k];
/* L170: */
}
/* Store trace, sum(eigenvalues) and information on performance. */
z__[(*n << 1) + 1] = trace;
z__[(*n << 1) + 2] = e;
z__[(*n << 1) + 3] = (real) iter;
/* Computing 2nd power */
i__1 = *n;
z__[(*n << 1) + 4] = (real) ndiv / (real) (i__1 * i__1);
z__[(*n << 1) + 5] = nfail * 100.f / (real) iter;
return 0;
/* End of SLASQ2 */
} /* slasq2_ */
/* Subroutine */ int sstemr_(char *jobz, char *range, integer *n, real *d__,
real *e, real *vl, real *vu, integer *il, integer *iu, integer *m,
real *w, real *z__, integer *ldz, integer *nzc, integer *isuppz,
logical *tryrac, real *work, integer *lwork, integer *iwork, integer *
liwork, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j;
real r1, r2;
integer jj;
real cs;
integer in;
real sn, wl, wu;
integer iil, iiu;
real eps, tmp;
integer indd, iend, jblk, wend;
real rmin, rmax;
integer itmp;
real tnrm;
integer inde2;
extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *)
;
integer itmp2;
real rtol1, rtol2, scale;
integer indgp;
extern logical lsame_(char *, char *);
integer iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
integer iindw, ilast, lwmin;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), sswap_(integer *, real *, integer *, real *, integer *
);
logical wantz;
extern /* Subroutine */ int slaev2_(real *, real *, real *, real *, real *
, real *, real *);
logical alleig;
integer ibegin;
logical indeig;
integer iindbl;
logical valeig;
extern doublereal slamch_(char *);
integer wbegin;
real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
real bignum;
integer inderr, iindwk, indgrs, offset;
extern /* Subroutine */ int slarrc_(char *, integer *, real *, real *,
real *, real *, real *, integer *, integer *, integer *, integer *
), slarre_(char *, integer *, real *, real *, integer *,
integer *, real *, real *, real *, real *, real *, real *,
integer *, integer *, integer *, real *, real *, real *, integer *
, integer *, real *, real *, real *, integer *, integer *)
;
real thresh;
integer iinspl, indwrk, ifirst, liwmin, nzcmin;
real pivmin;
extern doublereal slanst_(char *, integer *, real *, real *);
extern /* Subroutine */ int slarrj_(integer *, real *, real *, integer *,
integer *, real *, integer *, real *, real *, real *, integer *,
real *, real *, integer *), slarrr_(integer *, real *, real *,
integer *);
integer nsplit;
extern /* Subroutine */ int slarrv_(integer *, real *, real *, real *,
real *, real *, integer *, integer *, integer *, integer *, real *
, real *, real *, real *, real *, real *, integer *, integer *,
real *, real *, integer *, integer *, real *, integer *, integer *
);
real smlnum;
extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *);
logical lquery, zquery;
/* -- LAPACK computational routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SSTEMR computes selected eigenvalues and, optionally, eigenvectors */
/* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */
/* a well defined set of pairwise different real eigenvalues, the corresponding */
/* real eigenvectors are pairwise orthogonal. */
/* The spectrum may be computed either completely or partially by specifying */
/* either an interval (VL,VU] or a range of indices IL:IU for the desired */
/* eigenvalues. */
/* Depending on the number of desired eigenvalues, these are computed either */
/* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are */
/* computed by the use of various suitable L D L^T factorizations near clusters */
/* of close eigenvalues (referred to as RRRs, Relatively Robust */
/* Representations). An informal sketch of the algorithm follows. */
/* For each unreduced block (submatrix) of T, */
/* (a) Compute T - sigma I = L D L^T, so that L and D */
/* define all the wanted eigenvalues to high relative accuracy. */
/* This means that small relative changes in the entries of D and L */
/* cause only small relative changes in the eigenvalues and */
/* eigenvectors. The standard (unfactored) representation of the */
/* tridiagonal matrix T does not have this property in general. */
/* (b) Compute the eigenvalues to suitable accuracy. */
/* If the eigenvectors are desired, the algorithm attains full */
/* accuracy of the computed eigenvalues only right before */
/* the corresponding vectors have to be computed, see steps c) and d). */
/* (c) For each cluster of close eigenvalues, select a new */
/* shift close to the cluster, find a new factorization, and refine */
/* the shifted eigenvalues to suitable accuracy. */
/* (d) For each eigenvalue with a large enough relative separation compute */
/* the corresponding eigenvector by forming a rank revealing twisted */
/* factorization. Go back to (c) for any clusters that remain. */
/* For more details, see: */
/* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */
/* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */
/* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */
/* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */
/* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */
/* 2004. Also LAPACK Working Note 154. */
/* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */
/* tridiagonal eigenvalue/eigenvector problem", */
/* Computer Science Division Technical Report No. UCB/CSD-97-971, */
/* UC Berkeley, May 1997. */
/* Notes: */
/* 1.SSTEMR works only on machines which follow IEEE-754 */
/* floating-point standard in their handling of infinities and NaNs. */
/* This permits the use of efficient inner loops avoiding a check for */
/* zero divisors. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* RANGE (input) CHARACTER*1 */
/* = 'A': all eigenvalues will be found. */
/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
/* will be found. */
/* = 'I': the IL-th through IU-th eigenvalues will be found. */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* D (input/output) REAL array, dimension (N) */
/* On entry, the N diagonal elements of the tridiagonal matrix */
/* T. On exit, D is overwritten. */
/* E (input/output) REAL array, dimension (N) */
/* On entry, the (N-1) subdiagonal elements of the tridiagonal */
/* matrix T in elements 1 to N-1 of E. E(N) need not be set on */
/* input, but is used internally as workspace. */
/* On exit, E is overwritten. */
/* VL (input) REAL */
/* VU (input) REAL */
/* If RANGE='V', the lower and upper bounds of the interval to */
/* be searched for eigenvalues. VL < VU. */
/* Not referenced if RANGE = 'A' or 'I'. */
/* IL (input) INTEGER */
/* IU (input) INTEGER */
/* If RANGE='I', the indices (in ascending order) of the */
/* smallest and largest eigenvalues to be returned. */
/* 1 <= IL <= IU <= N, if N > 0. */
/* Not referenced if RANGE = 'A' or 'V'. */
/* M (output) INTEGER */
/* The total number of eigenvalues found. 0 <= M <= N. */
/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
/* W (output) REAL array, dimension (N) */
/* The first M elements contain the selected eigenvalues in */
/* ascending order. */
/* Z (output) REAL array, dimension (LDZ, max(1,M) ) */
/* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */
/* contain the orthonormal eigenvectors of the matrix T */
/* corresponding to the selected eigenvalues, with the i-th */
/* column of Z holding the eigenvector associated with W(i). */
/* If JOBZ = 'N', then Z is not referenced. */
/* Note: the user must ensure that at least max(1,M) columns are */
/* supplied in the array Z; if RANGE = 'V', the exact value of M */
/* is not known in advance and can be computed with a workspace */
/* query by setting NZC = -1, see below. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', then LDZ >= max(1,N). */
/* NZC (input) INTEGER */
/* The number of eigenvectors to be held in the array Z. */
/* If RANGE = 'A', then NZC >= max(1,N). */
/* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU]. */
/* If RANGE = 'I', then NZC >= IU-IL+1. */
/* If NZC = -1, then a workspace query is assumed; the */
/* routine calculates the number of columns of the array Z that */
/* are needed to hold the eigenvectors. */
/* This value is returned as the first entry of the Z array, and */
/* no error message related to NZC is issued by XERBLA. */
/* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) ) */
/* The support of the eigenvectors in Z, i.e., the indices */
/* indicating the nonzero elements in Z. The i-th computed eigenvector */
/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */
/* ISUPPZ( 2*i ). This is relevant in the case when the matrix */
/* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */
/* TRYRAC (input/output) LOGICAL */
/* If TRYRAC.EQ..TRUE., indicates that the code should check whether */
/* the tridiagonal matrix defines its eigenvalues to high relative */
/* accuracy. If so, the code uses relative-accuracy preserving */
/* algorithms that might be (a bit) slower depending on the matrix. */
/* If the matrix does not define its eigenvalues to high relative */
/* accuracy, the code can uses possibly faster algorithms. */
/* If TRYRAC.EQ..FALSE., the code is not required to guarantee */
/* relatively accurate eigenvalues and can use the fastest possible */
/* techniques. */
/* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix */
/* does not define its eigenvalues to high relative accuracy. */
/* WORK (workspace/output) REAL array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal */
/* (and minimal) LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,18*N) */
/* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* IWORK (workspace/output) INTEGER array, dimension (LIWORK) */
/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. LIWORK >= max(1,10*N) */
/* if the eigenvectors are desired, and LIWORK >= max(1,8*N) */
/* if only the eigenvalues are to be computed. */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal size of the IWORK array, */
/* returns this value as the first entry of the IWORK array, and */
/* no error message related to LIWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* On exit, INFO */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = 1X, internal error in SLARRE, */
/* if INFO = 2X, internal error in SLARRV. */
/* Here, the digit X = ABS( IINFO ) < 10, where IINFO is */
/* the nonzero error code returned by SLARRE or */
/* SLARRV, respectively. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Beresford Parlett, University of California, Berkeley, USA */
/* Jim Demmel, University of California, Berkeley, USA */
/* Inderjit Dhillon, University of Texas, Austin, USA */
/* Osni Marques, LBNL/NERSC, USA */
/* Christof Voemel, University of California, Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--isuppz;
--work;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
lquery = *lwork == -1 || *liwork == -1;
zquery = *nzc == -1;
*tryrac = *info != 0;
/* SSTEMR needs WORK of size 6*N, IWORK of size 3*N. */
/* In addition, SLARRE needs WORK of size 6*N, IWORK of size 5*N. */
/* Furthermore, SLARRV needs WORK of size 12*N, IWORK of size 7*N. */
if (wantz) {
lwmin = *n * 18;
liwmin = *n * 10;
} else {
/* need less workspace if only the eigenvalues are wanted */
lwmin = *n * 12;
liwmin = *n << 3;
}
wl = 0.f;
wu = 0.f;
iil = 0;
iiu = 0;
if (valeig) {
/* We do not reference VL, VU in the cases RANGE = 'I','A' */
/* The interval (WL, WU] contains all the wanted eigenvalues. */
/* It is either given by the user or computed in SLARRE. */
wl = *vl;
wu = *vu;
} else if (indeig) {
/* We do not reference IL, IU in the cases RANGE = 'V','A' */
iil = *il;
iiu = *iu;
}
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (valeig && *n > 0 && wu <= wl) {
*info = -7;
} else if (indeig && (iil < 1 || iil > *n)) {
*info = -8;
} else if (indeig && (iiu < iil || iiu > *n)) {
*info = -9;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -13;
} else if (*lwork < lwmin && ! lquery) {
*info = -17;
} else if (*liwork < liwmin && ! lquery) {
*info = -19;
}
/* Get machine constants. */
safmin = slamch_("Safe minimum");
eps = slamch_("Precision");
smlnum = safmin / eps;
bignum = 1.f / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
rmax = dmin(r__1,r__2);
if (*info == 0) {
work[1] = (real) lwmin;
iwork[1] = liwmin;
if (wantz && alleig) {
nzcmin = *n;
} else if (wantz && valeig) {
slarrc_("T", n, vl, vu, &d__[1], &e[1], &safmin, &nzcmin, &itmp, &
itmp2, info);
} else if (wantz && indeig) {
nzcmin = iiu - iil + 1;
} else {
/* WANTZ .EQ. FALSE. */
nzcmin = 0;
}
if (zquery && *info == 0) {
z__[z_dim1 + 1] = (real) nzcmin;
} else if (*nzc < nzcmin && ! zquery) {
*info = -14;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSTEMR", &i__1);
return 0;
} else if (lquery || zquery) {
return 0;
}
/* Handle N = 0, 1, and 2 cases immediately */
*m = 0;
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (alleig || indeig) {
*m = 1;
w[1] = d__[1];
} else {
if (wl < d__[1] && wu >= d__[1]) {
*m = 1;
w[1] = d__[1];
}
}
if (wantz && ! zquery) {
z__[z_dim1 + 1] = 1.f;
isuppz[1] = 1;
isuppz[2] = 1;
}
return 0;
}
if (*n == 2) {
if (! wantz) {
slae2_(&d__[1], &e[1], &d__[2], &r1, &r2);
} else if (wantz && ! zquery) {
slaev2_(&d__[1], &e[1], &d__[2], &r1, &r2, &cs, &sn);
}
if (alleig || valeig && r2 > wl && r2 <= wu || indeig && iil == 1) {
++(*m);
w[*m] = r2;
if (wantz && ! zquery) {
z__[*m * z_dim1 + 1] = -sn;
z__[*m * z_dim1 + 2] = cs;
/* Note: At most one of SN and CS can be zero. */
if (sn != 0.f) {
if (cs != 0.f) {
isuppz[(*m << 1) - 1] = 1;
isuppz[(*m << 1) - 1] = 2;
} else {
isuppz[(*m << 1) - 1] = 1;
isuppz[(*m << 1) - 1] = 1;
}
} else {
isuppz[(*m << 1) - 1] = 2;
isuppz[*m * 2] = 2;
}
}
}
if (alleig || valeig && r1 > wl && r1 <= wu || indeig && iiu == 2) {
++(*m);
w[*m] = r1;
if (wantz && ! zquery) {
z__[*m * z_dim1 + 1] = cs;
z__[*m * z_dim1 + 2] = sn;
/* Note: At most one of SN and CS can be zero. */
if (sn != 0.f) {
if (cs != 0.f) {
isuppz[(*m << 1) - 1] = 1;
isuppz[(*m << 1) - 1] = 2;
} else {
isuppz[(*m << 1) - 1] = 1;
isuppz[(*m << 1) - 1] = 1;
}
} else {
isuppz[(*m << 1) - 1] = 2;
isuppz[*m * 2] = 2;
}
}
}
return 0;
}
/* Continue with general N */
indgrs = 1;
inderr = (*n << 1) + 1;
indgp = *n * 3 + 1;
indd = (*n << 2) + 1;
inde2 = *n * 5 + 1;
indwrk = *n * 6 + 1;
iinspl = 1;
iindbl = *n + 1;
iindw = (*n << 1) + 1;
iindwk = *n * 3 + 1;
/* Scale matrix to allowable range, if necessary. */
/* The allowable range is related to the PIVMIN parameter; see the */
/* comments in SLARRD. The preference for scaling small values */
/* up is heuristic; we expect users' matrices not to be close to the */
/* RMAX threshold. */
scale = 1.f;
tnrm = slanst_("M", n, &d__[1], &e[1]);
if (tnrm > 0.f && tnrm < rmin) {
scale = rmin / tnrm;
} else if (tnrm > rmax) {
scale = rmax / tnrm;
}
if (scale != 1.f) {
sscal_(n, &scale, &d__[1], &c__1);
i__1 = *n - 1;
sscal_(&i__1, &scale, &e[1], &c__1);
tnrm *= scale;
if (valeig) {
/* If eigenvalues in interval have to be found, */
/* scale (WL, WU] accordingly */
wl *= scale;
wu *= scale;
}
}
/* Compute the desired eigenvalues of the tridiagonal after splitting */
/* into smaller subblocks if the corresponding off-diagonal elements */
/* are small */
/* THRESH is the splitting parameter for SLARRE */
/* A negative THRESH forces the old splitting criterion based on the */
/* size of the off-diagonal. A positive THRESH switches to splitting */
/* which preserves relative accuracy. */
if (*tryrac) {
/* Test whether the matrix warrants the more expensive relative approach. */
slarrr_(n, &d__[1], &e[1], &iinfo);
} else {
/* The user does not care about relative accurately eigenvalues */
iinfo = -1;
}
/* Set the splitting criterion */
if (iinfo == 0) {
thresh = eps;
} else {
thresh = -eps;
/* relative accuracy is desired but T does not guarantee it */
*tryrac = FALSE_;
}
if (*tryrac) {
/* Copy original diagonal, needed to guarantee relative accuracy */
scopy_(n, &d__[1], &c__1, &work[indd], &c__1);
}
/* Store the squares of the offdiagonal values of T */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/* Computing 2nd power */
r__1 = e[j];
work[inde2 + j - 1] = r__1 * r__1;
/* L5: */
}
/* Set the tolerance parameters for bisection */
if (! wantz) {
/* SLARRE computes the eigenvalues to full precision. */
rtol1 = eps * 4.f;
rtol2 = eps * 4.f;
} else {
/* SLARRE computes the eigenvalues to less than full precision. */
/* SLARRV will refine the eigenvalue approximations, and we can */
/* need less accurate initial bisection in SLARRE. */
/* Note: these settings do only affect the subset case and SLARRE */
/* Computing MAX */
r__1 = sqrt(eps) * .05f, r__2 = eps * 4.f;
rtol1 = dmax(r__1,r__2);
/* Computing MAX */
r__1 = sqrt(eps) * .005f, r__2 = eps * 4.f;
rtol2 = dmax(r__1,r__2);
}
slarre_(range, n, &wl, &wu, &iil, &iiu, &d__[1], &e[1], &work[inde2], &
rtol1, &rtol2, &thresh, &nsplit, &iwork[iinspl], m, &w[1], &work[
inderr], &work[indgp], &iwork[iindbl], &iwork[iindw], &work[
indgrs], &pivmin, &work[indwrk], &iwork[iindwk], &iinfo);
if (iinfo != 0) {
*info = abs(iinfo) + 10;
return 0;
}
/* Note that if RANGE .NE. 'V', SLARRE computes bounds on the desired */
/* part of the spectrum. All desired eigenvalues are contained in */
/* (WL,WU] */
if (wantz) {
/* Compute the desired eigenvectors corresponding to the computed */
/* eigenvalues */
slarrv_(n, &wl, &wu, &d__[1], &e[1], &pivmin, &iwork[iinspl], m, &
c__1, m, &c_b18, &rtol1, &rtol2, &w[1], &work[inderr], &work[
indgp], &iwork[iindbl], &iwork[iindw], &work[indgrs], &z__[
z_offset], ldz, &isuppz[1], &work[indwrk], &iwork[iindwk], &
iinfo);
if (iinfo != 0) {
*info = abs(iinfo) + 20;
return 0;
}
} else {
/* SLARRE computes eigenvalues of the (shifted) root representation */
/* SLARRV returns the eigenvalues of the unshifted matrix. */
/* However, if the eigenvectors are not desired by the user, we need */
/* to apply the corresponding shifts from SLARRE to obtain the */
/* eigenvalues of the original matrix. */
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
itmp = iwork[iindbl + j - 1];
w[j] += e[iwork[iinspl + itmp - 1]];
/* L20: */
}
}
if (*tryrac) {
/* Refine computed eigenvalues so that they are relatively accurate */
/* with respect to the original matrix T. */
ibegin = 1;
wbegin = 1;
i__1 = iwork[iindbl + *m - 1];
for (jblk = 1; jblk <= i__1; ++jblk) {
iend = iwork[iinspl + jblk - 1];
in = iend - ibegin + 1;
wend = wbegin - 1;
/* check if any eigenvalues have to be refined in this block */
L36:
if (wend < *m) {
if (iwork[iindbl + wend] == jblk) {
++wend;
goto L36;
}
}
if (wend < wbegin) {
ibegin = iend + 1;
goto L39;
}
offset = iwork[iindw + wbegin - 1] - 1;
ifirst = iwork[iindw + wbegin - 1];
ilast = iwork[iindw + wend - 1];
rtol2 = eps * 4.f;
slarrj_(&in, &work[indd + ibegin - 1], &work[inde2 + ibegin - 1],
&ifirst, &ilast, &rtol2, &offset, &w[wbegin], &work[
inderr + wbegin - 1], &work[indwrk], &iwork[iindwk], &
pivmin, &tnrm, &iinfo);
ibegin = iend + 1;
wbegin = wend + 1;
L39:
;
}
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (scale != 1.f) {
r__1 = 1.f / scale;
sscal_(m, &r__1, &w[1], &c__1);
}
/* If eigenvalues are not in increasing order, then sort them, */
/* possibly along with eigenvectors. */
if (nsplit > 1) {
if (! wantz) {
slasrt_("I", m, &w[1], &iinfo);
if (iinfo != 0) {
*info = 3;
return 0;
}
} else {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
i__ = 0;
tmp = w[j];
i__2 = *m;
for (jj = j + 1; jj <= i__2; ++jj) {
if (w[jj] < tmp) {
i__ = jj;
tmp = w[jj];
}
/* L50: */
}
if (i__ != 0) {
w[i__] = w[j];
w[j] = tmp;
if (wantz) {
sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j *
z_dim1 + 1], &c__1);
itmp = isuppz[(i__ << 1) - 1];
isuppz[(i__ << 1) - 1] = isuppz[(j << 1) - 1];
isuppz[(j << 1) - 1] = itmp;
itmp = isuppz[i__ * 2];
isuppz[i__ * 2] = isuppz[j * 2];
isuppz[j * 2] = itmp;
}
}
/* L60: */
}
}
}
work[1] = (real) lwmin;
iwork[1] = liwmin;
return 0;
/* End of SSTEMR */
} /* sstemr_ */
/* Subroutine */ int ssterf_(integer *n, real *d, real *e, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SSTERF computes all eigenvalues of a symmetric tridiagonal matrix
using the Pal-Walker-Kahan variant of the QL or QR algorithm.
Arguments
=========
N (input) INTEGER
The order of the matrix. N >= 0.
D (input/output) REAL array, dimension (N)
On entry, the n diagonal elements of the tridiagonal matrix.
On exit, if INFO = 0, the eigenvalues in ascending order.
E (input/output) REAL array, dimension (N-1)
On entry, the (n-1) subdiagonal elements of the tridiagonal
matrix.
On exit, E has been destroyed.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: the algorithm failed to find all of the eigenvalues in
a total of 30*N iterations; if INFO = i, then i
elements of E have not converged to zero.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__0 = 0;
static integer c__1 = 1;
static real c_b32 = 1.f;
/* System generated locals */
integer i__1;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal), r_sign(real *, real *);
/* Local variables */
static real oldc;
static integer lend, jtot;
extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *)
;
static real c;
static integer i, l, m;
static real p, gamma, r, s, alpha, sigma, anorm;
static integer l1, lendm1, lendp1;
static real bb;
extern doublereal slapy2_(real *, real *);
static integer iscale;
static real oldgam;
extern doublereal slamch_(char *);
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real safmax;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
static integer lendsv;
static real ssfmin;
static integer nmaxit;
static real ssfmax;
extern doublereal slanst_(char *, integer *, real *, real *);
extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *);
static integer lm1, mm1, nm1;
static real rt1, rt2, eps, rte;
static integer lsv;
static real tst, eps2;
#define E(I) e[(I)-1]
#define D(I) d[(I)-1]
*info = 0;
/* Quick return if possible */
if (*n < 0) {
*info = -1;
i__1 = -(*info);
xerbla_("SSTERF", &i__1);
return 0;
}
if (*n <= 1) {
return 0;
}
/* Determine the unit roundoff for this environment. */
eps = slamch_("E");
/* Computing 2nd power */
r__1 = eps;
eps2 = r__1 * r__1;
safmin = slamch_("S");
safmax = 1.f / safmin;
ssfmax = sqrt(safmax) / 3.f;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues of the tridiagonal matrix. */
nmaxit = *n * 30;
sigma = 0.f;
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 L170;
}
if (l1 > 1) {
E(l1 - 1) = 0.f;
}
if (l1 <= nm1) {
i__1 = nm1;
for (m = l1; m <= nm1; ++m) {
tst = (r__1 = E(m), dabs(r__1));
if (tst == 0.f) {
goto L30;
}
if (tst <= sqrt((r__1 = D(m), dabs(r__1))) * sqrt((r__2 = D(m + 1)
, dabs(r__2))) * eps) {
E(m) = 0.f;
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 = slanst_("I", &i__1, &D(l), &E(l));
iscale = 0;
if (anorm > ssfmax) {
iscale = 1;
i__1 = lend - l + 1;
slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &D(l), n,
info);
i__1 = lend - l;
slascl_("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;
slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &D(l), n,
info);
i__1 = lend - l;
slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &E(l), n,
info);
}
i__1 = lend - 1;
for (i = l; i <= lend-1; ++i) {
/* Computing 2nd power */
r__1 = E(i);
E(i) = r__1 * r__1;
/* L40: */
}
/* Choose between QL and QR iteration */
if ((r__1 = D(lend), dabs(r__1)) < (r__2 = D(l), dabs(r__2))) {
lend = lsv;
l = lendsv;
}
if (lend >= l) {
/* QL Iteration
Look for small subdiagonal element. */
L50:
if (l != lend) {
lendm1 = lend - 1;
i__1 = lendm1;
for (m = l; m <= lendm1; ++m) {
tst = (r__1 = E(m), dabs(r__1));
if (tst <= eps2 * (r__1 = D(m) * D(m + 1), dabs(r__1))) {
goto L70;
}
/* L60: */
}
}
m = lend;
L70:
if (m < lend) {
E(m) = 0.f;
}
p = D(l);
if (m == l) {
goto L90;
}
/* If remaining matrix is 2 by 2, use SLAE2 to compute its
eigenvalues. */
if (m == l + 1) {
rte = sqrt(E(l));
slae2_(&D(l), &rte, &D(l + 1), &rt1, &rt2);
D(l) = rt1;
D(l + 1) = rt2;
E(l) = 0.f;
l += 2;
if (l <= lend) {
goto L50;
}
goto L150;
}
if (jtot == nmaxit) {
goto L150;
}
++jtot;
/* Form shift. */
rte = sqrt(E(l));
sigma = (D(l + 1) - p) / (rte * 2.f);
r = slapy2_(&sigma, &c_b32);
sigma = p - rte / (sigma + r_sign(&r, &sigma));
c = 1.f;
s = 0.f;
gamma = D(m) - sigma;
p = gamma * gamma;
/* Inner loop */
mm1 = m - 1;
i__1 = l;
for (i = mm1; i >= l; --i) {
bb = E(i);
r = p + bb;
if (i != m - 1) {
E(i + 1) = s * r;
}
oldc = c;
c = p / r;
s = bb / r;
oldgam = gamma;
alpha = D(i);
gamma = c * (alpha - sigma) - s * oldgam;
D(i + 1) = oldgam + (alpha - gamma);
if (c != 0.f) {
p = gamma * gamma / c;
} else {
p = oldc * bb;
}
/* L80: */
}
E(l) = s * p;
D(l) = sigma + gamma;
goto L50;
/* Eigenvalue found. */
L90:
D(l) = p;
++l;
if (l <= lend) {
goto L50;
}
goto L150;
} else {
/* QR Iteration
Look for small superdiagonal element. */
L100:
if (l != lend) {
lendp1 = lend + 1;
i__1 = lendp1;
for (m = l; m >= lendp1; --m) {
tst = (r__1 = E(m - 1), dabs(r__1));
if (tst <= eps2 * (r__1 = D(m) * D(m - 1), dabs(r__1))) {
goto L120;
}
/* L110: */
}
}
m = lend;
L120:
if (m > lend) {
E(m - 1) = 0.f;
}
p = D(l);
if (m == l) {
goto L140;
}
/* If remaining matrix is 2 by 2, use SLAE2 to compute its
eigenvalues. */
if (m == l - 1) {
rte = sqrt(E(l - 1));
slae2_(&D(l), &rte, &D(l - 1), &rt1, &rt2);
D(l) = rt1;
D(l - 1) = rt2;
E(l - 1) = 0.f;
l += -2;
if (l >= lend) {
goto L100;
}
goto L150;
}
if (jtot == nmaxit) {
goto L150;
}
++jtot;
/* Form shift. */
rte = sqrt(E(l - 1));
sigma = (D(l - 1) - p) / (rte * 2.f);
r = slapy2_(&sigma, &c_b32);
sigma = p - rte / (sigma + r_sign(&r, &sigma));
c = 1.f;
s = 0.f;
gamma = D(m) - sigma;
p = gamma * gamma;
/* Inner loop */
lm1 = l - 1;
i__1 = lm1;
for (i = m; i <= lm1; ++i) {
bb = E(i);
r = p + bb;
if (i != m) {
E(i - 1) = s * r;
}
oldc = c;
c = p / r;
s = bb / r;
oldgam = gamma;
alpha = D(i + 1);
gamma = c * (alpha - sigma) - s * oldgam;
D(i) = oldgam + (alpha - gamma);
if (c != 0.f) {
p = gamma * gamma / c;
} else {
p = oldc * bb;
}
/* L130: */
}
E(lm1) = s * p;
D(l) = sigma + gamma;
goto L100;
/* Eigenvalue found. */
L140:
D(l) = p;
--l;
if (l >= lend) {
goto L100;
}
goto L150;
}
/* Undo scaling if necessary */
L150:
if (iscale == 1) {
i__1 = lendsv - lsv + 1;
slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &D(lsv), n,
info);
}
if (iscale == 2) {
i__1 = lendsv - lsv + 1;
slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &D(lsv), n,
info);
}
/* Check for no convergence to an eigenvalue after a total
of N*MAXIT iterations. */
if (jtot == nmaxit) {
i__1 = *n - 1;
for (i = 1; i <= *n-1; ++i) {
if (E(i) != 0.f) {
++(*info);
}
/* L160: */
}
return 0;
}
goto L10;
/* Sort eigenvalues in increasing order. */
L170:
slasrt_("I", n, &D(1), info);
return 0;
/* End of SSTERF */
} /* ssterf_ */
/* Subroutine */ int sstedc_(char *compz, integer *n, real *d__, real *e,
real *z__, integer *ldz, real *work, integer *lwork, integer *iwork,
integer *liwork, integer *info)
{
/* -- LAPACK driver 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
=======
SSTEDC computes all eigenvalues and, optionally, eigenvectors of a
symmetric tridiagonal matrix using the divide and conquer method.
The eigenvectors of a full or band real symmetric matrix can also be
found if SSYTRD or SSPTRD or SSBTRD has been used to reduce this
matrix to tridiagonal 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 SLAED3 for details.
Arguments
=========
COMPZ (input) CHARACTER*1
= 'N': Compute eigenvalues only.
= 'I': Compute eigenvectors of tridiagonal matrix also.
= 'V': Compute eigenvectors of original dense symmetric
matrix also. On entry, Z contains the orthogonal
matrix used to reduce the original matrix to
tridiagonal form.
N (input) INTEGER
The dimension of the symmetric tridiagonal matrix. N >= 0.
D (input/output) REAL 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) REAL array, dimension (N-1)
On entry, the subdiagonal elements of the tridiagonal matrix.
On exit, E has been destroyed.
Z (input/output) REAL 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.
If eigenvectors are desired, then LDZ >= max(1,N).
WORK (workspace/output) REAL array,
dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK.
If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.
If COMPZ = 'V' and N > 1 then LWORK must be at least
( 1 + 3*N + 2*N*lg N + 3*N**2 ),
where lg( N ) = smallest integer k such
that 2**k >= N.
If COMPZ = 'I' and N > 1 then LWORK must be at least
( 1 + 4*N + N**2 ).
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
IWORK (workspace/output) INTEGER array, dimension (LIWORK)
On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
LIWORK (input) INTEGER
The dimension of the array IWORK.
If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.
If COMPZ = 'V' and N > 1 then LIWORK must be at least
( 6 + 6*N + 5*N*lg N ).
If COMPZ = 'I' and N > 1 then LIWORK must be at least
( 3 + 5*N ).
If LIWORK = -1, then a workspace query is assumed; the
routine only calculates the optimal size of the IWORK array,
returns this value as the first entry of the IWORK array, and
no error message related to LIWORK is issued by XERBLA.
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 eigenvalue while
working on the submatrix lying in rows and columns
INFO/(N+1) through mod(INFO,N+1).
Further Details
===============
Based on contributions by
Jeff Rutter, Computer Science Division, University of California
at Berkeley, USA
Modified by Francoise Tisseur, University of Tennessee.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__2 = 2;
static integer c__9 = 9;
static integer c__0 = 0;
static real c_b18 = 0.f;
static real c_b19 = 1.f;
static integer c__1 = 1;
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double log(doublereal);
integer pow_ii(integer *, integer *);
double sqrt(doublereal);
/* Local variables */
static real tiny;
static integer i__, j, k, m;
static real p;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
static integer lwmin, start;
extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
integer *), slaed0_(integer *, integer *, integer *, real *, real
*, real *, integer *, real *, integer *, real *, integer *,
integer *);
static integer ii;
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *,
real *, integer *), slaset_(char *, integer *, integer *,
real *, real *, real *, integer *);
static integer liwmin, icompz;
static real orgnrm;
extern doublereal slanst_(char *, integer *, real *, real *);
extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *),
slasrt_(char *, integer *, real *, integer *);
static logical lquery;
static integer smlsiz;
extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *,
real *, integer *, real *, integer *);
static integer storez, strtrw, end, lgn;
static real eps;
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1 || *liwork == -1;
if (lsame_(compz, "N")) {
icompz = 0;
} else if (lsame_(compz, "V")) {
icompz = 1;
} else if (lsame_(compz, "I")) {
icompz = 2;
} else {
icompz = -1;
}
if (*n <= 1 || icompz <= 0) {
liwmin = 1;
lwmin = 1;
} else {
lgn = (integer) (log((real) (*n)) / log(2.f));
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (icompz == 1) {
/* Computing 2nd power */
i__1 = *n;
lwmin = *n * 3 + 1 + (*n << 1) * lgn + i__1 * i__1 * 3;
liwmin = *n * 6 + 6 + *n * 5 * lgn;
} else if (icompz == 2) {
/* Computing 2nd power */
i__1 = *n;
lwmin = (*n << 2) + 1 + i__1 * i__1;
liwmin = *n * 5 + 3;
}
}
if (icompz < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
*info = -6;
} else if (*lwork < lwmin && ! lquery) {
*info = -8;
} else if (*liwork < liwmin && ! lquery) {
*info = -10;
}
if (*info == 0) {
work[1] = (real) lwmin;
iwork[1] = liwmin;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSTEDC", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz != 0) {
z___ref(1, 1) = 1.f;
}
return 0;
}
smlsiz = ilaenv_(&c__9, "SSTEDC", " ", &c__0, &c__0, &c__0, &c__0, (
ftnlen)6, (ftnlen)1);
/* If the following conditional clause is removed, then the routine
will use the Divide and Conquer routine to compute only the
eigenvalues, which requires (3N + 3N**2) real workspace and
(2 + 5N + 2N lg(N)) integer workspace.
Since on many architectures SSTERF is much faster than any other
algorithm for finding eigenvalues only, it is used here
as the default.
If COMPZ = 'N', use SSTERF to compute the eigenvalues. */
if (icompz == 0) {
ssterf_(n, &d__[1], &e[1], info);
return 0;
}
/* If N is smaller than the minimum divide size (SMLSIZ+1), then
solve the problem with another solver. */
if (*n <= smlsiz) {
if (icompz == 0) {
ssterf_(n, &d__[1], &e[1], info);
return 0;
} else if (icompz == 2) {
ssteqr_("I", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1],
info);
return 0;
} else {
ssteqr_("V", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1],
info);
return 0;
}
}
/* If COMPZ = 'V', the Z matrix must be stored elsewhere for later
use. */
if (icompz == 1) {
storez = *n * *n + 1;
} else {
storez = 1;
}
if (icompz == 2) {
slaset_("Full", n, n, &c_b18, &c_b19, &z__[z_offset], ldz);
}
/* Scale. */
orgnrm = slanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.f) {
return 0;
}
eps = slamch_("Epsilon");
start = 1;
/* while ( START <= N ) */
L10:
if (start <= *n) {
/* Let END be the position of the next subdiagonal entry such that
E( END ) <= TINY or END = N if no such subdiagonal exists. The
matrix identified by the elements between START and END
constitutes an independent sub-problem. */
end = start;
L20:
if (end < *n) {
tiny = eps * sqrt((r__1 = d__[end], dabs(r__1))) * sqrt((r__2 =
d__[end + 1], dabs(r__2)));
if ((r__1 = e[end], dabs(r__1)) > tiny) {
++end;
goto L20;
}
}
/* (Sub) Problem determined. Compute its size and solve it. */
m = end - start + 1;
if (m == 1) {
start = end + 1;
goto L10;
}
if (m > smlsiz) {
*info = smlsiz;
/* Scale. */
orgnrm = slanst_("M", &m, &d__[start], &e[start]);
slascl_("G", &c__0, &c__0, &orgnrm, &c_b19, &m, &c__1, &d__[start]
, &m, info);
i__1 = m - 1;
i__2 = m - 1;
slascl_("G", &c__0, &c__0, &orgnrm, &c_b19, &i__1, &c__1, &e[
start], &i__2, info);
if (icompz == 1) {
strtrw = 1;
} else {
strtrw = start;
}
slaed0_(&icompz, n, &m, &d__[start], &e[start], &z___ref(strtrw,
start), ldz, &work[1], n, &work[storez], &iwork[1], info);
if (*info != 0) {
*info = (*info / (m + 1) + start - 1) * (*n + 1) + *info % (m
+ 1) + start - 1;
return 0;
}
/* Scale back. */
slascl_("G", &c__0, &c__0, &c_b19, &orgnrm, &m, &c__1, &d__[start]
, &m, info);
} else {
if (icompz == 1) {
/* Since QR won't update a Z matrix which is larger than the
length of D, we must solve the sub-problem in a workspace and
then multiply back into Z. */
ssteqr_("I", &m, &d__[start], &e[start], &work[1], &m, &work[
m * m + 1], info);
slacpy_("A", n, &m, &z___ref(1, start), ldz, &work[storez], n);
sgemm_("N", "N", n, &m, &m, &c_b19, &work[storez], ldz, &work[
1], &m, &c_b18, &z___ref(1, start), ldz);
} else if (icompz == 2) {
ssteqr_("I", &m, &d__[start], &e[start], &z___ref(start,
start), ldz, &work[1], info);
} else {
ssterf_(&m, &d__[start], &e[start], info);
}
if (*info != 0) {
*info = start * (*n + 1) + end;
return 0;
}
}
start = end + 1;
goto L10;
}
/* endwhile
If the problem split any number of times, then the eigenvalues
will not be properly ordered. Here we permute the eigenvalues
(and the associated eigenvectors) into ascending order. */
if (m != *n) {
if (icompz == 0) {
/* Use Quick Sort */
slasrt_("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];
}
/* L30: */
}
if (k != i__) {
d__[k] = d__[i__];
d__[i__] = p;
sswap_(n, &z___ref(1, i__), &c__1, &z___ref(1, k), &c__1);
}
/* L40: */
}
}
}
work[1] = (real) lwmin;
iwork[1] = liwmin;
return 0;
/* End of SSTEDC */
} /* sstedc_ */
/* Subroutine */ int ssteqr_(char *compz, int *n, real *d, real *e, real *
z, int *ldz, real *work, int *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SSTEQR 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 SSYTRD or SSPTRD or SSBTRD 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) REAL 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) REAL array, dimension (N-1)
On entry, the (n-1) subdiagonal elements of the tridiagonal
matrix.
On exit, E has been destroyed.
Z (input/output) REAL 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) REAL 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.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static real c_b9 = 0.f;
static real c_b10 = 1.f;
static int c__0 = 0;
static int c__1 = 1;
static int c__2 = 2;
/* System generated locals */
/* Unused variables commented out by MDG on 03-09-05
int z_dim1, z_offset;
*/
int i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal), r_sign(real *, real *);
/* Local variables */
static int lend, jtot;
extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *)
;
static real b, c, f, g;
static int i, j, k, l, m;
static real p, r, s;
extern logical lsame_(char *, char *);
static real anorm;
extern /* Subroutine */ int slasr_(char *, char *, char *, int *,
int *, real *, real *, real *, int *);
static int l1;
extern /* Subroutine */ int sswap_(int *, real *, int *, real *,
int *);
static int lendm1, lendp1;
extern /* Subroutine */ int slaev2_(real *, real *, real *, real *, real *
, real *, real *);
extern doublereal slapy2_(real *, real *);
static int ii, mm, iscale;
extern doublereal slamch_(char *);
static real safmin;
extern /* Subroutine */ int xerbla_(char *, int *);
static real safmax;
extern /* Subroutine */ int slascl_(char *, int *, int *, real *,
real *, int *, int *, real *, int *, int *);
static int lendsv;
extern /* Subroutine */ int slartg_(real *, real *, real *, real *, real *
), slaset_(char *, int *, int *, real *, real *, real *,
int *);
static real ssfmin;
static int nmaxit, icompz;
static real ssfmax;
extern doublereal slanst_(char *, int *, real *, real *);
extern /* Subroutine */ int slasrt_(char *, int *, real *, int *);
static int lm1, mm1, nm1;
static real rt1, rt2, eps;
static int lsv;
static real tst, eps2;
#define D(I) d[(I)-1]
#define E(I) e[(I)-1]
#define WORK(I) work[(I)-1]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)]
*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)) {
*/
/* Paretheses added by MDG on 03-09-05 */
} else if ((*ldz < 1 || icompz > 0) && (*ldz < max(1,*n))) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSTEQR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz == 2) {
Z(1,1) = 1.f;
}
return 0;
}
/* Determine the unit roundoff and over/underflow thresholds. */
eps = slamch_("E");
/* Computing 2nd power */
r__1 = eps;
eps2 = r__1 * r__1;
safmin = slamch_("S");
safmax = 1.f / safmin;
ssfmax = sqrt(safmax) / 3.f;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues and eigenvectors of the tridiagonal
matrix. */
if (icompz == 2) {
slaset_("Full", n, n, &c_b9, &c_b10, &Z(1,1), 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.f;
}
if (l1 <= nm1) {
i__1 = nm1;
for (m = l1; m <= nm1; ++m) {
tst = (r__1 = E(m), dabs(r__1));
if (tst == 0.f) {
goto L30;
}
if (tst <= sqrt((r__1 = D(m), dabs(r__1))) * sqrt((r__2 = D(m + 1)
, dabs(r__2))) * eps) {
E(m) = 0.f;
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 = slanst_("I", &i__1, &D(l), &E(l));
iscale = 0;
if (anorm == 0.f) {
goto L10;
}
if (anorm > ssfmax) {
iscale = 1;
i__1 = lend - l + 1;
slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &D(l), n,
info);
i__1 = lend - l;
slascl_("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;
slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &D(l), n,
info);
i__1 = lend - l;
slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &E(l), n,
info);
}
/* Choose between QL and QR iteration */
if ((r__1 = D(lend), dabs(r__1)) < (r__2 = D(l), dabs(r__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 <= lendm1; ++m) {
/* Computing 2nd power */
r__2 = (r__1 = E(m), dabs(r__1));
tst = r__2 * r__2;
if (tst <= eps2 * (r__1 = D(m), dabs(r__1)) * (r__2 = D(m + 1)
, dabs(r__2)) + safmin) {
goto L60;
}
/* L50: */
}
}
m = lend;
L60:
if (m < lend) {
E(m) = 0.f;
}
p = D(l);
if (m == l) {
goto L80;
}
/* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2
to compute its eigensystem. */
if (m == l + 1) {
if (icompz > 0) {
slaev2_(&D(l), &E(l), &D(l + 1), &rt1, &rt2, &c, &s);
WORK(l) = c;
WORK(*n - 1 + l) = s;
slasr_("R", "V", "B", n, &c__2, &WORK(l), &WORK(*n - 1 + l), &
Z(1,l), ldz);
} else {
slae2_(&D(l), &E(l), &D(l + 1), &rt1, &rt2);
}
D(l) = rt1;
D(l + 1) = rt2;
E(l) = 0.f;
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.f);
r = slapy2_(&g, &c_b10);
g = D(m) - p + E(l) / (g + r_sign(&r, &g));
s = 1.f;
c = 1.f;
p = 0.f;
/* Inner loop */
mm1 = m - 1;
i__1 = l;
for (i = mm1; i >= l; --i) {
f = s * E(i);
b = c * E(i);
slartg_(&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.f * 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) = -(doublereal)s;
}
/* L70: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = m - l + 1;
slasr_("R", "V", "B", n, &mm, &WORK(l), &WORK(*n - 1 + l), &Z(1,l), 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 >= lendp1; --m) {
/* Computing 2nd power */
r__2 = (r__1 = E(m - 1), dabs(r__1));
tst = r__2 * r__2;
if (tst <= eps2 * (r__1 = D(m), dabs(r__1)) * (r__2 = D(m - 1)
, dabs(r__2)) + safmin) {
goto L110;
}
/* L100: */
}
}
m = lend;
L110:
if (m > lend) {
E(m - 1) = 0.f;
}
p = D(l);
if (m == l) {
goto L130;
}
/* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2
to compute its eigensystem. */
if (m == l - 1) {
if (icompz > 0) {
slaev2_(&D(l - 1), &E(l - 1), &D(l), &rt1, &rt2, &c, &s);
WORK(m) = c;
WORK(*n - 1 + m) = s;
slasr_("R", "V", "F", n, &c__2, &WORK(m), &WORK(*n - 1 + m), &
Z(1,l-1), ldz);
} else {
slae2_(&D(l - 1), &E(l - 1), &D(l), &rt1, &rt2);
}
D(l - 1) = rt1;
D(l) = rt2;
E(l - 1) = 0.f;
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.f);
r = slapy2_(&g, &c_b10);
g = D(m) - p + E(l - 1) / (g + r_sign(&r, &g));
s = 1.f;
c = 1.f;
p = 0.f;
/* Inner loop */
lm1 = l - 1;
i__1 = lm1;
for (i = m; i <= lm1; ++i) {
f = s * E(i);
b = c * E(i);
slartg_(&g, &f, &c, &s, &r);
if (i != m) {
E(i - 1) = r;
}
g = D(i) - p;
r = (D(i + 1) - g) * s + c * 2.f * 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;
slasr_("R", "V", "F", n, &mm, &WORK(m), &WORK(*n - 1 + m), &Z(1,m), 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;
slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &D(lsv), n,
info);
i__1 = lendsv - lsv;
slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &E(lsv), n,
info);
} else if (iscale == 2) {
i__1 = lendsv - lsv + 1;
slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &D(lsv), n,
info);
i__1 = lendsv - lsv;
slascl_("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 <= *n-1; ++i) {
if (E(i) != 0.f) {
++(*info);
}
/* L150: */
}
goto L190;
/* Order eigenvalues and eigenvectors. */
L160:
if (icompz == 0) {
/* Use Quick Sort */
slasrt_("I", n, &D(1), info);
} else {
/* Use Selection Sort to minimize swaps of eigenvectors */
i__1 = *n;
for (ii = 2; ii <= *n; ++ii) {
i = ii - 1;
k = i;
p = D(i);
i__2 = *n;
for (j = ii; j <= *n; ++j) {
if (D(j) < p) {
k = j;
p = D(j);
}
/* L170: */
}
if (k != i) {
D(k) = D(i);
D(i) = p;
sswap_(n, &Z(1,i), &c__1, &Z(1,k), &
c__1);
}
/* L180: */
}
}
L190:
return 0;
/* End of SSTEQR */
} /* ssteqr_ */
/* Subroutine */ int clalsd_(char *uplo, integer *smlsiz, integer *n, integer
*nrhs, real *d__, real *e, complex *b, integer *ldb, real *rcond,
integer *rank, complex *work, real *rwork, integer *iwork, integer *
info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6;
real r__1;
complex q__1;
/* Builtin functions */
double r_imag(complex *), log(doublereal), r_sign(real *, real *);
/* Local variables */
integer c__, i__, j, k;
real r__;
integer s, u, z__;
real cs;
integer bx;
real sn;
integer st, vt, nm1, st1;
real eps;
integer iwk;
real tol;
integer difl, difr;
real rcnd;
integer jcol, irwb, perm, nsub, nlvl, sqre, bxst, jrow, irwu, jimag,
jreal;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
integer irwib;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
integer poles, sizei, irwrb, nsize;
extern /* Subroutine */ int csrot_(integer *, complex *, integer *,
complex *, integer *, real *, real *);
integer irwvt, icmpq1, icmpq2;
extern /* Subroutine */ int clalsa_(integer *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, real *,
integer *, real *, integer *, real *, real *, real *, real *,
integer *, integer *, integer *, integer *, real *, real *, real *
, real *, integer *, integer *), clascl_(char *, integer *,
integer *, real *, real *, integer *, integer *, complex *,
integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int slasda_(integer *, integer *, integer *,
integer *, real *, real *, real *, integer *, real *, integer *,
real *, real *, real *, real *, integer *, integer *, integer *,
integer *, real *, real *, real *, real *, integer *, integer *),
clacpy_(char *, integer *, integer *, complex *, integer *,
complex *, integer *), claset_(char *, integer *, integer
*, complex *, complex *, complex *, integer *), xerbla_(
char *, integer *), slascl_(char *, integer *, integer *,
real *, real *, integer *, integer *, real *, integer *, integer *
);
extern integer isamax_(integer *, real *, integer *);
integer givcol;
extern /* Subroutine */ int slasdq_(char *, integer *, integer *, integer
*, integer *, integer *, real *, real *, real *, integer *, real *
, integer *, real *, integer *, real *, integer *),
slaset_(char *, integer *, integer *, real *, real *, real *,
integer *), slartg_(real *, real *, real *, real *, real *
);
real orgnrm;
integer givnum;
extern doublereal slanst_(char *, integer *, real *, real *);
extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *);
integer givptr, nrwork, irwwrk, smlszp;
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLALSD 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) REAL 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/output) REAL array, dimension (N-1) */
/* Contains the super-diagonal entries of the bidiagonal matrix. */
/* On exit, E has been destroyed. */
/* B (input/output) COMPLEX 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) REAL */
/* 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) COMPLEX array, dimension (N * NRHS). */
/* RWORK (workspace) REAL array, dimension at least */
/* (9*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS + (SMLSIZ+1)**2), */
/* where */
/* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) */
/* IWORK (workspace) INTEGER array, dimension (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 */
/* ===================================================================== */
/* .. 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;
--rwork;
--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_("CLALSD", &i__1);
return 0;
}
eps = slamch_("Epsilon");
/* Set up the tolerance. */
if (*rcond <= 0.f || *rcond >= 1.f) {
rcnd = eps;
} else {
rcnd = *rcond;
}
*rank = 0;
/* Quick return if possible. */
if (*n == 0) {
return 0;
} else if (*n == 1) {
if (d__[1] == 0.f) {
claset_("A", &c__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
} else {
*rank = 1;
clascl_("G", &c__0, &c__0, &d__[1], &c_b10, &c__1, nrhs, &b[
b_offset], ldb, info);
d__[1] = dabs(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__) {
slartg_(&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) {
csrot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], &
c__1, &cs, &sn);
} else {
rwork[(i__ << 1) - 1] = cs;
rwork[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 = rwork[(j << 1) - 1];
sn = rwork[j * 2];
csrot_(&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 = slanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.f) {
claset_("A", n, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
return 0;
}
slascl_("G", &c__0, &c__0, &orgnrm, &c_b10, n, &c__1, &d__[1], n, info);
slascl_("G", &c__0, &c__0, &orgnrm, &c_b10, &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) {
irwu = 1;
irwvt = irwu + *n * *n;
irwwrk = irwvt + *n * *n;
irwrb = irwwrk;
irwib = irwrb + *n * *nrhs;
irwb = irwib + *n * *nrhs;
slaset_("A", n, n, &c_b35, &c_b10, &rwork[irwu], n);
slaset_("A", n, n, &c_b35, &c_b10, &rwork[irwvt], n);
slasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &rwork[irwvt], n,
&rwork[irwu], n, &rwork[irwwrk], &c__1, &rwork[irwwrk], info);
if (*info != 0) {
return 0;
}
/* In the real version, B is passed to SLASDQ and multiplied */
/* internally by Q'. Here B is complex and that product is */
/* computed below in two steps (real and imaginary parts). */
j = irwb - 1;
i__1 = *nrhs;
for (jcol = 1; jcol <= i__1; ++jcol) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
++j;
i__3 = jrow + jcol * b_dim1;
rwork[j] = b[i__3].r;
/* L40: */
}
/* L50: */
}
sgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwu], n, &rwork[irwb], n,
&c_b35, &rwork[irwrb], n);
j = irwb - 1;
i__1 = *nrhs;
for (jcol = 1; jcol <= i__1; ++jcol) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
++j;
rwork[j] = r_imag(&b[jrow + jcol * b_dim1]);
/* L60: */
}
/* L70: */
}
sgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwu], n, &rwork[irwb], n,
&c_b35, &rwork[irwib], n);
jreal = irwrb - 1;
jimag = irwib - 1;
i__1 = *nrhs;
for (jcol = 1; jcol <= i__1; ++jcol) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
++jreal;
++jimag;
i__3 = jrow + jcol * b_dim1;
i__4 = jreal;
i__5 = jimag;
q__1.r = rwork[i__4], q__1.i = rwork[i__5];
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L80: */
}
/* L90: */
}
tol = rcnd * (r__1 = d__[isamax_(n, &d__[1], &c__1)], dabs(r__1));
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] <= tol) {
claset_("A", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1], ldb);
} else {
clascl_("G", &c__0, &c__0, &d__[i__], &c_b10, &c__1, nrhs, &b[
i__ + b_dim1], ldb, info);
++(*rank);
}
/* L100: */
}
/* Since B is complex, the following call to SGEMM is performed */
/* in two steps (real and imaginary parts). That is for V * B */
/* (in the real version of the code V' is stored in WORK). */
/* CALL SGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO, */
/* $ WORK( NWORK ), N ) */
j = irwb - 1;
i__1 = *nrhs;
for (jcol = 1; jcol <= i__1; ++jcol) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
++j;
i__3 = jrow + jcol * b_dim1;
rwork[j] = b[i__3].r;
/* L110: */
}
/* L120: */
}
sgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwvt], n, &rwork[irwb],
n, &c_b35, &rwork[irwrb], n);
j = irwb - 1;
i__1 = *nrhs;
for (jcol = 1; jcol <= i__1; ++jcol) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
++j;
rwork[j] = r_imag(&b[jrow + jcol * b_dim1]);
/* L130: */
}
/* L140: */
}
sgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwvt], n, &rwork[irwb],
n, &c_b35, &rwork[irwib], n);
jreal = irwrb - 1;
jimag = irwib - 1;
i__1 = *nrhs;
for (jcol = 1; jcol <= i__1; ++jcol) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
++jreal;
++jimag;
i__3 = jrow + jcol * b_dim1;
i__4 = jreal;
i__5 = jimag;
q__1.r = rwork[i__4], q__1.i = rwork[i__5];
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L150: */
}
/* L160: */
}
/* Unscale. */
slascl_("G", &c__0, &c__0, &c_b10, &orgnrm, n, &c__1, &d__[1], n,
info);
slasrt_("D", n, &d__[1], info);
clascl_("G", &c__0, &c__0, &orgnrm, &c_b10, n, nrhs, &b[b_offset],
ldb, info);
return 0;
}
/* Book-keeping and setting up some constants. */
nlvl = (integer) (log((real) (*n) / (real) (*smlsiz + 1)) / log(2.f)) + 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;
nrwork = givnum + (nlvl << 1) * *n;
bx = 1;
irwrb = nrwork;
irwib = irwrb + *smlsiz * *nrhs;
irwb = irwib + *smlsiz * *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 ((r__1 = d__[i__], dabs(r__1)) < eps) {
d__[i__] = r_sign(&eps, &d__[i__]);
}
/* L170: */
}
i__1 = nm1;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((r__1 = e[i__], dabs(r__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 ((r__1 = e[i__], dabs(r__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;
ccopy_(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. */
ccopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n);
} else if (nsize <= *smlsiz) {
/* This is a small subproblem and is solved by SLASDQ. */
slaset_("A", &nsize, &nsize, &c_b35, &c_b10, &rwork[vt + st1],
n);
slaset_("A", &nsize, &nsize, &c_b35, &c_b10, &rwork[u + st1],
n);
slasdq_("U", &c__0, &nsize, &nsize, &nsize, &c__0, &d__[st], &
e[st], &rwork[vt + st1], n, &rwork[u + st1], n, &
rwork[nrwork], &c__1, &rwork[nrwork], info)
;
if (*info != 0) {
return 0;
}
/* In the real version, B is passed to SLASDQ and multiplied */
/* internally by Q'. Here B is complex and that product is */
/* computed below in two steps (real and imaginary parts). */
j = irwb - 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = st + nsize - 1;
for (jrow = st; jrow <= i__3; ++jrow) {
++j;
i__4 = jrow + jcol * b_dim1;
rwork[j] = b[i__4].r;
/* L180: */
}
/* L190: */
}
sgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[u + st1]
, n, &rwork[irwb], &nsize, &c_b35, &rwork[irwrb], &
nsize);
j = irwb - 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = st + nsize - 1;
for (jrow = st; jrow <= i__3; ++jrow) {
++j;
rwork[j] = r_imag(&b[jrow + jcol * b_dim1]);
/* L200: */
}
/* L210: */
}
sgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[u + st1]
, n, &rwork[irwb], &nsize, &c_b35, &rwork[irwib], &
nsize);
jreal = irwrb - 1;
jimag = irwib - 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = st + nsize - 1;
for (jrow = st; jrow <= i__3; ++jrow) {
++jreal;
++jimag;
i__4 = jrow + jcol * b_dim1;
i__5 = jreal;
i__6 = jimag;
q__1.r = rwork[i__5], q__1.i = rwork[i__6];
b[i__4].r = q__1.r, b[i__4].i = q__1.i;
/* L220: */
}
/* L230: */
}
clacpy_("A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx +
st1], n);
} else {
/* A large problem. Solve it using divide and conquer. */
slasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], &
rwork[u + st1], n, &rwork[vt + st1], &iwork[k + st1],
&rwork[difl + st1], &rwork[difr + st1], &rwork[z__ +
st1], &rwork[poles + st1], &iwork[givptr + st1], &
iwork[givcol + st1], n, &iwork[perm + st1], &rwork[
givnum + st1], &rwork[c__ + st1], &rwork[s + st1], &
rwork[nrwork], &iwork[iwk], info);
if (*info != 0) {
return 0;
}
bxst = bx + st1;
clalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, &
work[bxst], n, &rwork[u + st1], n, &rwork[vt + st1], &
iwork[k + st1], &rwork[difl + st1], &rwork[difr + st1]
, &rwork[z__ + st1], &rwork[poles + st1], &iwork[
givptr + st1], &iwork[givcol + st1], n, &iwork[perm +
st1], &rwork[givnum + st1], &rwork[c__ + st1], &rwork[
s + st1], &rwork[nrwork], &iwork[iwk], info);
if (*info != 0) {
return 0;
}
}
st = i__ + 1;
}
/* L240: */
}
/* Apply the singular values and treat the tiny ones as zero. */
tol = rcnd * (r__1 = d__[isamax_(n, &d__[1], &c__1)], dabs(r__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 ((r__1 = d__[i__], dabs(r__1)) <= tol) {
claset_("A", &c__1, nrhs, &c_b1, &c_b1, &work[bx + i__ - 1], n);
} else {
++(*rank);
clascl_("G", &c__0, &c__0, &d__[i__], &c_b10, &c__1, nrhs, &work[
bx + i__ - 1], n, info);
}
d__[i__] = (r__1 = d__[i__], dabs(r__1));
/* L250: */
}
/* 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) {
ccopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb);
} else if (nsize <= *smlsiz) {
/* Since B and BX are complex, the following call to SGEMM */
/* is performed in two steps (real and imaginary parts). */
/* CALL SGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE, */
/* $ RWORK( VT+ST1 ), N, RWORK( BXST ), N, ZERO, */
/* $ B( ST, 1 ), LDB ) */
j = bxst - *n - 1;
jreal = irwb - 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
j += *n;
i__3 = nsize;
for (jrow = 1; jrow <= i__3; ++jrow) {
++jreal;
i__4 = j + jrow;
rwork[jreal] = work[i__4].r;
/* L260: */
}
/* L270: */
}
sgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[vt + st1],
n, &rwork[irwb], &nsize, &c_b35, &rwork[irwrb], &nsize);
j = bxst - *n - 1;
jimag = irwb - 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
j += *n;
i__3 = nsize;
for (jrow = 1; jrow <= i__3; ++jrow) {
++jimag;
rwork[jimag] = r_imag(&work[j + jrow]);
/* L280: */
}
/* L290: */
}
sgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[vt + st1],
n, &rwork[irwb], &nsize, &c_b35, &rwork[irwib], &nsize);
jreal = irwrb - 1;
jimag = irwib - 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = st + nsize - 1;
for (jrow = st; jrow <= i__3; ++jrow) {
++jreal;
++jimag;
i__4 = jrow + jcol * b_dim1;
i__5 = jreal;
i__6 = jimag;
q__1.r = rwork[i__5], q__1.i = rwork[i__6];
b[i__4].r = q__1.r, b[i__4].i = q__1.i;
/* L300: */
}
/* L310: */
}
} else {
clalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st +
b_dim1], ldb, &rwork[u + st1], n, &rwork[vt + st1], &
iwork[k + st1], &rwork[difl + st1], &rwork[difr + st1], &
rwork[z__ + st1], &rwork[poles + st1], &iwork[givptr +
st1], &iwork[givcol + st1], n, &iwork[perm + st1], &rwork[
givnum + st1], &rwork[c__ + st1], &rwork[s + st1], &rwork[
nrwork], &iwork[iwk], info);
if (*info != 0) {
return 0;
}
}
/* L320: */
}
/* Unscale and sort the singular values. */
slascl_("G", &c__0, &c__0, &c_b10, &orgnrm, n, &c__1, &d__[1], n, info);
slasrt_("D", n, &d__[1], info);
clascl_("G", &c__0, &c__0, &orgnrm, &c_b10, n, nrhs, &b[b_offset], ldb,
info);
return 0;
/* End of CLALSD */
} /* clalsd_ */
