int TRL::dstqrb_(integer_ * n, doublereal_ * d__, doublereal_ * e,
doublereal_ * z__, doublereal_ * work, integer_ * info)
{
/*
Purpose
=======
DSTQRB computes all eigenvalues and the last component of the eigenvectors of a
symmetric tridiagonal matrix using the implicit QL or QR method.
This is mainly a modification of the CLAPACK subroutine dsteqr.c
Arguments
=========
N (input) INTEGER
The order of the matrix. N >= 0.
D (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the diagonal elements of the tridiagonal matrix.
On exit, if INFO = 0, the eigenvalues in ascending order.
E (input/output) DOUBLE PRECISION array, dimension (N-1)
On entry, the (n-1) subdiagonal elements of the tridiagonal
matrix.
On exit, E has been destroyed.
Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
On entry, if COMPZ = 'V', then Z contains the orthogonal
matrix used in the reduction to tridiagonal form.
On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
orthonormal eigenvectors of the original symmetric matrix,
and if COMPZ = 'I', Z contains the orthonormal eigenvectors
of the symmetric tridiagonal matrix.
If COMPZ = 'N', then Z is not referenced.
WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
If COMPZ = 'N', then WORK is not referenced.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: the algorithm has failed to find all the eigenvalues in
a total of 30*N iterations; if INFO = i, then i
elements of E have not converged to zero; on exit, D
and E contain the elements of a symmetric tridiagonal
matrix which is orthogonally similar to the original
matrix.
=====================================================================
*/
/* Table of constant values */
doublereal_ c_b10 = 1.;
integer_ c__0 = 0;
integer_ c__1 = 1;
/* System generated locals */
integer_ i__1, i__2;
doublereal_ d__1, d__2;
/* Builtin functions */
//double sqrt_(doublereal_), d_sign(doublereal_ *, doublereal_ *);
//extern /* Subroutine */ int dlae2_(doublereal_ *, doublereal_ *, doublereal_
// *, doublereal_ *, doublereal_ *);
doublereal_ b, c__, f, g;
integer_ i__, j, k, l, m;
doublereal_ p, r__, s;
//extern logical_ lsame_(char *, char *);
//extern /* Subroutine */ int dlasr_(char *, char *, char *, integer_ *,
// integer_ *, doublereal_ *,
// doublereal_ *, doublereal_ *,
// integer_ *);
doublereal_ anorm;
//extern /* Subroutine */ int dswap_(integer_ *, doublereal_ *, integer_ *,
// doublereal_ *, integer_ *);
integer_ l1;
//extern /* Subroutine */ int dlaev2_(doublereal_ *, doublereal_ *,
// doublereal_ *, doublereal_ *,
// doublereal_ *, doublereal_ *,
// doublereal_ *);
integer_ lendm1, lendp1;
//extern doublereal_ dlapy2_(doublereal_ *, doublereal_ *);
integer_ ii;
//extern doublereal_ dlamch_(char *);
integer_ mm, iscale;
//extern /* Subroutine */ int dlascl_(char *, integer_ *, integer_ *,
// doublereal_ *, doublereal_ *,
// integer_ *, integer_ *, doublereal_ *,
// integer_ *, integer_ *),
// dlaset_(char *, integer_ *, integer_ *, doublereal_ *, doublereal_ *,
// doublereal_ *, integer_ *);
doublereal_ safmin;
//extern /* Subroutine */ int dlartg_(doublereal_ *, doublereal_ *,
// doublereal_ *, doublereal_ *,
// doublereal_ *);
doublereal_ safmax;
//extern /* Subroutine */ int xerbla_(char *, integer_ *);
//extern doublereal_ dlanst_(char *, integer_ *, doublereal_ *,
// doublereal_ *);
//extern /* Subroutine */ int dlasrt_(char *, integer_ *, doublereal_ *,
// integer_ *);
/* Local variables */
integer_ lend, jtot;
integer_ lendsv;
doublereal_ ssfmin;
integer_ nmaxit;
doublereal_ ssfmax;
integer_ lm1, mm1, nm1;
doublereal_ rt1, rt2, eps;
integer_ lsv;
doublereal_ tst, eps2;
--d__;
--e;
--z__;
/* z_dim1 = *ldz; */
/* z_offset = 1 + z_dim1 * 1; */
/* z__ -= z_offset; */
--work;
/* Function Body */
*info = 0;
/* Taken out for TRLan
if (lsame_(compz, "N")) {
icompz = 0;
} else if (lsame_(compz, "V")) {
icompz = 1;
} else if (lsame_(compz, "I")) {
icompz = 2;
} else {
icompz = -1;
}
if (icompz < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSTEQR", &i__1);
return 0;
}
*/
/* icompz = 2; */
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
z__[1] = 1;
return 0;
}
/* Determine the unit roundoff and over/underflow thresholds. */
eps = dlamch_("E");
/* Computing 2nd power */
d__1 = eps;
eps2 = d__1 * d__1;
safmin = dlamch_("S");
safmax = 1. / safmin;
ssfmax = sqrt_(safmax) / 3.;
ssfmin = sqrt_(safmin) / eps2;
/* Compute the eigenvalues and eigenvectors of the tridiagonal
matrix. */
/* Taken out for TRLan
if (icompz == 2) {
dlaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz);
}
*/
for (j = 1; j < *n; j++) {
z__[j] = 0.0;
}
z__[*n] = 1.0;
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], fabs(d__1));
if (tst == 0.) {
goto L30;
}
if (tst <=
sqrt_((d__1 = d__[m], fabs(d__1))) * sqrt_((d__2 =
d__[m + 1],
fabs(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], fabs(d__1)) < (d__2 = d__[l], fabs(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], fabs(d__1));
tst = d__2 * d__2;
if (tst <=
eps2 * (d__1 = d__[m], fabs(d__1)) * (d__2 =
d__[m + 1],
fabs(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) {
dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
work[l] = c__;
work[*n - 1 + l] = s;
/* Taken out for TRLan
dlasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], &
z___ref(1, l), ldz);
*/
tst = z__[l + 1];
z__[l + 1] = c__ * tst - s * z__[l];
z__[l] = s * tst + c__ * z__[l];
d__[l] = rt1;
d__[l + 1] = rt2;
e[l] = 0.;
l += 2;
if (l <= lend) {
goto L40;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l + 1] - p) / (e[l] * 2.);
r__ = dlapy2_(&g, &c_b10);
g = d__[m] - p + e[l] / (g + d_sign(&r__, &g));
s = 1.;
c__ = 1.;
p = 0.;
/* Inner loop */
mm1 = m - 1;
i__1 = l;
for (i__ = mm1; i__ >= i__1; --i__) {
f = s * e[i__];
b = c__ * e[i__];
dlartg_(&g, &f, &c__, &s, &r__);
if (i__ != m - 1) {
e[i__ + 1] = r__;
}
g = d__[i__ + 1] - p;
r__ = (d__[i__] - g) * s + c__ * 2. * b;
p = s * r__;
d__[i__ + 1] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
work[i__] = c__;
work[*n - 1 + i__] = -s;
/* L70: */
}
/* If eigenvectors are desired, then apply saved rotations. */
mm = m - l + 1;
/* Taken out for TRLan
dlasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &
z___ref(1, l), ldz);
*/
dlasr_("R", "V", "B", &c__1, &mm, &work[l], &work[*n - 1 + l],
&z__[l], &c__1);
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], fabs(d__1));
tst = d__2 * d__2;
if (tst <=
eps2 * (d__1 = d__[m], fabs(d__1)) * (d__2 =
d__[m - 1],
fabs(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) {
dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s);
/* Taken out for TRLan
work[m] = c__;
work[*n - 1 + m] = s;
dlasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], &
z___ref(1, l - 1), ldz);
*/
tst = z__[l];
z__[l] = c__ * tst - s * z__[l - 1];
z__[l - 1] = s * tst + c__ * z__[l - 1];
d__[l - 1] = rt1;
d__[l] = rt2;
e[l - 1] = 0.;
l += -2;
if (l >= lend) {
goto L90;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l - 1] - p) / (e[l - 1] * 2.);
r__ = dlapy2_(&g, &c_b10);
g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g));
s = 1.;
c__ = 1.;
p = 0.;
/* Inner loop */
lm1 = l - 1;
i__1 = lm1;
for (i__ = m; i__ <= i__1; ++i__) {
f = s * e[i__];
b = c__ * e[i__];
dlartg_(&g, &f, &c__, &s, &r__);
if (i__ != m) {
e[i__ - 1] = r__;
}
g = d__[i__] - p;
r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b;
p = s * r__;
d__[i__] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
work[i__] = c__;
work[*n - 1 + i__] = s;
/* L120: */
}
/* If eigenvectors are desired, then apply saved rotations. */
mm = l - m + 1;
/*
dlasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &
z___ref(1, m), ldz);
*/
dlasr_("R", "V", "F", &c__1, &mm, &work[m], &work[*n - 1 + m],
&z__[m], &c__1);
d__[l] -= p;
e[lm1] = g;
goto L90;
/* Eigenvalue found. */
L130:
d__[l] = p;
--l;
if (l >= lend) {
goto L90;
}
goto L140;
}
/* Undo scaling if necessary */
L140:
if (iscale == 1) {
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1,
&d__[lsv], n, info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv],
n, info);
} else if (iscale == 2) {
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1,
&d__[lsv], n, info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv],
n, info);
}
/* Check for no convergence to an eigenvalue after a total
of N*MAXIT iterations. */
if (jtot < nmaxit) {
goto L10;
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.) {
++(*info);
}
/* L150: */
}
goto L190;
/* Order eigenvalues and eigenvectors. */
L160:
/* 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;
/* Taken out for TRLan
dswap_(n, &z___ref(1, i__), &c__1, &z___ref(1, k), &c__1);
*/
p = z__[k];
z__[k] = z__[i__];
z__[i__] = p;
}
/* L180: */
}
L190:
return 0;
}
/* Subroutine */ int dlasdq_(char *uplo, integer *sqre, integer *n, integer *
ncvt, integer *nru, integer *ncc, doublereal *d__, doublereal *e,
doublereal *vt, integer *ldvt, doublereal *u, integer *ldu,
doublereal *c__, integer *ldc, doublereal *work, integer *info)
{
/* System generated locals */
integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
i__2;
/* Local variables */
static integer isub;
static doublereal smin;
static integer sqre1, i__, j;
static doublereal r__;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *), dswap_(integer *, doublereal *, integer *
, doublereal *, integer *);
static integer iuplo;
static doublereal cs, sn;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *), xerbla_(char *,
integer *), dbdsqr_(char *, integer *, integer *, integer
*, integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static logical rotate;
static integer np1;
#define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1]
#define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1]
#define vt_ref(a_1,a_2) vt[(a_2)*vt_dim1 + a_1]
/* -- LAPACK auxiliary 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
=======
DLASDQ computes the singular value decomposition (SVD) of a real
(upper or lower) bidiagonal matrix with diagonal D and offdiagonal
E, accumulating the transformations if desired. Letting B denote
the input bidiagonal matrix, the algorithm computes orthogonal
matrices Q and P such that B = Q * S * P' (P' denotes the transpose
of P). The singular values S are overwritten on D.
The input matrix U is changed to U * Q if desired.
The input matrix VT is changed to P' * VT if desired.
The input matrix C is changed to Q' * C if desired.
See "Computing Small Singular Values of Bidiagonal Matrices With
Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
LAPACK Working Note #3, for a detailed description of the algorithm.
Arguments
=========
UPLO (input) CHARACTER*1
On entry, UPLO specifies whether the input bidiagonal matrix
is upper or lower bidiagonal, and wether it is square are
not.
UPLO = 'U' or 'u' B is upper bidiagonal.
UPLO = 'L' or 'l' B is lower bidiagonal.
SQRE (input) INTEGER
= 0: then the input matrix is N-by-N.
= 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and
(N+1)-by-N if UPLU = 'L'.
The bidiagonal matrix has
N = NL + NR + 1 rows and
M = N + SQRE >= N columns.
N (input) INTEGER
On entry, N specifies the number of rows and columns
in the matrix. N must be at least 0.
NCVT (input) INTEGER
On entry, NCVT specifies the number of columns of
the matrix VT. NCVT must be at least 0.
NRU (input) INTEGER
On entry, NRU specifies the number of rows of
the matrix U. NRU must be at least 0.
NCC (input) INTEGER
On entry, NCC specifies the number of columns of
the matrix C. NCC must be at least 0.
D (input/output) DOUBLE PRECISION array, dimension (N)
On entry, D contains the diagonal entries of the
bidiagonal matrix whose SVD is desired. On normal exit,
D contains the singular values in ascending order.
E (input/output) DOUBLE PRECISION array.
dimension is (N-1) if SQRE = 0 and N if SQRE = 1.
On entry, the entries of E contain the offdiagonal entries
of the bidiagonal matrix whose SVD is desired. On normal
exit, E will contain 0. If the algorithm does not converge,
D and E will contain the diagonal and superdiagonal entries
of a bidiagonal matrix orthogonally equivalent to the one
given as input.
VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)
On entry, contains a matrix which on exit has been
premultiplied by P', dimension N-by-NCVT if SQRE = 0
and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0).
LDVT (input) INTEGER
On entry, LDVT specifies the leading dimension of VT as
declared in the calling (sub) program. LDVT must be at
least 1. If NCVT is nonzero LDVT must also be at least N.
U (input/output) DOUBLE PRECISION array, dimension (LDU, N)
On entry, contains a matrix which on exit has been
postmultiplied by Q, dimension NRU-by-N if SQRE = 0
and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0).
LDU (input) INTEGER
On entry, LDU specifies the leading dimension of U as
declared in the calling (sub) program. LDU must be at
least max( 1, NRU ) .
C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)
On entry, contains an N-by-NCC matrix which on exit
has been premultiplied by Q' dimension N-by-NCC if SQRE = 0
and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0).
LDC (input) INTEGER
On entry, LDC specifies the leading dimension of C as
declared in the calling (sub) program. LDC must be at
least 1. If NCC is nonzero, LDC must also be at least N.
WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
Workspace. Only referenced if one of NCVT, NRU, or NCC is
nonzero, and if N is at least 2.
INFO (output) INTEGER
On exit, a value of 0 indicates a successful exit.
If INFO < 0, argument number -INFO is illegal.
If INFO > 0, the algorithm did not converge, and INFO
specifies how many superdiagonals did not converge.
Further Details
===============
Based on contributions by
Ming Gu and Huan Ren, Computer Science Division, University of
California at Berkeley, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--e;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1 * 1;
vt -= vt_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
iuplo = 0;
if (lsame_(uplo, "U")) {
iuplo = 1;
}
if (lsame_(uplo, "L")) {
iuplo = 2;
}
if (iuplo == 0) {
*info = -1;
} else if (*sqre < 0 || *sqre > 1) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ncvt < 0) {
*info = -4;
} else if (*nru < 0) {
*info = -5;
} else if (*ncc < 0) {
*info = -6;
} else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) {
*info = -10;
} else if (*ldu < max(1,*nru)) {
*info = -12;
} else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) {
*info = -14;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLASDQ", &i__1);
return 0;
}
if (*n == 0) {
return 0;
}
/* ROTATE is true if any singular vectors desired, false otherwise */
rotate = *ncvt > 0 || *nru > 0 || *ncc > 0;
np1 = *n + 1;
sqre1 = *sqre;
/* If matrix non-square upper bidiagonal, rotate to be lower
bidiagonal. The rotations are on the right. */
if (iuplo == 1 && sqre1 == 1) {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
if (rotate) {
work[i__] = cs;
work[*n + i__] = sn;
}
/* L10: */
}
dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__);
d__[*n] = r__;
e[*n] = 0.;
if (rotate) {
work[*n] = cs;
work[*n + *n] = sn;
}
iuplo = 2;
sqre1 = 0;
/* Update singular vectors if desired. */
if (*ncvt > 0) {
dlasr_("L", "V", "F", &np1, ncvt, &work[1], &work[np1], &vt[
vt_offset], ldvt);
}
}
/* If matrix lower bidiagonal, rotate to be upper bidiagonal
by applying Givens rotations on the left. */
if (iuplo == 2) {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
if (rotate) {
work[i__] = cs;
work[*n + i__] = sn;
}
/* L20: */
}
/* If matrix (N+1)-by-N lower bidiagonal, one additional
rotation is needed. */
if (sqre1 == 1) {
dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__);
d__[*n] = r__;
if (rotate) {
work[*n] = cs;
work[*n + *n] = sn;
}
}
/* Update singular vectors if desired. */
if (*nru > 0) {
if (sqre1 == 0) {
dlasr_("R", "V", "F", nru, n, &work[1], &work[np1], &u[
u_offset], ldu);
} else {
dlasr_("R", "V", "F", nru, &np1, &work[1], &work[np1], &u[
u_offset], ldu);
}
}
if (*ncc > 0) {
if (sqre1 == 0) {
dlasr_("L", "V", "F", n, ncc, &work[1], &work[np1], &c__[
c_offset], ldc);
} else {
dlasr_("L", "V", "F", &np1, ncc, &work[1], &work[np1], &c__[
c_offset], ldc);
}
}
}
/* Call DBDSQR to compute the SVD of the reduced real
N-by-N upper bidiagonal matrix. */
dbdsqr_("U", n, ncvt, nru, ncc, &d__[1], &e[1], &vt[vt_offset], ldvt, &u[
u_offset], ldu, &c__[c_offset], ldc, &work[1], info);
/* Sort the singular values into ascending order (insertion sort on
singular values, but only one transposition per singular vector) */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Scan for smallest D(I). */
isub = i__;
smin = d__[i__];
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
if (d__[j] < smin) {
isub = j;
smin = d__[j];
}
/* L30: */
}
if (isub != i__) {
/* Swap singular values and vectors. */
d__[isub] = d__[i__];
d__[i__] = smin;
if (*ncvt > 0) {
dswap_(ncvt, &vt_ref(isub, 1), ldvt, &vt_ref(i__, 1), ldvt);
}
if (*nru > 0) {
dswap_(nru, &u_ref(1, isub), &c__1, &u_ref(1, i__), &c__1);
}
if (*ncc > 0) {
dswap_(ncc, &c___ref(isub, 1), ldc, &c___ref(i__, 1), ldc);
}
}
/* L40: */
}
return 0;
/* End of DLASDQ */
} /* dlasdq_ */
/* Subroutine */ int dbdsqr_(char *uplo, integer *n, integer *ncvt, integer *
nru, integer *ncc, doublereal *d__, doublereal *e, doublereal *vt,
integer *ldvt, doublereal *u, integer *ldu, doublereal *c__, integer *
ldc, doublereal *work, integer *info)
{
/* System generated locals */
integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
i__2;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *), sqrt(doublereal), d_sign(
doublereal *, doublereal *);
/* Local variables */
doublereal f, g, h__;
integer i__, j, m;
doublereal r__, cs;
integer ll;
doublereal sn, mu;
integer nm1, nm12, nm13, lll;
doublereal eps, sll, tol, abse;
integer idir;
doublereal abss;
integer oldm;
doublereal cosl;
integer isub, iter;
doublereal unfl, sinl, cosr, smin, smax, sinr;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *), dlas2_(
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
doublereal oldcs;
extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *);
integer oldll;
doublereal shift, sigmn, oldsn;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer maxit;
doublereal sminl, sigmx;
logical lower;
extern /* Subroutine */ int dlasq1_(integer *, doublereal *, doublereal *,
doublereal *, integer *), dlasv2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *), xerbla_(char *,
integer *);
doublereal sminoa, thresh;
logical rotate;
doublereal tolmul;
/* -- LAPACK routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DBDSQR computes the singular values and, optionally, the right and/or */
/* left singular vectors from the singular value decomposition (SVD) of */
/* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit */
/* zero-shift QR algorithm. The SVD of B has the form */
/* B = Q * S * P**T */
/* where S is the diagonal matrix of singular values, Q is an orthogonal */
/* matrix of left singular vectors, and P is an orthogonal matrix of */
/* right singular vectors. If left singular vectors are requested, this */
/* subroutine actually returns U*Q instead of Q, and, if right singular */
/* vectors are requested, this subroutine returns P**T*VT instead of */
/* P**T, for given real input matrices U and VT. When U and VT are the */
/* orthogonal matrices that reduce a general matrix A to bidiagonal */
/* form: A = U*B*VT, as computed by DGEBRD, then */
/* A = (U*Q) * S * (P**T*VT) */
/* is the SVD of A. Optionally, the subroutine may also compute Q**T*C */
/* for a given real input matrix 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-1) */
/* On entry, the N-1 offdiagonal elements of the bidiagonal */
/* matrix B. */
/* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E */
/* will contain the diagonal and superdiagonal elements of a */
/* bidiagonal matrix orthogonally equivalent to the one given */
/* as input. */
/* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) */
/* On entry, an N-by-NCVT matrix VT. */
/* On exit, VT is overwritten by P**T * VT. */
/* Not referenced if NCVT = 0. */
/* LDVT (input) INTEGER */
/* The leading dimension of the array VT. */
/* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. */
/* U (input/output) DOUBLE PRECISION array, dimension (LDU, N) */
/* On entry, an NRU-by-N matrix U. */
/* On exit, U is overwritten by U * Q. */
/* Not referenced if NRU = 0. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= max(1,NRU). */
/* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) */
/* On entry, an N-by-NCC matrix C. */
/* On exit, C is overwritten by Q**T * C. */
/* Not referenced if NCC = 0. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. */
/* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
/* if NCVT = NRU = NCC = 0, (max(1, 4*N)) otherwise */
/* 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
lower = lsame_(uplo, "L");
if (! lsame_(uplo, "U") && ! lower) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ncvt < 0) {
*info = -3;
} else if (*nru < 0) {
*info = -4;
} else if (*ncc < 0) {
*info = -5;
} else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) {
*info = -9;
} else if (*ldu < max(1,*nru)) {
*info = -11;
} else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DBDSQR", &i__1);
return 0;
}
if (*n == 0) {
return 0;
}
if (*n == 1) {
goto L160;
}
/* ROTATE is true if any singular vectors desired, false otherwise */
rotate = *ncvt > 0 || *nru > 0 || *ncc > 0;
/* If no singular vectors desired, use qd algorithm */
if (! rotate) {
dlasq1_(n, &d__[1], &e[1], &work[1], info);
return 0;
}
nm1 = *n - 1;
nm12 = nm1 + nm1;
nm13 = nm12 + nm1;
idir = 0;
/* Get machine constants */
eps = dlamch_("Epsilon");
unfl = dlamch_("Safe minimum");
/* If matrix lower bidiagonal, rotate to be upper bidiagonal */
/* by applying Givens rotations on the left */
if (lower) {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
work[i__] = cs;
work[nm1 + i__] = sn;
/* L10: */
}
/* Update singular vectors if desired */
if (*nru > 0) {
dlasr_("R", "V", "F", nru, n, &work[1], &work[*n], &u[u_offset],
ldu);
}
if (*ncc > 0) {
dlasr_("L", "V", "F", n, ncc, &work[1], &work[*n], &c__[c_offset],
ldc);
}
}
/* Compute singular values to relative accuracy TOL */
/* (By setting TOL to be negative, algorithm will compute */
/* singular values to absolute accuracy ABS(TOL)*norm(input matrix)) */
/* Computing MAX */
/* Computing MIN */
d__3 = 100., d__4 = pow_dd(&eps, &c_b15);
d__1 = 10., d__2 = min(d__3,d__4);
tolmul = max(d__1,d__2);
tol = tolmul * eps;
/* Compute approximate maximum, minimum singular values */
smax = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = smax, d__3 = (d__1 = d__[i__], abs(d__1));
smax = max(d__2,d__3);
/* L20: */
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = smax, d__3 = (d__1 = e[i__], abs(d__1));
smax = max(d__2,d__3);
/* L30: */
}
sminl = 0.;
if (tol >= 0.) {
/* Relative accuracy desired */
sminoa = abs(d__[1]);
if (sminoa == 0.) {
goto L50;
}
mu = sminoa;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
mu = (d__2 = d__[i__], abs(d__2)) * (mu / (mu + (d__1 = e[i__ - 1]
, abs(d__1))));
sminoa = min(sminoa,mu);
if (sminoa == 0.) {
goto L50;
}
/* L40: */
}
L50:
sminoa /= sqrt((doublereal) (*n));
/* Computing MAX */
d__1 = tol * sminoa, d__2 = *n * 6 * *n * unfl;
thresh = max(d__1,d__2);
} else {
/* Absolute accuracy desired */
/* Computing MAX */
d__1 = abs(tol) * smax, d__2 = *n * 6 * *n * unfl;
thresh = max(d__1,d__2);
}
/* Prepare for main iteration loop for the singular values */
/* (MAXIT is the maximum number of passes through the inner */
/* loop permitted before nonconvergence signalled.) */
maxit = *n * 6 * *n;
iter = 0;
oldll = -1;
oldm = -1;
/* M points to last element of unconverged part of matrix */
m = *n;
/* Begin main iteration loop */
L60:
/* Check for convergence or exceeding iteration count */
if (m <= 1) {
goto L160;
}
if (iter > maxit) {
goto L200;
}
/* Find diagonal block of matrix to work on */
if (tol < 0. && (d__1 = d__[m], abs(d__1)) <= thresh) {
d__[m] = 0.;
}
smax = (d__1 = d__[m], abs(d__1));
smin = smax;
i__1 = m - 1;
for (lll = 1; lll <= i__1; ++lll) {
ll = m - lll;
abss = (d__1 = d__[ll], abs(d__1));
abse = (d__1 = e[ll], abs(d__1));
if (tol < 0. && abss <= thresh) {
d__[ll] = 0.;
}
if (abse <= thresh) {
goto L80;
}
smin = min(smin,abss);
/* Computing MAX */
d__1 = max(smax,abss);
smax = max(d__1,abse);
/* L70: */
}
ll = 0;
goto L90;
L80:
e[ll] = 0.;
/* Matrix splits since E(LL) = 0 */
if (ll == m - 1) {
/* Convergence of bottom singular value, return to top of loop */
--m;
goto L60;
}
L90:
++ll;
/* E(LL) through E(M-1) are nonzero, E(LL-1) is zero */
if (ll == m - 1) {
/* 2 by 2 block, handle separately */
dlasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr,
&sinl, &cosl);
d__[m - 1] = sigmx;
e[m - 1] = 0.;
d__[m] = sigmn;
/* Compute singular vectors, if desired */
if (*ncvt > 0) {
drot_(ncvt, &vt[m - 1 + vt_dim1], ldvt, &vt[m + vt_dim1], ldvt, &
cosr, &sinr);
}
if (*nru > 0) {
drot_(nru, &u[(m - 1) * u_dim1 + 1], &c__1, &u[m * u_dim1 + 1], &
c__1, &cosl, &sinl);
}
if (*ncc > 0) {
drot_(ncc, &c__[m - 1 + c_dim1], ldc, &c__[m + c_dim1], 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;
}
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;
}
mu = (d__2 = d__[lll], abs(d__2)) * (mu / (mu + (d__1 = e[lll]
, abs(d__1))));
sminl = min(sminl,mu);
/* L110: */
}
}
}
oldll = ll;
oldm = m;
/* Compute shift. First, test if shifting would ruin relative */
/* accuracy, and if so set the shift to zero. */
/* Computing MAX */
d__1 = eps, d__2 = tol * .01;
if (tol >= 0. && *n * tol * (sminl / smax) <= max(d__1,d__2)) {
/* Use a zero shift to avoid loss of relative accuracy */
shift = 0.;
} else {
/* Compute the shift from 2-by-2 block at end of matrix */
if (idir == 1) {
sll = (d__1 = d__[ll], abs(d__1));
dlas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__);
} else {
sll = (d__1 = d__[m], abs(d__1));
dlas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__);
}
/* Test if shift negligible, and if so set to zero */
if (sll > 0.) {
/* Computing 2nd power */
d__1 = shift / sll;
if (d__1 * d__1 < eps) {
shift = 0.;
}
}
}
/* Increment iteration count */
iter = iter + m - ll;
/* If SHIFT = 0, do simplified QR iteration */
if (shift == 0.) {
if (idir == 1) {
/* Chase bulge from top to bottom */
/* Save cosines and sines for later singular vector updates */
cs = 1.;
oldcs = 1.;
i__1 = m - 1;
for (i__ = ll; i__ <= i__1; ++i__) {
d__1 = d__[i__] * cs;
dlartg_(&d__1, &e[i__], &cs, &sn, &r__);
if (i__ > ll) {
e[i__ - 1] = oldsn * r__;
}
d__1 = oldcs * r__;
d__2 = d__[i__ + 1] * sn;
dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
work[i__ - ll + 1] = cs;
work[i__ - ll + 1 + nm1] = sn;
work[i__ - ll + 1 + nm12] = oldcs;
work[i__ - ll + 1 + nm13] = oldsn;
/* L120: */
}
h__ = d__[m] * cs;
d__[m] = h__ * oldcs;
e[m - 1] = h__ * oldsn;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[
ll + vt_dim1], ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
dlasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13
+ 1], &u[ll * u_dim1 + 1], ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13
+ 1], &c__[ll + c_dim1], ldc);
}
/* Test convergence */
if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
e[m - 1] = 0.;
}
} else {
/* Chase bulge from bottom to top */
/* Save cosines and sines for later singular vector updates */
cs = 1.;
oldcs = 1.;
i__1 = ll + 1;
for (i__ = m; i__ >= i__1; --i__) {
d__1 = d__[i__] * cs;
dlartg_(&d__1, &e[i__ - 1], &cs, &sn, &r__);
if (i__ < m) {
e[i__] = oldsn * r__;
}
d__1 = oldcs * r__;
d__2 = d__[i__ - 1] * sn;
dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
work[i__ - ll] = cs;
work[i__ - ll + nm1] = -sn;
work[i__ - ll + nm12] = oldcs;
work[i__ - ll + nm13] = -oldsn;
/* L130: */
}
h__ = d__[ll] * cs;
d__[ll] = h__ * oldcs;
e[ll] = h__ * oldsn;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[
nm13 + 1], &vt[ll + vt_dim1], ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
dlasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll *
u_dim1 + 1], ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &c__[
ll + c_dim1], ldc);
}
/* Test convergence */
if ((d__1 = e[ll], abs(d__1)) <= thresh) {
e[ll] = 0.;
}
}
} else {
/* Use nonzero shift */
if (idir == 1) {
/* Chase bulge from top to bottom */
/* Save cosines and sines for later singular vector updates */
f = ((d__1 = d__[ll], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[
ll]) + shift / d__[ll]);
g = e[ll];
i__1 = m - 1;
for (i__ = ll; i__ <= i__1; ++i__) {
dlartg_(&f, &g, &cosr, &sinr, &r__);
if (i__ > ll) {
e[i__ - 1] = r__;
}
f = cosr * d__[i__] + sinr * e[i__];
e[i__] = cosr * e[i__] - sinr * d__[i__];
g = sinr * d__[i__ + 1];
d__[i__ + 1] = cosr * d__[i__ + 1];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[i__] = r__;
f = cosl * e[i__] + sinl * d__[i__ + 1];
d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__];
if (i__ < m - 1) {
g = sinl * e[i__ + 1];
e[i__ + 1] = cosl * e[i__ + 1];
}
work[i__ - ll + 1] = cosr;
work[i__ - ll + 1 + nm1] = sinr;
work[i__ - ll + 1 + nm12] = cosl;
work[i__ - ll + 1 + nm13] = sinl;
/* L140: */
}
e[m - 1] = f;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[
ll + vt_dim1], ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
dlasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13
+ 1], &u[ll * u_dim1 + 1], ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13
+ 1], &c__[ll + c_dim1], ldc);
}
/* Test convergence */
if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
e[m - 1] = 0.;
}
} else {
/* Chase bulge from bottom to top */
/* Save cosines and sines for later singular vector updates */
f = ((d__1 = d__[m], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[m]
) + shift / d__[m]);
g = e[m - 1];
i__1 = ll + 1;
for (i__ = m; i__ >= i__1; --i__) {
dlartg_(&f, &g, &cosr, &sinr, &r__);
if (i__ < m) {
e[i__] = r__;
}
f = cosr * d__[i__] + sinr * e[i__ - 1];
e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__];
g = sinr * d__[i__ - 1];
d__[i__ - 1] = cosr * d__[i__ - 1];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[i__] = r__;
f = cosl * e[i__ - 1] + sinl * d__[i__ - 1];
d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1];
if (i__ > ll + 1) {
g = sinl * e[i__ - 2];
e[i__ - 2] = cosl * e[i__ - 2];
}
work[i__ - ll] = cosr;
work[i__ - ll + nm1] = -sinr;
work[i__ - ll + nm12] = cosl;
work[i__ - ll + nm13] = -sinl;
/* L150: */
}
e[ll] = f;
/* Test convergence */
if ((d__1 = e[ll], abs(d__1)) <= thresh) {
e[ll] = 0.;
}
/* Update singular vectors if desired */
if (*ncvt > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[
nm13 + 1], &vt[ll + vt_dim1], ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
dlasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll *
u_dim1 + 1], ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &c__[
ll + c_dim1], ldc);
}
}
}
/* QR iteration finished, go back and check convergence */
goto L60;
/* All singular values converged, so make them positive */
L160:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] < 0.) {
d__[i__] = -d__[i__];
/* Change sign of singular vectors, if desired */
if (*ncvt > 0) {
dscal_(ncvt, &c_b72, &vt[i__ + vt_dim1], ldvt);
}
}
/* L170: */
}
/* Sort the singular values into decreasing order (insertion sort on */
/* singular values, but only one transposition per singular vector) */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Scan for smallest D(I) */
isub = 1;
smin = d__[1];
i__2 = *n + 1 - i__;
for (j = 2; j <= i__2; ++j) {
if (d__[j] <= smin) {
isub = j;
smin = d__[j];
}
/* L180: */
}
if (isub != *n + 1 - i__) {
/* Swap singular values and vectors */
d__[isub] = d__[*n + 1 - i__];
d__[*n + 1 - i__] = smin;
if (*ncvt > 0) {
dswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[*n + 1 - i__ +
vt_dim1], ldvt);
}
if (*nru > 0) {
dswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[(*n + 1 - i__) *
u_dim1 + 1], &c__1);
}
if (*ncc > 0) {
dswap_(ncc, &c__[isub + c_dim1], ldc, &c__[*n + 1 - i__ +
c_dim1], ldc);
}
}
/* L190: */
}
goto L220;
/* Maximum number of iterations exceeded, failure to converge */
L200:
*info = 0;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.) {
++(*info);
}
/* L210: */
}
L220:
return 0;
/* End of DBDSQR */
} /* dbdsqr_ */
/* Subroutine */
int dsteqr_(char *compz, integer *n, doublereal *d__, doublereal *e, doublereal *z__, integer *ldz, doublereal *work, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
doublereal b, c__, f, g;
integer i__, j, k, l, m;
doublereal p, r__, s;
integer l1, ii, mm, lm1, mm1, nm1;
doublereal rt1, rt2, eps;
integer lsv;
doublereal tst, eps2;
integer lend, jtot;
extern /* Subroutine */
int dlae2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *);
extern logical lsame_(char *, char *);
extern /* Subroutine */
int dlasr_(char *, char *, char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *);
doublereal anorm;
extern /* Subroutine */
int dswap_(integer *, doublereal *, integer *, doublereal *, integer *), dlaev2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *);
integer lendm1, lendp1;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
integer iscale;
extern /* Subroutine */
int dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *), dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *);
doublereal safmin;
extern /* Subroutine */
int dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *);
doublereal safmax;
extern /* Subroutine */
int xerbla_(char *, integer *);
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */
int dlasrt_(char *, integer *, doublereal *, integer *);
integer lendsv;
doublereal ssfmin;
integer nmaxit, icompz;
doublereal ssfmax;
/* -- LAPACK 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_("DSTEQR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
if (*n == 1)
{
if (icompz == 2)
{
z__[z_dim1 + 1] = 1.;
}
return 0;
}
/* Determine the unit roundoff and over/underflow thresholds. */
eps = dlamch_("E");
/* Computing 2nd power */
d__1 = eps;
eps2 = d__1 * d__1;
safmin = dlamch_("S");
safmax = 1. / safmin;
ssfmax = sqrt(safmax) / 3.;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues and eigenvectors of the tridiagonal */
/* matrix. */
if (icompz == 2)
{
dlaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz);
}
nmaxit = *n * 30;
jtot = 0;
/* Determine where the matrix splits and choose QL or QR iteration */
/* for each block, according to whether top or bottom diagonal */
/* element is smaller. */
l1 = 1;
nm1 = *n - 1;
L10:
if (l1 > *n)
{
goto L160;
}
if (l1 > 1)
{
e[l1 - 1] = 0.;
}
if (l1 <= nm1)
{
i__1 = nm1;
for (m = l1;
m <= i__1;
++m)
{
tst = (d__1 = e[m], abs(d__1));
if (tst == 0.)
{
goto L30;
}
if (tst <= sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m + 1], abs(d__2))) * eps)
{
e[m] = 0.;
goto L30;
}
/* L20: */
}
}
m = *n;
L30:
l = l1;
lsv = l;
lend = m;
lendsv = lend;
l1 = m + 1;
if (lend == l)
{
goto L10;
}
/* Scale submatrix in rows and columns L to LEND */
i__1 = lend - l + 1;
anorm = dlanst_("M", &i__1, &d__[l], &e[l]);
iscale = 0;
if (anorm == 0.)
{
goto L10;
}
if (anorm > ssfmax)
{
iscale = 1;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, info);
}
else if (anorm < ssfmin)
{
iscale = 2;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, info);
}
/* Choose between QL and QR iteration */
if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2)))
{
lend = lsv;
l = lendsv;
}
if (lend > l)
{
/* QL Iteration */
/* Look for small subdiagonal element. */
L40:
if (l != lend)
{
lendm1 = lend - 1;
i__1 = lendm1;
for (m = l;
m <= i__1;
++m)
{
/* Computing 2nd power */
d__2 = (d__1 = e[m], abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m + 1], abs(d__2)) + safmin)
{
goto L60;
}
/* L50: */
}
}
m = lend;
L60:
if (m < lend)
{
e[m] = 0.;
}
p = d__[l];
if (m == l)
{
goto L80;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */
/* to compute its eigensystem. */
if (m == l + 1)
{
if (icompz > 0)
{
dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
work[l] = c__;
work[*n - 1 + l] = s;
dlasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], & z__[l * z_dim1 + 1], ldz);
}
else
{
dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
}
d__[l] = rt1;
d__[l + 1] = rt2;
e[l] = 0.;
l += 2;
if (l <= lend)
{
goto L40;
}
goto L140;
}
if (jtot == nmaxit)
{
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l + 1] - p) / (e[l] * 2.);
r__ = dlapy2_(&g, &c_b10);
g = d__[m] - p + e[l] / (g + d_sign(&r__, &g));
s = 1.;
c__ = 1.;
p = 0.;
/* Inner loop */
mm1 = m - 1;
i__1 = l;
for (i__ = mm1;
i__ >= i__1;
--i__)
{
f = s * e[i__];
b = c__ * e[i__];
dlartg_(&g, &f, &c__, &s, &r__);
if (i__ != m - 1)
{
e[i__ + 1] = r__;
}
g = d__[i__ + 1] - p;
r__ = (d__[i__] - g) * s + c__ * 2. * b;
p = s * r__;
d__[i__ + 1] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0)
{
work[i__] = c__;
work[*n - 1 + i__] = -s;
}
/* L70: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0)
{
mm = m - l + 1;
dlasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l * z_dim1 + 1], ldz);
}
d__[l] -= p;
e[l] = g;
goto L40;
/* Eigenvalue found. */
L80:
d__[l] = p;
++l;
if (l <= lend)
{
goto L40;
}
goto L140;
}
else
{
/* QR Iteration */
/* Look for small superdiagonal element. */
L90:
if (l != lend)
{
lendp1 = lend + 1;
i__1 = lendp1;
for (m = l;
m >= i__1;
--m)
{
/* Computing 2nd power */
d__2 = (d__1 = e[m - 1], abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m - 1], abs(d__2)) + safmin)
{
goto L110;
}
/* L100: */
}
}
m = lend;
L110:
if (m > lend)
{
e[m - 1] = 0.;
}
p = d__[l];
if (m == l)
{
goto L130;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */
/* to compute its eigensystem. */
if (m == l - 1)
{
if (icompz > 0)
{
dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s) ;
work[m] = c__;
work[*n - 1 + m] = s;
dlasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], & z__[(l - 1) * z_dim1 + 1], ldz);
}
else
{
dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
}
d__[l - 1] = rt1;
d__[l] = rt2;
e[l - 1] = 0.;
l += -2;
if (l >= lend)
{
goto L90;
}
goto L140;
}
if (jtot == nmaxit)
{
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l - 1] - p) / (e[l - 1] * 2.);
r__ = dlapy2_(&g, &c_b10);
g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g));
s = 1.;
c__ = 1.;
p = 0.;
/* Inner loop */
lm1 = l - 1;
i__1 = lm1;
for (i__ = m;
i__ <= i__1;
++i__)
{
f = s * e[i__];
b = c__ * e[i__];
dlartg_(&g, &f, &c__, &s, &r__);
if (i__ != m)
{
e[i__ - 1] = r__;
}
g = d__[i__] - p;
r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b;
p = s * r__;
d__[i__] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0)
{
work[i__] = c__;
work[*n - 1 + i__] = s;
}
/* L120: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0)
{
mm = l - m + 1;
dlasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m * z_dim1 + 1], ldz);
}
d__[l] -= p;
e[lm1] = g;
goto L90;
/* Eigenvalue found. */
L130:
d__[l] = p;
--l;
if (l >= lend)
{
goto L90;
}
goto L140;
}
/* Undo scaling if necessary */
L140:
if (iscale == 1)
{
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], n, info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n, info);
}
else if (iscale == 2)
{
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], n, info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n, info);
}
/* Check for no convergence to an eigenvalue after a total */
/* of N*MAXIT iterations. */
if (jtot < nmaxit)
{
goto L10;
}
i__1 = *n - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if (e[i__] != 0.)
{
++(*info);
}
/* L150: */
}
goto L190;
/* Order eigenvalues and eigenvectors. */
L160:
if (icompz == 0)
{
/* Use Quick Sort */
dlasrt_("I", n, &d__[1], info);
}
else
{
/* Use Selection Sort to minimize swaps of eigenvectors */
i__1 = *n;
for (ii = 2;
ii <= i__1;
++ii)
{
i__ = ii - 1;
k = i__;
p = d__[i__];
i__2 = *n;
for (j = ii;
j <= i__2;
++j)
{
if (d__[j] < p)
{
k = j;
p = d__[j];
}
/* L170: */
}
if (k != i__)
{
d__[k] = d__[i__];
d__[i__] = p;
dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1], &c__1);
}
/* L180: */
}
}
L190:
return 0;
/* End of DSTEQR */
}
/*< SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) >*/
/* Subroutine */ int dsteqr_(char *compz, integer *n, doublereal *d__,
doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
integer *info, ftnlen compz_len)
{
/* 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_(const char *, const char *, ftnlen, ftnlen);
extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen, ftnlen);
doublereal anorm;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *), dlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
integer lendm1, lendp1;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *,
ftnlen);
integer iscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, ftnlen), dlaset_(char *, integer *, integer
*, doublereal *, doublereal *, doublereal *, integer *, ftnlen);
doublereal safmin;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
doublereal safmax;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *,
ftnlen);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *, ftnlen);
integer lendsv;
doublereal ssfmin;
integer nmaxit, icompz;
doublereal ssfmax;
/* -- LAPACK routine (version 3.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2006 */
/* .. Scalar Arguments .. */
/*< CHARACTER COMPZ >*/
/*< INTEGER INFO, LDZ, N >*/
/* .. */
/* .. Array Arguments .. */
/*< DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) >*/
/* .. */
/* Purpose */
/* ======= */
/* DSTEQR computes all eigenvalues and, optionally, eigenvectors of a */
/* symmetric tridiagonal matrix using the implicit QL or QR method. */
/* The eigenvectors of a full or band symmetric matrix can also be found */
/* if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to */
/* tridiagonal form. */
/* Arguments */
/* ========= */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only. */
/* = 'V': Compute eigenvalues and eigenvectors of the original */
/* symmetric matrix. On entry, Z must contain the */
/* orthogonal matrix used to reduce the original matrix */
/* to tridiagonal form. */
/* = 'I': Compute eigenvalues and eigenvectors of the */
/* tridiagonal matrix. Z is initialized to the identity */
/* matrix. */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the diagonal elements of the tridiagonal matrix. */
/* On exit, if INFO = 0, the eigenvalues in ascending order. */
/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
/* matrix. */
/* On exit, E has been destroyed. */
/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) */
/* On entry, if COMPZ = 'V', then Z contains the orthogonal */
/* matrix used in the reduction to tridiagonal form. */
/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */
/* orthonormal eigenvectors of the original symmetric matrix, */
/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */
/* of the symmetric tridiagonal matrix. */
/* If COMPZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* eigenvectors are desired, then LDZ >= max(1,N). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) */
/* If COMPZ = 'N', then WORK is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: the algorithm has failed to find all the eigenvalues in */
/* a total of 30*N iterations; if INFO = i, then i */
/* elements of E have not converged to zero; on exit, D */
/* and E contain the elements of a symmetric tridiagonal */
/* matrix which is orthogonally similar to the original */
/* matrix. */
/* ===================================================================== */
/* .. Parameters .. */
/*< DOUBLE PRECISION ZERO, ONE, TWO, THREE >*/
/*< >*/
/*< INTEGER MAXIT >*/
/*< PARAMETER ( MAXIT = 30 ) >*/
/* .. */
/* .. Local Scalars .. */
/*< >*/
/*< >*/
/* .. */
/* .. External Functions .. */
/*< LOGICAL LSAME >*/
/*< DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 >*/
/*< EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 >*/
/* .. */
/* .. External Subroutines .. */
/*< >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC ABS, MAX, SIGN, SQRT >*/
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/*< INFO = 0 >*/
/* Parameter adjustments */
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
/*< IF( LSAME( COMPZ, 'N' ) ) THEN >*/
if (lsame_(compz, "N", (ftnlen)1, (ftnlen)1)) {
/*< ICOMPZ = 0 >*/
icompz = 0;
/*< ELSE IF( LSAME( COMPZ, 'V' ) ) THEN >*/
} else if (lsame_(compz, "V", (ftnlen)1, (ftnlen)1)) {
/*< ICOMPZ = 1 >*/
icompz = 1;
/*< ELSE IF( LSAME( COMPZ, 'I' ) ) THEN >*/
} else if (lsame_(compz, "I", (ftnlen)1, (ftnlen)1)) {
/*< ICOMPZ = 2 >*/
icompz = 2;
/*< ELSE >*/
} else {
/*< ICOMPZ = -1 >*/
icompz = -1;
/*< END IF >*/
}
/*< IF( ICOMPZ.LT.0 ) THEN >*/
if (icompz < 0) {
/*< INFO = -1 >*/
*info = -1;
/*< ELSE IF( N.LT.0 ) THEN >*/
} else if (*n < 0) {
/*< INFO = -2 >*/
*info = -2;
/*< >*/
} else if (*ldz < 1 || (icompz > 0 && *ldz < max(1,*n))) {
/*< INFO = -6 >*/
*info = -6;
/*< END IF >*/
}
/*< IF( INFO.NE.0 ) THEN >*/
if (*info != 0) {
/*< CALL XERBLA( 'DSTEQR', -INFO ) >*/
i__1 = -(*info);
xerbla_("DSTEQR", &i__1, (ftnlen)6);
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/* Quick return if possible */
/*< >*/
if (*n == 0) {
return 0;
}
/*< IF( N.EQ.1 ) THEN >*/
if (*n == 1) {
/*< >*/
if (icompz == 2) {
z__[z_dim1 + 1] = 1.;
}
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/* Determine the unit roundoff and over/underflow thresholds. */
/*< EPS = DLAMCH( 'E' ) >*/
eps = dlamch_("E", (ftnlen)1);
/*< EPS2 = EPS**2 >*/
/* Computing 2nd power */
d__1 = eps;
eps2 = d__1 * d__1;
/*< SAFMIN = DLAMCH( 'S' ) >*/
safmin = dlamch_("S", (ftnlen)1);
/*< SAFMAX = ONE / SAFMIN >*/
safmax = 1. / safmin;
/*< SSFMAX = SQRT( SAFMAX ) / THREE >*/
ssfmax = sqrt(safmax) / 3.;
/*< SSFMIN = SQRT( SAFMIN ) / EPS2 >*/
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues and eigenvectors of the tridiagonal */
/* matrix. */
/*< >*/
if (icompz == 2) {
dlaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz, (ftnlen)4);
}
/*< NMAXIT = N*MAXIT >*/
nmaxit = *n * 30;
/*< JTOT = 0 >*/
jtot = 0;
/* Determine where the matrix splits and choose QL or QR iteration */
/* for each block, according to whether top or bottom diagonal */
/* element is smaller. */
/*< L1 = 1 >*/
l1 = 1;
/*< NM1 = N - 1 >*/
nm1 = *n - 1;
/*< 10 CONTINUE >*/
L10:
/*< >*/
if (l1 > *n) {
goto L160;
}
/*< >*/
if (l1 > 1) {
e[l1 - 1] = 0.;
}
/*< IF( L1.LE.NM1 ) THEN >*/
if (l1 <= nm1) {
/*< DO 20 M = L1, NM1 >*/
i__1 = nm1;
for (m = l1; m <= i__1; ++m) {
/*< TST = ABS( E( M ) ) >*/
tst = (d__1 = e[m], abs(d__1));
/*< >*/
if (tst == 0.) {
goto L30;
}
/*< >*/
if (tst <= sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m
+ 1], abs(d__2))) * eps) {
/*< E( M ) = ZERO >*/
e[m] = 0.;
/*< GO TO 30 >*/
goto L30;
/*< END IF >*/
}
/*< 20 CONTINUE >*/
/* L20: */
}
/*< END IF >*/
}
/*< M = N >*/
m = *n;
/*< 30 CONTINUE >*/
L30:
/*< L = L1 >*/
l = l1;
/*< LSV = L >*/
lsv = l;
/*< LEND = M >*/
lend = m;
/*< LENDSV = LEND >*/
lendsv = lend;
/*< L1 = M + 1 >*/
l1 = m + 1;
/*< >*/
if (lend == l) {
goto L10;
}
/* Scale submatrix in rows and columns L to LEND */
/*< ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) ) >*/
i__1 = lend - l + 1;
anorm = dlanst_("I", &i__1, &d__[l], &e[l], (ftnlen)1);
/*< ISCALE = 0 >*/
iscale = 0;
/*< >*/
if (anorm == 0.) {
goto L10;
}
/*< IF( ANORM.GT.SSFMAX ) THEN >*/
if (anorm > ssfmax) {
/*< ISCALE = 1 >*/
iscale = 1;
/*< >*/
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
info, (ftnlen)1);
/*< >*/
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
info, (ftnlen)1);
/*< ELSE IF( ANORM.LT.SSFMIN ) THEN >*/
} else if (anorm < ssfmin) {
/*< ISCALE = 2 >*/
iscale = 2;
/*< >*/
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
info, (ftnlen)1);
/*< >*/
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
info, (ftnlen)1);
/*< END IF >*/
}
/* Choose between QL and QR iteration */
/*< IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN >*/
if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) {
/*< LEND = LSV >*/
lend = lsv;
/*< L = LENDSV >*/
l = lendsv;
/*< END IF >*/
}
/*< IF( LEND.GT.L ) THEN >*/
if (lend > l) {
/* QL Iteration */
/* Look for small subdiagonal element. */
/*< 40 CONTINUE >*/
L40:
/*< IF( L.NE.LEND ) THEN >*/
if (l != lend) {
/*< LENDM1 = LEND - 1 >*/
lendm1 = lend - 1;
/*< DO 50 M = L, LENDM1 >*/
i__1 = lendm1;
for (m = l; m <= i__1; ++m) {
/*< TST = ABS( E( M ) )**2 >*/
/* Computing 2nd power */
d__2 = (d__1 = e[m], abs(d__1));
tst = d__2 * d__2;
/*< >*/
if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
+ 1], abs(d__2)) + safmin) {
goto L60;
}
/*< 50 CONTINUE >*/
/* L50: */
}
/*< END IF >*/
}
/*< M = LEND >*/
m = lend;
/*< 60 CONTINUE >*/
L60:
/*< >*/
if (m < lend) {
e[m] = 0.;
}
/*< P = D( L ) >*/
p = d__[l];
/*< >*/
if (m == l) {
goto L80;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */
/* to compute its eigensystem. */
/*< IF( M.EQ.L+1 ) THEN >*/
if (m == l + 1) {
/*< IF( ICOMPZ.GT.0 ) THEN >*/
if (icompz > 0) {
/*< CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) >*/
dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
/*< WORK( L ) = C >*/
work[l] = c__;
/*< WORK( N-1+L ) = S >*/
work[*n - 1 + l] = s;
/*< >*/
dlasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], &
z__[l * z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, (
ftnlen)1);
/*< ELSE >*/
} else {
/*< CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) >*/
dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
/*< END IF >*/
}
/*< D( L ) = RT1 >*/
d__[l] = rt1;
/*< D( L+1 ) = RT2 >*/
d__[l + 1] = rt2;
/*< E( L ) = ZERO >*/
e[l] = 0.;
/*< L = L + 2 >*/
l += 2;
/*< >*/
if (l <= lend) {
goto L40;
}
/*< GO TO 140 >*/
goto L140;
/*< END IF >*/
}
/*< >*/
if (jtot == nmaxit) {
goto L140;
}
/*< JTOT = JTOT + 1 >*/
++jtot;
/* Form shift. */
/*< G = ( D( L+1 )-P ) / ( TWO*E( L ) ) >*/
g = (d__[l + 1] - p) / (e[l] * 2.);
/*< R = DLAPY2( G, ONE ) >*/
r__ = dlapy2_(&g, &c_b10);
/*< G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) >*/
g = d__[m] - p + e[l] / (g + d_sign(&r__, &g));
/*< S = ONE >*/
s = 1.;
/*< C = ONE >*/
c__ = 1.;
/*< P = ZERO >*/
p = 0.;
/* Inner loop */
/*< MM1 = M - 1 >*/
mm1 = m - 1;
/*< DO 70 I = MM1, L, -1 >*/
i__1 = l;
for (i__ = mm1; i__ >= i__1; --i__) {
/*< F = S*E( I ) >*/
f = s * e[i__];
/*< B = C*E( I ) >*/
b = c__ * e[i__];
/*< CALL DLARTG( G, F, C, S, R ) >*/
dlartg_(&g, &f, &c__, &s, &r__);
/*< >*/
if (i__ != m - 1) {
e[i__ + 1] = r__;
}
/*< G = D( I+1 ) - P >*/
g = d__[i__ + 1] - p;
/*< R = ( D( I )-G )*S + TWO*C*B >*/
r__ = (d__[i__] - g) * s + c__ * 2. * b;
/*< P = S*R >*/
p = s * r__;
/*< D( I+1 ) = G + P >*/
d__[i__ + 1] = g + p;
/*< G = C*R - B >*/
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
/*< IF( ICOMPZ.GT.0 ) THEN >*/
if (icompz > 0) {
/*< WORK( I ) = C >*/
work[i__] = c__;
/*< WORK( N-1+I ) = -S >*/
work[*n - 1 + i__] = -s;
/*< END IF >*/
}
/*< 70 CONTINUE >*/
/* L70: */
}
/* If eigenvectors are desired, then apply saved rotations. */
/*< IF( ICOMPZ.GT.0 ) THEN >*/
if (icompz > 0) {
/*< MM = M - L + 1 >*/
mm = m - l + 1;
/*< >*/
dlasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l
* z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, (ftnlen)1);
/*< END IF >*/
}
/*< D( L ) = D( L ) - P >*/
d__[l] -= p;
/*< E( L ) = G >*/
e[l] = g;
/*< GO TO 40 >*/
goto L40;
/* Eigenvalue found. */
/*< 80 CONTINUE >*/
L80:
/*< D( L ) = P >*/
d__[l] = p;
/*< L = L + 1 >*/
++l;
/*< >*/
if (l <= lend) {
goto L40;
}
/*< GO TO 140 >*/
goto L140;
/*< ELSE >*/
} else {
/* QR Iteration */
/* Look for small superdiagonal element. */
/*< 90 CONTINUE >*/
L90:
/*< IF( L.NE.LEND ) THEN >*/
if (l != lend) {
/*< LENDP1 = LEND + 1 >*/
lendp1 = lend + 1;
/*< DO 100 M = L, LENDP1, -1 >*/
i__1 = lendp1;
for (m = l; m >= i__1; --m) {
/*< TST = ABS( E( M-1 ) )**2 >*/
/* Computing 2nd power */
d__2 = (d__1 = e[m - 1], abs(d__1));
tst = d__2 * d__2;
/*< >*/
if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
- 1], abs(d__2)) + safmin) {
goto L110;
}
/*< 100 CONTINUE >*/
/* L100: */
}
/*< END IF >*/
}
/*< M = LEND >*/
m = lend;
/*< 110 CONTINUE >*/
L110:
/*< >*/
if (m > lend) {
e[m - 1] = 0.;
}
/*< P = D( L ) >*/
p = d__[l];
/*< >*/
if (m == l) {
goto L130;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */
/* to compute its eigensystem. */
/*< IF( M.EQ.L-1 ) THEN >*/
if (m == l - 1) {
/*< IF( ICOMPZ.GT.0 ) THEN >*/
if (icompz > 0) {
/*< CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) >*/
dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
;
/*< WORK( M ) = C >*/
work[m] = c__;
/*< WORK( N-1+M ) = S >*/
work[*n - 1 + m] = s;
/*< >*/
dlasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], &
z__[(l - 1) * z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1,
(ftnlen)1);
/*< ELSE >*/
} else {
/*< CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) >*/
dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
/*< END IF >*/
}
/*< D( L-1 ) = RT1 >*/
d__[l - 1] = rt1;
/*< D( L ) = RT2 >*/
d__[l] = rt2;
/*< E( L-1 ) = ZERO >*/
e[l - 1] = 0.;
/*< L = L - 2 >*/
l += -2;
/*< >*/
if (l >= lend) {
goto L90;
}
/*< GO TO 140 >*/
goto L140;
/*< END IF >*/
}
/*< >*/
if (jtot == nmaxit) {
goto L140;
}
/*< JTOT = JTOT + 1 >*/
++jtot;
/* Form shift. */
/*< G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) >*/
g = (d__[l - 1] - p) / (e[l - 1] * 2.);
/*< R = DLAPY2( G, ONE ) >*/
r__ = dlapy2_(&g, &c_b10);
/*< G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) >*/
g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g));
/*< S = ONE >*/
s = 1.;
/*< C = ONE >*/
c__ = 1.;
/*< P = ZERO >*/
p = 0.;
/* Inner loop */
/*< LM1 = L - 1 >*/
lm1 = l - 1;
/*< DO 120 I = M, LM1 >*/
i__1 = lm1;
for (i__ = m; i__ <= i__1; ++i__) {
/*< F = S*E( I ) >*/
f = s * e[i__];
/*< B = C*E( I ) >*/
b = c__ * e[i__];
/*< CALL DLARTG( G, F, C, S, R ) >*/
dlartg_(&g, &f, &c__, &s, &r__);
/*< >*/
if (i__ != m) {
e[i__ - 1] = r__;
}
/*< G = D( I ) - P >*/
g = d__[i__] - p;
/*< R = ( D( I+1 )-G )*S + TWO*C*B >*/
r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b;
/*< P = S*R >*/
p = s * r__;
/*< D( I ) = G + P >*/
d__[i__] = g + p;
/*< G = C*R - B >*/
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
/*< IF( ICOMPZ.GT.0 ) THEN >*/
if (icompz > 0) {
/*< WORK( I ) = C >*/
work[i__] = c__;
/*< WORK( N-1+I ) = S >*/
work[*n - 1 + i__] = s;
/*< END IF >*/
}
/*< 120 CONTINUE >*/
/* L120: */
}
/* If eigenvectors are desired, then apply saved rotations. */
/*< IF( ICOMPZ.GT.0 ) THEN >*/
if (icompz > 0) {
/*< MM = L - M + 1 >*/
mm = l - m + 1;
/*< >*/
dlasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m
* z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, (ftnlen)1);
/*< END IF >*/
}
/*< D( L ) = D( L ) - P >*/
d__[l] -= p;
/*< E( LM1 ) = G >*/
e[lm1] = g;
/*< GO TO 90 >*/
goto L90;
/* Eigenvalue found. */
/*< 130 CONTINUE >*/
L130:
/*< D( L ) = P >*/
d__[l] = p;
/*< L = L - 1 >*/
--l;
/*< >*/
if (l >= lend) {
goto L90;
}
/*< GO TO 140 >*/
goto L140;
/*< END IF >*/
}
/* Undo scaling if necessary */
/*< 140 CONTINUE >*/
L140:
/*< IF( ISCALE.EQ.1 ) THEN >*/
if (iscale == 1) {
/*< >*/
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
n, info, (ftnlen)1);
/*< >*/
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
info, (ftnlen)1);
/*< ELSE IF( ISCALE.EQ.2 ) THEN >*/
} else if (iscale == 2) {
/*< >*/
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
n, info, (ftnlen)1);
/*< >*/
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n,
info, (ftnlen)1);
/*< END IF >*/
}
/* Check for no convergence to an eigenvalue after a total */
/* of N*MAXIT iterations. */
/*< >*/
if (jtot < nmaxit) {
goto L10;
}
/*< DO 150 I = 1, N - 1 >*/
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< >*/
if (e[i__] != 0.) {
++(*info);
}
/*< 150 CONTINUE >*/
/* L150: */
}
/*< GO TO 190 >*/
goto L190;
/* Order eigenvalues and eigenvectors. */
/*< 160 CONTINUE >*/
L160:
/*< IF( ICOMPZ.EQ.0 ) THEN >*/
if (icompz == 0) {
/* Use Quick Sort */
/*< CALL DLASRT( 'I', N, D, INFO ) >*/
dlasrt_("I", n, &d__[1], info, (ftnlen)1);
/*< ELSE >*/
} else {
/* Use Selection Sort to minimize swaps of eigenvectors */
/*< DO 180 II = 2, N >*/
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
/*< I = II - 1 >*/
i__ = ii - 1;
/*< K = I >*/
k = i__;
/*< P = D( I ) >*/
p = d__[i__];
/*< DO 170 J = II, N >*/
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
/*< IF( D( J ).LT.P ) THEN >*/
if (d__[j] < p) {
/*< K = J >*/
k = j;
/*< P = D( J ) >*/
p = d__[j];
/*< END IF >*/
}
/*< 170 CONTINUE >*/
/* L170: */
}
/*< IF( K.NE.I ) THEN >*/
if (k != i__) {
/*< D( K ) = D( I ) >*/
d__[k] = d__[i__];
/*< D( I ) = P >*/
d__[i__] = p;
/*< CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) >*/
dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1],
&c__1);
/*< END IF >*/
}
/*< 180 CONTINUE >*/
/* L180: */
}
/*< END IF >*/
}
/*< 190 CONTINUE >*/
L190:
/*< RETURN >*/
return 0;
/* End of DSTEQR */
/*< END >*/
} /* dsteqr_ */
/* Subroutine */ int dbdsdc_(char *uplo, char *compq, integer *n, doublereal *
d__, doublereal *e, doublereal *u, integer *ldu, doublereal *vt,
integer *ldvt, doublereal *q, integer *iq, doublereal *work, integer *
iwork, integer *info)
{
/* System generated locals */
integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double d_sign(doublereal *, doublereal *), log(doublereal);
/* Local variables */
integer i__, j, k;
doublereal p, r__;
integer z__, ic, ii, kk;
doublereal cs;
integer is, iu;
doublereal sn;
integer nm1;
doublereal eps;
integer ivt, difl, difr, ierr, perm, mlvl, sqre;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *), dcopy_(integer *, doublereal *, integer *
, doublereal *, integer *), dswap_(integer *, doublereal *,
integer *, doublereal *, integer *);
integer poles, iuplo, nsize, start;
extern /* Subroutine */ int dlasd0_(integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
integer *, integer *, doublereal *, integer *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlasda_(integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *), dlascl_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *), dlasdq_(char *, integer *, integer *, integer
*, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *), dlaset_(char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *), dlartg_(doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
integer givcol;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
integer icompq;
doublereal orgnrm;
integer givnum, givptr, qstart, smlsiz, wstart, smlszp;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DBDSDC computes the singular value decomposition (SVD) of a real */
/* N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT, */
/* using a divide and conquer method, where S is a diagonal matrix */
/* with non-negative diagonal elements (the singular values of B), and */
/* U and VT are orthogonal matrices of left and right singular vectors, */
/* respectively. DBDSDC can be used to compute all singular values, */
/* and optionally, singular vectors or singular vectors in compact form. */
/* This code makes very mild assumptions about floating point */
/* arithmetic. It will work on machines with a guard digit in */
/* add/subtract, or on those binary machines without guard digits */
/* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */
/* It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. See DLASD3 for details. */
/* The code currently calls DLASDQ if singular values only are desired. */
/* However, it can be slightly modified to compute singular values */
/* using the divide and conquer method. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': B is upper bidiagonal. */
/* = 'L': B is lower bidiagonal. */
/* COMPQ (input) CHARACTER*1 */
/* Specifies whether singular vectors are to be computed */
/* as follows: */
/* = 'N': Compute singular values only; */
/* = 'P': Compute singular values and compute singular */
/* vectors in compact form; */
/* = 'I': Compute singular values and singular vectors. */
/* N (input) INTEGER */
/* The order of the matrix B. N >= 0. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the n diagonal elements of the bidiagonal matrix B. */
/* On exit, if INFO=0, the singular values of B. */
/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
/* On entry, the elements of E contain the offdiagonal */
/* elements of the bidiagonal matrix whose SVD is desired. */
/* On exit, E has been destroyed. */
/* U (output) DOUBLE PRECISION array, dimension (LDU,N) */
/* If COMPQ = 'I', then: */
/* On exit, if INFO = 0, U contains the left singular vectors */
/* of the bidiagonal matrix. */
/* For other values of COMPQ, U is not referenced. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= 1. */
/* If singular vectors are desired, then LDU >= max( 1, N ). */
/* VT (output) DOUBLE PRECISION array, dimension (LDVT,N) */
/* If COMPQ = 'I', then: */
/* On exit, if INFO = 0, VT' contains the right singular */
/* vectors of the bidiagonal matrix. */
/* For other values of COMPQ, VT is not referenced. */
/* LDVT (input) INTEGER */
/* The leading dimension of the array VT. LDVT >= 1. */
/* If singular vectors are desired, then LDVT >= max( 1, N ). */
/* Q (output) DOUBLE PRECISION array, dimension (LDQ) */
/* If COMPQ = 'P', then: */
/* On exit, if INFO = 0, Q and IQ contain the left */
/* and right singular vectors in a compact form, */
/* requiring O(N log N) space instead of 2*N**2. */
/* In particular, Q contains all the DOUBLE PRECISION data in */
/* LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1)))) */
/* words of memory, where SMLSIZ is returned by ILAENV and */
/* is equal to the maximum size of the subproblems at the */
/* bottom of the computation tree (usually about 25). */
/* For other values of COMPQ, Q is not referenced. */
/* IQ (output) INTEGER array, dimension (LDIQ) */
/* If COMPQ = 'P', then: */
/* On exit, if INFO = 0, Q and IQ contain the left */
/* and right singular vectors in a compact form, */
/* requiring O(N log N) space instead of 2*N**2. */
/* In particular, IQ contains all INTEGER data in */
/* LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1)))) */
/* words of memory, where SMLSIZ is returned by ILAENV and */
/* is equal to the maximum size of the subproblems at the */
/* bottom of the computation tree (usually about 25). */
/* For other values of COMPQ, IQ is not referenced. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* If COMPQ = 'N' then LWORK >= (4 * N). */
/* If COMPQ = 'P' then LWORK >= (6 * N). */
/* If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N). */
/* IWORK (workspace) INTEGER array, dimension (8*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: The algorithm failed to compute an singular value. */
/* The update process of divide and conquer failed. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Huan Ren, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* Changed dimension statement in comment describing E from (N) to */
/* (N-1). Sven, 17 Feb 05. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
--q;
--iq;
--work;
--iwork;
/* Function Body */
*info = 0;
iuplo = 0;
if (lsame_(uplo, "U")) {
iuplo = 1;
}
if (lsame_(uplo, "L")) {
iuplo = 2;
}
if (lsame_(compq, "N")) {
icompq = 0;
} else if (lsame_(compq, "P")) {
icompq = 1;
} else if (lsame_(compq, "I")) {
icompq = 2;
} else {
icompq = -1;
}
if (iuplo == 0) {
*info = -1;
} else if (icompq < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ldu < 1 || icompq == 2 && *ldu < *n) {
*info = -7;
} else if (*ldvt < 1 || icompq == 2 && *ldvt < *n) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DBDSDC", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
smlsiz = ilaenv_(&c__9, "DBDSDC", " ", &c__0, &c__0, &c__0, &c__0);
if (*n == 1) {
if (icompq == 1) {
q[1] = d_sign(&c_b15, &d__[1]);
q[smlsiz * *n + 1] = 1.;
} else if (icompq == 2) {
u[u_dim1 + 1] = d_sign(&c_b15, &d__[1]);
vt[vt_dim1 + 1] = 1.;
}
d__[1] = abs(d__[1]);
return 0;
}
nm1 = *n - 1;
/* If matrix lower bidiagonal, rotate to be upper bidiagonal */
/* by applying Givens rotations on the left */
wstart = 1;
qstart = 3;
if (icompq == 1) {
dcopy_(n, &d__[1], &c__1, &q[1], &c__1);
i__1 = *n - 1;
dcopy_(&i__1, &e[1], &c__1, &q[*n + 1], &c__1);
}
if (iuplo == 2) {
qstart = 5;
wstart = (*n << 1) - 1;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
if (icompq == 1) {
q[i__ + (*n << 1)] = cs;
q[i__ + *n * 3] = sn;
} else if (icompq == 2) {
work[i__] = cs;
work[nm1 + i__] = -sn;
}
/* L10: */
}
}
/* If ICOMPQ = 0, use DLASDQ to compute the singular values. */
if (icompq == 0) {
dlasdq_("U", &c__0, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[
vt_offset], ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[
wstart], info);
goto L40;
}
/* If N is smaller than the minimum divide size SMLSIZ, then solve */
/* the problem with another solver. */
if (*n <= smlsiz) {
if (icompq == 2) {
dlaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu);
dlaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt);
dlasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &vt[vt_offset]
, ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[
wstart], info);
} else if (icompq == 1) {
iu = 1;
ivt = iu + *n;
dlaset_("A", n, n, &c_b29, &c_b15, &q[iu + (qstart - 1) * *n], n);
dlaset_("A", n, n, &c_b29, &c_b15, &q[ivt + (qstart - 1) * *n], n);
dlasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &q[ivt + (
qstart - 1) * *n], n, &q[iu + (qstart - 1) * *n], n, &q[
iu + (qstart - 1) * *n], n, &work[wstart], info);
}
goto L40;
}
if (icompq == 2) {
dlaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu);
dlaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt);
}
/* Scale. */
orgnrm = dlanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.) {
return 0;
}
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b15, n, &c__1, &d__[1], n, &ierr);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b15, &nm1, &c__1, &e[1], &nm1, &
ierr);
eps = dlamch_("Epsilon");
mlvl = (integer) (log((doublereal) (*n) / (doublereal) (smlsiz + 1)) /
log(2.)) + 1;
smlszp = smlsiz + 1;
if (icompq == 1) {
iu = 1;
ivt = smlsiz + 1;
difl = ivt + smlszp;
difr = difl + mlvl;
z__ = difr + (mlvl << 1);
ic = z__ + mlvl;
is = ic + 1;
poles = is + 1;
givnum = poles + (mlvl << 1);
k = 1;
givptr = 2;
perm = 3;
givcol = perm + mlvl;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = d__[i__], abs(d__1)) < eps) {
d__[i__] = d_sign(&eps, &d__[i__]);
}
/* L20: */
}
start = 1;
sqre = 0;
i__1 = nm1;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) {
/* Subproblem found. First determine its size and then */
/* apply divide and conquer on it. */
if (i__ < nm1) {
/* A subproblem with E(I) small for I < NM1. */
nsize = i__ - start + 1;
} else if ((d__1 = e[i__], abs(d__1)) >= eps) {
/* A subproblem with E(NM1) not too small but I = NM1. */
nsize = *n - start + 1;
} else {
/* A subproblem with E(NM1) small. This implies an */
/* 1-by-1 subproblem at D(N). Solve this 1-by-1 problem */
/* first. */
nsize = i__ - start + 1;
if (icompq == 2) {
u[*n + *n * u_dim1] = d_sign(&c_b15, &d__[*n]);
vt[*n + *n * vt_dim1] = 1.;
} else if (icompq == 1) {
q[*n + (qstart - 1) * *n] = d_sign(&c_b15, &d__[*n]);
q[*n + (smlsiz + qstart - 1) * *n] = 1.;
}
d__[*n] = (d__1 = d__[*n], abs(d__1));
}
if (icompq == 2) {
dlasd0_(&nsize, &sqre, &d__[start], &e[start], &u[start +
start * u_dim1], ldu, &vt[start + start * vt_dim1],
ldvt, &smlsiz, &iwork[1], &work[wstart], info);
} else {
dlasda_(&icompq, &smlsiz, &nsize, &sqre, &d__[start], &e[
start], &q[start + (iu + qstart - 2) * *n], n, &q[
start + (ivt + qstart - 2) * *n], &iq[start + k * *n],
&q[start + (difl + qstart - 2) * *n], &q[start + (
difr + qstart - 2) * *n], &q[start + (z__ + qstart -
2) * *n], &q[start + (poles + qstart - 2) * *n], &iq[
start + givptr * *n], &iq[start + givcol * *n], n, &
iq[start + perm * *n], &q[start + (givnum + qstart -
2) * *n], &q[start + (ic + qstart - 2) * *n], &q[
start + (is + qstart - 2) * *n], &work[wstart], &
iwork[1], info);
if (*info != 0) {
return 0;
}
}
start = i__ + 1;
}
/* L30: */
}
/* Unscale */
dlascl_("G", &c__0, &c__0, &c_b15, &orgnrm, n, &c__1, &d__[1], n, &ierr);
L40:
/* Use Selection Sort to minimize swaps of singular vectors */
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
i__ = ii - 1;
kk = i__;
p = d__[i__];
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
if (d__[j] > p) {
kk = j;
p = d__[j];
}
/* L50: */
}
if (kk != i__) {
d__[kk] = d__[i__];
d__[i__] = p;
if (icompq == 1) {
iq[i__] = kk;
} else if (icompq == 2) {
dswap_(n, &u[i__ * u_dim1 + 1], &c__1, &u[kk * u_dim1 + 1], &
c__1);
dswap_(n, &vt[i__ + vt_dim1], ldvt, &vt[kk + vt_dim1], ldvt);
}
} else if (icompq == 1) {
iq[i__] = i__;
}
/* L60: */
}
/* If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO */
if (icompq == 1) {
if (iuplo == 1) {
iq[*n] = 1;
} else {
iq[*n] = 0;
}
}
/* If B is lower bidiagonal, update U by those Givens rotations */
/* which rotated B to be upper bidiagonal */
if (iuplo == 2 && icompq == 2) {
dlasr_("L", "V", "B", n, n, &work[1], &work[*n], &u[u_offset], ldu);
}
return 0;
/* End of DBDSDC */
} /* dbdsdc_ */
/* Subroutine */ int dsteqr_(char *compz, integer *n, doublereal *d__,
doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
doublereal b, c__, f, g;
integer i__, j, k, l, m;
doublereal p, r__, s;
integer l1, ii, mm, lm1, mm1, nm1;
doublereal rt1, rt2, eps;
integer lsv;
doublereal tst, eps2;
integer lend, jtot;
extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *);
doublereal anorm;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *), dlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
integer lendm1, lendp1;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
integer iscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlaset_(char *, integer *, integer
*, doublereal *, doublereal *, doublereal *, integer *);
doublereal safmin;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
doublereal safmax;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *);
integer lendsv;
doublereal ssfmin;
integer nmaxit, icompz;
doublereal ssfmax;
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSTEQR computes all eigenvalues and, optionally, eigenvectors of a */
/* symmetric tridiagonal matrix using the implicit QL or QR method. */
/* The eigenvectors of a full or band symmetric matrix can also be found */
/* if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to */
/* tridiagonal form. */
/* Arguments */
/* ========= */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only. */
/* = 'V': Compute eigenvalues and eigenvectors of the original */
/* symmetric matrix. On entry, Z must contain the */
/* orthogonal matrix used to reduce the original matrix */
/* to tridiagonal form. */
/* = 'I': Compute eigenvalues and eigenvectors of the */
/* tridiagonal matrix. Z is initialized to the identity */
/* matrix. */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the diagonal elements of the tridiagonal matrix. */
/* On exit, if INFO = 0, the eigenvalues in ascending order. */
/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
/* matrix. */
/* On exit, E has been destroyed. */
/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) */
/* On entry, if COMPZ = 'V', then Z contains the orthogonal */
/* matrix used in the reduction to tridiagonal form. */
/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */
/* orthonormal eigenvectors of the original symmetric matrix, */
/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */
/* of the symmetric tridiagonal matrix. */
/* If COMPZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* eigenvectors are desired, then LDZ >= max(1,N). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) */
/* If COMPZ = 'N', then WORK is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: the algorithm has failed to find all the eigenvalues in */
/* a total of 30*N iterations; if INFO = i, then i */
/* elements of E have not converged to zero; on exit, D */
/* and E contain the elements of a symmetric tridiagonal */
/* matrix which is orthogonally similar to the original */
/* matrix. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
if (lsame_(compz, "N")) {
icompz = 0;
} else if (lsame_(compz, "V")) {
icompz = 1;
} else if (lsame_(compz, "I")) {
icompz = 2;
} else {
icompz = -1;
}
if (icompz < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSTEQR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz == 2) {
z__[z_dim1 + 1] = 1.;
}
return 0;
}
/* Determine the unit roundoff and over/underflow thresholds. */
eps = dlamch_("E");
/* Computing 2nd power */
d__1 = eps;
eps2 = d__1 * d__1;
safmin = dlamch_("S");
safmax = 1. / safmin;
ssfmax = sqrt(safmax) / 3.;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues and eigenvectors of the tridiagonal */
/* matrix. */
if (icompz == 2) {
dlaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz);
}
nmaxit = *n * 30;
jtot = 0;
/* Determine where the matrix splits and choose QL or QR iteration */
/* for each block, according to whether top or bottom diagonal */
/* element is smaller. */
l1 = 1;
nm1 = *n - 1;
L10:
if (l1 > *n) {
goto L160;
}
if (l1 > 1) {
e[l1 - 1] = 0.;
}
if (l1 <= nm1) {
i__1 = nm1;
for (m = l1; m <= i__1; ++m) {
tst = (d__1 = e[m], abs(d__1));
if (tst == 0.) {
goto L30;
}
if (tst <= sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m
+ 1], abs(d__2))) * eps) {
e[m] = 0.;
goto L30;
}
/* L20: */
}
}
m = *n;
L30:
l = l1;
lsv = l;
lend = m;
lendsv = lend;
l1 = m + 1;
if (lend == l) {
goto L10;
}
/* Scale submatrix in rows and columns L to LEND */
i__1 = lend - l + 1;
anorm = dlanst_("I", &i__1, &d__[l], &e[l]);
iscale = 0;
if (anorm == 0.) {
goto L10;
}
if (anorm > ssfmax) {
iscale = 1;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
info);
} else if (anorm < ssfmin) {
iscale = 2;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
info);
}
/* Choose between QL and QR iteration */
if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) {
lend = lsv;
l = lendsv;
}
if (lend > l) {
/* QL Iteration */
/* Look for small subdiagonal element. */
L40:
if (l != lend) {
lendm1 = lend - 1;
i__1 = lendm1;
for (m = l; m <= i__1; ++m) {
/* Computing 2nd power */
d__2 = (d__1 = e[m], abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
+ 1], abs(d__2)) + safmin) {
goto L60;
}
/* L50: */
}
}
m = lend;
L60:
if (m < lend) {
e[m] = 0.;
}
p = d__[l];
if (m == l) {
goto L80;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */
/* to compute its eigensystem. */
if (m == l + 1) {
if (icompz > 0) {
dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
work[l] = c__;
work[*n - 1 + l] = s;
dlasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], &
z__[l * z_dim1 + 1], ldz);
} else {
dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
}
d__[l] = rt1;
d__[l + 1] = rt2;
e[l] = 0.;
l += 2;
if (l <= lend) {
goto L40;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l + 1] - p) / (e[l] * 2.);
r__ = dlapy2_(&g, &c_b10);
g = d__[m] - p + e[l] / (g + d_sign(&r__, &g));
s = 1.;
c__ = 1.;
p = 0.;
/* Inner loop */
mm1 = m - 1;
i__1 = l;
for (i__ = mm1; i__ >= i__1; --i__) {
f = s * e[i__];
b = c__ * e[i__];
dlartg_(&g, &f, &c__, &s, &r__);
if (i__ != m - 1) {
e[i__ + 1] = r__;
}
g = d__[i__ + 1] - p;
r__ = (d__[i__] - g) * s + c__ * 2. * b;
p = s * r__;
d__[i__ + 1] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
work[i__] = c__;
work[*n - 1 + i__] = -s;
}
/* L70: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = m - l + 1;
dlasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l
* z_dim1 + 1], ldz);
}
d__[l] -= p;
e[l] = g;
goto L40;
/* Eigenvalue found. */
L80:
d__[l] = p;
++l;
if (l <= lend) {
goto L40;
}
goto L140;
} else {
/* QR Iteration */
/* Look for small superdiagonal element. */
L90:
if (l != lend) {
lendp1 = lend + 1;
i__1 = lendp1;
for (m = l; m >= i__1; --m) {
/* Computing 2nd power */
d__2 = (d__1 = e[m - 1], abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
- 1], abs(d__2)) + safmin) {
goto L110;
}
/* L100: */
}
}
m = lend;
L110:
if (m > lend) {
e[m - 1] = 0.;
}
p = d__[l];
if (m == l) {
goto L130;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */
/* to compute its eigensystem. */
if (m == l - 1) {
if (icompz > 0) {
dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
;
work[m] = c__;
work[*n - 1 + m] = s;
dlasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], &
z__[(l - 1) * z_dim1 + 1], ldz);
} else {
dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
}
d__[l - 1] = rt1;
d__[l] = rt2;
e[l - 1] = 0.;
l += -2;
if (l >= lend) {
goto L90;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l - 1] - p) / (e[l - 1] * 2.);
r__ = dlapy2_(&g, &c_b10);
g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g));
s = 1.;
c__ = 1.;
p = 0.;
/* Inner loop */
lm1 = l - 1;
i__1 = lm1;
for (i__ = m; i__ <= i__1; ++i__) {
f = s * e[i__];
b = c__ * e[i__];
dlartg_(&g, &f, &c__, &s, &r__);
if (i__ != m) {
e[i__ - 1] = r__;
}
g = d__[i__] - p;
r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b;
p = s * r__;
d__[i__] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
work[i__] = c__;
work[*n - 1 + i__] = s;
}
/* L120: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = l - m + 1;
dlasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m
* z_dim1 + 1], ldz);
}
d__[l] -= p;
e[lm1] = g;
goto L90;
/* Eigenvalue found. */
L130:
d__[l] = p;
--l;
if (l >= lend) {
goto L90;
}
goto L140;
}
/* Undo scaling if necessary */
L140:
if (iscale == 1) {
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
info);
} else if (iscale == 2) {
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n,
info);
}
/* Check for no convergence to an eigenvalue after a total */
/* of N*MAXIT iterations. */
if (jtot < nmaxit) {
goto L10;
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.) {
++(*info);
}
/* L150: */
}
goto L190;
/* Order eigenvalues and eigenvectors. */
L160:
if (icompz == 0) {
/* Use Quick Sort */
dlasrt_("I", n, &d__[1], info);
} else {
/* Use Selection Sort to minimize swaps of eigenvectors */
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
i__ = ii - 1;
k = i__;
p = d__[i__];
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
if (d__[j] < p) {
k = j;
p = d__[j];
}
/* L170: */
}
if (k != i__) {
d__[k] = d__[i__];
d__[i__] = p;
dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1],
&c__1);
}
/* L180: */
}
}
L190:
return 0;
/* End of DSTEQR */
} /* dsteqr_ */
/*< subroutine dstqrb ( n, d, e, z, work, info ) >*/
/* Subroutine */ int dstqrb_(integer *n, doublereal *d__, doublereal *e,
doublereal *z__, doublereal *work, integer *info)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
doublereal b, c__, f, g;
integer i__, j, k, l, m;
doublereal p, r__, s;
integer l1, ii, mm, lm1, mm1, nm1;
doublereal rt1, rt2, eps;
integer lsv;
doublereal tst, eps2;
integer lend, jtot;
extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *), dlasr_(char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, ftnlen, ftnlen, ftnlen);
doublereal anorm;
extern /* Subroutine */ int dlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
integer lendm1, lendp1;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *,
ftnlen);
integer iscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, ftnlen);
doublereal safmin;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
doublereal safmax;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *,
ftnlen);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *, ftnlen);
integer lendsv, nmaxit, icompz;
doublereal ssfmax, ssfmin;
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/*< integer info, n >*/
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/*< >*/
/* .. parameters .. */
/*< >*/
/*< >*/
/*< integer maxit >*/
/*< parameter ( maxit = 30 ) >*/
/* .. */
/* .. local scalars .. */
/*< >*/
/*< >*/
/* .. */
/* .. external functions .. */
/*< logical lsame >*/
/*< >*/
/*< external lsame, dlamch, dlanst, dlapy2 >*/
/* .. */
/* .. external subroutines .. */
/*< >*/
/* .. */
/* .. intrinsic functions .. */
/*< intrinsic abs, max, sign, sqrt >*/
/* .. */
/* .. executable statements .. */
/* test the input parameters. */
/*< info = 0 >*/
/* Parameter adjustments */
--work;
--z__;
--e;
--d__;
/* Function Body */
*info = 0;
/* $$$ IF( LSAME( COMPZ, 'N' ) ) THEN */
/* $$$ ICOMPZ = 0 */
/* $$$ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN */
/* $$$ ICOMPZ = 1 */
/* $$$ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN */
/* $$$ ICOMPZ = 2 */
/* $$$ ELSE */
/* $$$ ICOMPZ = -1 */
/* $$$ END IF */
/* $$$ IF( ICOMPZ.LT.0 ) THEN */
/* $$$ INFO = -1 */
/* $$$ ELSE IF( N.LT.0 ) THEN */
/* $$$ INFO = -2 */
/* $$$ ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, */
/* $$$ $ N ) ) ) THEN */
/* $$$ INFO = -6 */
/* $$$ END IF */
/* $$$ IF( INFO.NE.0 ) THEN */
/* $$$ CALL XERBLA( 'SSTEQR', -INFO ) */
/* $$$ RETURN */
/* $$$ END IF */
/* *** New starting with version 2.5 *** */
/*< icompz = 2 >*/
icompz = 2;
/* ************************************* */
/* quick return if possible */
/*< >*/
if (*n == 0) {
return 0;
}
/*< if( n.eq.1 ) then >*/
if (*n == 1) {
/*< if( icompz.eq.2 ) z( 1 ) = one >*/
if (icompz == 2) {
z__[1] = 1.;
}
/*< return >*/
return 0;
/*< end if >*/
}
/* determine the unit roundoff and over/underflow thresholds. */
/*< eps = dlamch( 'e' ) >*/
eps = dlamch_("e", (ftnlen)1);
/*< eps2 = eps**2 >*/
/* Computing 2nd power */
d__1 = eps;
eps2 = d__1 * d__1;
/*< safmin = dlamch( 's' ) >*/
safmin = dlamch_("s", (ftnlen)1);
/*< safmax = one / safmin >*/
safmax = 1. / safmin;
/*< ssfmax = sqrt( safmax ) / three >*/
ssfmax = sqrt(safmax) / 3.;
/*< ssfmin = sqrt( safmin ) / eps2 >*/
ssfmin = sqrt(safmin) / eps2;
/* compute the eigenvalues and eigenvectors of the tridiagonal */
/* matrix. */
/* $$ if( icompz.eq.2 ) */
/* $$$ $ call dlaset( 'full', n, n, zero, one, z, ldz ) */
/* *** New starting with version 2.5 *** */
/*< if ( icompz .eq. 2 ) then >*/
if (icompz == 2) {
/*< do 5 j = 1, n-1 >*/
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/*< z(j) = zero >*/
z__[j] = 0.;
/*< 5 continue >*/
/* L5: */
}
/*< z( n ) = one >*/
z__[*n] = 1.;
/*< end if >*/
}
/* ************************************* */
/*< nmaxit = n*maxit >*/
nmaxit = *n * 30;
/*< jtot = 0 >*/
jtot = 0;
/* determine where the matrix splits and choose ql or qr iteration */
/* for each block, according to whether top or bottom diagonal */
/* element is smaller. */
/*< l1 = 1 >*/
l1 = 1;
/*< nm1 = n - 1 >*/
nm1 = *n - 1;
/*< 10 continue >*/
L10:
/*< >*/
if (l1 > *n) {
goto L160;
}
/*< >*/
if (l1 > 1) {
e[l1 - 1] = 0.;
}
/*< if( l1.le.nm1 ) then >*/
if (l1 <= nm1) {
/*< do 20 m = l1, nm1 >*/
i__1 = nm1;
for (m = l1; m <= i__1; ++m) {
/*< tst = abs( e( m ) ) >*/
tst = (d__1 = e[m], abs(d__1));
/*< >*/
if (tst == 0.) {
goto L30;
}
/*< >*/
if (tst <= sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m
+ 1], abs(d__2))) * eps) {
/*< e( m ) = zero >*/
e[m] = 0.;
/*< go to 30 >*/
goto L30;
/*< end if >*/
}
/*< 20 continue >*/
/* L20: */
}
/*< end if >*/
}
/*< m = n >*/
m = *n;
/*< 30 continue >*/
L30:
/*< l = l1 >*/
l = l1;
/*< lsv = l >*/
lsv = l;
/*< lend = m >*/
lend = m;
/*< lendsv = lend >*/
lendsv = lend;
/*< l1 = m + 1 >*/
l1 = m + 1;
/*< >*/
if (lend == l) {
goto L10;
}
/* scale submatrix in rows and columns l to lend */
/*< anorm = dlanst( 'i', lend-l+1, d( l ), e( l ) ) >*/
i__1 = lend - l + 1;
anorm = dlanst_("i", &i__1, &d__[l], &e[l], (ftnlen)1);
/*< iscale = 0 >*/
iscale = 0;
/*< >*/
if (anorm == 0.) {
goto L10;
}
/*< if( anorm.gt.ssfmax ) then >*/
if (anorm > ssfmax) {
/*< iscale = 1 >*/
iscale = 1;
/*< >*/
i__1 = lend - l + 1;
dlascl_("g", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
info, (ftnlen)1);
/*< >*/
i__1 = lend - l;
dlascl_("g", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
info, (ftnlen)1);
/*< else if( anorm.lt.ssfmin ) then >*/
} else if (anorm < ssfmin) {
/*< iscale = 2 >*/
iscale = 2;
/*< >*/
i__1 = lend - l + 1;
dlascl_("g", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
info, (ftnlen)1);
/*< >*/
i__1 = lend - l;
dlascl_("g", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
info, (ftnlen)1);
/*< end if >*/
}
/* choose between ql and qr iteration */
/*< if( abs( d( lend ) ).lt.abs( d( l ) ) ) then >*/
if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) {
/*< lend = lsv >*/
lend = lsv;
/*< l = lendsv >*/
l = lendsv;
/*< end if >*/
}
/*< if( lend.gt.l ) then >*/
if (lend > l) {
/* ql iteration */
/* look for small subdiagonal element. */
/*< 40 continue >*/
L40:
/*< if( l.ne.lend ) then >*/
if (l != lend) {
/*< lendm1 = lend - 1 >*/
lendm1 = lend - 1;
/*< do 50 m = l, lendm1 >*/
i__1 = lendm1;
for (m = l; m <= i__1; ++m) {
/*< tst = abs( e( m ) )**2 >*/
/* Computing 2nd power */
d__2 = (d__1 = e[m], abs(d__1));
tst = d__2 * d__2;
/*< >*/
if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
+ 1], abs(d__2)) + safmin) {
goto L60;
}
/*< 50 continue >*/
/* L50: */
}
/*< end if >*/
}
/*< m = lend >*/
m = lend;
/*< 60 continue >*/
L60:
/*< >*/
if (m < lend) {
e[m] = 0.;
}
/*< p = d( l ) >*/
p = d__[l];
/*< >*/
if (m == l) {
goto L80;
}
/* if remaining matrix is 2-by-2, use dlae2 or dlaev2 */
/* to compute its eigensystem. */
/*< if( m.eq.l+1 ) then >*/
if (m == l + 1) {
/*< if( icompz.gt.0 ) then >*/
if (icompz > 0) {
/*< call dlaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s ) >*/
dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
/*< work( l ) = c >*/
work[l] = c__;
/*< work( n-1+l ) = s >*/
work[*n - 1 + l] = s;
/* $$$ call dlasr( 'r', 'v', 'b', n, 2, work( l ), */
/* $$$ $ work( n-1+l ), z( 1, l ), ldz ) */
/* *** New starting with version 2.5 *** */
/*< tst = z(l+1) >*/
tst = z__[l + 1];
/*< z(l+1) = c*tst - s*z(l) >*/
z__[l + 1] = c__ * tst - s * z__[l];
/*< z(l) = s*tst + c*z(l) >*/
z__[l] = s * tst + c__ * z__[l];
/* ************************************* */
/*< else >*/
} else {
/*< call dlae2( d( l ), e( l ), d( l+1 ), rt1, rt2 ) >*/
dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
/*< end if >*/
}
/*< d( l ) = rt1 >*/
d__[l] = rt1;
/*< d( l+1 ) = rt2 >*/
d__[l + 1] = rt2;
/*< e( l ) = zero >*/
e[l] = 0.;
/*< l = l + 2 >*/
l += 2;
/*< >*/
if (l <= lend) {
goto L40;
}
/*< go to 140 >*/
goto L140;
/*< end if >*/
}
/*< >*/
if (jtot == nmaxit) {
goto L140;
}
/*< jtot = jtot + 1 >*/
++jtot;
/* form shift. */
/*< g = ( d( l+1 )-p ) / ( two*e( l ) ) >*/
g = (d__[l + 1] - p) / (e[l] * 2.);
/*< r = dlapy2( g, one ) >*/
r__ = dlapy2_(&g, &c_b31);
/*< g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) ) >*/
g = d__[m] - p + e[l] / (g + d_sign(&r__, &g));
/*< s = one >*/
s = 1.;
/*< c = one >*/
c__ = 1.;
/*< p = zero >*/
p = 0.;
/* inner loop */
/*< mm1 = m - 1 >*/
mm1 = m - 1;
/*< do 70 i = mm1, l, -1 >*/
i__1 = l;
for (i__ = mm1; i__ >= i__1; --i__) {
/*< f = s*e( i ) >*/
f = s * e[i__];
/*< b = c*e( i ) >*/
b = c__ * e[i__];
/*< call dlartg( g, f, c, s, r ) >*/
dlartg_(&g, &f, &c__, &s, &r__);
/*< >*/
if (i__ != m - 1) {
e[i__ + 1] = r__;
}
/*< g = d( i+1 ) - p >*/
g = d__[i__ + 1] - p;
/*< r = ( d( i )-g )*s + two*c*b >*/
r__ = (d__[i__] - g) * s + c__ * 2. * b;
/*< p = s*r >*/
p = s * r__;
/*< d( i+1 ) = g + p >*/
d__[i__ + 1] = g + p;
/*< g = c*r - b >*/
g = c__ * r__ - b;
/* if eigenvectors are desired, then save rotations. */
/*< if( icompz.gt.0 ) then >*/
if (icompz > 0) {
/*< work( i ) = c >*/
work[i__] = c__;
/*< work( n-1+i ) = -s >*/
work[*n - 1 + i__] = -s;
/*< end if >*/
}
/*< 70 continue >*/
/* L70: */
}
/* if eigenvectors are desired, then apply saved rotations. */
/*< if( icompz.gt.0 ) then >*/
if (icompz > 0) {
/*< mm = m - l + 1 >*/
mm = m - l + 1;
/* $$$ call dlasr( 'r', 'v', 'b', n, mm, work( l ), work( n-1+l ), */
/* $$$ $ z( 1, l ), ldz ) */
/* *** New starting with version 2.5 *** */
/*< >*/
dlasr_("r", "v", "b", &c__1, &mm, &work[l], &work[*n - 1 + l], &
z__[l], &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
/* ************************************* */
/*< end if >*/
}
/*< d( l ) = d( l ) - p >*/
d__[l] -= p;
/*< e( l ) = g >*/
e[l] = g;
/*< go to 40 >*/
goto L40;
/* eigenvalue found. */
/*< 80 continue >*/
L80:
/*< d( l ) = p >*/
d__[l] = p;
/*< l = l + 1 >*/
++l;
/*< >*/
if (l <= lend) {
goto L40;
}
/*< go to 140 >*/
goto L140;
/*< else >*/
} else {
/* qr iteration */
/* look for small superdiagonal element. */
/*< 90 continue >*/
L90:
/*< if( l.ne.lend ) then >*/
if (l != lend) {
/*< lendp1 = lend + 1 >*/
lendp1 = lend + 1;
/*< do 100 m = l, lendp1, -1 >*/
i__1 = lendp1;
for (m = l; m >= i__1; --m) {
/*< tst = abs( e( m-1 ) )**2 >*/
/* Computing 2nd power */
d__2 = (d__1 = e[m - 1], abs(d__1));
tst = d__2 * d__2;
/*< >*/
if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
- 1], abs(d__2)) + safmin) {
goto L110;
}
/*< 100 continue >*/
/* L100: */
}
/*< end if >*/
}
/*< m = lend >*/
m = lend;
/*< 110 continue >*/
L110:
/*< >*/
if (m > lend) {
e[m - 1] = 0.;
}
/*< p = d( l ) >*/
p = d__[l];
/*< >*/
if (m == l) {
goto L130;
}
/* if remaining matrix is 2-by-2, use dlae2 or dlaev2 */
/* to compute its eigensystem. */
/*< if( m.eq.l-1 ) then >*/
if (m == l - 1) {
/*< if( icompz.gt.0 ) then >*/
if (icompz > 0) {
/*< call dlaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s ) >*/
dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
;
/* $$$ work( m ) = c */
/* $$$ work( n-1+m ) = s */
/* $$$ call dlasr( 'r', 'v', 'f', n, 2, work( m ), */
/* $$$ $ work( n-1+m ), z( 1, l-1 ), ldz ) */
/* *** New starting with version 2.5 *** */
/*< tst = z(l) >*/
tst = z__[l];
/*< z(l) = c*tst - s*z(l-1) >*/
z__[l] = c__ * tst - s * z__[l - 1];
/*< z(l-1) = s*tst + c*z(l-1) >*/
z__[l - 1] = s * tst + c__ * z__[l - 1];
/* ************************************* */
/*< else >*/
} else {
/*< call dlae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 ) >*/
dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
/*< end if >*/
}
/*< d( l-1 ) = rt1 >*/
d__[l - 1] = rt1;
/*< d( l ) = rt2 >*/
d__[l] = rt2;
/*< e( l-1 ) = zero >*/
e[l - 1] = 0.;
/*< l = l - 2 >*/
l += -2;
/*< >*/
if (l >= lend) {
goto L90;
}
/*< go to 140 >*/
goto L140;
/*< end if >*/
}
/*< >*/
if (jtot == nmaxit) {
goto L140;
}
/*< jtot = jtot + 1 >*/
++jtot;
/* form shift. */
/*< g = ( d( l-1 )-p ) / ( two*e( l-1 ) ) >*/
g = (d__[l - 1] - p) / (e[l - 1] * 2.);
/*< r = dlapy2( g, one ) >*/
r__ = dlapy2_(&g, &c_b31);
/*< g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) ) >*/
g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g));
/*< s = one >*/
s = 1.;
/*< c = one >*/
c__ = 1.;
/*< p = zero >*/
p = 0.;
/* inner loop */
/*< lm1 = l - 1 >*/
lm1 = l - 1;
/*< do 120 i = m, lm1 >*/
i__1 = lm1;
for (i__ = m; i__ <= i__1; ++i__) {
/*< f = s*e( i ) >*/
f = s * e[i__];
/*< b = c*e( i ) >*/
b = c__ * e[i__];
/*< call dlartg( g, f, c, s, r ) >*/
dlartg_(&g, &f, &c__, &s, &r__);
/*< >*/
if (i__ != m) {
e[i__ - 1] = r__;
}
/*< g = d( i ) - p >*/
g = d__[i__] - p;
/*< r = ( d( i+1 )-g )*s + two*c*b >*/
r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b;
/*< p = s*r >*/
p = s * r__;
/*< d( i ) = g + p >*/
d__[i__] = g + p;
/*< g = c*r - b >*/
g = c__ * r__ - b;
/* if eigenvectors are desired, then save rotations. */
/*< if( icompz.gt.0 ) then >*/
if (icompz > 0) {
/*< work( i ) = c >*/
work[i__] = c__;
/*< work( n-1+i ) = s >*/
work[*n - 1 + i__] = s;
/*< end if >*/
}
/*< 120 continue >*/
/* L120: */
}
/* if eigenvectors are desired, then apply saved rotations. */
/*< if( icompz.gt.0 ) then >*/
if (icompz > 0) {
/*< mm = l - m + 1 >*/
mm = l - m + 1;
/* $$$ call dlasr( 'r', 'v', 'f', n, mm, work( m ), work( n-1+m ), */
/* $$$ $ z( 1, m ), ldz ) */
/* *** New starting with version 2.5 *** */
/*< >*/
dlasr_("r", "v", "f", &c__1, &mm, &work[m], &work[*n - 1 + m], &
z__[m], &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
/* ************************************* */
/*< end if >*/
}
/*< d( l ) = d( l ) - p >*/
d__[l] -= p;
/*< e( lm1 ) = g >*/
e[lm1] = g;
/*< go to 90 >*/
goto L90;
/* eigenvalue found. */
/*< 130 continue >*/
L130:
/*< d( l ) = p >*/
d__[l] = p;
/*< l = l - 1 >*/
--l;
/*< >*/
if (l >= lend) {
goto L90;
}
/*< go to 140 >*/
goto L140;
/*< end if >*/
}
/* undo scaling if necessary */
/*< 140 continue >*/
L140:
/*< if( iscale.eq.1 ) then >*/
if (iscale == 1) {
/*< >*/
i__1 = lendsv - lsv + 1;
dlascl_("g", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
n, info, (ftnlen)1);
/*< >*/
i__1 = lendsv - lsv;
dlascl_("g", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
info, (ftnlen)1);
/*< else if( iscale.eq.2 ) then >*/
} else if (iscale == 2) {
/*< >*/
i__1 = lendsv - lsv + 1;
dlascl_("g", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
n, info, (ftnlen)1);
/*< >*/
i__1 = lendsv - lsv;
dlascl_("g", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n,
info, (ftnlen)1);
/*< end if >*/
}
/* check for no convergence to an eigenvalue after a total */
/* of n*maxit iterations. */
/*< >*/
if (jtot < nmaxit) {
goto L10;
}
/*< do 150 i = 1, n - 1 >*/
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< >*/
if (e[i__] != 0.) {
++(*info);
}
/*< 150 continue >*/
/* L150: */
}
/*< go to 190 >*/
goto L190;
/* order eigenvalues and eigenvectors. */
/*< 160 continue >*/
L160:
/*< if( icompz.eq.0 ) then >*/
if (icompz == 0) {
/* use quick sort */
/*< call dlasrt( 'i', n, d, info ) >*/
dlasrt_("i", n, &d__[1], info, (ftnlen)1);
/*< else >*/
} else {
/* use selection sort to minimize swaps of eigenvectors */
/*< do 180 ii = 2, n >*/
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
/*< i = ii - 1 >*/
i__ = ii - 1;
/*< k = i >*/
k = i__;
/*< p = d( i ) >*/
p = d__[i__];
/*< do 170 j = ii, n >*/
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
/*< if( d( j ).lt.p ) then >*/
if (d__[j] < p) {
/*< k = j >*/
k = j;
/*< p = d( j ) >*/
p = d__[j];
/*< end if >*/
}
/*< 170 continue >*/
/* L170: */
}
/*< if( k.ne.i ) then >*/
if (k != i__) {
/*< d( k ) = d( i ) >*/
d__[k] = d__[i__];
/*< d( i ) = p >*/
d__[i__] = p;
/* $$$ call dswap( n, z( 1, i ), 1, z( 1, k ), 1 ) */
/* *** New starting with version 2.5 *** */
/*< p = z(k) >*/
p = z__[k];
/*< z(k) = z(i) >*/
z__[k] = z__[i__];
/*< z(i) = p >*/
z__[i__] = p;
/* ************************************* */
/*< end if >*/
}
/*< 180 continue >*/
/* L180: */
}
/*< end if >*/
}
/*< 190 continue >*/
L190:
/*< return >*/
return 0;
/* %---------------% */
/* | End of dstqrb | */
/* %---------------% */
/*< end >*/
} /* dstqrb_ */
/* Subroutine */ int dstqrb_(integer *n, doublereal *d__, doublereal *e,
doublereal *z__, doublereal *work, integer *info)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
/* Local variables */
static doublereal b, c__, f, g;
static integer i__, j, k, l, m;
static doublereal p, r__, s;
static integer l1, ii, mm, lm1, mm1, nm1;
static doublereal rt1, rt2, eps;
static integer lsv;
static doublereal tst, eps2;
static integer lend, jtot;
extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *), dlasr_(char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, ftnlen, ftnlen, ftnlen);
static doublereal anorm;
extern /* Subroutine */ int dlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
static integer lendm1, lendp1;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *,
ftnlen);
static integer iscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, ftnlen);
static doublereal safmin;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
static doublereal safmax;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *,
ftnlen);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *, ftnlen);
static integer lendsv, nmaxit, icompz;
static doublereal ssfmax, ssfmin;
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* .. parameters .. */
/* .. */
/* .. local scalars .. */
/* .. */
/* .. external functions .. */
/* .. */
/* .. external subroutines .. */
/* .. */
/* .. intrinsic functions .. */
/* .. */
/* .. executable statements .. */
/* test the input parameters. */
/* Parameter adjustments */
--work;
--z__;
--e;
--d__;
/* Function Body */
*info = 0;
/* $$$ IF( LSAME( COMPZ, 'N' ) ) THEN */
/* $$$ ICOMPZ = 0 */
/* $$$ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN */
/* $$$ ICOMPZ = 1 */
/* $$$ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN */
/* $$$ ICOMPZ = 2 */
/* $$$ ELSE */
/* $$$ ICOMPZ = -1 */
/* $$$ END IF */
/* $$$ IF( ICOMPZ.LT.0 ) THEN */
/* $$$ INFO = -1 */
/* $$$ ELSE IF( N.LT.0 ) THEN */
/* $$$ INFO = -2 */
/* $$$ ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, */
/* $$$ $ N ) ) ) THEN */
/* $$$ INFO = -6 */
/* $$$ END IF */
/* $$$ IF( INFO.NE.0 ) THEN */
/* $$$ CALL XERBLA( 'SSTEQR', -INFO ) */
/* $$$ RETURN */
/* $$$ END IF */
/* *** New starting with version 2.5 *** */
icompz = 2;
/* ************************************* */
/* quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz == 2) {
z__[1] = 1.;
}
return 0;
}
/* determine the unit roundoff and over/underflow thresholds. */
eps = dlamch_("e", (ftnlen)1);
/* Computing 2nd power */
d__1 = eps;
eps2 = d__1 * d__1;
safmin = dlamch_("s", (ftnlen)1);
safmax = 1. / safmin;
ssfmax = sqrt(safmax) / 3.;
ssfmin = sqrt(safmin) / eps2;
/* compute the eigenvalues and eigenvectors of the tridiagonal */
/* matrix. */
/* $$ if( icompz.eq.2 ) */
/* $$$ $ call dlaset( 'full', n, n, zero, one, z, ldz ) */
/* *** New starting with version 2.5 *** */
if (icompz == 2) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
z__[j] = 0.;
/* L5: */
}
z__[*n] = 1.;
}
/* ************************************* */
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], (ftnlen)1);
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, (ftnlen)1);
i__1 = lend - l;
dlascl_("g", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
info, (ftnlen)1);
} else if (anorm < ssfmin) {
iscale = 2;
i__1 = lend - l + 1;
dlascl_("g", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
info, (ftnlen)1);
i__1 = lend - l;
dlascl_("g", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
info, (ftnlen)1);
}
/* 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 dlaev2 */
/* 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;
/* $$$ call dlasr( 'r', 'v', 'b', n, 2, work( l ), */
/* $$$ $ work( n-1+l ), z( 1, l ), ldz ) */
/* *** New starting with version 2.5 *** */
tst = z__[l + 1];
z__[l + 1] = c__ * tst - s * z__[l];
z__[l] = s * tst + c__ * z__[l];
/* ************************************* */
} 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_b31);
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;
/* $$$ call dlasr( 'r', 'v', 'b', n, mm, work( l ), work( n-1+l ), */
/* $$$ $ z( 1, l ), ldz ) */
/* *** New starting with version 2.5 *** */
dlasr_("r", "v", "b", &c__1, &mm, &work[l], &work[*n - 1 + l], &
z__[l], &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
/* ************************************* */
}
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 dlaev2 */
/* 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 */
/* $$$ call dlasr( 'r', 'v', 'f', n, 2, work( m ), */
/* $$$ $ work( n-1+m ), z( 1, l-1 ), ldz ) */
/* *** New starting with version 2.5 *** */
tst = z__[l];
z__[l] = c__ * tst - s * z__[l - 1];
z__[l - 1] = s * tst + c__ * z__[l - 1];
/* ************************************* */
} 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_b31);
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;
/* $$$ call dlasr( 'r', 'v', 'f', n, mm, work( m ), work( n-1+m ), */
/* $$$ $ z( 1, m ), ldz ) */
/* *** New starting with version 2.5 *** */
dlasr_("r", "v", "f", &c__1, &mm, &work[m], &work[*n - 1 + m], &
z__[m], &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
/* ************************************* */
}
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, (ftnlen)1);
i__1 = lendsv - lsv;
dlascl_("g", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
info, (ftnlen)1);
} else if (iscale == 2) {
i__1 = lendsv - lsv + 1;
dlascl_("g", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
n, info, (ftnlen)1);
i__1 = lendsv - lsv;
dlascl_("g", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n,
info, (ftnlen)1);
}
/* check for no convergence to an eigenvalue after a total */
/* of n*maxit iterations. */
if (jtot < nmaxit) {
goto L10;
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.) {
++(*info);
}
/* L150: */
}
goto L190;
/* order eigenvalues and eigenvectors. */
L160:
if (icompz == 0) {
/* use quick sort */
dlasrt_("i", n, &d__[1], info, (ftnlen)1);
} 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;
/* $$$ call dswap( n, z( 1, i ), 1, z( 1, k ), 1 ) */
/* *** New starting with version 2.5 *** */
p = z__[k];
z__[k] = z__[i__];
z__[i__] = p;
/* ************************************* */
}
/* L180: */
}
}
L190:
return 0;
/* %---------------% */
/* | End of dstqrb | */
/* %---------------% */
} /* dstqrb_ */