/* Subroutine */ int zsteqr_(char *compz, integer *n, doublereal *d__,
doublereal *e, doublecomplex *z__, integer *ldz, doublereal *work,
integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
doublereal b, c__, f, g;
integer i__, j, k, l, m;
doublereal p, r__, s;
integer l1, ii, mm, lm1, mm1, nm1;
doublereal rt1, rt2, eps;
integer lsv;
doublereal tst, eps2;
integer lend, jtot;
extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
extern logical lsame_(char *, char *);
doublereal anorm;
extern /* Subroutine */ int zlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *), dlaev2_(doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *);
integer lendm1, lendp1;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
integer iscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
doublereal safmin;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
doublereal safmax;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *);
integer lendsv;
doublereal ssfmin;
integer nmaxit, icompz;
doublereal ssfmax;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZSTEQR 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 complex Hermitian matrix can also */
/* be found if ZHETRD or ZHPTRD or ZHBTRD 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 */
/* Hermitian matrix. On entry, Z must contain the */
/* unitary matrix used to reduce the original matrix */
/* to tridiagonal form. */
/* = 'I': Compute eigenvalues and eigenvectors of the */
/* tridiagonal matrix. Z is initialized to the identity */
/* matrix. */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the diagonal elements of the tridiagonal matrix. */
/* On exit, if INFO = 0, the eigenvalues in ascending order. */
/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
/* matrix. */
/* On exit, E has been destroyed. */
/* Z (input/output) COMPLEX*16 array, dimension (LDZ, N) */
/* On entry, if COMPZ = 'V', then Z contains the unitary */
/* 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 Hermitian matrix, */
/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */
/* of the symmetric tridiagonal matrix. */
/* If COMPZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* eigenvectors are desired, then LDZ >= max(1,N). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) */
/* If COMPZ = 'N', then WORK is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: the algorithm has failed to find all the eigenvalues in */
/* a total of 30*N iterations; if INFO = i, then i */
/* elements of E have not converged to zero; on exit, D */
/* and E contain the elements of a symmetric tridiagonal */
/* matrix which is unitarily similar to the original */
/* matrix. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
if (lsame_(compz, "N")) {
icompz = 0;
} else if (lsame_(compz, "V")) {
icompz = 1;
} else if (lsame_(compz, "I")) {
icompz = 2;
} else {
icompz = -1;
}
if (icompz < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZSTEQR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz == 2) {
i__1 = z_dim1 + 1;
z__[i__1].r = 1., z__[i__1].i = 0.;
}
return 0;
}
/* Determine the unit roundoff and over/underflow thresholds. */
eps = dlamch_("E");
/* Computing 2nd power */
d__1 = eps;
eps2 = d__1 * d__1;
safmin = dlamch_("S");
safmax = 1. / safmin;
ssfmax = sqrt(safmax) / 3.;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues and eigenvectors of the tridiagonal */
/* matrix. */
if (icompz == 2) {
zlaset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
nmaxit = *n * 30;
jtot = 0;
/* Determine where the matrix splits and choose QL or QR iteration */
/* for each block, according to whether top or bottom diagonal */
/* element is smaller. */
l1 = 1;
nm1 = *n - 1;
L10:
if (l1 > *n) {
goto L160;
}
if (l1 > 1) {
e[l1 - 1] = 0.;
}
if (l1 <= nm1) {
i__1 = nm1;
for (m = l1; m <= i__1; ++m) {
tst = (d__1 = e[m], abs(d__1));
if (tst == 0.) {
goto L30;
}
if (tst <= sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m
+ 1], abs(d__2))) * eps) {
e[m] = 0.;
goto L30;
}
/* L20: */
}
}
m = *n;
L30:
l = l1;
lsv = l;
lend = m;
lendsv = lend;
l1 = m + 1;
if (lend == l) {
goto L10;
}
/* Scale submatrix in rows and columns L to LEND */
i__1 = lend - l + 1;
anorm = dlanst_("I", &i__1, &d__[l], &e[l]);
iscale = 0;
if (anorm == 0.) {
goto L10;
}
if (anorm > ssfmax) {
iscale = 1;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
info);
} else if (anorm < ssfmin) {
iscale = 2;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
info);
}
/* Choose between QL and QR iteration */
if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) {
lend = lsv;
l = lendsv;
}
if (lend > l) {
/* QL Iteration */
/* Look for small subdiagonal element. */
L40:
if (l != lend) {
lendm1 = lend - 1;
i__1 = lendm1;
for (m = l; m <= i__1; ++m) {
/* Computing 2nd power */
d__2 = (d__1 = e[m], abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
+ 1], abs(d__2)) + safmin) {
goto L60;
}
/* L50: */
}
}
m = lend;
L60:
if (m < lend) {
e[m] = 0.;
}
p = d__[l];
if (m == l) {
goto L80;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */
/* to compute its eigensystem. */
if (m == l + 1) {
if (icompz > 0) {
dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
work[l] = c__;
work[*n - 1 + l] = s;
zlasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], &
z__[l * z_dim1 + 1], ldz);
} else {
dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
}
d__[l] = rt1;
d__[l + 1] = rt2;
e[l] = 0.;
l += 2;
if (l <= lend) {
goto L40;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l + 1] - p) / (e[l] * 2.);
r__ = dlapy2_(&g, &c_b41);
g = d__[m] - p + e[l] / (g + d_sign(&r__, &g));
s = 1.;
c__ = 1.;
p = 0.;
/* Inner loop */
mm1 = m - 1;
i__1 = l;
for (i__ = mm1; i__ >= i__1; --i__) {
f = s * e[i__];
b = c__ * e[i__];
dlartg_(&g, &f, &c__, &s, &r__);
if (i__ != m - 1) {
e[i__ + 1] = r__;
}
g = d__[i__ + 1] - p;
r__ = (d__[i__] - g) * s + c__ * 2. * b;
p = s * r__;
d__[i__ + 1] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
work[i__] = c__;
work[*n - 1 + i__] = -s;
}
/* L70: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = m - l + 1;
zlasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l
* z_dim1 + 1], ldz);
}
d__[l] -= p;
e[l] = g;
goto L40;
/* Eigenvalue found. */
L80:
d__[l] = p;
++l;
if (l <= lend) {
goto L40;
}
goto L140;
} else {
/* QR Iteration */
/* Look for small superdiagonal element. */
L90:
if (l != lend) {
lendp1 = lend + 1;
i__1 = lendp1;
for (m = l; m >= i__1; --m) {
/* Computing 2nd power */
d__2 = (d__1 = e[m - 1], abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
- 1], abs(d__2)) + safmin) {
goto L110;
}
/* L100: */
}
}
m = lend;
L110:
if (m > lend) {
e[m - 1] = 0.;
}
p = d__[l];
if (m == l) {
goto L130;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */
/* to compute its eigensystem. */
if (m == l - 1) {
if (icompz > 0) {
dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
;
work[m] = c__;
work[*n - 1 + m] = s;
zlasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], &
z__[(l - 1) * z_dim1 + 1], ldz);
} else {
dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
}
d__[l - 1] = rt1;
d__[l] = rt2;
e[l - 1] = 0.;
l += -2;
if (l >= lend) {
goto L90;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l - 1] - p) / (e[l - 1] * 2.);
r__ = dlapy2_(&g, &c_b41);
g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g));
s = 1.;
c__ = 1.;
p = 0.;
/* Inner loop */
lm1 = l - 1;
i__1 = lm1;
for (i__ = m; i__ <= i__1; ++i__) {
f = s * e[i__];
b = c__ * e[i__];
dlartg_(&g, &f, &c__, &s, &r__);
if (i__ != m) {
e[i__ - 1] = r__;
}
g = d__[i__] - p;
r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b;
p = s * r__;
d__[i__] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
work[i__] = c__;
work[*n - 1 + i__] = s;
}
/* L120: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = l - m + 1;
zlasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m
* z_dim1 + 1], ldz);
}
d__[l] -= p;
e[lm1] = g;
goto L90;
/* Eigenvalue found. */
L130:
d__[l] = p;
--l;
if (l >= lend) {
goto L90;
}
goto L140;
}
/* Undo scaling if necessary */
L140:
if (iscale == 1) {
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
info);
} else if (iscale == 2) {
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n,
info);
}
/* Check for no convergence to an eigenvalue after a total */
/* of N*MAXIT iterations. */
if (jtot == nmaxit) {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.) {
++(*info);
}
/* L150: */
}
return 0;
}
goto L10;
/* Order eigenvalues and eigenvectors. */
L160:
if (icompz == 0) {
/* Use Quick Sort */
dlasrt_("I", n, &d__[1], info);
} else {
/* Use Selection Sort to minimize swaps of eigenvectors */
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
i__ = ii - 1;
k = i__;
p = d__[i__];
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
if (d__[j] < p) {
k = j;
p = d__[j];
}
/* L170: */
}
if (k != i__) {
d__[k] = d__[i__];
d__[i__] = p;
zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1],
&c__1);
}
/* L180: */
}
}
return 0;
/* End of ZSTEQR */
} /* zsteqr_ */
/* Subroutine */
int zsteqr_(char *compz, integer *n, doublereal *d__, doublereal *e, doublecomplex *z__, integer *ldz, doublereal *work, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
doublereal b, c__, f, g;
integer i__, j, k, l, m;
doublereal p, r__, s;
integer l1, ii, mm, lm1, mm1, nm1;
doublereal rt1, rt2, eps;
integer lsv;
doublereal tst, eps2;
integer lend, jtot;
extern /* Subroutine */
int dlae2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *);
extern logical lsame_(char *, char *);
doublereal anorm;
extern /* Subroutine */
int zlasr_(char *, char *, char *, integer *, integer *, doublereal *, doublereal *, doublecomplex *, integer *), zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), dlaev2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *);
integer lendm1, lendp1;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
integer iscale;
extern /* Subroutine */
int dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *);
doublereal safmin;
extern /* Subroutine */
int dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *);
doublereal safmax;
extern /* Subroutine */
int xerbla_(char *, integer *);
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */
int dlasrt_(char *, integer *, doublereal *, integer *);
integer lendsv;
doublereal ssfmin;
integer nmaxit, icompz;
doublereal ssfmax;
extern /* Subroutine */
int zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *);
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--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_("ZSTEQR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
if (*n == 1)
{
if (icompz == 2)
{
i__1 = z_dim1 + 1;
z__[i__1].r = 1.;
z__[i__1].i = 0.; // , expr subst
}
return 0;
}
/* Determine the unit roundoff and over/underflow thresholds. */
eps = dlamch_("E");
/* Computing 2nd power */
d__1 = eps;
eps2 = d__1 * d__1;
safmin = dlamch_("S");
safmax = 1. / safmin;
ssfmax = sqrt(safmax) / 3.;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues and eigenvectors of the tridiagonal */
/* matrix. */
if (icompz == 2)
{
zlaset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
nmaxit = *n * 30;
jtot = 0;
/* Determine where the matrix splits and choose QL or QR iteration */
/* for each block, according to whether top or bottom diagonal */
/* element is smaller. */
l1 = 1;
nm1 = *n - 1;
L10:
if (l1 > *n)
{
goto L160;
}
if (l1 > 1)
{
e[l1 - 1] = 0.;
}
if (l1 <= nm1)
{
i__1 = nm1;
for (m = l1;
m <= i__1;
++m)
{
tst = (d__1 = e[m], f2c_abs(d__1));
if (tst == 0.)
{
goto L30;
}
if (tst <= sqrt((d__1 = d__[m], f2c_abs(d__1))) * sqrt((d__2 = d__[m + 1], f2c_abs(d__2))) * eps)
{
e[m] = 0.;
goto L30;
}
/* L20: */
}
}
m = *n;
L30:
l = l1;
lsv = l;
lend = m;
lendsv = lend;
l1 = m + 1;
if (lend == l)
{
goto L10;
}
/* Scale submatrix in rows and columns L to LEND */
i__1 = lend - l + 1;
anorm = dlanst_("I", &i__1, &d__[l], &e[l]);
iscale = 0;
if (anorm == 0.)
{
goto L10;
}
if (anorm > ssfmax)
{
iscale = 1;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, info);
}
else if (anorm < ssfmin)
{
iscale = 2;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, info);
}
/* Choose between QL and QR iteration */
if ((d__1 = d__[lend], f2c_abs(d__1)) < (d__2 = d__[l], f2c_abs(d__2)))
{
lend = lsv;
l = lendsv;
}
if (lend > l)
{
/* QL Iteration */
/* Look for small subdiagonal element. */
L40:
if (l != lend)
{
lendm1 = lend - 1;
i__1 = lendm1;
for (m = l;
m <= i__1;
++m)
{
/* Computing 2nd power */
d__2 = (d__1 = e[m], f2c_abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = d__[m], f2c_abs(d__1)) * (d__2 = d__[m + 1], f2c_abs(d__2)) + safmin)
{
goto L60;
}
/* L50: */
}
}
m = lend;
L60:
if (m < lend)
{
e[m] = 0.;
}
p = d__[l];
if (m == l)
{
goto L80;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */
/* to compute its eigensystem. */
if (m == l + 1)
{
if (icompz > 0)
{
dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
work[l] = c__;
work[*n - 1 + l] = s;
zlasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], & z__[l * z_dim1 + 1], ldz);
}
else
{
dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
}
d__[l] = rt1;
d__[l + 1] = rt2;
e[l] = 0.;
l += 2;
if (l <= lend)
{
goto L40;
}
goto L140;
}
if (jtot == nmaxit)
{
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l + 1] - p) / (e[l] * 2.);
r__ = dlapy2_(&g, &c_b41);
g = d__[m] - p + e[l] / (g + d_sign(&r__, &g));
s = 1.;
c__ = 1.;
p = 0.;
/* Inner loop */
mm1 = m - 1;
i__1 = l;
for (i__ = mm1;
i__ >= i__1;
--i__)
{
f = s * e[i__];
b = c__ * e[i__];
dlartg_(&g, &f, &c__, &s, &r__);
if (i__ != m - 1)
{
e[i__ + 1] = r__;
}
g = d__[i__ + 1] - p;
r__ = (d__[i__] - g) * s + c__ * 2. * b;
p = s * r__;
d__[i__ + 1] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0)
{
work[i__] = c__;
work[*n - 1 + i__] = -s;
}
/* L70: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0)
{
mm = m - l + 1;
zlasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l * z_dim1 + 1], ldz);
}
d__[l] -= p;
e[l] = g;
goto L40;
/* Eigenvalue found. */
L80:
d__[l] = p;
++l;
if (l <= lend)
{
goto L40;
}
goto L140;
}
else
{
/* QR Iteration */
/* Look for small superdiagonal element. */
L90:
if (l != lend)
{
lendp1 = lend + 1;
i__1 = lendp1;
for (m = l;
m >= i__1;
--m)
{
/* Computing 2nd power */
d__2 = (d__1 = e[m - 1], f2c_abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = d__[m], f2c_abs(d__1)) * (d__2 = d__[m - 1], f2c_abs(d__2)) + safmin)
{
goto L110;
}
/* L100: */
}
}
m = lend;
L110:
if (m > lend)
{
e[m - 1] = 0.;
}
p = d__[l];
if (m == l)
{
goto L130;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */
/* to compute its eigensystem. */
if (m == l - 1)
{
if (icompz > 0)
{
dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s) ;
work[m] = c__;
work[*n - 1 + m] = s;
zlasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], & z__[(l - 1) * z_dim1 + 1], ldz);
}
else
{
dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
}
d__[l - 1] = rt1;
d__[l] = rt2;
e[l - 1] = 0.;
l += -2;
if (l >= lend)
{
goto L90;
}
goto L140;
}
if (jtot == nmaxit)
{
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l - 1] - p) / (e[l - 1] * 2.);
r__ = dlapy2_(&g, &c_b41);
g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g));
s = 1.;
c__ = 1.;
p = 0.;
/* Inner loop */
lm1 = l - 1;
i__1 = lm1;
for (i__ = m;
i__ <= i__1;
++i__)
{
f = s * e[i__];
b = c__ * e[i__];
dlartg_(&g, &f, &c__, &s, &r__);
if (i__ != m)
{
e[i__ - 1] = r__;
}
g = d__[i__] - p;
r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b;
p = s * r__;
d__[i__] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0)
{
work[i__] = c__;
work[*n - 1 + i__] = s;
}
/* L120: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0)
{
mm = l - m + 1;
zlasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m * z_dim1 + 1], ldz);
}
d__[l] -= p;
e[lm1] = g;
goto L90;
/* Eigenvalue found. */
L130:
d__[l] = p;
--l;
if (l >= lend)
{
goto L90;
}
goto L140;
}
/* Undo scaling if necessary */
L140:
if (iscale == 1)
{
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], n, info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n, info);
}
else if (iscale == 2)
{
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], n, info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n, info);
}
/* Check for no convergence to an eigenvalue after a total */
/* of N*MAXIT iterations. */
if (jtot == nmaxit)
{
i__1 = *n - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if (e[i__] != 0.)
{
++(*info);
}
/* L150: */
}
return 0;
}
goto L10;
/* Order eigenvalues and eigenvectors. */
L160:
if (icompz == 0)
{
/* Use Quick Sort */
dlasrt_("I", n, &d__[1], info);
}
else
{
/* Use Selection Sort to minimize swaps of eigenvectors */
i__1 = *n;
for (ii = 2;
ii <= i__1;
++ii)
{
i__ = ii - 1;
k = i__;
p = d__[i__];
i__2 = *n;
for (j = ii;
j <= i__2;
++j)
{
if (d__[j] < p)
{
k = j;
p = d__[j];
}
/* L170: */
}
if (k != i__)
{
d__[k] = d__[i__];
d__[i__] = p;
zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1], &c__1);
}
/* L180: */
}
}
return 0;
/* End of ZSTEQR */
}
/* Subroutine */ int zbdsqr_(char *uplo, integer *n, integer *ncvt, integer *
nru, integer *ncc, doublereal *d__, doublereal *e, doublecomplex *vt,
integer *ldvt, doublecomplex *u, integer *ldu, doublecomplex *c__,
integer *ldc, doublereal *rwork, integer *info)
{
/* System generated locals */
integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
i__2;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *), sqrt(doublereal), d_sign(
doublereal *, doublereal *);
/* Local variables */
static doublereal abse;
static integer idir;
static doublereal abss;
static integer oldm;
static doublereal cosl;
static integer isub, iter;
static doublereal unfl, sinl, cosr, smin, smax, sinr;
extern /* Subroutine */ int dlas2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
static doublereal f, g, h__;
static integer i__, j, m;
static doublereal r__;
extern logical lsame_(char *, char *);
static doublereal oldcs;
static integer oldll;
static doublereal shift, sigmn, oldsn;
static integer maxit;
static doublereal sminl, sigmx;
static logical lower;
extern /* Subroutine */ int zlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublecomplex *, integer *), zdrot_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *)
, zswap_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *), dlasq1_(integer *, doublereal *, doublereal *,
doublereal *, integer *), dlasv2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
static doublereal cs;
static integer ll;
extern doublereal dlamch_(char *);
static doublereal sn, mu;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *), xerbla_(char *,
integer *), zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
static doublereal sminoa, thresh;
static logical rotate;
static doublereal sminlo;
static integer nm1;
static doublereal tolmul;
static integer nm12, nm13, lll;
static doublereal eps, sll, tol;
#define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1
#define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)]
#define u_subscr(a_1,a_2) (a_2)*u_dim1 + a_1
#define u_ref(a_1,a_2) u[u_subscr(a_1,a_2)]
#define vt_subscr(a_1,a_2) (a_2)*vt_dim1 + a_1
#define vt_ref(a_1,a_2) vt[vt_subscr(a_1,a_2)]
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1999
Purpose
=======
ZBDSQR computes the singular value decomposition (SVD) of a real
N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P'
denotes the transpose of P), where S is a diagonal matrix with
non-negative diagonal elements (the singular values of B), and Q
and P are orthogonal matrices.
The routine computes S, and optionally computes U * Q, P' * VT,
or Q' * C, for given complex input matrices U, VT, and C.
See "Computing Small Singular Values of Bidiagonal Matrices With
Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
no. 5, pp. 873-912, Sept 1990) and
"Accurate singular values and differential qd algorithms," by
B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
Department, University of California at Berkeley, July 1992
for a detailed description of the algorithm.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': B is upper bidiagonal;
= 'L': B is lower bidiagonal.
N (input) INTEGER
The order of the matrix B. N >= 0.
NCVT (input) INTEGER
The number of columns of the matrix VT. NCVT >= 0.
NRU (input) INTEGER
The number of rows of the matrix U. NRU >= 0.
NCC (input) INTEGER
The number of columns of the matrix C. NCC >= 0.
D (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the n diagonal elements of the bidiagonal matrix B.
On exit, if INFO=0, the singular values of B in decreasing
order.
E (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the elements of E contain the
offdiagonal elements of of the bidiagonal matrix whose SVD
is desired. On normal exit (INFO = 0), E is destroyed.
If the algorithm does not converge (INFO > 0), D and E
will contain the diagonal and superdiagonal elements of a
bidiagonal matrix orthogonally equivalent to the one given
as input. E(N) is used for workspace.
VT (input/output) COMPLEX*16 array, dimension (LDVT, NCVT)
On entry, an N-by-NCVT matrix VT.
On exit, VT is overwritten by P' * VT.
VT is not referenced if NCVT = 0.
LDVT (input) INTEGER
The leading dimension of the array VT.
LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
U (input/output) COMPLEX*16 array, dimension (LDU, N)
On entry, an NRU-by-N matrix U.
On exit, U is overwritten by U * Q.
U is not referenced if NRU = 0.
LDU (input) INTEGER
The leading dimension of the array U. LDU >= max(1,NRU).
C (input/output) COMPLEX*16 array, dimension (LDC, NCC)
On entry, an N-by-NCC matrix C.
On exit, C is overwritten by Q' * C.
C is not referenced if NCC = 0.
LDC (input) INTEGER
The leading dimension of the array C.
LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
RWORK (workspace) DOUBLE PRECISION array, dimension (4*N)
INFO (output) INTEGER
= 0: successful exit
< 0: If INFO = -i, the i-th argument had an illegal value
> 0: the algorithm did not converge; D and E contain the
elements of a bidiagonal matrix which is orthogonally
similar to the input matrix B; if INFO = i, i
elements of E have not converged to zero.
Internal Parameters
===================
TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))
TOLMUL controls the convergence criterion of the QR loop.
If it is positive, TOLMUL*EPS is the desired relative
precision in the computed singular values.
If it is negative, abs(TOLMUL*EPS*sigma_max) is the
desired absolute accuracy in the computed singular
values (corresponds to relative accuracy
abs(TOLMUL*EPS) in the largest singular value.
abs(TOLMUL) should be between 1 and 1/EPS, and preferably
between 10 (for fast convergence) and .1/EPS
(for there to be some accuracy in the results).
Default is to lose at either one eighth or 2 of the
available decimal digits in each computed singular value
(whichever is smaller).
MAXITR INTEGER, default = 6
MAXITR controls the maximum number of passes of the
algorithm through its inner loop. The algorithms stops
(and so fails to converge) if the number of passes
through the inner loop exceeds MAXITR*N**2.
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--e;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1 * 1;
vt -= vt_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--rwork;
/* Function Body */
*info = 0;
lower = lsame_(uplo, "L");
if (! lsame_(uplo, "U") && ! lower) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ncvt < 0) {
*info = -3;
} else if (*nru < 0) {
*info = -4;
} else if (*ncc < 0) {
*info = -5;
} else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) {
*info = -9;
} else if (*ldu < max(1,*nru)) {
*info = -11;
} else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZBDSQR", &i__1);
return 0;
}
if (*n == 0) {
return 0;
}
if (*n == 1) {
goto L160;
}
/* ROTATE is true if any singular vectors desired, false otherwise */
rotate = *ncvt > 0 || *nru > 0 || *ncc > 0;
/* If no singular vectors desired, use qd algorithm */
if (! rotate) {
dlasq1_(n, &d__[1], &e[1], &rwork[1], info);
return 0;
}
nm1 = *n - 1;
nm12 = nm1 + nm1;
nm13 = nm12 + nm1;
idir = 0;
/* Get machine constants */
eps = dlamch_("Epsilon");
unfl = dlamch_("Safe minimum");
/* If matrix lower bidiagonal, rotate to be upper bidiagonal
by applying Givens rotations on the left */
if (lower) {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
rwork[i__] = cs;
rwork[nm1 + i__] = sn;
/* L10: */
}
/* Update singular vectors if desired */
if (*nru > 0) {
zlasr_("R", "V", "F", nru, n, &rwork[1], &rwork[*n], &u[u_offset],
ldu);
}
if (*ncc > 0) {
zlasr_("L", "V", "F", n, ncc, &rwork[1], &rwork[*n], &c__[
c_offset], ldc);
}
}
/* Compute singular values to relative accuracy TOL
(By setting TOL to be negative, algorithm will compute
singular values to absolute accuracy ABS(TOL)*norm(input matrix))
Computing MAX
Computing MIN */
d__3 = 100., d__4 = pow_dd(&eps, &c_b15);
d__1 = 10., d__2 = min(d__3,d__4);
tolmul = max(d__1,d__2);
tol = tolmul * eps;
/* Compute approximate maximum, minimum singular values */
smax = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = smax, d__3 = (d__1 = d__[i__], abs(d__1));
smax = max(d__2,d__3);
/* L20: */
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = smax, d__3 = (d__1 = e[i__], abs(d__1));
smax = max(d__2,d__3);
/* L30: */
}
sminl = 0.;
if (tol >= 0.) {
/* Relative accuracy desired */
sminoa = abs(d__[1]);
if (sminoa == 0.) {
goto L50;
}
mu = sminoa;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
mu = (d__2 = d__[i__], abs(d__2)) * (mu / (mu + (d__1 = e[i__ - 1]
, abs(d__1))));
sminoa = min(sminoa,mu);
if (sminoa == 0.) {
goto L50;
}
/* L40: */
}
L50:
sminoa /= sqrt((doublereal) (*n));
/* Computing MAX */
d__1 = tol * sminoa, d__2 = *n * 6 * *n * unfl;
thresh = max(d__1,d__2);
} else {
/* Absolute accuracy desired
Computing MAX */
d__1 = abs(tol) * smax, d__2 = *n * 6 * *n * unfl;
thresh = max(d__1,d__2);
}
/* Prepare for main iteration loop for the singular values
(MAXIT is the maximum number of passes through the inner
loop permitted before nonconvergence signalled.) */
maxit = *n * 6 * *n;
iter = 0;
oldll = -1;
oldm = -1;
/* M points to last element of unconverged part of matrix */
m = *n;
/* Begin main iteration loop */
L60:
/* Check for convergence or exceeding iteration count */
if (m <= 1) {
goto L160;
}
if (iter > maxit) {
goto L200;
}
/* Find diagonal block of matrix to work on */
if (tol < 0. && (d__1 = d__[m], abs(d__1)) <= thresh) {
d__[m] = 0.;
}
smax = (d__1 = d__[m], abs(d__1));
smin = smax;
i__1 = m - 1;
for (lll = 1; lll <= i__1; ++lll) {
ll = m - lll;
abss = (d__1 = d__[ll], abs(d__1));
abse = (d__1 = e[ll], abs(d__1));
if (tol < 0. && abss <= thresh) {
d__[ll] = 0.;
}
if (abse <= thresh) {
goto L80;
}
smin = min(smin,abss);
/* Computing MAX */
d__1 = max(smax,abss);
smax = max(d__1,abse);
/* L70: */
}
ll = 0;
goto L90;
L80:
e[ll] = 0.;
/* Matrix splits since E(LL) = 0 */
if (ll == m - 1) {
/* Convergence of bottom singular value, return to top of loop */
--m;
goto L60;
}
L90:
++ll;
/* E(LL) through E(M-1) are nonzero, E(LL-1) is zero */
if (ll == m - 1) {
/* 2 by 2 block, handle separately */
dlasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr,
&sinl, &cosl);
d__[m - 1] = sigmx;
e[m - 1] = 0.;
d__[m] = sigmn;
/* Compute singular vectors, if desired */
if (*ncvt > 0) {
zdrot_(ncvt, &vt_ref(m - 1, 1), ldvt, &vt_ref(m, 1), ldvt, &cosr,
&sinr);
}
if (*nru > 0) {
zdrot_(nru, &u_ref(1, m - 1), &c__1, &u_ref(1, m), &c__1, &cosl, &
sinl);
}
if (*ncc > 0) {
zdrot_(ncc, &c___ref(m - 1, 1), ldc, &c___ref(m, 1), ldc, &cosl, &
sinl);
}
m += -2;
goto L60;
}
/* If working on new submatrix, choose shift direction
(from larger end diagonal element towards smaller) */
if (ll > oldm || m < oldll) {
if ((d__1 = d__[ll], abs(d__1)) >= (d__2 = d__[m], abs(d__2))) {
/* Chase bulge from top (big end) to bottom (small end) */
idir = 1;
} else {
/* Chase bulge from bottom (big end) to top (small end) */
idir = 2;
}
}
/* Apply convergence tests */
if (idir == 1) {
/* Run convergence test in forward direction
First apply standard test to bottom of matrix */
if ((d__2 = e[m - 1], abs(d__2)) <= abs(tol) * (d__1 = d__[m], abs(
d__1)) || tol < 0. && (d__3 = e[m - 1], abs(d__3)) <= thresh)
{
e[m - 1] = 0.;
goto L60;
}
if (tol >= 0.) {
/* If relative accuracy desired,
apply convergence criterion forward */
mu = (d__1 = d__[ll], abs(d__1));
sminl = mu;
i__1 = m - 1;
for (lll = ll; lll <= i__1; ++lll) {
if ((d__1 = e[lll], abs(d__1)) <= tol * mu) {
e[lll] = 0.;
goto L60;
}
sminlo = sminl;
mu = (d__2 = d__[lll + 1], abs(d__2)) * (mu / (mu + (d__1 = e[
lll], abs(d__1))));
sminl = min(sminl,mu);
/* L100: */
}
}
} else {
/* Run convergence test in backward direction
First apply standard test to top of matrix */
if ((d__2 = e[ll], abs(d__2)) <= abs(tol) * (d__1 = d__[ll], abs(d__1)
) || tol < 0. && (d__3 = e[ll], abs(d__3)) <= thresh) {
e[ll] = 0.;
goto L60;
}
if (tol >= 0.) {
/* If relative accuracy desired,
apply convergence criterion backward */
mu = (d__1 = d__[m], abs(d__1));
sminl = mu;
i__1 = ll;
for (lll = m - 1; lll >= i__1; --lll) {
if ((d__1 = e[lll], abs(d__1)) <= tol * mu) {
e[lll] = 0.;
goto L60;
}
sminlo = sminl;
mu = (d__2 = d__[lll], abs(d__2)) * (mu / (mu + (d__1 = e[lll]
, abs(d__1))));
sminl = min(sminl,mu);
/* L110: */
}
}
}
oldll = ll;
oldm = m;
/* Compute shift. First, test if shifting would ruin relative
accuracy, and if so set the shift to zero.
Computing MAX */
d__1 = eps, d__2 = tol * .01;
if (tol >= 0. && *n * tol * (sminl / smax) <= max(d__1,d__2)) {
/* Use a zero shift to avoid loss of relative accuracy */
shift = 0.;
} else {
/* Compute the shift from 2-by-2 block at end of matrix */
if (idir == 1) {
sll = (d__1 = d__[ll], abs(d__1));
dlas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__);
} else {
sll = (d__1 = d__[m], abs(d__1));
dlas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__);
}
/* Test if shift negligible, and if so set to zero */
if (sll > 0.) {
/* Computing 2nd power */
d__1 = shift / sll;
if (d__1 * d__1 < eps) {
shift = 0.;
}
}
}
/* Increment iteration count */
iter = iter + m - ll;
/* If SHIFT = 0, do simplified QR iteration */
if (shift == 0.) {
if (idir == 1) {
/* Chase bulge from top to bottom
Save cosines and sines for later singular vector updates */
cs = 1.;
oldcs = 1.;
i__1 = m - 1;
for (i__ = ll; i__ <= i__1; ++i__) {
d__1 = d__[i__] * cs;
dlartg_(&d__1, &e[i__], &cs, &sn, &r__);
if (i__ > ll) {
e[i__ - 1] = oldsn * r__;
}
d__1 = oldcs * r__;
d__2 = d__[i__ + 1] * sn;
dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
rwork[i__ - ll + 1] = cs;
rwork[i__ - ll + 1 + nm1] = sn;
rwork[i__ - ll + 1 + nm12] = oldcs;
rwork[i__ - ll + 1 + nm13] = oldsn;
/* L120: */
}
h__ = d__[m] * cs;
d__[m] = h__ * oldcs;
e[m - 1] = h__ * oldsn;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "F", &i__1, ncvt, &rwork[1], &rwork[*n], &
vt_ref(ll, 1), ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
zlasr_("R", "V", "F", nru, &i__1, &rwork[nm12 + 1], &rwork[
nm13 + 1], &u_ref(1, ll), ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "F", &i__1, ncc, &rwork[nm12 + 1], &rwork[
nm13 + 1], &c___ref(ll, 1), ldc);
}
/* Test convergence */
if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
e[m - 1] = 0.;
}
} else {
/* Chase bulge from bottom to top
Save cosines and sines for later singular vector updates */
cs = 1.;
oldcs = 1.;
i__1 = ll + 1;
for (i__ = m; i__ >= i__1; --i__) {
d__1 = d__[i__] * cs;
dlartg_(&d__1, &e[i__ - 1], &cs, &sn, &r__);
if (i__ < m) {
e[i__] = oldsn * r__;
}
d__1 = oldcs * r__;
d__2 = d__[i__ - 1] * sn;
dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
rwork[i__ - ll] = cs;
rwork[i__ - ll + nm1] = -sn;
rwork[i__ - ll + nm12] = oldcs;
rwork[i__ - ll + nm13] = -oldsn;
/* L130: */
}
h__ = d__[ll] * cs;
d__[ll] = h__ * oldcs;
e[ll] = h__ * oldsn;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "B", &i__1, ncvt, &rwork[nm12 + 1], &rwork[
nm13 + 1], &vt_ref(ll, 1), ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
zlasr_("R", "V", "B", nru, &i__1, &rwork[1], &rwork[*n], &
u_ref(1, ll), ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "B", &i__1, ncc, &rwork[1], &rwork[*n], &
c___ref(ll, 1), ldc);
}
/* Test convergence */
if ((d__1 = e[ll], abs(d__1)) <= thresh) {
e[ll] = 0.;
}
}
} else {
/* Use nonzero shift */
if (idir == 1) {
/* Chase bulge from top to bottom
Save cosines and sines for later singular vector updates */
f = ((d__1 = d__[ll], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[
ll]) + shift / d__[ll]);
g = e[ll];
i__1 = m - 1;
for (i__ = ll; i__ <= i__1; ++i__) {
dlartg_(&f, &g, &cosr, &sinr, &r__);
if (i__ > ll) {
e[i__ - 1] = r__;
}
f = cosr * d__[i__] + sinr * e[i__];
e[i__] = cosr * e[i__] - sinr * d__[i__];
g = sinr * d__[i__ + 1];
d__[i__ + 1] = cosr * d__[i__ + 1];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[i__] = r__;
f = cosl * e[i__] + sinl * d__[i__ + 1];
d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__];
if (i__ < m - 1) {
g = sinl * e[i__ + 1];
e[i__ + 1] = cosl * e[i__ + 1];
}
rwork[i__ - ll + 1] = cosr;
rwork[i__ - ll + 1 + nm1] = sinr;
rwork[i__ - ll + 1 + nm12] = cosl;
rwork[i__ - ll + 1 + nm13] = sinl;
/* L140: */
}
e[m - 1] = f;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "F", &i__1, ncvt, &rwork[1], &rwork[*n], &
vt_ref(ll, 1), ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
zlasr_("R", "V", "F", nru, &i__1, &rwork[nm12 + 1], &rwork[
nm13 + 1], &u_ref(1, ll), ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "F", &i__1, ncc, &rwork[nm12 + 1], &rwork[
nm13 + 1], &c___ref(ll, 1), ldc);
}
/* Test convergence */
if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
e[m - 1] = 0.;
}
} else {
/* Chase bulge from bottom to top
Save cosines and sines for later singular vector updates */
f = ((d__1 = d__[m], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[m]
) + shift / d__[m]);
g = e[m - 1];
i__1 = ll + 1;
for (i__ = m; i__ >= i__1; --i__) {
dlartg_(&f, &g, &cosr, &sinr, &r__);
if (i__ < m) {
e[i__] = r__;
}
f = cosr * d__[i__] + sinr * e[i__ - 1];
e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__];
g = sinr * d__[i__ - 1];
d__[i__ - 1] = cosr * d__[i__ - 1];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[i__] = r__;
f = cosl * e[i__ - 1] + sinl * d__[i__ - 1];
d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1];
if (i__ > ll + 1) {
g = sinl * e[i__ - 2];
e[i__ - 2] = cosl * e[i__ - 2];
}
rwork[i__ - ll] = cosr;
rwork[i__ - ll + nm1] = -sinr;
rwork[i__ - ll + nm12] = cosl;
rwork[i__ - ll + nm13] = -sinl;
/* L150: */
}
e[ll] = f;
/* Test convergence */
if ((d__1 = e[ll], abs(d__1)) <= thresh) {
e[ll] = 0.;
}
/* Update singular vectors if desired */
if (*ncvt > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "B", &i__1, ncvt, &rwork[nm12 + 1], &rwork[
nm13 + 1], &vt_ref(ll, 1), ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
zlasr_("R", "V", "B", nru, &i__1, &rwork[1], &rwork[*n], &
u_ref(1, ll), ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "B", &i__1, ncc, &rwork[1], &rwork[*n], &
c___ref(ll, 1), ldc);
}
}
}
/* QR iteration finished, go back and check convergence */
goto L60;
/* All singular values converged, so make them positive */
L160:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] < 0.) {
d__[i__] = -d__[i__];
/* Change sign of singular vectors, if desired */
if (*ncvt > 0) {
zdscal_(ncvt, &c_b72, &vt_ref(i__, 1), ldvt);
}
}
/* L170: */
}
/* Sort the singular values into decreasing order (insertion sort on
singular values, but only one transposition per singular vector) */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Scan for smallest D(I) */
isub = 1;
smin = d__[1];
i__2 = *n + 1 - i__;
for (j = 2; j <= i__2; ++j) {
if (d__[j] <= smin) {
isub = j;
smin = d__[j];
}
/* L180: */
}
if (isub != *n + 1 - i__) {
/* Swap singular values and vectors */
d__[isub] = d__[*n + 1 - i__];
d__[*n + 1 - i__] = smin;
if (*ncvt > 0) {
zswap_(ncvt, &vt_ref(isub, 1), ldvt, &vt_ref(*n + 1 - i__, 1),
ldvt);
}
if (*nru > 0) {
zswap_(nru, &u_ref(1, isub), &c__1, &u_ref(1, *n + 1 - i__), &
c__1);
}
if (*ncc > 0) {
zswap_(ncc, &c___ref(isub, 1), ldc, &c___ref(*n + 1 - i__, 1),
ldc);
}
}
/* L190: */
}
goto L220;
/* Maximum number of iterations exceeded, failure to converge */
L200:
*info = 0;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.) {
++(*info);
}
/* L210: */
}
L220:
return 0;
/* End of ZBDSQR */
} /* zbdsqr_ */
/* Subroutine */ int zsteqr_(char *compz, integer *n, doublereal *d,
doublereal *e, doublecomplex *z, integer *ldz, doublereal *work,
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
=======
ZSTEQR 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 complex Hermitian matrix can also
be found if ZHETRD or ZHPTRD or ZHBTRD 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
Hermitian matrix. On entry, Z must contain the
unitary matrix used to reduce the original matrix
to tridiagonal form.
= 'I': Compute eigenvalues and eigenvectors of the
tridiagonal matrix. Z is initialized to the identity
matrix.
N (input) INTEGER
The order of the matrix. N >= 0.
D (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the diagonal elements of the tridiagonal matrix.
On exit, if INFO = 0, the eigenvalues in ascending order.
E (input/output) DOUBLE PRECISION array, dimension (N-1)
On entry, the (n-1) subdiagonal elements of the tridiagonal
matrix.
On exit, E has been destroyed.
Z (input/output) COMPLEX*16 array, dimension (LDZ, N)
On entry, if COMPZ = 'V', then Z contains the unitary
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 Hermitian matrix,
and if COMPZ = 'I', Z contains the orthonormal eigenvectors
of the symmetric tridiagonal matrix.
If COMPZ = 'N', then Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
eigenvectors are desired, then LDZ >= max(1,N).
WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
If COMPZ = 'N', then WORK is not referenced.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: the algorithm has failed to find all the eigenvalues in
a total of 30*N iterations; if INFO = i, then i
elements of E have not converged to zero; on exit, D
and E contain the elements of a symmetric tridiagonal
matrix which is unitarily similar to the original
matrix.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
static integer c__0 = 0;
static integer c__1 = 1;
static integer c__2 = 2;
static doublereal c_b41 = 1.;
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
static integer lend, jtot;
extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
static doublereal b, c, f, g;
static integer i, j, k, l, m;
static doublereal p, r, s;
extern logical lsame_(char *, char *);
static doublereal anorm;
extern /* Subroutine */ int zlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublecomplex *, integer *);
static integer l1;
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), dlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
static integer lendm1, lendp1;
extern doublereal dlapy2_(doublereal *, doublereal *);
static integer ii;
extern doublereal dlamch_(char *);
static integer mm, iscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
static doublereal safmin;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
static doublereal safmax;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *);
static integer lendsv;
static doublereal ssfmin;
static integer nmaxit, icompz;
static doublereal ssfmax;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
static integer lm1, mm1, nm1;
static doublereal rt1, rt2, eps;
static integer lsv;
static doublereal 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)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZSTEQR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz == 2) {
i__1 = z_dim1 + 1;
Z(1,1).r = 1., Z(1,1).i = 0.;
}
return 0;
}
/* Determine the unit roundoff and over/underflow thresholds. */
eps = dlamch_("E");
/* Computing 2nd power */
d__1 = eps;
eps2 = d__1 * d__1;
safmin = dlamch_("S");
safmax = 1. / safmin;
ssfmax = sqrt(safmax) / 3.;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues and eigenvectors of the tridiagonal
matrix. */
if (icompz == 2) {
zlaset_("Full", n, n, &c_b1, &c_b2, &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.;
}
if (l1 <= nm1) {
i__1 = nm1;
for (m = l1; m <= nm1; ++m) {
tst = (d__1 = E(m), abs(d__1));
if (tst == 0.) {
goto L30;
}
if (tst <= sqrt((d__1 = D(m), abs(d__1))) * sqrt((d__2 = D(m + 1),
abs(d__2))) * eps) {
E(m) = 0.;
goto L30;
}
/* L20: */
}
}
m = *n;
L30:
l = l1;
lsv = l;
lend = m;
lendsv = lend;
l1 = m + 1;
if (lend == l) {
goto L10;
}
/* Scale submatrix in rows and columns L to LEND */
i__1 = lend - l + 1;
anorm = dlanst_("I", &i__1, &D(l), &E(l));
iscale = 0;
if (anorm == 0.) {
goto L10;
}
if (anorm > ssfmax) {
iscale = 1;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &D(l), n,
info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &E(l), n,
info);
} else if (anorm < ssfmin) {
iscale = 2;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &D(l), n,
info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &E(l), n,
info);
}
/* Choose between QL and QR iteration */
if ((d__1 = D(lend), abs(d__1)) < (d__2 = D(l), abs(d__2))) {
lend = lsv;
l = lendsv;
}
if (lend > l) {
/* QL Iteration
Look for small subdiagonal element. */
L40:
if (l != lend) {
lendm1 = lend - 1;
i__1 = lendm1;
for (m = l; m <= lendm1; ++m) {
/* Computing 2nd power */
d__2 = (d__1 = E(m), abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = D(m), abs(d__1)) * (d__2 = D(m + 1),
abs(d__2)) + safmin) {
goto L60;
}
/* L50: */
}
}
m = lend;
L60:
if (m < lend) {
E(m) = 0.;
}
p = D(l);
if (m == l) {
goto L80;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
to compute its eigensystem. */
if (m == l + 1) {
if (icompz > 0) {
dlaev2_(&D(l), &E(l), &D(l + 1), &rt1, &rt2, &c, &s);
WORK(l) = c;
WORK(*n - 1 + l) = s;
zlasr_("R", "V", "B", n, &c__2, &WORK(l), &WORK(*n - 1 + l), &
Z(1,l), ldz);
} else {
dlae2_(&D(l), &E(l), &D(l + 1), &rt1, &rt2);
}
D(l) = rt1;
D(l + 1) = rt2;
E(l) = 0.;
l += 2;
if (l <= lend) {
goto L40;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (D(l + 1) - p) / (E(l) * 2.);
r = dlapy2_(&g, &c_b41);
g = D(m) - p + E(l) / (g + d_sign(&r, &g));
s = 1.;
c = 1.;
p = 0.;
/* Inner loop */
mm1 = m - 1;
i__1 = l;
for (i = mm1; i >= l; --i) {
f = s * E(i);
b = c * E(i);
dlartg_(&g, &f, &c, &s, &r);
if (i != m - 1) {
E(i + 1) = r;
}
g = D(i + 1) - p;
r = (D(i) - g) * s + c * 2. * b;
p = s * r;
D(i + 1) = g + p;
g = c * r - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
WORK(i) = c;
WORK(*n - 1 + i) = -s;
}
/* L70: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = m - l + 1;
zlasr_("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 */
d__2 = (d__1 = E(m - 1), abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = D(m), abs(d__1)) * (d__2 = D(m - 1),
abs(d__2)) + safmin) {
goto L110;
}
/* L100: */
}
}
m = lend;
L110:
if (m > lend) {
E(m - 1) = 0.;
}
p = D(l);
if (m == l) {
goto L130;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
to compute its eigensystem. */
if (m == l - 1) {
if (icompz > 0) {
dlaev2_(&D(l - 1), &E(l - 1), &D(l), &rt1, &rt2, &c, &s);
WORK(m) = c;
WORK(*n - 1 + m) = s;
zlasr_("R", "V", "F", n, &c__2, &WORK(m), &WORK(*n - 1 + m), &
Z(1,l-1), ldz);
} else {
dlae2_(&D(l - 1), &E(l - 1), &D(l), &rt1, &rt2);
}
D(l - 1) = rt1;
D(l) = rt2;
E(l - 1) = 0.;
l += -2;
if (l >= lend) {
goto L90;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (D(l - 1) - p) / (E(l - 1) * 2.);
r = dlapy2_(&g, &c_b41);
g = D(m) - p + E(l - 1) / (g + d_sign(&r, &g));
s = 1.;
c = 1.;
p = 0.;
/* Inner loop */
lm1 = l - 1;
i__1 = lm1;
for (i = m; i <= lm1; ++i) {
f = s * E(i);
b = c * E(i);
dlartg_(&g, &f, &c, &s, &r);
if (i != m) {
E(i - 1) = r;
}
g = D(i) - p;
r = (D(i + 1) - g) * s + c * 2. * b;
p = s * r;
D(i) = g + p;
g = c * r - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
WORK(i) = c;
WORK(*n - 1 + i) = s;
}
/* L120: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = l - m + 1;
zlasr_("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;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &D(lsv), n,
info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &E(lsv), n,
info);
} else if (iscale == 2) {
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &D(lsv), n,
info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &E(lsv), n,
info);
}
/* Check for no convergence to an eigenvalue after a total
of N*MAXIT iterations. */
if (jtot == nmaxit) {
i__1 = *n - 1;
for (i = 1; i <= *n-1; ++i) {
if (E(i) != 0.) {
++(*info);
}
/* L150: */
}
return 0;
}
goto L10;
/* Order eigenvalues and eigenvectors. */
L160:
if (icompz == 0) {
/* Use Quick Sort */
dlasrt_("I", n, &D(1), info);
} else {
/* Use Selection Sort to minimize swaps of eigenvectors */
i__1 = *n;
for (ii = 2; ii <= *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;
zswap_(n, &Z(1,i), &c__1, &Z(1,k), &
c__1);
}
/* L180: */
}
}
return 0;
/* End of ZSTEQR */
} /* zsteqr_ */
