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 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 cggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
CGGBAL
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 xerbla(SRNAME, INFO)
XERBLA
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 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 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 cgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
CGEQRF
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 clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine ctgevc(SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO)
CTGEVC
subroutine cungqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
CUNGQR