      SUBROUTINE SB01DD( N, M, INDCON, A, LDA, B, LDB, NBLK, WR, WI,
     $                   Z, LDZ, Y, COUNT, G, LDG, TOL, IWORK, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute for a controllable matrix pair ( A, B ) a matrix G
C     such that the matrix A - B*G has the desired eigenstructure,
C     specified by desired eigenvalues and free eigenvector elements.
C
C     The pair ( A, B ) should be given in orthogonal canonical form
C     as returned by the SLICOT Library routine AB01ND.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A and the number of rows of the
C             matrix B.  N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of the matrix B.  M >= 0.
C
C     INDCON  (input) INTEGER
C             The controllability index of the pair ( A, B ).
C             0 <= INDCON <= N.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the N-by-N matrix A in orthogonal canonical form,
C             as returned by SLICOT Library routine AB01ND.
C             On exit, the leading N-by-N part of this array contains
C             the real Schur form of the matrix A - B*G.
C             The elements below the real Schur form of A are set to
C             zero.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the N-by-M matrix B in orthogonal canonical form,
C             as returned by SLICOT Library routine AB01ND.
C             On exit, the leading N-by-M part of this array contains
C             the transformed matrix B.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= max(1,N).
C
C     NBLK    (input) INTEGER array, dimension (N)
C             The leading INDCON elements of this array must contain the
C             orders of the diagonal blocks in the orthogonal canonical
C             form of A, as returned by SLICOT Library routine AB01ND.
C             The values of these elements must satisfy the following
C             conditions:
C             NBLK(1) >= NBLK(2) >= ... >= NBLK(INDCON),
C             NBLK(1) + NBLK(2) + ... + NBLK(INDCON) = N.
C
C     WR      (input) DOUBLE PRECISION array, dimension (N)
C     WI      (input) DOUBLE PRECISION array, dimension (N)
C             These arrays must contain the real and imaginary parts,
C             respectively, of the desired poles of the closed-loop
C             system, i.e., the eigenvalues of A - B*G. The poles can be
C             unordered, except that complex conjugate pairs of poles
C             must appear consecutively.
C             The elements of WI for complex eigenvalues are modified
C             internally, but restored on exit.
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
C             On entry, the leading N-by-N part of this array must
C             contain the orthogonal matrix Z generated by SLICOT
C             Library routine AB01ND in the reduction of ( A, B ) to
C             orthogonal canonical form.
C             On exit, the leading N-by-N part of this array contains
C             the orthogonal transformation matrix which reduces A - B*G
C             to real Schur form.
C
C     LDZ     INTEGER
C             The leading dimension of the array Z.  LDZ >= max(1,N).
C
C     Y       (input) DOUBLE PRECISION array, dimension (M*N)
C             Y contains elements which are used as free parameters
C             in the eigenstructure design. The values of these
C             parameters are often set by an external optimization
C             procedure.
C
C     COUNT   (output) INTEGER
C             The actual number of elements in Y used as free
C             eigenvector and feedback matrix elements in the
C             eigenstructure design.
C
C     G       (output) DOUBLE PRECISION array, dimension (LDG,N)
C             The leading M-by-N part of this array contains the
C             feedback matrix which assigns the desired eigenstructure
C             of A - B*G.
C
C     LDG     INTEGER
C             The leading dimension of the array G.  LDG >= max(1,M).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used in rank determination when
C             transforming (A, B). If the user sets TOL > 0, then
C             the given value of TOL is used as a lower bound for the
C             reciprocal condition number (see the description of the
C             argument RCOND in the SLICOT routine MB03OD);  a
C             (sub)matrix whose estimated condition number is less than
C             1/TOL is considered to be of full rank.  If the user sets
C             TOL <= 0, then an implicitly computed, default tolerance,
C             defined by  TOLDEF = N*N*EPS,  is used instead, where
C             EPS  is the machine precision (see LAPACK Library routine
C             DLAMCH).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (M)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(M*N,M*M+2*N+4*M+1).
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if the pair ( A, B ) is not controllable or the free
C                   parameters are not set appropriately.
C
C     METHOD
C
C     The routine implements the method proposed in [1], [2].
C
C     REFERENCES
C
C     [1] Petkov, P.Hr., Konstantinov, M.M., Gu, D.W. and
C         Postlethwaite, I.
C         Optimal pole assignment design of linear multi-input systems.
C         Report 96-11, Department of Engineering, Leicester University,
C         1996.
C
C     [2] Petkov, P.Hr., Christov, N.D. and Konstantinov, M.M.
C         A computational algorithm for pole assignment of linear multi
C         input systems. IEEE Trans. Automatic Control, vol. AC-31,
C         pp. 1044-1047, 1986.
C
C     NUMERICAL ASPECTS
C
C     The method implemented is backward stable.
C
C     FURTHER COMMENTS
C
C     The eigenvalues of the real Schur form matrix As, returned in the
C     array A, are very close to the desired eigenvalues WR+WI*i.
C     However, the eigenvalues of the closed-loop matrix A - B*G,
C     computed by the QR algorithm using the matrices A and B, given on
C     entry, may be far from WR+WI*i, although the relative error
C        norm( Z'*(A - B*G)*Z - As )/norm( As )
C     is close to machine accuracy. This may happen when the eigenvalue
C     problem for the matrix A - B*G is ill-conditioned.
C
C     CONTRIBUTORS
C
C     P.Hr. Petkov, Technical University of Sofia, Oct. 1998.
C     V. Sima, Katholieke Universiteit Leuven, Jan. 1999, SLICOT Library
C     version.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005,
C     Apr. 2017.
C
C     KEYWORDS
C
C     Closed loop spectrum, closed loop systems, eigenvalue assignment,
C     orthogonal canonical form, orthogonal transformation, pole
C     placement, Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
C
C     .. Scalar Arguments ..
      INTEGER            COUNT, INDCON, INFO, LDA, LDB, LDG, LDWORK,
     $                   LDZ, M, N
      DOUBLE PRECISION   TOL
C     ..
C     .. Array Arguments ..
      INTEGER            IWORK( * ), NBLK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), DWORK( * ),
     $                   G( LDG, * ), WI( * ), WR( * ), Y( * ),
     $                   Z( LDZ, * )
C     ..
C     .. Local Scalars ..
      LOGICAL            COMPLX
      INTEGER            I, IA, INDCN1, INDCN2, INDCRT, IP, IRMX, IWRK,
     $                   K, KK, KMR, L, LP1, M1, MAXWRK, MI, MP1, MR,
     $                   MR1, NBLKCR, NC, NI, NJ, NP1, NR, NR1, RANK
      DOUBLE PRECISION   P, Q, R, S, SVLMXA, SVLMXB, TOLDEF
C     ..
C     .. Local Arrays ..
      DOUBLE PRECISION   SVAL( 3 )
C     ..
C     .. External Functions ..
      DOUBLE PRECISION   DASUM, DLAMCH, DLANGE, DLAPY2
      EXTERNAL           DASUM, DLAMCH, DLANGE, DLAPY2
C     ..
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEMM, DGEMV, DLACPY, DLARF,
     $                   DLARFG, DLARTG, DLASET, DROT, DSCAL, MB02QD,
     $                   XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, MAX, MIN
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments.
C
      INFO = 0
      NR   = 0
      IWRK = MAX( M*N, M*M + 2*N + 4*M + 1 )
      DO 10 I = 1, MIN( INDCON, N )
         NR = NR + NBLK( I )
         IF( I.GT.1 ) THEN
            IF( NBLK( I-1 ).LT.NBLK( I ) )
     $         INFO = -8
         END IF
   10 CONTINUE
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( INDCON.LT.0 .OR. INDCON.GT.N ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( NR.NE.N ) THEN
         INFO = -8
      ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -12
      ELSE IF( LDG.LT.MAX( 1, M ) ) THEN
         INFO = -16
      ELSE IF( LDWORK.LT.IWRK ) THEN
         INFO = -20
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SB01DD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MIN( M, N, INDCON ).EQ.0 ) THEN
         COUNT = 0
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
      MAXWRK = IWRK
      TOLDEF = TOL
      IF ( TOLDEF.LE.ZERO ) THEN
C
C        Use the default tolerance, based on machine precision.
C
         TOLDEF = DBLE( N*N )*DLAMCH( 'EPSILON' )
      END IF
C
      IRMX = 2*N + 1
      IWRK = IRMX + M*M
      M1   = NBLK( 1 )
      COUNT  = 1
      INDCRT = INDCON
      NBLKCR = NBLK( INDCRT )
C
C     Compute the Frobenius norm of [ B  A ] (used for rank estimation),
C     taking into account the structure.
C
      NR = M1
      NC = 1
      SVLMXB = DLANGE( 'Frobenius', M1, M, B, LDB, DWORK )
      SVLMXA = ZERO
C
      DO 20 I = 1, INDCRT - 1
         NR = NR + NBLK( I+1 )
         SVLMXA = DLAPY2( SVLMXA,
     $                    DLANGE( 'Frobenius', NR, NBLK( I ),
     $                            A( 1, NC ), LDA, DWORK ) )
         NC = NC + NBLK( I )
   20 CONTINUE
C
      SVLMXA = DLAPY2( SVLMXA,
     $                 DLANGE( 'Frobenius', N, NBLKCR, A( 1, NC ), LDA,
     $                         DWORK ) )
      L  = 1
      MR = NBLKCR
      NR = N - MR + 1
   30 CONTINUE
C     WHILE( INDCRT.GT.1 )LOOP
      IF( INDCRT.GT.1 ) THEN
C
C        Assign next eigenvalue/eigenvector.
C
         LP1 = L + M1
         INDCN1 = INDCRT - 1
         MR1 = NBLK( INDCN1 )
         NR1 = NR - MR1
         COMPLX = WI(L).NE.ZERO
         CALL DCOPY( MR, Y( COUNT ), 1, DWORK( NR ), 1 )
         COUNT = COUNT + MR
         NC = 1
         IF( COMPLX ) THEN
            CALL DCOPY( MR, Y( COUNT ), 1, DWORK( N+NR ), 1 )
            COUNT = COUNT + MR
            WI( L+1 ) = WI( L )*WI( L+1 )
            NC = 2
         END IF
C
C        Compute and transform eigenvector.
C
         DO 50 IP = 1, INDCRT
            IF( IP.NE.INDCRT ) THEN
               CALL DLACPY( 'Full', MR, MR1, A( NR, NR1 ), LDA,
     $                      DWORK( IRMX ), M )
               IF( IP.EQ.1 ) THEN
                  MP1 = MR
                  NP1 = NR + MP1
               ELSE
                  MP1 = MR + 1
                  NP1 = NR + MP1
                  S = DASUM( MP1, DWORK( NR ), 1 )
                  IF( COMPLX ) S = S + DASUM( MP1, DWORK( N+NR ), 1 )
                  IF( S.NE.ZERO ) THEN
C
C                    Scale eigenvector elements.
C
                     CALL DSCAL( MP1, ONE/S, DWORK( NR ), 1 )
                     IF( COMPLX ) THEN
                        CALL DSCAL( MP1, ONE/S, DWORK( N+NR ), 1 )
                        IF( NP1.LE.N )
     $                     DWORK( N+NP1 ) = DWORK( N+NP1 ) / S
                     END IF
                  END IF
               END IF
C
C              Compute the right-hand side of the eigenvector equations.
C
               CALL DCOPY( MR, DWORK( NR ), 1, DWORK( NR1 ), 1 )
               CALL DSCAL( MR, WR( L ), DWORK( NR1 ), 1 )
               CALL DGEMV( 'No transpose', MR, MP1, -ONE, A( NR, NR ),
     $                     LDA, DWORK( NR ), 1, ONE, DWORK( NR1 ), 1 )
               IF( COMPLX ) THEN
                  CALL DAXPY( MR, WI( L+1 ), DWORK( N+NR ), 1,
     $                        DWORK( NR1 ), 1 )
                  CALL DCOPY( MR, DWORK( NR ), 1, DWORK( N+NR1 ), 1 )
                  CALL DAXPY( MR, WR( L+1 ), DWORK( N+NR ), 1,
     $                        DWORK( N+NR1 ), 1 )
                  CALL DGEMV( 'No transpose', MR, MP1, -ONE,
     $                        A( NR, NR ), LDA, DWORK( N+NR ), 1, ONE,
     $                        DWORK( N+NR1 ), 1 )
                  IF( NP1.LE.N )
     $               CALL DAXPY( MR, -DWORK( N+NP1 ), A( NR, NP1 ), 1,
     $                           DWORK( N+NR1 ), 1 )
               END IF
C
C              Solve linear equations for eigenvector elements.
C
               CALL MB02QD( 'FreeElements', 'NoPermuting', MR, MR1, NC,
     $                      TOLDEF, SVLMXA, DWORK( IRMX ), M,
     $                      DWORK( NR1 ), N, Y( COUNT ), IWORK, RANK,
     $                      SVAL, DWORK( IWRK ), LDWORK-IWRK+1, INFO )
               MAXWRK = MAX( MAXWRK, INT( DWORK( IWRK ) ) + IWRK - 1 )
               IF( RANK.LT.MR ) GO TO 80
C
               COUNT = COUNT + ( MR1 - MR )*NC
               NJ = NR1
            ELSE
               NJ = NR
            END IF
            NI = NR + MR - 1
            IF( IP.EQ.1 ) THEN
               KMR = MR - 1
            ELSE
               KMR = MR
               IF( IP.EQ.2 ) THEN
                  NI = NI + NBLKCR
               ELSE
                  NI = NI + NBLK( INDCRT-IP+2 ) + 1
                  IF( COMPLX ) NI = MIN( NI+1, N )
               END IF
            END IF
C
            DO 40 KK = 1, KMR
               K = NR + MR - KK
               IF( IP.EQ.1 ) K = N - KK
               CALL DLARTG( DWORK( K ), DWORK( K+1 ), P, Q, R )
               DWORK( K )   = R
               DWORK( K+1 ) = ZERO
C
C              Transform  A.
C
               CALL DROT( N-NJ+1, A( K, NJ ), LDA, A( K+1, NJ ), LDA,
     $                    P, Q )
               CALL DROT( NI, A( 1, K ), 1, A( 1, K+1 ), 1, P, Q )
C
               IF( K.LT.LP1 ) THEN
C
C                 Transform B.
C
                  CALL DROT( M, B( K, 1 ), LDB, B( K+1, 1 ), LDB, P, Q )
               END IF
C
C              Accumulate transformations.
C
               CALL DROT( N, Z( 1, K ), 1, Z( 1, K+1 ), 1, P, Q )
C
               IF( COMPLX ) THEN
                  CALL DROT( 1, DWORK( N+K ), 1, DWORK( N+K+1 ), 1, P,
     $                       Q )
                  K = K + 1
                  IF( K.LT.N ) THEN
                     CALL DLARTG( DWORK( N+K ), DWORK( N+K+1 ), P, Q,
     $                            R )
                     DWORK( N+K )   = R
                     DWORK( N+K+1 ) = ZERO
C
C                    Transform  A.
C
                     CALL DROT( N-NJ+1, A( K, NJ ), LDA, A( K+1, NJ ),
     $                          LDA, P, Q )
                     CALL DROT( NI, A( 1, K ), 1, A( 1, K+1 ), 1, P, Q )
C
                     IF( K.LE.LP1 ) THEN
C
C                       Transform B.
C
                        CALL DROT( M, B( K, 1 ), LDB, B( K+1, 1 ), LDB,
     $                             P, Q )
                     END IF
C
C                    Accumulate transformations.
C
                     CALL DROT( N, Z( 1, K ), 1, Z( 1, K+1 ), 1, P, Q )
C
                  END IF
               END IF
   40       CONTINUE
C
            IF( IP.NE.INDCRT ) THEN
               MR = MR1
               NR = NR1
               IF( IP.NE.INDCN1 ) THEN
                  INDCN2 = INDCRT - IP - 1
                  MR1 = NBLK( INDCN2 )
                  NR1 = NR1 - MR1
               END IF
            END IF
   50    CONTINUE
C
         IF( .NOT.COMPLX ) THEN
C
C           Find one column of G.
C
            CALL DLACPY( 'Full', M1, M, B( L+1, 1 ), LDB, DWORK( IRMX ),
     $                   M )
            CALL DCOPY(  M1, A( L+1, L ), 1, G( 1, L ), 1 )
         ELSE
C
C           Find two columns of G.
C
            IF( LP1.LT.N ) THEN
               LP1 = LP1 + 1
               K = L + 2
            ELSE
               K = L + 1
            END IF
            CALL DLACPY( 'Full', M1, M, B( K, 1 ), LDB, DWORK( IRMX ),
     $                   M )
            CALL DLACPY( 'Full', M1, 2, A( K, L ), LDA, G( 1, L ), LDG )
            IF( K.EQ.L+1 ) THEN
               G( 1, L )   = G( 1, L ) -
     $                       ( DWORK( N+L+1 ) / DWORK( L ) )*WI( L+1 )
               G( 1, L+1 ) = G( 1, L+1 ) - WR(L+1) +
     $                         ( DWORK( N+L ) / DWORK( L ) )*WI( L+1 )
            END IF
         END IF
C
         CALL MB02QD( 'FreeElements', 'NoPermuting', M1, M, NC, TOLDEF,
     $                SVLMXB, DWORK( IRMX ), M, G( 1, L ), LDG,
     $                Y( COUNT ), IWORK, RANK, SVAL, DWORK( IWRK ),
     $                LDWORK-IWRK+1, INFO )
         MAXWRK = MAX( MAXWRK, INT( DWORK( IWRK ) ) + IWRK - 1 )
         IF( RANK.LT.M1 ) GO TO 80
C
         COUNT = COUNT + ( M - M1 )*NC
         CALL DGEMM( 'No transpose', 'No transpose', LP1, NC, M, -ONE,
     $               B, LDB, G( 1, L ), LDG, ONE, A( 1, L ), LDA )
         L = L + 1
         NBLKCR = NBLKCR - 1
         IF( NBLKCR.EQ.0 ) THEN
            INDCRT = INDCRT - 1
            NBLKCR = NBLK( INDCRT )
         END IF
         IF( COMPLX ) THEN
            WI( L ) = -WI( L-1 )
            L = L + 1
            NBLKCR = NBLKCR - 1
            IF( NBLKCR.EQ.0 ) THEN
               INDCRT = INDCRT - 1
               IF( INDCRT.GT.0 ) NBLKCR = NBLK( INDCRT )
            END IF
         END IF
         MR = NBLKCR
         NR = N - MR + 1
         GO TO 30
      END IF
C     END WHILE 30
C
      IF( L.LE.N ) THEN
C
C        Find the remaining columns of G.
C
C        QR decomposition of the free eigenvectors.
C
         DO 60 I = 1, MR - 1
            IA = L + I - 1
            MI = MR - I + 1
            CALL DCOPY( MI, Y( COUNT ), 1, DWORK( 1 ), 1 )
            COUNT = COUNT + MI
            CALL DLARFG( MI, DWORK( 1 ), DWORK( 2 ), 1, R )
            DWORK( 1 ) = ONE
C
C           Transform A.
C
            CALL DLARF( 'Left', MI, MR, DWORK( 1 ), 1, R, A( IA, L ),
     $                  LDA, DWORK( N+1 ) )
            CALL DLARF( 'Right', N, MI, DWORK( 1 ), 1, R, A( 1, IA ),
     $                  LDA, DWORK( N+1 ) )
C
C           Transform B.
C
            CALL DLARF( 'Left', MI, M, DWORK( 1 ), 1, R, B( IA, 1 ),
     $                  LDB, DWORK( N+1 ) )
C
C           Accumulate transformations.
C
            CALL DLARF( 'Right', N, MI, DWORK( 1 ), 1, R, Z( 1, IA ),
     $                  LDZ, DWORK( N+1 ) )
   60    CONTINUE
C
         I = 0
C        REPEAT
   70    CONTINUE
            I  = I + 1
            IA = L + I - 1
            IF( WI( IA ).EQ.ZERO ) THEN
               CALL DCOPY( MR, A( IA, L ), LDA, G( I, L ), LDG )
               CALL DAXPY( MR-I, -ONE, Y( COUNT ), 1, G( I, L+I ), LDG )
               COUNT = COUNT + MR - I
               G( I, IA ) = G( I, IA ) - WR( IA )
            ELSE
               CALL DLACPY( 'Full', 2, MR, A( IA, L ), LDA, G( I, L ),
     $                      LDG )
               CALL DAXPY(  MR-I-1, -ONE, Y( COUNT ), 2, G( I, L+I+1 ),
     $                      LDG )
               CALL DAXPY(  MR-I-1, -ONE, Y( COUNT+1 ), 2,
     $                      G( I+1, L+I+1 ), LDG )
               COUNT = COUNT + 2*( MR - I - 1 )
               G( I, IA )     = G(I, IA )     - WR( IA )
               G( I, IA+1 )   = G(I, IA+1 )   - WI( IA )
               G( I+1, IA )   = G(I+1, IA )   - WI( IA+1 )
               G( I+1, IA+1 ) = G(I+1, IA+1 ) - WR( IA+1 )
               I = I + 1
            END IF
         IF( I.LT.MR ) GO TO 70
C        UNTIL I.GE.MR
C
         CALL DLACPY( 'Full', MR, M, B( L, 1 ), LDB, DWORK( IRMX ), M )
         CALL MB02QD( 'FreeElements', 'NoPermuting', MR, M, MR, TOLDEF,
     $                SVLMXB, DWORK( IRMX ), M, G( 1, L ), LDG,
     $                Y( COUNT ), IWORK, RANK, SVAL, DWORK( IWRK ),
     $                LDWORK-IWRK+1, INFO )
         MAXWRK = MAX( MAXWRK, INT( DWORK( IWRK ) ) + IWRK - 1 )
         IF( RANK.LT.MR ) GO TO 80
C
         COUNT = COUNT + ( M - MR )*MR
         CALL DGEMM( 'No transpose', 'No transpose', N, MR, M, -ONE, B,
     $               LDB, G( 1, L ), LDG, ONE, A( 1, L ), LDA )
      END IF
C
C     Transform G:
C     G := G * Z'.
C
      CALL DGEMM( 'No transpose', 'Transpose', M, N, N, ONE, G, LDG,
     $            Z, LDZ, ZERO, DWORK( 1 ), M )
      CALL DLACPY( 'Full', M, N, DWORK( 1 ), M, G, LDG )
      COUNT = COUNT - 1
C
      IF( N.GT.2) THEN
C
C        Set the elements of A below the Hessenberg part to zero.
C
         CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A( 3, 1 ), LDA )
      END IF
      DWORK( 1 ) = MAXWRK
      RETURN
C
C     Exit with INFO = 1 if the pair ( A, B ) is not controllable or
C     the free parameters are not set appropriately.
C
   80 INFO = 1
      RETURN
C *** Last line of SB01DD ***
      END


       SUBROUTINE W3FB00(ALAT,ALONG,XMESHL,XI,XJ)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM: W3FB00         LATITUDE, LONGITUDE TO I,J
C   AUTHOR: HEERMANN,A.      ORG: W345       DATE: 69-08-01
C
C ABSTRACT: CONVERTS THE COORDINATES OF A LOCATION ON EARTH FROM THE
C   NATURAL COORDINATE SYSTEM OF LATITUDE/LONGITUDE TO THE GRID (I,J)
C   COORDINATE SYSTEM OVERLAID ON THE POLAR STEREOGRAPHIC MAP PRO-
C   JECTION TRUE AT 60 N. A PREFERABLE, MORE FLEXIBLE SUBROUTINE TO
C   USE IS W3FB04. W3FB00 IS THE REVERSE OF W3FB01.
C
C PROGRAM HISTORY LOG:
C   69-08-01  A. HEERMANN
C   90-08-31  R.E.JONES     CONVERT TO CRAY CFT77 FORTRAN
C
C USAGE:  CALL W3FB00 (ALAT, ALONG, XMESHL, XI, XJ)
C
C   INPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     ALAT   ARG LIST  LATITUDE IN DEG.  (-20.0(S. HEMIS) ) ALAT ) 90.0)
C     ALONG            WEST LONGITUDE IN DEGREES
C     XMESHL ARG LIST  MESH LENGTH OF GRID IN KILOMETERS AT 60N
C
C   OUTPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     XI     ARG LIST  I OF THE POINT RELATIVE TO NORTH POLE
C     XJ     ARG LIST  J OF THE POINT RELATIVE TO NORTH POLE
C
C   SUBPROGRAMS CALLED:
C     NAMES                                                   LIBRARY
C     ------------------------------------------------------- --------
C     COS SIN                                                 SYSLIB
C
C   REMARKS: THE GRID USED IN THIS SUBROUTINE HAS ITS ORIGIN (I=0,J=0)
C     AT THE NORTH POLE, SO IF THE USER'S GRID HAS ITS ORIGIN AT A
C     POINT OTHER THAN THE NORTH POLE, A TRANSLATION IS REQUIRED TO
C     GET I AND J. THE SUBROUTINE GRID IS ORIENTED SO THAT LONGITUDE
C     80W IS PARALLEL TO THE GRIDLINES OF I=CONSTANT. THE RADIUS OF
C     THE EARTH IS TAKEN TO BE 6371.2 KM.
C     ALL PARAMETERS IN THE CALL STATEMENT MUST BE REAL
C     THIS CODE WILL NOT VECTORIZE ON A CRAY. YOU WILL HAVE PUT
C     IT LINE TO VECTORIZE IT.
C
C ATTRIBUTES:
C   LANGUAGE: IBM370 VS FORTRAN
C   MACHINE:  CRAY Y-MP8/832
C
C$$$
C
      DATA  RADPD /.01745329/
      DATA  EARTHR/6371.2/
C
      RE    = (EARTHR * 1.86603) / XMESHL
      XLAT  = ALAT * RADPD
      SINL  = SIN(XLAT)
      WLONG = (ALONG + 100.0) * RADPD
      R     = (RE * COS(XLAT)) / (1. + SINL)
      XI    = R * SIN(WLONG)
      XJ    = R * COS(WLONG)
      RETURN
      END


      SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S,
     $                   SEP, WORK, LWORK, INFO )
*
*  -- LAPACK routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH.
*
*     .. Scalar Arguments ..
      CHARACTER          COMPQ, JOB
      INTEGER            INFO, LDQ, LDT, LWORK, M, N
      DOUBLE PRECISION   S, SEP
*     ..
*     .. Array Arguments ..
      LOGICAL            SELECT( * )
      COMPLEX*16         Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  ZTRSEN reorders the Schur factorization of a complex matrix
*  A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in
*  the leading positions on the diagonal of the upper triangular matrix
*  T, and the leading columns of Q form an orthonormal basis of the
*  corresponding right invariant subspace.
*
*  Optionally the routine computes the reciprocal condition numbers of
*  the cluster of eigenvalues and/or the invariant subspace.
*
*  Arguments
*  =========
*
*  JOB     (input) CHARACTER*1
*          Specifies whether condition numbers are required for the
*          cluster of eigenvalues (S) or the invariant subspace (SEP):
*          = 'N': none;
*          = 'E': for eigenvalues only (S);
*          = 'V': for invariant subspace only (SEP);
*          = 'B': for both eigenvalues and invariant subspace (S and
*                 SEP).
*
*  COMPQ   (input) CHARACTER*1
*          = 'V': update the matrix Q of Schur vectors;
*          = 'N': do not update Q.
*
*  SELECT  (input) LOGICAL array, dimension (N)
*          SELECT specifies the eigenvalues in the selected cluster. To
*          select the j-th eigenvalue, SELECT(j) must be set to .TRUE..
*
*  N       (input) INTEGER
*          The order of the matrix T. N >= 0.
*
*  T       (input/output) COMPLEX*16 array, dimension (LDT,N)
*          On entry, the upper triangular matrix T.
*          On exit, T is overwritten by the reordered matrix T, with the
*          selected eigenvalues as the leading diagonal elements.
*
*  LDT     (input) INTEGER
*          The leading dimension of the array T. LDT >= max(1,N).
*
*  Q       (input/output) COMPLEX*16 array, dimension (LDQ,N)
*          On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
*          On exit, if COMPQ = 'V', Q has been postmultiplied by the
*          unitary transformation matrix which reorders T; the leading M
*          columns of Q form an orthonormal basis for the specified
*          invariant subspace.
*          If COMPQ = 'N', Q is not referenced.
*
*  LDQ     (input) INTEGER
*          The leading dimension of the array Q.
*          LDQ >= 1; and if COMPQ = 'V', LDQ >= N.
*
*  W       (output) COMPLEX*16 array, dimension (N)
*          The reordered eigenvalues of T, in the same order as they
*          appear on the diagonal of T.
*
*  M       (output) INTEGER
*          The dimension of the specified invariant subspace.
*          0 <= M <= N.
*
*  S       (output) DOUBLE PRECISION
*          If JOB = 'E' or 'B', S is a lower bound on the reciprocal
*          condition number for the selected cluster of eigenvalues.
*          S cannot underestimate the true reciprocal condition number
*          by more than a factor of sqrt(N). If M = 0 or N, S = 1.
*          If JOB = 'N' or 'V', S is not referenced.
*
*  SEP     (output) DOUBLE PRECISION
*          If JOB = 'V' or 'B', SEP is the estimated reciprocal
*          condition number of the specified invariant subspace. If
*          M = 0 or N, SEP = norm(T).
*          If JOB = 'N' or 'E', SEP is not referenced.
*
*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK.
*          If JOB = 'N', LWORK >= 1;
*          if JOB = 'E', LWORK = max(1,M*(N-M));
*          if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).
*
*          If LWORK = -1, then a workspace query is assumed; the routine
*          only calculates the optimal size of the WORK array, returns
*          this value as the first entry of the WORK array, and no error
*          message related to LWORK is issued by XERBLA.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  Further Details
*  ===============
*
*  ZTRSEN first collects the selected eigenvalues by computing a unitary
*  transformation Z to move them to the top left corner of T. In other
*  words, the selected eigenvalues are the eigenvalues of T11 in:
*
*                Z'*T*Z = ( T11 T12 ) n1
*                         (  0  T22 ) n2
*                            n1  n2
*
*  where N = n1+n2 and Z' means the conjugate transpose of Z. The first
*  n1 columns of Z span the specified invariant subspace of T.
*
*  If T has been obtained from the Schur factorization of a matrix
*  A = Q*T*Q', then the reordered Schur factorization of A is given by
*  A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span the
*  corresponding invariant subspace of A.
*
*  The reciprocal condition number of the average of the eigenvalues of
*  T11 may be returned in S. S lies between 0 (very badly conditioned)
*  and 1 (very well conditioned). It is computed as follows. First we
*  compute R so that
*
*                         P = ( I  R ) n1
*                             ( 0  0 ) n2
*                               n1 n2
*
*  is the projector on the invariant subspace associated with T11.
*  R is the solution of the Sylvester equation:
*
*                        T11*R - R*T22 = T12.
*
*  Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote
*  the two-norm of M. Then S is computed as the lower bound
*
*                      (1 + F-norm(R)**2)**(-1/2)
*
*  on the reciprocal of 2-norm(P), the true reciprocal condition number.
*  S cannot underestimate 1 / 2-norm(P) by more than a factor of
*  sqrt(N).
*
*  An approximate error bound for the computed average of the
*  eigenvalues of T11 is
*
*                         EPS * norm(T) / S
*
*  where EPS is the machine precision.
*
*  The reciprocal condition number of the right invariant subspace
*  spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.
*  SEP is defined as the separation of T11 and T22:
*
*                     sep( T11, T22 ) = sigma-min( C )
*
*  where sigma-min(C) is the smallest singular value of the
*  n1*n2-by-n1*n2 matrix
*
*     C  = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )
*
*  I(m) is an m by m identity matrix, and kprod denotes the Kronecker
*  product. We estimate sigma-min(C) by the reciprocal of an estimate of
*  the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)
*  cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).
*
*  When SEP is small, small changes in T can cause large changes in
*  the invariant subspace. An approximate bound on the maximum angular
*  error in the computed right invariant subspace is
*
*                      EPS * norm(T) / SEP
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY, WANTBH, WANTQ, WANTS, WANTSP
      INTEGER            IERR, K, KASE, KS, LWMIN, N1, N2, NN
      DOUBLE PRECISION   EST, RNORM, SCALE
*     ..
*     .. Local Arrays ..
      INTEGER            ISAVE( 3 )
      DOUBLE PRECISION   RWORK( 1 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   ZLANGE
      EXTERNAL           LSAME, ZLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, ZLACN2, ZLACPY, ZTREXC, ZTRSYL
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, SQRT
*     ..
*     .. Executable Statements ..
*
*     Decode and test the input parameters.
*
      WANTBH = LSAME( JOB, 'B' )
      WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
      WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
      WANTQ = LSAME( COMPQ, 'V' )
*
*     Set M to the number of selected eigenvalues.
*
      M = 0
      DO 10 K = 1, N
         IF( SELECT( K ) )
     $      M = M + 1
   10 CONTINUE
*
      N1 = M
      N2 = N - M
      NN = N1*N2
*
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 )
*
      IF( WANTSP ) THEN
         LWMIN = MAX( 1, 2*NN )
      ELSE IF( LSAME( JOB, 'N' ) ) THEN
         LWMIN = 1
      ELSE IF( LSAME( JOB, 'E' ) ) THEN
         LWMIN = MAX( 1, NN )
      END IF
*
      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP )
     $     THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
         INFO = -8
      ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -14
      END IF
*
      IF( INFO.EQ.0 ) THEN
         WORK( 1 ) = LWMIN
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZTRSEN', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.N .OR. M.EQ.0 ) THEN
         IF( WANTS )
     $      S = ONE
         IF( WANTSP )
     $      SEP = ZLANGE( '1', N, N, T, LDT, RWORK )
         GO TO 40
      END IF
*
*     Collect the selected eigenvalues at the top left corner of T.
*
      KS = 0
      DO 20 K = 1, N
         IF( SELECT( K ) ) THEN
            KS = KS + 1
*
*           Swap the K-th eigenvalue to position KS.
*
            IF( K.NE.KS )
     $         CALL ZTREXC( COMPQ, N, T, LDT, Q, LDQ, K, KS, IERR )
         END IF
   20 CONTINUE
*
      IF( WANTS ) THEN
*
*        Solve the Sylvester equation for R:
*
*           T11*R - R*T22 = scale*T12
*
         CALL ZLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 )
         CALL ZTRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ),
     $                LDT, WORK, N1, SCALE, IERR )
*
*        Estimate the reciprocal of the condition number of the cluster
*        of eigenvalues.
*
         RNORM = ZLANGE( 'F', N1, N2, WORK, N1, RWORK )
         IF( RNORM.EQ.ZERO ) THEN
            S = ONE
         ELSE
            S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )*
     $          SQRT( RNORM ) )
         END IF
      END IF
*
      IF( WANTSP ) THEN
*
*        Estimate sep(T11,T22).
*
         EST = ZERO
         KASE = 0
   30    CONTINUE
         CALL ZLACN2( NN, WORK( NN+1 ), WORK, EST, KASE, ISAVE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.1 ) THEN
*
*              Solve T11*R - R*T22 = scale*X.
*
               CALL ZTRSYL( 'N', 'N', -1, N1, N2, T, LDT,
     $                      T( N1+1, N1+1 ), LDT, WORK, N1, SCALE,
     $                      IERR )
            ELSE
*
*              Solve T11'*R - R*T22' = scale*X.
*
               CALL ZTRSYL( 'C', 'C', -1, N1, N2, T, LDT,
     $                      T( N1+1, N1+1 ), LDT, WORK, N1, SCALE,
     $                      IERR )
            END IF
            GO TO 30
         END IF
*
         SEP = SCALE / EST
      END IF
*
   40 CONTINUE
*
*     Copy reordered eigenvalues to W.
*
      DO 50 K = 1, N
         W( K ) = T( K, K )
   50 CONTINUE
*
      WORK( 1 ) = LWMIN
*
      RETURN
*
*     End of ZTRSEN
*
      END


!*==dsteqr.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DSTEQR
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DSTEQR + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          COMPZ
!       INTEGER            INFO, LDZ, N
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   D( * ), E( * ), WORK( * ), Z( LDZ, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DSTEQR computes all eigenvalues and, optionally, eigenvectors of a
!> symmetric tridiagonal matrix using the implicit QL or QR method.
!> The eigenvectors of a full or band symmetric matrix can also be found
!> if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to
!> tridiagonal form.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] COMPZ
!> \verbatim
!>          COMPZ is CHARACTER*1
!>          = 'N':  Compute eigenvalues only.
!>          = 'V':  Compute eigenvalues and eigenvectors of the original
!>                  symmetric matrix.  On entry, Z must contain the
!>                  orthogonal matrix used to reduce the original matrix
!>                  to tridiagonal form.
!>          = 'I':  Compute eigenvalues and eigenvectors of the
!>                  tridiagonal matrix.  Z is initialized to the identity
!>                  matrix.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] D
!> \verbatim
!>          D is DOUBLE PRECISION array, dimension (N)
!>          On entry, the diagonal elements of the tridiagonal matrix.
!>          On exit, if INFO = 0, the eigenvalues in ascending order.
!> \endverbatim
!>
!> \param[in,out] E
!> \verbatim
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          On entry, the (n-1) subdiagonal elements of the tridiagonal
!>          matrix.
!>          On exit, E has been destroyed.
!> \endverbatim
!>
!> \param[in,out] Z
!> \verbatim
!>          Z is DOUBLE PRECISION array, dimension (LDZ, N)
!>          On entry, if  COMPZ = 'V', then Z contains the orthogonal
!>          matrix used in the reduction to tridiagonal form.
!>          On exit, if INFO = 0, then if  COMPZ = 'V', Z contains the
!>          orthonormal eigenvectors of the original symmetric matrix,
!>          and if COMPZ = 'I', Z contains the orthonormal eigenvectors
!>          of the symmetric tridiagonal matrix.
!>          If COMPZ = 'N', then Z is not referenced.
!> \endverbatim
!>
!> \param[in] LDZ
!> \verbatim
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.  LDZ >= 1, and if
!>          eigenvectors are desired, then  LDZ >= max(1,N).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is DOUBLE PRECISION array, dimension (max(1,2*N-2))
!>          If COMPZ = 'N', then WORK is not referenced.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  the algorithm has failed to find all the eigenvalues in
!>                a total of 30*N iterations; if INFO = i, then i
!>                elements of E have not converged to zero; on exit, D
!>                and E contain the elements of a symmetric tridiagonal
!>                matrix which is orthogonally similar to the original
!>                matrix.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup auxOTHERcomputational
!
!  =====================================================================
      SUBROUTINE DSTEQR(Compz,N,D,E,Z,Ldz,Work,Info)
      IMPLICIT NONE
!*--DSTEQR135
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Compz
      INTEGER Info , Ldz , N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION D(*) , E(*) , Work(*) , Z(Ldz,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE , TWO , THREE
      PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
      INTEGER MAXIT
      PARAMETER (MAXIT=30)
!     ..
!     .. Local Scalars ..
      INTEGER i , icompz , ii , iscale , j , jtot , k , l , l1 , lend , &
     &        lendm1 , lendp1 , lendsv , lm1 , lsv , m , mm , mm1 ,     &
     &        nm1 , nmaxit
      DOUBLE PRECISION anorm , b , c , eps , eps2 , f , g , p , r ,     &
     &                 rt1 , rt2 , s , safmax , safmin , ssfmax ,       &
     &                 ssfmin , tst
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      DOUBLE PRECISION DLAMCH , DLANST , DLAPY2
      EXTERNAL LSAME , DLAMCH , DLANST , DLAPY2
!     ..
!     .. External Subroutines ..
      EXTERNAL DLAE2 , DLAEV2 , DLARTG , DLASCL , DLASET , DLASR ,      &
     &         DLASRT , DSWAP , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MAX , SIGN , SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      Info = 0
!
      IF ( LSAME(Compz,'N') ) THEN
         icompz = 0
      ELSEIF ( LSAME(Compz,'V') ) THEN
         icompz = 1
      ELSEIF ( LSAME(Compz,'I') ) THEN
         icompz = 2
      ELSE
         icompz = -1
      ENDIF
      IF ( icompz<0 ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( (Ldz<1) .OR. (icompz>0 .AND. Ldz<MAX(1,N)) ) THEN
         Info = -6
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('DSTEQR',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) RETURN
!
      IF ( N==1 ) THEN
         IF ( icompz==2 ) Z(1,1) = ONE
         RETURN
      ENDIF
!
!     Determine the unit roundoff and over/underflow thresholds.
!
      eps = DLAMCH('E')
      eps2 = eps**2
      safmin = DLAMCH('S')
      safmax = ONE/safmin
      ssfmax = SQRT(safmax)/THREE
      ssfmin = SQRT(safmin)/eps2
!
!     Compute the eigenvalues and eigenvectors of the tridiagonal
!     matrix.
!
      IF ( icompz==2 ) CALL DLASET('Full',N,N,ZERO,ONE,Z,Ldz)
!
      nmaxit = N*MAXIT
      jtot = 0
!
!     Determine where the matrix splits and choose QL or QR iteration
!     for each block, according to whether top or bottom diagonal
!     element is smaller.
!
      l1 = 1
      nm1 = N - 1
!
      DO WHILE ( l1<=N )
         IF ( l1>1 ) E(l1-1) = ZERO
         IF ( l1<=nm1 ) THEN
            DO m = l1 , nm1
               tst = ABS(E(m))
               IF ( tst==ZERO ) GOTO 50
               IF ( tst<=(SQRT(ABS(D(m)))*SQRT(ABS(D(m+1))))*eps ) THEN
                  E(m) = ZERO
                  GOTO 50
               ENDIF
            ENDDO
         ENDIF
         m = N
!
 50      l = l1
         lsv = l
         lend = m
         lendsv = lend
         l1 = m + 1
         IF ( lend/=l ) THEN
!
!     Scale submatrix in rows and columns L to LEND
!
            anorm = DLANST('M',lend-l+1,D(l),E(l))
            iscale = 0
            IF ( anorm/=ZERO ) THEN
               IF ( anorm>ssfmax ) THEN
                  iscale = 1
                  CALL DLASCL('G',0,0,anorm,ssfmax,lend-l+1,1,D(l),N,   &
     &                        Info)
                  CALL DLASCL('G',0,0,anorm,ssfmax,lend-l,1,E(l),N,Info)
               ELSEIF ( anorm<ssfmin ) THEN
                  iscale = 2
                  CALL DLASCL('G',0,0,anorm,ssfmin,lend-l+1,1,D(l),N,   &
     &                        Info)
                  CALL DLASCL('G',0,0,anorm,ssfmin,lend-l,1,E(l),N,Info)
               ENDIF
!
!     Choose between QL and QR iteration
!
               IF ( ABS(D(lend))<ABS(D(l)) ) THEN
                  lend = lsv
                  l = lendsv
               ENDIF
!
               IF ( lend>l ) THEN
!
!        QL Iteration
!
!        Look for small subdiagonal element.
!
 55               IF ( l/=lend ) THEN
                     lendm1 = lend - 1
                     DO m = l , lendm1
                        tst = ABS(E(m))**2
                        IF ( tst<=(eps2*ABS(D(m)))*ABS(D(m+1))+safmin ) &
     &                       GOTO 60
                     ENDDO
                  ENDIF
!
                  m = lend
!
 60               IF ( m<lend ) E(m) = ZERO
                  p = D(l)
                  IF ( m==l ) THEN
!
!        Eigenvalue found.
!
                     D(l) = p
!
                     l = l + 1
                     IF ( l<=lend ) GOTO 55
                  ELSE
!
!        If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
!        to compute its eigensystem.
!
                     IF ( m==l+1 ) THEN
                        IF ( icompz>0 ) THEN
                           CALL DLAEV2(D(l),E(l),D(l+1),rt1,rt2,c,s)
                           Work(l) = c
                           Work(N-1+l) = s
                           CALL DLASR('R','V','B',N,2,Work(l),          &
     &                                Work(N-1+l),Z(1,l),Ldz)
                        ELSE
                           CALL DLAE2(D(l),E(l),D(l+1),rt1,rt2)
                        ENDIF
                        D(l) = rt1
                        D(l+1) = rt2
                        E(l) = ZERO
                        l = l + 2
                        IF ( l>lend ) GOTO 80
                        GOTO 55
                     ENDIF
!
                     IF ( jtot/=nmaxit ) THEN
                        jtot = jtot + 1
!
!        Form shift.
!
                        g = (D(l+1)-p)/(TWO*E(l))
                        r = DLAPY2(g,ONE)
                        g = D(m) - p + (E(l)/(g+SIGN(r,g)))
!
                        s = ONE
                        c = ONE
                        p = ZERO
!
!        Inner loop
!
                        mm1 = m - 1
                        DO i = mm1 , l , -1
                           f = s*E(i)
                           b = c*E(i)
                           CALL DLARTG(g,f,c,s,r)
                           IF ( i/=m-1 ) E(i+1) = r
                           g = D(i+1) - p
                           r = (D(i)-g)*s + TWO*c*b
                           p = s*r
                           D(i+1) = g + p
                           g = c*r - b
!
!           If eigenvectors are desired, then save rotations.
!
                           IF ( icompz>0 ) THEN
                              Work(i) = c
                              Work(N-1+i) = -s
                           ENDIF
!
                        ENDDO
!
!        If eigenvectors are desired, then apply saved rotations.
!
                        IF ( icompz>0 ) THEN
                           mm = m - l + 1
                           CALL DLASR('R','V','B',N,mm,Work(l),         &
     &                                Work(N-1+l),Z(1,l),Ldz)
                        ENDIF
!
                        D(l) = D(l) - p
                        E(l) = g
                        GOTO 55
                     ENDIF
                  ENDIF
!
               ELSE
!
!        QR Iteration
!
!        Look for small superdiagonal element.
!
 65               IF ( l/=lend ) THEN
                     lendp1 = lend + 1
                     DO m = l , lendp1 , -1
                        tst = ABS(E(m-1))**2
                        IF ( tst<=(eps2*ABS(D(m)))*ABS(D(m-1))+safmin ) &
     &                       GOTO 70
                     ENDDO
                  ENDIF
!
                  m = lend
!
 70               IF ( m>lend ) E(m-1) = ZERO
                  p = D(l)
                  IF ( m==l ) THEN
!
!        Eigenvalue found.
!
                     D(l) = p
!
                     l = l - 1
                     IF ( l>=lend ) GOTO 65
                  ELSE
!
!        If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
!        to compute its eigensystem.
!
                     IF ( m==l-1 ) THEN
                        IF ( icompz>0 ) THEN
                           CALL DLAEV2(D(l-1),E(l-1),D(l),rt1,rt2,c,s)
                           Work(m) = c
                           Work(N-1+m) = s
                           CALL DLASR('R','V','F',N,2,Work(m),          &
     &                                Work(N-1+m),Z(1,l-1),Ldz)
                        ELSE
                           CALL DLAE2(D(l-1),E(l-1),D(l),rt1,rt2)
                        ENDIF
                        D(l-1) = rt1
                        D(l) = rt2
                        E(l-1) = ZERO
                        l = l - 2
                        IF ( l<lend ) GOTO 80
                        GOTO 65
                     ENDIF
!
                     IF ( jtot/=nmaxit ) THEN
                        jtot = jtot + 1
!
!        Form shift.
!
                        g = (D(l-1)-p)/(TWO*E(l-1))
                        r = DLAPY2(g,ONE)
                        g = D(m) - p + (E(l-1)/(g+SIGN(r,g)))
!
                        s = ONE
                        c = ONE
                        p = ZERO
!
!        Inner loop
!
                        lm1 = l - 1
                        DO i = m , lm1
                           f = s*E(i)
                           b = c*E(i)
                           CALL DLARTG(g,f,c,s,r)
                           IF ( i/=m ) E(i-1) = r
                           g = D(i) - p
                           r = (D(i+1)-g)*s + TWO*c*b
                           p = s*r
                           D(i) = g + p
                           g = c*r - b
!
!           If eigenvectors are desired, then save rotations.
!
                           IF ( icompz>0 ) THEN
                              Work(i) = c
                              Work(N-1+i) = s
                           ENDIF
!
                        ENDDO
!
!        If eigenvectors are desired, then apply saved rotations.
!
                        IF ( icompz>0 ) THEN
                           mm = l - m + 1
                           CALL DLASR('R','V','F',N,mm,Work(m),         &
     &                                Work(N-1+m),Z(1,m),Ldz)
                        ENDIF
!
                        D(l) = D(l) - p
                        E(lm1) = g
                        GOTO 65
                     ENDIF
                  ENDIF
!
               ENDIF
!
!     Undo scaling if necessary
!
 80            IF ( iscale==1 ) THEN
                  CALL DLASCL('G',0,0,ssfmax,anorm,lendsv-lsv+1,1,D(lsv)&
     &                        ,N,Info)
                  CALL DLASCL('G',0,0,ssfmax,anorm,lendsv-lsv,1,E(lsv), &
     &                        N,Info)
               ELSEIF ( iscale==2 ) THEN
                  CALL DLASCL('G',0,0,ssfmin,anorm,lendsv-lsv+1,1,D(lsv)&
     &                        ,N,Info)
                  CALL DLASCL('G',0,0,ssfmin,anorm,lendsv-lsv,1,E(lsv), &
     &                        N,Info)
               ENDIF
!
!     Check for no convergence to an eigenvalue after a total
!     of N*MAXIT iterations.
!
               IF ( jtot>=nmaxit ) THEN
                  DO i = 1 , N - 1
                     IF ( E(i)/=ZERO ) Info = Info + 1
                  ENDDO
                  GOTO 99999
               ENDIF
            ENDIF
         ENDIF
      ENDDO
!
!     Order eigenvalues and eigenvectors.
!
      IF ( icompz==0 ) THEN
!
!        Use Quick Sort
!
         CALL DLASRT('I',N,D,Info)
!
      ELSE
!
!        Use Selection Sort to minimize swaps of eigenvectors
!
         DO ii = 2 , N
            i = ii - 1
            k = i
            p = D(i)
            DO j = ii , N
               IF ( D(j)<p ) THEN
                  k = j
                  p = D(j)
               ENDIF
            ENDDO
            IF ( k/=i ) THEN
               D(k) = D(i)
               D(i) = p
               CALL DSWAP(N,Z(1,i),1,Z(1,k),1)
            ENDIF
         ENDDO
      ENDIF
!
!
!     End of DSTEQR
!
99999 END SUBROUTINE DSTEQR


      SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL,
     $                   LDVL, VR, LDVR, MM, M, WORK, INFO )
*
*  -- LAPACK routine (version 3.2) --
*     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   P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
     $                   VR( LDVR, * ), WORK( * )
*     ..
*
*
*  Purpose
*  =======
*
*  DTGEVC 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 DGGHRD + DHGEQZ.
*
*  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) DOUBLE PRECISION array, dimension (LDS,N)
*          The upper quasi-triangular matrix S from a generalized Schur
*          factorization, as computed by DHGEQZ.
*
*  LDS     (input) INTEGER
*          The leading dimension of array S.  LDS >= max(1,N).
*
*  P       (input) DOUBLE PRECISION array, dimension (LDP,N)
*          The upper triangular matrix P from a generalized Schur
*          factorization, as computed by DHGEQZ.
*          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) 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 left Schur vectors returned by DHGEQZ).
*          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) DOUBLE PRECISION 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 DHGEQZ).
*
*          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) DOUBLE PRECISION 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 ..
      DOUBLE PRECISION   ZERO, ONE, SAFETY
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0,
     $                   SAFETY = 1.0D+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
      DOUBLE PRECISION   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 ..
      DOUBLE PRECISION   BDIAG( 2 ), SUM( 2, 2 ), SUMS( 2, 2 ),
     $                   SUMP( 2, 2 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEMV, DLABAD, DLACPY, DLAG2, DLALN2, 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( 'DTGEVC', -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( 'DTGEVC', -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 (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 DLAG2( 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 DLALN2( .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 DGEMV( '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 DLACPY( ' ', N, NW, WORK( 4*N+1 ), N, VL( 1, JE ),
     $                      LDVL )
               IBEG = 1
            ELSE
               CALL DLACPY( ' ', 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 DLAG2( 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 DLALN2( .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 DTGEVC
*
      END