LAPACK  3.9.1
LAPACK: Linear Algebra PACKage
slarre.f
Go to the documentation of this file.
1 *> \brief \b SLARRE given the tridiagonal matrix T, sets small off-diagonal elements to zero and for each unreduced block Ti, finds base representations and eigenvalues.
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 *> \htmlonly
9 *> Download SLARRE + dependencies
10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slarre.f">
11 *> [TGZ]</a>
12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slarre.f">
13 *> [ZIP]</a>
14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slarre.f">
15 *> [TXT]</a>
16 *> \endhtmlonly
17 *
18 * Definition:
19 * ===========
20 *
21 * SUBROUTINE SLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2,
22 * RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M,
23 * W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN,
24 * WORK, IWORK, INFO )
25 *
26 * .. Scalar Arguments ..
27 * CHARACTER RANGE
28 * INTEGER IL, INFO, IU, M, N, NSPLIT
29 * REAL PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU
30 * ..
31 * .. Array Arguments ..
32 * INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ),
33 * $ INDEXW( * )
34 * REAL D( * ), E( * ), E2( * ), GERS( * ),
35 * $ W( * ),WERR( * ), WGAP( * ), WORK( * )
36 * ..
37 *
38 *
39 *> \par Purpose:
40 * =============
41 *>
42 *> \verbatim
43 *>
44 *> To find the desired eigenvalues of a given real symmetric
45 *> tridiagonal matrix T, SLARRE sets any "small" off-diagonal
46 *> elements to zero, and for each unreduced block T_i, it finds
47 *> (a) a suitable shift at one end of the block's spectrum,
48 *> (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and
49 *> (c) eigenvalues of each L_i D_i L_i^T.
50 *> The representations and eigenvalues found are then used by
51 *> SSTEMR to compute the eigenvectors of T.
52 *> The accuracy varies depending on whether bisection is used to
53 *> find a few eigenvalues or the dqds algorithm (subroutine SLASQ2) to
54 *> conpute all and then discard any unwanted one.
55 *> As an added benefit, SLARRE also outputs the n
56 *> Gerschgorin intervals for the matrices L_i D_i L_i^T.
57 *> \endverbatim
58 *
59 * Arguments:
60 * ==========
61 *
62 *> \param[in] RANGE
63 *> \verbatim
64 *> RANGE is CHARACTER*1
65 *> = 'A': ("All") all eigenvalues will be found.
66 *> = 'V': ("Value") all eigenvalues in the half-open interval
67 *> (VL, VU] will be found.
68 *> = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
69 *> entire matrix) will be found.
70 *> \endverbatim
71 *>
72 *> \param[in] N
73 *> \verbatim
74 *> N is INTEGER
75 *> The order of the matrix. N > 0.
76 *> \endverbatim
77 *>
78 *> \param[in,out] VL
79 *> \verbatim
80 *> VL is REAL
81 *> If RANGE='V', the lower bound for the eigenvalues.
82 *> Eigenvalues less than or equal to VL, or greater than VU,
83 *> will not be returned. VL < VU.
84 *> If RANGE='I' or ='A', SLARRE computes bounds on the desired
85 *> part of the spectrum.
86 *> \endverbatim
87 *>
88 *> \param[in,out] VU
89 *> \verbatim
90 *> VU is REAL
91 *> If RANGE='V', the upper bound for the eigenvalues.
92 *> Eigenvalues less than or equal to VL, or greater than VU,
93 *> will not be returned. VL < VU.
94 *> If RANGE='I' or ='A', SLARRE computes bounds on the desired
95 *> part of the spectrum.
96 *> \endverbatim
97 *>
98 *> \param[in] IL
99 *> \verbatim
100 *> IL is INTEGER
101 *> If RANGE='I', the index of the
102 *> smallest eigenvalue to be returned.
103 *> 1 <= IL <= IU <= N.
104 *> \endverbatim
105 *>
106 *> \param[in] IU
107 *> \verbatim
108 *> IU is INTEGER
109 *> If RANGE='I', the index of the
110 *> largest eigenvalue to be returned.
111 *> 1 <= IL <= IU <= N.
112 *> \endverbatim
113 *>
114 *> \param[in,out] D
115 *> \verbatim
116 *> D is REAL array, dimension (N)
117 *> On entry, the N diagonal elements of the tridiagonal
118 *> matrix T.
119 *> On exit, the N diagonal elements of the diagonal
120 *> matrices D_i.
121 *> \endverbatim
122 *>
123 *> \param[in,out] E
124 *> \verbatim
125 *> E is REAL array, dimension (N)
126 *> On entry, the first (N-1) entries contain the subdiagonal
127 *> elements of the tridiagonal matrix T; E(N) need not be set.
128 *> On exit, E contains the subdiagonal elements of the unit
129 *> bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),
130 *> 1 <= I <= NSPLIT, contain the base points sigma_i on output.
131 *> \endverbatim
132 *>
133 *> \param[in,out] E2
134 *> \verbatim
135 *> E2 is REAL array, dimension (N)
136 *> On entry, the first (N-1) entries contain the SQUARES of the
137 *> subdiagonal elements of the tridiagonal matrix T;
138 *> E2(N) need not be set.
139 *> On exit, the entries E2( ISPLIT( I ) ),
140 *> 1 <= I <= NSPLIT, have been set to zero
141 *> \endverbatim
142 *>
143 *> \param[in] RTOL1
144 *> \verbatim
145 *> RTOL1 is REAL
146 *> \endverbatim
147 *>
148 *> \param[in] RTOL2
149 *> \verbatim
150 *> RTOL2 is REAL
151 *> Parameters for bisection.
152 *> An interval [LEFT,RIGHT] has converged if
153 *> RIGHT-LEFT < MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
154 *> \endverbatim
155 *>
156 *> \param[in] SPLTOL
157 *> \verbatim
158 *> SPLTOL is REAL
159 *> The threshold for splitting.
160 *> \endverbatim
161 *>
162 *> \param[out] NSPLIT
163 *> \verbatim
164 *> NSPLIT is INTEGER
165 *> The number of blocks T splits into. 1 <= NSPLIT <= N.
166 *> \endverbatim
167 *>
168 *> \param[out] ISPLIT
169 *> \verbatim
170 *> ISPLIT is INTEGER array, dimension (N)
171 *> The splitting points, at which T breaks up into blocks.
172 *> The first block consists of rows/columns 1 to ISPLIT(1),
173 *> the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
174 *> etc., and the NSPLIT-th consists of rows/columns
175 *> ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
176 *> \endverbatim
177 *>
178 *> \param[out] M
179 *> \verbatim
180 *> M is INTEGER
181 *> The total number of eigenvalues (of all L_i D_i L_i^T)
182 *> found.
183 *> \endverbatim
184 *>
185 *> \param[out] W
186 *> \verbatim
187 *> W is REAL array, dimension (N)
188 *> The first M elements contain the eigenvalues. The
189 *> eigenvalues of each of the blocks, L_i D_i L_i^T, are
190 *> sorted in ascending order ( SLARRE may use the
191 *> remaining N-M elements as workspace).
192 *> \endverbatim
193 *>
194 *> \param[out] WERR
195 *> \verbatim
196 *> WERR is REAL array, dimension (N)
197 *> The error bound on the corresponding eigenvalue in W.
198 *> \endverbatim
199 *>
200 *> \param[out] WGAP
201 *> \verbatim
202 *> WGAP is REAL array, dimension (N)
203 *> The separation from the right neighbor eigenvalue in W.
204 *> The gap is only with respect to the eigenvalues of the same block
205 *> as each block has its own representation tree.
206 *> Exception: at the right end of a block we store the left gap
207 *> \endverbatim
208 *>
209 *> \param[out] IBLOCK
210 *> \verbatim
211 *> IBLOCK is INTEGER array, dimension (N)
212 *> The indices of the blocks (submatrices) associated with the
213 *> corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
214 *> W(i) belongs to the first block from the top, =2 if W(i)
215 *> belongs to the second block, etc.
216 *> \endverbatim
217 *>
218 *> \param[out] INDEXW
219 *> \verbatim
220 *> INDEXW is INTEGER array, dimension (N)
221 *> The indices of the eigenvalues within each block (submatrix);
222 *> for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
223 *> i-th eigenvalue W(i) is the 10-th eigenvalue in block 2
224 *> \endverbatim
225 *>
226 *> \param[out] GERS
227 *> \verbatim
228 *> GERS is REAL array, dimension (2*N)
229 *> The N Gerschgorin intervals (the i-th Gerschgorin interval
230 *> is (GERS(2*i-1), GERS(2*i)).
231 *> \endverbatim
232 *>
233 *> \param[out] PIVMIN
234 *> \verbatim
235 *> PIVMIN is REAL
236 *> The minimum pivot in the Sturm sequence for T.
237 *> \endverbatim
238 *>
239 *> \param[out] WORK
240 *> \verbatim
241 *> WORK is REAL array, dimension (6*N)
242 *> Workspace.
243 *> \endverbatim
244 *>
245 *> \param[out] IWORK
246 *> \verbatim
247 *> IWORK is INTEGER array, dimension (5*N)
248 *> Workspace.
249 *> \endverbatim
250 *>
251 *> \param[out] INFO
252 *> \verbatim
253 *> INFO is INTEGER
254 *> = 0: successful exit
255 *> > 0: A problem occurred in SLARRE.
256 *> < 0: One of the called subroutines signaled an internal problem.
257 *> Needs inspection of the corresponding parameter IINFO
258 *> for further information.
259 *>
260 *> =-1: Problem in SLARRD.
261 *> = 2: No base representation could be found in MAXTRY iterations.
262 *> Increasing MAXTRY and recompilation might be a remedy.
263 *> =-3: Problem in SLARRB when computing the refined root
264 *> representation for SLASQ2.
265 *> =-4: Problem in SLARRB when preforming bisection on the
266 *> desired part of the spectrum.
267 *> =-5: Problem in SLASQ2.
268 *> =-6: Problem in SLASQ2.
269 *> \endverbatim
270 *
271 * Authors:
272 * ========
273 *
274 *> \author Univ. of Tennessee
275 *> \author Univ. of California Berkeley
276 *> \author Univ. of Colorado Denver
277 *> \author NAG Ltd.
278 *
279 *> \ingroup OTHERauxiliary
280 *
281 *> \par Further Details:
282 * =====================
283 *>
284 *> \verbatim
285 *>
286 *> The base representations are required to suffer very little
287 *> element growth and consequently define all their eigenvalues to
288 *> high relative accuracy.
289 *> \endverbatim
290 *
291 *> \par Contributors:
292 * ==================
293 *>
294 *> Beresford Parlett, University of California, Berkeley, USA \n
295 *> Jim Demmel, University of California, Berkeley, USA \n
296 *> Inderjit Dhillon, University of Texas, Austin, USA \n
297 *> Osni Marques, LBNL/NERSC, USA \n
298 *> Christof Voemel, University of California, Berkeley, USA \n
299 *>
300 * =====================================================================
301  SUBROUTINE slarre( RANGE, N, VL, VU, IL, IU, D, E, E2,
302  $ RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M,
303  $ W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN,
304  $ WORK, IWORK, INFO )
305 *
306 * -- LAPACK auxiliary routine --
307 * -- LAPACK is a software package provided by Univ. of Tennessee, --
308 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
309 *
310 * .. Scalar Arguments ..
311  CHARACTER RANGE
312  INTEGER IL, INFO, IU, M, N, NSPLIT
313  REAL PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU
314 * ..
315 * .. Array Arguments ..
316  INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ),
317  $ INDEXW( * )
318  REAL D( * ), E( * ), E2( * ), GERS( * ),
319  $ w( * ),werr( * ), wgap( * ), work( * )
320 * ..
321 *
322 * =====================================================================
323 *
324 * .. Parameters ..
325  REAL FAC, FOUR, FOURTH, FUDGE, HALF, HNDRD,
326  $ MAXGROWTH, ONE, PERT, TWO, ZERO
327  PARAMETER ( ZERO = 0.0e0, one = 1.0e0,
328  $ two = 2.0e0, four=4.0e0,
329  $ hndrd = 100.0e0,
330  $ pert = 4.0e0,
331  $ half = one/two, fourth = one/four, fac= half,
332  $ maxgrowth = 64.0e0, fudge = 2.0e0 )
333  INTEGER MAXTRY, ALLRNG, INDRNG, VALRNG
334  PARAMETER ( MAXTRY = 6, allrng = 1, indrng = 2,
335  $ valrng = 3 )
336 * ..
337 * .. Local Scalars ..
338  LOGICAL FORCEB, NOREP, USEDQD
339  INTEGER CNT, CNT1, CNT2, I, IBEGIN, IDUM, IEND, IINFO,
340  $ IN, INDL, INDU, IRANGE, J, JBLK, MB, MM,
341  $ wbegin, wend
342  REAL AVGAP, BSRTOL, CLWDTH, DMAX, DPIVOT, EABS,
343  $ EMAX, EOLD, EPS, GL, GU, ISLEFT, ISRGHT, RTL,
344  $ RTOL, S1, S2, SAFMIN, SGNDEF, SIGMA, SPDIAM,
345  $ tau, tmp, tmp1
346 
347 
348 * ..
349 * .. Local Arrays ..
350  INTEGER ISEED( 4 )
351 * ..
352 * .. External Functions ..
353  LOGICAL LSAME
354  REAL SLAMCH
355  EXTERNAL SLAMCH, LSAME
356 
357 * ..
358 * .. External Subroutines ..
359  EXTERNAL scopy, slarnv, slarra, slarrb, slarrc, slarrd,
360  $ slasq2, slarrk
361 * ..
362 * .. Intrinsic Functions ..
363  INTRINSIC abs, max, min
364 
365 * ..
366 * .. Executable Statements ..
367 *
368 
369  info = 0
370 *
371 * Quick return if possible
372 *
373  IF( n.LE.0 ) THEN
374  RETURN
375  END IF
376 *
377 * Decode RANGE
378 *
379  IF( lsame( range, 'A' ) ) THEN
380  irange = allrng
381  ELSE IF( lsame( range, 'V' ) ) THEN
382  irange = valrng
383  ELSE IF( lsame( range, 'I' ) ) THEN
384  irange = indrng
385  END IF
386 
387  m = 0
388 
389 * Get machine constants
390  safmin = slamch( 'S' )
391  eps = slamch( 'P' )
392 
393 * Set parameters
394  rtl = hndrd*eps
395 * If one were ever to ask for less initial precision in BSRTOL,
396 * one should keep in mind that for the subset case, the extremal
397 * eigenvalues must be at least as accurate as the current setting
398 * (eigenvalues in the middle need not as much accuracy)
399  bsrtol = sqrt(eps)*(0.5e-3)
400 
401 * Treat case of 1x1 matrix for quick return
402  IF( n.EQ.1 ) THEN
403  IF( (irange.EQ.allrng).OR.
404  $ ((irange.EQ.valrng).AND.(d(1).GT.vl).AND.(d(1).LE.vu)).OR.
405  $ ((irange.EQ.indrng).AND.(il.EQ.1).AND.(iu.EQ.1)) ) THEN
406  m = 1
407  w(1) = d(1)
408 * The computation error of the eigenvalue is zero
409  werr(1) = zero
410  wgap(1) = zero
411  iblock( 1 ) = 1
412  indexw( 1 ) = 1
413  gers(1) = d( 1 )
414  gers(2) = d( 1 )
415  ENDIF
416 * store the shift for the initial RRR, which is zero in this case
417  e(1) = zero
418  RETURN
419  END IF
420 
421 * General case: tridiagonal matrix of order > 1
422 *
423 * Init WERR, WGAP. Compute Gerschgorin intervals and spectral diameter.
424 * Compute maximum off-diagonal entry and pivmin.
425  gl = d(1)
426  gu = d(1)
427  eold = zero
428  emax = zero
429  e(n) = zero
430  DO 5 i = 1,n
431  werr(i) = zero
432  wgap(i) = zero
433  eabs = abs( e(i) )
434  IF( eabs .GE. emax ) THEN
435  emax = eabs
436  END IF
437  tmp1 = eabs + eold
438  gers( 2*i-1) = d(i) - tmp1
439  gl = min( gl, gers( 2*i - 1))
440  gers( 2*i ) = d(i) + tmp1
441  gu = max( gu, gers(2*i) )
442  eold = eabs
443  5 CONTINUE
444 * The minimum pivot allowed in the Sturm sequence for T
445  pivmin = safmin * max( one, emax**2 )
446 * Compute spectral diameter. The Gerschgorin bounds give an
447 * estimate that is wrong by at most a factor of SQRT(2)
448  spdiam = gu - gl
449 
450 * Compute splitting points
451  CALL slarra( n, d, e, e2, spltol, spdiam,
452  $ nsplit, isplit, iinfo )
453 
454 * Can force use of bisection instead of faster DQDS.
455 * Option left in the code for future multisection work.
456  forceb = .false.
457 
458 * Initialize USEDQD, DQDS should be used for ALLRNG unless someone
459 * explicitly wants bisection.
460  usedqd = (( irange.EQ.allrng ) .AND. (.NOT.forceb))
461 
462  IF( (irange.EQ.allrng) .AND. (.NOT. forceb) ) THEN
463 * Set interval [VL,VU] that contains all eigenvalues
464  vl = gl
465  vu = gu
466  ELSE
467 * We call SLARRD to find crude approximations to the eigenvalues
468 * in the desired range. In case IRANGE = INDRNG, we also obtain the
469 * interval (VL,VU] that contains all the wanted eigenvalues.
470 * An interval [LEFT,RIGHT] has converged if
471 * RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT))
472 * SLARRD needs a WORK of size 4*N, IWORK of size 3*N
473  CALL slarrd( range, 'B', n, vl, vu, il, iu, gers,
474  $ bsrtol, d, e, e2, pivmin, nsplit, isplit,
475  $ mm, w, werr, vl, vu, iblock, indexw,
476  $ work, iwork, iinfo )
477  IF( iinfo.NE.0 ) THEN
478  info = -1
479  RETURN
480  ENDIF
481 * Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0
482  DO 14 i = mm+1,n
483  w( i ) = zero
484  werr( i ) = zero
485  iblock( i ) = 0
486  indexw( i ) = 0
487  14 CONTINUE
488  END IF
489 
490 
491 ***
492 * Loop over unreduced blocks
493  ibegin = 1
494  wbegin = 1
495  DO 170 jblk = 1, nsplit
496  iend = isplit( jblk )
497  in = iend - ibegin + 1
498 
499 * 1 X 1 block
500  IF( in.EQ.1 ) THEN
501  IF( (irange.EQ.allrng).OR.( (irange.EQ.valrng).AND.
502  $ ( d( ibegin ).GT.vl ).AND.( d( ibegin ).LE.vu ) )
503  $ .OR. ( (irange.EQ.indrng).AND.(iblock(wbegin).EQ.jblk))
504  $ ) THEN
505  m = m + 1
506  w( m ) = d( ibegin )
507  werr(m) = zero
508 * The gap for a single block doesn't matter for the later
509 * algorithm and is assigned an arbitrary large value
510  wgap(m) = zero
511  iblock( m ) = jblk
512  indexw( m ) = 1
513  wbegin = wbegin + 1
514  ENDIF
515 * E( IEND ) holds the shift for the initial RRR
516  e( iend ) = zero
517  ibegin = iend + 1
518  GO TO 170
519  END IF
520 *
521 * Blocks of size larger than 1x1
522 *
523 * E( IEND ) will hold the shift for the initial RRR, for now set it =0
524  e( iend ) = zero
525 *
526 * Find local outer bounds GL,GU for the block
527  gl = d(ibegin)
528  gu = d(ibegin)
529  DO 15 i = ibegin , iend
530  gl = min( gers( 2*i-1 ), gl )
531  gu = max( gers( 2*i ), gu )
532  15 CONTINUE
533  spdiam = gu - gl
534 
535  IF(.NOT. ((irange.EQ.allrng).AND.(.NOT.forceb)) ) THEN
536 * Count the number of eigenvalues in the current block.
537  mb = 0
538  DO 20 i = wbegin,mm
539  IF( iblock(i).EQ.jblk ) THEN
540  mb = mb+1
541  ELSE
542  GOTO 21
543  ENDIF
544  20 CONTINUE
545  21 CONTINUE
546 
547  IF( mb.EQ.0) THEN
548 * No eigenvalue in the current block lies in the desired range
549 * E( IEND ) holds the shift for the initial RRR
550  e( iend ) = zero
551  ibegin = iend + 1
552  GO TO 170
553  ELSE
554 
555 * Decide whether dqds or bisection is more efficient
556  usedqd = ( (mb .GT. fac*in) .AND. (.NOT.forceb) )
557  wend = wbegin + mb - 1
558 * Calculate gaps for the current block
559 * In later stages, when representations for individual
560 * eigenvalues are different, we use SIGMA = E( IEND ).
561  sigma = zero
562  DO 30 i = wbegin, wend - 1
563  wgap( i ) = max( zero,
564  $ w(i+1)-werr(i+1) - (w(i)+werr(i)) )
565  30 CONTINUE
566  wgap( wend ) = max( zero,
567  $ vu - sigma - (w( wend )+werr( wend )))
568 * Find local index of the first and last desired evalue.
569  indl = indexw(wbegin)
570  indu = indexw( wend )
571  ENDIF
572  ENDIF
573  IF(( (irange.EQ.allrng) .AND. (.NOT. forceb) ).OR.usedqd) THEN
574 * Case of DQDS
575 * Find approximations to the extremal eigenvalues of the block
576  CALL slarrk( in, 1, gl, gu, d(ibegin),
577  $ e2(ibegin), pivmin, rtl, tmp, tmp1, iinfo )
578  IF( iinfo.NE.0 ) THEN
579  info = -1
580  RETURN
581  ENDIF
582  isleft = max(gl, tmp - tmp1
583  $ - hndrd * eps* abs(tmp - tmp1))
584 
585  CALL slarrk( in, in, gl, gu, d(ibegin),
586  $ e2(ibegin), pivmin, rtl, tmp, tmp1, iinfo )
587  IF( iinfo.NE.0 ) THEN
588  info = -1
589  RETURN
590  ENDIF
591  isrght = min(gu, tmp + tmp1
592  $ + hndrd * eps * abs(tmp + tmp1))
593 * Improve the estimate of the spectral diameter
594  spdiam = isrght - isleft
595  ELSE
596 * Case of bisection
597 * Find approximations to the wanted extremal eigenvalues
598  isleft = max(gl, w(wbegin) - werr(wbegin)
599  $ - hndrd * eps*abs(w(wbegin)- werr(wbegin) ))
600  isrght = min(gu,w(wend) + werr(wend)
601  $ + hndrd * eps * abs(w(wend)+ werr(wend)))
602  ENDIF
603 
604 
605 * Decide whether the base representation for the current block
606 * L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I
607 * should be on the left or the right end of the current block.
608 * The strategy is to shift to the end which is "more populated"
609 * Furthermore, decide whether to use DQDS for the computation of
610 * the eigenvalue approximations at the end of SLARRE or bisection.
611 * dqds is chosen if all eigenvalues are desired or the number of
612 * eigenvalues to be computed is large compared to the blocksize.
613  IF( ( irange.EQ.allrng ) .AND. (.NOT.forceb) ) THEN
614 * If all the eigenvalues have to be computed, we use dqd
615  usedqd = .true.
616 * INDL is the local index of the first eigenvalue to compute
617  indl = 1
618  indu = in
619 * MB = number of eigenvalues to compute
620  mb = in
621  wend = wbegin + mb - 1
622 * Define 1/4 and 3/4 points of the spectrum
623  s1 = isleft + fourth * spdiam
624  s2 = isrght - fourth * spdiam
625  ELSE
626 * SLARRD has computed IBLOCK and INDEXW for each eigenvalue
627 * approximation.
628 * choose sigma
629  IF( usedqd ) THEN
630  s1 = isleft + fourth * spdiam
631  s2 = isrght - fourth * spdiam
632  ELSE
633  tmp = min(isrght,vu) - max(isleft,vl)
634  s1 = max(isleft,vl) + fourth * tmp
635  s2 = min(isrght,vu) - fourth * tmp
636  ENDIF
637  ENDIF
638 
639 * Compute the negcount at the 1/4 and 3/4 points
640  IF(mb.GT.1) THEN
641  CALL slarrc( 'T', in, s1, s2, d(ibegin),
642  $ e(ibegin), pivmin, cnt, cnt1, cnt2, iinfo)
643  ENDIF
644 
645  IF(mb.EQ.1) THEN
646  sigma = gl
647  sgndef = one
648  ELSEIF( cnt1 - indl .GE. indu - cnt2 ) THEN
649  IF( ( irange.EQ.allrng ) .AND. (.NOT.forceb) ) THEN
650  sigma = max(isleft,gl)
651  ELSEIF( usedqd ) THEN
652 * use Gerschgorin bound as shift to get pos def matrix
653 * for dqds
654  sigma = isleft
655  ELSE
656 * use approximation of the first desired eigenvalue of the
657 * block as shift
658  sigma = max(isleft,vl)
659  ENDIF
660  sgndef = one
661  ELSE
662  IF( ( irange.EQ.allrng ) .AND. (.NOT.forceb) ) THEN
663  sigma = min(isrght,gu)
664  ELSEIF( usedqd ) THEN
665 * use Gerschgorin bound as shift to get neg def matrix
666 * for dqds
667  sigma = isrght
668  ELSE
669 * use approximation of the first desired eigenvalue of the
670 * block as shift
671  sigma = min(isrght,vu)
672  ENDIF
673  sgndef = -one
674  ENDIF
675 
676 
677 * An initial SIGMA has been chosen that will be used for computing
678 * T - SIGMA I = L D L^T
679 * Define the increment TAU of the shift in case the initial shift
680 * needs to be refined to obtain a factorization with not too much
681 * element growth.
682  IF( usedqd ) THEN
683 * The initial SIGMA was to the outer end of the spectrum
684 * the matrix is definite and we need not retreat.
685  tau = spdiam*eps*n + two*pivmin
686  tau = max( tau,two*eps*abs(sigma) )
687  ELSE
688  IF(mb.GT.1) THEN
689  clwdth = w(wend) + werr(wend) - w(wbegin) - werr(wbegin)
690  avgap = abs(clwdth / real(wend-wbegin))
691  IF( sgndef.EQ.one ) THEN
692  tau = half*max(wgap(wbegin),avgap)
693  tau = max(tau,werr(wbegin))
694  ELSE
695  tau = half*max(wgap(wend-1),avgap)
696  tau = max(tau,werr(wend))
697  ENDIF
698  ELSE
699  tau = werr(wbegin)
700  ENDIF
701  ENDIF
702 *
703  DO 80 idum = 1, maxtry
704 * Compute L D L^T factorization of tridiagonal matrix T - sigma I.
705 * Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of
706 * pivots in WORK(2*IN+1:3*IN)
707  dpivot = d( ibegin ) - sigma
708  work( 1 ) = dpivot
709  dmax = abs( work(1) )
710  j = ibegin
711  DO 70 i = 1, in - 1
712  work( 2*in+i ) = one / work( i )
713  tmp = e( j )*work( 2*in+i )
714  work( in+i ) = tmp
715  dpivot = ( d( j+1 )-sigma ) - tmp*e( j )
716  work( i+1 ) = dpivot
717  dmax = max( dmax, abs(dpivot) )
718  j = j + 1
719  70 CONTINUE
720 * check for element growth
721  IF( dmax .GT. maxgrowth*spdiam ) THEN
722  norep = .true.
723  ELSE
724  norep = .false.
725  ENDIF
726  IF( usedqd .AND. .NOT.norep ) THEN
727 * Ensure the definiteness of the representation
728 * All entries of D (of L D L^T) must have the same sign
729  DO 71 i = 1, in
730  tmp = sgndef*work( i )
731  IF( tmp.LT.zero ) norep = .true.
732  71 CONTINUE
733  ENDIF
734  IF(norep) THEN
735 * Note that in the case of IRANGE=ALLRNG, we use the Gerschgorin
736 * shift which makes the matrix definite. So we should end up
737 * here really only in the case of IRANGE = VALRNG or INDRNG.
738  IF( idum.EQ.maxtry-1 ) THEN
739  IF( sgndef.EQ.one ) THEN
740 * The fudged Gerschgorin shift should succeed
741  sigma =
742  $ gl - fudge*spdiam*eps*n - fudge*two*pivmin
743  ELSE
744  sigma =
745  $ gu + fudge*spdiam*eps*n + fudge*two*pivmin
746  END IF
747  ELSE
748  sigma = sigma - sgndef * tau
749  tau = two * tau
750  END IF
751  ELSE
752 * an initial RRR is found
753  GO TO 83
754  END IF
755  80 CONTINUE
756 * if the program reaches this point, no base representation could be
757 * found in MAXTRY iterations.
758  info = 2
759  RETURN
760 
761  83 CONTINUE
762 * At this point, we have found an initial base representation
763 * T - SIGMA I = L D L^T with not too much element growth.
764 * Store the shift.
765  e( iend ) = sigma
766 * Store D and L.
767  CALL scopy( in, work, 1, d( ibegin ), 1 )
768  CALL scopy( in-1, work( in+1 ), 1, e( ibegin ), 1 )
769 
770 
771  IF(mb.GT.1 ) THEN
772 *
773 * Perturb each entry of the base representation by a small
774 * (but random) relative amount to overcome difficulties with
775 * glued matrices.
776 *
777  DO 122 i = 1, 4
778  iseed( i ) = 1
779  122 CONTINUE
780 
781  CALL slarnv(2, iseed, 2*in-1, work(1))
782  DO 125 i = 1,in-1
783  d(ibegin+i-1) = d(ibegin+i-1)*(one+eps*pert*work(i))
784  e(ibegin+i-1) = e(ibegin+i-1)*(one+eps*pert*work(in+i))
785  125 CONTINUE
786  d(iend) = d(iend)*(one+eps*four*work(in))
787 *
788  ENDIF
789 *
790 * Don't update the Gerschgorin intervals because keeping track
791 * of the updates would be too much work in SLARRV.
792 * We update W instead and use it to locate the proper Gerschgorin
793 * intervals.
794 
795 * Compute the required eigenvalues of L D L' by bisection or dqds
796  IF ( .NOT.usedqd ) THEN
797 * If SLARRD has been used, shift the eigenvalue approximations
798 * according to their representation. This is necessary for
799 * a uniform SLARRV since dqds computes eigenvalues of the
800 * shifted representation. In SLARRV, W will always hold the
801 * UNshifted eigenvalue approximation.
802  DO 134 j=wbegin,wend
803  w(j) = w(j) - sigma
804  werr(j) = werr(j) + abs(w(j)) * eps
805  134 CONTINUE
806 * call SLARRB to reduce eigenvalue error of the approximations
807 * from SLARRD
808  DO 135 i = ibegin, iend-1
809  work( i ) = d( i ) * e( i )**2
810  135 CONTINUE
811 * use bisection to find EV from INDL to INDU
812  CALL slarrb(in, d(ibegin), work(ibegin),
813  $ indl, indu, rtol1, rtol2, indl-1,
814  $ w(wbegin), wgap(wbegin), werr(wbegin),
815  $ work( 2*n+1 ), iwork, pivmin, spdiam,
816  $ in, iinfo )
817  IF( iinfo .NE. 0 ) THEN
818  info = -4
819  RETURN
820  END IF
821 * SLARRB computes all gaps correctly except for the last one
822 * Record distance to VU/GU
823  wgap( wend ) = max( zero,
824  $ ( vu-sigma ) - ( w( wend ) + werr( wend ) ) )
825  DO 138 i = indl, indu
826  m = m + 1
827  iblock(m) = jblk
828  indexw(m) = i
829  138 CONTINUE
830  ELSE
831 * Call dqds to get all eigs (and then possibly delete unwanted
832 * eigenvalues).
833 * Note that dqds finds the eigenvalues of the L D L^T representation
834 * of T to high relative accuracy. High relative accuracy
835 * might be lost when the shift of the RRR is subtracted to obtain
836 * the eigenvalues of T. However, T is not guaranteed to define its
837 * eigenvalues to high relative accuracy anyway.
838 * Set RTOL to the order of the tolerance used in SLASQ2
839 * This is an ESTIMATED error, the worst case bound is 4*N*EPS
840 * which is usually too large and requires unnecessary work to be
841 * done by bisection when computing the eigenvectors
842  rtol = log(real(in)) * four * eps
843  j = ibegin
844  DO 140 i = 1, in - 1
845  work( 2*i-1 ) = abs( d( j ) )
846  work( 2*i ) = e( j )*e( j )*work( 2*i-1 )
847  j = j + 1
848  140 CONTINUE
849  work( 2*in-1 ) = abs( d( iend ) )
850  work( 2*in ) = zero
851  CALL slasq2( in, work, iinfo )
852  IF( iinfo .NE. 0 ) THEN
853 * If IINFO = -5 then an index is part of a tight cluster
854 * and should be changed. The index is in IWORK(1) and the
855 * gap is in WORK(N+1)
856  info = -5
857  RETURN
858  ELSE
859 * Test that all eigenvalues are positive as expected
860  DO 149 i = 1, in
861  IF( work( i ).LT.zero ) THEN
862  info = -6
863  RETURN
864  ENDIF
865  149 CONTINUE
866  END IF
867  IF( sgndef.GT.zero ) THEN
868  DO 150 i = indl, indu
869  m = m + 1
870  w( m ) = work( in-i+1 )
871  iblock( m ) = jblk
872  indexw( m ) = i
873  150 CONTINUE
874  ELSE
875  DO 160 i = indl, indu
876  m = m + 1
877  w( m ) = -work( i )
878  iblock( m ) = jblk
879  indexw( m ) = i
880  160 CONTINUE
881  END IF
882 
883  DO 165 i = m - mb + 1, m
884 * the value of RTOL below should be the tolerance in SLASQ2
885  werr( i ) = rtol * abs( w(i) )
886  165 CONTINUE
887  DO 166 i = m - mb + 1, m - 1
888 * compute the right gap between the intervals
889  wgap( i ) = max( zero,
890  $ w(i+1)-werr(i+1) - (w(i)+werr(i)) )
891  166 CONTINUE
892  wgap( m ) = max( zero,
893  $ ( vu-sigma ) - ( w( m ) + werr( m ) ) )
894  END IF
895 * proceed with next block
896  ibegin = iend + 1
897  wbegin = wend + 1
898  170 CONTINUE
899 *
900 
901  RETURN
902 *
903 * end of SLARRE
904 *
905  END
subroutine slarrd(RANGE, ORDER, N, VL, VU, IL, IU, GERS, RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT, M, W, WERR, WL, WU, IBLOCK, INDEXW, WORK, IWORK, INFO)
SLARRD computes the eigenvalues of a symmetric tridiagonal matrix to suitable accuracy.
Definition: slarrd.f:329
subroutine slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition: slarnv.f:97
subroutine slarrc(JOBT, N, VL, VU, D, E, PIVMIN, EIGCNT, LCNT, RCNT, INFO)
SLARRC computes the number of eigenvalues of the symmetric tridiagonal matrix.
Definition: slarrc.f:137
subroutine slarre(RANGE, N, VL, VU, IL, IU, D, E, E2, RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M, W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN, WORK, IWORK, INFO)
SLARRE given the tridiagonal matrix T, sets small off-diagonal elements to zero and for each unreduce...
Definition: slarre.f:305
subroutine slarra(N, D, E, E2, SPLTOL, TNRM, NSPLIT, ISPLIT, INFO)
SLARRA computes the splitting points with the specified threshold.
Definition: slarra.f:136
subroutine slarrk(N, IW, GL, GU, D, E2, PIVMIN, RELTOL, W, WERR, INFO)
SLARRK computes one eigenvalue of a symmetric tridiagonal matrix T to suitable accuracy.
Definition: slarrk.f:145
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:196
subroutine slasq2(N, Z, INFO)
SLASQ2 computes all the eigenvalues of the symmetric positive definite tridiagonal matrix associated ...
Definition: slasq2.f:112
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
Definition: scopy.f:82