189 SUBROUTINE dgeev( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR,
190 $ ldvr, work, lwork, info )
198 CHARACTER jobvl, jobvr
199 INTEGER info, lda, ldvl, ldvr, lwork, n
202 DOUBLE PRECISION a( lda, * ), vl( ldvl, * ), vr( ldvr, * ),
203 $ wi( * ), work( * ), wr( * )
209 DOUBLE PRECISION zero, one
210 parameter( zero = 0.0d0, one = 1.0d0 )
213 LOGICAL lquery, scalea, wantvl, wantvr
215 INTEGER hswork, i, ibal, ierr, ihi, ilo, itau, iwrk, k,
216 $ maxwrk, minwrk, nout
217 DOUBLE PRECISION anrm, bignum, cs, cscale, eps, r, scl, smlnum,
222 DOUBLE PRECISION dum( 1 )
244 lquery = ( lwork.EQ.-1 )
245 wantvl =
lsame( jobvl,
'V' )
246 wantvr =
lsame( jobvr,
'V' )
247 IF( ( .NOT.wantvl ) .AND. ( .NOT.
lsame( jobvl,
'N' ) ) )
THEN
249 ELSE IF( ( .NOT.wantvr ) .AND. ( .NOT.
lsame( jobvr,
'N' ) ) )
THEN
251 ELSE IF( n.LT.0 )
THEN
253 ELSE IF( lda.LT.max( 1, n ) )
THEN
255 ELSE IF( ldvl.LT.1 .OR. ( wantvl .AND. ldvl.LT.n ) )
THEN
257 ELSE IF( ldvr.LT.1 .OR. ( wantvr .AND. ldvr.LT.n ) )
THEN
276 maxwrk = 2*n + n*
ilaenv( 1,
'DGEHRD',
' ', n, 1, n, 0 )
279 maxwrk = max( maxwrk, 2*n + ( n - 1 )*
ilaenv( 1,
280 $
'DORGHR',
' ', n, 1, n, -1 ) )
281 CALL
dhseqr(
'S',
'V', n, 1, n, a, lda, wr, wi, vl, ldvl,
284 maxwrk = max( maxwrk, n + 1, n + hswork )
285 maxwrk = max( maxwrk, 4*n )
286 ELSE IF( wantvr )
THEN
288 maxwrk = max( maxwrk, 2*n + ( n - 1 )*
ilaenv( 1,
289 $
'DORGHR',
' ', n, 1, n, -1 ) )
290 CALL
dhseqr(
'S',
'V', n, 1, n, a, lda, wr, wi, vr, ldvr,
293 maxwrk = max( maxwrk, n + 1, n + hswork )
294 maxwrk = max( maxwrk, 4*n )
297 CALL
dhseqr(
'E',
'N', n, 1, n, a, lda, wr, wi, vr, ldvr,
300 maxwrk = max( maxwrk, n + 1, n + hswork )
302 maxwrk = max( maxwrk, minwrk )
306 IF( lwork.LT.minwrk .AND. .NOT.lquery )
THEN
312 CALL
xerbla(
'DGEEV ', -info )
314 ELSE IF( lquery )
THEN
327 bignum = one / smlnum
328 CALL
dlabad( smlnum, bignum )
329 smlnum = sqrt( smlnum ) / eps
330 bignum = one / smlnum
334 anrm =
dlange(
'M', n, n, a, lda, dum )
336 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
339 ELSE IF( anrm.GT.bignum )
THEN
344 $ CALL
dlascl(
'G', 0, 0, anrm, cscale, n, n, a, lda, ierr )
350 CALL
dgebal(
'B', n, a, lda, ilo, ihi, work( ibal ), ierr )
357 CALL
dgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),
358 $ lwork-iwrk+1, ierr )
366 CALL
dlacpy(
'L', n, n, a, lda, vl, ldvl )
371 CALL
dorghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),
372 $ lwork-iwrk+1, ierr )
378 CALL
dhseqr(
'S',
'V', n, ilo, ihi, a, lda, wr, wi, vl, ldvl,
379 $ work( iwrk ), lwork-iwrk+1, info )
387 CALL
dlacpy(
'F', n, n, vl, ldvl, vr, ldvr )
390 ELSE IF( wantvr )
THEN
396 CALL
dlacpy(
'L', n, n, a, lda, vr, ldvr )
401 CALL
dorghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),
402 $ lwork-iwrk+1, ierr )
408 CALL
dhseqr(
'S',
'V', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,
409 $ work( iwrk ), lwork-iwrk+1, info )
417 CALL
dhseqr(
'E',
'N', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,
418 $ work( iwrk ), lwork-iwrk+1, info )
426 IF( wantvl .OR. wantvr )
THEN
431 CALL
dtrevc( side,
'B',
SELECT, n, a, lda, vl, ldvl, vr, ldvr,
432 $ n, nout, work( iwrk ), ierr )
440 CALL
dgebak(
'B',
'L', n, ilo, ihi, work( ibal ), n, vl, ldvl,
446 IF( wi( i ).EQ.zero )
THEN
447 scl = one /
dnrm2( n, vl( 1, i ), 1 )
448 CALL
dscal( n, scl, vl( 1, i ), 1 )
449 ELSE IF( wi( i ).GT.zero )
THEN
451 $
dnrm2( n, vl( 1, i+1 ), 1 ) )
452 CALL
dscal( n, scl, vl( 1, i ), 1 )
453 CALL
dscal( n, scl, vl( 1, i+1 ), 1 )
455 work( iwrk+k-1 ) = vl( k, i )**2 + vl( k, i+1 )**2
457 k =
idamax( n, work( iwrk ), 1 )
458 CALL
dlartg( vl( k, i ), vl( k, i+1 ), cs, sn, r )
459 CALL
drot( n, vl( 1, i ), 1, vl( 1, i+1 ), 1, cs, sn )
470 CALL
dgebak(
'B',
'R', n, ilo, ihi, work( ibal ), n, vr, ldvr,
476 IF( wi( i ).EQ.zero )
THEN
477 scl = one /
dnrm2( n, vr( 1, i ), 1 )
478 CALL
dscal( n, scl, vr( 1, i ), 1 )
479 ELSE IF( wi( i ).GT.zero )
THEN
481 $
dnrm2( n, vr( 1, i+1 ), 1 ) )
482 CALL
dscal( n, scl, vr( 1, i ), 1 )
483 CALL
dscal( n, scl, vr( 1, i+1 ), 1 )
485 work( iwrk+k-1 ) = vr( k, i )**2 + vr( k, i+1 )**2
487 k =
idamax( n, work( iwrk ), 1 )
488 CALL
dlartg( vr( k, i ), vr( k, i+1 ), cs, sn, r )
489 CALL
drot( n, vr( 1, i ), 1, vr( 1, i+1 ), 1, cs, sn )
499 CALL
dlascl(
'G', 0, 0, cscale, anrm, n-info, 1, wr( info+1 ),
500 $ max( n-info, 1 ), ierr )
501 CALL
dlascl(
'G', 0, 0, cscale, anrm, n-info, 1, wi( info+1 ),
502 $ max( n-info, 1 ), ierr )
504 CALL
dlascl(
'G', 0, 0, cscale, anrm, ilo-1, 1, wr, n,
506 CALL
dlascl(
'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n,
subroutine dgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
DGEHRD
subroutine dhseqr(JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO)
DHSEQR
LOGICAL function lsame(CA, CB)
LSAME
subroutine dlartg(F, G, CS, SN, R)
DLARTG generates a plane rotation with real cosine and real sine.
subroutine dtrevc(SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, INFO)
DTREVC
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
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 dgebal(JOB, N, A, LDA, ILO, IHI, SCALE, INFO)
DGEBAL
subroutine dscal(N, DA, DX, INCX)
DSCAL
INTEGER function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
subroutine drot(N, DX, INCX, DY, INCY, C, S)
DROT
subroutine dgebak(JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO)
DGEBAK
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
subroutine dorghr(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
DORGHR
DOUBLE PRECISION function dlapy2(X, Y)
DLAPY2 returns sqrt(x2+y2).
DOUBLE PRECISION function dnrm2(N, X, INCX)
DNRM2
INTEGER function idamax(N, DX, INCX)
IDAMAX
subroutine dgeev(JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, WORK, LWORK, INFO)
DGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...