372 SUBROUTINE cggevx( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB,
373 $ alpha, beta, vl, ldvl, vr, ldvr, ilo, ihi,
374 $ lscale, rscale, abnrm, bbnrm, rconde, rcondv,
375 $ work, lwork, rwork, iwork, bwork, info )
383 CHARACTER BALANC, JOBVL, JOBVR, SENSE
384 INTEGER IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N
390 REAL LSCALE( * ), RCONDE( * ), RCONDV( * ),
391 $ rscale( * ), rwork( * )
392 COMPLEX A( lda, * ), ALPHA( * ), B( ldb, * ),
393 $ beta( * ), vl( ldvl, * ), vr( ldvr, * ),
401 parameter( zero = 0.0e+0, one = 1.0e+0 )
403 parameter( czero = ( 0.0e+0, 0.0e+0 ),
404 $ cone = ( 1.0e+0, 0.0e+0 ) )
407 LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY, NOSCL,
408 $ wantsb, wantse, wantsn, wantsv
410 INTEGER I, ICOLS, IERR, IJOBVL, IJOBVR, IN, IROWS,
411 $ itau, iwrk, iwrk1, j, jc, jr, m, maxwrk, minwrk
412 REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
428 EXTERNAL lsame, ilaenv, clange, slamch
431 INTRINSIC abs, aimag, max,
REAL, SQRT
437 abs1( x ) = abs(
REAL( X ) ) + abs( AIMAG( x ) )
443 IF( lsame( jobvl,
'N' ) )
THEN
446 ELSE IF( lsame( jobvl,
'V' ) )
THEN
454 IF( lsame( jobvr,
'N' ) )
THEN
457 ELSE IF( lsame( jobvr,
'V' ) )
THEN
466 noscl = lsame( balanc,
'N' ) .OR. lsame( balanc,
'P' )
467 wantsn = lsame( sense,
'N' )
468 wantse = lsame( sense,
'E' )
469 wantsv = lsame( sense,
'V' )
470 wantsb = lsame( sense,
'B' )
475 lquery = ( lwork.EQ.-1 )
476 IF( .NOT.( noscl .OR. lsame( balanc,
'S' ) .OR.
477 $ lsame( balanc,
'B' ) ) )
THEN
479 ELSE IF( ijobvl.LE.0 )
THEN
481 ELSE IF( ijobvr.LE.0 )
THEN
483 ELSE IF( .NOT.( wantsn .OR. wantse .OR. wantsb .OR. wantsv ) )
486 ELSE IF( n.LT.0 )
THEN
488 ELSE IF( lda.LT.max( 1, n ) )
THEN
490 ELSE IF( ldb.LT.max( 1, n ) )
THEN
492 ELSE IF( ldvl.LT.1 .OR. ( ilvl .AND. ldvl.LT.n ) )
THEN
494 ELSE IF( ldvr.LT.1 .OR. ( ilvr .AND. ldvr.LT.n ) )
THEN
514 ELSE IF( wantsv .OR. wantsb )
THEN
515 minwrk = 2*n*( n + 1)
518 maxwrk = max( maxwrk,
519 $ n + n*ilaenv( 1,
'CGEQRF',
' ', n, 1, n, 0 ) )
520 maxwrk = max( maxwrk,
521 $ n + n*ilaenv( 1,
'CUNMQR',
' ', n, 1, n, 0 ) )
523 maxwrk = max( maxwrk, n +
524 $ n*ilaenv( 1,
'CUNGQR',
' ', n, 1, n, 0 ) )
529 IF( lwork.LT.minwrk .AND. .NOT.lquery )
THEN
535 CALL
xerbla(
'CGGEVX', -info )
537 ELSE IF( lquery )
THEN
549 smlnum = slamch(
'S' )
550 bignum = one / smlnum
551 CALL
slabad( smlnum, bignum )
552 smlnum = sqrt( smlnum ) / eps
553 bignum = one / smlnum
557 anrm = clange(
'M', n, n, a, lda, rwork )
559 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
562 ELSE IF( anrm.GT.bignum )
THEN
567 $ CALL
clascl(
'G', 0, 0, anrm, anrmto, n, n, a, lda, ierr )
571 bnrm = clange(
'M', n, n, b, ldb, rwork )
573 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
576 ELSE IF( bnrm.GT.bignum )
THEN
581 $ CALL
clascl(
'G', 0, 0, bnrm, bnrmto, n, n, b, ldb, ierr )
586 CALL
cggbal( balanc, n, a, lda, b, ldb, ilo, ihi, lscale, rscale,
591 abnrm = clange(
'1', n, n, a, lda, rwork( 1 ) )
594 CALL
slascl(
'G', 0, 0, anrmto, anrm, 1, 1, rwork( 1 ), 1,
599 bbnrm = clange(
'1', n, n, b, ldb, rwork( 1 ) )
602 CALL
slascl(
'G', 0, 0, bnrmto, bnrm, 1, 1, rwork( 1 ), 1,
610 irows = ihi + 1 - ilo
611 IF( ilv .OR. .NOT.wantsn )
THEN
618 CALL
cgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),
619 $ work( iwrk ), lwork+1-iwrk, ierr )
624 CALL
cunmqr(
'L',
'C', irows, icols, irows, b( ilo, ilo ), ldb,
625 $ work( itau ), a( ilo, ilo ), lda, work( iwrk ),
626 $ lwork+1-iwrk, ierr )
632 CALL
claset(
'Full', n, n, czero, cone, vl, ldvl )
633 IF( irows.GT.1 )
THEN
634 CALL
clacpy(
'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,
635 $ vl( ilo+1, ilo ), ldvl )
637 CALL
cungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,
638 $ work( itau ), work( iwrk ), lwork+1-iwrk, ierr )
642 $ CALL
claset(
'Full', n, n, czero, cone, vr, ldvr )
647 IF( ilv .OR. .NOT.wantsn )
THEN
651 CALL
cgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,
652 $ ldvl, vr, ldvr, ierr )
654 CALL
cgghrd(
'N',
'N', irows, 1, irows, a( ilo, ilo ), lda,
655 $ b( ilo, ilo ), ldb, vl, ldvl, vr, ldvr, ierr )
664 IF( ilv .OR. .NOT.wantsn )
THEN
670 CALL
chgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,
671 $ alpha, beta, vl, ldvl, vr, ldvr, work( iwrk ),
672 $ lwork+1-iwrk, rwork, ierr )
674 IF( ierr.GT.0 .AND. ierr.LE.n )
THEN
676 ELSE IF( ierr.GT.n .AND. ierr.LE.2*n )
THEN
690 IF( ilv .OR. .NOT.wantsn )
THEN
702 CALL
ctgevc( chtemp,
'B', ldumma, n, a, lda, b, ldb, vl,
703 $ ldvl, vr, ldvr, n, in, work( iwrk ), rwork,
711 IF( .NOT.wantsn )
THEN
732 IF( wantse .OR. wantsb )
THEN
733 CALL
ctgevc(
'B',
'S', bwork, n, a, lda, b, ldb,
734 $ work( 1 ), n, work( iwrk ), n, 1, m,
735 $ work( iwrk1 ), rwork, ierr )
742 CALL
ctgsna( sense,
'S', bwork, n, a, lda, b, ldb,
743 $ work( 1 ), n, work( iwrk ), n, rconde( i ),
744 $ rcondv( i ), 1, m, work( iwrk1 ),
745 $ lwork-iwrk1+1, iwork, ierr )
755 CALL
cggbak( balanc,
'L', n, ilo, ihi, lscale, rscale, n, vl,
761 temp = max( temp, abs1( vl( jr, jc ) ) )
767 vl( jr, jc ) = vl( jr, jc )*temp
773 CALL
cggbak( balanc,
'R', n, ilo, ihi, lscale, rscale, n, vr,
778 temp = max( temp, abs1( vr( jr, jc ) ) )
784 vr( jr, jc ) = vr( jr, jc )*temp
794 $ CALL
clascl(
'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr )
797 $ CALL
clascl(
'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr )
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 ctgevc(SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO)
CTGEVC
subroutine cggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
CGGBAL
subroutine ctgsna(JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO)
CTGSNA
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cunmqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
CUNMQR
subroutine cggbak(JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO)
CGGBAK
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 clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine cgghrd(COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO)
CGGHRD
subroutine cgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
CGEQRF
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 slabad(SMALL, LARGE)
SLABAD
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 chgeqz(JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO)
CHGEQZ
subroutine cungqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
CUNGQR