280 SUBROUTINE dgeesx( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM,
281 $ wr, wi, vs, ldvs, rconde, rcondv, work, lwork,
282 $ iwork, liwork, bwork, info )
290 CHARACTER jobvs, sense, sort
291 INTEGER info, lda, ldvs, liwork, lwork, n, sdim
292 DOUBLE PRECISION rconde, rcondv
297 DOUBLE PRECISION a( lda, * ), vs( ldvs, * ), wi( * ), work( * ),
308 DOUBLE PRECISION zero, one
309 parameter( zero = 0.0d0, one = 1.0d0 )
312 LOGICAL cursl, lastsl, lquery, lst2sl, scalea, wantsb,
313 $ wantse, wantsn, wantst, wantsv, wantvs
314 INTEGER hswork, i, i1, i2, ibal, icond, ierr, ieval,
315 $ ihi, ilo, inxt, ip, itau, iwrk, liwrk, lwrk,
317 DOUBLE PRECISION anrm, bignum, cscale, eps, smlnum
320 DOUBLE PRECISION dum( 1 )
340 wantvs =
lsame( jobvs,
'V' )
341 wantst =
lsame( sort,
'S' )
342 wantsn =
lsame( sense,
'N' )
343 wantse =
lsame( sense,
'E' )
344 wantsv =
lsame( sense,
'V' )
345 wantsb =
lsame( sense,
'B' )
346 lquery = ( lwork.EQ.-1 .OR. liwork.EQ.-1 )
348 IF( ( .NOT.wantvs ) .AND. ( .NOT.
lsame( jobvs,
'N' ) ) )
THEN
350 ELSE IF( ( .NOT.wantst ) .AND. ( .NOT.
lsame( sort,
'N' ) ) )
THEN
352 ELSE IF( .NOT.( wantsn .OR. wantse .OR. wantsv .OR. wantsb ) .OR.
353 $ ( .NOT.wantst .AND. .NOT.wantsn ) )
THEN
355 ELSE IF( n.LT.0 )
THEN
357 ELSE IF( lda.LT.max( 1, n ) )
THEN
359 ELSE IF( ldvs.LT.1 .OR. ( wantvs .AND. ldvs.LT.n ) )
THEN
383 maxwrk = 2*n + n*
ilaenv( 1,
'DGEHRD',
' ', n, 1, n, 0 )
386 CALL
dhseqr(
'S', jobvs, n, 1, n, a, lda, wr, wi, vs, ldvs,
390 IF( .NOT.wantvs )
THEN
391 maxwrk = max( maxwrk, n + hswork )
393 maxwrk = max( maxwrk, 2*n + ( n - 1 )*
ilaenv( 1,
394 $
'DORGHR',
' ', n, 1, n, -1 ) )
395 maxwrk = max( maxwrk, n + hswork )
399 $ lwrk = max( lwrk, n + ( n*n )/2 )
400 IF( wantsv .OR. wantsb )
406 IF( lwork.LT.minwrk .AND. .NOT.lquery )
THEN
408 ELSE IF( liwork.LT.1 .AND. .NOT.lquery )
THEN
414 CALL
xerbla(
'DGEESX', -info )
416 ELSE IF( lquery )
THEN
431 bignum = one / smlnum
432 CALL
dlabad( smlnum, bignum )
433 smlnum = sqrt( smlnum ) / eps
434 bignum = one / smlnum
438 anrm =
dlange(
'M', n, n, a, lda, dum )
440 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
443 ELSE IF( anrm.GT.bignum )
THEN
448 $ CALL
dlascl(
'G', 0, 0, anrm, cscale, n, n, a, lda, ierr )
454 CALL
dgebal(
'P', n, a, lda, ilo, ihi, work( ibal ), ierr )
461 CALL
dgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),
462 $ lwork-iwrk+1, ierr )
468 CALL
dlacpy(
'L', n, n, a, lda, vs, ldvs )
473 CALL
dorghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),
474 $ lwork-iwrk+1, ierr )
483 CALL
dhseqr(
'S', jobvs, n, ilo, ihi, a, lda, wr, wi, vs, ldvs,
484 $ work( iwrk ), lwork-iwrk+1, ieval )
490 IF( wantst .AND. info.EQ.0 )
THEN
492 CALL
dlascl(
'G', 0, 0, cscale, anrm, n, 1, wr, n, ierr )
493 CALL
dlascl(
'G', 0, 0, cscale, anrm, n, 1, wi, n, ierr )
496 bwork( i ) =
SELECT( wr( i ), wi( i ) )
506 CALL
dtrsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,
507 $ sdim, rconde, rcondv, work( iwrk ), lwork-iwrk+1,
508 $ iwork, liwork, icond )
510 $ maxwrk = max( maxwrk, n+2*sdim*( n-sdim ) )
511 IF( icond.EQ.-15 )
THEN
516 ELSE IF( icond.EQ.-17 )
THEN
521 ELSE IF( icond.GT.0 )
THEN
534 CALL
dgebak(
'P',
'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,
542 CALL
dlascl(
'H', 0, 0, cscale, anrm, n, n, a, lda, ierr )
543 CALL
dcopy( n, a, lda+1, wr, 1 )
544 IF( ( wantsv .OR. wantsb ) .AND. info.EQ.0 )
THEN
546 CALL
dlascl(
'G', 0, 0, cscale, anrm, 1, 1, dum, 1, ierr )
549 IF( cscale.EQ.smlnum )
THEN
555 IF( ieval.GT.0 )
THEN
558 CALL
dlascl(
'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n,
560 ELSE IF( wantst )
THEN
571 IF( wi( i ).EQ.zero )
THEN
574 IF( a( i+1, i ).EQ.zero )
THEN
577 ELSE IF( a( i+1, i ).NE.zero .AND. a( i, i+1 ).EQ.
582 $ CALL
dswap( i-1, a( 1, i ), 1, a( 1, i+1 ), 1 )
584 $ CALL
dswap( n-i-1, a( i, i+2 ), lda,
585 $ a( i+1, i+2 ), lda )
586 CALL
dswap( n, vs( 1, i ), 1, vs( 1, i+1 ), 1 )
587 a( i, i+1 ) = a( i+1, i )
594 CALL
dlascl(
'G', 0, 0, cscale, anrm, n-ieval, 1,
595 $ wi( ieval+1 ), max( n-ieval, 1 ), ierr )
598 IF( wantst .AND. info.EQ.0 )
THEN
607 cursl =
SELECT( wr( i ), wi( i ) )
608 IF( wi( i ).EQ.zero )
THEN
612 IF( cursl .AND. .NOT.lastsl )
619 cursl = cursl .OR. lastsl
624 IF( cursl .AND. .NOT.lst2sl )
639 IF( wantsv .OR. wantsb )
THEN
640 iwork( 1 ) = max( 1, sdim*( n-sdim ) )
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 ...
subroutine dgeesx(JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO)
DGEESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE...
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)