282 SUBROUTINE zgegv( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA,
283 $ vl, ldvl, vr, ldvr, work, lwork, rwork, info )
291 CHARACTER jobvl, jobvr
292 INTEGER info, lda, ldb, ldvl, ldvr, lwork, n
295 DOUBLE PRECISION rwork( * )
296 COMPLEX*16 a( lda, * ), alpha( * ),
b( ldb, * ),
297 $ beta( * ), vl( ldvl, * ), vr( ldvr, * ),
304 DOUBLE PRECISION zero, one
305 parameter( zero = 0.0d0, one = 1.0d0 )
306 COMPLEX*16 czero, cone
307 parameter( czero = ( 0.0d0, 0.0d0 ),
308 $ cone = ( 1.0d0, 0.0d0 ) )
311 LOGICAL ilimit, ilv, ilvl, ilvr, lquery
313 INTEGER icols, ihi, iinfo, ijobvl, ijobvr, ileft, ilo,
314 $ in, iright, irows, irwork, itau, iwork, jc, jr,
315 $ lopt, lwkmin, lwkopt, nb, nb1, nb2, nb3
316 DOUBLE PRECISION absai, absar, absb, anrm, anrm1, anrm2, bnrm,
317 $ bnrm1, bnrm2, eps, safmax, safmin, salfai,
318 $ salfar, sbeta, scale, temp
335 INTRINSIC abs, dble, dcmplx, dimag, int, max
338 DOUBLE PRECISION abs1
341 abs1( x ) = abs( dble( x ) ) + abs( dimag( x ) )
347 IF(
lsame( jobvl,
'N' ) )
THEN
350 ELSE IF(
lsame( jobvl,
'V' ) )
THEN
358 IF(
lsame( jobvr,
'N' ) )
THEN
361 ELSE IF(
lsame( jobvr,
'V' ) )
THEN
372 lwkmin = max( 2*n, 1 )
375 lquery = ( lwork.EQ.-1 )
377 IF( ijobvl.LE.0 )
THEN
379 ELSE IF( ijobvr.LE.0 )
THEN
381 ELSE IF( n.LT.0 )
THEN
383 ELSE IF( lda.LT.max( 1, n ) )
THEN
385 ELSE IF( ldb.LT.max( 1, n ) )
THEN
387 ELSE IF( ldvl.LT.1 .OR. ( ilvl .AND. ldvl.LT.n ) )
THEN
389 ELSE IF( ldvr.LT.1 .OR. ( ilvr .AND. ldvr.LT.n ) )
THEN
391 ELSE IF( lwork.LT.lwkmin .AND. .NOT.lquery )
THEN
396 nb1 =
ilaenv( 1,
'ZGEQRF',
' ', n, n, -1, -1 )
397 nb2 =
ilaenv( 1,
'ZUNMQR',
' ', n, n, n, -1 )
398 nb3 =
ilaenv( 1,
'ZUNGQR',
' ', n, n, n, -1 )
399 nb = max( nb1, nb2, nb3 )
400 lopt = max( 2*n, n*( nb+1 ) )
405 CALL
xerbla(
'ZGEGV ', -info )
407 ELSE IF( lquery )
THEN
420 safmin = safmin + safmin
421 safmax = one / safmin
425 anrm =
zlange(
'M', n, n, a, lda, rwork )
428 IF( anrm.LT.one )
THEN
429 IF( safmax*anrm.LT.one )
THEN
435 IF( anrm.GT.zero )
THEN
436 CALL
zlascl(
'G', -1, -1, anrm, one, n, n, a, lda, iinfo )
437 IF( iinfo.NE.0 )
THEN
445 bnrm =
zlange(
'M', n, n,
b, ldb, rwork )
448 IF( bnrm.LT.one )
THEN
449 IF( safmax*bnrm.LT.one )
THEN
455 IF( bnrm.GT.zero )
THEN
456 CALL
zlascl(
'G', -1, -1, bnrm, one, n, n,
b, ldb, iinfo )
457 IF( iinfo.NE.0 )
THEN
469 CALL
zggbal(
'P', n, a, lda,
b, ldb, ilo, ihi, rwork( ileft ),
470 $ rwork( iright ), rwork( irwork ), iinfo )
471 IF( iinfo.NE.0 )
THEN
478 irows = ihi + 1 - ilo
486 CALL
zgeqrf( irows, icols,
b( ilo, ilo ), ldb, work( itau ),
487 $ work( iwork ), lwork+1-iwork, iinfo )
489 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
490 IF( iinfo.NE.0 )
THEN
495 CALL
zunmqr(
'L',
'C', irows, icols, irows,
b( ilo, ilo ), ldb,
496 $ work( itau ), a( ilo, ilo ), lda, work( iwork ),
497 $ lwork+1-iwork, iinfo )
499 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
500 IF( iinfo.NE.0 )
THEN
506 CALL
zlaset(
'Full', n, n, czero, cone, vl, ldvl )
507 CALL
zlacpy(
'L', irows-1, irows-1,
b( ilo+1, ilo ), ldb,
508 $ vl( ilo+1, ilo ), ldvl )
509 CALL
zungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,
510 $ work( itau ), work( iwork ), lwork+1-iwork,
513 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
514 IF( iinfo.NE.0 )
THEN
521 $ CALL
zlaset(
'Full', n, n, czero, cone, vr, ldvr )
529 CALL
zgghrd( jobvl, jobvr, n, ilo, ihi, a, lda,
b, ldb, vl,
530 $ ldvl, vr, ldvr, iinfo )
532 CALL
zgghrd(
'N',
'N', irows, 1, irows, a( ilo, ilo ), lda,
533 $
b( ilo, ilo ), ldb, vl, ldvl, vr, ldvr, iinfo )
535 IF( iinfo.NE.0 )
THEN
548 CALL
zhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda,
b, ldb,
549 $ alpha, beta, vl, ldvl, vr, ldvr, work( iwork ),
550 $ lwork+1-iwork, rwork( irwork ), iinfo )
552 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
553 IF( iinfo.NE.0 )
THEN
554 IF( iinfo.GT.0 .AND. iinfo.LE.n )
THEN
556 ELSE IF( iinfo.GT.n .AND. iinfo.LE.2*n )
THEN
578 CALL
ztgevc( chtemp,
'B', ldumma, n, a, lda,
b, ldb, vl, ldvl,
579 $ vr, ldvr, n, in, work( iwork ), rwork( irwork ),
581 IF( iinfo.NE.0 )
THEN
589 CALL
zggbak(
'P',
'L', n, ilo, ihi, rwork( ileft ),
590 $ rwork( iright ), n, vl, ldvl, iinfo )
591 IF( iinfo.NE.0 )
THEN
598 temp = max( temp, abs1( vl( jr, jc ) ) )
604 vl( jr, jc ) = vl( jr, jc )*temp
609 CALL
zggbak(
'P',
'R', n, ilo, ihi, rwork( ileft ),
610 $ rwork( iright ), n, vr, ldvr, iinfo )
611 IF( iinfo.NE.0 )
THEN
618 temp = max( temp, abs1( vr( jr, jc ) ) )
624 vr( jr, jc ) = vr( jr, jc )*temp
642 absar = abs( dble( alpha( jc ) ) )
643 absai = abs( dimag( alpha( jc ) ) )
644 absb = abs( dble( beta( jc ) ) )
645 salfar = anrm*dble( alpha( jc ) )
646 salfai = anrm*dimag( alpha( jc ) )
647 sbeta = bnrm*dble( beta( jc ) )
653 IF( abs( salfai ).LT.safmin .AND. absai.GE.
654 $ max( safmin, eps*absar, eps*absb ) )
THEN
656 scale = ( safmin / anrm1 ) / max( safmin, anrm2*absai )
661 IF( abs( salfar ).LT.safmin .AND. absar.GE.
662 $ max( safmin, eps*absai, eps*absb ) )
THEN
664 scale = max( scale, ( safmin / anrm1 ) /
665 $ max( safmin, anrm2*absar ) )
670 IF( abs( sbeta ).LT.safmin .AND. absb.GE.
671 $ max( safmin, eps*absar, eps*absai ) )
THEN
673 scale = max( scale, ( safmin / bnrm1 ) /
674 $ max( safmin, bnrm2*absb ) )
680 temp = ( scale*safmin )*max( abs( salfar ), abs( salfai ),
683 $ scale = scale / temp
691 salfar = ( scale*dble( alpha( jc ) ) )*anrm
692 salfai = ( scale*dimag( alpha( jc ) ) )*anrm
693 sbeta = ( scale*beta( jc ) )*bnrm
695 alpha( jc ) = dcmplx( salfar, salfai )
subroutine zgegv(JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO)
ZGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
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
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