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 )
231 INTEGER IDAMAX, ILAENV
232 DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2, DNRM2
233 EXTERNAL lsame, idamax, ilaenv, dlamch, dlange, dlapy2,
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
326 smlnum = dlamch(
'S' )
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
450 scl = one / dlapy2( dnrm2( n, vl( 1, i ), 1 ),
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
480 scl = one / dlapy2( dnrm2( n, vr( 1, i ), 1 ),
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
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
subroutine dgebal(JOB, N, A, LDA, ILO, IHI, SCALE, INFO)
DGEBAL
subroutine dscal(N, DA, DX, INCX)
DSCAL
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.
subroutine dorghr(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
DORGHR
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 ...