226 SUBROUTINE dggev( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI,
227 $ beta, vl, ldvl, vr, ldvr, work, lwork, info )
235 CHARACTER jobvl, jobvr
236 INTEGER info, lda, ldb, ldvl, ldvr, lwork, n
239 DOUBLE PRECISION a( lda, * ), alphai( * ), alphar( * ),
240 $
b( ldb, * ), beta( * ), vl( ldvl, * ),
241 $ vr( ldvr, * ), work( * )
247 DOUBLE PRECISION zero, one
248 parameter( zero = 0.0d+0, one = 1.0d+0 )
251 LOGICAL ilascl, ilbscl, ilv, ilvl, ilvr, lquery
253 INTEGER icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo,
254 $ in, iright, irows, itau, iwrk, jc, jr, maxwrk,
256 DOUBLE PRECISION anrm, anrmto, bignum, bnrm, bnrmto, eps,
274 INTRINSIC abs, max, sqrt
280 IF(
lsame( jobvl,
'N' ) )
THEN
283 ELSE IF(
lsame( jobvl,
'V' ) )
THEN
291 IF(
lsame( jobvr,
'N' ) )
THEN
294 ELSE IF(
lsame( jobvr,
'V' ) )
THEN
306 lquery = ( lwork.EQ.-1 )
307 IF( ijobvl.LE.0 )
THEN
309 ELSE IF( ijobvr.LE.0 )
THEN
311 ELSE IF( n.LT.0 )
THEN
313 ELSE IF( lda.LT.max( 1, n ) )
THEN
315 ELSE IF( ldb.LT.max( 1, n ) )
THEN
317 ELSE IF( ldvl.LT.1 .OR. ( ilvl .AND. ldvl.LT.n ) )
THEN
319 ELSE IF( ldvr.LT.1 .OR. ( ilvr .AND. ldvr.LT.n ) )
THEN
332 minwrk = max( 1, 8*n )
333 maxwrk = max( 1, n*( 7 +
334 $
ilaenv( 1,
'DGEQRF',
' ', n, 1, n, 0 ) ) )
335 maxwrk = max( maxwrk, n*( 7 +
336 $
ilaenv( 1,
'DORMQR',
' ', n, 1, n, 0 ) ) )
338 maxwrk = max( maxwrk, n*( 7 +
339 $
ilaenv( 1,
'DORGQR',
' ', n, 1, n, -1 ) ) )
343 IF( lwork.LT.minwrk .AND. .NOT.lquery )
348 CALL
xerbla(
'DGGEV ', -info )
350 ELSE IF( lquery )
THEN
363 bignum = one / smlnum
364 CALL
dlabad( smlnum, bignum )
365 smlnum = sqrt( smlnum ) / eps
366 bignum = one / smlnum
370 anrm =
dlange(
'M', n, n, a, lda, work )
372 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
375 ELSE IF( anrm.GT.bignum )
THEN
380 $ CALL
dlascl(
'G', 0, 0, anrm, anrmto, n, n, a, lda, ierr )
384 bnrm =
dlange(
'M', n, n,
b, ldb, work )
386 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
389 ELSE IF( bnrm.GT.bignum )
THEN
394 $ CALL
dlascl(
'G', 0, 0, bnrm, bnrmto, n, n,
b, ldb, ierr )
402 CALL
dggbal(
'P', n, a, lda,
b, ldb, ilo, ihi, work( ileft ),
403 $ work( iright ), work( iwrk ), ierr )
408 irows = ihi + 1 - ilo
416 CALL
dgeqrf( irows, icols,
b( ilo, ilo ), ldb, work( itau ),
417 $ work( iwrk ), lwork+1-iwrk, ierr )
422 CALL
dormqr(
'L',
'T', irows, icols, irows,
b( ilo, ilo ), ldb,
423 $ work( itau ), a( ilo, ilo ), lda, work( iwrk ),
424 $ lwork+1-iwrk, ierr )
430 CALL
dlaset(
'Full', n, n, zero, one, vl, ldvl )
431 IF( irows.GT.1 )
THEN
432 CALL
dlacpy(
'L', irows-1, irows-1,
b( ilo+1, ilo ), ldb,
433 $ vl( ilo+1, ilo ), ldvl )
435 CALL
dorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,
436 $ work( itau ), work( iwrk ), lwork+1-iwrk, ierr )
442 $ CALL
dlaset(
'Full', n, n, zero, one, vr, ldvr )
451 CALL
dgghrd( jobvl, jobvr, n, ilo, ihi, a, lda,
b, ldb, vl,
452 $ ldvl, vr, ldvr, ierr )
454 CALL
dgghrd(
'N',
'N', irows, 1, irows, a( ilo, ilo ), lda,
455 $
b( ilo, ilo ), ldb, vl, ldvl, vr, ldvr, ierr )
468 CALL
dhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda,
b, ldb,
469 $ alphar, alphai, beta, vl, ldvl, vr, ldvr,
470 $ work( iwrk ), lwork+1-iwrk, ierr )
472 IF( ierr.GT.0 .AND. ierr.LE.n )
THEN
474 ELSE IF( ierr.GT.n .AND. ierr.LE.2*n )
THEN
495 CALL
dtgevc( chtemp,
'B', ldumma, n, a, lda,
b, ldb, vl, ldvl,
496 $ vr, ldvr, n, in, work( iwrk ), ierr )
506 CALL
dggbak(
'P',
'L', n, ilo, ihi, work( ileft ),
507 $ work( iright ), n, vl, ldvl, ierr )
509 IF( alphai( jc ).LT.zero )
512 IF( alphai( jc ).EQ.zero )
THEN
514 temp = max( temp, abs( vl( jr, jc ) ) )
518 temp = max( temp, abs( vl( jr, jc ) )+
519 $ abs( vl( jr, jc+1 ) ) )
525 IF( alphai( jc ).EQ.zero )
THEN
527 vl( jr, jc ) = vl( jr, jc )*temp
531 vl( jr, jc ) = vl( jr, jc )*temp
532 vl( jr, jc+1 ) = vl( jr, jc+1 )*temp
538 CALL
dggbak(
'P',
'R', n, ilo, ihi, work( ileft ),
539 $ work( iright ), n, vr, ldvr, ierr )
541 IF( alphai( jc ).LT.zero )
544 IF( alphai( jc ).EQ.zero )
THEN
546 temp = max( temp, abs( vr( jr, jc ) ) )
550 temp = max( temp, abs( vr( jr, jc ) )+
551 $ abs( vr( jr, jc+1 ) ) )
557 IF( alphai( jc ).EQ.zero )
THEN
559 vr( jr, jc ) = vr( jr, jc )*temp
563 vr( jr, jc ) = vr( jr, jc )*temp
564 vr( jr, jc+1 ) = vr( jr, jc+1 )*temp
579 CALL
dlascl(
'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr )
580 CALL
dlascl(
'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr )
584 CALL
dlascl(
'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr )
subroutine dgghrd(COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO)
DGGHRD
subroutine dgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGEQRF
subroutine dormqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
DORMQR
subroutine xerbla(SRNAME, INFO)
XERBLA
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
logical function lsame(CA, CB)
LSAME
subroutine dorgqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
DORGQR
subroutine dhgeqz(JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, INFO)
DHGEQZ
double precision function dlange(NORM, M, N, A, LDA, WORK)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine dggbak(JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO)
DGGBAK
double precision function dlamch(CMACH)
DLAMCH
subroutine dtgevc(SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, INFO)
DTGEVC
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine dggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
DGGBAL
subroutine dggev(JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO)
DGGEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...