347 SUBROUTINE zheevr( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
348 $ abstol, m, w, z, ldz, isuppz, work, lwork,
349 $ rwork, lrwork, iwork, liwork, info )
357 CHARACTER JOBZ, RANGE, UPLO
358 INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LRWORK, LWORK,
360 DOUBLE PRECISION ABSTOL, VL, VU
363 INTEGER ISUPPZ( * ), IWORK( * )
364 DOUBLE PRECISION RWORK( * ), W( * )
365 COMPLEX*16 A( lda, * ), WORK( * ), Z( ldz, * )
371 DOUBLE PRECISION ZERO, ONE, TWO
372 parameter( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0 )
375 LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG,
378 INTEGER I, IEEEOK, IINFO, IMAX, INDIBL, INDIFL, INDISP,
379 $ indiwo, indrd, indrdd, indre, indree, indrwk,
380 $ indtau, indwk, indwkn, iscale, itmp1, j, jj,
381 $ liwmin, llwork, llrwork, llwrkn, lrwmin,
382 $ lwkopt, lwmin, nb, nsplit
383 DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
384 $ sigma, smlnum, tmp1, vll, vuu
389 DOUBLE PRECISION DLAMCH, ZLANSY
390 EXTERNAL lsame, ilaenv, dlamch, zlansy
397 INTRINSIC dble, max, min, sqrt
403 ieeeok = ilaenv( 10,
'ZHEEVR',
'N', 1, 2, 3, 4 )
405 lower = lsame( uplo,
'L' )
406 wantz = lsame( jobz,
'V' )
407 alleig = lsame( range,
'A' )
408 valeig = lsame( range,
'V' )
409 indeig = lsame( range,
'I' )
411 lquery = ( ( lwork.EQ.-1 ) .OR. ( lrwork.EQ.-1 ) .OR.
414 lrwmin = max( 1, 24*n )
415 liwmin = max( 1, 10*n )
416 lwmin = max( 1, 2*n )
419 IF( .NOT.( wantz .OR. lsame( jobz,
'N' ) ) )
THEN
421 ELSE IF( .NOT.( alleig .OR. valeig .OR. indeig ) )
THEN
423 ELSE IF( .NOT.( lower .OR. lsame( uplo,
'U' ) ) )
THEN
425 ELSE IF( n.LT.0 )
THEN
427 ELSE IF( lda.LT.max( 1, n ) )
THEN
431 IF( n.GT.0 .AND. vu.LE.vl )
433 ELSE IF( indeig )
THEN
434 IF( il.LT.1 .OR. il.GT.max( 1, n ) )
THEN
436 ELSE IF( iu.LT.min( n, il ) .OR. iu.GT.n )
THEN
442 IF( ldz.LT.1 .OR. ( wantz .AND. ldz.LT.n ) )
THEN
448 nb = ilaenv( 1,
'ZHETRD', uplo, n, -1, -1, -1 )
449 nb = max( nb, ilaenv( 1,
'ZUNMTR', uplo, n, -1, -1, -1 ) )
450 lwkopt = max( ( nb+1 )*n, lwmin )
455 IF( lwork.LT.lwmin .AND. .NOT.lquery )
THEN
457 ELSE IF( lrwork.LT.lrwmin .AND. .NOT.lquery )
THEN
459 ELSE IF( liwork.LT.liwmin .AND. .NOT.lquery )
THEN
465 CALL
xerbla(
'ZHEEVR', -info )
467 ELSE IF( lquery )
THEN
481 IF( alleig .OR. indeig )
THEN
483 w( 1 ) = dble( a( 1, 1 ) )
485 IF( vl.LT.dble( a( 1, 1 ) ) .AND. vu.GE.dble( a( 1, 1 ) ) )
488 w( 1 ) = dble( a( 1, 1 ) )
501 safmin = dlamch(
'Safe minimum' )
502 eps = dlamch(
'Precision' )
503 smlnum = safmin / eps
504 bignum = one / smlnum
505 rmin = sqrt( smlnum )
506 rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
516 anrm = zlansy(
'M', uplo, n, a, lda, rwork )
517 IF( anrm.GT.zero .AND. anrm.LT.rmin )
THEN
520 ELSE IF( anrm.GT.rmax )
THEN
524 IF( iscale.EQ.1 )
THEN
527 CALL
zdscal( n-j+1, sigma, a( j, j ), 1 )
531 CALL
zdscal( j, sigma, a( 1, j ), 1 )
535 $ abstll = abstol*sigma
551 llwork = lwork - indwk + 1
568 llrwork = lrwork - indrwk + 1
587 CALL
zhetrd( uplo, n, a, lda, rwork( indrd ), rwork( indre ),
588 $ work( indtau ), work( indwk ), llwork, iinfo )
595 IF( il.EQ.1 .AND. iu.EQ.n )
THEN
599 IF( ( alleig.OR.test ) .AND. ( ieeeok.EQ.1 ) )
THEN
600 IF( .NOT.wantz )
THEN
601 CALL
dcopy( n, rwork( indrd ), 1, w, 1 )
602 CALL
dcopy( n-1, rwork( indre ), 1, rwork( indree ), 1 )
603 CALL
dsterf( n, w, rwork( indree ), info )
605 CALL
dcopy( n-1, rwork( indre ), 1, rwork( indree ), 1 )
606 CALL
dcopy( n, rwork( indrd ), 1, rwork( indrdd ), 1 )
608 IF (abstol .LE. two*n*eps)
THEN
613 CALL
zstemr( jobz,
'A', n, rwork( indrdd ),
614 $ rwork( indree ), vl, vu, il, iu, m, w,
615 $ z, ldz, n, isuppz, tryrac,
616 $ rwork( indrwk ), llrwork,
617 $ iwork, liwork, info )
622 IF( wantz .AND. info.EQ.0 )
THEN
624 llwrkn = lwork - indwkn + 1
625 CALL
zunmtr(
'L', uplo,
'N', n, m, a, lda,
626 $ work( indtau ), z, ldz, work( indwkn ),
648 CALL
dstebz( range, order, n, vll, vuu, il, iu, abstll,
649 $ rwork( indrd ), rwork( indre ), m, nsplit, w,
650 $ iwork( indibl ), iwork( indisp ), rwork( indrwk ),
651 $ iwork( indiwo ), info )
654 CALL
zstein( n, rwork( indrd ), rwork( indre ), m, w,
655 $ iwork( indibl ), iwork( indisp ), z, ldz,
656 $ rwork( indrwk ), iwork( indiwo ), iwork( indifl ),
663 llwrkn = lwork - indwkn + 1
664 CALL
zunmtr(
'L', uplo,
'N', n, m, a, lda, work( indtau ), z,
665 $ ldz, work( indwkn ), llwrkn, iinfo )
671 IF( iscale.EQ.1 )
THEN
677 CALL
dscal( imax, one / sigma, w, 1 )
688 IF( w( jj ).LT.tmp1 )
THEN
695 itmp1 = iwork( indibl+i-1 )
697 iwork( indibl+i-1 ) = iwork( indibl+j-1 )
699 iwork( indibl+j-1 ) = itmp1
700 CALL zswap( n, z( 1, i ), 1, z( 1, j ), 1 )
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
subroutine zstein(N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO)
ZSTEIN
subroutine dsterf(N, D, E, INFO)
DSTERF
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zhetrd(UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO)
ZHETRD
subroutine dscal(N, DA, DX, INCX)
DSCAL
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 dstebz(RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, INFO)
DSTEBZ
subroutine zunmtr(SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
ZUNMTR
subroutine zheevr(JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO)
ZHEEVR computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices ...