217 SUBROUTINE zggev( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA,
218 $ vl, ldvl, vr, ldvr, work, lwork, rwork, info )
226 CHARACTER jobvl, jobvr
227 INTEGER info, lda, ldb, ldvl, ldvr, lwork, n
230 DOUBLE PRECISION rwork( * )
231 COMPLEX*16 a( lda, * ), alpha( * ),
b( ldb, * ),
232 $ beta( * ), vl( ldvl, * ), vr( ldvr, * ),
239 DOUBLE PRECISION zero, one
240 parameter( zero = 0.0d0, one = 1.0d0 )
241 COMPLEX*16 czero, cone
242 parameter( czero = ( 0.0d0, 0.0d0 ),
243 $ cone = ( 1.0d0, 0.0d0 ) )
246 LOGICAL ilascl, ilbscl, ilv, ilvl, ilvr, lquery
248 INTEGER icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo,
249 $ in, iright, irows, irwrk, itau, iwrk, jc, jr,
251 DOUBLE PRECISION anrm, anrmto, bignum, bnrm, bnrmto, eps,
270 INTRINSIC abs, dble, dimag, max, sqrt
273 DOUBLE PRECISION abs1
276 abs1( x ) = abs( dble( x ) ) + abs( dimag( x ) )
282 IF(
lsame( jobvl,
'N' ) )
THEN
285 ELSE IF(
lsame( jobvl,
'V' ) )
THEN
293 IF(
lsame( jobvr,
'N' ) )
THEN
296 ELSE IF(
lsame( jobvr,
'V' ) )
THEN
308 lquery = ( lwork.EQ.-1 )
309 IF( ijobvl.LE.0 )
THEN
311 ELSE IF( ijobvr.LE.0 )
THEN
313 ELSE IF( n.LT.0 )
THEN
315 ELSE IF( lda.LT.max( 1, n ) )
THEN
317 ELSE IF( ldb.LT.max( 1, n ) )
THEN
319 ELSE IF( ldvl.LT.1 .OR. ( ilvl .AND. ldvl.LT.n ) )
THEN
321 ELSE IF( ldvr.LT.1 .OR. ( ilvr .AND. ldvr.LT.n ) )
THEN
334 lwkmin = max( 1, 2*n )
335 lwkopt = max( 1, n + n*
ilaenv( 1,
'ZGEQRF',
' ', n, 1, n, 0 ) )
336 lwkopt = max( lwkopt, n +
337 $ n*
ilaenv( 1,
'ZUNMQR',
' ', n, 1, n, 0 ) )
339 lwkopt = max( lwkopt, n +
340 $ n*
ilaenv( 1,
'ZUNGQR',
' ', n, 1, n, -1 ) )
344 IF( lwork.LT.lwkmin .AND. .NOT.lquery )
349 CALL
xerbla(
'ZGGEV ', -info )
351 ELSE IF( lquery )
THEN
364 bignum = one / smlnum
365 CALL
dlabad( smlnum, bignum )
366 smlnum = sqrt( smlnum ) / eps
367 bignum = one / smlnum
371 anrm =
zlange(
'M', n, n, a, lda, rwork )
373 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
376 ELSE IF( anrm.GT.bignum )
THEN
381 $ CALL
zlascl(
'G', 0, 0, anrm, anrmto, n, n, a, lda, ierr )
385 bnrm =
zlange(
'M', n, n,
b, ldb, rwork )
387 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
390 ELSE IF( bnrm.GT.bignum )
THEN
395 $ CALL
zlascl(
'G', 0, 0, bnrm, bnrmto, n, n,
b, ldb, ierr )
403 CALL
zggbal(
'P', n, a, lda,
b, ldb, ilo, ihi, rwork( ileft ),
404 $ rwork( iright ), rwork( irwrk ), ierr )
409 irows = ihi + 1 - ilo
417 CALL
zgeqrf( irows, icols,
b( ilo, ilo ), ldb, work( itau ),
418 $ work( iwrk ), lwork+1-iwrk, ierr )
423 CALL
zunmqr(
'L',
'C', irows, icols, irows,
b( ilo, ilo ), ldb,
424 $ work( itau ), a( ilo, ilo ), lda, work( iwrk ),
425 $ lwork+1-iwrk, ierr )
431 CALL
zlaset(
'Full', n, n, czero, cone, vl, ldvl )
432 IF( irows.GT.1 )
THEN
433 CALL
zlacpy(
'L', irows-1, irows-1,
b( ilo+1, ilo ), ldb,
434 $ vl( ilo+1, ilo ), ldvl )
436 CALL
zungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,
437 $ work( itau ), work( iwrk ), lwork+1-iwrk, ierr )
443 $ CALL
zlaset(
'Full', n, n, czero, cone, vr, ldvr )
451 CALL
zgghrd( jobvl, jobvr, n, ilo, ihi, a, lda,
b, ldb, vl,
452 $ ldvl, vr, ldvr, ierr )
454 CALL
zgghrd(
'N',
'N', irows, 1, irows, a( ilo, ilo ), lda,
455 $
b( ilo, ilo ), ldb, vl, ldvl, vr, ldvr, ierr )
469 CALL
zhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda,
b, ldb,
470 $ alpha, beta, vl, ldvl, vr, ldvr, work( iwrk ),
471 $ lwork+1-iwrk, rwork( irwrk ), ierr )
473 IF( ierr.GT.0 .AND. ierr.LE.n )
THEN
475 ELSE IF( ierr.GT.n .AND. ierr.LE.2*n )
THEN
498 CALL
ztgevc( chtemp,
'B', ldumma, n, a, lda,
b, ldb, vl, ldvl,
499 $ vr, ldvr, n, in, work( iwrk ), rwork( irwrk ),
510 CALL
zggbak(
'P',
'L', n, ilo, ihi, rwork( ileft ),
511 $ rwork( iright ), n, vl, ldvl, ierr )
515 temp = max( temp, abs1( vl( jr, jc ) ) )
521 vl( jr, jc ) = vl( jr, jc )*temp
526 CALL
zggbak(
'P',
'R', n, ilo, ihi, rwork( ileft ),
527 $ rwork( iright ), n, vr, ldvr, ierr )
531 temp = max( temp, abs1( vr( jr, jc ) ) )
537 vr( jr, jc ) = vr( jr, jc )*temp
548 $ CALL
zlascl(
'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr )
551 $ CALL
zlascl(
'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr )
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zhgeqz(JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO)
ZHGEQZ
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 zggev(JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO)
ZGGEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
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.
logical function lsame(CA, CB)
LSAME
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...
subroutine zgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
ZGEQRF VARIANT: left-looking Level 3 BLAS of the algorithm.
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 ...
double precision function dlamch(CMACH)
DLAMCH
subroutine ztgevc(SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO)
ZTGEVC
subroutine zunmqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
ZUNMQR
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
subroutine zggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
ZGGBAL