234 SUBROUTINE dsbevd_2stage( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ,
235 $ work, lwork, iwork, liwork, info )
246 INTEGER INFO, KD, LDAB, LDZ, LIWORK, LWORK, N
250 DOUBLE PRECISION AB( ldab, * ), W( * ), WORK( * ), Z( ldz, * )
256 DOUBLE PRECISION ZERO, ONE
257 parameter ( zero = 0.0d+0, one = 1.0d+0 )
260 LOGICAL LOWER, LQUERY, WANTZ
261 INTEGER IINFO, INDE, INDWK2, INDWRK, ISCALE, LIWMIN,
262 $ llwork, lwmin, lhtrd, lwtrd, ib, indhous,
264 DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
270 DOUBLE PRECISION DLAMCH, DLANSB
271 EXTERNAL lsame, dlamch, dlansb, ilaenv
284 wantz = lsame( jobz,
'V' )
285 lower = lsame( uplo,
'L' )
286 lquery = ( lwork.EQ.-1 .OR. liwork.EQ.-1 )
293 ib = ilaenv( 18,
'DSYTRD_SB2ST', jobz, n, kd, -1, -1 )
294 lhtrd = ilaenv( 19,
'DSYTRD_SB2ST', jobz, n, kd, ib, -1 )
295 lwtrd = ilaenv( 20,
'DSYTRD_SB2ST', jobz, n, kd, ib, -1 )
298 lwmin = 1 + 5*n + 2*n**2
301 lwmin = max( 2*n, n+lhtrd+lwtrd )
304 IF( .NOT.( lsame( jobz,
'N' ) ) )
THEN
306 ELSE IF( .NOT.( lower .OR. lsame( uplo,
'U' ) ) )
THEN
308 ELSE IF( n.LT.0 )
THEN
310 ELSE IF( kd.LT.0 )
THEN
312 ELSE IF( ldab.LT.kd+1 )
THEN
314 ELSE IF( ldz.LT.1 .OR. ( wantz .AND. ldz.LT.n ) )
THEN
322 IF( lwork.LT.lwmin .AND. .NOT.lquery )
THEN
324 ELSE IF( liwork.LT.liwmin .AND. .NOT.lquery )
THEN
330 CALL xerbla(
'DSBEVD_2STAGE', -info )
332 ELSE IF( lquery )
THEN
350 safmin = dlamch(
'Safe minimum' )
351 eps = dlamch(
'Precision' )
352 smlnum = safmin / eps
353 bignum = one / smlnum
354 rmin = sqrt( smlnum )
355 rmax = sqrt( bignum )
359 anrm = dlansb(
'M', uplo, n, kd, ab, ldab, work )
361 IF( anrm.GT.zero .AND. anrm.LT.rmin )
THEN
364 ELSE IF( anrm.GT.rmax )
THEN
368 IF( iscale.EQ.1 )
THEN
370 CALL dlascl(
'B', kd, kd, one, sigma, n, n, ab, ldab, info )
372 CALL dlascl(
'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
380 indwrk = indhous + lhtrd
381 llwork = lwork - indwrk + 1
382 indwk2 = indwrk + n*n
383 llwrk2 = lwork - indwk2 + 1
385 CALL dsytrd_sb2st(
"N", jobz, uplo, n, kd, ab, ldab, w,
386 $ work( inde ), work( indhous ), lhtrd,
387 $ work( indwrk ), llwork, iinfo )
391 IF( .NOT.wantz )
THEN
392 CALL dsterf( n, w, work( inde ), info )
394 CALL dstedc(
'I', n, w, work( inde ), work( indwrk ), n,
395 $ work( indwk2 ), llwrk2, iwork, liwork, info )
396 CALL dgemm(
'N',
'N', n, n, n, one, z, ldz, work( indwrk ), n,
397 $ zero, work( indwk2 ), n )
398 CALL dlacpy(
'A', n, n, work( indwk2 ), n, z, ldz )
404 $
CALL dscal( n, one / sigma, w, 1 )
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dlascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine dsterf(N, D, E, INFO)
DSTERF
subroutine dgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DGEMM
subroutine dsbevd_2stage(JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO)
DSBEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dscal(N, DA, DX, INCX)
DSCAL
subroutine dstedc(COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO)
DSTEDC