404 SUBROUTINE cheevr_2stage( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU,
405 $ il, iu, abstol, m, w, z, ldz, isuppz,
406 $ work, lwork, rwork, lrwork, iwork,
417 CHARACTER JOBZ, RANGE, UPLO
418 INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LRWORK, LWORK,
423 INTEGER ISUPPZ( * ), IWORK( * )
424 REAL RWORK( * ), W( * )
425 COMPLEX A( lda, * ), WORK( * ), Z( ldz, * )
432 parameter ( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0 )
435 LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG,
438 INTEGER I, IEEEOK, IINFO, IMAX, INDIBL, INDIFL, INDISP,
439 $ indiwo, indrd, indrdd, indre, indree, indrwk,
440 $ indtau, indwk, indwkn, iscale, itmp1, j, jj,
441 $ liwmin, llwork, llrwork, llwrkn, lrwmin,
442 $ lwmin, nsplit, lhtrd, lwtrd, kd, ib, indhous
443 REAL ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
444 $ sigma, smlnum, tmp1, vll, vuu
450 EXTERNAL lsame, ilaenv, slamch, clansy
457 INTRINSIC REAL, MAX, MIN, SQRT
463 ieeeok = ilaenv( 10,
'CHEEVR',
'N', 1, 2, 3, 4 )
465 lower = lsame( uplo,
'L' )
466 wantz = lsame( jobz,
'V' )
467 alleig = lsame( range,
'A' )
468 valeig = lsame( range,
'V' )
469 indeig = lsame( range,
'I' )
471 lquery = ( ( lwork.EQ.-1 ) .OR. ( lrwork.EQ.-1 ) .OR.
474 kd = ilaenv( 17,
'DSYTRD_2STAGE', jobz, n, -1, -1, -1 )
475 ib = ilaenv( 18,
'DSYTRD_2STAGE', jobz, n, kd, -1, -1 )
476 lhtrd = ilaenv( 19,
'DSYTRD_2STAGE', jobz, n, kd, ib, -1 )
477 lwtrd = ilaenv( 20,
'DSYTRD_2STAGE', jobz, n, kd, ib, -1 )
478 lwmin = n + lhtrd + lwtrd
479 lrwmin = max( 1, 24*n )
480 liwmin = max( 1, 10*n )
483 IF( .NOT.( lsame( jobz,
'N' ) ) )
THEN
485 ELSE IF( .NOT.( alleig .OR. valeig .OR. indeig ) )
THEN
487 ELSE IF( .NOT.( lower .OR. lsame( uplo,
'U' ) ) )
THEN
489 ELSE IF( n.LT.0 )
THEN
491 ELSE IF( lda.LT.max( 1, n ) )
THEN
495 IF( n.GT.0 .AND. vu.LE.vl )
497 ELSE IF( indeig )
THEN
498 IF( il.LT.1 .OR. il.GT.max( 1, n ) )
THEN
500 ELSE IF( iu.LT.min( n, il ) .OR. iu.GT.n )
THEN
506 IF( ldz.LT.1 .OR. ( wantz .AND. ldz.LT.n ) )
THEN
516 IF( lwork.LT.lwmin .AND. .NOT.lquery )
THEN
518 ELSE IF( lrwork.LT.lrwmin .AND. .NOT.lquery )
THEN
520 ELSE IF( liwork.LT.liwmin .AND. .NOT.lquery )
THEN
526 CALL xerbla(
'CHEEVR_2STAGE', -info )
528 ELSE IF( lquery )
THEN
542 IF( alleig .OR. indeig )
THEN
544 w( 1 ) =
REAL( A( 1, 1 ) )
546 IF( vl.LT.
REAL( A( 1, 1 ) ) .AND. VU.GE.
REAL( A( 1, 1 ) ) )
549 w( 1 ) =
REAL( A( 1, 1 ) )
562 safmin = slamch(
'Safe minimum' )
563 eps = slamch(
'Precision' )
564 smlnum = safmin / eps
565 bignum = one / smlnum
566 rmin = sqrt( smlnum )
567 rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
577 anrm = clansy(
'M', uplo, n, a, lda, rwork )
578 IF( anrm.GT.zero .AND. anrm.LT.rmin )
THEN
581 ELSE IF( anrm.GT.rmax )
THEN
585 IF( iscale.EQ.1 )
THEN
588 CALL csscal( n-j+1, sigma, a( j, j ), 1 )
592 CALL csscal( j, sigma, a( 1, j ), 1 )
596 $ abstll = abstol*sigma
612 indwk = indhous + lhtrd
613 llwork = lwork - indwk + 1
630 llrwork = lrwork - indrwk + 1
650 $ rwork( indre ), work( indtau ),
651 $ work( indhous ), lhtrd,
652 $ work( indwk ), llwork, iinfo )
659 IF( il.EQ.1 .AND. iu.EQ.n )
THEN
663 IF( ( alleig.OR.test ) .AND. ( ieeeok.EQ.1 ) )
THEN
664 IF( .NOT.wantz )
THEN
665 CALL scopy( n, rwork( indrd ), 1, w, 1 )
666 CALL scopy( n-1, rwork( indre ), 1, rwork( indree ), 1 )
667 CALL ssterf( n, w, rwork( indree ), info )
669 CALL scopy( n-1, rwork( indre ), 1, rwork( indree ), 1 )
670 CALL scopy( n, rwork( indrd ), 1, rwork( indrdd ), 1 )
672 IF (abstol .LE. two*n*eps)
THEN
677 CALL cstemr( jobz,
'A', n, rwork( indrdd ),
678 $ rwork( indree ), vl, vu, il, iu, m, w,
679 $ z, ldz, n, isuppz, tryrac,
680 $ rwork( indrwk ), llrwork,
681 $ iwork, liwork, info )
686 IF( wantz .AND. info.EQ.0 )
THEN
688 llwrkn = lwork - indwkn + 1
689 CALL cunmtr(
'L', uplo,
'N', n, m, a, lda,
690 $ work( indtau ), z, ldz, work( indwkn ),
712 CALL sstebz( range, order, n, vll, vuu, il, iu, abstll,
713 $ rwork( indrd ), rwork( indre ), m, nsplit, w,
714 $ iwork( indibl ), iwork( indisp ), rwork( indrwk ),
715 $ iwork( indiwo ), info )
718 CALL cstein( n, rwork( indrd ), rwork( indre ), m, w,
719 $ iwork( indibl ), iwork( indisp ), z, ldz,
720 $ rwork( indrwk ), iwork( indiwo ), iwork( indifl ),
727 llwrkn = lwork - indwkn + 1
728 CALL cunmtr(
'L', uplo,
'N', n, m, a, lda, work( indtau ), z,
729 $ ldz, work( indwkn ), llwrkn, iinfo )
735 IF( iscale.EQ.1 )
THEN
741 CALL sscal( imax, one / sigma, w, 1 )
752 IF( w( jj ).LT.tmp1 )
THEN
759 itmp1 = iwork( indibl+i-1 )
761 iwork( indibl+i-1 ) = iwork( indibl+j-1 )
763 iwork( indibl+j-1 ) = itmp1
764 CALL cswap( n, z( 1, i ), 1, z( 1, j ), 1 )
subroutine cstein(N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO)
CSTEIN
subroutine cheevr_2stage(JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO)
CHEEVR_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE ma...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine chetrd_2stage(VECT, UPLO, N, A, LDA, D, E, TAU, HOUS2, LHOUS2, WORK, LWORK, INFO)
CHETRD_2STAGE
subroutine sstebz(RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, INFO)
SSTEBZ
subroutine sscal(N, SA, SX, INCX)
SSCAL
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
subroutine ssterf(N, D, E, INFO)
SSTERF
subroutine cunmtr(SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
CUNMTR
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine cstemr(JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO)
CSTEMR
subroutine csscal(N, SA, CX, INCX)
CSSCAL