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 ( = 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.LE.
ELSE IF( IJOBVL0 ) THEN
478.LE.
ELSE IF( IJOBVR0 ) THEN
480.NOT..OR..OR..OR.
ELSE IF( ( WANTSN WANTSE WANTSB WANTSV ) )
483.LT.
ELSE IF( N0 ) THEN
485.LT.
ELSE IF( LDAMAX( 1, N ) ) THEN
487.LT.
ELSE IF( LDBMAX( 1, N ) ) THEN
489.LT..OR..AND..LT.
ELSE IF( LDVL1 ( ILVL LDVLN ) ) THEN
491.LT..OR..AND..LT.
ELSE IF( LDVR1 ( ILVR LDVRN ) ) THEN
511.OR.
ELSE IF( WANTSV 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.LT..AND..NOT.
IF( LWORKMINWRK 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.GT..AND..LT.
IF( ANRMZERO ANRMSMLNUM ) THEN
559.GT.
ELSE IF( ANRMBIGNUM ) THEN
564 $ CALL CLASCL( 'g
', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
568 BNRM = CLANGE( 'm
', N, N, B, LDB, RWORK )
570.GT..AND..LT.
IF( BNRMZERO BNRMSMLNUM ) THEN
573.GT.
ELSE IF( BNRMBIGNUM ) 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.OR..NOT.
IF( ILV 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.GT.
IF( IROWS1 ) 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.OR..NOT.
IF( ILV 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.OR..NOT.
IF( ILV 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.GT..AND..LE.
IF( IERR0 IERRN ) THEN
673.GT..AND..LE.
ELSE IF( IERRN IERR2*N ) THEN
687.OR..NOT.
IF( ILV WANTSN ) THEN
699 CALL CTGEVC( CHTEMP, 'b
', LDUMMA, N, A, LDA, B, LDB, VL,
700 $ LDVL, VR, LDVR, N, IN, WORK( IWRK ), RWORK,
708.NOT.
IF( WANTSN ) THEN
729.OR.
IF( WANTSE 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 cggbak(job, side, n, ilo, ihi, lscale, rscale, m, v, ldv, info)
CGGBAK
subroutine cggbal(job, n, a, lda, b, ldb, ilo, ihi, lscale, rscale, work, info)
CGGBAL
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 chgeqz(job, compq, compz, n, ilo, ihi, h, ldh, t, ldt, alpha, beta, q, ldq, z, ldz, work, lwork, rwork, info)
CHGEQZ
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 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 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 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