278 SUBROUTINE sgeesx( 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
294 REAL A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ),
306 PARAMETER ( ZERO = 0.0e0, one = 1.0e0 )
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, LWRK, LIWRK,
314 REAL ANRM, BIGNUM, CSCALE, EPS, SMLNUM
327 EXTERNAL lsame, ilaenv, slamch, slange
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,
'SGEHRD',
' ', n, 1, n, 0 )
383 CALL shseqr(
'S', jobvs, n, 1, n, a, lda, wr, wi, vs, ldvs,
387 IF( .NOT.wantvs )
THEN
388 maxwrk = max( maxwrk, n + hswork )
390 maxwrk = max( maxwrk, 2*n + ( n - 1 )*ilaenv( 1,
391 $
'SORGHR',
' ', 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(
'SGEESX', -info )
413 ELSE IF( lquery )
THEN
427 smlnum = slamch(
'S' )
428 bignum = one / smlnum
429 CALL slabad( smlnum, bignum )
430 smlnum = sqrt( smlnum ) / eps
431 bignum = one / smlnum
435 anrm = slange(
'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 slascl(
'G', 0, 0, anrm, cscale, n, n, a, lda, ierr )
451 CALL sgebal(
'P', n, a, lda, ilo, ihi, work( ibal ), ierr )
458 CALL sgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),
459 $ lwork-iwrk+1, ierr )
465 CALL slacpy(
'L', n, n, a, lda, vs, ldvs )
470 CALL sorghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),
471 $ lwork-iwrk+1, ierr )
480 CALL shseqr(
'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 slascl(
'G', 0, 0, cscale, anrm, n, 1, wr, n, ierr )
490 CALL slascl(
'G', 0, 0, cscale, anrm, n, 1, wi, n, ierr )
493 bwork( i ) =
SELECT( wr( i ), wi( i ) )
503 CALL strsen( 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 sgebak(
'P',
'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,
539 CALL slascl(
'H', 0, 0, cscale, anrm, n, n, a, lda, ierr )
540 CALL scopy( n, a, lda+1, wr, 1 )
541 IF( ( wantsv .OR. wantsb ) .AND. info.EQ.0 )
THEN
543 CALL slascl(
'G', 0, 0, cscale, anrm, 1, 1, dum, 1, ierr )
546 IF( cscale.EQ.smlnum )
THEN
552 IF( ieval.GT.0 )
THEN
555 CALL slascl(
'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 sswap( i-1, a( 1, i ), 1, a( 1, i+1 ), 1 )
581 $
CALL sswap( n-i-1, a( i, i+2 ), lda,
582 $ a( i+1, i+2 ), lda )
584 CALL sswap( n, vs( 1, i ), 1, vs( 1, i+1 ), 1 )
586 a( i, i+1 ) = a( i+1, i )
593 CALL slascl(
'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 ) = sdim*(n-sdim)
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine slascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
SLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine sgebal(JOB, N, A, LDA, ILO, IHI, SCALE, INFO)
SGEBAL
subroutine sgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
SGEHRD
subroutine sgebak(JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO)
SGEBAK
subroutine sgeesx(JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO)
SGEESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE ...
subroutine sorghr(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
SORGHR
subroutine strsen(JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO)
STRSEN
subroutine shseqr(JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO)
SHSEQR
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY