1 /* ../netlib/cstein.f -- translated by f2c (version 20100827). You must link the resulting object file with libf2c: on Microsoft Windows system, link with libf2c.lib;
2 on Linux or Unix systems, link with .../path/to/libf2c.a -lm or, if you install libf2c.a in a standard place, with -lf2c -lm -- in that order, at the end of the command line, as in cc *.o -lf2c -lm Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., http://www.netlib.org/f2c/libf2c.zip */
3 #include "FLA_f2c.h" /* Table of constant values */
4 static integer c__2 = 2;
5 static integer c__1 = 1;
6 static integer c_n1 = -1;
7 /* > \brief \b CSTEIN */
8 /* =========== DOCUMENTATION =========== */
9 /* Online html documentation available at */
10 /* http://www.netlib.org/lapack/explore-html/ */
11 /* > \htmlonly */
12 /* > Download CSTEIN + dependencies */
13 /* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cstein. f"> */
14 /* > [TGZ]</a> */
15 /* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cstein. f"> */
16 /* > [ZIP]</a> */
17 /* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cstein. f"> */
18 /* > [TXT]</a> */
19 /* > \endhtmlonly */
20 /* Definition: */
21 /* =========== */
22 /* SUBROUTINE CSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, */
23 /* IWORK, IFAIL, INFO ) */
24 /* .. Scalar Arguments .. */
25 /* INTEGER INFO, LDZ, M, N */
26 /* .. */
27 /* .. Array Arguments .. */
28 /* INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ), */
29 /* $ IWORK( * ) */
30 /* REAL D( * ), E( * ), W( * ), WORK( * ) */
31 /* COMPLEX Z( LDZ, * ) */
32 /* .. */
33 /* > \par Purpose: */
34 /* ============= */
35 /* > */
36 /* > \verbatim */
37 /* > */
38 /* > CSTEIN computes the eigenvectors of a real symmetric tridiagonal */
39 /* > matrix T corresponding to specified eigenvalues, using inverse */
40 /* > iteration. */
41 /* > */
42 /* > The maximum number of iterations allowed for each eigenvector is */
43 /* > specified by an internal parameter MAXITS (currently set to 5). */
44 /* > */
45 /* > Although the eigenvectors are real, they are stored in a complex */
46 /* > array, which may be passed to CUNMTR or CUPMTR for back */
47 /* > transformation to the eigenvectors of a complex Hermitian matrix */
48 /* > which was reduced to tridiagonal form. */
49 /* > */
50 /* > \endverbatim */
51 /* Arguments: */
52 /* ========== */
53 /* > \param[in] N */
54 /* > \verbatim */
55 /* > N is INTEGER */
56 /* > The order of the matrix. N >= 0. */
57 /* > \endverbatim */
58 /* > */
59 /* > \param[in] D */
60 /* > \verbatim */
61 /* > D is REAL array, dimension (N) */
62 /* > The n diagonal elements of the tridiagonal matrix T. */
63 /* > \endverbatim */
64 /* > */
65 /* > \param[in] E */
66 /* > \verbatim */
67 /* > E is REAL array, dimension (N-1) */
68 /* > The (n-1) subdiagonal elements of the tridiagonal matrix */
69 /* > T, stored in elements 1 to N-1. */
70 /* > \endverbatim */
71 /* > */
72 /* > \param[in] M */
73 /* > \verbatim */
74 /* > M is INTEGER */
75 /* > The number of eigenvectors to be found. 0 <= M <= N. */
76 /* > \endverbatim */
77 /* > */
78 /* > \param[in] W */
79 /* > \verbatim */
80 /* > W is REAL array, dimension (N) */
81 /* > The first M elements of W contain the eigenvalues for */
82 /* > which eigenvectors are to be computed. The eigenvalues */
83 /* > should be grouped by split-off block and ordered from */
84 /* > smallest to largest within the block. ( The output array */
85 /* > W from SSTEBZ with ORDER = 'B' is expected here. ) */
86 /* > \endverbatim */
87 /* > */
88 /* > \param[in] IBLOCK */
89 /* > \verbatim */
90 /* > IBLOCK is INTEGER array, dimension (N) */
91 /* > The submatrix indices associated with the corresponding */
92 /* > eigenvalues in W;
93 IBLOCK(i)=1 if eigenvalue W(i) belongs to */
94 /* > the first submatrix from the top, =2 if W(i) belongs to */
95 /* > the second submatrix, etc. ( The output array IBLOCK */
96 /* > from SSTEBZ is expected here. ) */
97 /* > \endverbatim */
98 /* > */
99 /* > \param[in] ISPLIT */
100 /* > \verbatim */
101 /* > ISPLIT is INTEGER array, dimension (N) */
102 /* > The splitting points, at which T breaks up into submatrices. */
103 /* > The first submatrix consists of rows/columns 1 to */
104 /* > ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */
105 /* > through ISPLIT( 2 ), etc. */
106 /* > ( The output array ISPLIT from SSTEBZ is expected here. ) */
107 /* > \endverbatim */
108 /* > */
109 /* > \param[out] Z */
110 /* > \verbatim */
111 /* > Z is COMPLEX array, dimension (LDZ, M) */
112 /* > The computed eigenvectors. The eigenvector associated */
113 /* > with the eigenvalue W(i) is stored in the i-th column of */
114 /* > Z. Any vector which fails to converge is set to its current */
115 /* > iterate after MAXITS iterations. */
116 /* > The imaginary parts of the eigenvectors are set to zero. */
117 /* > \endverbatim */
118 /* > */
119 /* > \param[in] LDZ */
120 /* > \verbatim */
121 /* > LDZ is INTEGER */
122 /* > The leading dimension of the array Z. LDZ >= max(1,N). */
123 /* > \endverbatim */
124 /* > */
125 /* > \param[out] WORK */
126 /* > \verbatim */
127 /* > WORK is REAL array, dimension (5*N) */
128 /* > \endverbatim */
129 /* > */
130 /* > \param[out] IWORK */
131 /* > \verbatim */
132 /* > IWORK is INTEGER array, dimension (N) */
133 /* > \endverbatim */
134 /* > */
135 /* > \param[out] IFAIL */
136 /* > \verbatim */
137 /* > IFAIL is INTEGER array, dimension (M) */
138 /* > On normal exit, all elements of IFAIL are zero. */
139 /* > If one or more eigenvectors fail to converge after */
140 /* > MAXITS iterations, then their indices are stored in */
141 /* > array IFAIL. */
142 /* > \endverbatim */
143 /* > */
144 /* > \param[out] INFO */
145 /* > \verbatim */
146 /* > INFO is INTEGER */
147 /* > = 0: successful exit */
148 /* > < 0: if INFO = -i, the i-th argument had an illegal value */
149 /* > > 0: if INFO = i, then i eigenvectors failed to converge */
150 /* > in MAXITS iterations. Their indices are stored in */
151 /* > array IFAIL. */
152 /* > \endverbatim */
153 /* > \par Internal Parameters: */
154 /* ========================= */
155 /* > */
156 /* > \verbatim */
157 /* > MAXITS INTEGER, default = 5 */
158 /* > The maximum number of iterations performed. */
159 /* > */
160 /* > EXTRA INTEGER, default = 2 */
161 /* > The number of iterations performed after norm growth */
162 /* > criterion is satisfied, should be at least 1. */
163 /* > \endverbatim */
164 /* Authors: */
165 /* ======== */
166 /* > \author Univ. of Tennessee */
167 /* > \author Univ. of California Berkeley */
168 /* > \author Univ. of Colorado Denver */
169 /* > \author NAG Ltd. */
170 /* > \date November 2011 */
171 /* > \ingroup complexOTHERcomputational */
172 /* ===================================================================== */
173 /* Subroutine */
cstein_(integer * n,real * d__,real * e,integer * m,real * w,integer * iblock,integer * isplit,complex * z__,integer * ldz,real * work,integer * iwork,integer * ifail,integer * info)174 int cstein_(integer *n, real *d__, real *e, integer *m, real *w, integer *iblock, integer *isplit, complex *z__, integer *ldz, real *work, integer *iwork, integer *ifail, integer *info)
175 {
176 /* System generated locals */
177 integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
178 real r__1, r__2, r__3, r__4, r__5;
179 complex q__1;
180 /* Builtin functions */
181 double sqrt(doublereal);
182 /* Local variables */
183 integer i__, j, b1, j1, bn, jr;
184 real xj, scl, eps, ctr, sep, nrm, tol;
185 integer its;
186 real xjm, eps1;
187 integer jblk, nblk, jmax;
188 extern real snrm2_(integer *, real *, integer *);
189 integer iseed[4], gpind, iinfo;
190 extern /* Subroutine */
191 int sscal_(integer *, real *, real *, integer *);
192 extern real sasum_(integer *, real *, integer *);
193 extern /* Subroutine */
194 int scopy_(integer *, real *, integer *, real *, integer *);
195 real ortol;
196 integer indrv1, indrv2, indrv3, indrv4, indrv5;
197 extern real slamch_(char *);
198 extern /* Subroutine */
199 int xerbla_(char *, integer *), slagtf_( integer *, real *, real *, real *, real *, real *, real *, integer *, integer *);
200 integer nrmchk;
201 extern integer isamax_(integer *, real *, integer *);
202 extern /* Subroutine */
203 int slagts_(integer *, integer *, real *, real *, real *, real *, integer *, real *, real *, integer *);
204 integer blksiz;
205 real onenrm, pertol;
206 extern /* Subroutine */
207 int slarnv_(integer *, integer *, integer *, real *);
208 real stpcrt;
209 /* -- LAPACK computational routine (version 3.4.0) -- */
210 /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
211 /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
212 /* November 2011 */
213 /* .. Scalar Arguments .. */
214 /* .. */
215 /* .. Array Arguments .. */
216 /* .. */
217 /* ===================================================================== */
218 /* .. Parameters .. */
219 /* .. */
220 /* .. Local Scalars .. */
221 /* .. */
222 /* .. Local Arrays .. */
223 /* .. */
224 /* .. External Functions .. */
225 /* .. */
226 /* .. External Subroutines .. */
227 /* .. */
228 /* .. Intrinsic Functions .. */
229 /* .. */
230 /* .. Executable Statements .. */
231 /* Test the input parameters. */
232 /* Parameter adjustments */
233 --d__;
234 --e;
235 --w;
236 --iblock;
237 --isplit;
238 z_dim1 = *ldz;
239 z_offset = 1 + z_dim1;
240 z__ -= z_offset;
241 --work;
242 --iwork;
243 --ifail;
244 /* Function Body */
245 *info = 0;
246 i__1 = *m;
247 for (i__ = 1;
248 i__ <= i__1;
249 ++i__)
250 {
251 ifail[i__] = 0;
252 /* L10: */
253 }
254 if (*n < 0)
255 {
256 *info = -1;
257 }
258 else if (*m < 0 || *m > *n)
259 {
260 *info = -4;
261 }
262 else if (*ldz < max(1,*n))
263 {
264 *info = -9;
265 }
266 else
267 {
268 i__1 = *m;
269 for (j = 2;
270 j <= i__1;
271 ++j)
272 {
273 if (iblock[j] < iblock[j - 1])
274 {
275 *info = -6;
276 goto L30;
277 }
278 if (iblock[j] == iblock[j - 1] && w[j] < w[j - 1])
279 {
280 *info = -5;
281 goto L30;
282 }
283 /* L20: */
284 }
285 L30:
286 ;
287 }
288 if (*info != 0)
289 {
290 i__1 = -(*info);
291 xerbla_("CSTEIN", &i__1);
292 return 0;
293 }
294 /* Quick return if possible */
295 if (*n == 0 || *m == 0)
296 {
297 return 0;
298 }
299 else if (*n == 1)
300 {
301 i__1 = z_dim1 + 1;
302 z__[i__1].r = 1.f;
303 z__[i__1].i = 0.f; // , expr subst
304 return 0;
305 }
306 /* Get machine constants. */
307 eps = slamch_("Precision");
308 /* Initialize seed for random number generator SLARNV. */
309 for (i__ = 1;
310 i__ <= 4;
311 ++i__)
312 {
313 iseed[i__ - 1] = 1;
314 /* L40: */
315 }
316 /* Initialize pointers. */
317 indrv1 = 0;
318 indrv2 = indrv1 + *n;
319 indrv3 = indrv2 + *n;
320 indrv4 = indrv3 + *n;
321 indrv5 = indrv4 + *n;
322 /* Compute eigenvectors of matrix blocks. */
323 j1 = 1;
324 i__1 = iblock[*m];
325 for (nblk = 1;
326 nblk <= i__1;
327 ++nblk)
328 {
329 /* Find starting and ending indices of block nblk. */
330 if (nblk == 1)
331 {
332 b1 = 1;
333 }
334 else
335 {
336 b1 = isplit[nblk - 1] + 1;
337 }
338 bn = isplit[nblk];
339 blksiz = bn - b1 + 1;
340 if (blksiz == 1)
341 {
342 goto L60;
343 }
344 gpind = b1;
345 /* Compute reorthogonalization criterion and stopping criterion. */
346 onenrm = (r__1 = d__[b1], f2c_abs(r__1)) + (r__2 = e[b1], f2c_abs(r__2));
347 /* Computing MAX */
348 r__3 = onenrm;
349 r__4 = (r__1 = d__[bn], f2c_abs(r__1)) + (r__2 = e[bn - 1], f2c_abs(r__2)); // , expr subst
350 onenrm = max(r__3,r__4);
351 i__2 = bn - 1;
352 for (i__ = b1 + 1;
353 i__ <= i__2;
354 ++i__)
355 {
356 /* Computing MAX */
357 r__4 = onenrm;
358 r__5 = (r__1 = d__[i__], f2c_abs(r__1)) + (r__2 = e[ i__ - 1], f2c_abs(r__2)) + (r__3 = e[i__], f2c_abs(r__3)); // , expr subst
359 onenrm = max(r__4,r__5);
360 /* L50: */
361 }
362 ortol = onenrm * .001f;
363 stpcrt = sqrt(.1f / blksiz);
364 /* Loop through eigenvalues of block nblk. */
365 L60:
366 jblk = 0;
367 i__2 = *m;
368 for (j = j1;
369 j <= i__2;
370 ++j)
371 {
372 if (iblock[j] != nblk)
373 {
374 j1 = j;
375 goto L180;
376 }
377 ++jblk;
378 xj = w[j];
379 /* Skip all the work if the block size is one. */
380 if (blksiz == 1)
381 {
382 work[indrv1 + 1] = 1.f;
383 goto L140;
384 }
385 /* If eigenvalues j and j-1 are too close, add a relatively */
386 /* small perturbation. */
387 if (jblk > 1)
388 {
389 eps1 = (r__1 = eps * xj, f2c_abs(r__1));
390 pertol = eps1 * 10.f;
391 sep = xj - xjm;
392 if (sep < pertol)
393 {
394 xj = xjm + pertol;
395 }
396 }
397 its = 0;
398 nrmchk = 0;
399 /* Get random starting vector. */
400 slarnv_(&c__2, iseed, &blksiz, &work[indrv1 + 1]);
401 /* Copy the matrix T so it won't be destroyed in factorization. */
402 scopy_(&blksiz, &d__[b1], &c__1, &work[indrv4 + 1], &c__1);
403 i__3 = blksiz - 1;
404 scopy_(&i__3, &e[b1], &c__1, &work[indrv2 + 2], &c__1);
405 i__3 = blksiz - 1;
406 scopy_(&i__3, &e[b1], &c__1, &work[indrv3 + 1], &c__1);
407 /* Compute LU factors with partial pivoting ( PT = LU ) */
408 tol = 0.f;
409 slagtf_(&blksiz, &work[indrv4 + 1], &xj, &work[indrv2 + 2], &work[ indrv3 + 1], &tol, &work[indrv5 + 1], &iwork[1], &iinfo);
410 /* Update iteration count. */
411 L70:
412 ++its;
413 if (its > 5)
414 {
415 goto L120;
416 }
417 /* Normalize and scale the righthand side vector Pb. */
418 /* Computing MAX */
419 r__2 = eps;
420 r__3 = (r__1 = work[indrv4 + blksiz], f2c_abs(r__1)); // , expr subst
421 scl = blksiz * onenrm * max(r__2,r__3) / sasum_(&blksiz, &work[ indrv1 + 1], &c__1);
422 sscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1);
423 /* Solve the system LU = Pb. */
424 slagts_(&c_n1, &blksiz, &work[indrv4 + 1], &work[indrv2 + 2], & work[indrv3 + 1], &work[indrv5 + 1], &iwork[1], &work[ indrv1 + 1], &tol, &iinfo);
425 /* Reorthogonalize by modified Gram-Schmidt if eigenvalues are */
426 /* close enough. */
427 if (jblk == 1)
428 {
429 goto L110;
430 }
431 if ((r__1 = xj - xjm, f2c_abs(r__1)) > ortol)
432 {
433 gpind = j;
434 }
435 if (gpind != j)
436 {
437 i__3 = j - 1;
438 for (i__ = gpind;
439 i__ <= i__3;
440 ++i__)
441 {
442 ctr = 0.f;
443 i__4 = blksiz;
444 for (jr = 1;
445 jr <= i__4;
446 ++jr)
447 {
448 i__5 = b1 - 1 + jr + i__ * z_dim1;
449 ctr += work[indrv1 + jr] * z__[i__5].r;
450 /* L80: */
451 }
452 i__4 = blksiz;
453 for (jr = 1;
454 jr <= i__4;
455 ++jr)
456 {
457 i__5 = b1 - 1 + jr + i__ * z_dim1;
458 work[indrv1 + jr] -= ctr * z__[i__5].r;
459 /* L90: */
460 }
461 /* L100: */
462 }
463 }
464 /* Check the infinity norm of the iterate. */
465 L110:
466 jmax = isamax_(&blksiz, &work[indrv1 + 1], &c__1);
467 nrm = (r__1 = work[indrv1 + jmax], f2c_abs(r__1));
468 /* Continue for additional iterations after norm reaches */
469 /* stopping criterion. */
470 if (nrm < stpcrt)
471 {
472 goto L70;
473 }
474 ++nrmchk;
475 if (nrmchk < 3)
476 {
477 goto L70;
478 }
479 goto L130;
480 /* If stopping criterion was not satisfied, update info and */
481 /* store eigenvector number in array ifail. */
482 L120:
483 ++(*info);
484 ifail[*info] = j;
485 /* Accept iterate as jth eigenvector. */
486 L130:
487 scl = 1.f / snrm2_(&blksiz, &work[indrv1 + 1], &c__1);
488 jmax = isamax_(&blksiz, &work[indrv1 + 1], &c__1);
489 if (work[indrv1 + jmax] < 0.f)
490 {
491 scl = -scl;
492 }
493 sscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1);
494 L140:
495 i__3 = *n;
496 for (i__ = 1;
497 i__ <= i__3;
498 ++i__)
499 {
500 i__4 = i__ + j * z_dim1;
501 z__[i__4].r = 0.f;
502 z__[i__4].i = 0.f; // , expr subst
503 /* L150: */
504 }
505 i__3 = blksiz;
506 for (i__ = 1;
507 i__ <= i__3;
508 ++i__)
509 {
510 i__4 = b1 + i__ - 1 + j * z_dim1;
511 i__5 = indrv1 + i__;
512 q__1.r = work[i__5];
513 q__1.i = 0.f; // , expr subst
514 z__[i__4].r = q__1.r;
515 z__[i__4].i = q__1.i; // , expr subst
516 /* L160: */
517 }
518 /* Save the shift to check eigenvalue spacing at next */
519 /* iteration. */
520 xjm = xj;
521 /* L170: */
522 }
523 L180:
524 ;
525 }
526 return 0;
527 /* End of CSTEIN */
528 }
529 /* cstein_ */
530