356 SUBROUTINE zheevr( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
357 $ abstol, m, w, z, ldz, isuppz, work, lwork,
358 $ rwork, lrwork, iwork, liwork, info )
366 CHARACTER JOBZ, RANGE, UPLO
367 INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LRWORK, LWORK,
369 DOUBLE PRECISION ABSTOL, VL, VU
372 INTEGER ISUPPZ( * ), IWORK( * )
373 DOUBLE PRECISION RWORK( * ), W( * )
374 COMPLEX*16 A( lda, * ), WORK( * ), Z( ldz, * )
380 DOUBLE PRECISION ZERO, ONE, TWO
381 parameter ( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0 )
384 LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG,
387 INTEGER I, IEEEOK, IINFO, IMAX, INDIBL, INDIFL, INDISP,
388 $ indiwo, indrd, indrdd, indre, indree, indrwk,
389 $ indtau, indwk, indwkn, iscale, itmp1, j, jj,
390 $ liwmin, llwork, llrwork, llwrkn, lrwmin,
391 $ lwkopt, lwmin, nb, nsplit
392 DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
393 $ sigma, smlnum, tmp1, vll, vuu
398 DOUBLE PRECISION DLAMCH, ZLANSY
399 EXTERNAL lsame, ilaenv, dlamch, zlansy
406 INTRINSIC dble, max, min, sqrt
412 ieeeok = ilaenv( 10,
'ZHEEVR',
'N', 1, 2, 3, 4 )
414 lower = lsame( uplo,
'L' )
415 wantz = lsame( jobz,
'V' )
416 alleig = lsame( range,
'A' )
417 valeig = lsame( range,
'V' )
418 indeig = lsame( range,
'I' )
420 lquery = ( ( lwork.EQ.-1 ) .OR. ( lrwork.EQ.-1 ) .OR.
423 lrwmin = max( 1, 24*n )
424 liwmin = max( 1, 10*n )
425 lwmin = max( 1, 2*n )
428 IF( .NOT.( wantz .OR. lsame( jobz,
'N' ) ) )
THEN
430 ELSE IF( .NOT.( alleig .OR. valeig .OR. indeig ) )
THEN
432 ELSE IF( .NOT.( lower .OR. lsame( uplo,
'U' ) ) )
THEN
434 ELSE IF( n.LT.0 )
THEN
436 ELSE IF( lda.LT.max( 1, n ) )
THEN
440 IF( n.GT.0 .AND. vu.LE.vl )
442 ELSE IF( indeig )
THEN
443 IF( il.LT.1 .OR. il.GT.max( 1, n ) )
THEN
445 ELSE IF( iu.LT.min( n, il ) .OR. iu.GT.n )
THEN
451 IF( ldz.LT.1 .OR. ( wantz .AND. ldz.LT.n ) )
THEN
457 nb = ilaenv( 1,
'ZHETRD', uplo, n, -1, -1, -1 )
458 nb = max( nb, ilaenv( 1,
'ZUNMTR', uplo, n, -1, -1, -1 ) )
459 lwkopt = max( ( nb+1 )*n, lwmin )
464 IF( lwork.LT.lwmin .AND. .NOT.lquery )
THEN
466 ELSE IF( lrwork.LT.lrwmin .AND. .NOT.lquery )
THEN
468 ELSE IF( liwork.LT.liwmin .AND. .NOT.lquery )
THEN
474 CALL xerbla(
'ZHEEVR', -info )
476 ELSE IF( lquery )
THEN
490 IF( alleig .OR. indeig )
THEN
492 w( 1 ) = dble( a( 1, 1 ) )
494 IF( vl.LT.dble( a( 1, 1 ) ) .AND. vu.GE.dble( a( 1, 1 ) ) )
497 w( 1 ) = dble( a( 1, 1 ) )
510 safmin = dlamch(
'Safe minimum' )
511 eps = dlamch(
'Precision' )
512 smlnum = safmin / eps
513 bignum = one / smlnum
514 rmin = sqrt( smlnum )
515 rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
525 anrm = zlansy(
'M', uplo, n, a, lda, rwork )
526 IF( anrm.GT.zero .AND. anrm.LT.rmin )
THEN
529 ELSE IF( anrm.GT.rmax )
THEN
533 IF( iscale.EQ.1 )
THEN
536 CALL zdscal( n-j+1, sigma, a( j, j ), 1 )
540 CALL zdscal( j, sigma, a( 1, j ), 1 )
544 $ abstll = abstol*sigma
560 llwork = lwork - indwk + 1
577 llrwork = lrwork - indrwk + 1
596 CALL zhetrd( uplo, n, a, lda, rwork( indrd ), rwork( indre ),
597 $ work( indtau ), work( indwk ), llwork, iinfo )
604 IF( il.EQ.1 .AND. iu.EQ.n )
THEN
608 IF( ( alleig.OR.test ) .AND. ( ieeeok.EQ.1 ) )
THEN
609 IF( .NOT.wantz )
THEN
610 CALL dcopy( n, rwork( indrd ), 1, w, 1 )
611 CALL dcopy( n-1, rwork( indre ), 1, rwork( indree ), 1 )
612 CALL dsterf( n, w, rwork( indree ), info )
614 CALL dcopy( n-1, rwork( indre ), 1, rwork( indree ), 1 )
615 CALL dcopy( n, rwork( indrd ), 1, rwork( indrdd ), 1 )
617 IF (abstol .LE. two*n*eps)
THEN
622 CALL zstemr( jobz,
'A', n, rwork( indrdd ),
623 $ rwork( indree ), vl, vu, il, iu, m, w,
624 $ z, ldz, n, isuppz, tryrac,
625 $ rwork( indrwk ), llrwork,
626 $ iwork, liwork, info )
631 IF( wantz .AND. info.EQ.0 )
THEN
633 llwrkn = lwork - indwkn + 1
634 CALL zunmtr(
'L', uplo,
'N', n, m, a, lda,
635 $ work( indtau ), z, ldz, work( indwkn ),
657 CALL dstebz( range, order, n, vll, vuu, il, iu, abstll,
658 $ rwork( indrd ), rwork( indre ), m, nsplit, w,
659 $ iwork( indibl ), iwork( indisp ), rwork( indrwk ),
660 $ iwork( indiwo ), info )
663 CALL zstein( n, rwork( indrd ), rwork( indre ), m, w,
664 $ iwork( indibl ), iwork( indisp ), z, ldz,
665 $ rwork( indrwk ), iwork( indiwo ), iwork( indifl ),
672 llwrkn = lwork - indwkn + 1
673 CALL zunmtr(
'L', uplo,
'N', n, m, a, lda, work( indtau ), z,
674 $ ldz, work( indwkn ), llwrkn, iinfo )
680 IF( iscale.EQ.1 )
THEN
686 CALL dscal( imax, one / sigma, w, 1 )
697 IF( w( jj ).LT.tmp1 )
THEN
704 itmp1 = iwork( indibl+i-1 )
706 iwork( indibl+i-1 ) = iwork( indibl+j-1 )
708 iwork( indibl+j-1 ) = itmp1
709 CALL zswap( n, z( 1, i ), 1, z( 1, j ), 1 )
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
subroutine dsterf(N, D, E, INFO)
DSTERF
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 zstein(N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO)
ZSTEIN
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 xerbla(SRNAME, INFO)
XERBLA
subroutine dscal(N, DA, DX, INCX)
DSCAL
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
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 ...
subroutine zhetrd(UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO)
ZHETRD