SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * May 7, 2001 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE INTEGER INFO, LDT, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), $ WORK( * ) * .. * * Purpose * ======= * * DTREVC computes some or all of the right and/or left eigenvectors of * a real upper quasi-triangular matrix T. * Matrices of this type are produced by the Schur factorization of * a real general matrix: A = Q*T*Q**T, as computed by DHSEQR. * * The right eigenvector x and the left eigenvector y of T corresponding * to an eigenvalue w are defined by: * * T*x = w*x, (y**H)*T = w*(y**H) * * where y**H denotes the conjugate transpose of y. * The eigenvalues are not input to this routine, but are read directly * from the diagonal blocks of T. * * This routine returns the matrices X and/or Y of right and left * eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an * input matrix. If Q is the orthogonal factor that reduces a matrix * A to Schur form T, then Q*X and Q*Y are the matrices of right and * left eigenvectors of A. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'R': compute right eigenvectors only; * = 'L': compute left eigenvectors only; * = 'B': compute both right and left eigenvectors. * * HOWMNY (input) 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, * as indicated by the logical array SELECT. * * SELECT (input/output) LOGICAL array, dimension (N) * If HOWMNY = 'S', SELECT specifies the eigenvectors to be * computed. * If w(j) is a real eigenvalue, the corresponding real * eigenvector is computed if SELECT(j) is .TRUE.. * If w(j) and w(j+1) are the real and imaginary parts of a * complex eigenvalue, the corresponding complex eigenvector is * computed if either SELECT(j) or SELECT(j+1) is .TRUE., and * on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to * .FALSE.. * Not referenced if HOWMNY = 'A' or 'B'. * * N (input) INTEGER * The order of the matrix T. N >= 0. * * T (input) DOUBLE PRECISION array, dimension (LDT,N) * The upper quasi-triangular matrix T in Schur canonical form. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= max(1,N). * * VL (input/output) DOUBLE PRECISION 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 orthogonal matrix Q * of Schur vectors returned by DHSEQR). * On exit, if SIDE = 'L' or 'B', VL contains: * if HOWMNY = 'A', the matrix Y of left eigenvectors of T; * if HOWMNY = 'B', the matrix Q*Y; * if HOWMNY = 'S', the left eigenvectors of T specified by * SELECT, stored consecutively in the columns * of VL, in the same order as their * eigenvalues. * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part, and the second the imaginary part. * Not referenced if SIDE = 'R'. * * LDVL (input) INTEGER * The leading dimension of the array VL. LDVL >= 1, and if * SIDE = 'L' or 'B', LDVL >= N. * * VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must * contain an N-by-N matrix Q (usually the orthogonal matrix Q * of Schur vectors returned by DHSEQR). * On exit, if SIDE = 'R' or 'B', VR contains: * if HOWMNY = 'A', the matrix X of right eigenvectors of T; * if HOWMNY = 'B', the matrix Q*X; * if HOWMNY = 'S', the right eigenvectors of T specified by * SELECT, stored consecutively in the columns * of VR, in the same order as their * eigenvalues. * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part and the second the imaginary part. * Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER * The leading dimension of the array VR. LDVR >= 1, and if * SIDE = 'R' or 'B', LDVR >= N. * * MM (input) INTEGER * The number of columns in the arrays VL and/or VR. MM >= M. * * M (output) 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 real eigenvector occupies one column and each * selected complex eigenvector occupies two columns. * * WORK (workspace) DOUBLE PRECISION array, dimension (3*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The algorithm used in this program is basically backward (forward) * substitution, with scaling to make the the code robust against * possible overflow. * * Each eigenvector is normalized so that the element of largest * magnitude has magnitude 1; here the magnitude of a complex number * (x,y) is taken to be |x| + |y|. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL ALLV, BOTHV, LEFTV, OVER, PAIR, RIGHTV, SOMEV INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, N2 DOUBLE PRECISION BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE, $ SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR, $ XNORM * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DDOT, DLAMCH EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DLALN2, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Local Arrays .. DOUBLE PRECISION X( 2, 2 ) * .. * .. Executable Statements .. * * Decode and test the input parameters * BOTHV = LSAME( SIDE, 'B' ) RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV * ALLV = LSAME( HOWMNY, 'A' ) OVER = LSAME( HOWMNY, 'B' ) SOMEV = LSAME( HOWMNY, 'S' ) * INFO = 0 IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -1 ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN INFO = -8 ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN INFO = -10 ELSE * * Set M to the number of columns required to store the selected * eigenvectors, standardize the array SELECT if necessary, and * test MM. * IF( SOMEV ) THEN M = 0 PAIR = .FALSE. DO 10 J = 1, N IF( PAIR ) THEN PAIR = .FALSE. SELECT( J ) = .FALSE. ELSE IF( J.LT.N ) THEN IF( T( J+1, J ).EQ.ZERO ) THEN IF( SELECT( J ) ) $ M = M + 1 ELSE PAIR = .TRUE. IF( SELECT( J ) .OR. SELECT( J+1 ) ) THEN SELECT( J ) = .TRUE. M = M + 2 END IF END IF ELSE IF( SELECT( N ) ) $ M = M + 1 END IF END IF 10 CONTINUE ELSE M = N END IF * IF( MM.LT.M ) THEN INFO = -11 END IF END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTREVC', -INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * Set the constants to control overflow. * UNFL = DLAMCH( 'Safe minimum' ) OVFL = ONE / UNFL CALL DLABAD( UNFL, OVFL ) ULP = DLAMCH( 'Precision' ) SMLNUM = UNFL*( N / ULP ) BIGNUM = ( ONE-ULP ) / SMLNUM * * Compute 1-norm of each column of strictly upper triangular * part of T to control overflow in triangular solver. * WORK( 1 ) = ZERO DO 30 J = 2, N WORK( J ) = ZERO DO 20 I = 1, J - 1 WORK( J ) = WORK( J ) + ABS( T( I, J ) ) 20 CONTINUE 30 CONTINUE * * Index IP is used to specify the real or complex eigenvalue: * IP = 0, real eigenvalue, * 1, first of conjugate complex pair: (wr,wi) * -1, second of conjugate complex pair: (wr,wi) * N2 = 2*N * IF( RIGHTV ) THEN * * Compute right eigenvectors. * IP = 0 IS = M DO 140 KI = N, 1, -1 * IF( IP.EQ.1 ) $ GO TO 130 IF( KI.EQ.1 ) $ GO TO 40 IF( T( KI, KI-1 ).EQ.ZERO ) $ GO TO 40 IP = -1 * 40 CONTINUE IF( SOMEV ) THEN IF( IP.EQ.0 ) THEN IF( .NOT.SELECT( KI ) ) $ GO TO 130 ELSE IF( .NOT.SELECT( KI-1 ) ) $ GO TO 130 END IF END IF * * Compute the KI-th eigenvalue (WR,WI). * WR = T( KI, KI ) WI = ZERO IF( IP.NE.0 ) $ WI = SQRT( ABS( T( KI, KI-1 ) ) )* $ SQRT( ABS( T( KI-1, KI ) ) ) SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) * IF( IP.EQ.0 ) THEN * * Real right eigenvector * WORK( KI+N ) = ONE * * Form right-hand side * DO 50 K = 1, KI - 1 WORK( K+N ) = -T( K, KI ) 50 CONTINUE * * Solve the upper quasi-triangular system: * (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK. * JNXT = KI - 1 DO 60 J = KI - 1, 1, -1 IF( J.GT.JNXT ) $ GO TO 60 J1 = J J2 = J JNXT = J - 1 IF( J.GT.1 ) THEN IF( T( J, J-1 ).NE.ZERO ) THEN J1 = J - 1 JNXT = J - 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ ZERO, X, 2, SCALE, XNORM, IERR ) * * Scale X(1,1) to avoid overflow when updating * the right-hand side. * IF( XNORM.GT.ONE ) THEN IF( WORK( J ).GT.BIGNUM / XNORM ) THEN X( 1, 1 ) = X( 1, 1 ) / XNORM SCALE = SCALE / XNORM END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) WORK( J+N ) = X( 1, 1 ) * * Update right-hand side * CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) * ELSE * * 2-by-2 diagonal block * CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, $ T( J-1, J-1 ), LDT, ONE, ONE, $ WORK( J-1+N ), N, WR, ZERO, X, 2, $ SCALE, XNORM, IERR ) * * Scale X(1,1) and X(2,1) to avoid overflow when * updating the right-hand side. * IF( XNORM.GT.ONE ) THEN BETA = MAX( WORK( J-1 ), WORK( J ) ) IF( BETA.GT.BIGNUM / XNORM ) THEN X( 1, 1 ) = X( 1, 1 ) / XNORM X( 2, 1 ) = X( 2, 1 ) / XNORM SCALE = SCALE / XNORM END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) WORK( J-1+N ) = X( 1, 1 ) WORK( J+N ) = X( 2, 1 ) * * Update right-hand side * CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, $ WORK( 1+N ), 1 ) CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) END IF 60 CONTINUE * * Copy the vector x or Q*x to VR and normalize. * IF( .NOT.OVER ) THEN CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS ), 1 ) * II = IDAMAX( KI, VR( 1, IS ), 1 ) REMAX = ONE / ABS( VR( II, IS ) ) CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 ) * DO 70 K = KI + 1, N VR( K, IS ) = ZERO 70 CONTINUE ELSE IF( KI.GT.1 ) $ CALL DGEMV( 'N', N, KI-1, ONE, VR, LDVR, $ WORK( 1+N ), 1, WORK( KI+N ), $ VR( 1, KI ), 1 ) * II = IDAMAX( N, VR( 1, KI ), 1 ) REMAX = ONE / ABS( VR( II, KI ) ) CALL DSCAL( N, REMAX, VR( 1, KI ), 1 ) END IF * ELSE * * Complex right eigenvector. * * Initial solve * [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0. * [ (T(KI,KI-1) T(KI,KI) ) ] * IF( ABS( T( KI-1, KI ) ).GE.ABS( T( KI, KI-1 ) ) ) THEN WORK( KI-1+N ) = ONE WORK( KI+N2 ) = WI / T( KI-1, KI ) ELSE WORK( KI-1+N ) = -WI / T( KI, KI-1 ) WORK( KI+N2 ) = ONE END IF WORK( KI+N ) = ZERO WORK( KI-1+N2 ) = ZERO * * Form right-hand side * DO 80 K = 1, KI - 2 WORK( K+N ) = -WORK( KI-1+N )*T( K, KI-1 ) WORK( K+N2 ) = -WORK( KI+N2 )*T( K, KI ) 80 CONTINUE * * Solve upper quasi-triangular system: * (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2) * JNXT = KI - 2 DO 90 J = KI - 2, 1, -1 IF( J.GT.JNXT ) $ GO TO 90 J1 = J J2 = J JNXT = J - 1 IF( J.GT.1 ) THEN IF( T( J, J-1 ).NE.ZERO ) THEN J1 = J - 1 JNXT = J - 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, WI, $ X, 2, SCALE, XNORM, IERR ) * * Scale X(1,1) and X(1,2) to avoid overflow when * updating the right-hand side. * IF( XNORM.GT.ONE ) THEN IF( WORK( J ).GT.BIGNUM / XNORM ) THEN X( 1, 1 ) = X( 1, 1 ) / XNORM X( 1, 2 ) = X( 1, 2 ) / XNORM SCALE = SCALE / XNORM END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 ) END IF WORK( J+N ) = X( 1, 1 ) WORK( J+N2 ) = X( 1, 2 ) * * Update the right-hand side * CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) CALL DAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1, $ WORK( 1+N2 ), 1 ) * ELSE * * 2-by-2 diagonal block * CALL DLALN2( .FALSE., 2, 2, SMIN, ONE, $ T( J-1, J-1 ), LDT, ONE, ONE, $ WORK( J-1+N ), N, WR, WI, X, 2, SCALE, $ XNORM, IERR ) * * Scale X to avoid overflow when updating * the right-hand side. * IF( XNORM.GT.ONE ) THEN BETA = MAX( WORK( J-1 ), WORK( J ) ) IF( BETA.GT.BIGNUM / XNORM ) THEN REC = ONE / XNORM X( 1, 1 ) = X( 1, 1 )*REC X( 1, 2 ) = X( 1, 2 )*REC X( 2, 1 ) = X( 2, 1 )*REC X( 2, 2 ) = X( 2, 2 )*REC SCALE = SCALE*REC END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 ) END IF WORK( J-1+N ) = X( 1, 1 ) WORK( J+N ) = X( 2, 1 ) WORK( J-1+N2 ) = X( 1, 2 ) WORK( J+N2 ) = X( 2, 2 ) * * Update the right-hand side * CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, $ WORK( 1+N ), 1 ) CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) CALL DAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1, $ WORK( 1+N2 ), 1 ) CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1, $ WORK( 1+N2 ), 1 ) END IF 90 CONTINUE * * Copy the vector x or Q*x to VR and normalize. * IF( .NOT.OVER ) THEN CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS-1 ), 1 ) CALL DCOPY( KI, WORK( 1+N2 ), 1, VR( 1, IS ), 1 ) * EMAX = ZERO DO 100 K = 1, KI EMAX = MAX( EMAX, ABS( VR( K, IS-1 ) )+ $ ABS( VR( K, IS ) ) ) 100 CONTINUE * REMAX = ONE / EMAX CALL DSCAL( KI, REMAX, VR( 1, IS-1 ), 1 ) CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 ) * DO 110 K = KI + 1, N VR( K, IS-1 ) = ZERO VR( K, IS ) = ZERO 110 CONTINUE * ELSE * IF( KI.GT.2 ) THEN CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, $ WORK( 1+N ), 1, WORK( KI-1+N ), $ VR( 1, KI-1 ), 1 ) CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, $ WORK( 1+N2 ), 1, WORK( KI+N2 ), $ VR( 1, KI ), 1 ) ELSE CALL DSCAL( N, WORK( KI-1+N ), VR( 1, KI-1 ), 1 ) CALL DSCAL( N, WORK( KI+N2 ), VR( 1, KI ), 1 ) END IF * EMAX = ZERO DO 120 K = 1, N EMAX = MAX( EMAX, ABS( VR( K, KI-1 ) )+ $ ABS( VR( K, KI ) ) ) 120 CONTINUE REMAX = ONE / EMAX CALL DSCAL( N, REMAX, VR( 1, KI-1 ), 1 ) CALL DSCAL( N, REMAX, VR( 1, KI ), 1 ) END IF END IF * IS = IS - 1 IF( IP.NE.0 ) $ IS = IS - 1 130 CONTINUE IF( IP.EQ.1 ) $ IP = 0 IF( IP.EQ.-1 ) $ IP = 1 140 CONTINUE END IF * IF( LEFTV ) THEN * * Compute left eigenvectors. * IP = 0 IS = 1 DO 260 KI = 1, N * IF( IP.EQ.-1 ) $ GO TO 250 IF( KI.EQ.N ) $ GO TO 150 IF( T( KI+1, KI ).EQ.ZERO ) $ GO TO 150 IP = 1 * 150 CONTINUE IF( SOMEV ) THEN IF( .NOT.SELECT( KI ) ) $ GO TO 250 END IF * * Compute the KI-th eigenvalue (WR,WI). * WR = T( KI, KI ) WI = ZERO IF( IP.NE.0 ) $ WI = SQRT( ABS( T( KI, KI+1 ) ) )* $ SQRT( ABS( T( KI+1, KI ) ) ) SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) * IF( IP.EQ.0 ) THEN * * Real left eigenvector. * WORK( KI+N ) = ONE * * Form right-hand side * DO 160 K = KI + 1, N WORK( K+N ) = -T( KI, K ) 160 CONTINUE * * Solve the quasi-triangular system: * (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK * VMAX = ONE VCRIT = BIGNUM * JNXT = KI + 1 DO 170 J = KI + 1, N IF( J.LT.JNXT ) $ GO TO 170 J1 = J J2 = J JNXT = J + 1 IF( J.LT.N ) THEN IF( T( J+1, J ).NE.ZERO ) THEN J2 = J + 1 JNXT = J + 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * * Scale if necessary to avoid overflow when forming * the right-hand side. * IF( WORK( J ).GT.VCRIT ) THEN REC = ONE / VMAX CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ DDOT( J-KI-1, T( KI+1, J ), 1, $ WORK( KI+1+N ), 1 ) * * Solve (T(J,J)-WR)'*X = WORK * CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ ZERO, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) WORK( J+N ) = X( 1, 1 ) VMAX = MAX( ABS( WORK( J+N ) ), VMAX ) VCRIT = BIGNUM / VMAX * ELSE * * 2-by-2 diagonal block * * Scale if necessary to avoid overflow when forming * the right-hand side. * BETA = MAX( WORK( J ), WORK( J+1 ) ) IF( BETA.GT.VCRIT ) THEN REC = ONE / VMAX CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ DDOT( J-KI-1, T( KI+1, J ), 1, $ WORK( KI+1+N ), 1 ) * WORK( J+1+N ) = WORK( J+1+N ) - $ DDOT( J-KI-1, T( KI+1, J+1 ), 1, $ WORK( KI+1+N ), 1 ) * * Solve * [T(J,J)-WR T(J,J+1) ]'* X = SCALE*( WORK1 ) * [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 ) * CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ ZERO, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) WORK( J+N ) = X( 1, 1 ) WORK( J+1+N ) = X( 2, 1 ) * VMAX = MAX( ABS( WORK( J+N ) ), $ ABS( WORK( J+1+N ) ), VMAX ) VCRIT = BIGNUM / VMAX * END IF 170 CONTINUE * * Copy the vector x or Q*x to VL and normalize. * IF( .NOT.OVER ) THEN CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 ) * II = IDAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 REMAX = ONE / ABS( VL( II, IS ) ) CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) * DO 180 K = 1, KI - 1 VL( K, IS ) = ZERO 180 CONTINUE * ELSE * IF( KI.LT.N ) $ CALL DGEMV( 'N', N, N-KI, ONE, VL( 1, KI+1 ), LDVL, $ WORK( KI+1+N ), 1, WORK( KI+N ), $ VL( 1, KI ), 1 ) * II = IDAMAX( N, VL( 1, KI ), 1 ) REMAX = ONE / ABS( VL( II, KI ) ) CALL DSCAL( N, REMAX, VL( 1, KI ), 1 ) * END IF * ELSE * * Complex left eigenvector. * * Initial solve: * ((T(KI,KI) T(KI,KI+1) )' - (WR - I* WI))*X = 0. * ((T(KI+1,KI) T(KI+1,KI+1)) ) * IF( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN WORK( KI+N ) = WI / T( KI, KI+1 ) WORK( KI+1+N2 ) = ONE ELSE WORK( KI+N ) = ONE WORK( KI+1+N2 ) = -WI / T( KI+1, KI ) END IF WORK( KI+1+N ) = ZERO WORK( KI+N2 ) = ZERO * * Form right-hand side * DO 190 K = KI + 2, N WORK( K+N ) = -WORK( KI+N )*T( KI, K ) WORK( K+N2 ) = -WORK( KI+1+N2 )*T( KI+1, K ) 190 CONTINUE * * Solve complex quasi-triangular system: * ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2 * VMAX = ONE VCRIT = BIGNUM * JNXT = KI + 2 DO 200 J = KI + 2, N IF( J.LT.JNXT ) $ GO TO 200 J1 = J J2 = J JNXT = J + 1 IF( J.LT.N ) THEN IF( T( J+1, J ).NE.ZERO ) THEN J2 = J + 1 JNXT = J + 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * * Scale if necessary to avoid overflow when * forming the right-hand side elements. * IF( WORK( J ).GT.VCRIT ) THEN REC = ONE / VMAX CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N ), 1 ) WORK( J+N2 ) = WORK( J+N2 ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N2 ), 1 ) * * Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2 * CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ -WI, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 ) END IF WORK( J+N ) = X( 1, 1 ) WORK( J+N2 ) = X( 1, 2 ) VMAX = MAX( ABS( WORK( J+N ) ), $ ABS( WORK( J+N2 ) ), VMAX ) VCRIT = BIGNUM / VMAX * ELSE * * 2-by-2 diagonal block * * Scale if necessary to avoid overflow when forming * the right-hand side elements. * BETA = MAX( WORK( J ), WORK( J+1 ) ) IF( BETA.GT.VCRIT ) THEN REC = ONE / VMAX CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N ), 1 ) * WORK( J+N2 ) = WORK( J+N2 ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N2 ), 1 ) * WORK( J+1+N ) = WORK( J+1+N ) - $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, $ WORK( KI+2+N ), 1 ) * WORK( J+1+N2 ) = WORK( J+1+N2 ) - $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, $ WORK( KI+2+N2 ), 1 ) * * Solve 2-by-2 complex linear equation * ([T(j,j) T(j,j+1) ]'-(wr-i*wi)*I)*X = SCALE*B * ([T(j+1,j) T(j+1,j+1)] ) * CALL DLALN2( .TRUE., 2, 2, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ -WI, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 ) END IF WORK( J+N ) = X( 1, 1 ) WORK( J+N2 ) = X( 1, 2 ) WORK( J+1+N ) = X( 2, 1 ) WORK( J+1+N2 ) = X( 2, 2 ) VMAX = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ), $ ABS( X( 2, 1 ) ), ABS( X( 2, 2 ) ), VMAX ) VCRIT = BIGNUM / VMAX * END IF 200 CONTINUE * * Copy the vector x or Q*x to VL and normalize. * 210 CONTINUE IF( .NOT.OVER ) THEN CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 ) CALL DCOPY( N-KI+1, WORK( KI+N2 ), 1, VL( KI, IS+1 ), $ 1 ) * EMAX = ZERO DO 220 K = KI, N EMAX = MAX( EMAX, ABS( VL( K, IS ) )+ $ ABS( VL( K, IS+1 ) ) ) 220 CONTINUE REMAX = ONE / EMAX CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) CALL DSCAL( N-KI+1, REMAX, VL( KI, IS+1 ), 1 ) * DO 230 K = 1, KI - 1 VL( K, IS ) = ZERO VL( K, IS+1 ) = ZERO 230 CONTINUE ELSE IF( KI.LT.N-1 ) THEN CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), $ LDVL, WORK( KI+2+N ), 1, WORK( KI+N ), $ VL( 1, KI ), 1 ) CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), $ LDVL, WORK( KI+2+N2 ), 1, $ WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 ) ELSE CALL DSCAL( N, WORK( KI+N ), VL( 1, KI ), 1 ) CALL DSCAL( N, WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 ) END IF * EMAX = ZERO DO 240 K = 1, N EMAX = MAX( EMAX, ABS( VL( K, KI ) )+ $ ABS( VL( K, KI+1 ) ) ) 240 CONTINUE REMAX = ONE / EMAX CALL DSCAL( N, REMAX, VL( 1, KI ), 1 ) CALL DSCAL( N, REMAX, VL( 1, KI+1 ), 1 ) * END IF * END IF * IS = IS + 1 IF( IP.NE.0 ) $ IS = IS + 1 250 CONTINUE IF( IP.EQ.-1 ) $ IP = 0 IF( IP.EQ.1 ) $ IP = -1 * 260 CONTINUE * END IF * RETURN * * End of DTREVC * END