191 SUBROUTINE dgeev( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR,
192 $ ldvr, work, lwork, info )
201 CHARACTER JOBVL, JOBVR
202 INTEGER INFO, LDA, LDVL, LDVR, LWORK, N
205 DOUBLE PRECISION A( lda, * ), VL( ldvl, * ), VR( ldvr, * ),
206 $ wi( * ), work( * ), wr( * )
212 DOUBLE PRECISION ZERO, ONE
213 parameter ( zero = 0.0d0, one = 1.0d0 )
216 LOGICAL LQUERY, SCALEA, WANTVL, WANTVR
218 INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K,
219 $ lwork_trevc, maxwrk, minwrk, nout
220 DOUBLE PRECISION ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM,
225 DOUBLE PRECISION DUM( 1 )
234 INTEGER IDAMAX, ILAENV
235 DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2, DNRM2
236 EXTERNAL lsame, idamax, ilaenv, dlamch, dlange, dlapy2,
247 lquery = ( lwork.EQ.-1 )
248 wantvl = lsame( jobvl,
'V' )
249 wantvr = lsame( jobvr,
'V' )
250 IF( ( .NOT.wantvl ) .AND. ( .NOT.lsame( jobvl,
'N' ) ) )
THEN
252 ELSE IF( ( .NOT.wantvr ) .AND. ( .NOT.lsame( jobvr,
'N' ) ) )
THEN
254 ELSE IF( n.LT.0 )
THEN
256 ELSE IF( lda.LT.max( 1, n ) )
THEN
258 ELSE IF( ldvl.LT.1 .OR. ( wantvl .AND. ldvl.LT.n ) )
THEN
260 ELSE IF( ldvr.LT.1 .OR. ( wantvr .AND. ldvr.LT.n ) )
THEN
279 maxwrk = 2*n + n*ilaenv( 1,
'DGEHRD',
' ', n, 1, n, 0 )
282 maxwrk = max( maxwrk, 2*n + ( n - 1 )*ilaenv( 1,
283 $
'DORGHR',
' ', n, 1, n, -1 ) )
284 CALL dhseqr(
'S',
'V', n, 1, n, a, lda, wr, wi, vl, ldvl,
286 hswork = int( work(1) )
287 maxwrk = max( maxwrk, n + 1, n + hswork )
288 CALL dtrevc3(
'L',
'B',
SELECT, n, a, lda,
289 $ vl, ldvl, vr, ldvr, n, nout,
291 lwork_trevc = int( work(1) )
292 maxwrk = max( maxwrk, n + lwork_trevc )
293 maxwrk = max( maxwrk, 4*n )
294 ELSE IF( wantvr )
THEN
296 maxwrk = max( maxwrk, 2*n + ( n - 1 )*ilaenv( 1,
297 $
'DORGHR',
' ', n, 1, n, -1 ) )
298 CALL dhseqr(
'S',
'V', n, 1, n, a, lda, wr, wi, vr, ldvr,
300 hswork = int( work(1) )
301 maxwrk = max( maxwrk, n + 1, n + hswork )
302 CALL dtrevc3(
'R',
'B',
SELECT, n, a, lda,
303 $ vl, ldvl, vr, ldvr, n, nout,
305 lwork_trevc = int( work(1) )
306 maxwrk = max( maxwrk, n + lwork_trevc )
307 maxwrk = max( maxwrk, 4*n )
310 CALL dhseqr(
'E',
'N', n, 1, n, a, lda, wr, wi, vr, ldvr,
312 hswork = int( work(1) )
313 maxwrk = max( maxwrk, n + 1, n + hswork )
315 maxwrk = max( maxwrk, minwrk )
319 IF( lwork.LT.minwrk .AND. .NOT.lquery )
THEN
325 CALL xerbla(
'DGEEV ', -info )
327 ELSE IF( lquery )
THEN
339 smlnum = dlamch(
'S' )
340 bignum = one / smlnum
341 CALL dlabad( smlnum, bignum )
342 smlnum = sqrt( smlnum ) / eps
343 bignum = one / smlnum
347 anrm = dlange(
'M', n, n, a, lda, dum )
349 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
352 ELSE IF( anrm.GT.bignum )
THEN
357 $
CALL dlascl(
'G', 0, 0, anrm, cscale, n, n, a, lda, ierr )
363 CALL dgebal(
'B', n, a, lda, ilo, ihi, work( ibal ), ierr )
370 CALL dgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),
371 $ lwork-iwrk+1, ierr )
379 CALL dlacpy(
'L', n, n, a, lda, vl, ldvl )
384 CALL dorghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),
385 $ lwork-iwrk+1, ierr )
391 CALL dhseqr(
'S',
'V', n, ilo, ihi, a, lda, wr, wi, vl, ldvl,
392 $ work( iwrk ), lwork-iwrk+1, info )
400 CALL dlacpy(
'F', n, n, vl, ldvl, vr, ldvr )
403 ELSE IF( wantvr )
THEN
409 CALL dlacpy(
'L', n, n, a, lda, vr, ldvr )
414 CALL dorghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),
415 $ lwork-iwrk+1, ierr )
421 CALL dhseqr(
'S',
'V', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,
422 $ work( iwrk ), lwork-iwrk+1, info )
430 CALL dhseqr(
'E',
'N', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,
431 $ work( iwrk ), lwork-iwrk+1, info )
439 IF( wantvl .OR. wantvr )
THEN
444 CALL dtrevc3( side,
'B',
SELECT, n, a, lda, vl, ldvl, vr, ldvr,
445 $ n, nout, work( iwrk ), lwork-iwrk+1, ierr )
453 CALL dgebak(
'B',
'L', n, ilo, ihi, work( ibal ), n, vl, ldvl,
459 IF( wi( i ).EQ.zero )
THEN
460 scl = one / dnrm2( n, vl( 1, i ), 1 )
461 CALL dscal( n, scl, vl( 1, i ), 1 )
462 ELSE IF( wi( i ).GT.zero )
THEN
463 scl = one / dlapy2( dnrm2( n, vl( 1, i ), 1 ),
464 $ dnrm2( n, vl( 1, i+1 ), 1 ) )
465 CALL dscal( n, scl, vl( 1, i ), 1 )
466 CALL dscal( n, scl, vl( 1, i+1 ), 1 )
468 work( iwrk+k-1 ) = vl( k, i )**2 + vl( k, i+1 )**2
470 k = idamax( n, work( iwrk ), 1 )
471 CALL dlartg( vl( k, i ), vl( k, i+1 ), cs, sn, r )
472 CALL drot( n, vl( 1, i ), 1, vl( 1, i+1 ), 1, cs, sn )
483 CALL dgebak(
'B',
'R', n, ilo, ihi, work( ibal ), n, vr, ldvr,
489 IF( wi( i ).EQ.zero )
THEN
490 scl = one / dnrm2( n, vr( 1, i ), 1 )
491 CALL dscal( n, scl, vr( 1, i ), 1 )
492 ELSE IF( wi( i ).GT.zero )
THEN
493 scl = one / dlapy2( dnrm2( n, vr( 1, i ), 1 ),
494 $ dnrm2( n, vr( 1, i+1 ), 1 ) )
495 CALL dscal( n, scl, vr( 1, i ), 1 )
496 CALL dscal( n, scl, vr( 1, i+1 ), 1 )
498 work( iwrk+k-1 ) = vr( k, i )**2 + vr( k, i+1 )**2
500 k = idamax( n, work( iwrk ), 1 )
501 CALL dlartg( vr( k, i ), vr( k, i+1 ), cs, sn, r )
502 CALL drot( n, vr( 1, i ), 1, vr( 1, i+1 ), 1, cs, sn )
512 CALL dlascl(
'G', 0, 0, cscale, anrm, n-info, 1, wr( info+1 ),
513 $ max( n-info, 1 ), ierr )
514 CALL dlascl(
'G', 0, 0, cscale, anrm, n-info, 1, wi( info+1 ),
515 $ max( n-info, 1 ), ierr )
517 CALL dlascl(
'G', 0, 0, cscale, anrm, ilo-1, 1, wr, n,
519 CALL dlascl(
'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n,
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dtrevc3(SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, LWORK, INFO)
DTREVC3
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 drot(N, DX, INCX, DY, INCY, C, S)
DROT
subroutine dgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
DGEHRD
subroutine dorghr(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
DORGHR
subroutine dlartg(F, G, CS, SN, R)
DLARTG generates a plane rotation with real cosine and real sine.
subroutine dgebak(JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO)
DGEBAK
subroutine dgebal(JOB, N, A, LDA, ILO, IHI, SCALE, INFO)
DGEBAL
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dscal(N, DA, DX, INCX)
DSCAL
subroutine dhseqr(JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO)
DHSEQR
subroutine dlabad(SMALL, LARGE)
DLABAD
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 ...