LAPACK  3.7.1
LAPACK: Linear Algebra PACKage
clarrv.f
Go to the documentation of this file.
1 *> \brief \b CLARRV computes the eigenvectors of the tridiagonal matrix T = L D LT given L, D and the eigenvalues of L D LT.
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 *> \htmlonly
9 *> Download CLARRV + dependencies
10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/clarrv.f">
11 *> [TGZ]</a>
12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/clarrv.f">
13 *> [ZIP]</a>
14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/clarrv.f">
15 *> [TXT]</a>
16 *> \endhtmlonly
17 *
18 * Definition:
19 * ===========
20 *
21 * SUBROUTINE CLARRV( N, VL, VU, D, L, PIVMIN,
22 * ISPLIT, M, DOL, DOU, MINRGP,
23 * RTOL1, RTOL2, W, WERR, WGAP,
24 * IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ,
25 * WORK, IWORK, INFO )
26 *
27 * .. Scalar Arguments ..
28 * INTEGER DOL, DOU, INFO, LDZ, M, N
29 * REAL MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU
30 * ..
31 * .. Array Arguments ..
32 * INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ),
33 * $ ISUPPZ( * ), IWORK( * )
34 * REAL D( * ), GERS( * ), L( * ), W( * ), WERR( * ),
35 * $ WGAP( * ), WORK( * )
36 * COMPLEX Z( LDZ, * )
37 * ..
38 *
39 *
40 *> \par Purpose:
41 * =============
42 *>
43 *> \verbatim
44 *>
45 *> CLARRV computes the eigenvectors of the tridiagonal matrix
46 *> T = L D L**T given L, D and APPROXIMATIONS to the eigenvalues of L D L**T.
47 *> The input eigenvalues should have been computed by SLARRE.
48 *> \endverbatim
49 *
50 * Arguments:
51 * ==========
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] VL
60 *> \verbatim
61 *> VL is REAL
62 *> Lower bound of the interval that contains the desired
63 *> eigenvalues. VL < VU. Needed to compute gaps on the left or right
64 *> end of the extremal eigenvalues in the desired RANGE.
65 *> \endverbatim
66 *>
67 *> \param[in] VU
68 *> \verbatim
69 *> VU is REAL
70 *> Upper bound of the interval that contains the desired
71 *> eigenvalues. VL < VU. Needed to compute gaps on the left or right
72 *> end of the extremal eigenvalues in the desired RANGE.
73 *> \endverbatim
74 *>
75 *> \param[in,out] D
76 *> \verbatim
77 *> D is REAL array, dimension (N)
78 *> On entry, the N diagonal elements of the diagonal matrix D.
79 *> On exit, D may be overwritten.
80 *> \endverbatim
81 *>
82 *> \param[in,out] L
83 *> \verbatim
84 *> L is REAL array, dimension (N)
85 *> On entry, the (N-1) subdiagonal elements of the unit
86 *> bidiagonal matrix L are in elements 1 to N-1 of L
87 *> (if the matrix is not split.) At the end of each block
88 *> is stored the corresponding shift as given by SLARRE.
89 *> On exit, L is overwritten.
90 *> \endverbatim
91 *>
92 *> \param[in] PIVMIN
93 *> \verbatim
94 *> PIVMIN is REAL
95 *> The minimum pivot allowed in the Sturm sequence.
96 *> \endverbatim
97 *>
98 *> \param[in] ISPLIT
99 *> \verbatim
100 *> ISPLIT is INTEGER array, dimension (N)
101 *> The splitting points, at which T breaks up into blocks.
102 *> The first block consists of rows/columns 1 to
103 *> ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
104 *> through ISPLIT( 2 ), etc.
105 *> \endverbatim
106 *>
107 *> \param[in] M
108 *> \verbatim
109 *> M is INTEGER
110 *> The total number of input eigenvalues. 0 <= M <= N.
111 *> \endverbatim
112 *>
113 *> \param[in] DOL
114 *> \verbatim
115 *> DOL is INTEGER
116 *> \endverbatim
117 *>
118 *> \param[in] DOU
119 *> \verbatim
120 *> DOU is INTEGER
121 *> If the user wants to compute only selected eigenvectors from all
122 *> the eigenvalues supplied, he can specify an index range DOL:DOU.
123 *> Or else the setting DOL=1, DOU=M should be applied.
124 *> Note that DOL and DOU refer to the order in which the eigenvalues
125 *> are stored in W.
126 *> If the user wants to compute only selected eigenpairs, then
127 *> the columns DOL-1 to DOU+1 of the eigenvector space Z contain the
128 *> computed eigenvectors. All other columns of Z are set to zero.
129 *> \endverbatim
130 *>
131 *> \param[in] MINRGP
132 *> \verbatim
133 *> MINRGP is REAL
134 *> \endverbatim
135 *>
136 *> \param[in] RTOL1
137 *> \verbatim
138 *> RTOL1 is REAL
139 *> \endverbatim
140 *>
141 *> \param[in] RTOL2
142 *> \verbatim
143 *> RTOL2 is REAL
144 *> Parameters for bisection.
145 *> An interval [LEFT,RIGHT] has converged if
146 *> RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
147 *> \endverbatim
148 *>
149 *> \param[in,out] W
150 *> \verbatim
151 *> W is REAL array, dimension (N)
152 *> The first M elements of W contain the APPROXIMATE eigenvalues for
153 *> which eigenvectors are to be computed. The eigenvalues
154 *> should be grouped by split-off block and ordered from
155 *> smallest to largest within the block ( The output array
156 *> W from SLARRE is expected here ). Furthermore, they are with
157 *> respect to the shift of the corresponding root representation
158 *> for their block. On exit, W holds the eigenvalues of the
159 *> UNshifted matrix.
160 *> \endverbatim
161 *>
162 *> \param[in,out] WERR
163 *> \verbatim
164 *> WERR is REAL array, dimension (N)
165 *> The first M elements contain the semiwidth of the uncertainty
166 *> interval of the corresponding eigenvalue in W
167 *> \endverbatim
168 *>
169 *> \param[in,out] WGAP
170 *> \verbatim
171 *> WGAP is REAL array, dimension (N)
172 *> The separation from the right neighbor eigenvalue in W.
173 *> \endverbatim
174 *>
175 *> \param[in] IBLOCK
176 *> \verbatim
177 *> IBLOCK is INTEGER array, dimension (N)
178 *> The indices of the blocks (submatrices) associated with the
179 *> corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
180 *> W(i) belongs to the first block from the top, =2 if W(i)
181 *> belongs to the second block, etc.
182 *> \endverbatim
183 *>
184 *> \param[in] INDEXW
185 *> \verbatim
186 *> INDEXW is INTEGER array, dimension (N)
187 *> The indices of the eigenvalues within each block (submatrix);
188 *> for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
189 *> i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.
190 *> \endverbatim
191 *>
192 *> \param[in] GERS
193 *> \verbatim
194 *> GERS is REAL array, dimension (2*N)
195 *> The N Gerschgorin intervals (the i-th Gerschgorin interval
196 *> is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should
197 *> be computed from the original UNshifted matrix.
198 *> \endverbatim
199 *>
200 *> \param[out] Z
201 *> \verbatim
202 *> Z is COMPLEX array, dimension (LDZ, max(1,M) )
203 *> If INFO = 0, the first M columns of Z contain the
204 *> orthonormal eigenvectors of the matrix T
205 *> corresponding to the input eigenvalues, with the i-th
206 *> column of Z holding the eigenvector associated with W(i).
207 *> Note: the user must ensure that at least max(1,M) columns are
208 *> supplied in the array Z.
209 *> \endverbatim
210 *>
211 *> \param[in] LDZ
212 *> \verbatim
213 *> LDZ is INTEGER
214 *> The leading dimension of the array Z. LDZ >= 1, and if
215 *> JOBZ = 'V', LDZ >= max(1,N).
216 *> \endverbatim
217 *>
218 *> \param[out] ISUPPZ
219 *> \verbatim
220 *> ISUPPZ is INTEGER array, dimension ( 2*max(1,M) )
221 *> The support of the eigenvectors in Z, i.e., the indices
222 *> indicating the nonzero elements in Z. The I-th eigenvector
223 *> is nonzero only in elements ISUPPZ( 2*I-1 ) through
224 *> ISUPPZ( 2*I ).
225 *> \endverbatim
226 *>
227 *> \param[out] WORK
228 *> \verbatim
229 *> WORK is REAL array, dimension (12*N)
230 *> \endverbatim
231 *>
232 *> \param[out] IWORK
233 *> \verbatim
234 *> IWORK is INTEGER array, dimension (7*N)
235 *> \endverbatim
236 *>
237 *> \param[out] INFO
238 *> \verbatim
239 *> INFO is INTEGER
240 *> = 0: successful exit
241 *>
242 *> > 0: A problem occurred in CLARRV.
243 *> < 0: One of the called subroutines signaled an internal problem.
244 *> Needs inspection of the corresponding parameter IINFO
245 *> for further information.
246 *>
247 *> =-1: Problem in SLARRB when refining a child's eigenvalues.
248 *> =-2: Problem in SLARRF when computing the RRR of a child.
249 *> When a child is inside a tight cluster, it can be difficult
250 *> to find an RRR. A partial remedy from the user's point of
251 *> view is to make the parameter MINRGP smaller and recompile.
252 *> However, as the orthogonality of the computed vectors is
253 *> proportional to 1/MINRGP, the user should be aware that
254 *> he might be trading in precision when he decreases MINRGP.
255 *> =-3: Problem in SLARRB when refining a single eigenvalue
256 *> after the Rayleigh correction was rejected.
257 *> = 5: The Rayleigh Quotient Iteration failed to converge to
258 *> full accuracy in MAXITR steps.
259 *> \endverbatim
260 *
261 * Authors:
262 * ========
263 *
264 *> \author Univ. of Tennessee
265 *> \author Univ. of California Berkeley
266 *> \author Univ. of Colorado Denver
267 *> \author NAG Ltd.
268 *
269 *> \date June 2016
270 *
271 *> \ingroup complexOTHERauxiliary
272 *
273 *> \par Contributors:
274 * ==================
275 *>
276 *> Beresford Parlett, University of California, Berkeley, USA \n
277 *> Jim Demmel, University of California, Berkeley, USA \n
278 *> Inderjit Dhillon, University of Texas, Austin, USA \n
279 *> Osni Marques, LBNL/NERSC, USA \n
280 *> Christof Voemel, University of California, Berkeley, USA
281 *
282 * =====================================================================
283  SUBROUTINE clarrv( N, VL, VU, D, L, PIVMIN,
284  $ ISPLIT, M, DOL, DOU, MINRGP,
285  $ RTOL1, RTOL2, W, WERR, WGAP,
286  $ IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ,
287  $ WORK, IWORK, INFO )
288 *
289 * -- LAPACK auxiliary routine (version 3.7.1) --
290 * -- LAPACK is a software package provided by Univ. of Tennessee, --
291 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
292 * June 2016
293 *
294 * .. Scalar Arguments ..
295  INTEGER DOL, DOU, INFO, LDZ, M, N
296  REAL MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU
297 * ..
298 * .. Array Arguments ..
299  INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ),
300  $ isuppz( * ), iwork( * )
301  REAL D( * ), GERS( * ), L( * ), W( * ), WERR( * ),
302  $ wgap( * ), work( * )
303  COMPLEX Z( ldz, * )
304 * ..
305 *
306 * =====================================================================
307 *
308 * .. Parameters ..
309  INTEGER MAXITR
310  parameter( maxitr = 10 )
311  COMPLEX CZERO
312  parameter( czero = ( 0.0e0, 0.0e0 ) )
313  REAL ZERO, ONE, TWO, THREE, FOUR, HALF
314  parameter( zero = 0.0e0, one = 1.0e0,
315  $ two = 2.0e0, three = 3.0e0,
316  $ four = 4.0e0, half = 0.5e0)
317 * ..
318 * .. Local Scalars ..
319  LOGICAL ESKIP, NEEDBS, STP2II, TRYRQC, USEDBS, USEDRQ
320  INTEGER DONE, I, IBEGIN, IDONE, IEND, II, IINDC1,
321  $ iindc2, iindr, iindwk, iinfo, im, in, indeig,
322  $ indld, indlld, indwrk, isupmn, isupmx, iter,
323  $ itmp1, j, jblk, k, miniwsize, minwsize, nclus,
324  $ ndepth, negcnt, newcls, newfst, newftt, newlst,
325  $ newsiz, offset, oldcls, oldfst, oldien, oldlst,
326  $ oldncl, p, parity, q, wbegin, wend, windex,
327  $ windmn, windpl, zfrom, zto, zusedl, zusedu,
328  $ zusedw
329  INTEGER INDIN1, INDIN2
330  REAL BSTRES, BSTW, EPS, FUDGE, GAP, GAPTOL, GL, GU,
331  $ lambda, left, lgap, mingma, nrminv, resid,
332  $ rgap, right, rqcorr, rqtol, savgap, sgndef,
333  $ sigma, spdiam, ssigma, tau, tmp, tol, ztz
334 * ..
335 * .. External Functions ..
336  REAL SLAMCH
337  EXTERNAL slamch
338 * ..
339 * .. External Subroutines ..
340  EXTERNAL clar1v, claset, csscal, scopy, slarrb,
341  $ slarrf
342 * ..
343 * .. Intrinsic Functions ..
344  INTRINSIC abs, REAL, MAX, MIN
345  INTRINSIC cmplx
346 * ..
347 * .. Executable Statements ..
348 * ..
349 
350  info = 0
351 *
352 * Quick return if possible
353 *
354  IF( n.LE.0 ) THEN
355  RETURN
356  END IF
357 *
358 * The first N entries of WORK are reserved for the eigenvalues
359  indld = n+1
360  indlld= 2*n+1
361  indin1 = 3*n + 1
362  indin2 = 4*n + 1
363  indwrk = 5*n + 1
364  minwsize = 12 * n
365 
366  DO 5 i= 1,minwsize
367  work( i ) = zero
368  5 CONTINUE
369 
370 * IWORK(IINDR+1:IINDR+N) hold the twist indices R for the
371 * factorization used to compute the FP vector
372  iindr = 0
373 * IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current
374 * layer and the one above.
375  iindc1 = n
376  iindc2 = 2*n
377  iindwk = 3*n + 1
378 
379  miniwsize = 7 * n
380  DO 10 i= 1,miniwsize
381  iwork( i ) = 0
382  10 CONTINUE
383 
384  zusedl = 1
385  IF(dol.GT.1) THEN
386 * Set lower bound for use of Z
387  zusedl = dol-1
388  ENDIF
389  zusedu = m
390  IF(dou.LT.m) THEN
391 * Set lower bound for use of Z
392  zusedu = dou+1
393  ENDIF
394 * The width of the part of Z that is used
395  zusedw = zusedu - zusedl + 1
396 
397 
398  CALL claset( 'Full', n, zusedw, czero, czero,
399  $ z(1,zusedl), ldz )
400 
401  eps = slamch( 'Precision' )
402  rqtol = two * eps
403 *
404 * Set expert flags for standard code.
405  tryrqc = .true.
406 
407  IF((dol.EQ.1).AND.(dou.EQ.m)) THEN
408  ELSE
409 * Only selected eigenpairs are computed. Since the other evalues
410 * are not refined by RQ iteration, bisection has to compute to full
411 * accuracy.
412  rtol1 = four * eps
413  rtol2 = four * eps
414  ENDIF
415 
416 * The entries WBEGIN:WEND in W, WERR, WGAP correspond to the
417 * desired eigenvalues. The support of the nonzero eigenvector
418 * entries is contained in the interval IBEGIN:IEND.
419 * Remark that if k eigenpairs are desired, then the eigenvectors
420 * are stored in k contiguous columns of Z.
421 
422 * DONE is the number of eigenvectors already computed
423  done = 0
424  ibegin = 1
425  wbegin = 1
426  DO 170 jblk = 1, iblock( m )
427  iend = isplit( jblk )
428  sigma = l( iend )
429 * Find the eigenvectors of the submatrix indexed IBEGIN
430 * through IEND.
431  wend = wbegin - 1
432  15 CONTINUE
433  IF( wend.LT.m ) THEN
434  IF( iblock( wend+1 ).EQ.jblk ) THEN
435  wend = wend + 1
436  GO TO 15
437  END IF
438  END IF
439  IF( wend.LT.wbegin ) THEN
440  ibegin = iend + 1
441  GO TO 170
442  ELSEIF( (wend.LT.dol).OR.(wbegin.GT.dou) ) THEN
443  ibegin = iend + 1
444  wbegin = wend + 1
445  GO TO 170
446  END IF
447 
448 * Find local spectral diameter of the block
449  gl = gers( 2*ibegin-1 )
450  gu = gers( 2*ibegin )
451  DO 20 i = ibegin+1 , iend
452  gl = min( gers( 2*i-1 ), gl )
453  gu = max( gers( 2*i ), gu )
454  20 CONTINUE
455  spdiam = gu - gl
456 
457 * OLDIEN is the last index of the previous block
458  oldien = ibegin - 1
459 * Calculate the size of the current block
460  in = iend - ibegin + 1
461 * The number of eigenvalues in the current block
462  im = wend - wbegin + 1
463 
464 * This is for a 1x1 block
465  IF( ibegin.EQ.iend ) THEN
466  done = done+1
467  z( ibegin, wbegin ) = cmplx( one, zero )
468  isuppz( 2*wbegin-1 ) = ibegin
469  isuppz( 2*wbegin ) = ibegin
470  w( wbegin ) = w( wbegin ) + sigma
471  work( wbegin ) = w( wbegin )
472  ibegin = iend + 1
473  wbegin = wbegin + 1
474  GO TO 170
475  END IF
476 
477 * The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND)
478 * Note that these can be approximations, in this case, the corresp.
479 * entries of WERR give the size of the uncertainty interval.
480 * The eigenvalue approximations will be refined when necessary as
481 * high relative accuracy is required for the computation of the
482 * corresponding eigenvectors.
483  CALL scopy( im, w( wbegin ), 1,
484  $ work( wbegin ), 1 )
485 
486 * We store in W the eigenvalue approximations w.r.t. the original
487 * matrix T.
488  DO 30 i=1,im
489  w(wbegin+i-1) = w(wbegin+i-1)+sigma
490  30 CONTINUE
491 
492 
493 * NDEPTH is the current depth of the representation tree
494  ndepth = 0
495 * PARITY is either 1 or 0
496  parity = 1
497 * NCLUS is the number of clusters for the next level of the
498 * representation tree, we start with NCLUS = 1 for the root
499  nclus = 1
500  iwork( iindc1+1 ) = 1
501  iwork( iindc1+2 ) = im
502 
503 * IDONE is the number of eigenvectors already computed in the current
504 * block
505  idone = 0
506 * loop while( IDONE.LT.IM )
507 * generate the representation tree for the current block and
508 * compute the eigenvectors
509  40 CONTINUE
510  IF( idone.LT.im ) THEN
511 * This is a crude protection against infinitely deep trees
512  IF( ndepth.GT.m ) THEN
513  info = -2
514  RETURN
515  ENDIF
516 * breadth first processing of the current level of the representation
517 * tree: OLDNCL = number of clusters on current level
518  oldncl = nclus
519 * reset NCLUS to count the number of child clusters
520  nclus = 0
521 *
522  parity = 1 - parity
523  IF( parity.EQ.0 ) THEN
524  oldcls = iindc1
525  newcls = iindc2
526  ELSE
527  oldcls = iindc2
528  newcls = iindc1
529  END IF
530 * Process the clusters on the current level
531  DO 150 i = 1, oldncl
532  j = oldcls + 2*i
533 * OLDFST, OLDLST = first, last index of current cluster.
534 * cluster indices start with 1 and are relative
535 * to WBEGIN when accessing W, WGAP, WERR, Z
536  oldfst = iwork( j-1 )
537  oldlst = iwork( j )
538  IF( ndepth.GT.0 ) THEN
539 * Retrieve relatively robust representation (RRR) of cluster
540 * that has been computed at the previous level
541 * The RRR is stored in Z and overwritten once the eigenvectors
542 * have been computed or when the cluster is refined
543 
544  IF((dol.EQ.1).AND.(dou.EQ.m)) THEN
545 * Get representation from location of the leftmost evalue
546 * of the cluster
547  j = wbegin + oldfst - 1
548  ELSE
549  IF(wbegin+oldfst-1.LT.dol) THEN
550 * Get representation from the left end of Z array
551  j = dol - 1
552  ELSEIF(wbegin+oldfst-1.GT.dou) THEN
553 * Get representation from the right end of Z array
554  j = dou
555  ELSE
556  j = wbegin + oldfst - 1
557  ENDIF
558  ENDIF
559  DO 45 k = 1, in - 1
560  d( ibegin+k-1 ) = REAL( Z( IBEGIN+K-1, $ J ) )
561  l( ibegin+k-1 ) = REAL( Z( IBEGIN+K-1, $ J+1 ) )
562  45 CONTINUE
563  d( iend ) = REAL( Z( IEND, J ) )
564  sigma = REAL( Z( IEND, J+1 ) )
565 
566 * Set the corresponding entries in Z to zero
567  CALL claset( 'Full', in, 2, czero, czero,
568  $ z( ibegin, j), ldz )
569  END IF
570 
571 * Compute DL and DLL of current RRR
572  DO 50 j = ibegin, iend-1
573  tmp = d( j )*l( j )
574  work( indld-1+j ) = tmp
575  work( indlld-1+j ) = tmp*l( j )
576  50 CONTINUE
577 
578  IF( ndepth.GT.0 ) THEN
579 * P and Q are index of the first and last eigenvalue to compute
580 * within the current block
581  p = indexw( wbegin-1+oldfst )
582  q = indexw( wbegin-1+oldlst )
583 * Offset for the arrays WORK, WGAP and WERR, i.e., the P-OFFSET
584 * through the Q-OFFSET elements of these arrays are to be used.
585 * OFFSET = P-OLDFST
586  offset = indexw( wbegin ) - 1
587 * perform limited bisection (if necessary) to get approximate
588 * eigenvalues to the precision needed.
589  CALL slarrb( in, d( ibegin ),
590  $ work(indlld+ibegin-1),
591  $ p, q, rtol1, rtol2, offset,
592  $ work(wbegin),wgap(wbegin),werr(wbegin),
593  $ work( indwrk ), iwork( iindwk ),
594  $ pivmin, spdiam, in, iinfo )
595  IF( iinfo.NE.0 ) THEN
596  info = -1
597  RETURN
598  ENDIF
599 * We also recompute the extremal gaps. W holds all eigenvalues
600 * of the unshifted matrix and must be used for computation
601 * of WGAP, the entries of WORK might stem from RRRs with
602 * different shifts. The gaps from WBEGIN-1+OLDFST to
603 * WBEGIN-1+OLDLST are correctly computed in SLARRB.
604 * However, we only allow the gaps to become greater since
605 * this is what should happen when we decrease WERR
606  IF( oldfst.GT.1) THEN
607  wgap( wbegin+oldfst-2 ) =
608  $ max(wgap(wbegin+oldfst-2),
609  $ w(wbegin+oldfst-1)-werr(wbegin+oldfst-1)
610  $ - w(wbegin+oldfst-2)-werr(wbegin+oldfst-2) )
611  ENDIF
612  IF( wbegin + oldlst -1 .LT. wend ) THEN
613  wgap( wbegin+oldlst-1 ) =
614  $ max(wgap(wbegin+oldlst-1),
615  $ w(wbegin+oldlst)-werr(wbegin+oldlst)
616  $ - w(wbegin+oldlst-1)-werr(wbegin+oldlst-1) )
617  ENDIF
618 * Each time the eigenvalues in WORK get refined, we store
619 * the newly found approximation with all shifts applied in W
620  DO 53 j=oldfst,oldlst
621  w(wbegin+j-1) = work(wbegin+j-1)+sigma
622  53 CONTINUE
623  END IF
624 
625 * Process the current node.
626  newfst = oldfst
627  DO 140 j = oldfst, oldlst
628  IF( j.EQ.oldlst ) THEN
629 * we are at the right end of the cluster, this is also the
630 * boundary of the child cluster
631  newlst = j
632  ELSE IF ( wgap( wbegin + j -1).GE.
633  $ minrgp* abs( work(wbegin + j -1) ) ) THEN
634 * the right relative gap is big enough, the child cluster
635 * (NEWFST,..,NEWLST) is well separated from the following
636  newlst = j
637  ELSE
638 * inside a child cluster, the relative gap is not
639 * big enough.
640  GOTO 140
641  END IF
642 
643 * Compute size of child cluster found
644  newsiz = newlst - newfst + 1
645 
646 * NEWFTT is the place in Z where the new RRR or the computed
647 * eigenvector is to be stored
648  IF((dol.EQ.1).AND.(dou.EQ.m)) THEN
649 * Store representation at location of the leftmost evalue
650 * of the cluster
651  newftt = wbegin + newfst - 1
652  ELSE
653  IF(wbegin+newfst-1.LT.dol) THEN
654 * Store representation at the left end of Z array
655  newftt = dol - 1
656  ELSEIF(wbegin+newfst-1.GT.dou) THEN
657 * Store representation at the right end of Z array
658  newftt = dou
659  ELSE
660  newftt = wbegin + newfst - 1
661  ENDIF
662  ENDIF
663 
664  IF( newsiz.GT.1) THEN
665 *
666 * Current child is not a singleton but a cluster.
667 * Compute and store new representation of child.
668 *
669 *
670 * Compute left and right cluster gap.
671 *
672 * LGAP and RGAP are not computed from WORK because
673 * the eigenvalue approximations may stem from RRRs
674 * different shifts. However, W hold all eigenvalues
675 * of the unshifted matrix. Still, the entries in WGAP
676 * have to be computed from WORK since the entries
677 * in W might be of the same order so that gaps are not
678 * exhibited correctly for very close eigenvalues.
679  IF( newfst.EQ.1 ) THEN
680  lgap = max( zero,
681  $ w(wbegin)-werr(wbegin) - vl )
682  ELSE
683  lgap = wgap( wbegin+newfst-2 )
684  ENDIF
685  rgap = wgap( wbegin+newlst-1 )
686 *
687 * Compute left- and rightmost eigenvalue of child
688 * to high precision in order to shift as close
689 * as possible and obtain as large relative gaps
690 * as possible
691 *
692  DO 55 k =1,2
693  IF(k.EQ.1) THEN
694  p = indexw( wbegin-1+newfst )
695  ELSE
696  p = indexw( wbegin-1+newlst )
697  ENDIF
698  offset = indexw( wbegin ) - 1
699  CALL slarrb( in, d(ibegin),
700  $ work( indlld+ibegin-1 ),p,p,
701  $ rqtol, rqtol, offset,
702  $ work(wbegin),wgap(wbegin),
703  $ werr(wbegin),work( indwrk ),
704  $ iwork( iindwk ), pivmin, spdiam,
705  $ in, iinfo )
706  55 CONTINUE
707 *
708  IF((wbegin+newlst-1.LT.dol).OR.
709  $ (wbegin+newfst-1.GT.dou)) THEN
710 * if the cluster contains no desired eigenvalues
711 * skip the computation of that branch of the rep. tree
712 *
713 * We could skip before the refinement of the extremal
714 * eigenvalues of the child, but then the representation
715 * tree could be different from the one when nothing is
716 * skipped. For this reason we skip at this place.
717  idone = idone + newlst - newfst + 1
718  GOTO 139
719  ENDIF
720 *
721 * Compute RRR of child cluster.
722 * Note that the new RRR is stored in Z
723 *
724 * SLARRF needs LWORK = 2*N
725  CALL slarrf( in, d( ibegin ), l( ibegin ),
726  $ work(indld+ibegin-1),
727  $ newfst, newlst, work(wbegin),
728  $ wgap(wbegin), werr(wbegin),
729  $ spdiam, lgap, rgap, pivmin, tau,
730  $ work( indin1 ), work( indin2 ),
731  $ work( indwrk ), iinfo )
732 * In the complex case, SLARRF cannot write
733 * the new RRR directly into Z and needs an intermediate
734 * workspace
735  DO 56 k = 1, in-1
736  z( ibegin+k-1, newftt ) =
737  $ cmplx( work( indin1+k-1 ), zero )
738  z( ibegin+k-1, newftt+1 ) =
739  $ cmplx( work( indin2+k-1 ), zero )
740  56 CONTINUE
741  z( iend, newftt ) =
742  $ cmplx( work( indin1+in-1 ), zero )
743  IF( iinfo.EQ.0 ) THEN
744 * a new RRR for the cluster was found by SLARRF
745 * update shift and store it
746  ssigma = sigma + tau
747  z( iend, newftt+1 ) = cmplx( ssigma, zero )
748 * WORK() are the midpoints and WERR() the semi-width
749 * Note that the entries in W are unchanged.
750  DO 116 k = newfst, newlst
751  fudge =
752  $ three*eps*abs(work(wbegin+k-1))
753  work( wbegin + k - 1 ) =
754  $ work( wbegin + k - 1) - tau
755  fudge = fudge +
756  $ four*eps*abs(work(wbegin+k-1))
757 * Fudge errors
758  werr( wbegin + k - 1 ) =
759  $ werr( wbegin + k - 1 ) + fudge
760 * Gaps are not fudged. Provided that WERR is small
761 * when eigenvalues are close, a zero gap indicates
762 * that a new representation is needed for resolving
763 * the cluster. A fudge could lead to a wrong decision
764 * of judging eigenvalues 'separated' which in
765 * reality are not. This could have a negative impact
766 * on the orthogonality of the computed eigenvectors.
767  116 CONTINUE
768 
769  nclus = nclus + 1
770  k = newcls + 2*nclus
771  iwork( k-1 ) = newfst
772  iwork( k ) = newlst
773  ELSE
774  info = -2
775  RETURN
776  ENDIF
777  ELSE
778 *
779 * Compute eigenvector of singleton
780 *
781  iter = 0
782 *
783  tol = four * log(REAL(in)) * eps
784 *
785  k = newfst
786  windex = wbegin + k - 1
787  windmn = max(windex - 1,1)
788  windpl = min(windex + 1,m)
789  lambda = work( windex )
790  done = done + 1
791 * Check if eigenvector computation is to be skipped
792  IF((windex.LT.dol).OR.
793  $ (windex.GT.dou)) THEN
794  eskip = .true.
795  GOTO 125
796  ELSE
797  eskip = .false.
798  ENDIF
799  left = work( windex ) - werr( windex )
800  right = work( windex ) + werr( windex )
801  indeig = indexw( windex )
802 * Note that since we compute the eigenpairs for a child,
803 * all eigenvalue approximations are w.r.t the same shift.
804 * In this case, the entries in WORK should be used for
805 * computing the gaps since they exhibit even very small
806 * differences in the eigenvalues, as opposed to the
807 * entries in W which might "look" the same.
808 
809  IF( k .EQ. 1) THEN
810 * In the case RANGE='I' and with not much initial
811 * accuracy in LAMBDA and VL, the formula
812 * LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA )
813 * can lead to an overestimation of the left gap and
814 * thus to inadequately early RQI 'convergence'.
815 * Prevent this by forcing a small left gap.
816  lgap = eps*max(abs(left),abs(right))
817  ELSE
818  lgap = wgap(windmn)
819  ENDIF
820  IF( k .EQ. im) THEN
821 * In the case RANGE='I' and with not much initial
822 * accuracy in LAMBDA and VU, the formula
823 * can lead to an overestimation of the right gap and
824 * thus to inadequately early RQI 'convergence'.
825 * Prevent this by forcing a small right gap.
826  rgap = eps*max(abs(left),abs(right))
827  ELSE
828  rgap = wgap(windex)
829  ENDIF
830  gap = min( lgap, rgap )
831  IF(( k .EQ. 1).OR.(k .EQ. im)) THEN
832 * The eigenvector support can become wrong
833 * because significant entries could be cut off due to a
834 * large GAPTOL parameter in LAR1V. Prevent this.
835  gaptol = zero
836  ELSE
837  gaptol = gap * eps
838  ENDIF
839  isupmn = in
840  isupmx = 1
841 * Update WGAP so that it holds the minimum gap
842 * to the left or the right. This is crucial in the
843 * case where bisection is used to ensure that the
844 * eigenvalue is refined up to the required precision.
845 * The correct value is restored afterwards.
846  savgap = wgap(windex)
847  wgap(windex) = gap
848 * We want to use the Rayleigh Quotient Correction
849 * as often as possible since it converges quadratically
850 * when we are close enough to the desired eigenvalue.
851 * However, the Rayleigh Quotient can have the wrong sign
852 * and lead us away from the desired eigenvalue. In this
853 * case, the best we can do is to use bisection.
854  usedbs = .false.
855  usedrq = .false.
856 * Bisection is initially turned off unless it is forced
857  needbs = .NOT.tryrqc
858  120 CONTINUE
859 * Check if bisection should be used to refine eigenvalue
860  IF(needbs) THEN
861 * Take the bisection as new iterate
862  usedbs = .true.
863  itmp1 = iwork( iindr+windex )
864  offset = indexw( wbegin ) - 1
865  CALL slarrb( in, d(ibegin),
866  $ work(indlld+ibegin-1),indeig,indeig,
867  $ zero, two*eps, offset,
868  $ work(wbegin),wgap(wbegin),
869  $ werr(wbegin),work( indwrk ),
870  $ iwork( iindwk ), pivmin, spdiam,
871  $ itmp1, iinfo )
872  IF( iinfo.NE.0 ) THEN
873  info = -3
874  RETURN
875  ENDIF
876  lambda = work( windex )
877 * Reset twist index from inaccurate LAMBDA to
878 * force computation of true MINGMA
879  iwork( iindr+windex ) = 0
880  ENDIF
881 * Given LAMBDA, compute the eigenvector.
882  CALL clar1v( in, 1, in, lambda, d( ibegin ),
883  $ l( ibegin ), work(indld+ibegin-1),
884  $ work(indlld+ibegin-1),
885  $ pivmin, gaptol, z( ibegin, windex ),
886  $ .NOT.usedbs, negcnt, ztz, mingma,
887  $ iwork( iindr+windex ), isuppz( 2*windex-1 ),
888  $ nrminv, resid, rqcorr, work( indwrk ) )
889  IF(iter .EQ. 0) THEN
890  bstres = resid
891  bstw = lambda
892  ELSEIF(resid.LT.bstres) THEN
893  bstres = resid
894  bstw = lambda
895  ENDIF
896  isupmn = min(isupmn,isuppz( 2*windex-1 ))
897  isupmx = max(isupmx,isuppz( 2*windex ))
898  iter = iter + 1
899 
900 * sin alpha <= |resid|/gap
901 * Note that both the residual and the gap are
902 * proportional to the matrix, so ||T|| doesn't play
903 * a role in the quotient
904 
905 *
906 * Convergence test for Rayleigh-Quotient iteration
907 * (omitted when Bisection has been used)
908 *
909  IF( resid.GT.tol*gap .AND. abs( rqcorr ).GT.
910  $ rqtol*abs( lambda ) .AND. .NOT. usedbs)
911  $ THEN
912 * We need to check that the RQCORR update doesn't
913 * move the eigenvalue away from the desired one and
914 * towards a neighbor. -> protection with bisection
915  IF(indeig.LE.negcnt) THEN
916 * The wanted eigenvalue lies to the left
917  sgndef = -one
918  ELSE
919 * The wanted eigenvalue lies to the right
920  sgndef = one
921  ENDIF
922 * We only use the RQCORR if it improves the
923 * the iterate reasonably.
924  IF( ( rqcorr*sgndef.GE.zero )
925  $ .AND.( lambda + rqcorr.LE. right)
926  $ .AND.( lambda + rqcorr.GE. left)
927  $ ) THEN
928  usedrq = .true.
929 * Store new midpoint of bisection interval in WORK
930  IF(sgndef.EQ.one) THEN
931 * The current LAMBDA is on the left of the true
932 * eigenvalue
933  left = lambda
934 * We prefer to assume that the error estimate
935 * is correct. We could make the interval not
936 * as a bracket but to be modified if the RQCORR
937 * chooses to. In this case, the RIGHT side should
938 * be modified as follows:
939 * RIGHT = MAX(RIGHT, LAMBDA + RQCORR)
940  ELSE
941 * The current LAMBDA is on the right of the true
942 * eigenvalue
943  right = lambda
944 * See comment about assuming the error estimate is
945 * correct above.
946 * LEFT = MIN(LEFT, LAMBDA + RQCORR)
947  ENDIF
948  work( windex ) =
949  $ half * (right + left)
950 * Take RQCORR since it has the correct sign and
951 * improves the iterate reasonably
952  lambda = lambda + rqcorr
953 * Update width of error interval
954  werr( windex ) =
955  $ half * (right-left)
956  ELSE
957  needbs = .true.
958  ENDIF
959  IF(right-left.LT.rqtol*abs(lambda)) THEN
960 * The eigenvalue is computed to bisection accuracy
961 * compute eigenvector and stop
962  usedbs = .true.
963  GOTO 120
964  ELSEIF( iter.LT.maxitr ) THEN
965  GOTO 120
966  ELSEIF( iter.EQ.maxitr ) THEN
967  needbs = .true.
968  GOTO 120
969  ELSE
970  info = 5
971  RETURN
972  END IF
973  ELSE
974  stp2ii = .false.
975  IF(usedrq .AND. usedbs .AND.
976  $ bstres.LE.resid) THEN
977  lambda = bstw
978  stp2ii = .true.
979  ENDIF
980  IF (stp2ii) THEN
981 * improve error angle by second step
982  CALL clar1v( in, 1, in, lambda,
983  $ d( ibegin ), l( ibegin ),
984  $ work(indld+ibegin-1),
985  $ work(indlld+ibegin-1),
986  $ pivmin, gaptol, z( ibegin, windex ),
987  $ .NOT.usedbs, negcnt, ztz, mingma,
988  $ iwork( iindr+windex ),
989  $ isuppz( 2*windex-1 ),
990  $ nrminv, resid, rqcorr, work( indwrk ) )
991  ENDIF
992  work( windex ) = lambda
993  END IF
994 *
995 * Compute FP-vector support w.r.t. whole matrix
996 *
997  isuppz( 2*windex-1 ) = isuppz( 2*windex-1 )+oldien
998  isuppz( 2*windex ) = isuppz( 2*windex )+oldien
999  zfrom = isuppz( 2*windex-1 )
1000  zto = isuppz( 2*windex )
1001  isupmn = isupmn + oldien
1002  isupmx = isupmx + oldien
1003 * Ensure vector is ok if support in the RQI has changed
1004  IF(isupmn.LT.zfrom) THEN
1005  DO 122 ii = isupmn,zfrom-1
1006  z( ii, windex ) = zero
1007  122 CONTINUE
1008  ENDIF
1009  IF(isupmx.GT.zto) THEN
1010  DO 123 ii = zto+1,isupmx
1011  z( ii, windex ) = zero
1012  123 CONTINUE
1013  ENDIF
1014  CALL csscal( zto-zfrom+1, nrminv,
1015  $ z( zfrom, windex ), 1 )
1016  125 CONTINUE
1017 * Update W
1018  w( windex ) = lambda+sigma
1019 * Recompute the gaps on the left and right
1020 * But only allow them to become larger and not
1021 * smaller (which can only happen through "bad"
1022 * cancellation and doesn't reflect the theory
1023 * where the initial gaps are underestimated due
1024 * to WERR being too crude.)
1025  IF(.NOT.eskip) THEN
1026  IF( k.GT.1) THEN
1027  wgap( windmn ) = max( wgap(windmn),
1028  $ w(windex)-werr(windex)
1029  $ - w(windmn)-werr(windmn) )
1030  ENDIF
1031  IF( windex.LT.wend ) THEN
1032  wgap( windex ) = max( savgap,
1033  $ w( windpl )-werr( windpl )
1034  $ - w( windex )-werr( windex) )
1035  ENDIF
1036  ENDIF
1037  idone = idone + 1
1038  ENDIF
1039 * here ends the code for the current child
1040 *
1041  139 CONTINUE
1042 * Proceed to any remaining child nodes
1043  newfst = j + 1
1044  140 CONTINUE
1045  150 CONTINUE
1046  ndepth = ndepth + 1
1047  GO TO 40
1048  END IF
1049  ibegin = iend + 1
1050  wbegin = wend + 1
1051  170 CONTINUE
1052 *
1053 
1054  RETURN
1055 *
1056 * End of CLARRV
1057 *
1058  END
1059 
slarrf
subroutine slarrf(N, D, L, LD, CLSTRT, CLEND, W, WGAP, WERR, SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, DPLUS, LPLUS, WORK, INFO)
SLARRF finds a new relatively robust representation such that at least one of the eigenvalues is rela...
Definition: slarrf.f:195
claset
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
Definition: claset.f:108
slarrb
subroutine slarrb(N, D, LLD, IFIRST, ILAST, RTOL1, RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK, PIVMIN, SPDIAM, TWIST, INFO)
SLARRB provides limited bisection to locate eigenvalues for more accuracy.
Definition: slarrb.f:198
clar1v
subroutine clar1v(N, B1, BN, LAMBDA, D, L, LD, LLD, PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, R, ISUPPZ, NRMINV, RESID, RQCORR, WORK)
CLAR1V computes the (scaled) r-th column of the inverse of the submatrix in rows b1 through bn of the...
Definition: clar1v.f:232
clarrv
subroutine clarrv(N, VL, VU, D, L, PIVMIN, ISPLIT, M, DOL, DOU, MINRGP, RTOL1, RTOL2, W, WERR, WGAP, IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, WORK, IWORK, INFO)
CLARRV computes the eigenvectors of the tridiagonal matrix T = L D LT given L, D and the eigenvalues ...
Definition: clarrv.f:288
scopy
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
Definition: scopy.f:84
csscal
subroutine csscal(N, SA, CX, INCX)
CSSCAL
Definition: csscal.f:80