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