int claed0_(int *qsiz, int *n, float *d__, float *e,
complex *q, int *ldq, complex *qstore, int *ldqs, float *rwork,
int *iwork, int *info)
{
/* System generated locals */
int q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2;
float r__1;
/* Builtin functions */
double log(double);
int pow_ii(int *, int *);
/* Local variables */
int i__, j, k, ll, iq, lgn, msd2, smm1, spm1, spm2;
float temp;
int curr, iperm;
extern int ccopy_(int *, complex *, int *,
complex *, int *);
int indxq, iwrem;
extern int scopy_(int *, float *, int *, float *,
int *);
int iqptr;
extern int claed7_(int *, int *, int *,
int *, int *, int *, float *, complex *, int *,
float *, int *, float *, int *, int *, int *,
int *, int *, float *, complex *, float *, int *,
int *);
int tlvls;
extern int clacrm_(int *, int *, complex *,
int *, float *, int *, complex *, int *, float *);
int igivcl;
extern int xerbla_(char *, int *);
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
int igivnm, submat, curprb, subpbs, igivpt, curlvl, matsiz, iprmpt,
smlsiz;
extern int ssteqr_(char *, int *, float *, float *,
float *, int *, float *, int *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* Using the divide and conquer method, CLAED0 computes all eigenvalues */
/* of a symmetric tridiagonal matrix which is one diagonal block of */
/* those from reducing a dense or band Hermitian matrix and */
/* corresponding eigenvectors of the dense or band matrix. */
/* Arguments */
/* ========= */
/* QSIZ (input) INTEGER */
/* The dimension of the unitary matrix used to reduce */
/* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. */
/* N (input) INTEGER */
/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
/* D (input/output) REAL array, dimension (N) */
/* On entry, the diagonal elements of the tridiagonal matrix. */
/* On exit, the eigenvalues in ascending order. */
/* E (input/output) REAL array, dimension (N-1) */
/* On entry, the off-diagonal elements of the tridiagonal matrix. */
/* On exit, E has been destroyed. */
/* Q (input/output) COMPLEX array, dimension (LDQ,N) */
/* On entry, Q must contain an QSIZ x N matrix whose columns */
/* unitarily orthonormal. It is a part of the unitary matrix */
/* that reduces the full dense Hermitian matrix to a */
/* (reducible) symmetric tridiagonal matrix. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= MAX(1,N). */
/* IWORK (workspace) INTEGER array, */
/* the dimension of IWORK must be at least */
/* 6 + 6*N + 5*N*lg N */
/* ( lg( N ) = smallest int k */
/* such that 2^k >= N ) */
/* RWORK (workspace) REAL array, */
/* dimension (1 + 3*N + 2*N*lg N + 3*N**2) */
/* ( lg( N ) = smallest int k */
/* such that 2^k >= N ) */
/* QSTORE (workspace) COMPLEX array, dimension (LDQS, N) */
/* Used to store parts of */
/* the eigenvector matrix when the updating matrix multiplies */
/* take place. */
/* LDQS (input) INTEGER */
/* The leading dimension of the array QSTORE. */
/* LDQS >= MAX(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: The algorithm failed to compute an eigenvalue while */
/* working on the submatrix lying in rows and columns */
/* INFO/(N+1) through mod(INFO,N+1). */
/* ===================================================================== */
/* Warning: N could be as big as QSIZ! */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
qstore_dim1 = *ldqs;
qstore_offset = 1 + qstore_dim1;
qstore -= qstore_offset;
--rwork;
--iwork;
/* Function Body */
*info = 0;
/* IF( ICOMPQ .LT. 0 .OR. ICOMPQ .GT. 2 ) THEN */
/* INFO = -1 */
/* ELSE IF( ( ICOMPQ .EQ. 1 ) .AND. ( QSIZ .LT. MAX( 0, N ) ) ) */
/* $ THEN */
if (*qsiz < MAX(0,*n)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldq < MAX(1,*n)) {
*info = -6;
} else if (*ldqs < MAX(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLAED0", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
smlsiz = ilaenv_(&c__9, "CLAED0", " ", &c__0, &c__0, &c__0, &c__0);
/* Determine the size and placement of the submatrices, and save in */
/* the leading elements of IWORK. */
iwork[1] = *n;
subpbs = 1;
tlvls = 0;
L10:
if (iwork[subpbs] > smlsiz) {
for (j = subpbs; j >= 1; --j) {
iwork[j * 2] = (iwork[j] + 1) / 2;
iwork[(j << 1) - 1] = iwork[j] / 2;
/* L20: */
}
++tlvls;
subpbs <<= 1;
goto L10;
}
i__1 = subpbs;
for (j = 2; j <= i__1; ++j) {
iwork[j] += iwork[j - 1];
/* L30: */
}
/* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 */
/* using rank-1 modifications (cuts). */
spm1 = subpbs - 1;
i__1 = spm1;
for (i__ = 1; i__ <= i__1; ++i__) {
submat = iwork[i__] + 1;
smm1 = submat - 1;
d__[smm1] -= (r__1 = e[smm1], ABS(r__1));
d__[submat] -= (r__1 = e[smm1], ABS(r__1));
/* L40: */
}
indxq = (*n << 2) + 3;
/* Set up workspaces for eigenvalues only/accumulate new vectors */
/* routine */
temp = log((float) (*n)) / log(2.f);
lgn = (int) temp;
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
iprmpt = indxq + *n + 1;
iperm = iprmpt + *n * lgn;
iqptr = iperm + *n * lgn;
igivpt = iqptr + *n + 2;
igivcl = igivpt + *n * lgn;
igivnm = 1;
iq = igivnm + (*n << 1) * lgn;
/* Computing 2nd power */
i__1 = *n;
iwrem = iq + i__1 * i__1 + 1;
/* Initialize pointers */
i__1 = subpbs;
for (i__ = 0; i__ <= i__1; ++i__) {
iwork[iprmpt + i__] = 1;
iwork[igivpt + i__] = 1;
/* L50: */
}
iwork[iqptr] = 1;
/* Solve each submatrix eigenproblem at the bottom of the divide and */
/* conquer tree. */
curr = 0;
i__1 = spm1;
for (i__ = 0; i__ <= i__1; ++i__) {
if (i__ == 0) {
submat = 1;
matsiz = iwork[1];
} else {
submat = iwork[i__] + 1;
matsiz = iwork[i__ + 1] - iwork[i__];
}
ll = iq - 1 + iwork[iqptr + curr];
ssteqr_("I", &matsiz, &d__[submat], &e[submat], &rwork[ll], &matsiz, &
rwork[1], info);
clacrm_(qsiz, &matsiz, &q[submat * q_dim1 + 1], ldq, &rwork[ll], &
matsiz, &qstore[submat * qstore_dim1 + 1], ldqs, &rwork[iwrem]
);
/* Computing 2nd power */
i__2 = matsiz;
iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2;
++curr;
if (*info > 0) {
*info = submat * (*n + 1) + submat + matsiz - 1;
return 0;
}
k = 1;
i__2 = iwork[i__ + 1];
for (j = submat; j <= i__2; ++j) {
iwork[indxq + j] = k;
++k;
/* L60: */
}
/* L70: */
}
/* Successively merge eigensystems of adjacent submatrices */
/* into eigensystem for the corresponding larger matrix. */
/* while ( SUBPBS > 1 ) */
curlvl = 1;
L80:
if (subpbs > 1) {
spm2 = subpbs - 2;
i__1 = spm2;
for (i__ = 0; i__ <= i__1; i__ += 2) {
if (i__ == 0) {
submat = 1;
matsiz = iwork[2];
msd2 = iwork[1];
curprb = 0;
} else {
submat = iwork[i__] + 1;
matsiz = iwork[i__ + 2] - iwork[i__];
msd2 = matsiz / 2;
++curprb;
}
/* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) */
/* into an eigensystem of size MATSIZ. CLAED7 handles the case */
/* when the eigenvectors of a full or band Hermitian matrix (which */
/* was reduced to tridiagonal form) are desired. */
/* I am free to use Q as a valuable working space until Loop 150. */
claed7_(&matsiz, &msd2, qsiz, &tlvls, &curlvl, &curprb, &d__[
submat], &qstore[submat * qstore_dim1 + 1], ldqs, &e[
submat + msd2 - 1], &iwork[indxq + submat], &rwork[iq], &
iwork[iqptr], &iwork[iprmpt], &iwork[iperm], &iwork[
igivpt], &iwork[igivcl], &rwork[igivnm], &q[submat *
q_dim1 + 1], &rwork[iwrem], &iwork[subpbs + 1], info);
if (*info > 0) {
*info = submat * (*n + 1) + submat + matsiz - 1;
return 0;
}
iwork[i__ / 2 + 1] = iwork[i__ + 2];
/* L90: */
}
subpbs /= 2;
++curlvl;
goto L80;
}
/* end while */
/* Re-merge the eigenvalues/vectors which were deflated at the final */
/* merge step. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
j = iwork[indxq + i__];
rwork[i__] = d__[j];
ccopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1 + 1]
, &c__1);
/* L100: */
}
scopy_(n, &rwork[1], &c__1, &d__[1], &c__1);
return 0;
/* End of CLAED0 */
} /* claed0_ */
/* Subroutine */ int claed0_(integer *qsiz, integer *n, real *d, real *e,
complex *q, integer *ldq, complex *qstore, integer *ldqs, real *rwork,
integer *iwork, 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
=======
Using the divide and conquer method, CLAED0 computes all eigenvalues
of a symmetric tridiagonal matrix which is one diagonal block of
those from reducing a dense or band Hermitian matrix and
corresponding eigenvectors of the dense or band matrix.
Arguments
=========
QSIZ (input) INTEGER
The dimension of the unitary matrix used to reduce
the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
N (input) INTEGER
The dimension of the symmetric tridiagonal matrix. N >= 0.
D (input/output) REAL array, dimension (N)
On entry, the diagonal elements of the tridiagonal matrix.
On exit, the eigenvalues in ascending order.
E (input/output) REAL array, dimension (N-1)
On entry, the off-diagonal elements of the tridiagonal matrix.
On exit, E has been destroyed.
Q (input/output) COMPLEX array, dimension (LDQ,N)
On entry, Q must contain an QSIZ x N matrix whose columns
unitarily orthonormal. It is a part of the unitary matrix
that reduces the full dense Hermitian matrix to a
(reducible) symmetric tridiagonal matrix.
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= max(1,N).
IWORK (workspace) INTEGER array,
the dimension of IWORK must be at least
6 + 6*N + 5*N*lg N
( lg( N ) = smallest integer k
such that 2^k >= N )
RWORK (workspace) REAL array,
dimension (1 + 3*N + 2*N*lg N + 3*N**2)
( lg( N ) = smallest integer k
such that 2^k >= N )
QSTORE (workspace) COMPLEX array, dimension (LDQS, N)
Used to store parts of
the eigenvector matrix when the updating matrix multiplies
take place.
LDQS (input) INTEGER
The leading dimension of the array QSTORE.
LDQS >= max(1,N).
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: The algorithm failed to compute an eigenvalue while
working on the submatrix lying in rows and columns
INFO/(N+1) through mod(INFO,N+1).
=====================================================================
Warning: N could be as big as QSIZ!
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__2 = 2;
static integer c__1 = 1;
/* System generated locals */
integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2;
real r__1;
/* Builtin functions */
double log(doublereal);
integer pow_ii(integer *, integer *);
/* Local variables */
static real temp;
static integer curr, i, j, k, iperm;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
static integer indxq, iwrem;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static integer iqptr;
extern /* Subroutine */ int claed7_(integer *, integer *, integer *,
integer *, integer *, integer *, real *, complex *, integer *,
real *, integer *, real *, integer *, integer *, integer *,
integer *, integer *, real *, complex *, real *, integer *,
integer *);
static integer tlvls, ll, iq;
extern /* Subroutine */ int clacrm_(integer *, integer *, complex *,
integer *, real *, integer *, complex *, integer *, real *);
static integer igivcl;
extern /* Subroutine */ int xerbla_(char *, integer *);
static integer igivnm, submat, curprb, subpbs, igivpt, curlvl, matsiz,
iprmpt;
extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *,
real *, integer *, real *, integer *);
static integer lgn, msd2, smm1, spm1, spm2;
#define D(I) d[(I)-1]
#define E(I) e[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define IWORK(I) iwork[(I)-1]
#define Q(I,J) q[(I)-1 + ((J)-1)* ( *ldq)]
#define QSTORE(I,J) qstore[(I)-1 + ((J)-1)* ( *ldqs)]
*info = 0;
/* IF( ICOMPQ .LT. 0 .OR. ICOMPQ .GT. 2 ) THEN
INFO = -1
ELSE IF( ( ICOMPQ .EQ. 1 ) .AND. ( QSIZ .LT. MAX( 0, N ) ) )
$ THEN */
if (*qsiz < max(0,*n)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldq < max(1,*n)) {
*info = -6;
} else if (*ldqs < max(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLAED0", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine the size and placement of the submatrices, and save in
the leading elements of IWORK. */
IWORK(1) = *n;
subpbs = 1;
tlvls = 0;
L10:
if (IWORK(subpbs) > 25) {
for (j = subpbs; j >= 1; --j) {
IWORK(j * 2) = (IWORK(j) + 1) / 2;
IWORK((j << 1) - 1) = IWORK(j) / 2;
/* L20: */
}
++tlvls;
subpbs <<= 1;
goto L10;
}
i__1 = subpbs;
for (j = 2; j <= subpbs; ++j) {
IWORK(j) += IWORK(j - 1);
/* L30: */
}
/* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
using rank-1 modifications (cuts). */
spm1 = subpbs - 1;
i__1 = spm1;
for (i = 1; i <= spm1; ++i) {
submat = IWORK(i) + 1;
smm1 = submat - 1;
D(smm1) -= (r__1 = E(smm1), dabs(r__1));
D(submat) -= (r__1 = E(smm1), dabs(r__1));
/* L40: */
}
indxq = (*n << 2) + 3;
/* Set up workspaces for eigenvalues only/accumulate new vectors
routine */
temp = log((real) (*n)) / log(2.f);
lgn = (integer) temp;
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
iprmpt = indxq + *n + 1;
iperm = iprmpt + *n * lgn;
iqptr = iperm + *n * lgn;
igivpt = iqptr + *n + 2;
igivcl = igivpt + *n * lgn;
igivnm = 1;
iq = igivnm + (*n << 1) * lgn;
/* Computing 2nd power */
i__1 = *n;
iwrem = iq + i__1 * i__1 + 1;
/* Initialize pointers */
i__1 = subpbs;
for (i = 0; i <= subpbs; ++i) {
IWORK(iprmpt + i) = 1;
IWORK(igivpt + i) = 1;
/* L50: */
}
IWORK(iqptr) = 1;
/* Solve each submatrix eigenproblem at the bottom of the divide and
conquer tree. */
curr = 0;
i__1 = spm1;
for (i = 0; i <= spm1; ++i) {
if (i == 0) {
submat = 1;
matsiz = IWORK(1);
} else {
submat = IWORK(i) + 1;
matsiz = IWORK(i + 1) - IWORK(i);
}
ll = iq - 1 + IWORK(iqptr + curr);
ssteqr_("I", &matsiz, &D(submat), &E(submat), &RWORK(ll), &matsiz, &
RWORK(1), info);
clacrm_(qsiz, &matsiz, &Q(1,submat), ldq, &RWORK(ll), &
matsiz, &QSTORE(1,submat), ldqs, &RWORK(iwrem)
);
/* Computing 2nd power */
i__2 = matsiz;
IWORK(iqptr + curr + 1) = IWORK(iqptr + curr) + i__2 * i__2;
++curr;
if (*info > 0) {
*info = submat * (*n + 1) + submat + matsiz - 1;
return 0;
}
k = 1;
i__2 = IWORK(i + 1);
for (j = submat; j <= IWORK(i+1); ++j) {
IWORK(indxq + j) = k;
++k;
/* L60: */
}
/* L70: */
}
/* Successively merge eigensystems of adjacent submatrices
into eigensystem for the corresponding larger matrix.
while ( SUBPBS > 1 ) */
curlvl = 1;
L80:
if (subpbs > 1) {
spm2 = subpbs - 2;
i__1 = spm2;
for (i = 0; i <= spm2; i += 2) {
if (i == 0) {
submat = 1;
matsiz = IWORK(2);
msd2 = IWORK(1);
curprb = 0;
} else {
submat = IWORK(i) + 1;
matsiz = IWORK(i + 2) - IWORK(i);
msd2 = matsiz / 2;
++curprb;
}
/* Merge lower order eigensystems (of size MSD2 and MATSIZ - M
SD2)
into an eigensystem of size MATSIZ. CLAED7 handles the cas
e
when the eigenvectors of a full or band Hermitian matrix (w
hich
was reduced to tridiagonal form) are desired.
I am free to use Q as a valuable working space until Loop 1
50. */
claed7_(&matsiz, &msd2, qsiz, &tlvls, &curlvl, &curprb, &D(submat)
, &QSTORE(1,submat), ldqs, &E(submat +
msd2 - 1), &IWORK(indxq + submat), &RWORK(iq), &IWORK(
iqptr), &IWORK(iprmpt), &IWORK(iperm), &IWORK(igivpt), &
IWORK(igivcl), &RWORK(igivnm), &Q(1,submat), &
RWORK(iwrem), &IWORK(subpbs + 1), info);
if (*info > 0) {
*info = submat * (*n + 1) + submat + matsiz - 1;
return 0;
}
IWORK(i / 2 + 1) = IWORK(i + 2);
/* L90: */
}
subpbs /= 2;
++curlvl;
goto L80;
}
/* end while
Re-merge the eigenvalues/vectors which were deflated at the final
merge step. */
i__1 = *n;
for (i = 1; i <= *n; ++i) {
j = IWORK(indxq + i);
RWORK(i) = D(j);
ccopy_(qsiz, &QSTORE(1,j), &c__1, &Q(1,i),
&c__1);
/* L100: */
}
scopy_(n, &RWORK(1), &c__1, &D(1), &c__1);
return 0;
/* End of CLAED0 */
} /* claed0_ */
int claed7_(int *n, int *cutpnt, int *qsiz,
int *tlvls, int *curlvl, int *curpbm, float *d__, complex *
q, int *ldq, float *rho, int *indxq, float *qstore, int *
qptr, int *prmptr, int *perm, int *givptr, int *
givcol, float *givnum, complex *work, float *rwork, int *iwork,
int *info)
{
/* System generated locals */
int q_dim1, q_offset, i__1, i__2;
/* Builtin functions */
int pow_ii(int *, int *);
/* Local variables */
int i__, k, n1, n2, iq, iw, iz, ptr, indx, curr, indxc, indxp;
extern int claed8_(int *, int *, int *,
complex *, int *, float *, float *, int *, float *, float *,
complex *, int *, float *, int *, int *, int *,
int *, int *, int *, float *, int *), slaed9_(
int *, int *, int *, int *, float *, float *,
int *, float *, float *, float *, float *, int *, int *),
slaeda_(int *, int *, int *, int *, int *,
int *, int *, int *, float *, float *, int *, float *
, float *, int *);
int idlmda;
extern int clacrm_(int *, int *, complex *,
int *, float *, int *, complex *, int *, float *),
xerbla_(char *, int *), slamrg_(int *, int *,
float *, int *, int *, int *);
int coltyp;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLAED7 computes the updated eigensystem of a diagonal */
/* matrix after modification by a rank-one symmetric matrix. This */
/* routine is used only for the eigenproblem which requires all */
/* eigenvalues and optionally eigenvectors of a dense or banded */
/* Hermitian matrix that has been reduced to tridiagonal form. */
/* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out) */
/* where Z = Q'u, u is a vector of length N with ones in the */
/* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. */
/* The eigenvectors of the original matrix are stored in Q, and the */
/* eigenvalues are in D. The algorithm consists of three stages: */
/* The first stage consists of deflating the size of the problem */
/* when there are multiple eigenvalues or if there is a zero in */
/* the Z vector. For each such occurence the dimension of the */
/* secular equation problem is reduced by one. This stage is */
/* performed by the routine SLAED2. */
/* The second stage consists of calculating the updated */
/* eigenvalues. This is done by finding the roots of the secular */
/* equation via the routine SLAED4 (as called by SLAED3). */
/* This routine also calculates the eigenvectors of the current */
/* problem. */
/* The final stage consists of computing the updated eigenvectors */
/* directly using the updated eigenvalues. The eigenvectors for */
/* the current problem are multiplied with the eigenvectors from */
/* the overall problem. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
/* CUTPNT (input) INTEGER */
/* Contains the location of the last eigenvalue in the leading */
/* sub-matrix. MIN(1,N) <= CUTPNT <= N. */
/* QSIZ (input) INTEGER */
/* The dimension of the unitary matrix used to reduce */
/* the full matrix to tridiagonal form. QSIZ >= N. */
/* TLVLS (input) INTEGER */
/* The total number of merging levels in the overall divide and */
/* conquer tree. */
/* CURLVL (input) INTEGER */
/* The current level in the overall merge routine, */
/* 0 <= curlvl <= tlvls. */
/* CURPBM (input) INTEGER */
/* The current problem in the current level in the overall */
/* merge routine (counting from upper left to lower right). */
/* D (input/output) REAL array, dimension (N) */
/* On entry, the eigenvalues of the rank-1-perturbed matrix. */
/* On exit, the eigenvalues of the repaired matrix. */
/* Q (input/output) COMPLEX array, dimension (LDQ,N) */
/* On entry, the eigenvectors of the rank-1-perturbed matrix. */
/* On exit, the eigenvectors of the repaired tridiagonal matrix. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= MAX(1,N). */
/* RHO (input) REAL */
/* Contains the subdiagonal element used to create the rank-1 */
/* modification. */
/* INDXQ (output) INTEGER array, dimension (N) */
/* This contains the permutation which will reintegrate the */
/* subproblem just solved back into sorted order, */
/* ie. D( INDXQ( I = 1, N ) ) will be in ascending order. */
/* IWORK (workspace) INTEGER array, dimension (4*N) */
/* RWORK (workspace) REAL array, */
/* dimension (3*N+2*QSIZ*N) */
/* WORK (workspace) COMPLEX array, dimension (QSIZ*N) */
/* QSTORE (input/output) REAL array, dimension (N**2+1) */
/* Stores eigenvectors of submatrices encountered during */
/* divide and conquer, packed together. QPTR points to */
/* beginning of the submatrices. */
/* QPTR (input/output) INTEGER array, dimension (N+2) */
/* List of indices pointing to beginning of submatrices stored */
/* in QSTORE. The submatrices are numbered starting at the */
/* bottom left of the divide and conquer tree, from left to */
/* right and bottom to top. */
/* PRMPTR (input) INTEGER array, dimension (N lg N) */
/* Contains a list of pointers which indicate where in PERM a */
/* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) */
/* indicates the size of the permutation and also the size of */
/* the full, non-deflated problem. */
/* PERM (input) INTEGER array, dimension (N lg N) */
/* Contains the permutations (from deflation and sorting) to be */
/* applied to each eigenblock. */
/* GIVPTR (input) INTEGER array, dimension (N lg N) */
/* Contains a list of pointers which indicate where in GIVCOL a */
/* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) */
/* indicates the number of Givens rotations. */
/* GIVCOL (input) INTEGER array, dimension (2, N lg N) */
/* Each pair of numbers indicates a pair of columns to take place */
/* in a Givens rotation. */
/* GIVNUM (input) REAL array, dimension (2, N lg N) */
/* Each number indicates the S value to be used in the */
/* corresponding Givens rotation. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = 1, an eigenvalue did not converge */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--indxq;
--qstore;
--qptr;
--prmptr;
--perm;
--givptr;
givcol -= 3;
givnum -= 3;
--work;
--rwork;
--iwork;
/* Function Body */
*info = 0;
/* IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN */
/* INFO = -1 */
/* ELSE IF( N.LT.0 ) THEN */
if (*n < 0) {
*info = -1;
} else if (MIN(1,*n) > *cutpnt || *n < *cutpnt) {
*info = -2;
} else if (*qsiz < *n) {
*info = -3;
} else if (*ldq < MAX(1,*n)) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLAED7", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* The following values are for bookkeeping purposes only. They are */
/* int pointers which indicate the portion of the workspace */
/* used by a particular array in SLAED2 and SLAED3. */
iz = 1;
idlmda = iz + *n;
iw = idlmda + *n;
iq = iw + *n;
indx = 1;
indxc = indx + *n;
coltyp = indxc + *n;
indxp = coltyp + *n;
/* Form the z-vector which consists of the last row of Q_1 and the */
/* first row of Q_2. */
ptr = pow_ii(&c__2, tlvls) + 1;
i__1 = *curlvl - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *tlvls - i__;
ptr += pow_ii(&c__2, &i__2);
/* L10: */
}
curr = ptr + *curpbm;
slaeda_(n, tlvls, curlvl, curpbm, &prmptr[1], &perm[1], &givptr[1], &
givcol[3], &givnum[3], &qstore[1], &qptr[1], &rwork[iz], &rwork[
iz + *n], info);
/* When solving the final problem, we no longer need the stored data, */
/* so we will overwrite the data from this level onto the previously */
/* used storage space. */
if (*curlvl == *tlvls) {
qptr[curr] = 1;
prmptr[curr] = 1;
givptr[curr] = 1;
}
/* Sort and Deflate eigenvalues. */
claed8_(&k, n, qsiz, &q[q_offset], ldq, &d__[1], rho, cutpnt, &rwork[iz],
&rwork[idlmda], &work[1], qsiz, &rwork[iw], &iwork[indxp], &iwork[
indx], &indxq[1], &perm[prmptr[curr]], &givptr[curr + 1], &givcol[
(givptr[curr] << 1) + 1], &givnum[(givptr[curr] << 1) + 1], info);
prmptr[curr + 1] = prmptr[curr] + *n;
givptr[curr + 1] += givptr[curr];
/* Solve Secular Equation. */
if (k != 0) {
slaed9_(&k, &c__1, &k, n, &d__[1], &rwork[iq], &k, rho, &rwork[idlmda]
, &rwork[iw], &qstore[qptr[curr]], &k, info);
clacrm_(qsiz, &k, &work[1], qsiz, &qstore[qptr[curr]], &k, &q[
q_offset], ldq, &rwork[iq]);
/* Computing 2nd power */
i__1 = k;
qptr[curr + 1] = qptr[curr] + i__1 * i__1;
if (*info != 0) {
return 0;
}
/* Prepare the INDXQ sorting premutation. */
n1 = k;
n2 = *n - k;
slamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]);
} else {
qptr[curr + 1] = qptr[curr];
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
indxq[i__] = i__;
/* L20: */
}
}
return 0;
/* End of CLAED7 */
} /* claed7_ */
/* Subroutine */ int cstedc_(char *compz, integer *n, real *d__, real *e,
complex *z__, integer *ldz, complex *work, integer *lwork, real *
rwork, integer *lrwork, integer *iwork, integer *liwork, integer *
info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2, i__3, i__4;
real r__1, r__2;
/* Local variables */
integer i__, j, k, m;
real p;
integer ii, ll, lgn;
real eps, tiny;
integer lwmin;
integer start;
integer finish;
integer liwmin, icompz;
real orgnrm;
integer lrwmin;
logical lquery;
integer smlsiz;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CSTEDC computes all eigenvalues and, optionally, eigenvectors of a */
/* symmetric tridiagonal matrix using the divide and conquer method. */
/* The eigenvectors of a full or band complex Hermitian matrix can also */
/* be found if CHETRD or CHPTRD or CHBTRD has been used to reduce this */
/* matrix to tridiagonal form. */
/* This code makes very mild assumptions about floating point */
/* arithmetic. It will work on machines with a guard digit in */
/* add/subtract, or on those binary machines without guard digits */
/* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */
/* It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. See SLAED3 for details. */
/* Arguments */
/* ========= */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only. */
/* = 'I': Compute eigenvectors of tridiagonal matrix also. */
/* = 'V': Compute eigenvectors of original Hermitian matrix */
/* also. On entry, Z contains the unitary matrix used */
/* to reduce the original matrix to tridiagonal form. */
/* N (input) INTEGER */
/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
/* D (input/output) REAL array, dimension (N) */
/* On entry, the diagonal elements of the tridiagonal matrix. */
/* On exit, if INFO = 0, the eigenvalues in ascending order. */
/* E (input/output) REAL array, dimension (N-1) */
/* On entry, the subdiagonal elements of the tridiagonal matrix. */
/* On exit, E has been destroyed. */
/* Z (input/output) COMPLEX 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. */
/* If eigenvectors are desired, then LDZ >= max(1,N). */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* If COMPZ = 'N' or 'I', or N <= 1, LWORK must be at least 1. */
/* If COMPZ = 'V' and N > 1, LWORK must be at least N*N. */
/* Note that for COMPZ = 'V', then if N is less than or */
/* equal to the minimum divide size, usually 25, then LWORK need */
/* only be 1. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal sizes of the WORK, RWORK and */
/* IWORK arrays, returns these values as the first entries of */
/* the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK)) */
/* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. */
/* LRWORK (input) INTEGER */
/* The dimension of the array RWORK. */
/* If COMPZ = 'N' or N <= 1, LRWORK must be at least 1. */
/* If COMPZ = 'V' and N > 1, LRWORK must be at least */
/* 1 + 3*N + 2*N*lg N + 3*N**2 , */
/* where lg( N ) = smallest integer k such */
/* that 2**k >= N. */
/* If COMPZ = 'I' and N > 1, LRWORK must be at least */
/* 1 + 4*N + 2*N**2 . */
/* Note that for COMPZ = 'I' or 'V', then if N is less than or */
/* equal to the minimum divide size, usually 25, then LRWORK */
/* need only be max(1,2*(N-1)). */
/* If LRWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal sizes of the WORK, RWORK */
/* and IWORK arrays, returns these values as the first entries */
/* of the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. */
/* If COMPZ = 'N' or N <= 1, LIWORK must be at least 1. */
/* If COMPZ = 'V' or N > 1, LIWORK must be at least */
/* 6 + 6*N + 5*N*lg N. */
/* If COMPZ = 'I' or N > 1, LIWORK must be at least */
/* 3 + 5*N . */
/* Note that for COMPZ = 'I' or 'V', then if N is less than or */
/* equal to the minimum divide size, usually 25, then LIWORK */
/* need only be 1. */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal sizes of the WORK, RWORK */
/* and IWORK arrays, returns these values as the first entries */
/* of the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: The algorithm failed to compute an eigenvalue while */
/* working on the submatrix lying in rows and columns */
/* INFO/(N+1) through mod(INFO,N+1). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Jeff Rutter, Computer Science Division, University of California */
/* at Berkeley, USA */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
--iwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
if (lsame_(compz, "N")) {
icompz = 0;
} else if (lsame_(compz, "V")) {
icompz = 1;
} else if (lsame_(compz, "I")) {
icompz = 2;
} else {
icompz = -1;
}
if (icompz < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
*info = -6;
}
if (*info == 0) {
/* Compute the workspace requirements */
smlsiz = ilaenv_(&c__9, "CSTEDC", " ", &c__0, &c__0, &c__0, &c__0);
if (*n <= 1 || icompz == 0) {
lwmin = 1;
liwmin = 1;
lrwmin = 1;
} else if (*n <= smlsiz) {
lwmin = 1;
liwmin = 1;
lrwmin = *n - 1 << 1;
} else if (icompz == 1) {
lgn = (integer) (log((real) (*n)) / log(2.f));
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
lwmin = *n * *n;
/* Computing 2nd power */
i__1 = *n;
lrwmin = *n * 3 + 1 + (*n << 1) * lgn + i__1 * i__1 * 3;
liwmin = *n * 6 + 6 + *n * 5 * lgn;
} else if (icompz == 2) {
lwmin = 1;
/* Computing 2nd power */
i__1 = *n;
lrwmin = (*n << 2) + 1 + (i__1 * i__1 << 1);
liwmin = *n * 5 + 3;
}
work[1].r = (real) lwmin, work[1].i = 0.f;
rwork[1] = (real) lrwmin;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -8;
} else if (*lrwork < lrwmin && ! lquery) {
*info = -10;
} else if (*liwork < liwmin && ! lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CSTEDC", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz != 0) {
i__1 = z_dim1 + 1;
z__[i__1].r = 1.f, z__[i__1].i = 0.f;
}
return 0;
}
/* If the following conditional clause is removed, then the routine */
/* will use the Divide and Conquer routine to compute only the */
/* eigenvalues, which requires (3N + 3N**2) real workspace and */
/* (2 + 5N + 2N lg(N)) integer workspace. */
/* Since on many architectures SSTERF is much faster than any other */
/* algorithm for finding eigenvalues only, it is used here */
/* as the default. If the conditional clause is removed, then */
/* information on the size of workspace needs to be changed. */
/* If COMPZ = 'N', use SSTERF to compute the eigenvalues. */
if (icompz == 0) {
ssterf_(n, &d__[1], &e[1], info);
goto L70;
}
/* If N is smaller than the minimum divide size (SMLSIZ+1), then */
/* solve the problem with another solver. */
if (*n <= smlsiz) {
csteqr_(compz, n, &d__[1], &e[1], &z__[z_offset], ldz, &rwork[1],
info);
} else {
/* If COMPZ = 'I', we simply call SSTEDC instead. */
if (icompz == 2) {
slaset_("Full", n, n, &c_b17, &c_b18, &rwork[1], n);
ll = *n * *n + 1;
i__1 = *lrwork - ll + 1;
sstedc_("I", n, &d__[1], &e[1], &rwork[1], n, &rwork[ll], &i__1, &
iwork[1], liwork, info);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * z_dim1;
i__4 = (j - 1) * *n + i__;
z__[i__3].r = rwork[i__4], z__[i__3].i = 0.f;
}
}
goto L70;
}
/* From now on, only option left to be handled is COMPZ = 'V', */
/* i.e. ICOMPZ = 1. */
/* Scale. */
orgnrm = slanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.f) {
goto L70;
}
eps = slamch_("Epsilon");
start = 1;
/* while ( START <= N ) */
L30:
if (start <= *n) {
/* Let FINISH be the position of the next subdiagonal entry */
/* such that E( FINISH ) <= TINY or FINISH = N if no such */
/* subdiagonal exists. The matrix identified by the elements */
/* between START and FINISH constitutes an independent */
/* sub-problem. */
finish = start;
L40:
if (finish < *n) {
tiny = eps * sqrt((r__1 = d__[finish], dabs(r__1))) * sqrt((
r__2 = d__[finish + 1], dabs(r__2)));
if ((r__1 = e[finish], dabs(r__1)) > tiny) {
++finish;
goto L40;
}
}
/* (Sub) Problem determined. Compute its size and solve it. */
m = finish - start + 1;
if (m > smlsiz) {
/* Scale. */
orgnrm = slanst_("M", &m, &d__[start], &e[start]);
slascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &m, &c__1, &d__[
start], &m, info);
i__1 = m - 1;
i__2 = m - 1;
slascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &i__1, &c__1, &e[
start], &i__2, info);
claed0_(n, &m, &d__[start], &e[start], &z__[start * z_dim1 +
1], ldz, &work[1], n, &rwork[1], &iwork[1], info);
if (*info > 0) {
*info = (*info / (m + 1) + start - 1) * (*n + 1) + *info %
(m + 1) + start - 1;
goto L70;
}
/* Scale back. */
slascl_("G", &c__0, &c__0, &c_b18, &orgnrm, &m, &c__1, &d__[
start], &m, info);
} else {
ssteqr_("I", &m, &d__[start], &e[start], &rwork[1], &m, &
rwork[m * m + 1], info);
clacrm_(n, &m, &z__[start * z_dim1 + 1], ldz, &rwork[1], &m, &
work[1], n, &rwork[m * m + 1]);
clacpy_("A", n, &m, &work[1], n, &z__[start * z_dim1 + 1],
ldz);
if (*info > 0) {
*info = start * (*n + 1) + finish;
goto L70;
}
}
start = finish + 1;
goto L30;
}
/* endwhile */
/* If the problem split any number of times, then the eigenvalues */
/* will not be properly ordered. Here we permute the eigenvalues */
/* (and the associated eigenvectors) into ascending order. */
if (m != *n) {
/* Use Selection Sort to minimize swaps of eigenvectors */
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
i__ = ii - 1;
k = i__;
p = d__[i__];
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
if (d__[j] < p) {
k = j;
p = d__[j];
}
}
if (k != i__) {
d__[k] = d__[i__];
d__[i__] = p;
cswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1
+ 1], &c__1);
}
}
}
}
L70:
work[1].r = (real) lwmin, work[1].i = 0.f;
rwork[1] = (real) lrwmin;
iwork[1] = liwmin;
return 0;
/* End of CSTEDC */
} /* cstedc_ */
