403 $ IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ,
404 $ WORK, LWORK, RWORK, LRWORK, IWORK,
414 CHARACTER JOBZ, RANGE, UPLO
415 INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LRWORK, LWORK,
417 DOUBLE PRECISION ABSTOL, VL, VU
420 INTEGER ISUPPZ( * ), IWORK( * )
421 DOUBLE PRECISION RWORK( * ), W( * )
422 COMPLEX*16 A( LDA, * ), WORK( * ), Z( LDZ, * )
428 DOUBLE PRECISION ZERO, ONE, TWO
429 PARAMETER ( ZERO = 0.0d+0, one = 1.0d+0, two = 2.0d+0 )
432 LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG,
435 INTEGER I, IEEEOK, IINFO, IMAX, INDIBL, INDIFL, INDISP,
436 $ INDIWO, INDRD, INDRDD, INDRE, INDREE, INDRWK,
437 $ indtau, indwk, indwkn, iscale, itmp1, j, jj,
438 $ liwmin, llwork, llrwork, llwrkn, lrwmin,
439 $ lwmin, nsplit, lhtrd, lwtrd, kd, ib, indhous
440 DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
441 $ SIGMA, SMLNUM, TMP1, VLL, VUU
445 INTEGER ILAENV, ILAENV2STAGE
446 DOUBLE PRECISION DLAMCH, ZLANSY
447 EXTERNAL lsame, dlamch, zlansy, ilaenv, ilaenv2stage
454 INTRINSIC dble, max, min, sqrt
460 ieeeok = ilaenv( 10,
'ZHEEVR',
'N', 1, 2, 3, 4 )
462 lower = lsame( uplo,
'L' )
463 wantz = lsame( jobz,
'V' )
464 alleig = lsame( range,
'A' )
465 valeig = lsame( range,
'V' )
466 indeig = lsame( range,
'I' )
468 lquery = ( ( lwork.EQ.-1 ) .OR. ( lrwork.EQ.-1 ) .OR.
471 kd = ilaenv2stage( 1,
'ZHETRD_2STAGE', jobz, n, -1, -1, -1 )
472 ib = ilaenv2stage( 2,
'ZHETRD_2STAGE', jobz, n, kd, -1, -1 )
473 lhtrd = ilaenv2stage( 3,
'ZHETRD_2STAGE', jobz, n, kd, ib, -1 )
474 lwtrd = ilaenv2stage( 4,
'ZHETRD_2STAGE', jobz, n, kd, ib, -1 )
475 lwmin = n + lhtrd + lwtrd
476 lrwmin = max( 1, 24*n )
477 liwmin = max( 1, 10*n )
480 IF( .NOT.( lsame( jobz,
'N' ) ) )
THEN
482 ELSE IF( .NOT.( alleig .OR. valeig .OR. indeig ) )
THEN
484 ELSE IF( .NOT.( lower .OR. lsame( uplo,
'U' ) ) )
THEN
486 ELSE IF( n.LT.0 )
THEN
488 ELSE IF( lda.LT.max( 1, n ) )
THEN
492 IF( n.GT.0 .AND. vu.LE.vl )
494 ELSE IF( indeig )
THEN
495 IF( il.LT.1 .OR. il.GT.max( 1, n ) )
THEN
497 ELSE IF( iu.LT.min( n, il ) .OR. iu.GT.n )
THEN
503 IF( ldz.LT.1 .OR. ( wantz .AND. ldz.LT.n ) )
THEN
513 IF( lwork.LT.lwmin .AND. .NOT.lquery )
THEN
515 ELSE IF( lrwork.LT.lrwmin .AND. .NOT.lquery )
THEN
517 ELSE IF( liwork.LT.liwmin .AND. .NOT.lquery )
THEN
523 CALL xerbla(
'ZHEEVR_2STAGE', -info )
525 ELSE IF( lquery )
THEN
539 IF( alleig .OR. indeig )
THEN
541 w( 1 ) = dble( a( 1, 1 ) )
543 IF( vl.LT.dble( a( 1, 1 ) ) .AND. vu.GE.dble( a( 1, 1 ) ) )
546 w( 1 ) = dble( a( 1, 1 ) )
559 safmin = dlamch(
'Safe minimum' )
560 eps = dlamch(
'Precision' )
561 smlnum = safmin / eps
562 bignum = one / smlnum
563 rmin = sqrt( smlnum )
564 rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
574 anrm = zlansy(
'M', uplo, n, a, lda, rwork )
575 IF( anrm.GT.zero .AND. anrm.LT.rmin )
THEN
578 ELSE IF( anrm.GT.rmax )
THEN
582 IF( iscale.EQ.1 )
THEN
585 CALL zdscal( n-j+1, sigma, a( j, j ), 1 )
589 CALL zdscal( j, sigma, a( 1, j ), 1 )
593 $ abstll = abstol*sigma
609 indwk = indhous + lhtrd
610 llwork = lwork - indwk + 1
627 llrwork = lrwork - indrwk + 1
647 $ rwork( indre ), work( indtau ),
648 $ work( indhous ), lhtrd,
649 $ work( indwk ), llwork, iinfo )
656 IF( il.EQ.1 .AND. iu.EQ.n )
THEN
660 IF( ( alleig.OR.test ) .AND. ( ieeeok.EQ.1 ) )
THEN
661 IF( .NOT.wantz )
THEN
662 CALL dcopy( n, rwork( indrd ), 1, w, 1 )
663 CALL dcopy( n-1, rwork( indre ), 1, rwork( indree ), 1 )
664 CALL dsterf( n, w, rwork( indree ), info )
666 CALL dcopy( n-1, rwork( indre ), 1, rwork( indree ), 1 )
667 CALL dcopy( n, rwork( indrd ), 1, rwork( indrdd ), 1 )
669 IF (abstol .LE. two*n*eps)
THEN
674 CALL zstemr( jobz,
'A', n, rwork( indrdd ),
675 $ rwork( indree ), vl, vu, il, iu, m, w,
676 $ z, ldz, n, isuppz, tryrac,
677 $ rwork( indrwk ), llrwork,
678 $ iwork, liwork, info )
683 IF( wantz .AND. info.EQ.0 )
THEN
685 llwrkn = lwork - indwkn + 1
686 CALL zunmtr(
'L', uplo,
'N', n, m, a, lda,
687 $ work( indtau ), z, ldz, work( indwkn ),
709 CALL dstebz( range, order, n, vll, vuu, il, iu, abstll,
710 $ rwork( indrd ), rwork( indre ), m, nsplit, w,
711 $ iwork( indibl ), iwork( indisp ), rwork( indrwk ),
712 $ iwork( indiwo ), info )
715 CALL zstein( n, rwork( indrd ), rwork( indre ), m, w,
716 $ iwork( indibl ), iwork( indisp ), z, ldz,
717 $ rwork( indrwk ), iwork( indiwo ), iwork( indifl ),
724 llwrkn = lwork - indwkn + 1
725 CALL zunmtr(
'L', uplo,
'N', n, m, a, lda, work( indtau ), z,
726 $ ldz, work( indwkn ), llwrkn, iinfo )
732 IF( iscale.EQ.1 )
THEN
738 CALL dscal( imax, one / sigma, w, 1 )
749 IF( w( jj ).LT.tmp1 )
THEN
756 itmp1 = iwork( indibl+i-1 )
758 iwork( indibl+i-1 ) = iwork( indibl+j-1 )
760 iwork( indibl+j-1 ) = itmp1
761 CALL zswap( n, z( 1, i ), 1, z( 1, j ), 1 )
subroutine xerbla(srname, info)
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
subroutine zheevr_2stage(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz, isuppz, work, lwork, rwork, lrwork, iwork, liwork, info)
ZHEEVR_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE mat...
subroutine zhetrd_2stage(vect, uplo, n, a, lda, d, e, tau, hous2, lhous2, work, lwork, info)
ZHETRD_2STAGE
subroutine dscal(n, da, dx, incx)
DSCAL
subroutine zdscal(n, da, zx, incx)
ZDSCAL
subroutine dstebz(range, order, n, vl, vu, il, iu, abstol, d, e, m, nsplit, w, iblock, isplit, work, iwork, info)
DSTEBZ
subroutine zstein(n, d, e, m, w, iblock, isplit, z, ldz, work, iwork, ifail, info)
ZSTEIN
subroutine zstemr(jobz, range, n, d, e, vl, vu, il, iu, m, w, z, ldz, nzc, isuppz, tryrac, work, lwork, iwork, liwork, info)
ZSTEMR
subroutine dsterf(n, d, e, info)
DSTERF
subroutine zswap(n, zx, incx, zy, incy)
ZSWAP
subroutine zunmtr(side, uplo, trans, m, n, a, lda, tau, c, ldc, work, lwork, info)
ZUNMTR