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 )
329 DOUBLE PRECISION DLAMCH, DLANGE
330 EXTERNAL lsame, ilaenv,
dlabad, dlamch, dlange
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
430 smlnum = dlamch(
'S' )
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 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...
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dtrsen(JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO)
DTRSEN
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 dgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
DGEHRD
subroutine dorghr(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
DORGHR
subroutine dgebak(JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO)
DGEBAK
subroutine dswap(N, DX, INCX, DY, INCY)
DSWAP
subroutine dgebal(JOB, N, A, LDA, ILO, IHI, SCALE, INFO)
DGEBAL
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dhseqr(JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO)
DHSEQR
subroutine dlabad(SMALL, LARGE)
DLABAD