216 SUBROUTINE dgees( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI,
217 $ vs, ldvs, work, lwork, bwork, info )
225 CHARACTER jobvs, sort
226 INTEGER info, lda, ldvs, lwork, n, sdim
230 DOUBLE PRECISION a( lda, * ), vs( ldvs, * ), wi( * ), work( * ),
241 DOUBLE PRECISION zero, one
242 parameter( zero = 0.0d0, one = 1.0d0 )
245 LOGICAL cursl, lastsl, lquery, lst2sl, scalea, wantst,
247 INTEGER hswork, i, i1, i2, ibal, icond, ierr, ieval,
248 $ ihi, ilo, inxt, ip, itau, iwrk, maxwrk, minwrk
249 DOUBLE PRECISION anrm, bignum, cscale, eps, s, sep, smlnum
253 DOUBLE PRECISION dum( 1 )
273 lquery = ( lwork.EQ.-1 )
274 wantvs =
lsame( jobvs,
'V' )
275 wantst =
lsame( sort,
'S' )
276 IF( ( .NOT.wantvs ) .AND. ( .NOT.
lsame( jobvs,
'N' ) ) )
THEN
278 ELSE IF( ( .NOT.wantst ) .AND. ( .NOT.
lsame( sort,
'N' ) ) )
THEN
280 ELSE IF( n.LT.0 )
THEN
282 ELSE IF( lda.LT.max( 1, n ) )
THEN
284 ELSE IF( ldvs.LT.1 .OR. ( wantvs .AND. ldvs.LT.n ) )
THEN
303 maxwrk = 2*n + n*
ilaenv( 1,
'DGEHRD',
' ', n, 1, n, 0 )
306 CALL
dhseqr(
'S', jobvs, n, 1, n, a, lda, wr, wi, vs, ldvs,
310 IF( .NOT.wantvs )
THEN
311 maxwrk = max( maxwrk, n + hswork )
313 maxwrk = max( maxwrk, 2*n + ( n - 1 )*
ilaenv( 1,
314 $
'DORGHR',
' ', n, 1, n, -1 ) )
315 maxwrk = max( maxwrk, n + hswork )
320 IF( lwork.LT.minwrk .AND. .NOT.lquery )
THEN
326 CALL
xerbla(
'DGEES ', -info )
328 ELSE IF( lquery )
THEN
343 bignum = one / smlnum
344 CALL
dlabad( smlnum, bignum )
345 smlnum = sqrt( smlnum ) / eps
346 bignum = one / smlnum
350 anrm =
dlange(
'M', n, n, a, lda, dum )
352 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
355 ELSE IF( anrm.GT.bignum )
THEN
360 $ CALL
dlascl(
'G', 0, 0, anrm, cscale, n, n, a, lda, ierr )
366 CALL
dgebal(
'P', n, a, lda, ilo, ihi, work( ibal ), ierr )
373 CALL
dgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),
374 $ lwork-iwrk+1, ierr )
380 CALL
dlacpy(
'L', n, n, a, lda, vs, ldvs )
385 CALL
dorghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),
386 $ lwork-iwrk+1, ierr )
395 CALL
dhseqr(
'S', jobvs, n, ilo, ihi, a, lda, wr, wi, vs, ldvs,
396 $ work( iwrk ), lwork-iwrk+1, ieval )
402 IF( wantst .AND. info.EQ.0 )
THEN
404 CALL
dlascl(
'G', 0, 0, cscale, anrm, n, 1, wr, n, ierr )
405 CALL
dlascl(
'G', 0, 0, cscale, anrm, n, 1, wi, n, ierr )
408 bwork( i ) =
SELECT( wr( i ), wi( i ) )
414 CALL
dtrsen(
'N', jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,
415 $ sdim, s, sep, work( iwrk ), lwork-iwrk+1, idum, 1,
426 CALL
dgebak(
'P',
'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,
434 CALL
dlascl(
'H', 0, 0, cscale, anrm, n, n, a, lda, ierr )
435 CALL
dcopy( n, a, lda+1, wr, 1 )
436 IF( cscale.EQ.smlnum )
THEN
442 IF( ieval.GT.0 )
THEN
445 CALL
dlascl(
'G', 0, 0, cscale, anrm, ilo-1, 1, wi,
446 $ max( ilo-1, 1 ), ierr )
447 ELSE IF( wantst )
THEN
458 IF( wi( i ).EQ.zero )
THEN
461 IF( a( i+1, i ).EQ.zero )
THEN
464 ELSE IF( a( i+1, i ).NE.zero .AND. a( i, i+1 ).EQ.
469 $ CALL
dswap( i-1, a( 1, i ), 1, a( 1, i+1 ), 1 )
471 $ CALL
dswap( n-i-1, a( i, i+2 ), lda,
472 $ a( i+1, i+2 ), lda )
474 CALL
dswap( n, vs( 1, i ), 1, vs( 1, i+1 ), 1 )
476 a( i, i+1 ) = a( i+1, i )
486 CALL
dlascl(
'G', 0, 0, cscale, anrm, n-ieval, 1,
487 $ wi( ieval+1 ), max( n-ieval, 1 ), ierr )
490 IF( wantst .AND. info.EQ.0 )
THEN
499 cursl =
SELECT( wr( i ), wi( i ) )
500 IF( wi( i ).EQ.zero )
THEN
504 IF( cursl .AND. .NOT.lastsl )
511 cursl = cursl .OR. lastsl
516 IF( cursl .AND. .NOT.lst2sl )
subroutine dgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
DGEHRD
subroutine dhseqr(JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO)
DHSEQR
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine xerbla(SRNAME, INFO)
XERBLA
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 dlabad(SMALL, LARGE)
DLABAD
subroutine dtrsen(JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO)
DTRSEN
subroutine dgebal(JOB, N, A, LDA, ILO, IHI, SCALE, INFO)
DGEBAL
logical function lsame(CA, CB)
LSAME
double precision function dlange(NORM, M, N, A, LDA, WORK)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
double precision function dlamch(CMACH)
DLAMCH
subroutine dgebak(JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO)
DGEBAK
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dswap(N, DX, INCX, DY, INCY)
DSWAP
subroutine dorghr(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
DORGHR
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
subroutine dgees(JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, VS, LDVS, WORK, LWORK, BWORK, INFO)
DGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE ...