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,
441 EXTERNAL lsame, ilaenv, slamch, slange
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
561 smlnum = slamch(
'S' )
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 sggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
SGGBAL
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 sgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGEQRF
subroutine sormqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMQR
subroutine shgeqz(JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, INFO)
SHGEQZ
subroutine xerbla(SRNAME, INFO)
XERBLA
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 sggbak(JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO)
SGGBAK
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 slabad(SMALL, LARGE)
SLABAD
subroutine sgghrd(COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO)
SGGHRD
subroutine sorgqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
SORGQR
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine stgsna(JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO)
STGSNA