284 SUBROUTINE cgeevx( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL,
285 $ ldvl, vr, ldvr, ilo, ihi, scale, abnrm, rconde,
286 $ rcondv, work, lwork, rwork, info )
294 CHARACTER BALANC, JOBVL, JOBVR, SENSE
295 INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N
299 REAL RCONDE( * ), RCONDV( * ), RWORK( * ),
301 COMPLEX A( lda, * ), VL( ldvl, * ), VR( ldvr, * ),
309 parameter( zero = 0.0e0, one = 1.0e0 )
312 LOGICAL LQUERY, SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE,
315 INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K, MAXWRK,
317 REAL ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM
331 INTEGER ILAENV, ISAMAX
332 REAL CLANGE, SCNRM2, SLAMCH
333 EXTERNAL lsame, ilaenv, isamax, clange, scnrm2, slamch
336 INTRINSIC aimag, cmplx, conjg, max,
REAL, SQRT
343 lquery = ( lwork.EQ.-1 )
344 wantvl = lsame( jobvl,
'V' )
345 wantvr = lsame( jobvr,
'V' )
346 wntsnn = lsame( sense,
'N' )
347 wntsne = lsame( sense,
'E' )
348 wntsnv = lsame( sense,
'V' )
349 wntsnb = lsame( sense,
'B' )
350 IF( .NOT.( lsame( balanc,
'N' ) .OR. lsame( balanc,
'S' ) .OR.
351 $ lsame( balanc,
'P' ) .OR. lsame( balanc,
'B' ) ) )
THEN
353 ELSE IF( ( .NOT.wantvl ) .AND. ( .NOT.lsame( jobvl,
'N' ) ) )
THEN
355 ELSE IF( ( .NOT.wantvr ) .AND. ( .NOT.lsame( jobvr,
'N' ) ) )
THEN
357 ELSE IF( .NOT.( wntsnn .OR. wntsne .OR. wntsnb .OR. wntsnv ) .OR.
358 $ ( ( wntsne .OR. wntsnb ) .AND. .NOT.( wantvl .AND.
361 ELSE IF( n.LT.0 )
THEN
363 ELSE IF( lda.LT.max( 1, n ) )
THEN
365 ELSE IF( ldvl.LT.1 .OR. ( wantvl .AND. ldvl.LT.n ) )
THEN
367 ELSE IF( ldvr.LT.1 .OR. ( wantvr .AND. ldvr.LT.n ) )
THEN
387 maxwrk = n + n*ilaenv( 1,
'CGEHRD',
' ', n, 1, n, 0 )
390 CALL chseqr(
'S',
'V', n, 1, n, a, lda, w, vl, ldvl,
392 ELSE IF( wantvr )
THEN
393 CALL chseqr(
'S',
'V', n, 1, n, a, lda, w, vr, ldvr,
397 CALL chseqr(
'E',
'N', n, 1, n, a, lda, w, vr, ldvr,
400 CALL chseqr(
'S',
'N', n, 1, n, a, lda, w, vr, ldvr,
406 IF( ( .NOT.wantvl ) .AND. ( .NOT.wantvr ) )
THEN
408 IF( .NOT.( wntsnn .OR. wntsne ) )
409 $ minwrk = max( minwrk, n*n + 2*n )
410 maxwrk = max( maxwrk, hswork )
411 IF( .NOT.( wntsnn .OR. wntsne ) )
412 $ maxwrk = max( maxwrk, n*n + 2*n )
415 IF( .NOT.( wntsnn .OR. wntsne ) )
416 $ minwrk = max( minwrk, n*n + 2*n )
417 maxwrk = max( maxwrk, hswork )
418 maxwrk = max( maxwrk, n + ( n - 1 )*ilaenv( 1,
'CUNGHR',
419 $
' ', n, 1, n, -1 ) )
420 IF( .NOT.( wntsnn .OR. wntsne ) )
421 $ maxwrk = max( maxwrk, n*n + 2*n )
422 maxwrk = max( maxwrk, 2*n )
424 maxwrk = max( maxwrk, minwrk )
428 IF( lwork.LT.minwrk .AND. .NOT.lquery )
THEN
434 CALL xerbla(
'CGEEVX', -info )
436 ELSE IF( lquery )
THEN
448 smlnum = slamch(
'S' )
449 bignum = one / smlnum
450 CALL slabad( smlnum, bignum )
451 smlnum = sqrt( smlnum ) / eps
452 bignum = one / smlnum
457 anrm = clange(
'M', n, n, a, lda, dum )
459 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
462 ELSE IF( anrm.GT.bignum )
THEN
467 $
CALL clascl(
'G', 0, 0, anrm, cscale, n, n, a, lda, ierr )
471 CALL cgebal( balanc, n, a, lda, ilo, ihi, scale, ierr )
472 abnrm = clange(
'1', n, n, a, lda, dum )
475 CALL slascl(
'G', 0, 0, cscale, anrm, 1, 1, dum, 1, ierr )
485 CALL cgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),
486 $ lwork-iwrk+1, ierr )
494 CALL clacpy(
'L', n, n, a, lda, vl, ldvl )
500 CALL cunghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),
501 $ lwork-iwrk+1, ierr )
508 CALL chseqr(
'S',
'V', n, ilo, ihi, a, lda, w, vl, ldvl,
509 $ work( iwrk ), lwork-iwrk+1, info )
517 CALL clacpy(
'F', n, n, vl, ldvl, vr, ldvr )
520 ELSE IF( wantvr )
THEN
526 CALL clacpy(
'L', n, n, a, lda, vr, ldvr )
532 CALL cunghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),
533 $ lwork-iwrk+1, ierr )
540 CALL chseqr(
'S',
'V', n, ilo, ihi, a, lda, w, vr, ldvr,
541 $ work( iwrk ), lwork-iwrk+1, info )
558 CALL chseqr( job,
'N', n, ilo, ihi, a, lda, w, vr, ldvr,
559 $ work( iwrk ), lwork-iwrk+1, info )
567 IF( wantvl .OR. wantvr )
THEN
573 CALL ctrevc( side,
'B',
SELECT, n, a, lda, vl, ldvl, vr, ldvr,
574 $ n, nout, work( iwrk ), rwork, ierr )
581 IF( .NOT.wntsnn )
THEN
582 CALL ctrsna( sense,
'A',
SELECT, n, a, lda, vl, ldvl, vr, ldvr,
583 $ rconde, rcondv, n, nout, work( iwrk ), n, rwork,
591 CALL cgebak( balanc,
'L', n, ilo, ihi, scale, n, vl, ldvl,
597 scl = one / scnrm2( n, vl( 1, i ), 1 )
598 CALL csscal( n, scl, vl( 1, i ), 1 )
600 rwork( k ) =
REAL( VL( K, I ) )**2 +
601 $ aimag( vl( k, i ) )**2
603 k = isamax( n, rwork, 1 )
604 tmp = conjg( vl( k, i ) ) / sqrt( rwork( k ) )
605 CALL cscal( n, tmp, vl( 1, i ), 1 )
606 vl( k, i ) = cmplx(
REAL( VL( K, I ) ), ZERO )
614 CALL cgebak( balanc,
'R', n, ilo, ihi, scale, n, vr, ldvr,
620 scl = one / scnrm2( n, vr( 1, i ), 1 )
621 CALL csscal( n, scl, vr( 1, i ), 1 )
623 rwork( k ) =
REAL( VR( K, I ) )**2 +
624 $ aimag( vr( k, i ) )**2
626 k = isamax( n, rwork, 1 )
627 tmp = conjg( vr( k, i ) ) / sqrt( rwork( k ) )
628 CALL cscal( n, tmp, vr( 1, i ), 1 )
629 vr( k, i ) = cmplx(
REAL( VR( K, I ) ), ZERO )
637 CALL clascl(
'G', 0, 0, cscale, anrm, n-info, 1, w( info+1 ),
638 $ max( n-info, 1 ), ierr )
640 IF( ( wntsnv .OR. wntsnb ) .AND. icond.EQ.0 )
641 $
CALL slascl(
'G', 0, 0, cscale, anrm, n, 1, rcondv, n,
644 CALL clascl(
'G', 0, 0, cscale, anrm, ilo-1, 1, w, n, ierr )
subroutine cscal(N, CA, CX, INCX)
CSCAL
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine slascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
SLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine ctrsna(JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK, INFO)
CTRSNA
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine cgebal(JOB, N, A, LDA, ILO, IHI, SCALE, INFO)
CGEBAL
subroutine chseqr(JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, WORK, LWORK, INFO)
CHSEQR
subroutine clascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
CLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine cgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
CGEHRD
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine csscal(N, SA, CX, INCX)
CSSCAL
subroutine cgebak(JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO)
CGEBAK
subroutine cgeevx(BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, INFO)
CGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
subroutine ctrevc(SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO)
CTREVC
subroutine cunghr(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
CUNGHR