354 SUBROUTINE zheevr( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
355 $ abstol, m, w, z, ldz, isuppz, work, lwork,
356 $ rwork, lrwork, iwork, liwork, info )
364 CHARACTER JOBZ, RANGE, UPLO
365 INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LRWORK, LWORK,
367 DOUBLE PRECISION ABSTOL, VL, VU
370 INTEGER ISUPPZ( * ), IWORK( * )
371 DOUBLE PRECISION RWORK( * ), W( * )
372 COMPLEX*16 A( lda, * ), WORK( * ), Z( ldz, * )
378 DOUBLE PRECISION ZERO, ONE, TWO
379 parameter ( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0 )
382 LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG,
385 INTEGER I, IEEEOK, IINFO, IMAX, INDIBL, INDIFL, INDISP,
386 $ indiwo, indrd, indrdd, indre, indree, indrwk,
387 $ indtau, indwk, indwkn, iscale, itmp1, j, jj,
388 $ liwmin, llwork, llrwork, llwrkn, lrwmin,
389 $ lwkopt, lwmin, nb, nsplit
390 DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
391 $ sigma, smlnum, tmp1, vll, vuu
396 DOUBLE PRECISION DLAMCH, ZLANSY
397 EXTERNAL lsame, ilaenv, dlamch, zlansy
404 INTRINSIC dble, max, min, sqrt
410 ieeeok = ilaenv( 10,
'ZHEEVR',
'N', 1, 2, 3, 4 )
412 lower = lsame( uplo,
'L' )
413 wantz = lsame( jobz,
'V' )
414 alleig = lsame( range,
'A' )
415 valeig = lsame( range,
'V' )
416 indeig = lsame( range,
'I' )
418 lquery = ( ( lwork.EQ.-1 ) .OR. ( lrwork.EQ.-1 ) .OR.
421 lrwmin = max( 1, 24*n )
422 liwmin = max( 1, 10*n )
423 lwmin = max( 1, 2*n )
426 IF( .NOT.( wantz .OR. lsame( jobz,
'N' ) ) )
THEN
428 ELSE IF( .NOT.( alleig .OR. valeig .OR. indeig ) )
THEN
430 ELSE IF( .NOT.( lower .OR. lsame( uplo,
'U' ) ) )
THEN
432 ELSE IF( n.LT.0 )
THEN
434 ELSE IF( lda.LT.max( 1, n ) )
THEN
438 IF( n.GT.0 .AND. vu.LE.vl )
440 ELSE IF( indeig )
THEN
441 IF( il.LT.1 .OR. il.GT.max( 1, n ) )
THEN
443 ELSE IF( iu.LT.min( n, il ) .OR. iu.GT.n )
THEN
449 IF( ldz.LT.1 .OR. ( wantz .AND. ldz.LT.n ) )
THEN
455 nb = ilaenv( 1,
'ZHETRD', uplo, n, -1, -1, -1 )
456 nb = max( nb, ilaenv( 1,
'ZUNMTR', uplo, n, -1, -1, -1 ) )
457 lwkopt = max( ( nb+1 )*n, lwmin )
462 IF( lwork.LT.lwmin .AND. .NOT.lquery )
THEN
464 ELSE IF( lrwork.LT.lrwmin .AND. .NOT.lquery )
THEN
466 ELSE IF( liwork.LT.liwmin .AND. .NOT.lquery )
THEN
472 CALL xerbla(
'ZHEEVR', -info )
474 ELSE IF( lquery )
THEN
488 IF( alleig .OR. indeig )
THEN
490 w( 1 ) = dble( a( 1, 1 ) )
492 IF( vl.LT.dble( a( 1, 1 ) ) .AND. vu.GE.dble( a( 1, 1 ) ) )
495 w( 1 ) = dble( a( 1, 1 ) )
508 safmin = dlamch(
'Safe minimum' )
509 eps = dlamch(
'Precision' )
510 smlnum = safmin / eps
511 bignum = one / smlnum
512 rmin = sqrt( smlnum )
513 rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
523 anrm = zlansy(
'M', uplo, n, a, lda, rwork )
524 IF( anrm.GT.zero .AND. anrm.LT.rmin )
THEN
527 ELSE IF( anrm.GT.rmax )
THEN
531 IF( iscale.EQ.1 )
THEN
534 CALL zdscal( n-j+1, sigma, a( j, j ), 1 )
538 CALL zdscal( j, sigma, a( 1, j ), 1 )
542 $ abstll = abstol*sigma
558 llwork = lwork - indwk + 1
575 llrwork = lrwork - indrwk + 1
594 CALL zhetrd( uplo, n, a, lda, rwork( indrd ), rwork( indre ),
595 $ work( indtau ), work( indwk ), llwork, iinfo )
602 IF( il.EQ.1 .AND. iu.EQ.n )
THEN
606 IF( ( alleig.OR.test ) .AND. ( ieeeok.EQ.1 ) )
THEN
607 IF( .NOT.wantz )
THEN
608 CALL dcopy( n, rwork( indrd ), 1, w, 1 )
609 CALL dcopy( n-1, rwork( indre ), 1, rwork( indree ), 1 )
610 CALL dsterf( n, w, rwork( indree ), info )
612 CALL dcopy( n-1, rwork( indre ), 1, rwork( indree ), 1 )
613 CALL dcopy( n, rwork( indrd ), 1, rwork( indrdd ), 1 )
615 IF (abstol .LE. two*n*eps)
THEN
620 CALL zstemr( jobz,
'A', n, rwork( indrdd ),
621 $ rwork( indree ), vl, vu, il, iu, m, w,
622 $ z, ldz, n, isuppz, tryrac,
623 $ rwork( indrwk ), llrwork,
624 $ iwork, liwork, info )
629 IF( wantz .AND. info.EQ.0 )
THEN
631 llwrkn = lwork - indwkn + 1
632 CALL zunmtr(
'L', uplo,
'N', n, m, a, lda,
633 $ work( indtau ), z, ldz, work( indwkn ),
655 CALL dstebz( range, order, n, vll, vuu, il, iu, abstll,
656 $ rwork( indrd ), rwork( indre ), m, nsplit, w,
657 $ iwork( indibl ), iwork( indisp ), rwork( indrwk ),
658 $ iwork( indiwo ), info )
661 CALL zstein( n, rwork( indrd ), rwork( indre ), m, w,
662 $ iwork( indibl ), iwork( indisp ), z, ldz,
663 $ rwork( indrwk ), iwork( indiwo ), iwork( indifl ),
670 llwrkn = lwork - indwkn + 1
671 CALL zunmtr(
'L', uplo,
'N', n, m, a, lda, work( indtau ), z,
672 $ ldz, work( indwkn ), llwrkn, iinfo )
678 IF( iscale.EQ.1 )
THEN
684 CALL dscal( imax, one / sigma, w, 1 )
695 IF( w( jj ).LT.tmp1 )
THEN
702 itmp1 = iwork( indibl+i-1 )
704 iwork( indibl+i-1 ) = iwork( indibl+j-1 )
706 iwork( indibl+j-1 ) = itmp1
707 CALL zswap( n, z( 1, i ), 1, z( 1, j ), 1 )
subroutine dsterf(N, D, E, INFO)
DSTERF
subroutine dstebz(RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, INFO)
DSTEBZ
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine zhetrd(UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO)
ZHETRD
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zstein(N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO)
ZSTEIN
subroutine dscal(N, DA, DX, INCX)
DSCAL
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 zunmtr(SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
ZUNMTR
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
subroutine zstemr(JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO)
ZSTEMR