302 SUBROUTINE dgeevx( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI,
303 $ vl, ldvl, vr, ldvr, ilo, ihi, scale, abnrm,
304 $ rconde, rcondv, work, lwork, iwork, info )
312 CHARACTER BALANC, JOBVL, JOBVR, SENSE
313 INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N
314 DOUBLE PRECISION ABNRM
318 DOUBLE PRECISION A( lda, * ), RCONDE( * ), RCONDV( * ),
319 $ scale( * ), vl( ldvl, * ), vr( ldvr, * ),
320 $ wi( * ), work( * ), wr( * )
326 DOUBLE PRECISION ZERO, ONE
327 parameter( zero = 0.0d0, one = 1.0d0 )
330 LOGICAL LQUERY, SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE,
333 INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K, MAXWRK,
335 DOUBLE PRECISION ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM,
340 DOUBLE PRECISION DUM( 1 )
349 INTEGER IDAMAX, ILAENV
350 DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2, DNRM2
351 EXTERNAL lsame, idamax, ilaenv, dlamch, dlange, dlapy2,
362 lquery = ( lwork.EQ.-1 )
363 wantvl = lsame( jobvl,
'V' )
364 wantvr = lsame( jobvr,
'V' )
365 wntsnn = lsame( sense,
'N' )
366 wntsne = lsame( sense,
'E' )
367 wntsnv = lsame( sense,
'V' )
368 wntsnb = lsame( sense,
'B' )
369 IF( .NOT.( lsame( balanc,
'N' ) .OR. lsame( balanc,
370 $
'S' ) .OR. lsame( balanc,
'P' ) .OR. lsame( balanc,
'B' ) ) )
373 ELSE IF( ( .NOT.wantvl ) .AND. ( .NOT.lsame( jobvl,
'N' ) ) )
THEN
375 ELSE IF( ( .NOT.wantvr ) .AND. ( .NOT.lsame( jobvr,
'N' ) ) )
THEN
377 ELSE IF( .NOT.( wntsnn .OR. wntsne .OR. wntsnb .OR. wntsnv ) .OR.
378 $ ( ( wntsne .OR. wntsnb ) .AND. .NOT.( wantvl .AND.
381 ELSE IF( n.LT.0 )
THEN
383 ELSE IF( lda.LT.max( 1, n ) )
THEN
385 ELSE IF( ldvl.LT.1 .OR. ( wantvl .AND. ldvl.LT.n ) )
THEN
387 ELSE IF( ldvr.LT.1 .OR. ( wantvr .AND. ldvr.LT.n ) )
THEN
406 maxwrk = n + n*ilaenv( 1,
'DGEHRD',
' ', n, 1, n, 0 )
409 CALL dhseqr(
'S',
'V', n, 1, n, a, lda, wr, wi, vl, ldvl,
411 ELSE IF( wantvr )
THEN
412 CALL dhseqr(
'S',
'V', n, 1, n, a, lda, wr, wi, vr, ldvr,
416 CALL dhseqr(
'E',
'N', n, 1, n, a, lda, wr, wi, vr,
417 $ ldvr, work, -1, info )
419 CALL dhseqr(
'S',
'N', n, 1, n, a, lda, wr, wi, vr,
420 $ ldvr, work, -1, info )
425 IF( ( .NOT.wantvl ) .AND. ( .NOT.wantvr ) )
THEN
428 $ minwrk = max( minwrk, n*n+6*n )
429 maxwrk = max( maxwrk, hswork )
431 $ maxwrk = max( maxwrk, n*n + 6*n )
434 IF( ( .NOT.wntsnn ) .AND. ( .NOT.wntsne ) )
435 $ minwrk = max( minwrk, n*n + 6*n )
436 maxwrk = max( maxwrk, hswork )
437 maxwrk = max( maxwrk, n + ( n - 1 )*ilaenv( 1,
'DORGHR',
438 $
' ', n, 1, n, -1 ) )
439 IF( ( .NOT.wntsnn ) .AND. ( .NOT.wntsne ) )
440 $ maxwrk = max( maxwrk, n*n + 6*n )
441 maxwrk = max( maxwrk, 3*n )
443 maxwrk = max( maxwrk, minwrk )
447 IF( lwork.LT.minwrk .AND. .NOT.lquery )
THEN
453 CALL xerbla(
'DGEEVX', -info )
455 ELSE IF( lquery )
THEN
467 smlnum = dlamch(
'S' )
468 bignum = one / smlnum
469 CALL dlabad( smlnum, bignum )
470 smlnum = sqrt( smlnum ) / eps
471 bignum = one / smlnum
476 anrm = dlange(
'M', n, n, a, lda, dum )
478 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
481 ELSE IF( anrm.GT.bignum )
THEN
486 $
CALL dlascl(
'G', 0, 0, anrm, cscale, n, n, a, lda, ierr )
490 CALL dgebal( balanc, n, a, lda, ilo, ihi, scale, ierr )
491 abnrm = dlange(
'1', n, n, a, lda, dum )
494 CALL dlascl(
'G', 0, 0, cscale, anrm, 1, 1, dum, 1, ierr )
503 CALL dgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),
504 $ lwork-iwrk+1, ierr )
512 CALL dlacpy(
'L', n, n, a, lda, vl, ldvl )
517 CALL dorghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),
518 $ lwork-iwrk+1, ierr )
524 CALL dhseqr(
'S',
'V', n, ilo, ihi, a, lda, wr, wi, vl, ldvl,
525 $ work( iwrk ), lwork-iwrk+1, info )
533 CALL dlacpy(
'F', n, n, vl, ldvl, vr, ldvr )
536 ELSE IF( wantvr )
THEN
542 CALL dlacpy(
'L', n, n, a, lda, vr, ldvr )
547 CALL dorghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),
548 $ lwork-iwrk+1, ierr )
554 CALL dhseqr(
'S',
'V', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,
555 $ work( iwrk ), lwork-iwrk+1, info )
571 CALL dhseqr( job,
'N', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,
572 $ work( iwrk ), lwork-iwrk+1, info )
580 IF( wantvl .OR. wantvr )
THEN
585 CALL dtrevc( side,
'B',
SELECT, n, a, lda, vl, ldvl, vr, ldvr,
586 $ n, nout, work( iwrk ), ierr )
592 IF( .NOT.wntsnn )
THEN
593 CALL dtrsna( sense,
'A',
SELECT, n, a, lda, vl, ldvl, vr, ldvr,
594 $ rconde, rcondv, n, nout, work( iwrk ), n, iwork,
602 CALL dgebak( balanc,
'L', n, ilo, ihi, scale, n, vl, ldvl,
608 IF( wi( i ).EQ.zero )
THEN
609 scl = one / dnrm2( n, vl( 1, i ), 1 )
610 CALL dscal( n, scl, vl( 1, i ), 1 )
611 ELSE IF( wi( i ).GT.zero )
THEN
612 scl = one / dlapy2( dnrm2( n, vl( 1, i ), 1 ),
613 $ dnrm2( n, vl( 1, i+1 ), 1 ) )
614 CALL dscal( n, scl, vl( 1, i ), 1 )
615 CALL dscal( n, scl, vl( 1, i+1 ), 1 )
617 work( k ) = vl( k, i )**2 + vl( k, i+1 )**2
619 k = idamax( n, work, 1 )
620 CALL dlartg( vl( k, i ), vl( k, i+1 ), cs, sn, r )
621 CALL drot( n, vl( 1, i ), 1, vl( 1, i+1 ), 1, cs, sn )
631 CALL dgebak( balanc,
'R', n, ilo, ihi, scale, n, vr, ldvr,
637 IF( wi( i ).EQ.zero )
THEN
638 scl = one / dnrm2( n, vr( 1, i ), 1 )
639 CALL dscal( n, scl, vr( 1, i ), 1 )
640 ELSE IF( wi( i ).GT.zero )
THEN
641 scl = one / dlapy2( dnrm2( n, vr( 1, i ), 1 ),
642 $ dnrm2( n, vr( 1, i+1 ), 1 ) )
643 CALL dscal( n, scl, vr( 1, i ), 1 )
644 CALL dscal( n, scl, vr( 1, i+1 ), 1 )
646 work( k ) = vr( k, i )**2 + vr( k, i+1 )**2
648 k = idamax( n, work, 1 )
649 CALL dlartg( vr( k, i ), vr( k, i+1 ), cs, sn, r )
650 CALL drot( n, vr( 1, i ), 1, vr( 1, i+1 ), 1, cs, sn )
660 CALL dlascl(
'G', 0, 0, cscale, anrm, n-info, 1, wr( info+1 ),
661 $ max( n-info, 1 ), ierr )
662 CALL dlascl(
'G', 0, 0, cscale, anrm, n-info, 1, wi( info+1 ),
663 $ max( n-info, 1 ), ierr )
665 IF( ( wntsnv .OR. wntsnb ) .AND. icond.EQ.0 )
666 $
CALL dlascl(
'G', 0, 0, cscale, anrm, n, 1, rcondv, n,
669 CALL dlascl(
'G', 0, 0, cscale, anrm, ilo-1, 1, wr, n,
671 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 dgeevx(BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, INFO)
DGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
subroutine dtrsna(JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, INFO)
DTRSNA
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