/* Subroutine */
int zlaev2_(doublecomplex *a, doublecomplex *b, doublecomplex *c__, doublereal *rt1, doublereal *rt2, doublereal *cs1, doublecomplex *sn1)
{
/* System generated locals */
doublereal d__1, d__2, d__3;
doublecomplex z__1, z__2;
/* Builtin functions */
double z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
doublereal t;
doublecomplex w;
extern /* Subroutine */
int dlaev2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *);
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
if (z_abs(b) == 0.)
{
w.r = 1.;
w.i = 0.; // , expr subst
}
else
{
d_cnjg(&z__2, b);
d__1 = z_abs(b);
z__1.r = z__2.r / d__1;
z__1.i = z__2.i / d__1; // , expr subst
w.r = z__1.r;
w.i = z__1.i; // , expr subst
}
d__1 = a->r;
d__2 = z_abs(b);
d__3 = c__->r;
dlaev2_(&d__1, &d__2, &d__3, rt1, rt2, cs1, &t);
z__1.r = t * w.r;
z__1.i = t * w.i; // , expr subst
sn1->r = z__1.r, sn1->i = z__1.i;
return 0;
/* End of ZLAEV2 */
}
/*< SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO ) >*/
/* Subroutine */ int dsptrf_(char *uplo, integer *n, doublereal *ap, integer *ipiv,
integer *info, ftnlen uplo_len)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal c__;
integer j, k;
doublereal s, t, r1, r2;
integer kc, kk, kp, kx, knc, kpc=0, npp, imax=0, jmax;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *), dspr_(char *
, integer *, doublereal *, doublereal *, integer *, doublereal *,
ftnlen);
doublereal alpha;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(const char *, const char *, ftnlen, ftnlen);
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer kstep;
logical upper;
extern /* Subroutine */ int dlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
doublereal absakk;
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
doublereal colmax, rowmax;
(void)uplo_len;
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* March 31, 1993 */
/* .. Scalar Arguments .. */
/*< CHARACTER UPLO >*/
/*< INTEGER INFO, N >*/
/* .. */
/* .. Array Arguments .. */
/*< INTEGER IPIV( * ) >*/
/*< DOUBLE PRECISION AP( * ) >*/
/* .. */
/* Purpose */
/* ======= */
/* DSPTRF computes the factorization of a real symmetric matrix A stored */
/* in packed format using the Bunch-Kaufman diagonal pivoting method: */
/* A = U*D*U**T or A = L*D*L**T */
/* where U (or L) is a product of permutation and unit upper (lower) */
/* triangular matrices, and D is symmetric and block diagonal with */
/* 1-by-1 and 2-by-2 diagonal blocks. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the symmetric matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, the block diagonal matrix D and the multipliers used */
/* to obtain the factor U or L, stored as a packed triangular */
/* matrix overwriting A (see below for further details). */
/* IPIV (output) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D. */
/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */
/* has been completed, but the block diagonal matrix D is */
/* exactly singular, and division by zero will occur if it */
/* is used to solve a system of equations. */
/* Further Details */
/* =============== */
/* If UPLO = 'U', then A = U*D*U', where */
/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
/* ( I v 0 ) k-s */
/* U(k) = ( 0 I 0 ) s */
/* ( 0 0 I ) n-k */
/* k-s s n-k */
/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
/* If UPLO = 'L', then A = L*D*L', where */
/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
/* ( I 0 0 ) k-1 */
/* L(k) = ( 0 I 0 ) s */
/* ( 0 v I ) n-k-s+1 */
/* k-1 s n-k-s+1 */
/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
/* ===================================================================== */
/* .. Parameters .. */
/*< DOUBLE PRECISION ZERO, ONE >*/
/*< PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) >*/
/*< DOUBLE PRECISION EIGHT, SEVTEN >*/
/*< PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) >*/
/* .. */
/* .. Local Scalars .. */
/*< LOGICAL UPPER >*/
/*< >*/
/*< DOUBLE PRECISION ABSAKK, ALPHA, C, COLMAX, R1, R2, ROWMAX, S, T >*/
/* .. */
/* .. External Functions .. */
/*< LOGICAL LSAME >*/
/*< INTEGER IDAMAX >*/
/*< EXTERNAL LSAME, IDAMAX >*/
/* .. */
/* .. External Subroutines .. */
/*< EXTERNAL DLAEV2, DROT, DSCAL, DSPR, DSWAP, XERBLA >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC ABS, MAX, SQRT >*/
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/*< INFO = 0 >*/
/* Parameter adjustments */
--ipiv;
--ap;
/* Function Body */
*info = 0;
/*< UPPER = LSAME( UPLO, 'U' ) >*/
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
/*< IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN >*/
if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
/*< INFO = -1 >*/
*info = -1;
/*< ELSE IF( N.LT.0 ) THEN >*/
} else if (*n < 0) {
/*< INFO = -2 >*/
*info = -2;
/*< END IF >*/
}
/*< IF( INFO.NE.0 ) THEN >*/
if (*info != 0) {
/*< CALL XERBLA( 'DSPTRF', -INFO ) >*/
i__1 = -(*info);
xerbla_("DSPTRF", &i__1, (ftnlen)6);
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/* Initialize ALPHA for use in choosing pivot block size. */
/*< ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT >*/
alpha = (sqrt(17.) + 1.) / 8.;
/*< IF( UPPER ) THEN >*/
if (upper) {
/* Factorize A as U*D*U' using the upper triangle of A */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2 */
/*< K = N >*/
k = *n;
/*< KC = ( N-1 )*N / 2 + 1 >*/
kc = (*n - 1) * *n / 2 + 1;
/*< 10 CONTINUE >*/
L10:
/*< KNC = KC >*/
knc = kc;
/* If K < 1, exit from loop */
/*< >*/
if (k < 1) {
goto L70;
}
/*< KSTEP = 1 >*/
kstep = 1;
/* Determine rows and columns to be interchanged and whether */
/* a 1-by-1 or 2-by-2 pivot block will be used */
/*< ABSAKK = ABS( AP( KC+K-1 ) ) >*/
absakk = (d__1 = ap[kc + k - 1], abs(d__1));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value */
/*< IF( K.GT.1 ) THEN >*/
if (k > 1) {
/*< IMAX = IDAMAX( K-1, AP( KC ), 1 ) >*/
i__1 = k - 1;
imax = idamax_(&i__1, &ap[kc], &c__1);
/*< COLMAX = ABS( AP( KC+IMAX-1 ) ) >*/
colmax = (d__1 = ap[kc + imax - 1], abs(d__1));
/*< ELSE >*/
} else {
/*< COLMAX = ZERO >*/
colmax = 0.;
/*< END IF >*/
}
/*< IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN >*/
if (max(absakk,colmax) == 0.) {
/* Column K is zero: set INFO and continue */
/*< >*/
if (*info == 0) {
*info = k;
}
/*< KP = K >*/
kp = k;
/*< ELSE >*/
} else {
/*< IF( ABSAKK.GE.ALPHA*COLMAX ) THEN >*/
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
/*< KP = K >*/
kp = k;
/*< ELSE >*/
} else {
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
/*< ROWMAX = ZERO >*/
rowmax = 0.;
/*< JMAX = IMAX >*/
jmax = imax;
/*< KX = IMAX*( IMAX+1 ) / 2 + IMAX >*/
kx = imax * (imax + 1) / 2 + imax;
/*< DO 20 J = IMAX + 1, K >*/
i__1 = k;
for (j = imax + 1; j <= i__1; ++j) {
/*< IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN >*/
if ((d__1 = ap[kx], abs(d__1)) > rowmax) {
/*< ROWMAX = ABS( AP( KX ) ) >*/
rowmax = (d__1 = ap[kx], abs(d__1));
/*< JMAX = J >*/
jmax = j;
/*< END IF >*/
}
/*< KX = KX + J >*/
kx += j;
/*< 20 CONTINUE >*/
/* L20: */
}
/*< KPC = ( IMAX-1 )*IMAX / 2 + 1 >*/
kpc = (imax - 1) * imax / 2 + 1;
/*< IF( IMAX.GT.1 ) THEN >*/
if (imax > 1) {
/*< JMAX = IDAMAX( IMAX-1, AP( KPC ), 1 ) >*/
i__1 = imax - 1;
jmax = idamax_(&i__1, &ap[kpc], &c__1);
/*< ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-1 ) ) ) >*/
/* Computing MAX */
d__2 = rowmax, d__3 = (d__1 = ap[kpc + jmax - 1], abs(
d__1));
rowmax = max(d__2,d__3);
/*< END IF >*/
}
/*< IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN >*/
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
/*< KP = K >*/
kp = k;
/*< ELSE IF( ABS( AP( KPC+IMAX-1 ) ).GE.ALPHA*ROWMAX ) THEN >*/
} else if ((d__1 = ap[kpc + imax - 1], abs(d__1)) >= alpha *
rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1 */
/* pivot block */
/*< KP = IMAX >*/
kp = imax;
/*< ELSE >*/
} else {
/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
/* pivot block */
/*< KP = IMAX >*/
kp = imax;
/*< KSTEP = 2 >*/
kstep = 2;
/*< END IF >*/
}
/*< END IF >*/
}
/*< KK = K - KSTEP + 1 >*/
kk = k - kstep + 1;
/*< >*/
if (kstep == 2) {
knc = knc - k + 1;
}
/*< IF( KP.NE.KK ) THEN >*/
if (kp != kk) {
/* Interchange rows and columns KK and KP in the leading */
/* submatrix A(1:k,1:k) */
/*< CALL DSWAP( KP-1, AP( KNC ), 1, AP( KPC ), 1 ) >*/
i__1 = kp - 1;
dswap_(&i__1, &ap[knc], &c__1, &ap[kpc], &c__1);
/*< KX = KPC + KP - 1 >*/
kx = kpc + kp - 1;
/*< DO 30 J = KP + 1, KK - 1 >*/
i__1 = kk - 1;
for (j = kp + 1; j <= i__1; ++j) {
/*< KX = KX + J - 1 >*/
kx = kx + j - 1;
/*< T = AP( KNC+J-1 ) >*/
t = ap[knc + j - 1];
/*< AP( KNC+J-1 ) = AP( KX ) >*/
ap[knc + j - 1] = ap[kx];
/*< AP( KX ) = T >*/
ap[kx] = t;
/*< 30 CONTINUE >*/
/* L30: */
}
/*< T = AP( KNC+KK-1 ) >*/
t = ap[knc + kk - 1];
/*< AP( KNC+KK-1 ) = AP( KPC+KP-1 ) >*/
ap[knc + kk - 1] = ap[kpc + kp - 1];
/*< AP( KPC+KP-1 ) = T >*/
ap[kpc + kp - 1] = t;
/*< IF( KSTEP.EQ.2 ) THEN >*/
if (kstep == 2) {
/*< T = AP( KC+K-2 ) >*/
t = ap[kc + k - 2];
/*< AP( KC+K-2 ) = AP( KC+KP-1 ) >*/
ap[kc + k - 2] = ap[kc + kp - 1];
/*< AP( KC+KP-1 ) = T >*/
ap[kc + kp - 1] = t;
/*< END IF >*/
}
/*< END IF >*/
}
/* Update the leading submatrix */
/*< IF( KSTEP.EQ.1 ) THEN >*/
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k now holds */
/* W(k) = U(k)*D(k) */
/* where U(k) is the k-th column of U */
/* Perform a rank-1 update of A(1:k-1,1:k-1) as */
/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */
/*< R1 = ONE / AP( KC+K-1 ) >*/
r1 = 1. / ap[kc + k - 1];
/*< CALL DSPR( UPLO, K-1, -R1, AP( KC ), 1, AP ) >*/
i__1 = k - 1;
d__1 = -r1;
dspr_(uplo, &i__1, &d__1, &ap[kc], &c__1, &ap[1], (ftnlen)1);
/* Store U(k) in column k */
/*< CALL DSCAL( K-1, R1, AP( KC ), 1 ) >*/
i__1 = k - 1;
dscal_(&i__1, &r1, &ap[kc], &c__1);
/*< ELSE >*/
} else {
/* 2-by-2 pivot block D(k): columns k and k-1 now hold */
/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */
/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */
/* of U */
/* Perform a rank-2 update of A(1:k-2,1:k-2) as */
/* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' */
/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */
/* Convert this to two rank-1 updates by using the eigen- */
/* decomposition of D(k) */
/*< >*/
dlaev2_(&ap[kc - 1], &ap[kc + k - 2], &ap[kc + k - 1], &r1, &
r2, &c__, &s);
/*< R1 = ONE / R1 >*/
r1 = 1. / r1;
/*< R2 = ONE / R2 >*/
r2 = 1. / r2;
/*< CALL DROT( K-2, AP( KNC ), 1, AP( KC ), 1, C, S ) >*/
i__1 = k - 2;
drot_(&i__1, &ap[knc], &c__1, &ap[kc], &c__1, &c__, &s);
/*< CALL DSPR( UPLO, K-2, -R1, AP( KNC ), 1, AP ) >*/
i__1 = k - 2;
d__1 = -r1;
dspr_(uplo, &i__1, &d__1, &ap[knc], &c__1, &ap[1], (ftnlen)1);
/*< CALL DSPR( UPLO, K-2, -R2, AP( KC ), 1, AP ) >*/
i__1 = k - 2;
d__1 = -r2;
dspr_(uplo, &i__1, &d__1, &ap[kc], &c__1, &ap[1], (ftnlen)1);
/* Store U(k) and U(k-1) in columns k and k-1 */
/*< CALL DSCAL( K-2, R1, AP( KNC ), 1 ) >*/
i__1 = k - 2;
dscal_(&i__1, &r1, &ap[knc], &c__1);
/*< CALL DSCAL( K-2, R2, AP( KC ), 1 ) >*/
i__1 = k - 2;
dscal_(&i__1, &r2, &ap[kc], &c__1);
/*< CALL DROT( K-2, AP( KNC ), 1, AP( KC ), 1, C, -S ) >*/
i__1 = k - 2;
d__1 = -s;
drot_(&i__1, &ap[knc], &c__1, &ap[kc], &c__1, &c__, &d__1);
/*< END IF >*/
}
/*< END IF >*/
}
/* Store details of the interchanges in IPIV */
/*< IF( KSTEP.EQ.1 ) THEN >*/
if (kstep == 1) {
/*< IPIV( K ) = KP >*/
ipiv[k] = kp;
/*< ELSE >*/
} else {
/*< IPIV( K ) = -KP >*/
ipiv[k] = -kp;
/*< IPIV( K-1 ) = -KP >*/
ipiv[k - 1] = -kp;
/*< END IF >*/
}
/* Decrease K and return to the start of the main loop */
/*< K = K - KSTEP >*/
k -= kstep;
/*< KC = KNC - K >*/
kc = knc - k;
/*< GO TO 10 >*/
goto L10;
/*< ELSE >*/
} else {
/* Factorize A as L*D*L' using the lower triangle of A */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2 */
/*< K = 1 >*/
k = 1;
/*< KC = 1 >*/
kc = 1;
/*< NPP = N*( N+1 ) / 2 >*/
npp = *n * (*n + 1) / 2;
/*< 40 CONTINUE >*/
L40:
/*< KNC = KC >*/
knc = kc;
/* If K > N, exit from loop */
/*< >*/
if (k > *n) {
goto L70;
}
/*< KSTEP = 1 >*/
kstep = 1;
/* Determine rows and columns to be interchanged and whether */
/* a 1-by-1 or 2-by-2 pivot block will be used */
/*< ABSAKK = ABS( AP( KC ) ) >*/
absakk = (d__1 = ap[kc], abs(d__1));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value */
/*< IF( K.LT.N ) THEN >*/
if (k < *n) {
/*< IMAX = K + IDAMAX( N-K, AP( KC+1 ), 1 ) >*/
i__1 = *n - k;
imax = k + idamax_(&i__1, &ap[kc + 1], &c__1);
/*< COLMAX = ABS( AP( KC+IMAX-K ) ) >*/
colmax = (d__1 = ap[kc + imax - k], abs(d__1));
/*< ELSE >*/
} else {
/*< COLMAX = ZERO >*/
colmax = 0.;
/*< END IF >*/
}
/*< IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN >*/
if (max(absakk,colmax) == 0.) {
/* Column K is zero: set INFO and continue */
/*< >*/
if (*info == 0) {
*info = k;
}
/*< KP = K >*/
kp = k;
/*< ELSE >*/
} else {
/*< IF( ABSAKK.GE.ALPHA*COLMAX ) THEN >*/
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
/*< KP = K >*/
kp = k;
/*< ELSE >*/
} else {
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
/*< ROWMAX = ZERO >*/
rowmax = 0.;
/*< KX = KC + IMAX - K >*/
kx = kc + imax - k;
/*< DO 50 J = K, IMAX - 1 >*/
i__1 = imax - 1;
for (j = k; j <= i__1; ++j) {
/*< IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN >*/
if ((d__1 = ap[kx], abs(d__1)) > rowmax) {
/*< ROWMAX = ABS( AP( KX ) ) >*/
rowmax = (d__1 = ap[kx], abs(d__1));
/*< JMAX = J >*/
jmax = j;
/*< END IF >*/
}
/*< KX = KX + N - J >*/
kx = kx + *n - j;
/*< 50 CONTINUE >*/
/* L50: */
}
/*< KPC = NPP - ( N-IMAX+1 )*( N-IMAX+2 ) / 2 + 1 >*/
kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1;
/*< IF( IMAX.LT.N ) THEN >*/
if (imax < *n) {
/*< JMAX = IMAX + IDAMAX( N-IMAX, AP( KPC+1 ), 1 ) >*/
i__1 = *n - imax;
jmax = imax + idamax_(&i__1, &ap[kpc + 1], &c__1);
/*< ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-IMAX ) ) ) >*/
/* Computing MAX */
d__2 = rowmax, d__3 = (d__1 = ap[kpc + jmax - imax], abs(
d__1));
rowmax = max(d__2,d__3);
/*< END IF >*/
}
/*< IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN >*/
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
/*< KP = K >*/
kp = k;
/*< ELSE IF( ABS( AP( KPC ) ).GE.ALPHA*ROWMAX ) THEN >*/
} else if ((d__1 = ap[kpc], abs(d__1)) >= alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1 */
/* pivot block */
/*< KP = IMAX >*/
kp = imax;
/*< ELSE >*/
} else {
/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
/* pivot block */
/*< KP = IMAX >*/
kp = imax;
/*< KSTEP = 2 >*/
kstep = 2;
/*< END IF >*/
}
/*< END IF >*/
}
/*< KK = K + KSTEP - 1 >*/
kk = k + kstep - 1;
/*< >*/
if (kstep == 2) {
knc = knc + *n - k + 1;
}
/*< IF( KP.NE.KK ) THEN >*/
if (kp != kk) {
/* Interchange rows and columns KK and KP in the trailing */
/* submatrix A(k:n,k:n) */
/*< >*/
if (kp < *n) {
i__1 = *n - kp;
dswap_(&i__1, &ap[knc + kp - kk + 1], &c__1, &ap[kpc + 1],
&c__1);
}
/*< KX = KNC + KP - KK >*/
kx = knc + kp - kk;
/*< DO 60 J = KK + 1, KP - 1 >*/
i__1 = kp - 1;
for (j = kk + 1; j <= i__1; ++j) {
/*< KX = KX + N - J + 1 >*/
kx = kx + *n - j + 1;
/*< T = AP( KNC+J-KK ) >*/
t = ap[knc + j - kk];
/*< AP( KNC+J-KK ) = AP( KX ) >*/
ap[knc + j - kk] = ap[kx];
/*< AP( KX ) = T >*/
ap[kx] = t;
/*< 60 CONTINUE >*/
/* L60: */
}
/*< T = AP( KNC ) >*/
t = ap[knc];
/*< AP( KNC ) = AP( KPC ) >*/
ap[knc] = ap[kpc];
/*< AP( KPC ) = T >*/
ap[kpc] = t;
/*< IF( KSTEP.EQ.2 ) THEN >*/
if (kstep == 2) {
/*< T = AP( KC+1 ) >*/
t = ap[kc + 1];
/*< AP( KC+1 ) = AP( KC+KP-K ) >*/
ap[kc + 1] = ap[kc + kp - k];
/*< AP( KC+KP-K ) = T >*/
ap[kc + kp - k] = t;
/*< END IF >*/
}
/*< END IF >*/
}
/* Update the trailing submatrix */
/*< IF( KSTEP.EQ.1 ) THEN >*/
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k now holds */
/* W(k) = L(k)*D(k) */
/* where L(k) is the k-th column of L */
/*< IF( K.LT.N ) THEN >*/
if (k < *n) {
/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */
/*< R1 = ONE / AP( KC ) >*/
r1 = 1. / ap[kc];
/*< >*/
i__1 = *n - k;
d__1 = -r1;
dspr_(uplo, &i__1, &d__1, &ap[kc + 1], &c__1, &ap[kc + *n
- k + 1], (ftnlen)1);
/* Store L(k) in column K */
/*< CALL DSCAL( N-K, R1, AP( KC+1 ), 1 ) >*/
i__1 = *n - k;
dscal_(&i__1, &r1, &ap[kc + 1], &c__1);
/*< END IF >*/
}
/*< ELSE >*/
} else {
/* 2-by-2 pivot block D(k): columns K and K+1 now hold */
/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */
/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */
/* of L */
/*< IF( K.LT.N-1 ) THEN >*/
if (k < *n - 1) {
/* Perform a rank-2 update of A(k+2:n,k+2:n) as */
/* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )' */
/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' */
/* Convert this to two rank-1 updates by using the eigen- */
/* decomposition of D(k) */
/*< >*/
dlaev2_(&ap[kc], &ap[kc + 1], &ap[knc], &r1, &r2, &c__, &
s);
/*< R1 = ONE / R1 >*/
r1 = 1. / r1;
/*< R2 = ONE / R2 >*/
r2 = 1. / r2;
/*< >*/
i__1 = *n - k - 1;
drot_(&i__1, &ap[kc + 2], &c__1, &ap[knc + 1], &c__1, &
c__, &s);
/*< >*/
i__1 = *n - k - 1;
d__1 = -r1;
dspr_(uplo, &i__1, &d__1, &ap[kc + 2], &c__1, &ap[knc + *
n - k], (ftnlen)1);
/*< >*/
i__1 = *n - k - 1;
d__1 = -r2;
dspr_(uplo, &i__1, &d__1, &ap[knc + 1], &c__1, &ap[knc + *
n - k], (ftnlen)1);
/* Store L(k) and L(k+1) in columns k and k+1 */
/*< CALL DSCAL( N-K-1, R1, AP( KC+2 ), 1 ) >*/
i__1 = *n - k - 1;
dscal_(&i__1, &r1, &ap[kc + 2], &c__1);
/*< CALL DSCAL( N-K-1, R2, AP( KNC+1 ), 1 ) >*/
i__1 = *n - k - 1;
dscal_(&i__1, &r2, &ap[knc + 1], &c__1);
/*< >*/
i__1 = *n - k - 1;
d__1 = -s;
drot_(&i__1, &ap[kc + 2], &c__1, &ap[knc + 1], &c__1, &
c__, &d__1);
/*< END IF >*/
}
/*< END IF >*/
}
/*< END IF >*/
}
/* Store details of the interchanges in IPIV */
/*< IF( KSTEP.EQ.1 ) THEN >*/
if (kstep == 1) {
/*< IPIV( K ) = KP >*/
ipiv[k] = kp;
/*< ELSE >*/
} else {
/*< IPIV( K ) = -KP >*/
ipiv[k] = -kp;
/*< IPIV( K+1 ) = -KP >*/
ipiv[k + 1] = -kp;
/*< END IF >*/
}
/* Increase K and return to the start of the main loop */
/*< K = K + KSTEP >*/
k += kstep;
/*< KC = KNC + N - K + 2 >*/
kc = knc + *n - k + 2;
/*< GO TO 40 >*/
goto L40;
/*< END IF >*/
}
/*< 70 CONTINUE >*/
L70:
/*< RETURN >*/
return 0;
/* End of DSPTRF */
/*< END >*/
} /* dsptrf_ */
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 zsteqr_(char *compz, integer *n, doublereal *d__,
doublereal *e, doublecomplex *z__, integer *ldz, doublereal *work,
integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
doublereal b, c__, f, g;
integer i__, j, k, l, m;
doublereal p, r__, s;
integer l1, ii, mm, lm1, mm1, nm1;
doublereal rt1, rt2, eps;
integer lsv;
doublereal tst, eps2;
integer lend, jtot;
extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
extern logical lsame_(char *, char *);
doublereal anorm;
extern /* Subroutine */ int zlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *), dlaev2_(doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *);
integer lendm1, lendp1;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
integer iscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
doublereal safmin;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
doublereal safmax;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *);
integer lendsv;
doublereal ssfmin;
integer nmaxit, icompz;
doublereal ssfmax;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a */
/* symmetric tridiagonal matrix using the implicit QL or QR method. */
/* The eigenvectors of a full or band complex Hermitian matrix can also */
/* be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this */
/* matrix to tridiagonal form. */
/* Arguments */
/* ========= */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only. */
/* = 'V': Compute eigenvalues and eigenvectors of the original */
/* Hermitian matrix. On entry, Z must contain the */
/* unitary matrix used to reduce the original matrix */
/* to tridiagonal form. */
/* = 'I': Compute eigenvalues and eigenvectors of the */
/* tridiagonal matrix. Z is initialized to the identity */
/* matrix. */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the diagonal elements of the tridiagonal matrix. */
/* On exit, if INFO = 0, the eigenvalues in ascending order. */
/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
/* matrix. */
/* On exit, E has been destroyed. */
/* Z (input/output) COMPLEX*16 array, dimension (LDZ, N) */
/* On entry, if COMPZ = 'V', then Z contains the unitary */
/* matrix used in the reduction to tridiagonal form. */
/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */
/* orthonormal eigenvectors of the original Hermitian matrix, */
/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */
/* of the symmetric tridiagonal matrix. */
/* If COMPZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* eigenvectors are desired, then LDZ >= max(1,N). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) */
/* If COMPZ = 'N', then WORK is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: the algorithm has failed to find all the eigenvalues in */
/* a total of 30*N iterations; if INFO = i, then i */
/* elements of E have not converged to zero; on exit, D */
/* and E contain the elements of a symmetric tridiagonal */
/* matrix which is unitarily similar to the original */
/* matrix. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
if (lsame_(compz, "N")) {
icompz = 0;
} else if (lsame_(compz, "V")) {
icompz = 1;
} else if (lsame_(compz, "I")) {
icompz = 2;
} else {
icompz = -1;
}
if (icompz < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZSTEQR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz == 2) {
i__1 = z_dim1 + 1;
z__[i__1].r = 1., z__[i__1].i = 0.;
}
return 0;
}
/* Determine the unit roundoff and over/underflow thresholds. */
eps = dlamch_("E");
/* Computing 2nd power */
d__1 = eps;
eps2 = d__1 * d__1;
safmin = dlamch_("S");
safmax = 1. / safmin;
ssfmax = sqrt(safmax) / 3.;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues and eigenvectors of the tridiagonal */
/* matrix. */
if (icompz == 2) {
zlaset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
nmaxit = *n * 30;
jtot = 0;
/* Determine where the matrix splits and choose QL or QR iteration */
/* for each block, according to whether top or bottom diagonal */
/* element is smaller. */
l1 = 1;
nm1 = *n - 1;
L10:
if (l1 > *n) {
goto L160;
}
if (l1 > 1) {
e[l1 - 1] = 0.;
}
if (l1 <= nm1) {
i__1 = nm1;
for (m = l1; m <= i__1; ++m) {
tst = (d__1 = e[m], abs(d__1));
if (tst == 0.) {
goto L30;
}
if (tst <= sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m
+ 1], abs(d__2))) * eps) {
e[m] = 0.;
goto L30;
}
/* L20: */
}
}
m = *n;
L30:
l = l1;
lsv = l;
lend = m;
lendsv = lend;
l1 = m + 1;
if (lend == l) {
goto L10;
}
/* Scale submatrix in rows and columns L to LEND */
i__1 = lend - l + 1;
anorm = dlanst_("I", &i__1, &d__[l], &e[l]);
iscale = 0;
if (anorm == 0.) {
goto L10;
}
if (anorm > ssfmax) {
iscale = 1;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
info);
} else if (anorm < ssfmin) {
iscale = 2;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
info);
}
/* Choose between QL and QR iteration */
if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) {
lend = lsv;
l = lendsv;
}
if (lend > l) {
/* QL Iteration */
/* Look for small subdiagonal element. */
L40:
if (l != lend) {
lendm1 = lend - 1;
i__1 = lendm1;
for (m = l; m <= i__1; ++m) {
/* Computing 2nd power */
d__2 = (d__1 = e[m], abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
+ 1], abs(d__2)) + safmin) {
goto L60;
}
/* L50: */
}
}
m = lend;
L60:
if (m < lend) {
e[m] = 0.;
}
p = d__[l];
if (m == l) {
goto L80;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */
/* to compute its eigensystem. */
if (m == l + 1) {
if (icompz > 0) {
dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
work[l] = c__;
work[*n - 1 + l] = s;
zlasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], &
z__[l * z_dim1 + 1], ldz);
} else {
dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
}
d__[l] = rt1;
d__[l + 1] = rt2;
e[l] = 0.;
l += 2;
if (l <= lend) {
goto L40;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l + 1] - p) / (e[l] * 2.);
r__ = dlapy2_(&g, &c_b41);
g = d__[m] - p + e[l] / (g + d_sign(&r__, &g));
s = 1.;
c__ = 1.;
p = 0.;
/* Inner loop */
mm1 = m - 1;
i__1 = l;
for (i__ = mm1; i__ >= i__1; --i__) {
f = s * e[i__];
b = c__ * e[i__];
dlartg_(&g, &f, &c__, &s, &r__);
if (i__ != m - 1) {
e[i__ + 1] = r__;
}
g = d__[i__ + 1] - p;
r__ = (d__[i__] - g) * s + c__ * 2. * b;
p = s * r__;
d__[i__ + 1] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
work[i__] = c__;
work[*n - 1 + i__] = -s;
}
/* L70: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = m - l + 1;
zlasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l
* z_dim1 + 1], ldz);
}
d__[l] -= p;
e[l] = g;
goto L40;
/* Eigenvalue found. */
L80:
d__[l] = p;
++l;
if (l <= lend) {
goto L40;
}
goto L140;
} else {
/* QR Iteration */
/* Look for small superdiagonal element. */
L90:
if (l != lend) {
lendp1 = lend + 1;
i__1 = lendp1;
for (m = l; m >= i__1; --m) {
/* Computing 2nd power */
d__2 = (d__1 = e[m - 1], abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
- 1], abs(d__2)) + safmin) {
goto L110;
}
/* L100: */
}
}
m = lend;
L110:
if (m > lend) {
e[m - 1] = 0.;
}
p = d__[l];
if (m == l) {
goto L130;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */
/* to compute its eigensystem. */
if (m == l - 1) {
if (icompz > 0) {
dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
;
work[m] = c__;
work[*n - 1 + m] = s;
zlasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], &
z__[(l - 1) * z_dim1 + 1], ldz);
} else {
dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
}
d__[l - 1] = rt1;
d__[l] = rt2;
e[l - 1] = 0.;
l += -2;
if (l >= lend) {
goto L90;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l - 1] - p) / (e[l - 1] * 2.);
r__ = dlapy2_(&g, &c_b41);
g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g));
s = 1.;
c__ = 1.;
p = 0.;
/* Inner loop */
lm1 = l - 1;
i__1 = lm1;
for (i__ = m; i__ <= i__1; ++i__) {
f = s * e[i__];
b = c__ * e[i__];
dlartg_(&g, &f, &c__, &s, &r__);
if (i__ != m) {
e[i__ - 1] = r__;
}
g = d__[i__] - p;
r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b;
p = s * r__;
d__[i__] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
work[i__] = c__;
work[*n - 1 + i__] = s;
}
/* L120: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = l - m + 1;
zlasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m
* z_dim1 + 1], ldz);
}
d__[l] -= p;
e[lm1] = g;
goto L90;
/* Eigenvalue found. */
L130:
d__[l] = p;
--l;
if (l >= lend) {
goto L90;
}
goto L140;
}
/* Undo scaling if necessary */
L140:
if (iscale == 1) {
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
info);
} else if (iscale == 2) {
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n,
info);
}
/* Check for no convergence to an eigenvalue after a total */
/* of N*MAXIT iterations. */
if (jtot == nmaxit) {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.) {
++(*info);
}
/* L150: */
}
return 0;
}
goto L10;
/* Order eigenvalues and eigenvectors. */
L160:
if (icompz == 0) {
/* Use Quick Sort */
dlasrt_("I", n, &d__[1], info);
} else {
/* Use Selection Sort to minimize swaps of eigenvectors */
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
i__ = ii - 1;
k = i__;
p = d__[i__];
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
if (d__[j] < p) {
k = j;
p = d__[j];
}
/* L170: */
}
if (k != i__) {
d__[k] = d__[i__];
d__[i__] = p;
zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1],
&c__1);
}
/* L180: */
}
}
return 0;
/* End of ZSTEQR */
} /* zsteqr_ */
/* Subroutine */ int dstemr_(char *jobz, char *range, integer *n, doublereal *
d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il,
integer *iu, integer *m, doublereal *w, doublereal *z__, integer *ldz,
integer *nzc, integer *isuppz, logical *tryrac, doublereal *work,
integer *lwork, integer *iwork, integer *liwork, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j;
doublereal r1, r2;
integer jj;
doublereal cs;
integer in;
doublereal sn, wl, wu;
integer iil, iiu;
doublereal eps, tmp;
integer indd, iend, jblk, wend;
doublereal rmin, rmax;
integer itmp;
doublereal tnrm;
extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
integer inde2, itmp2;
doublereal rtol1, rtol2;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
doublereal scale;
integer indgp;
extern logical lsame_(char *, char *);
integer iinfo, iindw, ilast;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
integer lwmin;
logical wantz;
extern /* Subroutine */ int dlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
extern doublereal dlamch_(char *);
logical alleig;
integer ibegin;
logical indeig;
integer iindbl;
logical valeig;
extern /* Subroutine */ int dlarrc_(char *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *, integer *, integer *), dlarre_(char *,
integer *, doublereal *, doublereal *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *);
integer wbegin;
doublereal safmin;
extern /* Subroutine */ int dlarrj_(integer *, doublereal *, doublereal *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *), xerbla_(char *, integer *);
doublereal bignum;
integer inderr, iindwk, indgrs, offset;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dlarrr_(integer *, doublereal *, doublereal *,
integer *), dlarrv_(integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlasrt_(char *, integer *, doublereal *,
integer *);
doublereal thresh;
integer iinspl, ifirst, indwrk, liwmin, nzcmin;
doublereal pivmin;
integer nsplit;
doublereal smlnum;
logical lquery, zquery;
/* -- LAPACK computational routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSTEMR computes selected eigenvalues and, optionally, eigenvectors */
/* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */
/* a well defined set of pairwise different real eigenvalues, the corresponding */
/* real eigenvectors are pairwise orthogonal. */
/* The spectrum may be computed either completely or partially by specifying */
/* either an interval (VL,VU] or a range of indices IL:IU for the desired */
/* eigenvalues. */
/* Depending on the number of desired eigenvalues, these are computed either */
/* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are */
/* computed by the use of various suitable L D L^T factorizations near clusters */
/* of close eigenvalues (referred to as RRRs, Relatively Robust */
/* Representations). An informal sketch of the algorithm follows. */
/* For each unreduced block (submatrix) of T, */
/* (a) Compute T - sigma I = L D L^T, so that L and D */
/* define all the wanted eigenvalues to high relative accuracy. */
/* This means that small relative changes in the entries of D and L */
/* cause only small relative changes in the eigenvalues and */
/* eigenvectors. The standard (unfactored) representation of the */
/* tridiagonal matrix T does not have this property in general. */
/* (b) Compute the eigenvalues to suitable accuracy. */
/* If the eigenvectors are desired, the algorithm attains full */
/* accuracy of the computed eigenvalues only right before */
/* the corresponding vectors have to be computed, see steps c) and d). */
/* (c) For each cluster of close eigenvalues, select a new */
/* shift close to the cluster, find a new factorization, and refine */
/* the shifted eigenvalues to suitable accuracy. */
/* (d) For each eigenvalue with a large enough relative separation compute */
/* the corresponding eigenvector by forming a rank revealing twisted */
/* factorization. Go back to (c) for any clusters that remain. */
/* For more details, see: */
/* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */
/* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */
/* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */
/* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */
/* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */
/* 2004. Also LAPACK Working Note 154. */
/* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */
/* tridiagonal eigenvalue/eigenvector problem", */
/* Computer Science Division Technical Report No. UCB/CSD-97-971, */
/* UC Berkeley, May 1997. */
/* Notes: */
/* 1.DSTEMR works only on machines which follow IEEE-754 */
/* floating-point standard in their handling of infinities and NaNs. */
/* This permits the use of efficient inner loops avoiding a check for */
/* zero divisors. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* RANGE (input) CHARACTER*1 */
/* = 'A': all eigenvalues will be found. */
/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
/* will be found. */
/* = 'I': the IL-th through IU-th eigenvalues will be found. */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the N diagonal elements of the tridiagonal matrix */
/* T. On exit, D is overwritten. */
/* E (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the (N-1) subdiagonal elements of the tridiagonal */
/* matrix T in elements 1 to N-1 of E. E(N) need not be set on */
/* input, but is used internally as workspace. */
/* On exit, E is overwritten. */
/* VL (input) DOUBLE PRECISION */
/* VU (input) DOUBLE PRECISION */
/* If RANGE='V', the lower and upper bounds of the interval to */
/* be searched for eigenvalues. VL < VU. */
/* Not referenced if RANGE = 'A' or 'I'. */
/* IL (input) INTEGER */
/* IU (input) INTEGER */
/* If RANGE='I', the indices (in ascending order) of the */
/* smallest and largest eigenvalues to be returned. */
/* 1 <= IL <= IU <= N, if N > 0. */
/* Not referenced if RANGE = 'A' or 'V'. */
/* M (output) INTEGER */
/* The total number of eigenvalues found. 0 <= M <= N. */
/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
/* W (output) DOUBLE PRECISION array, dimension (N) */
/* The first M elements contain the selected eigenvalues in */
/* ascending order. */
/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) */
/* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */
/* contain the orthonormal eigenvectors of the matrix T */
/* corresponding to the selected eigenvalues, with the i-th */
/* column of Z holding the eigenvector associated with W(i). */
/* If JOBZ = 'N', then Z is not referenced. */
/* Note: the user must ensure that at least max(1,M) columns are */
/* supplied in the array Z; if RANGE = 'V', the exact value of M */
/* is not known in advance and can be computed with a workspace */
/* query by setting NZC = -1, see below. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', then LDZ >= max(1,N). */
/* NZC (input) INTEGER */
/* The number of eigenvectors to be held in the array Z. */
/* If RANGE = 'A', then NZC >= max(1,N). */
/* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU]. */
/* If RANGE = 'I', then NZC >= IU-IL+1. */
/* If NZC = -1, then a workspace query is assumed; the */
/* routine calculates the number of columns of the array Z that */
/* are needed to hold the eigenvectors. */
/* This value is returned as the first entry of the Z array, and */
/* no error message related to NZC is issued by XERBLA. */
/* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) ) */
/* The support of the eigenvectors in Z, i.e., the indices */
/* indicating the nonzero elements in Z. The i-th computed eigenvector */
/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */
/* ISUPPZ( 2*i ). This is relevant in the case when the matrix */
/* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */
/* TRYRAC (input/output) LOGICAL */
/* If TRYRAC.EQ..TRUE., indicates that the code should check whether */
/* the tridiagonal matrix defines its eigenvalues to high relative */
/* accuracy. If so, the code uses relative-accuracy preserving */
/* algorithms that might be (a bit) slower depending on the matrix. */
/* If the matrix does not define its eigenvalues to high relative */
/* accuracy, the code can uses possibly faster algorithms. */
/* If TRYRAC.EQ..FALSE., the code is not required to guarantee */
/* relatively accurate eigenvalues and can use the fastest possible */
/* techniques. */
/* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix */
/* does not define its eigenvalues to high relative accuracy. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal */
/* (and minimal) LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,18*N) */
/* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* IWORK (workspace/output) INTEGER array, dimension (LIWORK) */
/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. LIWORK >= max(1,10*N) */
/* if the eigenvectors are desired, and LIWORK >= max(1,8*N) */
/* if only the eigenvalues are to be computed. */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal size of the IWORK array, */
/* returns this value as the first entry of the IWORK array, and */
/* no error message related to LIWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* On exit, INFO */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = 1X, internal error in DLARRE, */
/* if INFO = 2X, internal error in DLARRV. */
/* Here, the digit X = ABS( IINFO ) < 10, where IINFO is */
/* the nonzero error code returned by DLARRE or */
/* DLARRV, respectively. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Beresford Parlett, University of California, Berkeley, USA */
/* Jim Demmel, University of California, Berkeley, USA */
/* Inderjit Dhillon, University of Texas, Austin, USA */
/* Osni Marques, LBNL/NERSC, USA */
/* Christof Voemel, University of California, Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--isuppz;
--work;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
lquery = *lwork == -1 || *liwork == -1;
zquery = *nzc == -1;
/* DSTEMR needs WORK of size 6*N, IWORK of size 3*N. */
/* In addition, DLARRE needs WORK of size 6*N, IWORK of size 5*N. */
/* Furthermore, DLARRV needs WORK of size 12*N, IWORK of size 7*N. */
if (wantz) {
lwmin = *n * 18;
liwmin = *n * 10;
} else {
/* need less workspace if only the eigenvalues are wanted */
lwmin = *n * 12;
liwmin = *n << 3;
}
wl = 0.;
wu = 0.;
iil = 0;
iiu = 0;
if (valeig) {
/* We do not reference VL, VU in the cases RANGE = 'I','A' */
/* The interval (WL, WU] contains all the wanted eigenvalues. */
/* It is either given by the user or computed in DLARRE. */
wl = *vl;
wu = *vu;
} else if (indeig) {
/* We do not reference IL, IU in the cases RANGE = 'V','A' */
iil = *il;
iiu = *iu;
}
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (valeig && *n > 0 && wu <= wl) {
*info = -7;
} else if (indeig && (iil < 1 || iil > *n)) {
*info = -8;
} else if (indeig && (iiu < iil || iiu > *n)) {
*info = -9;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -13;
} else if (*lwork < lwmin && ! lquery) {
*info = -17;
} else if (*liwork < liwmin && ! lquery) {
*info = -19;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
rmax = min(d__1,d__2);
if (*info == 0) {
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
if (wantz && alleig) {
nzcmin = *n;
} else if (wantz && valeig) {
dlarrc_("T", n, vl, vu, &d__[1], &e[1], &safmin, &nzcmin, &itmp, &
itmp2, info);
} else if (wantz && indeig) {
nzcmin = iiu - iil + 1;
} else {
/* WANTZ .EQ. FALSE. */
nzcmin = 0;
}
if (zquery && *info == 0) {
z__[z_dim1 + 1] = (doublereal) nzcmin;
} else if (*nzc < nzcmin && ! zquery) {
*info = -14;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSTEMR", &i__1);
return 0;
} else if (lquery || zquery) {
return 0;
}
/* Handle N = 0, 1, and 2 cases immediately */
*m = 0;
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (alleig || indeig) {
*m = 1;
w[1] = d__[1];
} else {
if (wl < d__[1] && wu >= d__[1]) {
*m = 1;
w[1] = d__[1];
}
}
if (wantz && ! zquery) {
z__[z_dim1 + 1] = 1.;
isuppz[1] = 1;
isuppz[2] = 1;
}
return 0;
}
if (*n == 2) {
if (! wantz) {
dlae2_(&d__[1], &e[1], &d__[2], &r1, &r2);
} else if (wantz && ! zquery) {
dlaev2_(&d__[1], &e[1], &d__[2], &r1, &r2, &cs, &sn);
}
if (alleig || valeig && r2 > wl && r2 <= wu || indeig && iil == 1) {
++(*m);
w[*m] = r2;
if (wantz && ! zquery) {
z__[*m * z_dim1 + 1] = -sn;
z__[*m * z_dim1 + 2] = cs;
/* Note: At most one of SN and CS can be zero. */
if (sn != 0.) {
if (cs != 0.) {
isuppz[(*m << 1) - 1] = 1;
isuppz[(*m << 1) - 1] = 2;
} else {
isuppz[(*m << 1) - 1] = 1;
isuppz[(*m << 1) - 1] = 1;
}
} else {
isuppz[(*m << 1) - 1] = 2;
isuppz[*m * 2] = 2;
}
}
}
if (alleig || valeig && r1 > wl && r1 <= wu || indeig && iiu == 2) {
++(*m);
w[*m] = r1;
if (wantz && ! zquery) {
z__[*m * z_dim1 + 1] = cs;
z__[*m * z_dim1 + 2] = sn;
/* Note: At most one of SN and CS can be zero. */
if (sn != 0.) {
if (cs != 0.) {
isuppz[(*m << 1) - 1] = 1;
isuppz[(*m << 1) - 1] = 2;
} else {
isuppz[(*m << 1) - 1] = 1;
isuppz[(*m << 1) - 1] = 1;
}
} else {
isuppz[(*m << 1) - 1] = 2;
isuppz[*m * 2] = 2;
}
}
}
return 0;
}
/* Continue with general N */
indgrs = 1;
inderr = (*n << 1) + 1;
indgp = *n * 3 + 1;
indd = (*n << 2) + 1;
inde2 = *n * 5 + 1;
indwrk = *n * 6 + 1;
iinspl = 1;
iindbl = *n + 1;
iindw = (*n << 1) + 1;
iindwk = *n * 3 + 1;
/* Scale matrix to allowable range, if necessary. */
/* The allowable range is related to the PIVMIN parameter; see the */
/* comments in DLARRD. The preference for scaling small values */
/* up is heuristic; we expect users' matrices not to be close to the */
/* RMAX threshold. */
scale = 1.;
tnrm = dlanst_("M", n, &d__[1], &e[1]);
if (tnrm > 0. && tnrm < rmin) {
scale = rmin / tnrm;
} else if (tnrm > rmax) {
scale = rmax / tnrm;
}
if (scale != 1.) {
dscal_(n, &scale, &d__[1], &c__1);
i__1 = *n - 1;
dscal_(&i__1, &scale, &e[1], &c__1);
tnrm *= scale;
if (valeig) {
/* If eigenvalues in interval have to be found, */
/* scale (WL, WU] accordingly */
wl *= scale;
wu *= scale;
}
}
/* Compute the desired eigenvalues of the tridiagonal after splitting */
/* into smaller subblocks if the corresponding off-diagonal elements */
/* are small */
/* THRESH is the splitting parameter for DLARRE */
/* A negative THRESH forces the old splitting criterion based on the */
/* size of the off-diagonal. A positive THRESH switches to splitting */
/* which preserves relative accuracy. */
if (*tryrac) {
/* Test whether the matrix warrants the more expensive relative approach. */
dlarrr_(n, &d__[1], &e[1], &iinfo);
} else {
/* The user does not care about relative accurately eigenvalues */
iinfo = -1;
}
/* Set the splitting criterion */
if (iinfo == 0) {
thresh = eps;
} else {
thresh = -eps;
/* relative accuracy is desired but T does not guarantee it */
*tryrac = FALSE_;
}
if (*tryrac) {
/* Copy original diagonal, needed to guarantee relative accuracy */
dcopy_(n, &d__[1], &c__1, &work[indd], &c__1);
}
/* Store the squares of the offdiagonal values of T */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/* Computing 2nd power */
d__1 = e[j];
work[inde2 + j - 1] = d__1 * d__1;
/* L5: */
}
/* Set the tolerance parameters for bisection */
if (! wantz) {
/* DLARRE computes the eigenvalues to full precision. */
rtol1 = eps * 4.;
rtol2 = eps * 4.;
} else {
/* DLARRE computes the eigenvalues to less than full precision. */
/* DLARRV will refine the eigenvalue approximations, and we can */
/* need less accurate initial bisection in DLARRE. */
/* Note: these settings do only affect the subset case and DLARRE */
rtol1 = sqrt(eps);
/* Computing MAX */
d__1 = sqrt(eps) * .005, d__2 = eps * 4.;
rtol2 = max(d__1,d__2);
}
dlarre_(range, n, &wl, &wu, &iil, &iiu, &d__[1], &e[1], &work[inde2], &
rtol1, &rtol2, &thresh, &nsplit, &iwork[iinspl], m, &w[1], &work[
inderr], &work[indgp], &iwork[iindbl], &iwork[iindw], &work[
indgrs], &pivmin, &work[indwrk], &iwork[iindwk], &iinfo);
if (iinfo != 0) {
*info = abs(iinfo) + 10;
return 0;
}
/* Note that if RANGE .NE. 'V', DLARRE computes bounds on the desired */
/* part of the spectrum. All desired eigenvalues are contained in */
/* (WL,WU] */
if (wantz) {
/* Compute the desired eigenvectors corresponding to the computed */
/* eigenvalues */
dlarrv_(n, &wl, &wu, &d__[1], &e[1], &pivmin, &iwork[iinspl], m, &
c__1, m, &c_b18, &rtol1, &rtol2, &w[1], &work[inderr], &work[
indgp], &iwork[iindbl], &iwork[iindw], &work[indgrs], &z__[
z_offset], ldz, &isuppz[1], &work[indwrk], &iwork[iindwk], &
iinfo);
if (iinfo != 0) {
*info = abs(iinfo) + 20;
return 0;
}
} else {
/* DLARRE computes eigenvalues of the (shifted) root representation */
/* DLARRV returns the eigenvalues of the unshifted matrix. */
/* However, if the eigenvectors are not desired by the user, we need */
/* to apply the corresponding shifts from DLARRE to obtain the */
/* eigenvalues of the original matrix. */
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
itmp = iwork[iindbl + j - 1];
w[j] += e[iwork[iinspl + itmp - 1]];
/* L20: */
}
}
if (*tryrac) {
/* Refine computed eigenvalues so that they are relatively accurate */
/* with respect to the original matrix T. */
ibegin = 1;
wbegin = 1;
i__1 = iwork[iindbl + *m - 1];
for (jblk = 1; jblk <= i__1; ++jblk) {
iend = iwork[iinspl + jblk - 1];
in = iend - ibegin + 1;
wend = wbegin - 1;
/* check if any eigenvalues have to be refined in this block */
L36:
if (wend < *m) {
if (iwork[iindbl + wend] == jblk) {
++wend;
goto L36;
}
}
if (wend < wbegin) {
ibegin = iend + 1;
goto L39;
}
offset = iwork[iindw + wbegin - 1] - 1;
ifirst = iwork[iindw + wbegin - 1];
ilast = iwork[iindw + wend - 1];
rtol2 = eps * 4.;
dlarrj_(&in, &work[indd + ibegin - 1], &work[inde2 + ibegin - 1],
&ifirst, &ilast, &rtol2, &offset, &w[wbegin], &work[
inderr + wbegin - 1], &work[indwrk], &iwork[iindwk], &
pivmin, &tnrm, &iinfo);
ibegin = iend + 1;
wbegin = wend + 1;
L39:
;
}
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (scale != 1.) {
d__1 = 1. / scale;
dscal_(m, &d__1, &w[1], &c__1);
}
/* If eigenvalues are not in increasing order, then sort them, */
/* possibly along with eigenvectors. */
if (nsplit > 1) {
if (! wantz) {
dlasrt_("I", m, &w[1], &iinfo);
if (iinfo != 0) {
*info = 3;
return 0;
}
} else {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
i__ = 0;
tmp = w[j];
i__2 = *m;
for (jj = j + 1; jj <= i__2; ++jj) {
if (w[jj] < tmp) {
i__ = jj;
tmp = w[jj];
}
/* L50: */
}
if (i__ != 0) {
w[i__] = w[j];
w[j] = tmp;
if (wantz) {
dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j *
z_dim1 + 1], &c__1);
itmp = isuppz[(i__ << 1) - 1];
isuppz[(i__ << 1) - 1] = isuppz[(j << 1) - 1];
isuppz[(j << 1) - 1] = itmp;
itmp = isuppz[i__ * 2];
isuppz[i__ * 2] = isuppz[j * 2];
isuppz[j * 2] = itmp;
}
}
/* L60: */
}
}
}
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
return 0;
/* End of DSTEMR */
} /* dstemr_ */
/* 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 */ int zlaev2_(doublecomplex *a, doublecomplex *b,
doublecomplex *c__, doublereal *rt1, doublereal *rt2, doublereal *cs1,
doublecomplex *sn1)
{
/* System generated locals */
doublereal d__1, d__2, d__3;
doublecomplex z__1, z__2;
/* Builtin functions */
double z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
doublereal t;
doublecomplex w;
extern /* Subroutine */ int dlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix */
/* [ A B ] */
/* [ CONJG(B) C ]. */
/* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the */
/* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right */
/* eigenvector for RT1, giving the decomposition */
/* [ CS1 CONJG(SN1) ] [ A B ] [ CS1 -CONJG(SN1) ] = [ RT1 0 ] */
/* [-SN1 CS1 ] [ CONJG(B) C ] [ SN1 CS1 ] [ 0 RT2 ]. */
/* Arguments */
/* ========= */
/* A (input) COMPLEX*16 */
/* The (1,1) element of the 2-by-2 matrix. */
/* B (input) COMPLEX*16 */
/* The (1,2) element and the conjugate of the (2,1) element of */
/* the 2-by-2 matrix. */
/* C (input) COMPLEX*16 */
/* The (2,2) element of the 2-by-2 matrix. */
/* RT1 (output) DOUBLE PRECISION */
/* The eigenvalue of larger absolute value. */
/* RT2 (output) DOUBLE PRECISION */
/* The eigenvalue of smaller absolute value. */
/* CS1 (output) DOUBLE PRECISION */
/* SN1 (output) COMPLEX*16 */
/* The vector (CS1, SN1) is a unit right eigenvector for RT1. */
/* Further Details */
/* =============== */
/* RT1 is accurate to a few ulps barring over/underflow. */
/* RT2 may be inaccurate if there is massive cancellation in the */
/* determinant A*C-B*B; higher precision or correctly rounded or */
/* correctly truncated arithmetic would be needed to compute RT2 */
/* accurately in all cases. */
/* CS1 and SN1 are accurate to a few ulps barring over/underflow. */
/* Overflow is possible only if RT1 is within a factor of 5 of overflow. */
/* Underflow is harmless if the input data is 0 or exceeds */
/* underflow_threshold / macheps. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
if (z_abs(b) == 0.) {
w.r = 1., w.i = 0.;
} else {
d_cnjg(&z__2, b);
d__1 = z_abs(b);
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
w.r = z__1.r, w.i = z__1.i;
}
d__1 = a->r;
d__2 = z_abs(b);
d__3 = c__->r;
dlaev2_(&d__1, &d__2, &d__3, rt1, rt2, cs1, &t);
z__1.r = t * w.r, z__1.i = t * w.i;
sn1->r = z__1.r, sn1->i = z__1.i;
return 0;
/* End of ZLAEV2 */
} /* zlaev2_ */
/*< 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 zstemr_(char *jobz, char *range, integer *n, doublereal * d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il, integer *iu, integer *m, doublereal *w, doublecomplex *z__, integer * ldz, integer *nzc, integer *isuppz, logical *tryrac, doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j;
doublereal r1, r2;
integer jj;
doublereal cs;
integer in;
doublereal sn, wl, wu;
integer iil, iiu;
doublereal eps, tmp;
integer indd, iend, jblk, wend;
doublereal rmin, rmax;
integer itmp;
doublereal tnrm;
extern /* Subroutine */
int dlae2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *);
integer inde2, itmp2;
doublereal rtol1, rtol2;
extern /* Subroutine */
int dscal_(integer *, doublereal *, doublereal *, integer *);
doublereal scale;
integer indgp;
extern logical lsame_(char *, char *);
integer iinfo, iindw, ilast;
extern /* Subroutine */
int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
integer lwmin;
logical wantz;
extern /* Subroutine */
int zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), dlaev2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *);
extern doublereal dlamch_(char *);
logical alleig;
integer ibegin;
logical indeig;
integer iindbl;
logical valeig;
extern /* Subroutine */
int dlarrc_(char *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, integer *, integer *, integer *), dlarre_(char *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *);
integer wbegin;
doublereal safmin;
extern /* Subroutine */
int dlarrj_(integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
doublereal bignum;
integer inderr, iindwk, indgrs, offset;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */
int dlarrr_(integer *, doublereal *, doublereal *, integer *), dlasrt_(char *, integer *, doublereal *, integer *);
doublereal thresh;
integer iinspl, indwrk, ifirst, liwmin, nzcmin;
doublereal pivmin;
integer nsplit;
doublereal smlnum;
extern /* Subroutine */
int zlarrv_(integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublecomplex *, integer *, integer *, doublereal *, integer *, integer *);
logical lquery, zquery;
/* -- LAPACK computational routine (version 3.5.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2013 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--isuppz;
--work;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
lquery = *lwork == -1 || *liwork == -1;
zquery = *nzc == -1;
/* DSTEMR needs WORK of size 6*N, IWORK of size 3*N. */
/* In addition, DLARRE needs WORK of size 6*N, IWORK of size 5*N. */
/* Furthermore, ZLARRV needs WORK of size 12*N, IWORK of size 7*N. */
if (wantz)
{
lwmin = *n * 18;
liwmin = *n * 10;
}
else
{
/* need less workspace if only the eigenvalues are wanted */
lwmin = *n * 12;
liwmin = *n << 3;
}
wl = 0.;
wu = 0.;
iil = 0;
iiu = 0;
nsplit = 0;
if (valeig)
{
/* We do not reference VL, VU in the cases RANGE = 'I','A' */
/* The interval (WL, WU] contains all the wanted eigenvalues. */
/* It is either given by the user or computed in DLARRE. */
wl = *vl;
wu = *vu;
}
else if (indeig)
{
/* We do not reference IL, IU in the cases RANGE = 'V','A' */
iil = *il;
iiu = *iu;
}
*info = 0;
if (! (wantz || lsame_(jobz, "N")))
{
*info = -1;
}
else if (! (alleig || valeig || indeig))
{
*info = -2;
}
else if (*n < 0)
{
*info = -3;
}
else if (valeig && *n > 0 && wu <= wl)
{
*info = -7;
}
else if (indeig && (iil < 1 || iil > *n))
{
*info = -8;
}
else if (indeig && (iiu < iil || iiu > *n))
{
*info = -9;
}
else if (*ldz < 1 || wantz && *ldz < *n)
{
*info = -13;
}
else if (*lwork < lwmin && ! lquery)
{
*info = -17;
}
else if (*liwork < liwmin && ! lquery)
{
*info = -19;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
d__1 = sqrt(bignum);
d__2 = 1. / sqrt(sqrt(safmin)); // , expr subst
rmax = min(d__1,d__2);
if (*info == 0)
{
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
if (wantz && alleig)
{
nzcmin = *n;
}
else if (wantz && valeig)
{
dlarrc_("T", n, vl, vu, &d__[1], &e[1], &safmin, &nzcmin, &itmp, & itmp2, info);
}
else if (wantz && indeig)
{
nzcmin = iiu - iil + 1;
}
else
{
/* WANTZ .EQ. FALSE. */
nzcmin = 0;
}
if (zquery && *info == 0)
{
i__1 = z_dim1 + 1;
z__[i__1].r = (doublereal) nzcmin;
z__[i__1].i = 0.; // , expr subst
}
else if (*nzc < nzcmin && ! zquery)
{
*info = -14;
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZSTEMR", &i__1);
return 0;
}
else if (lquery || zquery)
{
return 0;
}
/* Handle N = 0, 1, and 2 cases immediately */
*m = 0;
if (*n == 0)
{
return 0;
}
if (*n == 1)
{
if (alleig || indeig)
{
*m = 1;
w[1] = d__[1];
}
else
{
if (wl < d__[1] && wu >= d__[1])
{
*m = 1;
w[1] = d__[1];
}
}
if (wantz && ! zquery)
{
i__1 = z_dim1 + 1;
z__[i__1].r = 1.;
z__[i__1].i = 0.; // , expr subst
isuppz[1] = 1;
isuppz[2] = 1;
}
return 0;
}
if (*n == 2)
{
if (! wantz)
{
dlae2_(&d__[1], &e[1], &d__[2], &r1, &r2);
}
else if (wantz && ! zquery)
{
dlaev2_(&d__[1], &e[1], &d__[2], &r1, &r2, &cs, &sn);
}
if (alleig || valeig && r2 > wl && r2 <= wu || indeig && iil == 1)
{
++(*m);
w[*m] = r2;
if (wantz && ! zquery)
{
i__1 = *m * z_dim1 + 1;
d__1 = -sn;
z__[i__1].r = d__1;
z__[i__1].i = 0.; // , expr subst
i__1 = *m * z_dim1 + 2;
z__[i__1].r = cs;
z__[i__1].i = 0.; // , expr subst
/* Note: At most one of SN and CS can be zero. */
if (sn != 0.)
{
if (cs != 0.)
{
isuppz[(*m << 1) - 1] = 1;
isuppz[(*m << 1) - 1] = 2;
}
else
{
isuppz[(*m << 1) - 1] = 1;
isuppz[(*m << 1) - 1] = 1;
}
}
else
{
isuppz[(*m << 1) - 1] = 2;
isuppz[*m * 2] = 2;
}
}
}
if (alleig || valeig && r1 > wl && r1 <= wu || indeig && iiu == 2)
{
++(*m);
w[*m] = r1;
if (wantz && ! zquery)
{
i__1 = *m * z_dim1 + 1;
z__[i__1].r = cs;
z__[i__1].i = 0.; // , expr subst
i__1 = *m * z_dim1 + 2;
z__[i__1].r = sn;
z__[i__1].i = 0.; // , expr subst
/* Note: At most one of SN and CS can be zero. */
if (sn != 0.)
{
if (cs != 0.)
{
isuppz[(*m << 1) - 1] = 1;
isuppz[(*m << 1) - 1] = 2;
}
else
{
isuppz[(*m << 1) - 1] = 1;
isuppz[(*m << 1) - 1] = 1;
}
}
else
{
isuppz[(*m << 1) - 1] = 2;
isuppz[*m * 2] = 2;
}
}
}
}
else
{
/* Continue with general N */
indgrs = 1;
inderr = (*n << 1) + 1;
indgp = *n * 3 + 1;
indd = (*n << 2) + 1;
inde2 = *n * 5 + 1;
indwrk = *n * 6 + 1;
iinspl = 1;
iindbl = *n + 1;
iindw = (*n << 1) + 1;
iindwk = *n * 3 + 1;
/* Scale matrix to allowable range, if necessary. */
/* The allowable range is related to the PIVMIN parameter;
see the */
/* comments in DLARRD. The preference for scaling small values */
/* up is heuristic;
we expect users' matrices not to be close to the */
/* RMAX threshold. */
scale = 1.;
tnrm = dlanst_("M", n, &d__[1], &e[1]);
if (tnrm > 0. && tnrm < rmin)
{
scale = rmin / tnrm;
}
else if (tnrm > rmax)
{
scale = rmax / tnrm;
}
if (scale != 1.)
{
dscal_(n, &scale, &d__[1], &c__1);
i__1 = *n - 1;
dscal_(&i__1, &scale, &e[1], &c__1);
tnrm *= scale;
if (valeig)
{
/* If eigenvalues in interval have to be found, */
/* scale (WL, WU] accordingly */
wl *= scale;
wu *= scale;
}
}
/* Compute the desired eigenvalues of the tridiagonal after splitting */
/* into smaller subblocks if the corresponding off-diagonal elements */
/* are small */
/* THRESH is the splitting parameter for DLARRE */
/* A negative THRESH forces the old splitting criterion based on the */
/* size of the off-diagonal. A positive THRESH switches to splitting */
/* which preserves relative accuracy. */
if (*tryrac)
{
/* Test whether the matrix warrants the more expensive relative approach. */
dlarrr_(n, &d__[1], &e[1], &iinfo);
}
else
{
/* The user does not care about relative accurately eigenvalues */
iinfo = -1;
}
/* Set the splitting criterion */
if (iinfo == 0)
{
thresh = eps;
}
else
{
thresh = -eps;
/* relative accuracy is desired but T does not guarantee it */
*tryrac = FALSE_;
}
if (*tryrac)
{
/* Copy original diagonal, needed to guarantee relative accuracy */
dcopy_(n, &d__[1], &c__1, &work[indd], &c__1);
}
/* Store the squares of the offdiagonal values of T */
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
/* Computing 2nd power */
d__1 = e[j];
work[inde2 + j - 1] = d__1 * d__1;
/* L5: */
}
/* Set the tolerance parameters for bisection */
if (! wantz)
{
/* DLARRE computes the eigenvalues to full precision. */
rtol1 = eps * 4.;
rtol2 = eps * 4.;
}
else
{
/* DLARRE computes the eigenvalues to less than full precision. */
/* ZLARRV will refine the eigenvalue approximations, and we only */
/* need less accurate initial bisection in DLARRE. */
/* Note: these settings do only affect the subset case and DLARRE */
rtol1 = sqrt(eps);
/* Computing MAX */
d__1 = sqrt(eps) * .005;
d__2 = eps * 4.; // , expr subst
rtol2 = max(d__1,d__2);
}
dlarre_(range, n, &wl, &wu, &iil, &iiu, &d__[1], &e[1], &work[inde2], &rtol1, &rtol2, &thresh, &nsplit, &iwork[iinspl], m, &w[1], & work[inderr], &work[indgp], &iwork[iindbl], &iwork[iindw], & work[indgrs], &pivmin, &work[indwrk], &iwork[iindwk], &iinfo);
if (iinfo != 0)
{
*info = f2c_abs(iinfo) + 10;
return 0;
}
/* Note that if RANGE .NE. 'V', DLARRE computes bounds on the desired */
/* part of the spectrum. All desired eigenvalues are contained in */
/* (WL,WU] */
if (wantz)
{
/* Compute the desired eigenvectors corresponding to the computed */
/* eigenvalues */
zlarrv_(n, &wl, &wu, &d__[1], &e[1], &pivmin, &iwork[iinspl], m, & c__1, m, &c_b18, &rtol1, &rtol2, &w[1], &work[inderr], & work[indgp], &iwork[iindbl], &iwork[iindw], &work[indgrs], &z__[z_offset], ldz, &isuppz[1], &work[indwrk], &iwork[ iindwk], &iinfo);
if (iinfo != 0)
{
*info = f2c_abs(iinfo) + 20;
return 0;
}
}
else
{
/* DLARRE computes eigenvalues of the (shifted) root representation */
/* ZLARRV returns the eigenvalues of the unshifted matrix. */
/* However, if the eigenvectors are not desired by the user, we need */
/* to apply the corresponding shifts from DLARRE to obtain the */
/* eigenvalues of the original matrix. */
i__1 = *m;
for (j = 1;
j <= i__1;
++j)
{
itmp = iwork[iindbl + j - 1];
w[j] += e[iwork[iinspl + itmp - 1]];
/* L20: */
}
}
if (*tryrac)
{
/* Refine computed eigenvalues so that they are relatively accurate */
/* with respect to the original matrix T. */
ibegin = 1;
wbegin = 1;
i__1 = iwork[iindbl + *m - 1];
for (jblk = 1;
jblk <= i__1;
++jblk)
{
iend = iwork[iinspl + jblk - 1];
in = iend - ibegin + 1;
wend = wbegin - 1;
/* check if any eigenvalues have to be refined in this block */
L36:
if (wend < *m)
{
if (iwork[iindbl + wend] == jblk)
{
++wend;
goto L36;
}
}
if (wend < wbegin)
{
ibegin = iend + 1;
goto L39;
}
offset = iwork[iindw + wbegin - 1] - 1;
ifirst = iwork[iindw + wbegin - 1];
ilast = iwork[iindw + wend - 1];
rtol2 = eps * 4.;
dlarrj_(&in, &work[indd + ibegin - 1], &work[inde2 + ibegin - 1], &ifirst, &ilast, &rtol2, &offset, &w[wbegin], & work[inderr + wbegin - 1], &work[indwrk], &iwork[ iindwk], &pivmin, &tnrm, &iinfo);
ibegin = iend + 1;
wbegin = wend + 1;
L39:
;
}
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (scale != 1.)
{
d__1 = 1. / scale;
dscal_(m, &d__1, &w[1], &c__1);
}
}
/* If eigenvalues are not in increasing order, then sort them, */
/* possibly along with eigenvectors. */
if (nsplit > 1 || *n == 2)
{
if (! wantz)
{
dlasrt_("I", m, &w[1], &iinfo);
if (iinfo != 0)
{
*info = 3;
return 0;
}
}
else
{
i__1 = *m - 1;
for (j = 1;
j <= i__1;
++j)
{
i__ = 0;
tmp = w[j];
i__2 = *m;
for (jj = j + 1;
jj <= i__2;
++jj)
{
if (w[jj] < tmp)
{
i__ = jj;
tmp = w[jj];
}
/* L50: */
}
if (i__ != 0)
{
w[i__] = w[j];
w[j] = tmp;
if (wantz)
{
zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], &c__1);
itmp = isuppz[(i__ << 1) - 1];
isuppz[(i__ << 1) - 1] = isuppz[(j << 1) - 1];
isuppz[(j << 1) - 1] = itmp;
itmp = isuppz[i__ * 2];
isuppz[i__ * 2] = isuppz[j * 2];
isuppz[j * 2] = itmp;
}
}
/* L60: */
}
}
}
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
return 0;
/* End of ZSTEMR */
}
/* Subroutine */ int zlaev2_(doublecomplex *a, doublecomplex *b,
doublecomplex *c, doublereal *rt1, doublereal *rt2, doublereal *cs1,
doublecomplex *sn1)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
ZLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix
[ A B ]
[ CONJG(B) C ].
On return, RT1 is the eigenvalue of larger absolute value, RT2 is the
eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right
eigenvector for RT1, giving the decomposition
[ CS1 CONJG(SN1) ] [ A B ] [ CS1 -CONJG(SN1) ] = [ RT1 0 ]
[-SN1 CS1 ] [ CONJG(B) C ] [ SN1 CS1 ] [ 0 RT2 ].
Arguments
=========
A (input) COMPLEX*16
The (1,1) element of the 2-by-2 matrix.
B (input) COMPLEX*16
The (1,2) element and the conjugate of the (2,1) element of
the 2-by-2 matrix.
C (input) COMPLEX*16
The (2,2) element of the 2-by-2 matrix.
RT1 (output) DOUBLE PRECISION
The eigenvalue of larger absolute value.
RT2 (output) DOUBLE PRECISION
The eigenvalue of smaller absolute value.
CS1 (output) DOUBLE PRECISION
SN1 (output) COMPLEX*16
The vector (CS1, SN1) is a unit right eigenvector for RT1.
Further Details
===============
RT1 is accurate to a few ulps barring over/underflow.
RT2 may be inaccurate if there is massive cancellation in the
determinant A*C-B*B; higher precision or correctly rounded or
correctly truncated arithmetic would be needed to compute RT2
accurately in all cases.
CS1 and SN1 are accurate to a few ulps barring over/underflow.
Overflow is possible only if RT1 is within a factor of 5 of overflow.
Underflow is harmless if the input data is 0 or exceeds
underflow_threshold / macheps.
=====================================================================
*/
/* System generated locals */
doublereal d__1, d__2, d__3;
doublecomplex z__1, z__2;
/* Builtin functions */
double z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static doublereal t;
static doublecomplex w;
extern /* Subroutine */ int dlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
if (z_abs(b) == 0.) {
w.r = 1., w.i = 0.;
} else {
d_cnjg(&z__2, b);
d__1 = z_abs(b);
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
w.r = z__1.r, w.i = z__1.i;
}
d__1 = a->r;
d__2 = z_abs(b);
d__3 = c->r;
dlaev2_(&d__1, &d__2, &d__3, rt1, rt2, cs1, &t);
z__1.r = t * w.r, z__1.i = t * w.i;
sn1->r = z__1.r, sn1->i = z__1.i;
return 0;
/* End of ZLAEV2 */
} /* zlaev2_ */
/*< 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 zsteqr_(char *compz, integer *n, doublereal *d,
doublereal *e, doublecomplex *z, integer *ldz, doublereal *work,
integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a
symmetric tridiagonal matrix using the implicit QL or QR method.
The eigenvectors of a full or band complex Hermitian matrix can also
be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this
matrix to tridiagonal form.
Arguments
=========
COMPZ (input) CHARACTER*1
= 'N': Compute eigenvalues only.
= 'V': Compute eigenvalues and eigenvectors of the original
Hermitian matrix. On entry, Z must contain the
unitary matrix used to reduce the original matrix
to tridiagonal form.
= 'I': Compute eigenvalues and eigenvectors of the
tridiagonal matrix. Z is initialized to the identity
matrix.
N (input) INTEGER
The order of the matrix. N >= 0.
D (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the diagonal elements of the tridiagonal matrix.
On exit, if INFO = 0, the eigenvalues in ascending order.
E (input/output) DOUBLE PRECISION array, dimension (N-1)
On entry, the (n-1) subdiagonal elements of the tridiagonal
matrix.
On exit, E has been destroyed.
Z (input/output) COMPLEX*16 array, dimension (LDZ, N)
On entry, if COMPZ = 'V', then Z contains the unitary
matrix used in the reduction to tridiagonal form.
On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
orthonormal eigenvectors of the original Hermitian matrix,
and if COMPZ = 'I', Z contains the orthonormal eigenvectors
of the symmetric tridiagonal matrix.
If COMPZ = 'N', then Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
eigenvectors are desired, then LDZ >= max(1,N).
WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
If COMPZ = 'N', then WORK is not referenced.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: the algorithm has failed to find all the eigenvalues in
a total of 30*N iterations; if INFO = i, then i
elements of E have not converged to zero; on exit, D
and E contain the elements of a symmetric tridiagonal
matrix which is unitarily similar to the original
matrix.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
static integer c__0 = 0;
static integer c__1 = 1;
static integer c__2 = 2;
static doublereal c_b41 = 1.;
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
static integer lend, jtot;
extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
static doublereal b, c, f, g;
static integer i, j, k, l, m;
static doublereal p, r, s;
extern logical lsame_(char *, char *);
static doublereal anorm;
extern /* Subroutine */ int zlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublecomplex *, integer *);
static integer l1;
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), dlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
static integer lendm1, lendp1;
extern doublereal dlapy2_(doublereal *, doublereal *);
static integer ii;
extern doublereal dlamch_(char *);
static integer mm, iscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
static doublereal safmin;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
static doublereal safmax;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *);
static integer lendsv;
static doublereal ssfmin;
static integer nmaxit, icompz;
static doublereal ssfmax;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
static integer lm1, mm1, nm1;
static doublereal rt1, rt2, eps;
static integer lsv;
static doublereal tst, eps2;
#define D(I) d[(I)-1]
#define E(I) e[(I)-1]
#define WORK(I) work[(I)-1]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)]
*info = 0;
if (lsame_(compz, "N")) {
icompz = 0;
} else if (lsame_(compz, "V")) {
icompz = 1;
} else if (lsame_(compz, "I")) {
icompz = 2;
} else {
icompz = -1;
}
if (icompz < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZSTEQR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz == 2) {
i__1 = z_dim1 + 1;
Z(1,1).r = 1., Z(1,1).i = 0.;
}
return 0;
}
/* Determine the unit roundoff and over/underflow thresholds. */
eps = dlamch_("E");
/* Computing 2nd power */
d__1 = eps;
eps2 = d__1 * d__1;
safmin = dlamch_("S");
safmax = 1. / safmin;
ssfmax = sqrt(safmax) / 3.;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues and eigenvectors of the tridiagonal
matrix. */
if (icompz == 2) {
zlaset_("Full", n, n, &c_b1, &c_b2, &Z(1,1), ldz);
}
nmaxit = *n * 30;
jtot = 0;
/* Determine where the matrix splits and choose QL or QR iteration
for each block, according to whether top or bottom diagonal
element is smaller. */
l1 = 1;
nm1 = *n - 1;
L10:
if (l1 > *n) {
goto L160;
}
if (l1 > 1) {
E(l1 - 1) = 0.;
}
if (l1 <= nm1) {
i__1 = nm1;
for (m = l1; m <= nm1; ++m) {
tst = (d__1 = E(m), abs(d__1));
if (tst == 0.) {
goto L30;
}
if (tst <= sqrt((d__1 = D(m), abs(d__1))) * sqrt((d__2 = D(m + 1),
abs(d__2))) * eps) {
E(m) = 0.;
goto L30;
}
/* L20: */
}
}
m = *n;
L30:
l = l1;
lsv = l;
lend = m;
lendsv = lend;
l1 = m + 1;
if (lend == l) {
goto L10;
}
/* Scale submatrix in rows and columns L to LEND */
i__1 = lend - l + 1;
anorm = dlanst_("I", &i__1, &D(l), &E(l));
iscale = 0;
if (anorm == 0.) {
goto L10;
}
if (anorm > ssfmax) {
iscale = 1;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &D(l), n,
info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &E(l), n,
info);
} else if (anorm < ssfmin) {
iscale = 2;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &D(l), n,
info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &E(l), n,
info);
}
/* Choose between QL and QR iteration */
if ((d__1 = D(lend), abs(d__1)) < (d__2 = D(l), abs(d__2))) {
lend = lsv;
l = lendsv;
}
if (lend > l) {
/* QL Iteration
Look for small subdiagonal element. */
L40:
if (l != lend) {
lendm1 = lend - 1;
i__1 = lendm1;
for (m = l; m <= lendm1; ++m) {
/* Computing 2nd power */
d__2 = (d__1 = E(m), abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = D(m), abs(d__1)) * (d__2 = D(m + 1),
abs(d__2)) + safmin) {
goto L60;
}
/* L50: */
}
}
m = lend;
L60:
if (m < lend) {
E(m) = 0.;
}
p = D(l);
if (m == l) {
goto L80;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
to compute its eigensystem. */
if (m == l + 1) {
if (icompz > 0) {
dlaev2_(&D(l), &E(l), &D(l + 1), &rt1, &rt2, &c, &s);
WORK(l) = c;
WORK(*n - 1 + l) = s;
zlasr_("R", "V", "B", n, &c__2, &WORK(l), &WORK(*n - 1 + l), &
Z(1,l), ldz);
} else {
dlae2_(&D(l), &E(l), &D(l + 1), &rt1, &rt2);
}
D(l) = rt1;
D(l + 1) = rt2;
E(l) = 0.;
l += 2;
if (l <= lend) {
goto L40;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (D(l + 1) - p) / (E(l) * 2.);
r = dlapy2_(&g, &c_b41);
g = D(m) - p + E(l) / (g + d_sign(&r, &g));
s = 1.;
c = 1.;
p = 0.;
/* Inner loop */
mm1 = m - 1;
i__1 = l;
for (i = mm1; i >= l; --i) {
f = s * E(i);
b = c * E(i);
dlartg_(&g, &f, &c, &s, &r);
if (i != m - 1) {
E(i + 1) = r;
}
g = D(i + 1) - p;
r = (D(i) - g) * s + c * 2. * b;
p = s * r;
D(i + 1) = g + p;
g = c * r - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
WORK(i) = c;
WORK(*n - 1 + i) = -s;
}
/* L70: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = m - l + 1;
zlasr_("R", "V", "B", n, &mm, &WORK(l), &WORK(*n - 1 + l), &Z(1,l), ldz);
}
D(l) -= p;
E(l) = g;
goto L40;
/* Eigenvalue found. */
L80:
D(l) = p;
++l;
if (l <= lend) {
goto L40;
}
goto L140;
} else {
/* QR Iteration
Look for small superdiagonal element. */
L90:
if (l != lend) {
lendp1 = lend + 1;
i__1 = lendp1;
for (m = l; m >= lendp1; --m) {
/* Computing 2nd power */
d__2 = (d__1 = E(m - 1), abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = D(m), abs(d__1)) * (d__2 = D(m - 1),
abs(d__2)) + safmin) {
goto L110;
}
/* L100: */
}
}
m = lend;
L110:
if (m > lend) {
E(m - 1) = 0.;
}
p = D(l);
if (m == l) {
goto L130;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
to compute its eigensystem. */
if (m == l - 1) {
if (icompz > 0) {
dlaev2_(&D(l - 1), &E(l - 1), &D(l), &rt1, &rt2, &c, &s);
WORK(m) = c;
WORK(*n - 1 + m) = s;
zlasr_("R", "V", "F", n, &c__2, &WORK(m), &WORK(*n - 1 + m), &
Z(1,l-1), ldz);
} else {
dlae2_(&D(l - 1), &E(l - 1), &D(l), &rt1, &rt2);
}
D(l - 1) = rt1;
D(l) = rt2;
E(l - 1) = 0.;
l += -2;
if (l >= lend) {
goto L90;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (D(l - 1) - p) / (E(l - 1) * 2.);
r = dlapy2_(&g, &c_b41);
g = D(m) - p + E(l - 1) / (g + d_sign(&r, &g));
s = 1.;
c = 1.;
p = 0.;
/* Inner loop */
lm1 = l - 1;
i__1 = lm1;
for (i = m; i <= lm1; ++i) {
f = s * E(i);
b = c * E(i);
dlartg_(&g, &f, &c, &s, &r);
if (i != m) {
E(i - 1) = r;
}
g = D(i) - p;
r = (D(i + 1) - g) * s + c * 2. * b;
p = s * r;
D(i) = g + p;
g = c * r - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
WORK(i) = c;
WORK(*n - 1 + i) = s;
}
/* L120: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = l - m + 1;
zlasr_("R", "V", "F", n, &mm, &WORK(m), &WORK(*n - 1 + m), &Z(1,m), ldz);
}
D(l) -= p;
E(lm1) = g;
goto L90;
/* Eigenvalue found. */
L130:
D(l) = p;
--l;
if (l >= lend) {
goto L90;
}
goto L140;
}
/* Undo scaling if necessary */
L140:
if (iscale == 1) {
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &D(lsv), n,
info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &E(lsv), n,
info);
} else if (iscale == 2) {
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &D(lsv), n,
info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &E(lsv), n,
info);
}
/* Check for no convergence to an eigenvalue after a total
of N*MAXIT iterations. */
if (jtot == nmaxit) {
i__1 = *n - 1;
for (i = 1; i <= *n-1; ++i) {
if (E(i) != 0.) {
++(*info);
}
/* L150: */
}
return 0;
}
goto L10;
/* Order eigenvalues and eigenvectors. */
L160:
if (icompz == 0) {
/* Use Quick Sort */
dlasrt_("I", n, &D(1), info);
} else {
/* Use Selection Sort to minimize swaps of eigenvectors */
i__1 = *n;
for (ii = 2; ii <= *n; ++ii) {
i = ii - 1;
k = i;
p = D(i);
i__2 = *n;
for (j = ii; j <= *n; ++j) {
if (D(j) < p) {
k = j;
p = D(j);
}
/* L170: */
}
if (k != i) {
D(k) = D(i);
D(i) = p;
zswap_(n, &Z(1,i), &c__1, &Z(1,k), &
c__1);
}
/* L180: */
}
}
return 0;
/* End of ZSTEQR */
} /* zsteqr_ */
/* 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_ */