252 $ WORK, LWORK, RWORK, LRWORK, IWORK,
263 INTEGER INFO, KD, LDAB, LDZ, LIWORK, LRWORK, LWORK, N
267 DOUBLE PRECISION RWORK( * ), W( * )
268 COMPLEX*16 AB( LDAB, * ), WORK( * ), Z( LDZ, * )
274 DOUBLE PRECISION ZERO, ONE
275 PARAMETER ( ZERO = 0.0d0, one = 1.0d0 )
276 COMPLEX*16 CZERO, CONE
277 parameter( czero = ( 0.0d0, 0.0d0 ),
278 $ cone = ( 1.0d0, 0.0d0 ) )
281 LOGICAL LOWER, LQUERY, WANTZ
282 INTEGER IINFO, IMAX, INDE, INDWK2, INDRWK, ISCALE,
283 $ llwork, indwk, lhtrd, lwtrd, ib, indhous,
284 $ liwmin, llrwk, llwk2, lrwmin, lwmin
285 DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
291 DOUBLE PRECISION DLAMCH, ZLANHB
292 EXTERNAL lsame, dlamch, zlanhb, ilaenv2stage
305 wantz = lsame( jobz,
'V' )
306 lower = lsame( uplo,
'L' )
307 lquery = ( lwork.EQ.-1 .OR. liwork.EQ.-1 .OR. lrwork.EQ.-1 )
315 ib = ilaenv2stage( 2,
'ZHETRD_HB2ST', jobz, n, kd, -1, -1 )
316 lhtrd = ilaenv2stage( 3,
'ZHETRD_HB2ST', jobz, n, kd, ib, -1 )
317 lwtrd = ilaenv2stage( 4,
'ZHETRD_HB2ST', jobz, n, kd, ib, -1 )
320 lrwmin = 1 + 5*n + 2*n**2
323 lwmin = max( n, lhtrd + lwtrd )
328 IF( .NOT.( lsame( jobz,
'N' ) ) )
THEN
330 ELSE IF( .NOT.( lower .OR. lsame( uplo,
'U' ) ) )
THEN
332 ELSE IF( n.LT.0 )
THEN
334 ELSE IF( kd.LT.0 )
THEN
336 ELSE IF( ldab.LT.kd+1 )
THEN
338 ELSE IF( ldz.LT.1 .OR. ( wantz .AND. ldz.LT.n ) )
THEN
347 IF( lwork.LT.lwmin .AND. .NOT.lquery )
THEN
349 ELSE IF( lrwork.LT.lrwmin .AND. .NOT.lquery )
THEN
351 ELSE IF( liwork.LT.liwmin .AND. .NOT.lquery )
THEN
357 CALL xerbla(
'ZHBEVD_2STAGE', -info )
359 ELSE IF( lquery )
THEN
369 w( 1 ) = dble( ab( 1, 1 ) )
377 safmin = dlamch(
'Safe minimum' )
378 eps = dlamch(
'Precision' )
379 smlnum = safmin / eps
380 bignum = one / smlnum
381 rmin = sqrt( smlnum )
382 rmax = sqrt( bignum )
386 anrm = zlanhb(
'M', uplo, n, kd, ab, ldab, rwork )
388 IF( anrm.GT.zero .AND. anrm.LT.rmin )
THEN
391 ELSE IF( anrm.GT.rmax )
THEN
395 IF( iscale.EQ.1 )
THEN
397 CALL zlascl(
'B', kd, kd, one, sigma, n, n, ab, ldab, info )
399 CALL zlascl(
'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
407 llrwk = lrwork - indrwk + 1
409 indwk = indhous + lhtrd
410 llwork = lwork - indwk + 1
412 llwk2 = lwork - indwk2 + 1
415 $ rwork( inde ), work( indhous ), lhtrd,
416 $ work( indwk ), llwork, iinfo )
420 IF( .NOT.wantz )
THEN
421 CALL dsterf( n, w, rwork( inde ), info )
423 CALL zstedc(
'I', n, w, rwork( inde ), work, n, work( indwk2 ),
424 $ llwk2, rwork( indrwk ), llrwk, iwork, liwork,
426 CALL zgemm(
'N',
'N', n, n, n, cone, z, ldz, work, n, czero,
427 $ work( indwk2 ), n )
428 CALL zlacpy(
'A', n, n, work( indwk2 ), n, z, ldz )
433 IF( iscale.EQ.1 )
THEN
439 CALL dscal( imax, one / sigma, w, 1 )
subroutine xerbla(srname, info)
subroutine zgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZGEMM
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 ...
subroutine zhetrd_hb2st(stage1, vect, uplo, n, kd, ab, ldab, d, e, hous, lhous, work, lwork, info)
ZHETRD_HB2ST reduces a complex Hermitian band matrix A to real symmetric tridiagonal form T
subroutine zlacpy(uplo, m, n, a, lda, b, ldb)
ZLACPY copies all or part of one two-dimensional array to another.
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 dscal(n, da, dx, incx)
DSCAL
subroutine zstedc(compz, n, d, e, z, ldz, work, lwork, rwork, lrwork, iwork, liwork, info)
ZSTEDC
subroutine dsterf(n, d, e, info)
DSTERF