3 /* Table of constant values */
5 static integer c__1 = 1;
6 static doublereal c_b18 = .001;
8 /* Subroutine */ int dstemr_(char *jobz, char *range, integer *n, doublereal *
9 d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il,
10 integer *iu, integer *m, doublereal *w, doublereal *z__, integer *ldz,
11 integer *nzc, integer *isuppz, logical *tryrac, doublereal *work,
12 integer *lwork, integer *iwork, integer *liwork, integer *info)
14 /* System generated locals */
15 integer z_dim1, z_offset, i__1, i__2;
16 doublereal d__1, d__2;
18 /* Builtin functions */
19 double sqrt(doublereal);
27 doublereal sn, wl, wu;
30 integer indd, iend, jblk, wend;
31 doublereal rmin, rmax;
34 extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
35 *, doublereal *, doublereal *);
37 doublereal rtol1, rtol2;
38 extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
42 extern logical lsame_(char *, char *);
43 integer iinfo, iindw, ilast;
44 extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
45 doublereal *, integer *), dswap_(integer *, doublereal *, integer
46 *, doublereal *, integer *);
49 extern /* Subroutine */ int dlaev2_(doublereal *, doublereal *,
50 doublereal *, doublereal *, doublereal *, doublereal *,
52 extern doublereal dlamch_(char *);
58 extern /* Subroutine */ int dlarrc_(char *, integer *, doublereal *,
59 doublereal *, doublereal *, doublereal *, doublereal *, integer *,
60 integer *, integer *, integer *), dlarre_(char *,
61 integer *, doublereal *, doublereal *, integer *, integer *,
62 doublereal *, doublereal *, doublereal *, doublereal *,
63 doublereal *, doublereal *, integer *, integer *, integer *,
64 doublereal *, doublereal *, doublereal *, integer *, integer *,
65 doublereal *, doublereal *, doublereal *, integer *, integer *);
68 extern /* Subroutine */ int dlarrj_(integer *, doublereal *, doublereal *,
69 integer *, integer *, doublereal *, integer *, doublereal *,
70 doublereal *, doublereal *, integer *, doublereal *, doublereal *,
71 integer *), xerbla_(char *, integer *);
73 integer inderr, iindwk, indgrs, offset;
74 extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
75 extern /* Subroutine */ int dlarrr_(integer *, doublereal *, doublereal *,
76 integer *), dlarrv_(integer *, doublereal *, doublereal *,
77 doublereal *, doublereal *, doublereal *, integer *, integer *,
78 integer *, integer *, doublereal *, doublereal *, doublereal *,
79 doublereal *, doublereal *, doublereal *, integer *, integer *,
80 doublereal *, doublereal *, integer *, integer *, doublereal *,
81 integer *, integer *), dlasrt_(char *, integer *, doublereal *,
84 integer iinspl, ifirst, indwrk, liwmin, nzcmin;
88 logical lquery, zquery;
91 /* -- LAPACK computational routine (version 3.1) -- */
92 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
95 /* .. Scalar Arguments .. */
97 /* .. Array Arguments .. */
103 /* DSTEMR computes selected eigenvalues and, optionally, eigenvectors */
104 /* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */
105 /* a well defined set of pairwise different real eigenvalues, the corresponding */
106 /* real eigenvectors are pairwise orthogonal. */
108 /* The spectrum may be computed either completely or partially by specifying */
109 /* either an interval (VL,VU] or a range of indices IL:IU for the desired */
112 /* Depending on the number of desired eigenvalues, these are computed either */
113 /* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are */
114 /* computed by the use of various suitable L D L^T factorizations near clusters */
115 /* of close eigenvalues (referred to as RRRs, Relatively Robust */
116 /* Representations). An informal sketch of the algorithm follows. */
118 /* For each unreduced block (submatrix) of T, */
119 /* (a) Compute T - sigma I = L D L^T, so that L and D */
120 /* define all the wanted eigenvalues to high relative accuracy. */
121 /* This means that small relative changes in the entries of D and L */
122 /* cause only small relative changes in the eigenvalues and */
123 /* eigenvectors. The standard (unfactored) representation of the */
124 /* tridiagonal matrix T does not have this property in general. */
125 /* (b) Compute the eigenvalues to suitable accuracy. */
126 /* If the eigenvectors are desired, the algorithm attains full */
127 /* accuracy of the computed eigenvalues only right before */
128 /* the corresponding vectors have to be computed, see steps c) and d). */
129 /* (c) For each cluster of close eigenvalues, select a new */
130 /* shift close to the cluster, find a new factorization, and refine */
131 /* the shifted eigenvalues to suitable accuracy. */
132 /* (d) For each eigenvalue with a large enough relative separation compute */
133 /* the corresponding eigenvector by forming a rank revealing twisted */
134 /* factorization. Go back to (c) for any clusters that remain. */
136 /* For more details, see: */
137 /* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */
138 /* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */
139 /* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */
140 /* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */
141 /* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */
142 /* 2004. Also LAPACK Working Note 154. */
143 /* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */
144 /* tridiagonal eigenvalue/eigenvector problem", */
145 /* Computer Science Division Technical Report No. UCB/CSD-97-971, */
146 /* UC Berkeley, May 1997. */
149 /* 1.DSTEMR works only on machines which follow IEEE-754 */
150 /* floating-point standard in their handling of infinities and NaNs. */
151 /* This permits the use of efficient inner loops avoiding a check for */
157 /* JOBZ (input) CHARACTER*1 */
158 /* = 'N': Compute eigenvalues only; */
159 /* = 'V': Compute eigenvalues and eigenvectors. */
161 /* RANGE (input) CHARACTER*1 */
162 /* = 'A': all eigenvalues will be found. */
163 /* = 'V': all eigenvalues in the half-open interval (VL,VU] */
165 /* = 'I': the IL-th through IU-th eigenvalues will be found. */
167 /* N (input) INTEGER */
168 /* The order of the matrix. N >= 0. */
170 /* D (input/output) DOUBLE PRECISION array, dimension (N) */
171 /* On entry, the N diagonal elements of the tridiagonal matrix */
172 /* T. On exit, D is overwritten. */
174 /* E (input/output) DOUBLE PRECISION array, dimension (N) */
175 /* On entry, the (N-1) subdiagonal elements of the tridiagonal */
176 /* matrix T in elements 1 to N-1 of E. E(N) need not be set on */
177 /* input, but is used internally as workspace. */
178 /* On exit, E is overwritten. */
180 /* VL (input) DOUBLE PRECISION */
181 /* VU (input) DOUBLE PRECISION */
182 /* If RANGE='V', the lower and upper bounds of the interval to */
183 /* be searched for eigenvalues. VL < VU. */
184 /* Not referenced if RANGE = 'A' or 'I'. */
186 /* IL (input) INTEGER */
187 /* IU (input) INTEGER */
188 /* If RANGE='I', the indices (in ascending order) of the */
189 /* smallest and largest eigenvalues to be returned. */
190 /* 1 <= IL <= IU <= N, if N > 0. */
191 /* Not referenced if RANGE = 'A' or 'V'. */
193 /* M (output) INTEGER */
194 /* The total number of eigenvalues found. 0 <= M <= N. */
195 /* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
197 /* W (output) DOUBLE PRECISION array, dimension (N) */
198 /* The first M elements contain the selected eigenvalues in */
199 /* ascending order. */
201 /* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) */
202 /* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */
203 /* contain the orthonormal eigenvectors of the matrix T */
204 /* corresponding to the selected eigenvalues, with the i-th */
205 /* column of Z holding the eigenvector associated with W(i). */
206 /* If JOBZ = 'N', then Z is not referenced. */
207 /* Note: the user must ensure that at least max(1,M) columns are */
208 /* supplied in the array Z; if RANGE = 'V', the exact value of M */
209 /* is not known in advance and can be computed with a workspace */
210 /* query by setting NZC = -1, see below. */
212 /* LDZ (input) INTEGER */
213 /* The leading dimension of the array Z. LDZ >= 1, and if */
214 /* JOBZ = 'V', then LDZ >= max(1,N). */
216 /* NZC (input) INTEGER */
217 /* The number of eigenvectors to be held in the array Z. */
218 /* If RANGE = 'A', then NZC >= max(1,N). */
219 /* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU]. */
220 /* If RANGE = 'I', then NZC >= IU-IL+1. */
221 /* If NZC = -1, then a workspace query is assumed; the */
222 /* routine calculates the number of columns of the array Z that */
223 /* are needed to hold the eigenvectors. */
224 /* This value is returned as the first entry of the Z array, and */
225 /* no error message related to NZC is issued by XERBLA. */
227 /* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) ) */
228 /* The support of the eigenvectors in Z, i.e., the indices */
229 /* indicating the nonzero elements in Z. The i-th computed eigenvector */
230 /* is nonzero only in elements ISUPPZ( 2*i-1 ) through */
231 /* ISUPPZ( 2*i ). This is relevant in the case when the matrix */
232 /* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */
234 /* TRYRAC (input/output) LOGICAL */
235 /* If TRYRAC.EQ..TRUE., indicates that the code should check whether */
236 /* the tridiagonal matrix defines its eigenvalues to high relative */
237 /* accuracy. If so, the code uses relative-accuracy preserving */
238 /* algorithms that might be (a bit) slower depending on the matrix. */
239 /* If the matrix does not define its eigenvalues to high relative */
240 /* accuracy, the code can uses possibly faster algorithms. */
241 /* If TRYRAC.EQ..FALSE., the code is not required to guarantee */
242 /* relatively accurate eigenvalues and can use the fastest possible */
244 /* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix */
245 /* does not define its eigenvalues to high relative accuracy. */
247 /* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */
248 /* On exit, if INFO = 0, WORK(1) returns the optimal */
249 /* (and minimal) LWORK. */
251 /* LWORK (input) INTEGER */
252 /* The dimension of the array WORK. LWORK >= max(1,18*N) */
253 /* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'. */
254 /* If LWORK = -1, then a workspace query is assumed; the routine */
255 /* only calculates the optimal size of the WORK array, returns */
256 /* this value as the first entry of the WORK array, and no error */
257 /* message related to LWORK is issued by XERBLA. */
259 /* IWORK (workspace/output) INTEGER array, dimension (LIWORK) */
260 /* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
262 /* LIWORK (input) INTEGER */
263 /* The dimension of the array IWORK. LIWORK >= max(1,10*N) */
264 /* if the eigenvectors are desired, and LIWORK >= max(1,8*N) */
265 /* if only the eigenvalues are to be computed. */
266 /* If LIWORK = -1, then a workspace query is assumed; the */
267 /* routine only calculates the optimal size of the IWORK array, */
268 /* returns this value as the first entry of the IWORK array, and */
269 /* no error message related to LIWORK is issued by XERBLA. */
271 /* INFO (output) INTEGER */
273 /* = 0: successful exit */
274 /* < 0: if INFO = -i, the i-th argument had an illegal value */
275 /* > 0: if INFO = 1X, internal error in DLARRE, */
276 /* if INFO = 2X, internal error in DLARRV. */
277 /* Here, the digit X = ABS( IINFO ) < 10, where IINFO is */
278 /* the nonzero error code returned by DLARRE or */
279 /* DLARRV, respectively. */
282 /* Further Details */
283 /* =============== */
285 /* Based on contributions by */
286 /* Beresford Parlett, University of California, Berkeley, USA */
287 /* Jim Demmel, University of California, Berkeley, USA */
288 /* Inderjit Dhillon, University of Texas, Austin, USA */
289 /* Osni Marques, LBNL/NERSC, USA */
290 /* Christof Voemel, University of California, Berkeley, USA */
292 /* ===================================================================== */
294 /* .. Parameters .. */
296 /* .. Local Scalars .. */
299 /* .. External Functions .. */
301 /* .. External Subroutines .. */
303 /* .. Intrinsic Functions .. */
305 /* .. Executable Statements .. */
307 /* Test the input parameters. */
309 /* Parameter adjustments */
314 z_offset = 1 + z_dim1;
321 wantz = lsame_(jobz, "V");
322 alleig = lsame_(range, "A");
323 valeig = lsame_(range, "V");
324 indeig = lsame_(range, "I");
326 lquery = *lwork == -1 || *liwork == -1;
328 *tryrac = *info != 0;
329 /* DSTEMR needs WORK of size 6*N, IWORK of size 3*N. */
330 /* In addition, DLARRE needs WORK of size 6*N, IWORK of size 5*N. */
331 /* Furthermore, DLARRV needs WORK of size 12*N, IWORK of size 7*N. */
336 /* need less workspace if only the eigenvalues are wanted */
345 /* We do not reference VL, VU in the cases RANGE = 'I','A' */
346 /* The interval (WL, WU] contains all the wanted eigenvalues. */
347 /* It is either given by the user or computed in DLARRE. */
351 /* We do not reference IL, IU in the cases RANGE = 'V','A' */
357 if (! (wantz || lsame_(jobz, "N"))) {
359 } else if (! (alleig || valeig || indeig)) {
363 } else if (valeig && *n > 0 && wu <= wl) {
365 } else if (indeig && (iil < 1 || iil > *n)) {
367 } else if (indeig && (iiu < iil || iiu > *n)) {
369 } else if (*ldz < 1 || wantz && *ldz < *n) {
371 } else if (*lwork < lwmin && ! lquery) {
373 } else if (*liwork < liwmin && ! lquery) {
377 /* Get machine constants. */
379 safmin = dlamch_("Safe minimum");
380 eps = dlamch_("Precision");
381 smlnum = safmin / eps;
382 bignum = 1. / smlnum;
385 d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
386 rmax = min(d__1,d__2);
389 work[1] = (doublereal) lwmin;
392 if (wantz && alleig) {
394 } else if (wantz && valeig) {
395 dlarrc_("T", n, vl, vu, &d__[1], &e[1], &safmin, &nzcmin, &itmp, &
397 } else if (wantz && indeig) {
398 nzcmin = iiu - iil + 1;
400 /* WANTZ .EQ. FALSE. */
403 if (zquery && *info == 0) {
404 z__[z_dim1 + 1] = (doublereal) nzcmin;
405 } else if (*nzc < nzcmin && ! zquery) {
412 xerbla_("DSTEMR", &i__1);
415 } else if (lquery || zquery) {
419 /* Handle N = 0, 1, and 2 cases immediately */
427 if (alleig || indeig) {
431 if (wl < d__[1] && wu >= d__[1]) {
436 if (wantz && ! zquery) {
437 z__[z_dim1 + 1] = 1.;
446 dlae2_(&d__[1], &e[1], &d__[2], &r1, &r2);
447 } else if (wantz && ! zquery) {
448 dlaev2_(&d__[1], &e[1], &d__[2], &r1, &r2, &cs, &sn);
450 if (alleig || valeig && r2 > wl && r2 <= wu || indeig && iil == 1) {
453 if (wantz && ! zquery) {
454 z__[*m * z_dim1 + 1] = -sn;
455 z__[*m * z_dim1 + 2] = cs;
456 /* Note: At most one of SN and CS can be zero. */
459 isuppz[(*m << 1) - 1] = 1;
460 isuppz[(*m << 1) - 1] = 2;
462 isuppz[(*m << 1) - 1] = 1;
463 isuppz[(*m << 1) - 1] = 1;
466 isuppz[(*m << 1) - 1] = 2;
471 if (alleig || valeig && r1 > wl && r1 <= wu || indeig && iiu == 2) {
474 if (wantz && ! zquery) {
475 z__[*m * z_dim1 + 1] = cs;
476 z__[*m * z_dim1 + 2] = sn;
477 /* Note: At most one of SN and CS can be zero. */
480 isuppz[(*m << 1) - 1] = 1;
481 isuppz[(*m << 1) - 1] = 2;
483 isuppz[(*m << 1) - 1] = 1;
484 isuppz[(*m << 1) - 1] = 1;
487 isuppz[(*m << 1) - 1] = 2;
494 /* Continue with general N */
496 inderr = (*n << 1) + 1;
498 indd = (*n << 2) + 1;
504 iindw = (*n << 1) + 1;
507 /* Scale matrix to allowable range, if necessary. */
508 /* The allowable range is related to the PIVMIN parameter; see the */
509 /* comments in DLARRD. The preference for scaling small values */
510 /* up is heuristic; we expect users' matrices not to be close to the */
511 /* RMAX threshold. */
514 tnrm = dlanst_("M", n, &d__[1], &e[1]);
515 if (tnrm > 0. && tnrm < rmin) {
517 } else if (tnrm > rmax) {
521 dscal_(n, &scale, &d__[1], &c__1);
523 dscal_(&i__1, &scale, &e[1], &c__1);
526 /* If eigenvalues in interval have to be found, */
527 /* scale (WL, WU] accordingly */
533 /* Compute the desired eigenvalues of the tridiagonal after splitting */
534 /* into smaller subblocks if the corresponding off-diagonal elements */
536 /* THRESH is the splitting parameter for DLARRE */
537 /* A negative THRESH forces the old splitting criterion based on the */
538 /* size of the off-diagonal. A positive THRESH switches to splitting */
539 /* which preserves relative accuracy. */
542 /* Test whether the matrix warrants the more expensive relative approach. */
543 dlarrr_(n, &d__[1], &e[1], &iinfo);
545 /* The user does not care about relative accurately eigenvalues */
548 /* Set the splitting criterion */
553 /* relative accuracy is desired but T does not guarantee it */
558 /* Copy original diagonal, needed to guarantee relative accuracy */
559 dcopy_(n, &d__[1], &c__1, &work[indd], &c__1);
561 /* Store the squares of the offdiagonal values of T */
563 for (j = 1; j <= i__1; ++j) {
564 /* Computing 2nd power */
566 work[inde2 + j - 1] = d__1 * d__1;
569 /* Set the tolerance parameters for bisection */
571 /* DLARRE computes the eigenvalues to full precision. */
575 /* DLARRE computes the eigenvalues to less than full precision. */
576 /* DLARRV will refine the eigenvalue approximations, and we can */
577 /* need less accurate initial bisection in DLARRE. */
578 /* Note: these settings do only affect the subset case and DLARRE */
581 d__1 = sqrt(eps) * .005, d__2 = eps * 4.;
582 rtol2 = max(d__1,d__2);
584 dlarre_(range, n, &wl, &wu, &iil, &iiu, &d__[1], &e[1], &work[inde2], &
585 rtol1, &rtol2, &thresh, &nsplit, &iwork[iinspl], m, &w[1], &work[
586 inderr], &work[indgp], &iwork[iindbl], &iwork[iindw], &work[
587 indgrs], &pivmin, &work[indwrk], &iwork[iindwk], &iinfo);
589 *info = abs(iinfo) + 10;
592 /* Note that if RANGE .NE. 'V', DLARRE computes bounds on the desired */
593 /* part of the spectrum. All desired eigenvalues are contained in */
597 /* Compute the desired eigenvectors corresponding to the computed */
600 dlarrv_(n, &wl, &wu, &d__[1], &e[1], &pivmin, &iwork[iinspl], m, &
601 c__1, m, &c_b18, &rtol1, &rtol2, &w[1], &work[inderr], &work[
602 indgp], &iwork[iindbl], &iwork[iindw], &work[indgrs], &z__[
603 z_offset], ldz, &isuppz[1], &work[indwrk], &iwork[iindwk], &
606 *info = abs(iinfo) + 20;
610 /* DLARRE computes eigenvalues of the (shifted) root representation */
611 /* DLARRV returns the eigenvalues of the unshifted matrix. */
612 /* However, if the eigenvectors are not desired by the user, we need */
613 /* to apply the corresponding shifts from DLARRE to obtain the */
614 /* eigenvalues of the original matrix. */
616 for (j = 1; j <= i__1; ++j) {
617 itmp = iwork[iindbl + j - 1];
618 w[j] += e[iwork[iinspl + itmp - 1]];
624 /* Refine computed eigenvalues so that they are relatively accurate */
625 /* with respect to the original matrix T. */
628 i__1 = iwork[iindbl + *m - 1];
629 for (jblk = 1; jblk <= i__1; ++jblk) {
630 iend = iwork[iinspl + jblk - 1];
631 in = iend - ibegin + 1;
633 /* check if any eigenvalues have to be refined in this block */
636 if (iwork[iindbl + wend] == jblk) {
645 offset = iwork[iindw + wbegin - 1] - 1;
646 ifirst = iwork[iindw + wbegin - 1];
647 ilast = iwork[iindw + wend - 1];
649 dlarrj_(&in, &work[indd + ibegin - 1], &work[inde2 + ibegin - 1],
650 &ifirst, &ilast, &rtol2, &offset, &w[wbegin], &work[
651 inderr + wbegin - 1], &work[indwrk], &iwork[iindwk], &
652 pivmin, &tnrm, &iinfo);
660 /* If matrix was scaled, then rescale eigenvalues appropriately. */
664 dscal_(m, &d__1, &w[1], &c__1);
667 /* If eigenvalues are not in increasing order, then sort them, */
668 /* possibly along with eigenvectors. */
672 dlasrt_("I", m, &w[1], &iinfo);
679 for (j = 1; j <= i__1; ++j) {
683 for (jj = j + 1; jj <= i__2; ++jj) {
694 dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j *
696 itmp = isuppz[(i__ << 1) - 1];
697 isuppz[(i__ << 1) - 1] = isuppz[(j << 1) - 1];
698 isuppz[(j << 1) - 1] = itmp;
699 itmp = isuppz[i__ * 2];
700 isuppz[i__ * 2] = isuppz[j * 2];
701 isuppz[j * 2] = itmp;
710 work[1] = (doublereal) lwmin;