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