280 SUBROUTINE sgeesx( 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
297 REAL a( lda, * ), vs( ldvs, * ), wi( * ), work( * ),
309 parameter( zero = 0.0e0, one = 1.0e0 )
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, lwrk, liwrk,
317 REAL anrm, bignum, cscale, eps, smlnum
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,
'SGEHRD',
' ', n, 1, n, 0 )
386 CALL
shseqr(
'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 $
'SORGHR',
' ', 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(
'SGEESX', -info )
416 ELSE IF( lquery )
THEN
431 bignum = one / smlnum
432 CALL
slabad( smlnum, bignum )
433 smlnum = sqrt( smlnum ) / eps
434 bignum = one / smlnum
438 anrm =
slange(
'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
slascl(
'G', 0, 0, anrm, cscale, n, n, a, lda, ierr )
454 CALL
sgebal(
'P', n, a, lda, ilo, ihi, work( ibal ), ierr )
461 CALL
sgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),
462 $ lwork-iwrk+1, ierr )
468 CALL
slacpy(
'L', n, n, a, lda, vs, ldvs )
473 CALL
sorghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),
474 $ lwork-iwrk+1, ierr )
483 CALL
shseqr(
'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
slascl(
'G', 0, 0, cscale, anrm, n, 1, wr, n, ierr )
493 CALL
slascl(
'G', 0, 0, cscale, anrm, n, 1, wi, n, ierr )
496 bwork( i ) =
SELECT( wr( i ), wi( i ) )
506 CALL
strsen( 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
sgebak(
'P',
'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,
542 CALL
slascl(
'H', 0, 0, cscale, anrm, n, n, a, lda, ierr )
543 CALL
scopy( n, a, lda+1, wr, 1 )
544 IF( ( wantsv .OR. wantsb ) .AND. info.EQ.0 )
THEN
546 CALL
slascl(
'G', 0, 0, cscale, anrm, 1, 1, dum, 1, ierr )
549 IF( cscale.EQ.smlnum )
THEN
555 IF( ieval.GT.0 )
THEN
558 CALL
slascl(
'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
sswap( i-1, a( 1, i ), 1, a( 1, i+1 ), 1 )
584 $ CALL
sswap( n-i-1, a( i, i+2 ), lda,
585 $ a( i+1, i+2 ), lda )
586 CALL
sswap( n, vs( 1, i ), 1, vs( 1, i+1 ), 1 )
587 a( i, i+1 ) = a( i+1, i )
594 CALL
slascl(
'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 ) = sdim*(n-sdim)
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP
real function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine sgebak(JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO)
SGEBAK
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 scopy(N, SX, INCX, SY, INCY)
SCOPY
logical function lsame(CA, CB)
LSAME
subroutine sgebal(JOB, N, A, LDA, ILO, IHI, SCALE, INFO)
SGEBAL
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 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 slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
real function slamch(CMACH)
SLAMCH
subroutine slabad(SMALL, LARGE)
SLABAD
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
subroutine sorghr(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
SORGHR
subroutine sgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
SGEHRD