372 SUBROUTINE zggevx( 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
385 DOUBLE PRECISION abnrm, bbnrm
390 DOUBLE PRECISION lscale( * ), rconde( * ), rcondv( * ),
391 $ rscale( * ), rwork( * )
392 COMPLEX*16 a( lda, * ), alpha( * ),
b( ldb, * ),
393 $ beta( * ), vl( ldvl, * ), vr( ldvr, * ),
400 DOUBLE PRECISION zero, one
401 parameter( zero = 0.0d+0, one = 1.0d+0 )
402 COMPLEX*16 czero, cone
403 parameter( czero = ( 0.0d+0, 0.0d+0 ),
404 $ cone = ( 1.0d+0, 0.0d+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 DOUBLE PRECISION anrm, anrmto, bignum, bnrm, bnrmto, eps,
431 INTRINSIC abs, dble, dimag, max, sqrt
434 DOUBLE PRECISION abs1
437 abs1(
x ) = abs( dble(
x ) ) + abs( dimag(
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,
'ZGEQRF',
' ', n, 1, n, 0 ) )
520 maxwrk = max( maxwrk,
521 $ n + n*
ilaenv( 1,
'ZUNMQR',
' ', n, 1, n, 0 ) )
523 maxwrk = max( maxwrk, n +
524 $ n*
ilaenv( 1,
'ZUNGQR',
' ', n, 1, n, 0 ) )
529 IF( lwork.LT.minwrk .AND. .NOT.lquery )
THEN
535 CALL
xerbla(
'ZGGEVX', -info )
537 ELSE IF( lquery )
THEN
550 bignum = one / smlnum
551 CALL
dlabad( smlnum, bignum )
552 smlnum = sqrt( smlnum ) / eps
553 bignum = one / smlnum
557 anrm =
zlange(
'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
zlascl(
'G', 0, 0, anrm, anrmto, n, n, a, lda, ierr )
571 bnrm =
zlange(
'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
zlascl(
'G', 0, 0, bnrm, bnrmto, n, n,
b, ldb, ierr )
586 CALL
zggbal( balanc, n, a, lda,
b, ldb, ilo, ihi, lscale, rscale,
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, vl,
761 temp = max( temp, abs1( vl( jr, jc ) ) )
767 vl( jr, jc ) = vl( jr, jc )*temp
773 CALL
zggbak( 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
zlascl(
'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr )
797 $ CALL
zlascl(
'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr )
LOGICAL function lsame(CA, CB)
LSAME
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine ztgsna(JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO)
ZTGSNA
subroutine zggevx(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)
ZGGEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
subroutine zhgeqz(JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO)
ZHGEQZ
DOUBLE PRECISION function zlange(NORM, M, N, A, LDA, WORK)
ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine zungqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
ZUNGQR
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zggbak(JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO)
ZGGBAK
subroutine dlascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine dlabad(SMALL, LARGE)
DLABAD
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine zgghrd(COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO)
ZGGHRD
subroutine zlascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
INTEGER function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
subroutine zgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
ZGEQRF VARIANT: left-looking Level 3 BLAS of the algorithm.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine ztgevc(SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO)
ZTGEVC
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
subroutine zunmqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
ZUNMQR
subroutine zggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
ZGGBAL