278 SUBROUTINE dgeesx( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM,
279 $ WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK,
280 $ IWORK, LIWORK, BWORK, INFO )
287 CHARACTER JOBVS, SENSE, SORT
288 INTEGER INFO, LDA, LDVS, LIWORK, LWORK, N, SDIM
289 DOUBLE PRECISION RCONDE, RCONDV
294 DOUBLE PRECISION A( lda, * ), VS( ldvs, * ), WI( * ), WORK( * ),
305 DOUBLE PRECISION ZERO, ONE
306 parameter( zero = 0.0d0, one = 1.0d0 )
309 LOGICAL CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTSB,
310 $ wantse, wantsn, wantst, wantsv, wantvs
311 INTEGER HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL,
312 $ ihi, ilo, inxt, ip, itau, iwrk, liwrk, lwrk,
314 DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SMLNUM
317 DOUBLE PRECISION DUM( 1 )
326 DOUBLE PRECISION DLAMCH, DLANGE
327 EXTERNAL lsame, ilaenv,
dlabad, dlamch, dlange
337 wantvs = lsame( jobvs,
'V' )
338 wantst = lsame( sort,
'S' )
339 wantsn = lsame( sense,
'N' )
340 wantse = lsame( sense,
'E' )
341 wantsv = lsame( sense,
'V' )
342 wantsb = lsame( sense,
'B' )
343 lquery = ( lwork.EQ.-1 .OR. liwork.EQ.-1 )
345 IF( ( .NOT.wantvs ) .AND. ( .NOT.lsame( jobvs,
'N' ) ) )
THEN 347 ELSE IF( ( .NOT.wantst ) .AND. ( .NOT.lsame( sort,
'N' ) ) )
THEN 349 ELSE IF( .NOT.( wantsn .OR. wantse .OR. wantsv .OR. wantsb ) .OR.
350 $ ( .NOT.wantst .AND. .NOT.wantsn ) )
THEN 352 ELSE IF( n.LT.0 )
THEN 354 ELSE IF( lda.LT.max( 1, n ) )
THEN 356 ELSE IF( ldvs.LT.1 .OR. ( wantvs .AND. ldvs.LT.n ) )
THEN 380 maxwrk = 2*n + n*ilaenv( 1,
'DGEHRD',
' ', n, 1, n, 0 )
383 CALL dhseqr(
'S', jobvs, n, 1, n, a, lda, wr, wi, vs, ldvs,
385 hswork = int( work( 1 ) )
387 IF( .NOT.wantvs )
THEN 388 maxwrk = max( maxwrk, n + hswork )
390 maxwrk = max( maxwrk, 2*n + ( n - 1 )*ilaenv( 1,
391 $
'DORGHR',
' ', n, 1, n, -1 ) )
392 maxwrk = max( maxwrk, n + hswork )
396 $ lwrk = max( lwrk, n + ( n*n )/2 )
397 IF( wantsv .OR. wantsb )
403 IF( lwork.LT.minwrk .AND. .NOT.lquery )
THEN 405 ELSE IF( liwork.LT.1 .AND. .NOT.lquery )
THEN 411 CALL xerbla(
'DGEESX', -info )
413 ELSE IF( lquery )
THEN 427 smlnum = dlamch(
'S' )
428 bignum = one / smlnum
429 CALL dlabad( smlnum, bignum )
430 smlnum = sqrt( smlnum ) / eps
431 bignum = one / smlnum
435 anrm = dlange(
'M', n, n, a, lda, dum )
437 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN 440 ELSE IF( anrm.GT.bignum )
THEN 445 $
CALL dlascl(
'G', 0, 0, anrm, cscale, n, n, a, lda, ierr )
451 CALL dgebal(
'P', n, a, lda, ilo, ihi, work( ibal ), ierr )
458 CALL dgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),
459 $ lwork-iwrk+1, ierr )
465 CALL dlacpy(
'L', n, n, a, lda, vs, ldvs )
470 CALL dorghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),
471 $ lwork-iwrk+1, ierr )
480 CALL dhseqr(
'S', jobvs, n, ilo, ihi, a, lda, wr, wi, vs, ldvs,
481 $ work( iwrk ), lwork-iwrk+1, ieval )
487 IF( wantst .AND. info.EQ.0 )
THEN 489 CALL dlascl(
'G', 0, 0, cscale, anrm, n, 1, wr, n, ierr )
490 CALL dlascl(
'G', 0, 0, cscale, anrm, n, 1, wi, n, ierr )
493 bwork( i ) =
SELECT( wr( i ), wi( i ) )
503 CALL dtrsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,
504 $ sdim, rconde, rcondv, work( iwrk ), lwork-iwrk+1,
505 $ iwork, liwork, icond )
507 $ maxwrk = max( maxwrk, n+2*sdim*( n-sdim ) )
508 IF( icond.EQ.-15 )
THEN 513 ELSE IF( icond.EQ.-17 )
THEN 518 ELSE IF( icond.GT.0 )
THEN 531 CALL dgebak(
'P',
'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,
539 CALL dlascl(
'H', 0, 0, cscale, anrm, n, n, a, lda, ierr )
540 CALL dcopy( n, a, lda+1, wr, 1 )
541 IF( ( wantsv .OR. wantsb ) .AND. info.EQ.0 )
THEN 543 CALL dlascl(
'G', 0, 0, cscale, anrm, 1, 1, dum, 1, ierr )
546 IF( cscale.EQ.smlnum )
THEN 552 IF( ieval.GT.0 )
THEN 555 CALL dlascl(
'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n,
557 ELSE IF( wantst )
THEN 568 IF( wi( i ).EQ.zero )
THEN 571 IF( a( i+1, i ).EQ.zero )
THEN 574 ELSE IF( a( i+1, i ).NE.zero .AND. a( i, i+1 ).EQ.
579 $
CALL dswap( i-1, a( 1, i ), 1, a( 1, i+1 ), 1 )
581 $
CALL dswap( n-i-1, a( i, i+2 ), lda,
582 $ a( i+1, i+2 ), lda )
584 CALL dswap( n, vs( 1, i ), 1, vs( 1, i+1 ), 1 )
586 a( i, i+1 ) = a( i+1, i )
593 CALL dlascl(
'G', 0, 0, cscale, anrm, n-ieval, 1,
594 $ wi( ieval+1 ), max( n-ieval, 1 ), ierr )
597 IF( wantst .AND. info.EQ.0 )
THEN 606 cursl =
SELECT( wr( i ), wi( i ) )
607 IF( wi( i ).EQ.zero )
THEN 611 IF( cursl .AND. .NOT.lastsl )
618 cursl = cursl .OR. lastsl
623 IF( cursl .AND. .NOT.lst2sl )
638 IF( wantsv .OR. wantsb )
THEN 639 iwork( 1 ) = max( 1, sdim*( n-sdim ) )
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
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dorghr(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
DORGHR
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dhseqr(JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO)
DHSEQR
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 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 dswap(N, DX, INCX, DY, INCY)
DSWAP
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
DGEHRD
subroutine dgebak(JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO)
DGEBAK