213 SUBROUTINE zhbevd( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK,
214 $ LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )
222 INTEGER INFO, KD, LDAB, LDZ, LIWORK, LRWORK, LWORK, N
226 DOUBLE PRECISION RWORK( * ), W( * )
227 COMPLEX*16 AB( LDAB, * ), WORK( * ), Z( LDZ, * )
233 DOUBLE PRECISION ZERO, ONE
234 parameter( zero = 0.0d0, one = 1.0d0 )
235 COMPLEX*16 CZERO, CONE
236 parameter( czero = ( 0.0d0, 0.0d0 ),
237 $ cone = ( 1.0d0, 0.0d0 ) )
240 LOGICAL LOWER, LQUERY, WANTZ
241 INTEGER IINFO, IMAX, INDE, INDWK2, INDWRK, ISCALE,
242 $ liwmin, llrwk, llwk2, lrwmin, lwmin
243 DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
248 DOUBLE PRECISION DLAMCH, ZLANHB
249 EXTERNAL lsame, dlamch, zlanhb
262 wantz = lsame( jobz,
'V' )
263 lower = lsame( uplo,
'L' )
264 lquery = ( lwork.EQ.-1 .OR. liwork.EQ.-1 .OR. lrwork.EQ.-1 )
274 lrwmin = 1 + 5*n + 2*n**2
282 IF( .NOT.( wantz .OR. lsame( jobz,
'N' ) ) )
THEN
284 ELSE IF( .NOT.( lower .OR. lsame( uplo,
'U' ) ) )
THEN
286 ELSE IF( n.LT.0 )
THEN
288 ELSE IF( kd.LT.0 )
THEN
290 ELSE IF( ldab.LT.kd+1 )
THEN
292 ELSE IF( ldz.LT.1 .OR. ( wantz .AND. ldz.LT.n ) )
THEN
301 IF( lwork.LT.lwmin .AND. .NOT.lquery )
THEN
303 ELSE IF( lrwork.LT.lrwmin .AND. .NOT.lquery )
THEN
305 ELSE IF( liwork.LT.liwmin .AND. .NOT.lquery )
THEN
311 CALL xerbla(
'ZHBEVD', -info )
313 ELSE IF( lquery )
THEN
323 w( 1 ) = dble( ab( 1, 1 ) )
331 safmin = dlamch(
'Safe minimum' )
332 eps = dlamch(
'Precision' )
333 smlnum = safmin / eps
334 bignum = one / smlnum
335 rmin = sqrt( smlnum )
336 rmax = sqrt( bignum )
340 anrm = zlanhb(
'M', uplo, n, kd, ab, ldab, rwork )
342 IF( anrm.GT.zero .AND. anrm.LT.rmin )
THEN
345 ELSE IF( anrm.GT.rmax )
THEN
349 IF( iscale.EQ.1 )
THEN
351 CALL zlascl(
'B', kd, kd, one, sigma, n, n, ab, ldab, info )
353 CALL zlascl(
'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
362 llwk2 = lwork - indwk2 + 1
363 llrwk = lrwork - indwrk + 1
364 CALL zhbtrd( jobz, uplo, n, kd, ab, ldab, w, rwork( inde ), z,
369 IF( .NOT.wantz )
THEN
370 CALL dsterf( n, w, rwork( inde ), info )
372 CALL zstedc(
'I', n, w, rwork( inde ), work, n, work( indwk2 ),
373 $ llwk2, rwork( indwrk ), llrwk, iwork, liwork,
375 CALL zgemm(
'N',
'N', n, n, n, cone, z, ldz, work, n, czero,
376 $ work( indwk2 ), n )
377 CALL zlacpy(
'A', n, n, work( indwk2 ), n, z, ldz )
382 IF( iscale.EQ.1 )
THEN
388 CALL dscal( imax, one / sigma, w, 1 )
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dsterf(N, D, E, INFO)
DSTERF
subroutine zgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZGEMM
subroutine zlascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zstedc(COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO)
ZSTEDC
subroutine zhbtrd(VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO)
ZHBTRD
subroutine zhbevd(JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO)
ZHBEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
subroutine dscal(N, DA, DX, INCX)
DSCAL