286 SUBROUTINE zgeevx( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL,
287 $ ldvl, vr, ldvr, ilo, ihi, scale, abnrm, rconde,
288 $ rcondv, work, lwork, rwork, info )
297 CHARACTER BALANC, JOBVL, JOBVR, SENSE
298 INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N
299 DOUBLE PRECISION ABNRM
302 DOUBLE PRECISION RCONDE( * ), RCONDV( * ), RWORK( * ),
304 COMPLEX*16 A( lda, * ), VL( ldvl, * ), VR( ldvr, * ),
311 DOUBLE PRECISION ZERO, ONE
312 parameter ( zero = 0.0d0, one = 1.0d0 )
315 LOGICAL LQUERY, SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE,
318 INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K,
319 $ lwork_trevc, maxwrk, minwrk, nout
320 DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM
325 DOUBLE PRECISION DUM( 1 )
334 INTEGER IDAMAX, ILAENV
335 DOUBLE PRECISION DLAMCH, DZNRM2, ZLANGE
336 EXTERNAL lsame, idamax, ilaenv, dlamch, dznrm2, zlange
339 INTRINSIC dble, dcmplx, conjg, aimag, max, sqrt
346 lquery = ( lwork.EQ.-1 )
347 wantvl = lsame( jobvl,
'V' )
348 wantvr = lsame( jobvr,
'V' )
349 wntsnn = lsame( sense,
'N' )
350 wntsne = lsame( sense,
'E' )
351 wntsnv = lsame( sense,
'V' )
352 wntsnb = lsame( sense,
'B' )
353 IF( .NOT.( lsame( balanc,
'N' ) .OR. lsame( balanc,
'S' ) .OR.
354 $ lsame( balanc,
'P' ) .OR. lsame( balanc,
'B' ) ) )
THEN
356 ELSE IF( ( .NOT.wantvl ) .AND. ( .NOT.lsame( jobvl,
'N' ) ) )
THEN
358 ELSE IF( ( .NOT.wantvr ) .AND. ( .NOT.lsame( jobvr,
'N' ) ) )
THEN
360 ELSE IF( .NOT.( wntsnn .OR. wntsne .OR. wntsnb .OR. wntsnv ) .OR.
361 $ ( ( wntsne .OR. wntsnb ) .AND. .NOT.( wantvl .AND.
364 ELSE IF( n.LT.0 )
THEN
366 ELSE IF( lda.LT.max( 1, n ) )
THEN
368 ELSE IF( ldvl.LT.1 .OR. ( wantvl .AND. ldvl.LT.n ) )
THEN
370 ELSE IF( ldvr.LT.1 .OR. ( wantvr .AND. ldvr.LT.n ) )
THEN
390 maxwrk = n + n*ilaenv( 1,
'ZGEHRD',
' ', n, 1, n, 0 )
393 CALL ztrevc3(
'L',
'B',
SELECT, n, a, lda,
394 $ vl, ldvl, vr, ldvr,
395 $ n, nout, work, -1, rwork, -1, ierr )
396 lwork_trevc = int( work(1) )
397 maxwrk = max( maxwrk, lwork_trevc )
398 CALL zhseqr(
'S',
'V', n, 1, n, a, lda, w, vl, ldvl,
400 ELSE IF( wantvr )
THEN
401 CALL ztrevc3(
'R',
'B',
SELECT, n, a, lda,
402 $ vl, ldvl, vr, ldvr,
403 $ n, nout, work, -1, rwork, -1, ierr )
404 lwork_trevc = int( work(1) )
405 maxwrk = max( maxwrk, lwork_trevc )
406 CALL zhseqr(
'S',
'V', n, 1, n, a, lda, w, vr, ldvr,
410 CALL zhseqr(
'E',
'N', n, 1, n, a, lda, w, vr, ldvr,
413 CALL zhseqr(
'S',
'N', n, 1, n, a, lda, w, vr, ldvr,
417 hswork = int( work(1) )
419 IF( ( .NOT.wantvl ) .AND. ( .NOT.wantvr ) )
THEN
421 IF( .NOT.( wntsnn .OR. wntsne ) )
422 $ minwrk = max( minwrk, n*n + 2*n )
423 maxwrk = max( maxwrk, hswork )
424 IF( .NOT.( wntsnn .OR. wntsne ) )
425 $ maxwrk = max( maxwrk, n*n + 2*n )
428 IF( .NOT.( wntsnn .OR. wntsne ) )
429 $ minwrk = max( minwrk, n*n + 2*n )
430 maxwrk = max( maxwrk, hswork )
431 maxwrk = max( maxwrk, n + ( n - 1 )*ilaenv( 1,
'ZUNGHR',
432 $
' ', n, 1, n, -1 ) )
433 IF( .NOT.( wntsnn .OR. wntsne ) )
434 $ maxwrk = max( maxwrk, n*n + 2*n )
435 maxwrk = max( maxwrk, 2*n )
437 maxwrk = max( maxwrk, minwrk )
441 IF( lwork.LT.minwrk .AND. .NOT.lquery )
THEN
447 CALL xerbla(
'ZGEEVX', -info )
449 ELSE IF( lquery )
THEN
461 smlnum = dlamch(
'S' )
462 bignum = one / smlnum
463 CALL dlabad( smlnum, bignum )
464 smlnum = sqrt( smlnum ) / eps
465 bignum = one / smlnum
470 anrm = zlange(
'M', n, n, a, lda, dum )
472 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
475 ELSE IF( anrm.GT.bignum )
THEN
480 $
CALL zlascl(
'G', 0, 0, anrm, cscale, n, n, a, lda, ierr )
484 CALL zgebal( balanc, n, a, lda, ilo, ihi, scale, ierr )
485 abnrm = zlange(
'1', n, n, a, lda, dum )
488 CALL dlascl(
'G', 0, 0, cscale, anrm, 1, 1, dum, 1, ierr )
498 CALL zgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),
499 $ lwork-iwrk+1, ierr )
507 CALL zlacpy(
'L', n, n, a, lda, vl, ldvl )
513 CALL zunghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),
514 $ lwork-iwrk+1, ierr )
521 CALL zhseqr(
'S',
'V', n, ilo, ihi, a, lda, w, vl, ldvl,
522 $ work( iwrk ), lwork-iwrk+1, info )
530 CALL zlacpy(
'F', n, n, vl, ldvl, vr, ldvr )
533 ELSE IF( wantvr )
THEN
539 CALL zlacpy(
'L', n, n, a, lda, vr, ldvr )
545 CALL zunghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),
546 $ lwork-iwrk+1, ierr )
553 CALL zhseqr(
'S',
'V', n, ilo, ihi, a, lda, w, vr, ldvr,
554 $ work( iwrk ), lwork-iwrk+1, info )
571 CALL zhseqr( job,
'N', n, ilo, ihi, a, lda, w, vr, ldvr,
572 $ work( iwrk ), lwork-iwrk+1, info )
580 IF( wantvl .OR. wantvr )
THEN
586 CALL ztrevc3( side,
'B',
SELECT, n, a, lda, vl, ldvl, vr, ldvr,
587 $ n, nout, work( iwrk ), lwork-iwrk+1,
595 IF( .NOT.wntsnn )
THEN
596 CALL ztrsna( sense,
'A',
SELECT, n, a, lda, vl, ldvl, vr, ldvr,
597 $ rconde, rcondv, n, nout, work( iwrk ), n, rwork,
605 CALL zgebak( balanc,
'L', n, ilo, ihi, scale, n, vl, ldvl,
611 scl = one / dznrm2( n, vl( 1, i ), 1 )
612 CALL zdscal( n, scl, vl( 1, i ), 1 )
614 rwork( k ) = dble( vl( k, i ) )**2 +
615 $ aimag( vl( k, i ) )**2
617 k = idamax( n, rwork, 1 )
618 tmp = conjg( vl( k, i ) ) / sqrt( rwork( k ) )
619 CALL zscal( n, tmp, vl( 1, i ), 1 )
620 vl( k, i ) = dcmplx( dble( vl( k, i ) ), zero )
628 CALL zgebak( balanc,
'R', n, ilo, ihi, scale, n, vr, ldvr,
634 scl = one / dznrm2( n, vr( 1, i ), 1 )
635 CALL zdscal( n, scl, vr( 1, i ), 1 )
637 rwork( k ) = dble( vr( k, i ) )**2 +
638 $ aimag( vr( k, i ) )**2
640 k = idamax( n, rwork, 1 )
641 tmp = conjg( vr( k, i ) ) / sqrt( rwork( k ) )
642 CALL zscal( n, tmp, vr( 1, i ), 1 )
643 vr( k, i ) = dcmplx( dble( vr( k, i ) ), zero )
651 CALL zlascl(
'G', 0, 0, cscale, anrm, n-info, 1, w( info+1 ),
652 $ max( n-info, 1 ), ierr )
654 IF( ( wntsnv .OR. wntsnb ) .AND. icond.EQ.0 )
655 $
CALL dlascl(
'G', 0, 0, cscale, anrm, n, 1, rcondv, n,
658 CALL zlascl(
'G', 0, 0, cscale, anrm, ilo-1, 1, w, n, ierr )
subroutine zgebak(JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO)
ZGEBAK
subroutine ztrsna(JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK, INFO)
ZTRSNA
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 zgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
ZGEHRD
subroutine zlascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zunghr(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
ZUNGHR
subroutine zgebal(JOB, N, A, LDA, ILO, IHI, SCALE, INFO)
ZGEBAL
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine zhseqr(JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, WORK, LWORK, INFO)
ZHSEQR
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
subroutine zgeevx(BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, INFO)
ZGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
subroutine ztrevc3(SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, LWORK, RWORK, LRWORK, INFO)
ZTREVC3
subroutine zscal(N, ZA, ZX, INCX)
ZSCAL