int zlaed0_(int *qsiz, int *n, double *d__, double *e, doublecomplex *q, int *ldq, doublecomplex *qstore, int *ldqs, double *rwork, int *iwork, int *info) { /* System generated locals */ int q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2; double d__1; /* Builtin functions */ double log(double); int pow_ii(int *, int *); /* Local variables */ int i__, j, k, ll, iq, lgn, msd2, smm1, spm1, spm2; double temp; int curr, iperm; extern int dcopy_(int *, double *, int *, double *, int *); int indxq, iwrem, iqptr, tlvls; extern int zcopy_(int *, doublecomplex *, int *, doublecomplex *, int *), zlaed7_(int *, int *, int *, int *, int *, int *, double *, doublecomplex *, int *, double *, int *, double *, int *, int *, int *, int *, int *, double *, doublecomplex *, double *, int *, int *) ; int igivcl; extern int xerbla_(char *, int *); extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); extern int zlacrm_(int *, int *, doublecomplex *, int *, double *, int *, doublecomplex *, int *, double *); int igivnm, submat, curprb, subpbs, igivpt; extern int dsteqr_(char *, int *, double *, double *, double *, int *, double *, int *); int curlvl, matsiz, iprmpt, smlsiz; /* -- 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, ZLAED0 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) DOUBLE PRECISION array, dimension (N) */ /* On entry, the diagonal elements of the tridiagonal matrix. */ /* On exit, the eigenvalues in ascending order. */ /* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ /* On entry, the off-diagonal elements of the tridiagonal matrix. */ /* On exit, E has been destroyed. */ /* Q (input/output) COMPLEX*16 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) DOUBLE PRECISION 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*16 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_("ZLAED0", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } smlsiz = ilaenv_(&c__9, "ZLAED0", " ", &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] -= (d__1 = e[smm1], ABS(d__1)); d__[submat] -= (d__1 = e[smm1], ABS(d__1)); /* L40: */ } indxq = (*n << 2) + 3; /* Set up workspaces for eigenvalues only/accumulate new vectors */ /* routine */ temp = log((double) (*n)) / log(2.); 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]; dsteqr_("I", &matsiz, &d__[submat], &e[submat], &rwork[ll], &matsiz, & rwork[1], info); zlacrm_(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. ZLAED7 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. */ zlaed7_(&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]; zcopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1 + 1] , &c__1); /* L100: */ } dcopy_(n, &rwork[1], &c__1, &d__[1], &c__1); return 0; /* End of ZLAED0 */ } /* zlaed0_ */
/* Subroutine */ int zlaed7_(integer *n, integer *cutpnt, integer *qsiz, integer *tlvls, integer *curlvl, integer *curpbm, doublereal *d__, doublecomplex *q, integer *ldq, doublereal *rho, integer *indxq, doublereal *qstore, integer *qptr, integer *prmptr, integer *perm, integer *givptr, integer *givcol, doublereal *givnum, doublecomplex * work, doublereal *rwork, integer *iwork, integer *info) { /* System generated locals */ integer q_dim1, q_offset, i__1, i__2; /* Builtin functions */ integer pow_ii(integer *, integer *); /* Local variables */ integer i__, k, n1, n2, iq, iw, iz, ptr, indx, curr, indxc, indxp; extern /* Subroutine */ int dlaed9_(integer *, integer *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, integer *), zlaed8_(integer *, integer *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublecomplex *, integer *, doublereal *, integer *, integer *, integer *, integer *, integer *, integer *, doublereal *, integer *), dlaeda_(integer *, integer *, integer *, integer *, integer *, integer *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, integer *); integer idlmda; extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, integer *, integer *, integer *), xerbla_(char *, integer *), zlacrm_(integer *, integer *, doublecomplex *, integer *, doublereal *, integer *, doublecomplex *, integer *, doublereal * ); integer coltyp; /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZLAED7 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 DLAED2. */ /* The second stage consists of calculating the updated */ /* eigenvalues. This is done by finding the roots of the secular */ /* equation via the routine DLAED4 (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) DOUBLE PRECISION 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*16 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) DOUBLE PRECISION */ /* 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) DOUBLE PRECISION array, */ /* dimension (3*N+2*QSIZ*N) */ /* WORK (workspace) COMPLEX*16 array, dimension (QSIZ*N) */ /* QSTORE (input/output) DOUBLE PRECISION 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) DOUBLE PRECISION 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_("ZLAED7", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* The following values are for bookkeeping purposes only. They are */ /* integer pointers which indicate the portion of the workspace */ /* used by a particular array in DLAED2 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; dlaeda_(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. */ zlaed8_(&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) { dlaed9_(&k, &c__1, &k, n, &d__[1], &rwork[iq], &k, rho, &rwork[idlmda] , &rwork[iw], &qstore[qptr[curr]], &k, info); zlacrm_(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; dlamrg_(&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 ZLAED7 */ } /* zlaed7_ */
/* Subroutine */ int zstedc_(char *compz, integer *n, doublereal *d__, doublereal *e, doublecomplex *z__, integer *ldz, doublecomplex *work, integer *lwork, doublereal *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; doublereal d__1, d__2; /* Builtin functions */ double log(doublereal); integer pow_ii(integer *, integer *); double sqrt(doublereal); /* Local variables */ integer i__, j, k, m; doublereal p; integer ii, ll, lgn; doublereal eps, tiny; extern logical lsame_(char *, char *); integer lwmin, start; extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlaed0_(integer *, integer *, doublereal *, doublereal *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, integer *, integer *); extern doublereal dlamch_(char *); extern /* Subroutine */ int dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *), dstedc_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, integer *, integer *), dlaset_( char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *); integer finish; extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *); extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *, integer *), zlacrm_(integer *, integer *, doublecomplex *, integer *, doublereal *, integer *, doublecomplex *, integer *, doublereal *); integer liwmin, icompz; extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); doublereal orgnrm; integer lrwmin; logical lquery; integer smlsiz; extern /* Subroutine */ int zsteqr_(char *, integer *, doublereal *, doublereal *, doublecomplex *, integer *, doublereal *, integer *); /* -- LAPACK routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZSTEDC 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 ZHETRD or ZHPTRD or ZHBTRD 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 DLAED3 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) 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 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. */ /* If eigenvectors are desired, then LDZ >= max(1,N). */ /* WORK (workspace/output) COMPLEX*16 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) DOUBLE PRECISION array, */ /* dimension (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 */ /* ===================================================================== */ /* .. 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; --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, "ZSTEDC", " ", &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((doublereal) (*n)) / log(2.)); 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 = (doublereal) lwmin, work[1].i = 0.; rwork[1] = (doublereal) 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_("ZSTEDC", &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., z__[i__1].i = 0.; } 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 DSTERF 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 DSTERF to compute the eigenvalues. */ if (icompz == 0) { dsterf_(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) { zsteqr_(compz, n, &d__[1], &e[1], &z__[z_offset], ldz, &rwork[1], info); } else { /* If COMPZ = 'I', we simply call DSTEDC instead. */ if (icompz == 2) { dlaset_("Full", n, n, &c_b17, &c_b18, &rwork[1], n); ll = *n * *n + 1; i__1 = *lrwork - ll + 1; dstedc_("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.; /* L10: */ } /* L20: */ } goto L70; } /* From now on, only option left to be handled is COMPZ = 'V', */ /* i.e. ICOMPZ = 1. */ /* Scale. */ orgnrm = dlanst_("M", n, &d__[1], &e[1]); if (orgnrm == 0.) { goto L70; } eps = dlamch_("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((d__1 = d__[finish], abs(d__1))) * sqrt(( d__2 = d__[finish + 1], abs(d__2))); if ((d__1 = e[finish], abs(d__1)) > tiny) { ++finish; goto L40; } } /* (Sub) Problem determined. Compute its size and solve it. */ m = finish - start + 1; if (m > smlsiz) { /* Scale. */ orgnrm = dlanst_("M", &m, &d__[start], &e[start]); dlascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &m, &c__1, &d__[ start], &m, info); i__1 = m - 1; i__2 = m - 1; dlascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &i__1, &c__1, &e[ start], &i__2, info); zlaed0_(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. */ dlascl_("G", &c__0, &c__0, &c_b18, &orgnrm, &m, &c__1, &d__[ start], &m, info); } else { dsteqr_("I", &m, &d__[start], &e[start], &rwork[1], &m, & rwork[m * m + 1], info); zlacrm_(n, &m, &z__[start * z_dim1 + 1], ldz, &rwork[1], &m, & work[1], n, &rwork[m * m + 1]); zlacpy_("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]; } /* L50: */ } 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); } /* L60: */ } } } L70: work[1].r = (doublereal) lwmin, work[1].i = 0.; rwork[1] = (doublereal) lrwmin; iwork[1] = liwmin; return 0; /* End of ZSTEDC */ } /* zstedc_ */