LAPACK  3.7.1
LAPACK: Linear Algebra PACKage
zlarrv.f
Go to the documentation of this file.
1 *> \brief \b ZLARRV 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 ZLARRV + dependencies
10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarrv.f">
11 *> [TGZ]</a>
12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarrv.f">
13 *> [ZIP]</a>
14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarrv.f">
15 *> [TXT]</a>
16 *> \endhtmlonly
17 *
18 * Definition:
19 * ===========
20 *
21 * SUBROUTINE ZLARRV( 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 * DOUBLE PRECISION MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU
30 * ..
31 * .. Array Arguments ..
32 * INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ),
33 * $ ISUPPZ( * ), IWORK( * )
34 * DOUBLE PRECISION D( * ), GERS( * ), L( * ), W( * ), WERR( * ),
35 * $ WGAP( * ), WORK( * )
36 * COMPLEX*16 Z( LDZ, * )
37 * ..
38 *
39 *
40 *> \par Purpose:
41 * =============
42 *>
43 *> \verbatim
44 *>
45 *> ZLARRV 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 DLARRE.
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 DOUBLE PRECISION
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 DOUBLE PRECISION
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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DLARRE.
89 *> On exit, L is overwritten.
90 *> \endverbatim
91 *>
92 *> \param[in] PIVMIN
93 *> \verbatim
94 *> PIVMIN is DOUBLE PRECISION
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 DOUBLE PRECISION
134 *> \endverbatim
135 *>
136 *> \param[in] RTOL1
137 *> \verbatim
138 *> RTOL1 is DOUBLE PRECISION
139 *> \endverbatim
140 *>
141 *> \param[in] RTOL2
142 *> \verbatim
143 *> RTOL2 is DOUBLE PRECISION
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 DOUBLE PRECISION 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 DLARRE 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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*16 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 DOUBLE PRECISION 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 ZLARRV.
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 DLARRB when refining a child's eigenvalues.
248 *> =-2: Problem in DLARRF 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 DLARRB 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 complex16OTHERauxiliary
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 zlarrv( 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  DOUBLE PRECISION MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU
297 * ..
298 * .. Array Arguments ..
299  INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ),
300  $ isuppz( * ), iwork( * )
301  DOUBLE PRECISION D( * ), GERS( * ), L( * ), W( * ), WERR( * ),
302  $ wgap( * ), work( * )
303  COMPLEX*16 Z( ldz, * )
304 * ..
305 *
306 * =====================================================================
307 *
308 * .. Parameters ..
309  INTEGER MAXITR
310  parameter( maxitr = 10 )
311  COMPLEX*16 CZERO
312  parameter( czero = ( 0.0d0, 0.0d0 ) )
313  DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, HALF
314  parameter( zero = 0.0d0, one = 1.0d0,
315  $ two = 2.0d0, three = 3.0d0,
316  $ four = 4.0d0, half = 0.5d0)
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  DOUBLE PRECISION 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  DOUBLE PRECISION DLAMCH
337  EXTERNAL dlamch
338 * ..
339 * .. External Subroutines ..
340  EXTERNAL dcopy, dlarrb, dlarrf, zdscal, zlar1v,
341  $ zlaset
342 * ..
343 * .. Intrinsic Functions ..
344  INTRINSIC abs, dble, max, min
345  INTRINSIC dcmplx
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 zlaset( 'Full', n, zusedw, czero, czero,
399  $ z(1,zusedl), ldz )
400 
401  eps = dlamch( '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 ) = dcmplx( 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 dcopy( 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 ) = dble( z( ibegin+k-1,
561  $ j ) )
562  l( ibegin+k-1 ) = dble( z( ibegin+k-1,
563  $ j+1 ) )
564  45 CONTINUE
565  d( iend ) = dble( z( iend, j ) )
566  sigma = dble( z( iend, j+1 ) )
567 
568 * Set the corresponding entries in Z to zero
569  CALL zlaset( 'Full', in, 2, czero, czero,
570  $ z( ibegin, j), ldz )
571  END IF
572 
573 * Compute DL and DLL of current RRR
574  DO 50 j = ibegin, iend-1
575  tmp = d( j )*l( j )
576  work( indld-1+j ) = tmp
577  work( indlld-1+j ) = tmp*l( j )
578  50 CONTINUE
579 
580  IF( ndepth.GT.0 ) THEN
581 * P and Q are index of the first and last eigenvalue to compute
582 * within the current block
583  p = indexw( wbegin-1+oldfst )
584  q = indexw( wbegin-1+oldlst )
585 * Offset for the arrays WORK, WGAP and WERR, i.e., the P-OFFSET
586 * through the Q-OFFSET elements of these arrays are to be used.
587 * OFFSET = P-OLDFST
588  offset = indexw( wbegin ) - 1
589 * perform limited bisection (if necessary) to get approximate
590 * eigenvalues to the precision needed.
591  CALL dlarrb( in, d( ibegin ),
592  $ work(indlld+ibegin-1),
593  $ p, q, rtol1, rtol2, offset,
594  $ work(wbegin),wgap(wbegin),werr(wbegin),
595  $ work( indwrk ), iwork( iindwk ),
596  $ pivmin, spdiam, in, iinfo )
597  IF( iinfo.NE.0 ) THEN
598  info = -1
599  RETURN
600  ENDIF
601 * We also recompute the extremal gaps. W holds all eigenvalues
602 * of the unshifted matrix and must be used for computation
603 * of WGAP, the entries of WORK might stem from RRRs with
604 * different shifts. The gaps from WBEGIN-1+OLDFST to
605 * WBEGIN-1+OLDLST are correctly computed in DLARRB.
606 * However, we only allow the gaps to become greater since
607 * this is what should happen when we decrease WERR
608  IF( oldfst.GT.1) THEN
609  wgap( wbegin+oldfst-2 ) =
610  $ max(wgap(wbegin+oldfst-2),
611  $ w(wbegin+oldfst-1)-werr(wbegin+oldfst-1)
612  $ - w(wbegin+oldfst-2)-werr(wbegin+oldfst-2) )
613  ENDIF
614  IF( wbegin + oldlst -1 .LT. wend ) THEN
615  wgap( wbegin+oldlst-1 ) =
616  $ max(wgap(wbegin+oldlst-1),
617  $ w(wbegin+oldlst)-werr(wbegin+oldlst)
618  $ - w(wbegin+oldlst-1)-werr(wbegin+oldlst-1) )
619  ENDIF
620 * Each time the eigenvalues in WORK get refined, we store
621 * the newly found approximation with all shifts applied in W
622  DO 53 j=oldfst,oldlst
623  w(wbegin+j-1) = work(wbegin+j-1)+sigma
624  53 CONTINUE
625  END IF
626 
627 * Process the current node.
628  newfst = oldfst
629  DO 140 j = oldfst, oldlst
630  IF( j.EQ.oldlst ) THEN
631 * we are at the right end of the cluster, this is also the
632 * boundary of the child cluster
633  newlst = j
634  ELSE IF ( wgap( wbegin + j -1).GE.
635  $ minrgp* abs( work(wbegin + j -1) ) ) THEN
636 * the right relative gap is big enough, the child cluster
637 * (NEWFST,..,NEWLST) is well separated from the following
638  newlst = j
639  ELSE
640 * inside a child cluster, the relative gap is not
641 * big enough.
642  GOTO 140
643  END IF
644 
645 * Compute size of child cluster found
646  newsiz = newlst - newfst + 1
647 
648 * NEWFTT is the place in Z where the new RRR or the computed
649 * eigenvector is to be stored
650  IF((dol.EQ.1).AND.(dou.EQ.m)) THEN
651 * Store representation at location of the leftmost evalue
652 * of the cluster
653  newftt = wbegin + newfst - 1
654  ELSE
655  IF(wbegin+newfst-1.LT.dol) THEN
656 * Store representation at the left end of Z array
657  newftt = dol - 1
658  ELSEIF(wbegin+newfst-1.GT.dou) THEN
659 * Store representation at the right end of Z array
660  newftt = dou
661  ELSE
662  newftt = wbegin + newfst - 1
663  ENDIF
664  ENDIF
665 
666  IF( newsiz.GT.1) THEN
667 *
668 * Current child is not a singleton but a cluster.
669 * Compute and store new representation of child.
670 *
671 *
672 * Compute left and right cluster gap.
673 *
674 * LGAP and RGAP are not computed from WORK because
675 * the eigenvalue approximations may stem from RRRs
676 * different shifts. However, W hold all eigenvalues
677 * of the unshifted matrix. Still, the entries in WGAP
678 * have to be computed from WORK since the entries
679 * in W might be of the same order so that gaps are not
680 * exhibited correctly for very close eigenvalues.
681  IF( newfst.EQ.1 ) THEN
682  lgap = max( zero,
683  $ w(wbegin)-werr(wbegin) - vl )
684  ELSE
685  lgap = wgap( wbegin+newfst-2 )
686  ENDIF
687  rgap = wgap( wbegin+newlst-1 )
688 *
689 * Compute left- and rightmost eigenvalue of child
690 * to high precision in order to shift as close
691 * as possible and obtain as large relative gaps
692 * as possible
693 *
694  DO 55 k =1,2
695  IF(k.EQ.1) THEN
696  p = indexw( wbegin-1+newfst )
697  ELSE
698  p = indexw( wbegin-1+newlst )
699  ENDIF
700  offset = indexw( wbegin ) - 1
701  CALL dlarrb( in, d(ibegin),
702  $ work( indlld+ibegin-1 ),p,p,
703  $ rqtol, rqtol, offset,
704  $ work(wbegin),wgap(wbegin),
705  $ werr(wbegin),work( indwrk ),
706  $ iwork( iindwk ), pivmin, spdiam,
707  $ in, iinfo )
708  55 CONTINUE
709 *
710  IF((wbegin+newlst-1.LT.dol).OR.
711  $ (wbegin+newfst-1.GT.dou)) THEN
712 * if the cluster contains no desired eigenvalues
713 * skip the computation of that branch of the rep. tree
714 *
715 * We could skip before the refinement of the extremal
716 * eigenvalues of the child, but then the representation
717 * tree could be different from the one when nothing is
718 * skipped. For this reason we skip at this place.
719  idone = idone + newlst - newfst + 1
720  GOTO 139
721  ENDIF
722 *
723 * Compute RRR of child cluster.
724 * Note that the new RRR is stored in Z
725 *
726 * DLARRF needs LWORK = 2*N
727  CALL dlarrf( in, d( ibegin ), l( ibegin ),
728  $ work(indld+ibegin-1),
729  $ newfst, newlst, work(wbegin),
730  $ wgap(wbegin), werr(wbegin),
731  $ spdiam, lgap, rgap, pivmin, tau,
732  $ work( indin1 ), work( indin2 ),
733  $ work( indwrk ), iinfo )
734 * In the complex case, DLARRF cannot write
735 * the new RRR directly into Z and needs an intermediate
736 * workspace
737  DO 56 k = 1, in-1
738  z( ibegin+k-1, newftt ) =
739  $ dcmplx( work( indin1+k-1 ), zero )
740  z( ibegin+k-1, newftt+1 ) =
741  $ dcmplx( work( indin2+k-1 ), zero )
742  56 CONTINUE
743  z( iend, newftt ) =
744  $ dcmplx( work( indin1+in-1 ), zero )
745  IF( iinfo.EQ.0 ) THEN
746 * a new RRR for the cluster was found by DLARRF
747 * update shift and store it
748  ssigma = sigma + tau
749  z( iend, newftt+1 ) = dcmplx( ssigma, zero )
750 * WORK() are the midpoints and WERR() the semi-width
751 * Note that the entries in W are unchanged.
752  DO 116 k = newfst, newlst
753  fudge =
754  $ three*eps*abs(work(wbegin+k-1))
755  work( wbegin + k - 1 ) =
756  $ work( wbegin + k - 1) - tau
757  fudge = fudge +
758  $ four*eps*abs(work(wbegin+k-1))
759 * Fudge errors
760  werr( wbegin + k - 1 ) =
761  $ werr( wbegin + k - 1 ) + fudge
762 * Gaps are not fudged. Provided that WERR is small
763 * when eigenvalues are close, a zero gap indicates
764 * that a new representation is needed for resolving
765 * the cluster. A fudge could lead to a wrong decision
766 * of judging eigenvalues 'separated' which in
767 * reality are not. This could have a negative impact
768 * on the orthogonality of the computed eigenvectors.
769  116 CONTINUE
770 
771  nclus = nclus + 1
772  k = newcls + 2*nclus
773  iwork( k-1 ) = newfst
774  iwork( k ) = newlst
775  ELSE
776  info = -2
777  RETURN
778  ENDIF
779  ELSE
780 *
781 * Compute eigenvector of singleton
782 *
783  iter = 0
784 *
785  tol = four * log(dble(in)) * eps
786 *
787  k = newfst
788  windex = wbegin + k - 1
789  windmn = max(windex - 1,1)
790  windpl = min(windex + 1,m)
791  lambda = work( windex )
792  done = done + 1
793 * Check if eigenvector computation is to be skipped
794  IF((windex.LT.dol).OR.
795  $ (windex.GT.dou)) THEN
796  eskip = .true.
797  GOTO 125
798  ELSE
799  eskip = .false.
800  ENDIF
801  left = work( windex ) - werr( windex )
802  right = work( windex ) + werr( windex )
803  indeig = indexw( windex )
804 * Note that since we compute the eigenpairs for a child,
805 * all eigenvalue approximations are w.r.t the same shift.
806 * In this case, the entries in WORK should be used for
807 * computing the gaps since they exhibit even very small
808 * differences in the eigenvalues, as opposed to the
809 * entries in W which might "look" the same.
810 
811  IF( k .EQ. 1) THEN
812 * In the case RANGE='I' and with not much initial
813 * accuracy in LAMBDA and VL, the formula
814 * LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA )
815 * can lead to an overestimation of the left gap and
816 * thus to inadequately early RQI 'convergence'.
817 * Prevent this by forcing a small left gap.
818  lgap = eps*max(abs(left),abs(right))
819  ELSE
820  lgap = wgap(windmn)
821  ENDIF
822  IF( k .EQ. im) THEN
823 * In the case RANGE='I' and with not much initial
824 * accuracy in LAMBDA and VU, the formula
825 * can lead to an overestimation of the right gap and
826 * thus to inadequately early RQI 'convergence'.
827 * Prevent this by forcing a small right gap.
828  rgap = eps*max(abs(left),abs(right))
829  ELSE
830  rgap = wgap(windex)
831  ENDIF
832  gap = min( lgap, rgap )
833  IF(( k .EQ. 1).OR.(k .EQ. im)) THEN
834 * The eigenvector support can become wrong
835 * because significant entries could be cut off due to a
836 * large GAPTOL parameter in LAR1V. Prevent this.
837  gaptol = zero
838  ELSE
839  gaptol = gap * eps
840  ENDIF
841  isupmn = in
842  isupmx = 1
843 * Update WGAP so that it holds the minimum gap
844 * to the left or the right. This is crucial in the
845 * case where bisection is used to ensure that the
846 * eigenvalue is refined up to the required precision.
847 * The correct value is restored afterwards.
848  savgap = wgap(windex)
849  wgap(windex) = gap
850 * We want to use the Rayleigh Quotient Correction
851 * as often as possible since it converges quadratically
852 * when we are close enough to the desired eigenvalue.
853 * However, the Rayleigh Quotient can have the wrong sign
854 * and lead us away from the desired eigenvalue. In this
855 * case, the best we can do is to use bisection.
856  usedbs = .false.
857  usedrq = .false.
858 * Bisection is initially turned off unless it is forced
859  needbs = .NOT.tryrqc
860  120 CONTINUE
861 * Check if bisection should be used to refine eigenvalue
862  IF(needbs) THEN
863 * Take the bisection as new iterate
864  usedbs = .true.
865  itmp1 = iwork( iindr+windex )
866  offset = indexw( wbegin ) - 1
867  CALL dlarrb( in, d(ibegin),
868  $ work(indlld+ibegin-1),indeig,indeig,
869  $ zero, two*eps, offset,
870  $ work(wbegin),wgap(wbegin),
871  $ werr(wbegin),work( indwrk ),
872  $ iwork( iindwk ), pivmin, spdiam,
873  $ itmp1, iinfo )
874  IF( iinfo.NE.0 ) THEN
875  info = -3
876  RETURN
877  ENDIF
878  lambda = work( windex )
879 * Reset twist index from inaccurate LAMBDA to
880 * force computation of true MINGMA
881  iwork( iindr+windex ) = 0
882  ENDIF
883 * Given LAMBDA, compute the eigenvector.
884  CALL zlar1v( in, 1, in, lambda, d( ibegin ),
885  $ l( ibegin ), work(indld+ibegin-1),
886  $ work(indlld+ibegin-1),
887  $ pivmin, gaptol, z( ibegin, windex ),
888  $ .NOT.usedbs, negcnt, ztz, mingma,
889  $ iwork( iindr+windex ), isuppz( 2*windex-1 ),
890  $ nrminv, resid, rqcorr, work( indwrk ) )
891  IF(iter .EQ. 0) THEN
892  bstres = resid
893  bstw = lambda
894  ELSEIF(resid.LT.bstres) THEN
895  bstres = resid
896  bstw = lambda
897  ENDIF
898  isupmn = min(isupmn,isuppz( 2*windex-1 ))
899  isupmx = max(isupmx,isuppz( 2*windex ))
900  iter = iter + 1
901 
902 * sin alpha <= |resid|/gap
903 * Note that both the residual and the gap are
904 * proportional to the matrix, so ||T|| doesn't play
905 * a role in the quotient
906 
907 *
908 * Convergence test for Rayleigh-Quotient iteration
909 * (omitted when Bisection has been used)
910 *
911  IF( resid.GT.tol*gap .AND. abs( rqcorr ).GT.
912  $ rqtol*abs( lambda ) .AND. .NOT. usedbs)
913  $ THEN
914 * We need to check that the RQCORR update doesn't
915 * move the eigenvalue away from the desired one and
916 * towards a neighbor. -> protection with bisection
917  IF(indeig.LE.negcnt) THEN
918 * The wanted eigenvalue lies to the left
919  sgndef = -one
920  ELSE
921 * The wanted eigenvalue lies to the right
922  sgndef = one
923  ENDIF
924 * We only use the RQCORR if it improves the
925 * the iterate reasonably.
926  IF( ( rqcorr*sgndef.GE.zero )
927  $ .AND.( lambda + rqcorr.LE. right)
928  $ .AND.( lambda + rqcorr.GE. left)
929  $ ) THEN
930  usedrq = .true.
931 * Store new midpoint of bisection interval in WORK
932  IF(sgndef.EQ.one) THEN
933 * The current LAMBDA is on the left of the true
934 * eigenvalue
935  left = lambda
936 * We prefer to assume that the error estimate
937 * is correct. We could make the interval not
938 * as a bracket but to be modified if the RQCORR
939 * chooses to. In this case, the RIGHT side should
940 * be modified as follows:
941 * RIGHT = MAX(RIGHT, LAMBDA + RQCORR)
942  ELSE
943 * The current LAMBDA is on the right of the true
944 * eigenvalue
945  right = lambda
946 * See comment about assuming the error estimate is
947 * correct above.
948 * LEFT = MIN(LEFT, LAMBDA + RQCORR)
949  ENDIF
950  work( windex ) =
951  $ half * (right + left)
952 * Take RQCORR since it has the correct sign and
953 * improves the iterate reasonably
954  lambda = lambda + rqcorr
955 * Update width of error interval
956  werr( windex ) =
957  $ half * (right-left)
958  ELSE
959  needbs = .true.
960  ENDIF
961  IF(right-left.LT.rqtol*abs(lambda)) THEN
962 * The eigenvalue is computed to bisection accuracy
963 * compute eigenvector and stop
964  usedbs = .true.
965  GOTO 120
966  ELSEIF( iter.LT.maxitr ) THEN
967  GOTO 120
968  ELSEIF( iter.EQ.maxitr ) THEN
969  needbs = .true.
970  GOTO 120
971  ELSE
972  info = 5
973  RETURN
974  END IF
975  ELSE
976  stp2ii = .false.
977  IF(usedrq .AND. usedbs .AND.
978  $ bstres.LE.resid) THEN
979  lambda = bstw
980  stp2ii = .true.
981  ENDIF
982  IF (stp2ii) THEN
983 * improve error angle by second step
984  CALL zlar1v( in, 1, in, lambda,
985  $ d( ibegin ), l( ibegin ),
986  $ work(indld+ibegin-1),
987  $ work(indlld+ibegin-1),
988  $ pivmin, gaptol, z( ibegin, windex ),
989  $ .NOT.usedbs, negcnt, ztz, mingma,
990  $ iwork( iindr+windex ),
991  $ isuppz( 2*windex-1 ),
992  $ nrminv, resid, rqcorr, work( indwrk ) )
993  ENDIF
994  work( windex ) = lambda
995  END IF
996 *
997 * Compute FP-vector support w.r.t. whole matrix
998 *
999  isuppz( 2*windex-1 ) = isuppz( 2*windex-1 )+oldien
1000  isuppz( 2*windex ) = isuppz( 2*windex )+oldien
1001  zfrom = isuppz( 2*windex-1 )
1002  zto = isuppz( 2*windex )
1003  isupmn = isupmn + oldien
1004  isupmx = isupmx + oldien
1005 * Ensure vector is ok if support in the RQI has changed
1006  IF(isupmn.LT.zfrom) THEN
1007  DO 122 ii = isupmn,zfrom-1
1008  z( ii, windex ) = zero
1009  122 CONTINUE
1010  ENDIF
1011  IF(isupmx.GT.zto) THEN
1012  DO 123 ii = zto+1,isupmx
1013  z( ii, windex ) = zero
1014  123 CONTINUE
1015  ENDIF
1016  CALL zdscal( zto-zfrom+1, nrminv,
1017  $ z( zfrom, windex ), 1 )
1018  125 CONTINUE
1019 * Update W
1020  w( windex ) = lambda+sigma
1021 * Recompute the gaps on the left and right
1022 * But only allow them to become larger and not
1023 * smaller (which can only happen through "bad"
1024 * cancellation and doesn't reflect the theory
1025 * where the initial gaps are underestimated due
1026 * to WERR being too crude.)
1027  IF(.NOT.eskip) THEN
1028  IF( k.GT.1) THEN
1029  wgap( windmn ) = max( wgap(windmn),
1030  $ w(windex)-werr(windex)
1031  $ - w(windmn)-werr(windmn) )
1032  ENDIF
1033  IF( windex.LT.wend ) THEN
1034  wgap( windex ) = max( savgap,
1035  $ w( windpl )-werr( windpl )
1036  $ - w( windex )-werr( windex) )
1037  ENDIF
1038  ENDIF
1039  idone = idone + 1
1040  ENDIF
1041 * here ends the code for the current child
1042 *
1043  139 CONTINUE
1044 * Proceed to any remaining child nodes
1045  newfst = j + 1
1046  140 CONTINUE
1047  150 CONTINUE
1048  ndepth = ndepth + 1
1049  GO TO 40
1050  END IF
1051  ibegin = iend + 1
1052  wbegin = wend + 1
1053  170 CONTINUE
1054 *
1055 
1056  RETURN
1057 *
1058 * End of ZLARRV
1059 *
1060  END
dcopy
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
Definition: dcopy.f:84
zlar1v
subroutine zlar1v(N, B1, BN, LAMBDA, D, L, LD, LLD, PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, R, ISUPPZ, NRMINV, RESID, RQCORR, WORK)
ZLAR1V computes the (scaled) r-th column of the inverse of the submatrix in rows b1 through bn of the...
Definition: zlar1v.f:232
zlaset
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
Definition: zlaset.f:108
zlarrv
subroutine zlarrv(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)
ZLARRV computes the eigenvectors of the tridiagonal matrix T = L D LT given L, D and the eigenvalues ...
Definition: zlarrv.f:288
dlarrf
subroutine dlarrf(N, D, L, LD, CLSTRT, CLEND, W, WGAP, WERR, SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, DPLUS, LPLUS, WORK, INFO)
DLARRF finds a new relatively robust representation such that at least one of the eigenvalues is rela...
Definition: dlarrf.f:195
dlarrb
subroutine dlarrb(N, D, LLD, IFIRST, ILAST, RTOL1, RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK, PIVMIN, SPDIAM, TWIST, INFO)
DLARRB provides limited bisection to locate eigenvalues for more accuracy.
Definition: dlarrb.f:198
zdscal
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
Definition: zdscal.f:80