232 SUBROUTINE chpevx( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU,
233 $ abstol, m, w, z, ldz, work, rwork, iwork,
242 CHARACTER jobz, range, uplo
243 INTEGER il, info, iu, ldz, m, n
247 INTEGER ifail( * ), iwork( * )
248 REAL rwork( * ), w( * )
249 COMPLEX ap( * ), work( * ), z( ldz, * )
256 parameter( zero = 0.0e0, one = 1.0e0 )
258 parameter( cone = ( 1.0e0, 0.0e0 ) )
261 LOGICAL alleig, indeig, test, valeig, wantz
263 INTEGER i, iinfo, imax, indd, inde, indee, indibl,
264 $ indisp, indiwk, indrwk, indtau, indwrk, iscale,
265 $ itmp1,
j, jj, nsplit
266 REAL abstll, anrm, bignum, eps, rmax, rmin, safmin,
267 $ sigma, smlnum, tmp1, vll, vuu
279 INTRINSIC max, min,
REAL, sqrt
285 wantz =
lsame( jobz,
'V' )
286 alleig =
lsame( range,
'A' )
287 valeig =
lsame( range,
'V' )
288 indeig =
lsame( range,
'I' )
291 IF( .NOT.( wantz .OR.
lsame( jobz,
'N' ) ) )
THEN
293 ELSE IF( .NOT.( alleig .OR. valeig .OR. indeig ) )
THEN
295 ELSE IF( .NOT.(
lsame( uplo,
'L' ) .OR.
lsame( uplo,
'U' ) ) )
298 ELSE IF( n.LT.0 )
THEN
302 IF( n.GT.0 .AND. vu.LE.vl )
304 ELSE IF( indeig )
THEN
305 IF( il.LT.1 .OR. il.GT.max( 1, n ) )
THEN
307 ELSE IF( iu.LT.min( n, il ) .OR. iu.GT.n )
THEN
313 IF( ldz.LT.1 .OR. ( wantz .AND. ldz.LT.n ) )
318 CALL
xerbla(
'CHPEVX', -info )
329 IF( alleig .OR. indeig )
THEN
333 IF( vl.LT.
REAL( AP( 1 ) ) .AND. vu.GE.
REAL( AP( 1 ) ) ) then
345 safmin =
slamch(
'Safe minimum' )
346 eps =
slamch(
'Precision' )
347 smlnum = safmin / eps
348 bignum = one / smlnum
349 rmin = sqrt( smlnum )
350 rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
363 anrm =
clanhp(
'M', uplo, n, ap, rwork )
364 IF( anrm.GT.zero .AND. anrm.LT.rmin )
THEN
367 ELSE IF( anrm.GT.rmax )
THEN
371 IF( iscale.EQ.1 )
THEN
372 CALL
csscal( ( n*( n+1 ) ) / 2, sigma, ap, 1 )
374 $ abstll = abstol*sigma
388 CALL
chptrd( uplo, n, ap, rwork( indd ), rwork( inde ),
389 $ work( indtau ), iinfo )
397 IF (il.EQ.1 .AND. iu.EQ.n)
THEN
401 IF ((alleig .OR. test) .AND. (abstol.LE.zero))
THEN
402 CALL
scopy( n, rwork( indd ), 1, w, 1 )
404 IF( .NOT.wantz )
THEN
405 CALL
scopy( n-1, rwork( inde ), 1, rwork( indee ), 1 )
406 CALL
ssterf( n, w, rwork( indee ), info )
408 CALL
cupgtr( uplo, n, ap, work( indtau ), z, ldz,
409 $ work( indwrk ), iinfo )
410 CALL
scopy( n-1, rwork( inde ), 1, rwork( indee ), 1 )
411 CALL
csteqr( jobz, n, w, rwork( indee ), z, ldz,
412 $ rwork( indrwk ), info )
436 CALL
sstebz( range, order, n, vll, vuu, il, iu, abstll,
437 $ rwork( indd ), rwork( inde ), m, nsplit, w,
438 $ iwork( indibl ), iwork( indisp ), rwork( indrwk ),
439 $ iwork( indiwk ), info )
442 CALL
cstein( n, rwork( indd ), rwork( inde ), m, w,
443 $ iwork( indibl ), iwork( indisp ), z, ldz,
444 $ rwork( indrwk ), iwork( indiwk ), ifail, info )
450 CALL
cupmtr(
'L', uplo,
'N', n, m, ap, work( indtau ), z, ldz,
451 $ work( indwrk ), iinfo )
457 IF( iscale.EQ.1 )
THEN
463 CALL
sscal( imax, one / sigma, w, 1 )
474 IF( w( jj ).LT.tmp1 )
THEN
481 itmp1 = iwork( indibl+i-1 )
483 iwork( indibl+i-1 ) = iwork( indibl+
j-1 )
485 iwork( indibl+
j-1 ) = itmp1
486 CALL
cswap( n, z( 1, i ), 1, z( 1,
j ), 1 )
489 ifail( i ) = ifail(
j )
LOGICAL function lsame(CA, CB)
LSAME
REAL function slamch(CMACH)
SLAMCH
subroutine chptrd(UPLO, N, AP, D, E, TAU, INFO)
CHPTRD
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine chpevx(JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO)
CHPEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matric...
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
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
subroutine cupmtr(SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, INFO)
CUPMTR
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine cupgtr(UPLO, N, AP, TAU, Q, LDQ, WORK, INFO)
CUPGTR
subroutine csscal(N, SA, CX, INCX)
CSSCAL
REAL function clanhp(NORM, UPLO, N, AP, WORK)
CLANHP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a complex Hermitian matrix supplied in packed form.
subroutine ssterf(N, D, E, INFO)
SSTERF
subroutine sscal(N, SA, SX, INCX)
SSCAL