phynexis-deps/lapack
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
Files
9aed94de6d78beddb218baaebce809193b8160fc
lapack/SRC/ctgevc.f
T
NAKATA Maho ac82605ea9 refactor: rename ABS1 statement function to CABS1 for consistency 
Several LAPACK, BLAS, and CBLAS source files defined a local statement
function named ABS1 for the complex 1-norm approximation:

    ABS1( X ) = ABS( REAL( X ) ) + ABS( AIMAG( X ) )
    ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) )

The majority of the codebase already uses CABS1 for this identical
purpose. This commit renames ABS1 to CABS1 in all remaining files
(definition line, declaration line, and all call sites within the
same file) to make the naming consistent across the repository.

A small number of fixed-form lines required continuation-line splits
to stay within the 72-column limit after the rename.

No numerical change. Statement functions are file-local in Fortran,
so there is no ABI or interface impact.

This is a preparatory cleanup before inlining these statement
functions (see issue #1200).
2026-03-28 14:46:42 +09:00

734 lines
23 KiB
FortranFixed
Raw Blame History

*> \brief \b CTGEVC
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> Download CTGEVC + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ctgevc.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ctgevc.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ctgevc.f">
*> [TXT]</a>
*
* Definition:
* ===========
*
* SUBROUTINE CTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL,
* LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER HOWMNY, SIDE
* INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N
* ..
* .. Array Arguments ..
* LOGICAL SELECT( * )
* REAL RWORK( * )
* COMPLEX P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
* $ VR( LDVR, * ), WORK( * )
* ..
*
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CTGEVC computes some or all of the right and/or left eigenvectors of
*> a pair of complex matrices (S,P), where S and P are upper triangular.
*> Matrix pairs of this type are produced by the generalized Schur
*> factorization of a complex matrix pair (A,B):
*>
*> A = Q*S*Z**H, B = Q*P*Z**H
*>
*> as computed by CGGHRD + CHGEQZ.
*>
*> The right eigenvector x and the left eigenvector y of (S,P)
*> corresponding to an eigenvalue w are defined by:
*>
*> S*x = w*P*x, (y**H)*S = w*(y**H)*P,
*>
*> where y**H denotes the conjugate transpose of y.
*> The eigenvalues are not input to this routine, but are computed
*> directly from the diagonal elements of S and P.
*>
*> This routine returns the matrices X and/or Y of right and left
*> eigenvectors of (S,P), or the products Z*X and/or Q*Y,
*> where Z and Q are input matrices.
*> If Q and Z are the unitary factors from the generalized Schur
*> factorization of a matrix pair (A,B), then Z*X and Q*Y
*> are the matrices of right and left eigenvectors of (A,B).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'R': compute right eigenvectors only;
*> = 'L': compute left eigenvectors only;
*> = 'B': compute both right and left eigenvectors.
*> \endverbatim
*>
*> \param[in] HOWMNY
*> \verbatim
*> HOWMNY is CHARACTER*1
*> = 'A': compute all right and/or left eigenvectors;
*> = 'B': compute all right and/or left eigenvectors,
*> backtransformed by the matrices in VR and/or VL;
*> = 'S': compute selected right and/or left eigenvectors,
*> specified by the logical array SELECT.
*> \endverbatim
*>
*> \param[in] SELECT
*> \verbatim
*> SELECT is LOGICAL array, dimension (N)
*> If HOWMNY='S', SELECT specifies the eigenvectors to be
*> computed. The eigenvector corresponding to the j-th
*> eigenvalue is computed if SELECT(j) = .TRUE..
*> Not referenced if HOWMNY = 'A' or 'B'.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrices S and P. N >= 0.
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*> S is COMPLEX array, dimension (LDS,N)
*> The upper triangular matrix S from a generalized Schur
*> factorization, as computed by CHGEQZ.
*> \endverbatim
*>
*> \param[in] LDS
*> \verbatim
*> LDS is INTEGER
*> The leading dimension of array S. LDS >= max(1,N).
*> \endverbatim
*>
*> \param[in] P
*> \verbatim
*> P is COMPLEX array, dimension (LDP,N)
*> The upper triangular matrix P from a generalized Schur
*> factorization, as computed by CHGEQZ. P must have real
*> diagonal elements.
*> \endverbatim
*>
*> \param[in] LDP
*> \verbatim
*> LDP is INTEGER
*> The leading dimension of array P. LDP >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] VL
*> \verbatim
*> VL is COMPLEX array, dimension (LDVL,MM)
*> On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
*> contain an N-by-N matrix Q (usually the unitary matrix Q
*> of left Schur vectors returned by CHGEQZ).
*> On exit, if SIDE = 'L' or 'B', VL contains:
*> if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);
*> if HOWMNY = 'B', the matrix Q*Y;
*> if HOWMNY = 'S', the left eigenvectors of (S,P) specified by
*> SELECT, stored consecutively in the columns of
*> VL, in the same order as their eigenvalues.
*> Not referenced if SIDE = 'R'.
*> \endverbatim
*>
*> \param[in] LDVL
*> \verbatim
*> LDVL is INTEGER
*> The leading dimension of array VL. LDVL >= 1, and if
*> SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N.
*> \endverbatim
*>
*> \param[in,out] VR
*> \verbatim
*> VR is COMPLEX array, dimension (LDVR,MM)
*> On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
*> contain an N-by-N matrix Z (usually the unitary matrix Z
*> of right Schur vectors returned by CHGEQZ).
*> On exit, if SIDE = 'R' or 'B', VR contains:
*> if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);
*> if HOWMNY = 'B', the matrix Z*X;
*> if HOWMNY = 'S', the right eigenvectors of (S,P) specified by
*> SELECT, stored consecutively in the columns of
*> VR, in the same order as their eigenvalues.
*> Not referenced if SIDE = 'L'.
*> \endverbatim
*>
*> \param[in] LDVR
*> \verbatim
*> LDVR is INTEGER
*> The leading dimension of the array VR. LDVR >= 1, and if
*> SIDE = 'R' or 'B', LDVR >= N.
*> \endverbatim
*>
*> \param[in] MM
*> \verbatim
*> MM is INTEGER
*> The number of columns in the arrays VL and/or VR. MM >= M.
*> \endverbatim
*>
*> \param[out] M
*> \verbatim
*> M is INTEGER
*> The number of columns in the arrays VL and/or VR actually
*> used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
*> is set to N. Each selected eigenvector occupies one column.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is REAL array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup tgevc
*
* =====================================================================
SUBROUTINE CTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL,
$ LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )
IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER HOWMNY, SIDE
INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
REAL RWORK( * )
COMPLEX P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
$ VR( LDVR, * ), WORK( * )
* ..
*
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
COMPLEX CZERO, CONE
PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ),
$ CONE = ( 1.0E+0, 0.0E+0 ) )
* ..
* .. Local Scalars ..
LOGICAL COMPL, COMPR, ILALL, ILBACK, ILBBAD, ILCOMP,
$ LSA, LSB
INTEGER I, IBEG, IEIG, IEND, IHWMNY, IM, ISIDE, ISRC,
$ J, JE, JR
REAL ACOEFA, ACOEFF, ANORM, ASCALE, BCOEFA, BIG,
$ BIGNUM, BNORM, BSCALE, DMIN, SAFMIN, SBETA,
$ SCALE, SMALL, TEMP, ULP, XMAX
COMPLEX BCOEFF, CA, CB, D, SALPHA, SUM, SUMA, SUMB, X
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH
COMPLEX CLADIV
EXTERNAL LSAME, SLAMCH, CLADIV
* ..
* .. External Subroutines ..
EXTERNAL CGEMV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, AIMAG, CMPLX, CONJG, MAX, MIN, REAL
* ..
* .. Statement Functions ..
REAL CABS1
* ..
* .. Statement Function definitions ..
CABS1( X ) = ABS( REAL( X ) ) + ABS( AIMAG( X ) )
* ..
* .. Executable Statements ..
*
* Decode and Test the input parameters
*
IF( LSAME( HOWMNY, 'A' ) ) THEN
IHWMNY = 1
ILALL = .TRUE.
ILBACK = .FALSE.
ELSE IF( LSAME( HOWMNY, 'S' ) ) THEN
IHWMNY = 2
ILALL = .FALSE.
ILBACK = .FALSE.
ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN
IHWMNY = 3
ILALL = .TRUE.
ILBACK = .TRUE.
ELSE
IHWMNY = -1
END IF
*
IF( LSAME( SIDE, 'R' ) ) THEN
ISIDE = 1
COMPL = .FALSE.
COMPR = .TRUE.
ELSE IF( LSAME( SIDE, 'L' ) ) THEN
ISIDE = 2
COMPL = .TRUE.
COMPR = .FALSE.
ELSE IF( LSAME( SIDE, 'B' ) ) THEN
ISIDE = 3
COMPL = .TRUE.
COMPR = .TRUE.
ELSE
ISIDE = -1
END IF
*
INFO = 0
IF( ISIDE.LT.0 ) THEN
INFO = -1
ELSE IF( IHWMNY.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDS.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDP.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'CTGEVC', -INFO )
RETURN
END IF
*
* Count the number of eigenvectors
*
IF( .NOT.ILALL ) THEN
IM = 0
DO 10 J = 1, N
IF( SELECT( J ) )
$ IM = IM + 1
10 CONTINUE
ELSE
IM = N
END IF
*
* Check diagonal of B
*
ILBBAD = .FALSE.
DO 20 J = 1, N
IF( AIMAG( P( J, J ) ).NE.ZERO )
$ ILBBAD = .TRUE.
20 CONTINUE
*
IF( ILBBAD ) THEN
INFO = -7
ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN
INFO = -10
ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN
INFO = -12
ELSE IF( MM.LT.IM ) THEN
INFO = -13
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'CTGEVC', -INFO )
RETURN
END IF
*
* Quick return if possible
*
M = IM
IF( N.EQ.0 )
$ RETURN
*
* Machine Constants
*
SAFMIN = SLAMCH( 'Safe minimum' )
BIG = ONE / SAFMIN
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
SMALL = SAFMIN*REAL( N ) / ULP
BIG = ONE / SMALL
BIGNUM = ONE / ( SAFMIN*REAL( N ) )
*
* Compute the 1-norm of each column of the strictly upper triangular
* part of A and B to check for possible overflow in the triangular
* solver.
*
ANORM = CABS1( S( 1, 1 ) )
BNORM = CABS1( P( 1, 1 ) )
RWORK( 1 ) = ZERO
RWORK( N+1 ) = ZERO
DO 40 J = 2, N
RWORK( J ) = ZERO
RWORK( N+J ) = ZERO
DO 30 I = 1, J - 1
RWORK( J ) = RWORK( J ) + CABS1( S( I, J ) )
RWORK( N+J ) = RWORK( N+J ) + CABS1( P( I, J ) )
30 CONTINUE
ANORM = MAX( ANORM, RWORK( J )+CABS1( S( J, J ) ) )
BNORM = MAX( BNORM, RWORK( N+J )+CABS1( P( J, J ) ) )
40 CONTINUE
*
ASCALE = ONE / MAX( ANORM, SAFMIN )
BSCALE = ONE / MAX( BNORM, SAFMIN )
*
* Left eigenvectors
*
IF( COMPL ) THEN
IEIG = 0
*
* Main loop over eigenvalues
*
DO 140 JE = 1, N
IF( ILALL ) THEN
ILCOMP = .TRUE.
ELSE
ILCOMP = SELECT( JE )
END IF
IF( ILCOMP ) THEN
IEIG = IEIG + 1
*
IF( CABS1( S( JE, JE ) ).LE.SAFMIN .AND.
$ ABS( REAL( P( JE, JE ) ) ).LE.SAFMIN ) THEN
*
* Singular matrix pencil -- return unit eigenvector
*
DO 50 JR = 1, N
VL( JR, IEIG ) = CZERO
50 CONTINUE
VL( IEIG, IEIG ) = CONE
GO TO 140
END IF
*
* Non-singular eigenvalue:
* Compute coefficients a and b in
* H
* y ( a A - b B ) = 0
*
TEMP = ONE / MAX( CABS1( S( JE, JE ) )*ASCALE,
$ ABS( REAL( P( JE, JE ) ) )*BSCALE, SAFMIN )
SALPHA = ( TEMP*S( JE, JE ) )*ASCALE
SBETA = ( TEMP*REAL( P( JE, JE ) ) )*BSCALE
ACOEFF = SBETA*ASCALE
BCOEFF = SALPHA*BSCALE
*
* Scale to avoid underflow
*
LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEFF ).LT.SMALL
LSB = CABS1( SALPHA ).GE.SAFMIN .AND. CABS1( BCOEFF ).LT.
$ SMALL
*
SCALE = ONE
IF( LSA )
$ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
IF( LSB )
$ SCALE = MAX( SCALE, ( SMALL / CABS1( SALPHA ) )*
$ MIN( BNORM, BIG ) )
IF( LSA .OR. LSB ) THEN
SCALE = MIN( SCALE, ONE /
$ ( SAFMIN*MAX( ONE, ABS( ACOEFF ),
$ CABS1( BCOEFF ) ) ) )
IF( LSA ) THEN
ACOEFF = ASCALE*( SCALE*SBETA )
ELSE
ACOEFF = SCALE*ACOEFF
END IF
IF( LSB ) THEN
BCOEFF = BSCALE*( SCALE*SALPHA )
ELSE
BCOEFF = SCALE*BCOEFF
END IF
END IF
*
ACOEFA = ABS( ACOEFF )
BCOEFA = CABS1( BCOEFF )
XMAX = ONE
DO 60 JR = 1, N
WORK( JR ) = CZERO
60 CONTINUE
WORK( JE ) = CONE
DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
*
* H
* Triangular solve of (a A - b B) y = 0
*
* H
* (rowwise in (a A - b B) , or columnwise in a A - b B)
*
DO 100 J = JE + 1, N
*
* Compute
* j-1
* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k)
* k=je
* (Scale if necessary)
*
TEMP = ONE / XMAX
IF( ACOEFA*RWORK( J )+BCOEFA*RWORK( N+J ).GT.BIGNUM*
$ TEMP ) THEN
DO 70 JR = JE, J - 1
WORK( JR ) = TEMP*WORK( JR )
70 CONTINUE
XMAX = ONE
END IF
SUMA = CZERO
SUMB = CZERO
*
DO 80 JR = JE, J - 1
SUMA = SUMA + CONJG( S( JR, J ) )*WORK( JR )
SUMB = SUMB + CONJG( P( JR, J ) )*WORK( JR )
80 CONTINUE
SUM = ACOEFF*SUMA - CONJG( BCOEFF )*SUMB
*
* Form x(j) = - SUM / conjg( a*S(j,j) - b*P(j,j) )
*
* with scaling and perturbation of the denominator
*
D = CONJG( ACOEFF*S( J, J )-BCOEFF*P( J, J ) )
IF( CABS1( D ).LE.DMIN )
$ D = CMPLX( DMIN )
*
IF( CABS1( D ).LT.ONE ) THEN
IF( CABS1( SUM ).GE.BIGNUM*CABS1( D ) ) THEN
TEMP = ONE / CABS1( SUM )
DO 90 JR = JE, J - 1
WORK( JR ) = TEMP*WORK( JR )
90 CONTINUE
XMAX = TEMP*XMAX
SUM = TEMP*SUM
END IF
END IF
WORK( J ) = CLADIV( -SUM, D )
XMAX = MAX( XMAX, CABS1( WORK( J ) ) )
100 CONTINUE
*
* Back transform eigenvector if HOWMNY='B'.
*
IF( ILBACK ) THEN
CALL CGEMV( 'N', N, N+1-JE, CONE, VL( 1, JE ),
$ LDVL,
$ WORK( JE ), 1, CZERO, WORK( N+1 ), 1 )
ISRC = 2
IBEG = 1
ELSE
ISRC = 1
IBEG = JE
END IF
*
* Copy and scale eigenvector into column of VL
*
XMAX = ZERO
DO 110 JR = IBEG, N
XMAX = MAX( XMAX, CABS1( WORK( ( ISRC-1 )*N+JR ) ) )
110 CONTINUE
*
IF( XMAX.GT.SAFMIN ) THEN
TEMP = ONE / XMAX
DO 120 JR = IBEG, N
VL( JR, IEIG ) = TEMP*WORK( ( ISRC-1 )*N+JR )
120 CONTINUE
ELSE
IBEG = N + 1
END IF
*
DO 130 JR = 1, IBEG - 1
VL( JR, IEIG ) = CZERO
130 CONTINUE
*
END IF
140 CONTINUE
END IF
*
* Right eigenvectors
*
IF( COMPR ) THEN
IEIG = IM + 1
*
* Main loop over eigenvalues
*
DO 250 JE = N, 1, -1
IF( ILALL ) THEN
ILCOMP = .TRUE.
ELSE
ILCOMP = SELECT( JE )
END IF
IF( ILCOMP ) THEN
IEIG = IEIG - 1
*
IF( CABS1( S( JE, JE ) ).LE.SAFMIN .AND.
$ ABS( REAL( P( JE, JE ) ) ).LE.SAFMIN ) THEN
*
* Singular matrix pencil -- return unit eigenvector
*
DO 150 JR = 1, N
VR( JR, IEIG ) = CZERO
150 CONTINUE
VR( IEIG, IEIG ) = CONE
GO TO 250
END IF
*
* Non-singular eigenvalue:
* Compute coefficients a and b in
*
* ( a A - b B ) x = 0
*
TEMP = ONE / MAX( CABS1( S( JE, JE ) )*ASCALE,
$ ABS( REAL( P( JE, JE ) ) )*BSCALE, SAFMIN )
SALPHA = ( TEMP*S( JE, JE ) )*ASCALE
SBETA = ( TEMP*REAL( P( JE, JE ) ) )*BSCALE
ACOEFF = SBETA*ASCALE
BCOEFF = SALPHA*BSCALE
*
* Scale to avoid underflow
*
LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEFF ).LT.SMALL
LSB = CABS1( SALPHA ).GE.SAFMIN .AND. CABS1( BCOEFF ).LT.
$ SMALL
*
SCALE = ONE
IF( LSA )
$ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
IF( LSB )
$ SCALE = MAX( SCALE, ( SMALL / CABS1( SALPHA ) )*
$ MIN( BNORM, BIG ) )
IF( LSA .OR. LSB ) THEN
SCALE = MIN( SCALE, ONE /
$ ( SAFMIN*MAX( ONE, ABS( ACOEFF ),
$ CABS1( BCOEFF ) ) ) )
IF( LSA ) THEN
ACOEFF = ASCALE*( SCALE*SBETA )
ELSE
ACOEFF = SCALE*ACOEFF
END IF
IF( LSB ) THEN
BCOEFF = BSCALE*( SCALE*SALPHA )
ELSE
BCOEFF = SCALE*BCOEFF
END IF
END IF
*
ACOEFA = ABS( ACOEFF )
BCOEFA = CABS1( BCOEFF )
XMAX = ONE
DO 160 JR = 1, N
WORK( JR ) = CZERO
160 CONTINUE
WORK( JE ) = CONE
DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
*
* Triangular solve of (a A - b B) x = 0 (columnwise)
*
* WORK(1:j-1) contains sums w,
* WORK(j+1:JE) contains x
*
DO 170 JR = 1, JE - 1
WORK( JR ) = ACOEFF*S( JR, JE ) - BCOEFF*P( JR, JE )
170 CONTINUE
WORK( JE ) = CONE
*
DO 210 J = JE - 1, 1, -1
*
* Form x(j) := - w(j) / d
* with scaling and perturbation of the denominator
*
D = ACOEFF*S( J, J ) - BCOEFF*P( J, J )
IF( CABS1( D ).LE.DMIN )
$ D = CMPLX( DMIN )
*
IF( CABS1( D ).LT.ONE ) THEN
IF( CABS1( WORK( J ) ).GE.BIGNUM*CABS1( D ) ) THEN
TEMP = ONE / CABS1( WORK( J ) )
DO 180 JR = 1, JE
WORK( JR ) = TEMP*WORK( JR )
180 CONTINUE
END IF
END IF
*
WORK( J ) = CLADIV( -WORK( J ), D )
*
IF( J.GT.1 ) THEN
*
* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling
*
IF( CABS1( WORK( J ) ).GT.ONE ) THEN
TEMP = ONE / CABS1( WORK( J ) )
IF( ACOEFA*RWORK( J )+BCOEFA*RWORK( N+J ).GE.
$ BIGNUM*TEMP ) THEN
DO 190 JR = 1, JE
WORK( JR ) = TEMP*WORK( JR )
190 CONTINUE
END IF
END IF
*
CA = ACOEFF*WORK( J )
CB = BCOEFF*WORK( J )
DO 200 JR = 1, J - 1
WORK( JR ) = WORK( JR ) + CA*S( JR, J ) -
$ CB*P( JR, J )
200 CONTINUE
END IF
210 CONTINUE
*
* Back transform eigenvector if HOWMNY='B'.
*
IF( ILBACK ) THEN
CALL CGEMV( 'N', N, JE, CONE, VR, LDVR, WORK, 1,
$ CZERO, WORK( N+1 ), 1 )
ISRC = 2
IEND = N
ELSE
ISRC = 1
IEND = JE
END IF
*
* Copy and scale eigenvector into column of VR
*
XMAX = ZERO
DO 220 JR = 1, IEND
XMAX = MAX( XMAX, CABS1( WORK( ( ISRC-1 )*N+JR ) ) )
220 CONTINUE
*
IF( XMAX.GT.SAFMIN ) THEN
TEMP = ONE / XMAX
DO 230 JR = 1, IEND
VR( JR, IEIG ) = TEMP*WORK( ( ISRC-1 )*N+JR )
230 CONTINUE
ELSE
IEND = 0
END IF
*
DO 240 JR = IEND + 1, N
VR( JR, IEIG ) = CZERO
240 CONTINUE
*
END IF
250 CONTINUE
END IF
*
RETURN
*
* End of CTGEVC
*
END
Reference in New Issue View Git Blame Copy Permalink