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, * ), ( * ), 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, , , 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 )