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 ...