370 SUBROUTINE cggevx( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB,
371 $ ALPHA, BETA, VL, LDVL, VR, LDVR, ILO, IHI,
372 $ LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV,
373 $ WORK, LWORK, RWORK, IWORK, BWORK, INFO )
380 CHARACTER BALANC, JOBVL, JOBVR, SENSE
381 INTEGER IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N
387 REAL LSCALE( * ), RCONDE( * ), RCONDV( * ),
388 $ rscale( * ), rwork( * )
389 COMPLEX A( LDA, * ), ALPHA( * ), B( LDB, * ),
390 $ beta( * ), vl( ldvl, * ), vr( ldvr, * ),
398 PARAMETER ( ZERO = 0.0e+0, one = 1.0e+0 )
400 parameter( czero = ( 0.0e+0, 0.0e+0 ),
401 $ cone = ( 1.0e+0, 0.0e+0 ) )
404 LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY, NOSCL,
405 $ WANTSB, WANTSE, WANTSN, WANTSV
407 INTEGER I, ICOLS, IERR, IJOBVL, IJOBVR, IN, IROWS,
408 $ ITAU, IWRK, IWRK1, J, JC, JR, M, MAXWRK, MINWRK
409 REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
425 EXTERNAL lsame, ilaenv, clange, slamch
428 INTRINSIC abs, aimag, max, real, sqrt
434 abs1( x ) = abs( real( x ) ) + abs( aimag( x ) )
440 IF( lsame( jobvl,
'N' ) )
THEN
443 ELSE IF( lsame( jobvl,
'V' ) )
THEN
451 IF( lsame( jobvr,
'N' ) )
THEN
454 ELSE IF( lsame( jobvr,
'V' ) )
THEN
463 noscl = lsame( balanc,
'N' ) .OR. lsame( balanc,
'P' )
464 wantsn = lsame( sense,
'N' )
465 wantse = lsame( sense,
'E' )
466 wantsv = lsame( sense,
'V' )
467 wantsb = lsame( sense,
'B' )
472 lquery = ( lwork.EQ.-1 )
473 IF( .NOT.( noscl .OR. lsame( balanc,
'S' ) .OR.
474 $ lsame( balanc,
'B' ) ) )
THEN
476 ELSE IF( ijobvl.LE.0 )
THEN
478 ELSE IF( ijobvr.LE.0 )
THEN
480 ELSE IF( .NOT.( wantsn .OR. wantse .OR. wantsb .OR. wantsv ) )
483 ELSE IF( n.LT.0 )
THEN
485 ELSE IF( lda.LT.max( 1, n ) )
THEN
487 ELSE IF( ldb.LT.max( 1, n ) )
THEN
489 ELSE IF( ldvl.LT.1 .OR. ( ilvl .AND. ldvl.LT.n ) )
THEN
491 ELSE IF( ldvr.LT.1 .OR. ( ilvr .AND. ldvr.LT.n ) )
THEN
511 ELSE IF( wantsv .OR. wantsb )
THEN
512 minwrk = 2*n*( n + 1)
515 maxwrk = max( maxwrk,
516 $ n + n*ilaenv( 1,
'CGEQRF',
' ', n, 1, n, 0 ) )
517 maxwrk = max( maxwrk,
518 $ n + n*ilaenv( 1,
'CUNMQR',
' ', n, 1, n, 0 ) )
520 maxwrk = max( maxwrk, n +
521 $ n*ilaenv( 1,
'CUNGQR',
' ', n, 1, n, 0 ) )
526 IF( lwork.LT.minwrk .AND. .NOT.lquery )
THEN
532 CALL xerbla(
'CGGEVX', -info )
534 ELSE IF( lquery )
THEN
546 smlnum = slamch(
'S' )
547 bignum = one / smlnum
548 CALL slabad( smlnum, bignum )
549 smlnum = sqrt( smlnum ) / eps
550 bignum = one / smlnum
554 anrm = clange(
'M', n, n, a, lda, rwork )
556 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
559 ELSE IF( anrm.GT.bignum )
THEN
564 $
CALL clascl(
'G', 0, 0, anrm, anrmto, n, n, a, lda, ierr )
568 bnrm = clange(
'M', n, n, b, ldb, rwork )
570 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
573 ELSE IF( bnrm.GT.bignum )
THEN
578 $
CALL clascl(
'G', 0, 0, bnrm, bnrmto, n, n, b, ldb, ierr )
583 CALL cggbal( balanc, n, a, lda, b, ldb, ilo, ihi, lscale, rscale,
588 abnrm = clange(
'1', n, n, a, lda, rwork( 1 ) )
591 CALL slascl(
'G', 0, 0, anrmto, anrm, 1, 1, rwork( 1 ), 1,
596 bbnrm = clange(
'1', n, n, b, ldb, rwork( 1 ) )
599 CALL slascl(
'G', 0, 0, bnrmto, bnrm, 1, 1, rwork( 1 ), 1,
607 irows = ihi + 1 - ilo
608 IF( ilv .OR. .NOT.wantsn )
THEN
615 CALL cgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),
616 $ work( iwrk ), lwork+1-iwrk, ierr )
621 CALL cunmqr(
'L',
'C', irows, icols, irows, b( ilo, ilo ), ldb,
622 $ work( itau ), a( ilo, ilo ), lda, work( iwrk ),
623 $ lwork+1-iwrk, ierr )
629 CALL claset(
'Full', n, n, czero, cone, vl, ldvl )
630 IF( irows.GT.1 )
THEN
631 CALL clacpy(
'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,
632 $ vl( ilo+1, ilo ), ldvl )
634 CALL cungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,
635 $ work( itau ), work( iwrk ), lwork+1-iwrk, ierr )
639 $
CALL claset(
'Full', n, n, czero, cone, vr, ldvr )
644 IF( ilv .OR. .NOT.wantsn )
THEN
648 CALL cgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,
649 $ ldvl, vr, ldvr, ierr )
651 CALL cgghrd(
'N',
'N', irows, 1, irows, a( ilo, ilo ), lda,
652 $ b( ilo, ilo ), ldb, vl, ldvl, vr, ldvr, ierr )
661 IF( ilv .OR. .NOT.wantsn )
THEN
667 CALL chgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,
668 $ alpha, beta, vl, ldvl, vr, ldvr, work( iwrk ),
669 $ lwork+1-iwrk, rwork, ierr )
671 IF( ierr.GT.0 .AND. ierr.LE.n )
THEN
673 ELSE IF( ierr.GT.n .AND. ierr.LE.2*n )
THEN
687 IF( ilv .OR. .NOT.wantsn )
THEN
699 CALL ctgevc( chtemp,
'B', ldumma, n, a, lda, b, ldb, vl,
700 $ ldvl, vr, ldvr, n, in, work( iwrk ), rwork,
708 IF( .NOT.wantsn )
THEN
729 IF( wantse .OR. wantsb )
THEN
730 CALL ctgevc(
'B',
'S', bwork, n, a, lda, b, ldb,
731 $ work( 1 ), n, work( iwrk ), n, 1, m,
732 $ work( iwrk1 ), rwork, ierr )
739 CALL ctgsna( sense,
'S', bwork, n, a, lda, b, ldb,
740 $ work( 1 ), n, work( iwrk ), n, rconde( i ),
741 $ rcondv( i ), 1, m, work( iwrk1 ),
742 $ lwork-iwrk1+1, iwork, ierr )
752 CALL cggbak( balanc,
'L', n, ilo, ihi, lscale, rscale, n, vl,
758 temp = max( temp, abs1( vl( jr, jc ) ) )
764 vl( jr, jc ) = vl( jr, jc )*temp
770 CALL cggbak( balanc,
'R', n, ilo, ihi, lscale, rscale, n, vr,
775 temp = max( temp, abs1( vr( jr, jc ) ) )
781 vr( jr, jc ) = vr( jr, jc )*temp
791 $
CALL clascl(
'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr )
794 $
CALL clascl(
'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr )
subroutine slabad(SMALL, LARGE)
SLABAD
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 xerbla(SRNAME, INFO)
XERBLA
subroutine cggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
CGGBAL
subroutine cggbak(JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO)
CGGBAK
subroutine chgeqz(JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO)
CHGEQZ
subroutine cgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
CGEQRF
subroutine ctgevc(SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO)
CTGEVC
subroutine cggevx(BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, IWORK, BWORK, INFO)
CGGEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
subroutine clascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
CLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine ctgsna(JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO)
CTGSNA
subroutine cunmqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
CUNMQR
subroutine cgghrd(COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO)
CGGHRD
subroutine cungqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
CUNGQR