368 SUBROUTINE zggevx( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B,
370 $ ALPHA, BETA, VL, LDVL, VR, LDVR, ILO, IHI,
371 $ LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV,
372 $ WORK, LWORK, RWORK, IWORK, BWORK, INFO )
379 CHARACTER BALANC, JOBVL, JOBVR, SENSE
380 INTEGER IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N
381 DOUBLE PRECISION ABNRM, BBNRM
386 DOUBLE PRECISION LSCALE( * ), RCONDE( * ), RCONDV( * ),
387 $ RSCALE( * ), RWORK( * )
388 COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ),
389 $ beta( * ), vl( ldvl, * ), vr( ldvr, * ),
396 DOUBLE PRECISION ZERO, ONE
397 PARAMETER ( ZERO = 0.0d+0, one = 1.0d+0 )
398 COMPLEX*16 CZERO, CONE
399 PARAMETER ( CZERO = ( 0.0d+0, 0.0d+0 ),
400 $ cone = ( 1.0d+0, 0.0d+0 ) )
403 LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY, NOSCL,
404 $ WANTSB, WANTSE, WANTSN, WANTSV
406 INTEGER I, ICOLS, IERR, IJOBVL, IJOBVR, IN, IROWS,
407 $ itau, iwrk, iwrk1, j, jc, jr, m, maxwrk, minwrk
408 DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
424 DOUBLE PRECISION DLAMCH, ZLANGE
425 EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE
428 INTRINSIC abs, dble, dimag, max, sqrt
431 DOUBLE PRECISION ABS1
434 abs1( x ) = abs( dble( x ) ) + abs( dimag( 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,
'ZGEQRF',
' ', n, 1, n,
518 maxwrk = max( maxwrk,
519 $ n + n*ilaenv( 1,
'ZUNMQR',
' ', n, 1, n,
522 maxwrk = max( maxwrk, n +
523 $ n*ilaenv( 1,
'ZUNGQR',
' ', n, 1, n,
529 IF( lwork.LT.minwrk .AND. .NOT.lquery )
THEN
535 CALL xerbla(
'ZGGEVX', -info )
537 ELSE IF( lquery )
THEN
549 smlnum = dlamch(
'S' )
550 bignum = one / smlnum
551 smlnum = sqrt( smlnum ) / eps
552 bignum = one / smlnum
556 anrm = zlange(
'M', n, n, a, lda, rwork )
558 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
561 ELSE IF( anrm.GT.bignum )
THEN
566 $
CALL zlascl(
'G', 0, 0, anrm, anrmto, n, n, a, lda, ierr )
570 bnrm = zlange(
'M', n, n, b, ldb, rwork )
572 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
575 ELSE IF( bnrm.GT.bignum )
THEN
580 $
CALL zlascl(
'G', 0, 0, bnrm, bnrmto, n, n, b, ldb, ierr )
585 CALL zggbal( balanc, n, a, lda, b, ldb, ilo, ihi, lscale,
591 abnrm = zlange(
'1', n, n, a, lda, rwork( 1 ) )
594 CALL dlascl(
'G', 0, 0, anrmto, anrm, 1, 1, rwork( 1 ), 1,
599 bbnrm = zlange(
'1', n, n, b, ldb, rwork( 1 ) )
602 CALL dlascl(
'G', 0, 0, bnrmto, bnrm, 1, 1, rwork( 1 ), 1,
610 irows = ihi + 1 - ilo
611 IF( ilv .OR. .NOT.wantsn )
THEN
618 CALL zgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),
619 $ work( iwrk ), lwork+1-iwrk, ierr )
624 CALL zunmqr(
'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 zlaset(
'Full', n, n, czero, cone, vl, ldvl )
633 IF( irows.GT.1 )
THEN
634 CALL zlacpy(
'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,
635 $ vl( ilo+1, ilo ), ldvl )
637 CALL zungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,
638 $ work( itau ), work( iwrk ), lwork+1-iwrk, ierr )
642 $
CALL zlaset(
'Full', n, n, czero, cone, vr, ldvr )
647 IF( ilv .OR. .NOT.wantsn )
THEN
651 CALL zgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,
652 $ ldvl, vr, ldvr, ierr )
654 CALL zgghrd(
'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 zhgeqz( 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 ztgevc( 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 ztgevc(
'B',
'S', bwork, n, a, lda, b, ldb,
734 $ work( 1 ), n, work( iwrk ), n, 1, m,
735 $ work( iwrk1 ), rwork, ierr )
742 CALL ztgsna( 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 zggbak( balanc,
'L', n, ilo, ihi, lscale, rscale, n,
762 temp = max( temp, abs1( vl( jr, jc ) ) )
768 vl( jr, jc ) = vl( jr, jc )*temp
774 CALL zggbak( balanc,
'R', n, ilo, ihi, lscale, rscale, n,
780 temp = max( temp, abs1( vr( jr, jc ) ) )
786 vr( jr, jc ) = vr( jr, jc )*temp
796 $
CALL zlascl(
'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr )
799 $
CALL zlascl(
'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr )