259 SUBROUTINE zhbevd_2stage( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ,
260 $ work, lwork, rwork, lrwork, iwork,
272 INTEGER INFO, KD, LDAB, LDZ, LIWORK, LRWORK, LWORK, N
276 DOUBLE PRECISION RWORK( * ), W( * )
277 COMPLEX*16 AB( ldab, * ), WORK( * ), Z( ldz, * )
283 DOUBLE PRECISION ZERO, ONE
284 parameter ( zero = 0.0d0, one = 1.0d0 )
285 COMPLEX*16 CZERO, CONE
286 parameter ( czero = ( 0.0d0, 0.0d0 ),
287 $ cone = ( 1.0d0, 0.0d0 ) )
290 LOGICAL LOWER, LQUERY, WANTZ
291 INTEGER IINFO, IMAX, INDE, INDWK2, INDRWK, ISCALE,
292 $ llwork, indwk, lhtrd, lwtrd, ib, indhous,
293 $ liwmin, llrwk, llwk2, lrwmin, lwmin
294 DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
300 DOUBLE PRECISION DLAMCH, ZLANHB
301 EXTERNAL lsame, dlamch, zlanhb, ilaenv
314 wantz = lsame( jobz,
'V' )
315 lower = lsame( uplo,
'L' )
316 lquery = ( lwork.EQ.-1 .OR. liwork.EQ.-1 .OR. lrwork.EQ.-1 )
324 ib = ilaenv( 18,
'ZHETRD_HB2ST', jobz, n, kd, -1, -1 )
325 lhtrd = ilaenv( 19,
'ZHETRD_HB2ST', jobz, n, kd, ib, -1 )
326 lwtrd = ilaenv( 20,
'ZHETRD_HB2ST', jobz, n, kd, ib, -1 )
329 lrwmin = 1 + 5*n + 2*n**2
332 lwmin = max( n, lhtrd + lwtrd )
337 IF( .NOT.( lsame( jobz,
'N' ) ) )
THEN
339 ELSE IF( .NOT.( lower .OR. lsame( uplo,
'U' ) ) )
THEN
341 ELSE IF( n.LT.0 )
THEN
343 ELSE IF( kd.LT.0 )
THEN
345 ELSE IF( ldab.LT.kd+1 )
THEN
347 ELSE IF( ldz.LT.1 .OR. ( wantz .AND. ldz.LT.n ) )
THEN
356 IF( lwork.LT.lwmin .AND. .NOT.lquery )
THEN
358 ELSE IF( lrwork.LT.lrwmin .AND. .NOT.lquery )
THEN
360 ELSE IF( liwork.LT.liwmin .AND. .NOT.lquery )
THEN
366 CALL xerbla(
'ZHBEVD_2STAGE', -info )
368 ELSE IF( lquery )
THEN
378 w( 1 ) = dble( ab( 1, 1 ) )
386 safmin = dlamch(
'Safe minimum' )
387 eps = dlamch(
'Precision' )
388 smlnum = safmin / eps
389 bignum = one / smlnum
390 rmin = sqrt( smlnum )
391 rmax = sqrt( bignum )
395 anrm = zlanhb(
'M', uplo, n, kd, ab, ldab, rwork )
397 IF( anrm.GT.zero .AND. anrm.LT.rmin )
THEN
400 ELSE IF( anrm.GT.rmax )
THEN
404 IF( iscale.EQ.1 )
THEN
406 CALL zlascl(
'B', kd, kd, one, sigma, n, n, ab, ldab, info )
408 CALL zlascl(
'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
416 llrwk = lrwork - indrwk + 1
418 indwk = indhous + lhtrd
419 llwork = lwork - indwk + 1
421 llwk2 = lwork - indwk2 + 1
423 CALL zhetrd_hb2st(
"N", jobz, uplo, n, kd, ab, ldab, w,
424 $ rwork( inde ), work( indhous ), lhtrd,
425 $ work( indwk ), llwork, iinfo )
429 IF( .NOT.wantz )
THEN
430 CALL dsterf( n, w, rwork( inde ), info )
432 CALL zstedc(
'I', n, w, rwork( inde ), work, n, work( indwk2 ),
433 $ llwk2, rwork( indrwk ), llrwk, iwork, liwork,
435 CALL zgemm(
'N',
'N', n, n, n, cone, z, ldz, work, n, czero,
436 $ work( indwk2 ), n )
437 CALL zlacpy(
'A', n, n, work( indwk2 ), n, z, ldz )
442 IF( iscale.EQ.1 )
THEN
448 CALL dscal( imax, one / sigma, w, 1 )
subroutine zstedc(COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO)
ZSTEDC
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 zgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZGEMM
subroutine dsterf(N, D, E, INFO)
DSTERF
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dscal(N, DA, DX, INCX)
DSCAL
subroutine zhbevd_2stage(JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO)
ZHBEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER...