389 SUBROUTINE sggevx( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB,
390 $ alphar, alphai, beta, vl, ldvl, vr, ldvr, ilo,
391 $ ihi, lscale, rscale, abnrm, bbnrm, rconde,
392 $ rcondv, work, lwork, iwork, bwork, info )
400 CHARACTER balanc, jobvl, jobvr, sense
401 INTEGER ihi, ilo, info, lda, ldb, ldvl, ldvr, lwork, n
407 REAL a( lda, * ), alphai( * ), alphar( * ),
408 $
b( ldb, * ), beta( * ), lscale( * ),
409 $ rconde( * ), rcondv( * ), rscale( * ),
410 $ vl( ldvl, * ), vr( ldvr, * ), work( * )
417 parameter( zero = 0.0e+0, one = 1.0e+0 )
420 LOGICAL ilascl, ilbscl, ilv, ilvl, ilvr, lquery, noscl,
421 $ pair, wantsb, wantse, wantsn, wantsv
423 INTEGER i, icols, ierr, ijobvl, ijobvr, in, irows,
424 $ itau, iwrk, iwrk1,
j, jc, jr, m, maxwrk,
426 REAL anrm, anrmto, bignum, bnrm, bnrmto, eps,
444 INTRINSIC abs, max, sqrt
450 IF(
lsame( jobvl,
'N' ) )
THEN
453 ELSE IF(
lsame( jobvl,
'V' ) )
THEN
461 IF(
lsame( jobvr,
'N' ) )
THEN
464 ELSE IF(
lsame( jobvr,
'V' ) )
THEN
473 noscl =
lsame( balanc,
'N' ) .OR.
lsame( balanc,
'P' )
474 wantsn =
lsame( sense,
'N' )
475 wantse =
lsame( sense,
'E' )
476 wantsv =
lsame( sense,
'V' )
477 wantsb =
lsame( sense,
'B' )
482 lquery = ( lwork.EQ.-1 )
483 IF( .NOT.( noscl .OR.
lsame( balanc,
'S' ) .OR.
484 $
lsame( balanc,
'B' ) ) )
THEN
486 ELSE IF( ijobvl.LE.0 )
THEN
488 ELSE IF( ijobvr.LE.0 )
THEN
490 ELSE IF( .NOT.( wantsn .OR. wantse .OR. wantsb .OR. wantsv ) )
493 ELSE IF( n.LT.0 )
THEN
495 ELSE IF( lda.LT.max( 1, n ) )
THEN
497 ELSE IF( ldb.LT.max( 1, n ) )
THEN
499 ELSE IF( ldvl.LT.1 .OR. ( ilvl .AND. ldvl.LT.n ) )
THEN
501 ELSE IF( ldvr.LT.1 .OR. ( ilvr .AND. ldvr.LT.n ) )
THEN
518 IF( noscl .AND. .NOT.ilv )
THEN
525 ELSE IF( wantsv .OR. wantsb )
THEN
526 minwrk = 2*n*( n + 4 ) + 16
529 maxwrk = max( maxwrk,
530 $ n + n*
ilaenv( 1,
'SGEQRF',
' ', n, 1, n, 0 ) )
531 maxwrk = max( maxwrk,
532 $ n + n*
ilaenv( 1,
'SORMQR',
' ', n, 1, n, 0 ) )
534 maxwrk = max( maxwrk, n +
535 $ n*
ilaenv( 1,
'SORGQR',
' ', n, 1, n, 0 ) )
540 IF( lwork.LT.minwrk .AND. .NOT.lquery )
THEN
546 CALL
xerbla(
'SGGEVX', -info )
548 ELSE IF( lquery )
THEN
562 bignum = one / smlnum
563 CALL
slabad( smlnum, bignum )
564 smlnum = sqrt( smlnum ) / eps
565 bignum = one / smlnum
569 anrm =
slange(
'M', n, n, a, lda, work )
571 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
574 ELSE IF( anrm.GT.bignum )
THEN
579 $ CALL
slascl(
'G', 0, 0, anrm, anrmto, n, n, a, lda, ierr )
583 bnrm =
slange(
'M', n, n,
b, ldb, work )
585 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
588 ELSE IF( bnrm.GT.bignum )
THEN
593 $ CALL
slascl(
'G', 0, 0, bnrm, bnrmto, n, n,
b, ldb, ierr )
598 CALL
sggbal( balanc, n, a, lda,
b, ldb, ilo, ihi, lscale, rscale,
603 abnrm =
slange(
'1', n, n, a, lda, work( 1 ) )
606 CALL
slascl(
'G', 0, 0, anrmto, anrm, 1, 1, work( 1 ), 1,
611 bbnrm =
slange(
'1', n, n,
b, ldb, work( 1 ) )
614 CALL
slascl(
'G', 0, 0, bnrmto, bnrm, 1, 1, work( 1 ), 1,
622 irows = ihi + 1 - ilo
623 IF( ilv .OR. .NOT.wantsn )
THEN
630 CALL
sgeqrf( irows, icols,
b( ilo, ilo ), ldb, work( itau ),
631 $ work( iwrk ), lwork+1-iwrk, ierr )
636 CALL
sormqr(
'L',
'T', irows, icols, irows,
b( ilo, ilo ), ldb,
637 $ work( itau ), a( ilo, ilo ), lda, work( iwrk ),
638 $ lwork+1-iwrk, ierr )
644 CALL
slaset(
'Full', n, n, zero, one, vl, ldvl )
645 IF( irows.GT.1 )
THEN
646 CALL
slacpy(
'L', irows-1, irows-1,
b( ilo+1, ilo ), ldb,
647 $ vl( ilo+1, ilo ), ldvl )
649 CALL
sorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,
650 $ work( itau ), work( iwrk ), lwork+1-iwrk, ierr )
654 $ CALL
slaset(
'Full', n, n, zero, one, vr, ldvr )
659 IF( ilv .OR. .NOT.wantsn )
THEN
663 CALL
sgghrd( jobvl, jobvr, n, ilo, ihi, a, lda,
b, ldb, vl,
664 $ ldvl, vr, ldvr, ierr )
666 CALL
sgghrd(
'N',
'N', irows, 1, irows, a( ilo, ilo ), lda,
667 $
b( ilo, ilo ), ldb, vl, ldvl, vr, ldvr, ierr )
674 IF( ilv .OR. .NOT.wantsn )
THEN
680 CALL
shgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda,
b, ldb,
681 $ alphar, alphai, beta, vl, ldvl, vr, ldvr, work,
684 IF( ierr.GT.0 .AND. ierr.LE.n )
THEN
686 ELSE IF( ierr.GT.n .AND. ierr.LE.2*n )
THEN
699 IF( ilv .OR. .NOT.wantsn )
THEN
711 CALL
stgevc( chtemp,
'B', ldumma, n, a, lda,
b, ldb, vl,
712 $ ldvl, vr, ldvr, n, in, work, ierr )
719 IF( .NOT.wantsn )
THEN
738 IF( a( i+1, i ).NE.zero )
THEN
749 ELSE IF( mm.EQ.2 )
THEN
751 bwork( i+1 ) = .true.
760 IF( wantse .OR. wantsb )
THEN
761 CALL
stgevc(
'B',
'S', bwork, n, a, lda,
b, ldb,
762 $ work( 1 ), n, work( iwrk ), n, mm, m,
763 $ work( iwrk1 ), ierr )
770 CALL
stgsna( sense,
'S', bwork, n, a, lda,
b, ldb,
771 $ work( 1 ), n, work( iwrk ), n, rconde( i ),
772 $ rcondv( i ), mm, m, work( iwrk1 ),
773 $ lwork-iwrk1+1, iwork, ierr )
783 CALL
sggbak( balanc,
'L', n, ilo, ihi, lscale, rscale, n, vl,
787 IF( alphai( jc ).LT.zero )
790 IF( alphai( jc ).EQ.zero )
THEN
792 temp = max( temp, abs( vl( jr, jc ) ) )
796 temp = max( temp, abs( vl( jr, jc ) )+
797 $ abs( vl( jr, jc+1 ) ) )
803 IF( alphai( jc ).EQ.zero )
THEN
805 vl( jr, jc ) = vl( jr, jc )*temp
809 vl( jr, jc ) = vl( jr, jc )*temp
810 vl( jr, jc+1 ) = vl( jr, jc+1 )*temp
816 CALL
sggbak( balanc,
'R', n, ilo, ihi, lscale, rscale, n, vr,
819 IF( alphai( jc ).LT.zero )
822 IF( alphai( jc ).EQ.zero )
THEN
824 temp = max( temp, abs( vr( jr, jc ) ) )
828 temp = max( temp, abs( vr( jr, jc ) )+
829 $ abs( vr( jr, jc+1 ) ) )
835 IF( alphai( jc ).EQ.zero )
THEN
837 vr( jr, jc ) = vr( jr, jc )*temp
841 vr( jr, jc ) = vr( jr, jc )*temp
842 vr( jr, jc+1 ) = vr( jr, jc+1 )*temp
853 CALL
slascl(
'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr )
854 CALL
slascl(
'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr )
858 CALL
slascl(
'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr )
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
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 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 stgevc(SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, INFO)
STGEVC
subroutine sggevx(BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, BWORK, INFO)
SGGEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
logical function lsame(CA, CB)
LSAME
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.
real function slamch(CMACH)
SLAMCH
subroutine sgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGEQRF
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine stgsna(JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO)
STGSNA
subroutine slabad(SMALL, LARGE)
SLABAD
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
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