LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ slarre()

subroutine slarre ( character  range,
integer  n,
real  vl,
real  vu,
integer  il,
integer  iu,
real, dimension( * )  d,
real, dimension( * )  e,
real, dimension( * )  e2,
real  rtol1,
real  rtol2,
real  spltol,
integer  nsplit,
integer, dimension( * )  isplit,
integer  m,
real, dimension( * )  w,
real, dimension( * )  werr,
real, dimension( * )  wgap,
integer, dimension( * )  iblock,
integer, dimension( * )  indexw,
real, dimension( * )  gers,
real  pivmin,
real, dimension( * )  work,
integer, dimension( * )  iwork,
integer  info 
)

SLARRE given the tridiagonal matrix T, sets small off-diagonal elements to zero and for each unreduced block Ti, finds base representations and eigenvalues.

Download SLARRE + dependencies [TGZ] [ZIP] [TXT]

Purpose:
 To find the desired eigenvalues of a given real symmetric
 tridiagonal matrix T, SLARRE sets any "small" off-diagonal
 elements to zero, and for each unreduced block T_i, it finds
 (a) a suitable shift at one end of the block's spectrum,
 (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and
 (c) eigenvalues of each L_i D_i L_i^T.
 The representations and eigenvalues found are then used by
 SSTEMR to compute the eigenvectors of T.
 The accuracy varies depending on whether bisection is used to
 find a few eigenvalues or the dqds algorithm (subroutine SLASQ2) to
 compute all and then discard any unwanted one.
 As an added benefit, SLARRE also outputs the n
 Gerschgorin intervals for the matrices L_i D_i L_i^T.
Parameters
[in]RANGE
          RANGE is CHARACTER*1
          = 'A': ("All")   all eigenvalues will be found.
          = 'V': ("Value") all eigenvalues in the half-open interval
                           (VL, VU] will be found.
          = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
                           entire matrix) will be found.
[in]N
          N is INTEGER
          The order of the matrix. N > 0.
[in,out]VL
          VL is REAL
          If RANGE='V', the lower bound for the eigenvalues.
          Eigenvalues less than or equal to VL, or greater than VU,
          will not be returned.  VL < VU.
          If RANGE='I' or ='A', SLARRE computes bounds on the desired
          part of the spectrum.
[in,out]VU
          VU is REAL
          If RANGE='V', the upper bound for the eigenvalues.
          Eigenvalues less than or equal to VL, or greater than VU,
          will not be returned.  VL < VU.
          If RANGE='I' or ='A', SLARRE computes bounds on the desired
          part of the spectrum.
[in]IL
          IL is INTEGER
          If RANGE='I', the index of the
          smallest eigenvalue to be returned.
          1 <= IL <= IU <= N.
[in]IU
          IU is INTEGER
          If RANGE='I', the index of the
          largest eigenvalue to be returned.
          1 <= IL <= IU <= N.
[in,out]D
          D is REAL array, dimension (N)
          On entry, the N diagonal elements of the tridiagonal
          matrix T.
          On exit, the N diagonal elements of the diagonal
          matrices D_i.
[in,out]E
          E is REAL array, dimension (N)
          On entry, the first (N-1) entries contain the subdiagonal
          elements of the tridiagonal matrix T; E(N) need not be set.
          On exit, E contains the subdiagonal elements of the unit
          bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),
          1 <= I <= NSPLIT, contain the base points sigma_i on output.
[in,out]E2
          E2 is REAL array, dimension (N)
          On entry, the first (N-1) entries contain the SQUARES of the
          subdiagonal elements of the tridiagonal matrix T;
          E2(N) need not be set.
          On exit, the entries E2( ISPLIT( I ) ),
          1 <= I <= NSPLIT, have been set to zero
[in]RTOL1
          RTOL1 is REAL
[in]RTOL2
          RTOL2 is REAL
           Parameters for bisection.
           An interval [LEFT,RIGHT] has converged if
           RIGHT-LEFT < MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
[in]SPLTOL
          SPLTOL is REAL
          The threshold for splitting.
[out]NSPLIT
          NSPLIT is INTEGER
          The number of blocks T splits into. 1 <= NSPLIT <= N.
[out]ISPLIT
          ISPLIT is INTEGER array, dimension (N)
          The splitting points, at which T breaks up into blocks.
          The first block consists of rows/columns 1 to ISPLIT(1),
          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
          etc., and the NSPLIT-th consists of rows/columns
          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
[out]M
          M is INTEGER
          The total number of eigenvalues (of all L_i D_i L_i^T)
          found.
[out]W
          W is REAL array, dimension (N)
          The first M elements contain the eigenvalues. The
          eigenvalues of each of the blocks, L_i D_i L_i^T, are
          sorted in ascending order ( SLARRE may use the
          remaining N-M elements as workspace).
[out]WERR
          WERR is REAL array, dimension (N)
          The error bound on the corresponding eigenvalue in W.
[out]WGAP
          WGAP is REAL array, dimension (N)
          The separation from the right neighbor eigenvalue in W.
          The gap is only with respect to the eigenvalues of the same block
          as each block has its own representation tree.
          Exception: at the right end of a block we store the left gap
[out]IBLOCK
          IBLOCK is INTEGER array, dimension (N)
          The indices of the blocks (submatrices) associated with the
          corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
          W(i) belongs to the first block from the top, =2 if W(i)
          belongs to the second block, etc.
[out]INDEXW
          INDEXW is INTEGER array, dimension (N)
          The indices of the eigenvalues within each block (submatrix);
          for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
          i-th eigenvalue W(i) is the 10-th eigenvalue in block 2
[out]GERS
          GERS is REAL array, dimension (2*N)
          The N Gerschgorin intervals (the i-th Gerschgorin interval
          is (GERS(2*i-1), GERS(2*i)).
[out]PIVMIN
          PIVMIN is REAL
          The minimum pivot in the Sturm sequence for T.
[out]WORK
          WORK is REAL array, dimension (6*N)
          Workspace.
[out]IWORK
          IWORK is INTEGER array, dimension (5*N)
          Workspace.
[out]INFO
          INFO is INTEGER
          = 0:  successful exit
          > 0:  A problem occurred in SLARRE.
          < 0:  One of the called subroutines signaled an internal problem.
                Needs inspection of the corresponding parameter IINFO
                for further information.

          =-1:  Problem in SLARRD.
          = 2:  No base representation could be found in MAXTRY iterations.
                Increasing MAXTRY and recompilation might be a remedy.
          =-3:  Problem in SLARRB when computing the refined root
                representation for SLASQ2.
          =-4:  Problem in SLARRB when preforming bisection on the
                desired part of the spectrum.
          =-5:  Problem in SLASQ2.
          =-6:  Problem in SLASQ2.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
  The base representations are required to suffer very little
  element growth and consequently define all their eigenvalues to
  high relative accuracy.
Contributors:
Beresford Parlett, University of California, Berkeley, USA
Jim Demmel, University of California, Berkeley, USA
Inderjit Dhillon, University of Texas, Austin, USA
Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA

Definition at line 301 of file slarre.f.

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 nsplit = 0
371 m = 0
372*
373* Quick return if possible
374*
375 IF( n.LE.0 ) THEN
376 RETURN
377 END IF
378*
379* Decode RANGE
380*
381 IF( lsame( range, 'A' ) ) THEN
382 irange = allrng
383 ELSE IF( lsame( range, 'V' ) ) THEN
384 irange = valrng
385 ELSE IF( lsame( range, 'I' ) ) THEN
386 irange = indrng
387 END IF
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*
subroutine scopy(n, sx, incx, sy, incy)
SCOPY
Definition scopy.f:82
real function slamch(cmach)
SLAMCH
Definition slamch.f:68
subroutine slarnv(idist, iseed, n, x)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition slarnv.f:97
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 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 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 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 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 slasq2(n, z, info)
SLASQ2 computes all the eigenvalues of the symmetric positive definite tridiagonal matrix associated ...
Definition slasq2.f:112
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
Here is the call graph for this function:
Here is the caller graph for this function: