ztgevc.f

          SUBROUTINE ZTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL,
         $                   LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )
    *
    *  -- LAPACK routine (version 3.1) --
    *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
    *     November 2006
    *
    *     .. Scalar Arguments ..
          CHARACTER          HOWMNY, SIDE
          INTEGER            INFO, LDP, LDS, LDVL, LDVR, M, MM, N
    *     ..
    *     .. Array Arguments ..
          LOGICAL            SELECT( * )
          DOUBLE PRECISION   RWORK( * )
          COMPLEX*16         P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
         $                   VR( LDVR, * ), WORK( * )
    *     ..
    *
    *
    *  Purpose
    *  =======
    *
    *  ZTGEVC 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 ZGGHRD + ZHGEQZ.
    *
    *  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 tranpose 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).
    *
    *  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,
    *                 specified by the logical array SELECT.
    *
    *  SELECT  (input) 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'.
    *
    *  N       (input) INTEGER
    *          The order of the matrices S and P.  N >= 0.
    *
    *  S       (input) COMPLEX*16 array, dimension (LDS,N)
    *          The upper triangular matrix S from a generalized Schur
    *          factorization, as computed by ZHGEQZ.
    *
    *  LDS     (input) INTEGER
    *          The leading dimension of array S.  LDS >= max(1,N).
    *
    *  P       (input) COMPLEX*16 array, dimension (LDP,N)
    *          The upper triangular matrix P from a generalized Schur
    *          factorization, as computed by ZHGEQZ.  P must have real
    *          diagonal elements.
    *
    *  LDP     (input) INTEGER
    *          The leading dimension of array P.  LDP >= max(1,N).
    *
    *  VL      (input/output) COMPLEX*16 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 ZHGEQZ).
    *          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'.
    *
    *  LDVL    (input) INTEGER
    *          The leading dimension of array VL.  LDVL >= 1, and if
    *          SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N.
    *
    *  VR      (input/output) COMPLEX*16 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 unitary matrix Z
    *          of right Schur vectors returned by ZHGEQZ).
    *          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'.
    *
    *  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 eigenvector occupies one column.
    *
    *  WORK    (workspace) COMPLEX*16 array, dimension (2*N)
    *
    *  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)
    *
    *  INFO    (output) INTEGER
    *          = 0:  successful exit.
    *          < 0:  if INFO = -i, the i-th argument had an illegal value.
    *
    *  =====================================================================
    *
    *     .. Parameters ..
          DOUBLE PRECISION   ZERO, ONE
          PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
          COMPLEX*16         CZERO, CONE
          PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
         $                   CONE = ( 1.0D+0, 0.0D+0 ) )
    *     ..
    *     .. Local Scalars ..
          LOGICAL            COMPL, COMPR, ILALL, ILBACK, ILBBAD, ILCOMP,
         $                   LSA, LSB
          INTEGER            I, IBEG, IEIG, IEND, IHWMNY, IM, ISIDE, ISRC,
         $                   J, JE, JR
          DOUBLE PRECISION   ACOEFA, ACOEFF, ANORM, ASCALE, BCOEFA, BIG,
         $                   BIGNUM, BNORM, BSCALE, DMIN, SAFMIN, SBETA,
         $                   SCALE, SMALL, TEMP, ULP, XMAX
          COMPLEX*16         BCOEFF, CA, CB, D, SALPHA, SUM, SUMA, SUMB, X
    *     ..
    *     .. External Functions ..
          LOGICAL            LSAME
          DOUBLE PRECISION   DLAMCH
          COMPLEX*16         ZLADIV
          EXTERNAL           LSAME, DLAMCH, ZLADIV
    *     ..
    *     .. External Subroutines ..
          EXTERNAL           DLABAD, XERBLA, ZGEMV
    *     ..
    *     .. Intrinsic Functions ..
          INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN
    *     ..
    *     .. Statement Functions ..
          DOUBLE PRECISION   ABS1
    *     ..
    *     .. Statement Function definitions ..
          ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( 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( 'ZTGEVC', -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( DIMAG( 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( 'ZTGEVC', -INFO )
             RETURN
          END IF
    *
    *     Quick return if possible
    *
          M = IM
          IF( N.EQ.0 )
         $   RETURN
    *
    *     Machine Constants
    *
          SAFMIN = DLAMCH( 'Safe minimum' )
          BIG = ONE / SAFMIN
          CALL DLABAD( SAFMIN, BIG )
          ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
          SMALL = SAFMIN*N / ULP
          BIG = ONE / SMALL
          BIGNUM = ONE / ( SAFMIN*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 = ABS1( S( 1, 1 ) )
          BNORM = ABS1( 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 ) + ABS1( S( I, J ) )
                RWORK( N+J ) = RWORK( N+J ) + ABS1( P( I, J ) )
       30    CONTINUE
             ANORM = MAX( ANORM, RWORK( J )+ABS1( S( J, J ) ) )
             BNORM = MAX( BNORM, RWORK( N+J )+ABS1( 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( ABS1( S( JE, JE ) ).LE.SAFMIN .AND.
         $             ABS( DBLE( 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( ABS1( S( JE, JE ) )*ASCALE,
         $                ABS( DBLE( P( JE, JE ) ) )*BSCALE, SAFMIN )
                   SALPHA = ( TEMP*S( JE, JE ) )*ASCALE
                   SBETA = ( TEMP*DBLE( 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 = ABS1( SALPHA ).GE.SAFMIN .AND. ABS1( BCOEFF ).LT.
         $               SMALL
    *
                   SCALE = ONE
                   IF( LSA )
         $            SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
                   IF( LSB )
         $            SCALE = MAX( SCALE, ( SMALL / ABS1( SALPHA ) )*
         $                    MIN( BNORM, BIG ) )
                   IF( LSA .OR. LSB ) THEN
                      SCALE = MIN( SCALE, ONE /
         $                    ( SAFMIN*MAX( ONE, ABS( ACOEFF ),
         $                    ABS1( 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 = ABS1( 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 + DCONJG( S( JR, J ) )*WORK( JR )
                         SUMB = SUMB + DCONJG( P( JR, J ) )*WORK( JR )
       80             CONTINUE
                      SUM = ACOEFF*SUMA - DCONJG( BCOEFF )*SUMB
    *
    *                 Form x(j) = - SUM / conjg( a*S(j,j) - b*P(j,j) )
    *
    *                 with scaling and perturbation of the denominator
    *
                      D = DCONJG( ACOEFF*S( J, J )-BCOEFF*P( J, J ) )
                      IF( ABS1( D ).LE.DMIN )
         $               D = DCMPLX( DMIN )
    *
                      IF( ABS1( D ).LT.ONE ) THEN
                         IF( ABS1( SUM ).GE.BIGNUM*ABS1( D ) ) THEN
                            TEMP = ONE / ABS1( 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 ) = ZLADIV( -SUM, D )
                      XMAX = MAX( XMAX, ABS1( WORK( J ) ) )
      100          CONTINUE
    *
    *              Back transform eigenvector if HOWMNY='B'.
    *
                   IF( ILBACK ) THEN
                      CALL ZGEMV( '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, ABS1( 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( ABS1( S( JE, JE ) ).LE.SAFMIN .AND.
         $             ABS( DBLE( 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( ABS1( S( JE, JE ) )*ASCALE,
         $                ABS( DBLE( P( JE, JE ) ) )*BSCALE, SAFMIN )
                   SALPHA = ( TEMP*S( JE, JE ) )*ASCALE
                   SBETA = ( TEMP*DBLE( 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 = ABS1( SALPHA ).GE.SAFMIN .AND. ABS1( BCOEFF ).LT.
         $               SMALL
    *
                   SCALE = ONE
                   IF( LSA )
         $            SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
                   IF( LSB )
         $            SCALE = MAX( SCALE, ( SMALL / ABS1( SALPHA ) )*
         $                    MIN( BNORM, BIG ) )
                   IF( LSA .OR. LSB ) THEN
                      SCALE = MIN( SCALE, ONE /
         $                    ( SAFMIN*MAX( ONE, ABS( ACOEFF ),
         $                    ABS1( 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 = ABS1( 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( ABS1( D ).LE.DMIN )
         $               D = DCMPLX( DMIN )
    *
                      IF( ABS1( D ).LT.ONE ) THEN
                         IF( ABS1( WORK( J ) ).GE.BIGNUM*ABS1( D ) ) THEN
                            TEMP = ONE / ABS1( WORK( J ) )
                            DO 180 JR = 1, JE
                               WORK( JR ) = TEMP*WORK( JR )
      180                   CONTINUE
                         END IF
                      END IF
    *
                      WORK( J ) = ZLADIV( -WORK( J ), D )
    *
                      IF( J.GT.1 ) THEN
    *
    *                    w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling
    *
                         IF( ABS1( WORK( J ) ).GT.ONE ) THEN
                            TEMP = ONE / ABS1( 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 ZGEMV( '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, ABS1( 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 ZTGEVC
    *
          END