stgevc.f

          SUBROUTINE STGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL,
         $                   LDVL, VR, LDVR, MM, M, WORK, 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( * )
          REAL               P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
         $                   VR( LDVR, * ), WORK( * )
    *     ..
    *
    *
    *  Purpose
    *  =======
    *
    *  STGEVC computes some or all of the right and/or left eigenvectors of
    *  a pair of real matrices (S,P), where S is a quasi-triangular matrix
    *  and P is upper triangular.  Matrix pairs of this type are produced by
    *  the generalized Schur factorization of a matrix pair (A,B):
    *
    *     A = Q*S*Z**T,  B = Q*P*Z**T
    *
    *  as computed by SGGHRD + SHGEQZ.
    *
    *  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 blocks 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 orthogonal 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.  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 matrices S and P.  N >= 0.
    *
    *  S       (input) REAL array, dimension (LDS,N)
    *          The upper quasi-triangular matrix S from a generalized Schur
    *          factorization, as computed by SHGEQZ.
    *
    *  LDS     (input) INTEGER
    *          The leading dimension of array S.  LDS >= max(1,N).
    *
    *  P       (input) REAL array, dimension (LDP,N)
    *          The upper triangular matrix P from a generalized Schur
    *          factorization, as computed by SHGEQZ.
    *          2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks
    *          of S must be in positive diagonal form.
    *
    *  LDP     (input) INTEGER
    *          The leading dimension of array P.  LDP >= max(1,N).
    *
    *  VL      (input/output) REAL 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 left Schur vectors returned by SHGEQZ).
    *          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.
    *
    *          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 array VL.  LDVL >= 1, and if
    *          SIDE = 'L' or 'B', LDVL >= N.
    *
    *  VR      (input/output) REAL 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 orthogonal matrix Z
    *          of right Schur vectors returned by SHGEQZ).
    *
    *          On exit, if SIDE = 'R' or 'B', VR contains:
    *          if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);
    *          if HOWMNY = 'B' or 'b', the matrix Z*X;
    *          if HOWMNY = 'S' or 's', the right eigenvectors of (S,P)
    *                      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) REAL array, dimension (6*N)
    *
    *  INFO    (output) INTEGER
    *          = 0:  successful exit.
    *          < 0:  if INFO = -i, the i-th argument had an illegal value.
    *          > 0:  the 2-by-2 block (INFO:INFO+1) does not have a complex
    *                eigenvalue.
    *
    *  Further Details
    *  ===============
    *
    *  Allocation of workspace:
    *  ---------- -- ---------
    *
    *     WORK( j ) = 1-norm of j-th column of A, above the diagonal
    *     WORK( N+j ) = 1-norm of j-th column of B, above the diagonal
    *     WORK( 2*N+1:3*N ) = real part of eigenvector
    *     WORK( 3*N+1:4*N ) = imaginary part of eigenvector
    *     WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector
    *     WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector
    *
    *  Rowwise vs. columnwise solution methods:
    *  ------- --  ---------- -------- -------
    *
    *  Finding a generalized eigenvector consists basically of solving the
    *  singular triangular system
    *
    *   (A - w B) x = 0     (for right) or:   (A - w B)**H y = 0  (for left)
    *
    *  Consider finding the i-th right eigenvector (assume all eigenvalues
    *  are real). The equation to be solved is:
    *       n                   i
    *  0 = sum  C(j,k) v(k)  = sum  C(j,k) v(k)     for j = i,. . .,1
    *      k=j                 k=j
    *
    *  where  C = (A - w B)  (The components v(i+1:n) are 0.)
    *
    *  The "rowwise" method is:
    *
    *  (1)  v(i) := 1
    *  for j = i-1,. . .,1:
    *                          i
    *      (2) compute  s = - sum C(j,k) v(k)   and
    *                        k=j+1
    *
    *      (3) v(j) := s / C(j,j)
    *
    *  Step 2 is sometimes called the "dot product" step, since it is an
    *  inner product between the j-th row and the portion of the eigenvector
    *  that has been computed so far.
    *
    *  The "columnwise" method consists basically in doing the sums
    *  for all the rows in parallel.  As each v(j) is computed, the
    *  contribution of v(j) times the j-th column of C is added to the
    *  partial sums.  Since FORTRAN arrays are stored columnwise, this has
    *  the advantage that at each step, the elements of C that are accessed
    *  are adjacent to one another, whereas with the rowwise method, the
    *  elements accessed at a step are spaced LDS (and LDP) words apart.
    *
    *  When finding left eigenvectors, the matrix in question is the
    *  transpose of the one in storage, so the rowwise method then
    *  actually accesses columns of A and B at each step, and so is the
    *  preferred method.
    *
    *  =====================================================================
    *
    *     .. Parameters ..
          REAL               ZERO, ONE, SAFETY
          PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0,
         $                   SAFETY = 1.0E+2 )
    *     ..
    *     .. Local Scalars ..
          LOGICAL            COMPL, COMPR, IL2BY2, ILABAD, ILALL, ILBACK,
         $                   ILBBAD, ILCOMP, ILCPLX, LSA, LSB
          INTEGER            I, IBEG, IEIG, IEND, IHWMNY, IINFO, IM, ISIDE,
         $                   J, JA, JC, JE, JR, JW, NA, NW
          REAL               ACOEF, ACOEFA, ANORM, ASCALE, BCOEFA, BCOEFI,
         $                   BCOEFR, BIG, BIGNUM, BNORM, BSCALE, CIM2A,
         $                   CIM2B, CIMAGA, CIMAGB, CRE2A, CRE2B, CREALA,
         $                   CREALB, DMIN, SAFMIN, SALFAR, SBETA, SCALE,
         $                   SMALL, TEMP, TEMP2, TEMP2I, TEMP2R, ULP, XMAX,
         $                   XSCALE
    *     ..
    *     .. Local Arrays ..
          REAL               BDIAG( 2 ), SUM( 2, 2 ), SUMS( 2, 2 ),
         $                   SUMP( 2, 2 )
    *     ..
    *     .. External Functions ..
          LOGICAL            LSAME
          REAL               SLAMCH
          EXTERNAL           LSAME, SLAMCH
    *     ..
    *     .. External Subroutines ..
          EXTERNAL           SGEMV, SLABAD, SLACPY, SLAG2, SLALN2, XERBLA
    *     ..
    *     .. Intrinsic Functions ..
          INTRINSIC          ABS, MAX, MIN
    *     ..
    *     .. 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
             ILALL = .TRUE.
          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( 'STGEVC', -INFO )
             RETURN
          END IF
    *
    *     Count the number of eigenvectors to be computed
    *
          IF( .NOT.ILALL ) THEN
             IM = 0
             ILCPLX = .FALSE.
             DO 10 J = 1, N
                IF( ILCPLX ) THEN
                   ILCPLX = .FALSE.
                   GO TO 10
                END IF
                IF( J.LT.N ) THEN
                   IF( S( J+1, J ).NE.ZERO )
         $            ILCPLX = .TRUE.
                END IF
                IF( ILCPLX ) THEN
                   IF( SELECT( J ) .OR. SELECT( J+1 ) )
         $            IM = IM + 2
                ELSE
                   IF( SELECT( J ) )
         $            IM = IM + 1
                END IF
       10    CONTINUE
          ELSE
             IM = N
          END IF
    *
    *     Check 2-by-2 diagonal blocks of A, B
    *
          ILABAD = .FALSE.
          ILBBAD = .FALSE.
          DO 20 J = 1, N - 1
             IF( S( J+1, J ).NE.ZERO ) THEN
                IF( P( J, J ).EQ.ZERO .OR. P( J+1, J+1 ).EQ.ZERO .OR.
         $          P( J, J+1 ).NE.ZERO )ILBBAD = .TRUE.
                IF( J.LT.N-1 ) THEN
                   IF( S( J+2, J+1 ).NE.ZERO )
         $            ILABAD = .TRUE.
                END IF
             END IF
       20 CONTINUE
    *
          IF( ILABAD ) THEN
             INFO = -5
          ELSE 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( 'STGEVC', -INFO )
             RETURN
          END IF
    *
    *     Quick return if possible
    *
          M = IM
          IF( N.EQ.0 )
         $   RETURN
    *
    *     Machine Constants
    *
          SAFMIN = SLAMCH( 'Safe minimum' )
          BIG = ONE / SAFMIN
          CALL SLABAD( SAFMIN, BIG )
          ULP = SLAMCH( 'Epsilon' )*SLAMCH( '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 (i.e., excluding all elements belonging to the diagonal
    *     blocks) of A and B to check for possible overflow in the
    *     triangular solver.
    *
          ANORM = ABS( S( 1, 1 ) )
          IF( N.GT.1 )
         $   ANORM = ANORM + ABS( S( 2, 1 ) )
          BNORM = ABS( P( 1, 1 ) )
          WORK( 1 ) = ZERO
          WORK( N+1 ) = ZERO
    *
          DO 50 J = 2, N
             TEMP = ZERO
             TEMP2 = ZERO
             IF( S( J, J-1 ).EQ.ZERO ) THEN
                IEND = J - 1
             ELSE
                IEND = J - 2
             END IF
             DO 30 I = 1, IEND
                TEMP = TEMP + ABS( S( I, J ) )
                TEMP2 = TEMP2 + ABS( P( I, J ) )
       30    CONTINUE
             WORK( J ) = TEMP
             WORK( N+J ) = TEMP2
             DO 40 I = IEND + 1, MIN( J+1, N )
                TEMP = TEMP + ABS( S( I, J ) )
                TEMP2 = TEMP2 + ABS( P( I, J ) )
       40    CONTINUE
             ANORM = MAX( ANORM, TEMP )
             BNORM = MAX( BNORM, TEMP2 )
       50 CONTINUE
    *
          ASCALE = ONE / MAX( ANORM, SAFMIN )
          BSCALE = ONE / MAX( BNORM, SAFMIN )
    *
    *     Left eigenvectors
    *
          IF( COMPL ) THEN
             IEIG = 0
    *
    *        Main loop over eigenvalues
    *
             ILCPLX = .FALSE.
             DO 220 JE = 1, N
    *
    *           Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or
    *           (b) this would be the second of a complex pair.
    *           Check for complex eigenvalue, so as to be sure of which
    *           entry(-ies) of SELECT to look at.
    *
                IF( ILCPLX ) THEN
                   ILCPLX = .FALSE.
                   GO TO 220
                END IF
                NW = 1
                IF( JE.LT.N ) THEN
                   IF( S( JE+1, JE ).NE.ZERO ) THEN
                      ILCPLX = .TRUE.
                      NW = 2
                   END IF
                END IF
                IF( ILALL ) THEN
                   ILCOMP = .TRUE.
                ELSE IF( ILCPLX ) THEN
                   ILCOMP = SELECT( JE ) .OR. SELECT( JE+1 )
                ELSE
                   ILCOMP = SELECT( JE )
                END IF
                IF( .NOT.ILCOMP )
         $         GO TO 220
    *
    *           Decide if (a) singular pencil, (b) real eigenvalue, or
    *           (c) complex eigenvalue.
    *
                IF( .NOT.ILCPLX ) THEN
                   IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND.
         $             ABS( P( JE, JE ) ).LE.SAFMIN ) THEN
    *
    *                 Singular matrix pencil -- return unit eigenvector
    *
                      IEIG = IEIG + 1
                      DO 60 JR = 1, N
                         VL( JR, IEIG ) = ZERO
       60             CONTINUE
                      VL( IEIG, IEIG ) = ONE
                      GO TO 220
                   END IF
                END IF
    *
    *           Clear vector
    *
                DO 70 JR = 1, NW*N
                   WORK( 2*N+JR ) = ZERO
       70       CONTINUE
    *                                                 T
    *           Compute coefficients in  ( a A - b B )  y = 0
    *              a  is  ACOEF
    *              b  is  BCOEFR + i*BCOEFI
    *
                IF( .NOT.ILCPLX ) THEN
    *
    *              Real eigenvalue
    *
                   TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE,
         $                ABS( P( JE, JE ) )*BSCALE, SAFMIN )
                   SALFAR = ( TEMP*S( JE, JE ) )*ASCALE
                   SBETA = ( TEMP*P( JE, JE ) )*BSCALE
                   ACOEF = SBETA*ASCALE
                   BCOEFR = SALFAR*BSCALE
                   BCOEFI = ZERO
    *
    *              Scale to avoid underflow
    *
                   SCALE = ONE
                   LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL
                   LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT.
         $               SMALL
                   IF( LSA )
         $            SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
                   IF( LSB )
         $            SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )*
         $                    MIN( BNORM, BIG ) )
                   IF( LSA .OR. LSB ) THEN
                      SCALE = MIN( SCALE, ONE /
         $                    ( SAFMIN*MAX( ONE, ABS( ACOEF ),
         $                    ABS( BCOEFR ) ) ) )
                      IF( LSA ) THEN
                         ACOEF = ASCALE*( SCALE*SBETA )
                      ELSE
                         ACOEF = SCALE*ACOEF
                      END IF
                      IF( LSB ) THEN
                         BCOEFR = BSCALE*( SCALE*SALFAR )
                      ELSE
                         BCOEFR = SCALE*BCOEFR
                      END IF
                   END IF
                   ACOEFA = ABS( ACOEF )
                   BCOEFA = ABS( BCOEFR )
    *
    *              First component is 1
    *
                   WORK( 2*N+JE ) = ONE
                   XMAX = ONE
                ELSE
    *
    *              Complex eigenvalue
    *
                   CALL SLAG2( S( JE, JE ), LDS, P( JE, JE ), LDP,
         $                     SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2,
         $                     BCOEFI )
                   BCOEFI = -BCOEFI
                   IF( BCOEFI.EQ.ZERO ) THEN
                      INFO = JE
                      RETURN
                   END IF
    *
    *              Scale to avoid over/underflow
    *
                   ACOEFA = ABS( ACOEF )
                   BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
                   SCALE = ONE
                   IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN )
         $            SCALE = ( SAFMIN / ULP ) / ACOEFA
                   IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN )
         $            SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA )
                   IF( SAFMIN*ACOEFA.GT.ASCALE )
         $            SCALE = ASCALE / ( SAFMIN*ACOEFA )
                   IF( SAFMIN*BCOEFA.GT.BSCALE )
         $            SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) )
                   IF( SCALE.NE.ONE ) THEN
                      ACOEF = SCALE*ACOEF
                      ACOEFA = ABS( ACOEF )
                      BCOEFR = SCALE*BCOEFR
                      BCOEFI = SCALE*BCOEFI
                      BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
                   END IF
    *
    *              Compute first two components of eigenvector
    *
                   TEMP = ACOEF*S( JE+1, JE )
                   TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE )
                   TEMP2I = -BCOEFI*P( JE, JE )
                   IF( ABS( TEMP ).GT.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN
                      WORK( 2*N+JE ) = ONE
                      WORK( 3*N+JE ) = ZERO
                      WORK( 2*N+JE+1 ) = -TEMP2R / TEMP
                      WORK( 3*N+JE+1 ) = -TEMP2I / TEMP
                   ELSE
                      WORK( 2*N+JE+1 ) = ONE
                      WORK( 3*N+JE+1 ) = ZERO
                      TEMP = ACOEF*S( JE, JE+1 )
                      WORK( 2*N+JE ) = ( BCOEFR*P( JE+1, JE+1 )-ACOEF*
         $                             S( JE+1, JE+1 ) ) / TEMP
                      WORK( 3*N+JE ) = BCOEFI*P( JE+1, JE+1 ) / TEMP
                   END IF
                   XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ),
         $                ABS( WORK( 2*N+JE+1 ) )+ABS( WORK( 3*N+JE+1 ) ) )
                END IF
    *
                DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
    *
    *                                           T
    *           Triangular solve of  (a A - b B)  y = 0
    *
    *                                   T
    *           (rowwise in  (a A - b B) , or columnwise in (a A - b B) )
    *
                IL2BY2 = .FALSE.
    *
                DO 160 J = JE + NW, N
                   IF( IL2BY2 ) THEN
                      IL2BY2 = .FALSE.
                      GO TO 160
                   END IF
    *
                   NA = 1
                   BDIAG( 1 ) = P( J, J )
                   IF( J.LT.N ) THEN
                      IF( S( J+1, J ).NE.ZERO ) THEN
                         IL2BY2 = .TRUE.
                         BDIAG( 2 ) = P( J+1, J+1 )
                         NA = 2
                      END IF
                   END IF
    *
    *              Check whether scaling is necessary for dot products
    *
                   XSCALE = ONE / MAX( ONE, XMAX )
                   TEMP = MAX( WORK( J ), WORK( N+J ),
         $                ACOEFA*WORK( J )+BCOEFA*WORK( N+J ) )
                   IF( IL2BY2 )
         $            TEMP = MAX( TEMP, WORK( J+1 ), WORK( N+J+1 ),
         $                   ACOEFA*WORK( J+1 )+BCOEFA*WORK( N+J+1 ) )
                   IF( TEMP.GT.BIGNUM*XSCALE ) THEN
                      DO 90 JW = 0, NW - 1
                         DO 80 JR = JE, J - 1
                            WORK( ( JW+2 )*N+JR ) = XSCALE*
         $                     WORK( ( JW+2 )*N+JR )
       80                CONTINUE
       90             CONTINUE
                      XMAX = XMAX*XSCALE
                   END IF
    *
    *              Compute dot products
    *
    *                    j-1
    *              SUM = sum  conjg( a*S(k,j) - b*P(k,j) )*x(k)
    *                    k=je
    *
    *              To reduce the op count, this is done as
    *
    *              _        j-1                  _        j-1
    *              a*conjg( sum  S(k,j)*x(k) ) - b*conjg( sum  P(k,j)*x(k) )
    *                       k=je                          k=je
    *
    *              which may cause underflow problems if A or B are close
    *              to underflow.  (E.g., less than SMALL.)
    *
    *
    *              A series of compiler directives to defeat vectorization
    *              for the next loop
    *
    *$PL$ CMCHAR=' '
    CDIR$          NEXTSCALAR
    C$DIR          SCALAR
    CDIR$          NEXT SCALAR
    CVD$L          NOVECTOR
    CDEC$          NOVECTOR
    CVD$           NOVECTOR
    *VDIR          NOVECTOR
    *VOCL          LOOP,SCALAR
    CIBM           PREFER SCALAR
    *$PL$ CMCHAR='*'
    *
                   DO 120 JW = 1, NW
    *
    *$PL$ CMCHAR=' '
    CDIR$             NEXTSCALAR
    C$DIR             SCALAR
    CDIR$             NEXT SCALAR
    CVD$L             NOVECTOR
    CDEC$             NOVECTOR
    CVD$              NOVECTOR
    *VDIR             NOVECTOR
    *VOCL             LOOP,SCALAR
    CIBM              PREFER SCALAR
    *$PL$ CMCHAR='*'
    *
                      DO 110 JA = 1, NA
                         SUMS( JA, JW ) = ZERO
                         SUMP( JA, JW ) = ZERO
    *
                         DO 100 JR = JE, J - 1
                            SUMS( JA, JW ) = SUMS( JA, JW ) +
         $                                   S( JR, J+JA-1 )*
         $                                   WORK( ( JW+1 )*N+JR )
                            SUMP( JA, JW ) = SUMP( JA, JW ) +
         $                                   P( JR, J+JA-1 )*
         $                                   WORK( ( JW+1 )*N+JR )
      100                CONTINUE
      110             CONTINUE
      120          CONTINUE
    *
    *$PL$ CMCHAR=' '
    CDIR$          NEXTSCALAR
    C$DIR          SCALAR
    CDIR$          NEXT SCALAR
    CVD$L          NOVECTOR
    CDEC$          NOVECTOR
    CVD$           NOVECTOR
    *VDIR          NOVECTOR
    *VOCL          LOOP,SCALAR
    CIBM           PREFER SCALAR
    *$PL$ CMCHAR='*'
    *
                   DO 130 JA = 1, NA
                      IF( ILCPLX ) THEN
                         SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) +
         $                              BCOEFR*SUMP( JA, 1 ) -
         $                              BCOEFI*SUMP( JA, 2 )
                         SUM( JA, 2 ) = -ACOEF*SUMS( JA, 2 ) +
         $                              BCOEFR*SUMP( JA, 2 ) +
         $                              BCOEFI*SUMP( JA, 1 )
                      ELSE
                         SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) +
         $                              BCOEFR*SUMP( JA, 1 )
                      END IF
      130          CONTINUE
    *
    *                                  T
    *              Solve  ( a A - b B )  y = SUM(,)
    *              with scaling and perturbation of the denominator
    *
                   CALL SLALN2( .TRUE., NA, NW, DMIN, ACOEF, S( J, J ), LDS,
         $                      BDIAG( 1 ), BDIAG( 2 ), SUM, 2, BCOEFR,
         $                      BCOEFI, WORK( 2*N+J ), N, SCALE, TEMP,
         $                      IINFO )
                   IF( SCALE.LT.ONE ) THEN
                      DO 150 JW = 0, NW - 1
                         DO 140 JR = JE, J - 1
                            WORK( ( JW+2 )*N+JR ) = SCALE*
         $                     WORK( ( JW+2 )*N+JR )
      140                CONTINUE
      150             CONTINUE
                      XMAX = SCALE*XMAX
                   END IF
                   XMAX = MAX( XMAX, TEMP )
      160       CONTINUE
    *
    *           Copy eigenvector to VL, back transforming if
    *           HOWMNY='B'.
    *
                IEIG = IEIG + 1
                IF( ILBACK ) THEN
                   DO 170 JW = 0, NW - 1
                      CALL SGEMV( 'N', N, N+1-JE, ONE, VL( 1, JE ), LDVL,
         $                        WORK( ( JW+2 )*N+JE ), 1, ZERO,
         $                        WORK( ( JW+4 )*N+1 ), 1 )
      170          CONTINUE
                   CALL SLACPY( ' ', N, NW, WORK( 4*N+1 ), N, VL( 1, JE ),
         $                      LDVL )
                   IBEG = 1
                ELSE
                   CALL SLACPY( ' ', N, NW, WORK( 2*N+1 ), N, VL( 1, IEIG ),
         $                      LDVL )
                   IBEG = JE
                END IF
    *
    *           Scale eigenvector
    *
                XMAX = ZERO
                IF( ILCPLX ) THEN
                   DO 180 J = IBEG, N
                      XMAX = MAX( XMAX, ABS( VL( J, IEIG ) )+
         $                   ABS( VL( J, IEIG+1 ) ) )
      180          CONTINUE
                ELSE
                   DO 190 J = IBEG, N
                      XMAX = MAX( XMAX, ABS( VL( J, IEIG ) ) )
      190          CONTINUE
                END IF
    *
                IF( XMAX.GT.SAFMIN ) THEN
                   XSCALE = ONE / XMAX
    *
                   DO 210 JW = 0, NW - 1
                      DO 200 JR = IBEG, N
                         VL( JR, IEIG+JW ) = XSCALE*VL( JR, IEIG+JW )
      200             CONTINUE
      210          CONTINUE
                END IF
                IEIG = IEIG + NW - 1
    *
      220    CONTINUE
          END IF
    *
    *     Right eigenvectors
    *
          IF( COMPR ) THEN
             IEIG = IM + 1
    *
    *        Main loop over eigenvalues
    *
             ILCPLX = .FALSE.
             DO 500 JE = N, 1, -1
    *
    *           Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or
    *           (b) this would be the second of a complex pair.
    *           Check for complex eigenvalue, so as to be sure of which
    *           entry(-ies) of SELECT to look at -- if complex, SELECT(JE)
    *           or SELECT(JE-1).
    *           If this is a complex pair, the 2-by-2 diagonal block
    *           corresponding to the eigenvalue is in rows/columns JE-1:JE
    *
                IF( ILCPLX ) THEN
                   ILCPLX = .FALSE.
                   GO TO 500
                END IF
                NW = 1
                IF( JE.GT.1 ) THEN
                   IF( S( JE, JE-1 ).NE.ZERO ) THEN
                      ILCPLX = .TRUE.
                      NW = 2
                   END IF
                END IF
                IF( ILALL ) THEN
                   ILCOMP = .TRUE.
                ELSE IF( ILCPLX ) THEN
                   ILCOMP = SELECT( JE ) .OR. SELECT( JE-1 )
                ELSE
                   ILCOMP = SELECT( JE )
                END IF
                IF( .NOT.ILCOMP )
         $         GO TO 500
    *
    *           Decide if (a) singular pencil, (b) real eigenvalue, or
    *           (c) complex eigenvalue.
    *
                IF( .NOT.ILCPLX ) THEN
                   IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND.
         $             ABS( P( JE, JE ) ).LE.SAFMIN ) THEN
    *
    *                 Singular matrix pencil -- unit eigenvector
    *
                      IEIG = IEIG - 1
                      DO 230 JR = 1, N
                         VR( JR, IEIG ) = ZERO
      230             CONTINUE
                      VR( IEIG, IEIG ) = ONE
                      GO TO 500
                   END IF
                END IF
    *
    *           Clear vector
    *
                DO 250 JW = 0, NW - 1
                   DO 240 JR = 1, N
                      WORK( ( JW+2 )*N+JR ) = ZERO
      240          CONTINUE
      250       CONTINUE
    *
    *           Compute coefficients in  ( a A - b B ) x = 0
    *              a  is  ACOEF
    *              b  is  BCOEFR + i*BCOEFI
    *
                IF( .NOT.ILCPLX ) THEN
    *
    *              Real eigenvalue
    *
                   TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE,
         $                ABS( P( JE, JE ) )*BSCALE, SAFMIN )
                   SALFAR = ( TEMP*S( JE, JE ) )*ASCALE
                   SBETA = ( TEMP*P( JE, JE ) )*BSCALE
                   ACOEF = SBETA*ASCALE
                   BCOEFR = SALFAR*BSCALE
                   BCOEFI = ZERO
    *
    *              Scale to avoid underflow
    *
                   SCALE = ONE
                   LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL
                   LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT.
         $               SMALL
                   IF( LSA )
         $            SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
                   IF( LSB )
         $            SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )*
         $                    MIN( BNORM, BIG ) )
                   IF( LSA .OR. LSB ) THEN
                      SCALE = MIN( SCALE, ONE /
         $                    ( SAFMIN*MAX( ONE, ABS( ACOEF ),
         $                    ABS( BCOEFR ) ) ) )
                      IF( LSA ) THEN
                         ACOEF = ASCALE*( SCALE*SBETA )
                      ELSE
                         ACOEF = SCALE*ACOEF
                      END IF
                      IF( LSB ) THEN
                         BCOEFR = BSCALE*( SCALE*SALFAR )
                      ELSE
                         BCOEFR = SCALE*BCOEFR
                      END IF
                   END IF
                   ACOEFA = ABS( ACOEF )
                   BCOEFA = ABS( BCOEFR )
    *
    *              First component is 1
    *
                   WORK( 2*N+JE ) = ONE
                   XMAX = ONE
    *
    *              Compute contribution from column JE of A and B to sum
    *              (See "Further Details", above.)
    *
                   DO 260 JR = 1, JE - 1
                      WORK( 2*N+JR ) = BCOEFR*P( JR, JE ) -
         $                             ACOEF*S( JR, JE )
      260          CONTINUE
                ELSE
    *
    *              Complex eigenvalue
    *
                   CALL SLAG2( S( JE-1, JE-1 ), LDS, P( JE-1, JE-1 ), LDP,
         $                     SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2,
         $                     BCOEFI )
                   IF( BCOEFI.EQ.ZERO ) THEN
                      INFO = JE - 1
                      RETURN
                   END IF
    *
    *              Scale to avoid over/underflow
    *
                   ACOEFA = ABS( ACOEF )
                   BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
                   SCALE = ONE
                   IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN )
         $            SCALE = ( SAFMIN / ULP ) / ACOEFA
                   IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN )
         $            SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA )
                   IF( SAFMIN*ACOEFA.GT.ASCALE )
         $            SCALE = ASCALE / ( SAFMIN*ACOEFA )
                   IF( SAFMIN*BCOEFA.GT.BSCALE )
         $            SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) )
                   IF( SCALE.NE.ONE ) THEN
                      ACOEF = SCALE*ACOEF
                      ACOEFA = ABS( ACOEF )
                      BCOEFR = SCALE*BCOEFR
                      BCOEFI = SCALE*BCOEFI
                      BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
                   END IF
    *
    *              Compute first two components of eigenvector
    *              and contribution to sums
    *
                   TEMP = ACOEF*S( JE, JE-1 )
                   TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE )
                   TEMP2I = -BCOEFI*P( JE, JE )
                   IF( ABS( TEMP ).GE.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN
                      WORK( 2*N+JE ) = ONE
                      WORK( 3*N+JE ) = ZERO
                      WORK( 2*N+JE-1 ) = -TEMP2R / TEMP
                      WORK( 3*N+JE-1 ) = -TEMP2I / TEMP
                   ELSE
                      WORK( 2*N+JE-1 ) = ONE
                      WORK( 3*N+JE-1 ) = ZERO
                      TEMP = ACOEF*S( JE-1, JE )
                      WORK( 2*N+JE ) = ( BCOEFR*P( JE-1, JE-1 )-ACOEF*
         $                             S( JE-1, JE-1 ) ) / TEMP
                      WORK( 3*N+JE ) = BCOEFI*P( JE-1, JE-1 ) / TEMP
                   END IF
    *
                   XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ),
         $                ABS( WORK( 2*N+JE-1 ) )+ABS( WORK( 3*N+JE-1 ) ) )
    *
    *              Compute contribution from columns JE and JE-1
    *              of A and B to the sums.
    *
                   CREALA = ACOEF*WORK( 2*N+JE-1 )
                   CIMAGA = ACOEF*WORK( 3*N+JE-1 )
                   CREALB = BCOEFR*WORK( 2*N+JE-1 ) -
         $                  BCOEFI*WORK( 3*N+JE-1 )
                   CIMAGB = BCOEFI*WORK( 2*N+JE-1 ) +
         $                  BCOEFR*WORK( 3*N+JE-1 )
                   CRE2A = ACOEF*WORK( 2*N+JE )
                   CIM2A = ACOEF*WORK( 3*N+JE )
                   CRE2B = BCOEFR*WORK( 2*N+JE ) - BCOEFI*WORK( 3*N+JE )
                   CIM2B = BCOEFI*WORK( 2*N+JE ) + BCOEFR*WORK( 3*N+JE )
                   DO 270 JR = 1, JE - 2
                      WORK( 2*N+JR ) = -CREALA*S( JR, JE-1 ) +
         $                             CREALB*P( JR, JE-1 ) -
         $                             CRE2A*S( JR, JE ) + CRE2B*P( JR, JE )
                      WORK( 3*N+JR ) = -CIMAGA*S( JR, JE-1 ) +
         $                             CIMAGB*P( JR, JE-1 ) -
         $                             CIM2A*S( JR, JE ) + CIM2B*P( JR, JE )
      270          CONTINUE
                END IF
    *
                DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
    *
    *           Columnwise triangular solve of  (a A - b B)  x = 0
    *
                IL2BY2 = .FALSE.
                DO 370 J = JE - NW, 1, -1
    *
    *              If a 2-by-2 block, is in position j-1:j, wait until
    *              next iteration to process it (when it will be j:j+1)
    *
                   IF( .NOT.IL2BY2 .AND. J.GT.1 ) THEN
                      IF( S( J, J-1 ).NE.ZERO ) THEN
                         IL2BY2 = .TRUE.
                         GO TO 370
                      END IF
                   END IF
                   BDIAG( 1 ) = P( J, J )
                   IF( IL2BY2 ) THEN
                      NA = 2
                      BDIAG( 2 ) = P( J+1, J+1 )
                   ELSE
                      NA = 1
                   END IF
    *
    *              Compute x(j) (and x(j+1), if 2-by-2 block)
    *
                   CALL SLALN2( .FALSE., NA, NW, DMIN, ACOEF, S( J, J ),
         $                      LDS, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ),
         $                      N, BCOEFR, BCOEFI, SUM, 2, SCALE, TEMP,
         $                      IINFO )
                   IF( SCALE.LT.ONE ) THEN
    *
                      DO 290 JW = 0, NW - 1
                         DO 280 JR = 1, JE
                            WORK( ( JW+2 )*N+JR ) = SCALE*
         $                     WORK( ( JW+2 )*N+JR )
      280                CONTINUE
      290             CONTINUE
                   END IF
                   XMAX = MAX( SCALE*XMAX, TEMP )
    *
                   DO 310 JW = 1, NW
                      DO 300 JA = 1, NA
                         WORK( ( JW+1 )*N+J+JA-1 ) = SUM( JA, JW )
      300             CONTINUE
      310          CONTINUE
    *
    *              w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling
    *
                   IF( J.GT.1 ) THEN
    *
    *                 Check whether scaling is necessary for sum.
    *
                      XSCALE = ONE / MAX( ONE, XMAX )
                      TEMP = ACOEFA*WORK( J ) + BCOEFA*WORK( N+J )
                      IF( IL2BY2 )
         $               TEMP = MAX( TEMP, ACOEFA*WORK( J+1 )+BCOEFA*
         $                      WORK( N+J+1 ) )
                      TEMP = MAX( TEMP, ACOEFA, BCOEFA )
                      IF( TEMP.GT.BIGNUM*XSCALE ) THEN
    *
                         DO 330 JW = 0, NW - 1
                            DO 320 JR = 1, JE
                               WORK( ( JW+2 )*N+JR ) = XSCALE*
         $                        WORK( ( JW+2 )*N+JR )
      320                   CONTINUE
      330                CONTINUE
                         XMAX = XMAX*XSCALE
                      END IF
    *
    *                 Compute the contributions of the off-diagonals of
    *                 column j (and j+1, if 2-by-2 block) of A and B to the
    *                 sums.
    *
    *
                      DO 360 JA = 1, NA
                         IF( ILCPLX ) THEN
                            CREALA = ACOEF*WORK( 2*N+J+JA-1 )
                            CIMAGA = ACOEF*WORK( 3*N+J+JA-1 )
                            CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) -
         $                           BCOEFI*WORK( 3*N+J+JA-1 )
                            CIMAGB = BCOEFI*WORK( 2*N+J+JA-1 ) +
         $                           BCOEFR*WORK( 3*N+J+JA-1 )
                            DO 340 JR = 1, J - 1
                               WORK( 2*N+JR ) = WORK( 2*N+JR ) -
         $                                      CREALA*S( JR, J+JA-1 ) +
         $                                      CREALB*P( JR, J+JA-1 )
                               WORK( 3*N+JR ) = WORK( 3*N+JR ) -
         $                                      CIMAGA*S( JR, J+JA-1 ) +
         $                                      CIMAGB*P( JR, J+JA-1 )
      340                   CONTINUE
                         ELSE
                            CREALA = ACOEF*WORK( 2*N+J+JA-1 )
                            CREALB = BCOEFR*WORK( 2*N+J+JA-1 )
                            DO 350 JR = 1, J - 1
                               WORK( 2*N+JR ) = WORK( 2*N+JR ) -
         $                                      CREALA*S( JR, J+JA-1 ) +
         $                                      CREALB*P( JR, J+JA-1 )
      350                   CONTINUE
                         END IF
      360             CONTINUE
                   END IF
    *
                   IL2BY2 = .FALSE.
      370       CONTINUE
    *
    *           Copy eigenvector to VR, back transforming if
    *           HOWMNY='B'.
    *
                IEIG = IEIG - NW
                IF( ILBACK ) THEN
    *
                   DO 410 JW = 0, NW - 1
                      DO 380 JR = 1, N
                         WORK( ( JW+4 )*N+JR ) = WORK( ( JW+2 )*N+1 )*
         $                                       VR( JR, 1 )
      380             CONTINUE
    *
    *                 A series of compiler directives to defeat
    *                 vectorization for the next loop
    *
    *
                      DO 400 JC = 2, JE
                         DO 390 JR = 1, N
                            WORK( ( JW+4 )*N+JR ) = WORK( ( JW+4 )*N+JR ) +
         $                     WORK( ( JW+2 )*N+JC )*VR( JR, JC )
      390                CONTINUE
      400             CONTINUE
      410          CONTINUE
    *
                   DO 430 JW = 0, NW - 1
                      DO 420 JR = 1, N
                         VR( JR, IEIG+JW ) = WORK( ( JW+4 )*N+JR )
      420             CONTINUE
      430          CONTINUE
    *
                   IEND = N
                ELSE
                   DO 450 JW = 0, NW - 1
                      DO 440 JR = 1, N
                         VR( JR, IEIG+JW ) = WORK( ( JW+2 )*N+JR )
      440             CONTINUE
      450          CONTINUE
    *
                   IEND = JE
                END IF
    *
    *           Scale eigenvector
    *
                XMAX = ZERO
                IF( ILCPLX ) THEN
                   DO 460 J = 1, IEND
                      XMAX = MAX( XMAX, ABS( VR( J, IEIG ) )+
         $                   ABS( VR( J, IEIG+1 ) ) )
      460          CONTINUE
                ELSE
                   DO 470 J = 1, IEND
                      XMAX = MAX( XMAX, ABS( VR( J, IEIG ) ) )
      470          CONTINUE
                END IF
    *
                IF( XMAX.GT.SAFMIN ) THEN
                   XSCALE = ONE / XMAX
                   DO 490 JW = 0, NW - 1
                      DO 480 JR = 1, IEND
                         VR( JR, IEIG+JW ) = XSCALE*VR( JR, IEIG+JW )
      480             CONTINUE
      490          CONTINUE
                END IF
      500    CONTINUE
          END IF
    *
          RETURN
    *
    *     End of STGEVC
    *
          END