259 SUBROUTINE chbevx( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL,
260 $ vu, il, iu, abstol, m, w, z, ldz, work, rwork,
261 $ iwork, ifail, info )
269 CHARACTER jobz, range, uplo
270 INTEGER il, info, iu, kd, ldab, ldq, ldz, m, n
274 INTEGER ifail( * ), iwork( * )
275 REAL rwork( * ), w( * )
276 COMPLEX ab( ldab, * ), q( ldq, * ), work( * ),
284 parameter( zero = 0.0e0, one = 1.0e0 )
286 parameter( czero = ( 0.0e0, 0.0e0 ),
287 $ cone = ( 1.0e0, 0.0e0 ) )
290 LOGICAL alleig, indeig, lower, test, valeig, wantz
292 INTEGER i, iinfo, imax, indd, inde, indee, indibl,
293 $ indisp, indiwk, indrwk, indwrk, iscale, itmp1,
295 REAL abstll, anrm, bignum, eps, rmax, rmin, safmin,
296 $ sigma, smlnum, tmp1, vll, vuu
310 INTRINSIC max, min,
REAL, sqrt
316 wantz =
lsame( jobz,
'V' )
317 alleig =
lsame( range,
'A' )
318 valeig =
lsame( range,
'V' )
319 indeig =
lsame( range,
'I' )
320 lower =
lsame( uplo,
'L' )
323 IF( .NOT.( wantz .OR.
lsame( jobz,
'N' ) ) )
THEN
325 ELSE IF( .NOT.( alleig .OR. valeig .OR. indeig ) )
THEN
327 ELSE IF( .NOT.( lower .OR.
lsame( uplo,
'U' ) ) )
THEN
329 ELSE IF( n.LT.0 )
THEN
331 ELSE IF( kd.LT.0 )
THEN
333 ELSE IF( ldab.LT.kd+1 )
THEN
335 ELSE IF( wantz .AND. ldq.LT.max( 1, n ) )
THEN
339 IF( n.GT.0 .AND. vu.LE.vl )
341 ELSE IF( indeig )
THEN
342 IF( il.LT.1 .OR. il.GT.max( 1, n ) )
THEN
344 ELSE IF( iu.LT.min( n, il ) .OR. iu.GT.n )
THEN
350 IF( ldz.LT.1 .OR. ( wantz .AND. ldz.LT.n ) )
355 CALL
xerbla(
'CHBEVX', -info )
370 ctmp1 = ab( kd+1, 1 )
374 IF( .NOT.( vl.LT.tmp1 .AND. vu.GE.tmp1 ) )
387 safmin =
slamch(
'Safe minimum' )
388 eps =
slamch(
'Precision' )
389 smlnum = safmin / eps
390 bignum = one / smlnum
391 rmin = sqrt( smlnum )
392 rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
405 anrm =
clanhb(
'M', uplo, n, kd, ab, ldab, rwork )
406 IF( anrm.GT.zero .AND. anrm.LT.rmin )
THEN
409 ELSE IF( anrm.GT.rmax )
THEN
413 IF( iscale.EQ.1 )
THEN
415 CALL
clascl(
'B', kd, kd, one, sigma, n, n, ab, ldab, info )
417 CALL
clascl(
'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
420 $ abstll = abstol*sigma
433 CALL
chbtrd( jobz, uplo, n, kd, ab, ldab, rwork( indd ),
434 $ rwork( inde ), q, ldq, work( indwrk ), iinfo )
442 IF (il.EQ.1 .AND. iu.EQ.n)
THEN
446 IF ((alleig .OR. test) .AND. (abstol.LE.zero))
THEN
447 CALL
scopy( n, rwork( indd ), 1, w, 1 )
449 IF( .NOT.wantz )
THEN
450 CALL
scopy( n-1, rwork( inde ), 1, rwork( indee ), 1 )
451 CALL
ssterf( n, w, rwork( indee ), info )
453 CALL
clacpy(
'A', n, n, q, ldq, z, ldz )
454 CALL
scopy( n-1, rwork( inde ), 1, rwork( indee ), 1 )
455 CALL
csteqr( jobz, n, w, rwork( indee ), z, ldz,
456 $ rwork( indrwk ), info )
480 CALL
sstebz( range, order, n, vll, vuu, il, iu, abstll,
481 $ rwork( indd ), rwork( inde ), m, nsplit, w,
482 $ iwork( indibl ), iwork( indisp ), rwork( indrwk ),
483 $ iwork( indiwk ), info )
486 CALL
cstein( n, rwork( indd ), rwork( inde ), m, w,
487 $ iwork( indibl ), iwork( indisp ), z, ldz,
488 $ rwork( indrwk ), iwork( indiwk ), ifail, info )
494 CALL
ccopy( n, z( 1,
j ), 1, work( 1 ), 1 )
495 CALL
cgemv(
'N', n, n, cone, q, ldq, work, 1, czero,
503 IF( iscale.EQ.1 )
THEN
509 CALL
sscal( imax, one / sigma, w, 1 )
520 IF( w( jj ).LT.tmp1 )
THEN
527 itmp1 = iwork( indibl+i-1 )
529 iwork( indibl+i-1 ) = iwork( indibl+
j-1 )
531 iwork( indibl+
j-1 ) = itmp1
532 CALL
cswap( n, z( 1, i ), 1, z( 1,
j ), 1 )
535 ifail( i ) = ifail(
j )
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine chbtrd(VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO)
CHBTRD
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
logical function lsame(CA, CB)
LSAME
subroutine cgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGEMV
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine csteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
CSTEQR
subroutine cstein(N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO)
CSTEIN
subroutine sstebz(RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, INFO)
SSTEBZ
real function slamch(CMACH)
SLAMCH
real function clanhb(NORM, UPLO, N, K, AB, LDAB, WORK)
CLANHB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a Hermitian band matrix.
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.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine ssterf(N, D, E, INFO)
SSTERF
subroutine chbevx(JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO)
CHBEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matric...
subroutine sscal(N, SA, SX, INCX)
SSCAL