232 SUBROUTINE zhpevx( 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
244 DOUBLE PRECISION abstol, vl, vu
247 INTEGER ifail( * ), iwork( * )
248 DOUBLE PRECISION rwork( * ), w( * )
249 COMPLEX*16 ap( * ), work( * ), z( ldz, * )
255 DOUBLE PRECISION zero, one
256 parameter( zero = 0.0d0, one = 1.0d0 )
258 parameter( cone = ( 1.0d0, 0.0d0 ) )
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 DOUBLE PRECISION abstll, anrm, bignum, eps, rmax, rmin, safmin,
267 $ sigma, smlnum, tmp1, vll, vuu
279 INTRINSIC dble, max, min, 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(
'ZHPEVX', -info )
329 IF( alleig .OR. indeig )
THEN
333 IF( vl.LT.dble( ap( 1 ) ) .AND. vu.GE.dble( ap( 1 ) ) )
THEN
345 safmin =
dlamch(
'Safe minimum' )
346 eps =
dlamch(
'Precision' )
347 smlnum = safmin / eps
348 bignum = one / smlnum
349 rmin = sqrt( smlnum )
350 rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
363 anrm =
zlanhp(
'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
zdscal( ( n*( n+1 ) ) / 2, sigma, ap, 1 )
374 $ abstll = abstol*sigma
388 CALL
zhptrd( 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
dcopy( n, rwork( indd ), 1, w, 1 )
404 IF( .NOT.wantz )
THEN
405 CALL
dcopy( n-1, rwork( inde ), 1, rwork( indee ), 1 )
406 CALL
dsterf( n, w, rwork( indee ), info )
408 CALL
zupgtr( uplo, n, ap, work( indtau ), z, ldz,
409 $ work( indwrk ), iinfo )
410 CALL
dcopy( n-1, rwork( inde ), 1, rwork( indee ), 1 )
411 CALL
zsteqr( jobz, n, w, rwork( indee ), z, ldz,
412 $ rwork( indrwk ), info )
436 CALL
dstebz( 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
zstein( n, rwork( indd ), rwork( inde ), m, w,
443 $ iwork( indibl ), iwork( indisp ), z, ldz,
444 $ rwork( indrwk ), iwork( indiwk ), ifail, info )
450 CALL
zupmtr(
'L', uplo,
'N', n, m, ap, work( indtau ), z, ldz,
451 $ work( indwrk ), iinfo )
457 IF( iscale.EQ.1 )
THEN
463 CALL
dscal( 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
zswap( n, z( 1, i ), 1, z( 1,
j ), 1 )
489 ifail( i ) = ifail(
j )
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
LOGICAL function lsame(CA, CB)
LSAME
subroutine zhptrd(UPLO, N, AP, D, E, TAU, INFO)
ZHPTRD
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
subroutine zstein(N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO)
ZSTEIN
subroutine dsterf(N, D, E, INFO)
DSTERF
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine zupmtr(SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, INFO)
ZUPMTR
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dscal(N, DA, DX, INCX)
DSCAL
subroutine zupgtr(UPLO, N, AP, TAU, Q, LDQ, WORK, INFO)
ZUPGTR
subroutine zsteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
ZSTEQR
DOUBLE PRECISION function zlanhp(NORM, UPLO, N, AP, WORK)
ZLANHP 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.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
subroutine dstebz(RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, INFO)
DSTEBZ
subroutine zhpevx(JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO)
ZHPEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matric...