224 SUBROUTINE dggev( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI,
225 $ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
232 CHARACTER JOBVL, JOBVR
233 INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N
236 DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
237 $ b( ldb, * ), beta( * ), vl( ldvl, * ),
238 $ vr( ldvr, * ), work( * )
244 DOUBLE PRECISION ZERO, ONE
245 parameter( zero = 0.0d+0, one = 1.0d+0 )
248 LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY
250 INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO,
251 $ in, iright, irows, itau, iwrk, jc, jr, maxwrk,
253 DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
267 DOUBLE PRECISION DLAMCH, DLANGE
268 EXTERNAL lsame, ilaenv, dlamch, dlange
271 INTRINSIC abs, max, sqrt
277 IF( lsame( jobvl,
'N' ) )
THEN
280 ELSE IF( lsame( jobvl,
'V' ) )
THEN
288 IF( lsame( jobvr,
'N' ) )
THEN
291 ELSE IF( lsame( jobvr,
'V' ) )
THEN
303 lquery = ( lwork.EQ.-1 )
304 IF( ijobvl.LE.0 )
THEN
306 ELSE IF( ijobvr.LE.0 )
THEN
308 ELSE IF( n.LT.0 )
THEN
310 ELSE IF( lda.LT.max( 1, n ) )
THEN
312 ELSE IF( ldb.LT.max( 1, n ) )
THEN
314 ELSE IF( ldvl.LT.1 .OR. ( ilvl .AND. ldvl.LT.n ) )
THEN
316 ELSE IF( ldvr.LT.1 .OR. ( ilvr .AND. ldvr.LT.n ) )
THEN
329 minwrk = max( 1, 8*n )
330 maxwrk = max( 1, n*( 7 +
331 $ ilaenv( 1,
'DGEQRF',
' ', n, 1, n, 0 ) ) )
332 maxwrk = max( maxwrk, n*( 7 +
333 $ ilaenv( 1,
'DORMQR',
' ', n, 1, n, 0 ) ) )
335 maxwrk = max( maxwrk, n*( 7 +
336 $ ilaenv( 1,
'DORGQR',
' ', n, 1, n, -1 ) ) )
340 IF( lwork.LT.minwrk .AND. .NOT.lquery )
345 CALL xerbla(
'DGGEV ', -info )
347 ELSE IF( lquery )
THEN
359 smlnum = dlamch(
'S' )
360 bignum = one / smlnum
361 CALL dlabad( smlnum, bignum )
362 smlnum = sqrt( smlnum ) / eps
363 bignum = one / smlnum
367 anrm = dlange(
'M', n, n, a, lda, work )
369 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
372 ELSE IF( anrm.GT.bignum )
THEN
377 $
CALL dlascl(
'G', 0, 0, anrm, anrmto, n, n, a, lda, ierr )
381 bnrm = dlange(
'M', n, n, b, ldb, work )
383 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
386 ELSE IF( bnrm.GT.bignum )
THEN
391 $
CALL dlascl(
'G', 0, 0, bnrm, bnrmto, n, n, b, ldb, ierr )
399 CALL dggbal(
'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),
400 $ work( iright ), work( iwrk ), ierr )
405 irows = ihi + 1 - ilo
413 CALL dgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),
414 $ work( iwrk ), lwork+1-iwrk, ierr )
419 CALL dormqr(
'L',
'T', irows, icols, irows, b( ilo, ilo ), ldb,
420 $ work( itau ), a( ilo, ilo ), lda, work( iwrk ),
421 $ lwork+1-iwrk, ierr )
427 CALL dlaset(
'Full', n, n, zero, one, vl, ldvl )
428 IF( irows.GT.1 )
THEN
429 CALL dlacpy(
'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,
430 $ vl( ilo+1, ilo ), ldvl )
432 CALL dorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,
433 $ work( itau ), work( iwrk ), lwork+1-iwrk, ierr )
439 $
CALL dlaset(
'Full', n, n, zero, one, vr, ldvr )
448 CALL dgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,
449 $ ldvl, vr, ldvr, ierr )
451 CALL dgghrd(
'N',
'N', irows, 1, irows, a( ilo, ilo ), lda,
452 $ b( ilo, ilo ), ldb, vl, ldvl, vr, ldvr, ierr )
465 CALL dhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,
466 $ alphar, alphai, beta, vl, ldvl, vr, ldvr,
467 $ work( iwrk ), lwork+1-iwrk, ierr )
469 IF( ierr.GT.0 .AND. ierr.LE.n )
THEN
471 ELSE IF( ierr.GT.n .AND. ierr.LE.2*n )
THEN
492 CALL dtgevc( chtemp,
'B', ldumma, n, a, lda, b, ldb, vl, ldvl,
493 $ vr, ldvr, n, in, work( iwrk ), ierr )
503 CALL dggbak(
'P',
'L', n, ilo, ihi, work( ileft ),
504 $ work( iright ), n, vl, ldvl, ierr )
506 IF( alphai( jc ).LT.zero )
509 IF( alphai( jc ).EQ.zero )
THEN
511 temp = max( temp, abs( vl( jr, jc ) ) )
515 temp = max( temp, abs( vl( jr, jc ) )+
516 $ abs( vl( jr, jc+1 ) ) )
522 IF( alphai( jc ).EQ.zero )
THEN
524 vl( jr, jc ) = vl( jr, jc )*temp
528 vl( jr, jc ) = vl( jr, jc )*temp
529 vl( jr, jc+1 ) = vl( jr, jc+1 )*temp
535 CALL dggbak(
'P',
'R', n, ilo, ihi, work( ileft ),
536 $ work( iright ), n, vr, ldvr, ierr )
538 IF( alphai( jc ).LT.zero )
541 IF( alphai( jc ).EQ.zero )
THEN
543 temp = max( temp, abs( vr( jr, jc ) ) )
547 temp = max( temp, abs( vr( jr, jc ) )+
548 $ abs( vr( jr, jc+1 ) ) )
554 IF( alphai( jc ).EQ.zero )
THEN
556 vr( jr, jc ) = vr( jr, jc )*temp
560 vr( jr, jc ) = vr( jr, jc )*temp
561 vr( jr, jc+1 ) = vr( jr, jc+1 )*temp
576 CALL dlascl(
'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr )
577 CALL dlascl(
'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr )
581 CALL dlascl(
'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr )
subroutine dlabad(SMALL, LARGE)
DLABAD
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 dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
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 xerbla(SRNAME, INFO)
XERBLA
subroutine dggbak(JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO)
DGGBAK
subroutine dggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
DGGBAL
subroutine dhgeqz(JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, INFO)
DHGEQZ
subroutine dgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGEQRF
subroutine dtgevc(SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, INFO)
DTGEVC
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
subroutine dorgqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
DORGQR
subroutine dgghrd(COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO)
DGGHRD
subroutine dormqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
DORMQR