205 SUBROUTINE zhbevd( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ,
207 $ LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )
215 INTEGER INFO, KD, LDAB, LDZ, LIWORK, LRWORK, LWORK, N
219 DOUBLE PRECISION RWORK( * ), W( * )
220 COMPLEX*16 AB( LDAB, * ), WORK( * ), Z( LDZ, * )
226 DOUBLE PRECISION ZERO, ONE
227 PARAMETER ( ZERO = 0.0d0, one = 1.0d0 )
228 COMPLEX*16 CZERO, CONE
229 parameter( czero = ( 0.0d0, 0.0d0 ),
230 $ cone = ( 1.0d0, 0.0d0 ) )
233 LOGICAL LOWER, LQUERY, WANTZ
234 INTEGER IINFO, IMAX, INDE, INDWK2, INDWRK, ISCALE,
235 $ liwmin, llrwk, llwk2, lrwmin, lwmin
236 DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
241 DOUBLE PRECISION DLAMCH, ZLANHB
242 EXTERNAL lsame, dlamch, zlanhb
256 wantz = lsame( jobz,
'V' )
257 lower = lsame( uplo,
'L' )
258 lquery = ( lwork.EQ.-1 .OR. liwork.EQ.-1 .OR. lrwork.EQ.-1 )
268 lrwmin = 1 + 5*n + 2*n**2
276 IF( .NOT.( wantz .OR. lsame( jobz,
'N' ) ) )
THEN
278 ELSE IF( .NOT.( lower .OR. lsame( uplo,
'U' ) ) )
THEN
280 ELSE IF( n.LT.0 )
THEN
282 ELSE IF( kd.LT.0 )
THEN
284 ELSE IF( ldab.LT.kd+1 )
THEN
286 ELSE IF( ldz.LT.1 .OR. ( wantz .AND. ldz.LT.n ) )
THEN
292 rwork( 1 ) = real( lrwmin )
295 IF( lwork.LT.lwmin .AND. .NOT.lquery )
THEN
297 ELSE IF( lrwork.LT.lrwmin .AND. .NOT.lquery )
THEN
299 ELSE IF( liwork.LT.liwmin .AND. .NOT.lquery )
THEN
305 CALL xerbla(
'ZHBEVD', -info )
307 ELSE IF( lquery )
THEN
317 w( 1 ) = dble( ab( 1, 1 ) )
325 safmin = dlamch(
'Safe minimum' )
326 eps = dlamch(
'Precision' )
327 smlnum = safmin / eps
328 bignum = one / smlnum
329 rmin = sqrt( smlnum )
330 rmax = sqrt( bignum )
334 anrm = zlanhb(
'M', uplo, n, kd, ab, ldab, rwork )
336 IF( anrm.GT.zero .AND. anrm.LT.rmin )
THEN
339 ELSE IF( anrm.GT.rmax )
THEN
343 IF( iscale.EQ.1 )
THEN
345 CALL zlascl(
'B', kd, kd, one, sigma, n, n, ab, ldab,
348 CALL zlascl(
'Q', kd, kd, one, sigma, n, n, ab, ldab,
358 llwk2 = lwork - indwk2 + 1
359 llrwk = lrwork - indwrk + 1
360 CALL zhbtrd( jobz, uplo, n, kd, ab, ldab, w, rwork( inde ), z,
365 IF( .NOT.wantz )
THEN
366 CALL dsterf( n, w, rwork( inde ), info )
368 CALL zstedc(
'I', n, w, rwork( inde ), work, n,
370 $ llwk2, rwork( indwrk ), llrwk, iwork, liwork,
372 CALL zgemm(
'N',
'N', n, n, n, cone, z, ldz, work, n, czero,
373 $ work( indwk2 ), n )
374 CALL zlacpy(
'A', n, n, work( indwk2 ), n, z, ldz )
379 IF( iscale.EQ.1 )
THEN
385 CALL dscal( imax, one / sigma, w, 1 )
389 rwork( 1 ) = real( lrwmin )
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...