325 SUBROUTINE chbevx_2stage( JOBZ, RANGE, UPLO, N, KD, AB, LDAB,
326 $ q, ldq, vl, vu, il, iu, abstol, m, w,
327 $ z, ldz, work, lwork, rwork, iwork,
338 CHARACTER JOBZ, RANGE, UPLO
339 INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N, LWORK
343 INTEGER IFAIL( * ), IWORK( * )
344 REAL RWORK( * ), W( * )
345 COMPLEX AB( ldab, * ), Q( ldq, * ), WORK( * ),
353 parameter ( zero = 0.0e0, one = 1.0e0 )
355 parameter ( czero = ( 0.0e0, 0.0e0 ),
356 $ cone = ( 1.0e0, 0.0e0 ) )
359 LOGICAL ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ,
362 INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
363 $ indisp, indiwk, indrwk, indwrk, iscale, itmp1,
364 $ llwork, lwmin, lhtrd, lwtrd, ib, indhous,
366 REAL ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
367 $ sigma, smlnum, tmp1, vll, vuu
374 EXTERNAL lsame, slamch, clanhb, ilaenv
379 $
cswap, chetrd_hb2st
382 INTRINSIC REAL, MAX, MIN, SQRT
388 wantz = lsame( jobz,
'V' )
389 alleig = lsame( range,
'A' )
390 valeig = lsame( range,
'V' )
391 indeig = lsame( range,
'I' )
392 lower = lsame( uplo,
'L' )
393 lquery = ( lwork.EQ.-1 )
396 IF( .NOT.( lsame( jobz,
'N' ) ) )
THEN
398 ELSE IF( .NOT.( alleig .OR. valeig .OR. indeig ) )
THEN
400 ELSE IF( .NOT.( lower .OR. lsame( uplo,
'U' ) ) )
THEN
402 ELSE IF( n.LT.0 )
THEN
404 ELSE IF( kd.LT.0 )
THEN
406 ELSE IF( ldab.LT.kd+1 )
THEN
408 ELSE IF( wantz .AND. ldq.LT.max( 1, n ) )
THEN
412 IF( n.GT.0 .AND. vu.LE.vl )
414 ELSE IF( indeig )
THEN
415 IF( il.LT.1 .OR. il.GT.max( 1, n ) )
THEN
417 ELSE IF( iu.LT.min( n, il ) .OR. iu.GT.n )
THEN
423 IF( ldz.LT.1 .OR. ( wantz .AND. ldz.LT.n ) )
432 ib = ilaenv( 18,
'CHETRD_HB2ST', jobz, n, kd, -1, -1 )
433 lhtrd = ilaenv( 19,
'CHETRD_HB2ST', jobz, n, kd, ib, -1 )
434 lwtrd = ilaenv( 20,
'CHETRD_HB2ST', jobz, n, kd, ib, -1 )
435 lwmin = lhtrd + lwtrd
439 IF( lwork.LT.lwmin .AND. .NOT.lquery )
444 CALL xerbla(
'CHBEVX_2STAGE', -info )
446 ELSE IF( lquery )
THEN
461 ctmp1 = ab( kd+1, 1 )
465 IF( .NOT.( vl.LT.tmp1 .AND. vu.GE.tmp1 ) )
469 w( 1 ) =
REAL( ctmp1 )
478 safmin = slamch(
'Safe minimum' )
479 eps = slamch(
'Precision' )
480 smlnum = safmin / eps
481 bignum = one / smlnum
482 rmin = sqrt( smlnum )
483 rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
496 anrm = clanhb(
'M', uplo, n, kd, ab, ldab, rwork )
497 IF( anrm.GT.zero .AND. anrm.LT.rmin )
THEN
500 ELSE IF( anrm.GT.rmax )
THEN
504 IF( iscale.EQ.1 )
THEN
506 CALL clascl(
'B', kd, kd, one, sigma, n, n, ab, ldab, info )
508 CALL clascl(
'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
511 $ abstll = abstol*sigma
525 indwrk = indhous + lhtrd
526 llwork = lwork - indwrk + 1
528 CALL chetrd_hb2st(
'N', jobz, uplo, n, kd, ab, ldab,
529 $ rwork( indd ), rwork( inde ), work( indhous ),
530 $ lhtrd, work( indwrk ), llwork, iinfo )
538 IF (il.EQ.1 .AND. iu.EQ.n)
THEN
542 IF ((alleig .OR. test) .AND. (abstol.LE.zero))
THEN
543 CALL scopy( n, rwork( indd ), 1, w, 1 )
545 IF( .NOT.wantz )
THEN
546 CALL scopy( n-1, rwork( inde ), 1, rwork( indee ), 1 )
547 CALL ssterf( n, w, rwork( indee ), info )
549 CALL clacpy(
'A', n, n, q, ldq, z, ldz )
550 CALL scopy( n-1, rwork( inde ), 1, rwork( indee ), 1 )
551 CALL csteqr( jobz, n, w, rwork( indee ), z, ldz,
552 $ rwork( indrwk ), info )
576 CALL sstebz( range, order, n, vll, vuu, il, iu, abstll,
577 $ rwork( indd ), rwork( inde ), m, nsplit, w,
578 $ iwork( indibl ), iwork( indisp ), rwork( indrwk ),
579 $ iwork( indiwk ), info )
582 CALL cstein( n, rwork( indd ), rwork( inde ), m, w,
583 $ iwork( indibl ), iwork( indisp ), z, ldz,
584 $ rwork( indrwk ), iwork( indiwk ), ifail, info )
590 CALL ccopy( n, z( 1, j ), 1, work( 1 ), 1 )
591 CALL cgemv(
'N', n, n, cone, q, ldq, work, 1, czero,
599 IF( iscale.EQ.1 )
THEN
605 CALL sscal( imax, one / sigma, w, 1 )
616 IF( w( jj ).LT.tmp1 )
THEN
623 itmp1 = iwork( indibl+i-1 )
625 iwork( indibl+i-1 ) = iwork( indibl+j-1 )
627 iwork( indibl+j-1 ) = itmp1
628 CALL cswap( n, z( 1, i ), 1, z( 1, j ), 1 )
631 ifail( i ) = ifail( j )
subroutine cstein(N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO)
CSTEIN
subroutine csteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
CSTEQR
subroutine clascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
CLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine cgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGEMV
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
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 ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
subroutine ssterf(N, D, E, INFO)
SSTERF
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine chbevx_2stage(JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO)
CHBEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER...