216 SUBROUTINE sgees( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI,
217 $ vs, ldvs, work, lwork, bwork, info )
225 CHARACTER JOBVS, SORT
226 INTEGER INFO, LDA, LDVS, LWORK, N, SDIM
230 REAL A( lda, * ), VS( ldvs, * ), WI( * ), WORK( * ),
242 parameter( zero = 0.0e0, one = 1.0e0 )
245 LOGICAL CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTST,
247 INTEGER HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL,
248 $ ihi, ilo, inxt, ip, itau, iwrk, maxwrk, minwrk
249 REAL ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM
263 EXTERNAL lsame, ilaenv, slamch, slange
273 lquery = ( lwork.EQ.-1 )
274 wantvs = lsame( jobvs,
'V' )
275 wantst = lsame( sort,
'S' )
276 IF( ( .NOT.wantvs ) .AND. ( .NOT.lsame( jobvs,
'N' ) ) )
THEN
278 ELSE IF( ( .NOT.wantst ) .AND. ( .NOT.lsame( sort,
'N' ) ) )
THEN
280 ELSE IF( n.LT.0 )
THEN
282 ELSE IF( lda.LT.max( 1, n ) )
THEN
284 ELSE IF( ldvs.LT.1 .OR. ( wantvs .AND. ldvs.LT.n ) )
THEN
303 maxwrk = 2*n + n*ilaenv( 1,
'SGEHRD',
' ', n, 1, n, 0 )
306 CALL
shseqr(
'S', jobvs, n, 1, n, a, lda, wr, wi, vs, ldvs,
310 IF( .NOT.wantvs )
THEN
311 maxwrk = max( maxwrk, n + hswork )
313 maxwrk = max( maxwrk, 2*n + ( n - 1 )*ilaenv( 1,
314 $
'SORGHR',
' ', n, 1, n, -1 ) )
315 maxwrk = max( maxwrk, n + hswork )
320 IF( lwork.LT.minwrk .AND. .NOT.lquery )
THEN
326 CALL
xerbla(
'SGEES ', -info )
328 ELSE IF( lquery )
THEN
342 smlnum = slamch(
'S' )
343 bignum = one / smlnum
344 CALL
slabad( smlnum, bignum )
345 smlnum = sqrt( smlnum ) / eps
346 bignum = one / smlnum
350 anrm = slange(
'M', n, n, a, lda, dum )
352 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
355 ELSE IF( anrm.GT.bignum )
THEN
360 $ CALL
slascl(
'G', 0, 0, anrm, cscale, n, n, a, lda, ierr )
366 CALL
sgebal(
'P', n, a, lda, ilo, ihi, work( ibal ), ierr )
373 CALL
sgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),
374 $ lwork-iwrk+1, ierr )
380 CALL
slacpy(
'L', n, n, a, lda, vs, ldvs )
385 CALL
sorghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),
386 $ lwork-iwrk+1, ierr )
395 CALL
shseqr(
'S', jobvs, n, ilo, ihi, a, lda, wr, wi, vs, ldvs,
396 $ work( iwrk ), lwork-iwrk+1, ieval )
402 IF( wantst .AND. info.EQ.0 )
THEN
404 CALL
slascl(
'G', 0, 0, cscale, anrm, n, 1, wr, n, ierr )
405 CALL
slascl(
'G', 0, 0, cscale, anrm, n, 1, wi, n, ierr )
408 bwork( i ) =
SELECT( wr( i ), wi( i ) )
414 CALL
strsen(
'N', jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,
415 $ sdim, s, sep, work( iwrk ), lwork-iwrk+1, idum, 1,
426 CALL
sgebak(
'P',
'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,
434 CALL
slascl(
'H', 0, 0, cscale, anrm, n, n, a, lda, ierr )
435 CALL
scopy( n, a, lda+1, wr, 1 )
436 IF( cscale.EQ.smlnum )
THEN
442 IF( ieval.GT.0 )
THEN
445 CALL
slascl(
'G', 0, 0, cscale, anrm, ilo-1, 1, wi,
446 $ max( ilo-1, 1 ), ierr )
447 ELSE IF( wantst )
THEN
458 IF( wi( i ).EQ.zero )
THEN
461 IF( a( i+1, i ).EQ.zero )
THEN
464 ELSE IF( a( i+1, i ).NE.zero .AND. a( i, i+1 ).EQ.
469 $ CALL
sswap( i-1, a( 1, i ), 1, a( 1, i+1 ), 1 )
471 $ CALL
sswap( n-i-1, a( i, i+2 ), lda,
472 $ a( i+1, i+2 ), lda )
474 CALL
sswap( n, vs( 1, i ), 1, vs( 1, i+1 ), 1 )
476 a( i, i+1 ) = a( i+1, i )
486 CALL
slascl(
'G', 0, 0, cscale, anrm, n-ieval, 1,
487 $ wi( ieval+1 ), max( n-ieval, 1 ), ierr )
490 IF( wantst .AND. info.EQ.0 )
THEN
499 cursl =
SELECT( wr( i ), wi( i ) )
500 IF( wi( i ).EQ.zero )
THEN
504 IF( cursl .AND. .NOT.lastsl )
511 cursl = cursl .OR. lastsl
516 IF( cursl .AND. .NOT.lst2sl )
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP
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
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 sgees(JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, VS, LDVS, WORK, LWORK, BWORK, INFO)
SGEES 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.
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine sorghr(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
SORGHR
subroutine sgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
SGEHRD