226 SUBROUTINE sgegs( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR,
227 $ alphai, beta, vsl, ldvsl, vsr, ldvsr, work,
236 CHARACTER JOBVSL, JOBVSR
237 INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N
240 REAL A( lda, * ), ALPHAI( * ), ALPHAR( * ),
241 $ b( ldb, * ), beta( * ), vsl( ldvsl, * ),
242 $ vsr( ldvsr, * ), work( * )
249 parameter( zero = 0.0e0, one = 1.0e0 )
252 LOGICAL ILASCL, ILBSCL, ILVSL, ILVSR, LQUERY
253 INTEGER ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT,
254 $ ilo, iright, irows, itau, iwork, lopt, lwkmin,
255 $ lwkopt, nb, nb1, nb2, nb3
256 REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
267 EXTERNAL ilaenv, lsame, slamch, slange
276 IF( lsame( jobvsl,
'N' ) )
THEN
279 ELSE IF( lsame( jobvsl,
'V' ) )
THEN
287 IF( lsame( jobvsr,
'N' ) )
THEN
290 ELSE IF( lsame( jobvsr,
'V' ) )
THEN
300 lwkmin = max( 4*n, 1 )
303 lquery = ( lwork.EQ.-1 )
305 IF( ijobvl.LE.0 )
THEN
307 ELSE IF( ijobvr.LE.0 )
THEN
309 ELSE IF( n.LT.0 )
THEN
311 ELSE IF( lda.LT.max( 1, n ) )
THEN
313 ELSE IF( ldb.LT.max( 1, n ) )
THEN
315 ELSE IF( ldvsl.LT.1 .OR. ( ilvsl .AND. ldvsl.LT.n ) )
THEN
317 ELSE IF( ldvsr.LT.1 .OR. ( ilvsr .AND. ldvsr.LT.n ) )
THEN
319 ELSE IF( lwork.LT.lwkmin .AND. .NOT.lquery )
THEN
324 nb1 = ilaenv( 1,
'SGEQRF',
' ', n, n, -1, -1 )
325 nb2 = ilaenv( 1,
'SORMQR',
' ', n, n, n, -1 )
326 nb3 = ilaenv( 1,
'SORGQR',
' ', n, n, n, -1 )
327 nb = max( nb1, nb2, nb3 )
333 CALL
xerbla(
'SGEGS ', -info )
335 ELSE IF( lquery )
THEN
346 eps = slamch(
'E' )*slamch(
'B' )
347 safmin = slamch(
'S' )
348 smlnum = n*safmin / eps
349 bignum = one / smlnum
353 anrm = slange(
'M', n, n, a, lda, work )
355 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
358 ELSE IF( anrm.GT.bignum )
THEN
364 CALL
slascl(
'G', -1, -1, anrm, anrmto, n, n, a, lda, iinfo )
365 IF( iinfo.NE.0 )
THEN
373 bnrm = slange(
'M', n, n, b, ldb, work )
375 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
378 ELSE IF( bnrm.GT.bignum )
THEN
384 CALL
slascl(
'G', -1, -1, bnrm, bnrmto, n, n, b, ldb, iinfo )
385 IF( iinfo.NE.0 )
THEN
398 CALL
sggbal(
'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),
399 $ work( iright ), work( iwork ), iinfo )
400 IF( iinfo.NE.0 )
THEN
409 irows = ihi + 1 - ilo
413 CALL
sgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),
414 $ work( iwork ), lwork+1-iwork, iinfo )
416 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
417 IF( iinfo.NE.0 )
THEN
422 CALL
sormqr(
'L',
'T', irows, icols, irows, b( ilo, ilo ), ldb,
423 $ work( itau ), a( ilo, ilo ), lda, work( iwork ),
424 $ lwork+1-iwork, iinfo )
426 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
427 IF( iinfo.NE.0 )
THEN
433 CALL
slaset(
'Full', n, n, zero, one, vsl, ldvsl )
434 CALL
slacpy(
'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,
435 $ vsl( ilo+1, ilo ), ldvsl )
436 CALL
sorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,
437 $ work( itau ), work( iwork ), lwork+1-iwork,
440 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
441 IF( iinfo.NE.0 )
THEN
448 $ CALL
slaset(
'Full', n, n, zero, one, vsr, ldvsr )
452 CALL
sgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,
453 $ ldvsl, vsr, ldvsr, iinfo )
454 IF( iinfo.NE.0 )
THEN
464 CALL
shgeqz(
'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,
465 $ alphar, alphai, beta, vsl, ldvsl, vsr, ldvsr,
466 $ work( iwork ), lwork+1-iwork, iinfo )
468 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
469 IF( iinfo.NE.0 )
THEN
470 IF( iinfo.GT.0 .AND. iinfo.LE.n )
THEN
472 ELSE IF( iinfo.GT.n .AND. iinfo.LE.2*n )
THEN
483 CALL
sggbak(
'P',
'L', n, ilo, ihi, work( ileft ),
484 $ work( iright ), n, vsl, ldvsl, iinfo )
485 IF( iinfo.NE.0 )
THEN
491 CALL
sggbak(
'P',
'R', n, ilo, ihi, work( ileft ),
492 $ work( iright ), n, vsr, ldvsr, iinfo )
493 IF( iinfo.NE.0 )
THEN
502 CALL
slascl(
'H', -1, -1, anrmto, anrm, n, n, a, lda, iinfo )
503 IF( iinfo.NE.0 )
THEN
507 CALL
slascl(
'G', -1, -1, anrmto, anrm, n, 1, alphar, n,
509 IF( iinfo.NE.0 )
THEN
513 CALL
slascl(
'G', -1, -1, anrmto, anrm, n, 1, alphai, n,
515 IF( iinfo.NE.0 )
THEN
522 CALL
slascl(
'U', -1, -1, bnrmto, bnrm, n, n, b, ldb, iinfo )
523 IF( iinfo.NE.0 )
THEN
527 CALL
slascl(
'G', -1, -1, bnrmto, bnrm, n, 1, beta, n, iinfo )
528 IF( iinfo.NE.0 )
THEN
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine sggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
SGGBAL
subroutine sormqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMQR
subroutine sgghrd(COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO)
SGGHRD
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine shgeqz(JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, INFO)
SHGEQZ
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 sgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGEQRF
subroutine sgegs(JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, INFO)
SGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
subroutine sorgqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
SORGQR
subroutine sggbak(JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO)
SGGBAK