C
C SPDX-License-Identifier: BSD-3-Clause
C
      SUBROUTINE AB09KX( JOB, DICO, WEIGHT, N, NV, NW, M, P,
     $                   A,  LDA,  B,  LDB,  C,  LDC,  D,  LDD,
     $                   AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV,
     $                   AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW,
     $                   DWORK, LDWORK, IWARN, INFO )
C
C     PURPOSE
C
C     To construct a state-space representation (A,BS,CS,DS) of the
C     stable projection of V*G*W or conj(V)*G*conj(W) from the
C     state-space representations (A,B,C,D), (AV,BV,CV,DV), and
C     (AW,BW,CW,DW) of the transfer-function matrices G, V and W,
C     respectively. G is assumed to be a stable transfer-function
C     matrix and the state matrix A must be in a real Schur form.
C     When computing the stable projection of V*G*W, V and W are assumed
C     to be completely unstable transfer-function matrices.
C     When computing the stable projection of conj(V)*G*conj(W),
C     V and W are assumed to be stable transfer-function matrices.
C
C     For a transfer-function matrix G, conj(G) denotes the conjugate
C     of G given by G'(-s) for a continuous-time system or G'(1/z)
C     for a discrete-time system.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies which projection to be computed as follows:
C             = 'N':  compute the stable projection of V*G*W;
C             = 'C':  compute the stable projection of
C                     conj(V)*G*conj(W).
C
C     DICO    CHARACTER*1
C             Specifies the type of the systems as follows:
C             = 'C':  G, V and W are continuous-time systems;
C             = 'D':  G, V and W are discrete-time systems.
C
C     WEIGHT  CHARACTER*1
C             Specifies the type of frequency weighting, as follows:
C             = 'N':  no weightings are used (V = I, W = I);
C             = 'L':  only left weighting V is used (W = I);
C             = 'R':  only right weighting W is used (V = I);
C             = 'B':  both left and right weightings V and W are used.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A. Also the number of rows of
C             the matrix B and the number of columns of the matrix C.
C             N represents the dimension of the state vector of the
C             system with the transfer-function matrix G.  N >= 0.
C
C     NV      (input) INTEGER
C             The order of the matrix AV. Also the number of rows of
C             the matrix BV and the number of columns of the matrix CV.
C             NV represents the dimension of the state vector of the
C             system with the transfer-function matrix V.  NV >= 0.
C
C     NW      (input) INTEGER
C             The order of the matrix AW. Also the number of rows of
C             the matrix BW and the number of columns of the matrix CW.
C             NW represents the dimension of the state vector of the
C             system with the transfer-function matrix W.  NW >= 0.
C
C     M       (input) INTEGER
C             The number of columns of the matrices B, D, BW and DW
C             and number of rows of the matrices CW and DW.  M >= 0.
C             M represents the dimension of input vectors of the
C             systems with the transfer-function matrices G and W and
C             also the dimension of the output vector of the system
C             with the transfer-function matrix W.
C
C     P       (input) INTEGER
C             The number of rows of the matrices C, D, CV and DV and the
C             number of columns of the matrices BV and DV.  P >= 0.
C             P represents the dimension of output vectors of the
C             systems with the transfer-function matrices G and V and
C             also the dimension of the input vector of the system
C             with the transfer-function matrix V.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must
C             contain the state matrix A of the system with the
C             transfer-function matrix G in a real Schur form.
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 input matrix B of the system with the
C             transfer-function matrix G.
C             On exit, if INFO = 0, the leading N-by-M part of this
C             array contains the input matrix BS of the stable
C             projection of V*G*W if JOB = 'N', and of conj(V)*G*conj(W)
C             if JOB = 'C'.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the output matrix C of the system with the
C             transfer-function matrix G.
C             On exit, if INFO = 0, the leading P-by-N part of this
C             array contains the output matrix CS of the stable
C             projection of V*G*W if JOB = 'N', and of conj(V)*G*conj(W)
C             if JOB = 'C'.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= MAX(1,P).
C
C     D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
C             On entry, the leading P-by-M part of this array must
C             contain the feedthrough matrix D of the system with the
C             transfer-function matrix G.
C             On exit, if INFO = 0, the leading P-by-M part of this
C             array contains the feedthrough matrix DS of the stable
C             projection of V*G*W if JOB = 'N', and of conj(V)*G*conj(W)
C             if JOB = 'C'.
C
C     LDD     INTEGER
C             The leading dimension of the array D.  LDD >= MAX(1,P).
C
C     AV      (input/output) DOUBLE PRECISION array, dimension (LDAV,NV)
C             On entry, if WEIGHT = 'L' or 'B', the leading NV-by-NV
C             part of this array must contain the state matrix AV of
C             the system with the transfer-function matrix V.
C             On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading
C             NV-by-NV part of this array contains a real Schur form
C             of AV.
C             AV is not referenced if WEIGHT = 'R' or 'N'.
C
C     LDAV    INTEGER
C             The leading dimension of the array AV.
C             LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B';
C             LDAV >= 1,         if WEIGHT = 'R' or 'N'.
C
C     BV      (input/output) DOUBLE PRECISION array, dimension (LDBV,P)
C             On entry, if WEIGHT = 'L' or 'B', the leading NV-by-P part
C             of this array must contain the input matrix BV of the
C             system with the transfer-function matrix V.
C             On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading
C             NV-by-P part of this array contains the transformed input
C             matrix BV.
C             BV is not referenced if WEIGHT = 'R' or 'N'.
C
C     LDBV    INTEGER
C             The leading dimension of the array BV.
C             LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B';
C             LDBV >= 1,         if WEIGHT = 'R' or 'N'.
C
C     CV      (input/output) DOUBLE PRECISION array, dimension (LDCV,NV)
C             On entry, if WEIGHT = 'L' or 'B', the leading P-by-NV part
C             of this array must contain the output matrix CV of the
C             system with the transfer-function matrix V.
C             On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading
C             P-by-NV part of this array contains the transformed output
C             matrix CV.
C             CV is not referenced if WEIGHT = 'R' or 'N'.
C
C     LDCV    INTEGER
C             The leading dimension of the array CV.
C             LDCV >= MAX(1,P), if WEIGHT = 'L' or 'B';
C             LDCV >= 1,        if WEIGHT = 'R' or 'N'.
C
C     DV      (input) DOUBLE PRECISION array, dimension (LDDV,P)
C             If WEIGHT = 'L' or 'B', the leading P-by-P part of this
C             array must contain the feedthrough matrix DV of the system
C             with the transfer-function matrix V.
C             DV is not referenced if WEIGHT = 'R' or 'N'.
C
C     LDDV    INTEGER
C             The leading dimension of the array DV.
C             LDDV >= MAX(1,P), if WEIGHT = 'L' or 'B';
C             LDDV >= 1,        if WEIGHT = 'R' or 'N'.
C
C     AW      (input/output) DOUBLE PRECISION array, dimension (LDAW,NW)
C             On entry, if WEIGHT = 'R' or 'B', the leading NW-by-NW
C             part of this array must contain the state matrix AW of
C             the system with the transfer-function matrix W.
C             On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading
C             NW-by-NW part of this array contains a real Schur form
C             of AW.
C             AW is not referenced if WEIGHT = 'L' or 'N'.
C
C     LDAW    INTEGER
C             The leading dimension of the array AW.
C             LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B';
C             LDAW >= 1,         if WEIGHT = 'L' or 'N'.
C
C     BW      (input/output) DOUBLE PRECISION array, dimension (LDBW,M)
C             On entry, if WEIGHT = 'R' or 'B', the leading NW-by-M part
C             of this array must contain the input matrix BW of the
C             system with the transfer-function matrix W.
C             On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading
C             NW-by-M part of this array contains the transformed input
C             matrix BW.
C             BW is not referenced if WEIGHT = 'L' or 'N'.
C
C     LDBW    INTEGER
C             The leading dimension of the array BW.
C             LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B';
C             LDBW >= 1,         if WEIGHT = 'L' or 'N'.
C
C     CW      (input/output) DOUBLE PRECISION array, dimension (LDCW,NW)
C             On entry, if WEIGHT = 'R' or 'B', the leading M-by-NW part
C             of this array must contain the output matrix CW of the
C             system with the transfer-function matrix W.
C             On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading
C             M-by-NW part of this array contains the transformed output
C             matrix CW.
C             CW is not referenced if WEIGHT = 'L' or 'N'.
C
C     LDCW    INTEGER
C             The leading dimension of the array CW.
C             LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B';
C             LDCW >= 1,        if WEIGHT = 'L' or 'N'.
C
C     DW      (input) DOUBLE PRECISION array, dimension (LDDW,M)
C             If WEIGHT = 'R' or 'B', the leading M-by-M part of this
C             array must contain the feedthrough matrix DW of the system
C             with the transfer-function matrix W.
C             DW is not referenced if WEIGHT = 'L' or 'N'.
C
C     LDDW    INTEGER
C             The leading dimension of the array DW.
C             LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B';
C             LDDW >= 1,        if WEIGHT = 'L' or 'N'.
C
C     Workspace
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( 1, LDW1, LDW2 ), where
C               LDW1 = 0 if WEIGHT = 'R' or 'N' and
C               LDW1 = MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) )
C                      if WEIGHT = 'L' or WEIGHT = 'B',
C               LDW2 = 0 if WEIGHT = 'L' or 'N' and
C               LDW2 = MAX( NW*(NW+5), NW*N + MAX( b, M*N, P*M ) )
C                      if WEIGHT = 'R' or WEIGHT = 'B',
C               a = 0,    b = 0,     if DICO = 'C' or  JOB = 'N',
C               a = 2*NV, b = 2*NW,  if DICO = 'D' and JOB = 'C'.
C             For good performance, LDWORK should be larger.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             =  0:  no warning;
C             =  1:  JOB = 'N' and AV is not completely unstable, or
C                    JOB = 'C' and AV is not stable;
C             =  2:  JOB = 'N' and AW is not completely unstable, or
C                    JOB = 'C' and AW is not stable;
C             =  3:  both above conditions appear.
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:  the reduction of AV to a real Schur form failed;
C             =  2:  the reduction of AW to a real Schur form failed;
C             =  3:  the solution of the Sylvester equation failed
C                    because the matrices A and AV have common
C                    eigenvalues (if JOB = 'N'), or -AV and A have
C                    common eigenvalues (if JOB = 'C' and DICO = 'C'),
C                    or AV has an eigenvalue which is the reciprocal of
C                    one of the eigenvalues of A (if JOB = 'C' and
C                    DICO = 'D');
C             =  4:  the solution of the Sylvester equation failed
C                    because the matrices A and AW have common
C                    eigenvalues (if JOB = 'N'), or -AW and A have
C                    common eigenvalues (if JOB = 'C' and DICO = 'C'),
C                    or AW has an eigenvalue which is the reciprocal of
C                    one of the eigenvalues of A (if JOB = 'C' and
C                    DICO = 'D').
C
C     METHOD
C
C     The matrices of the stable projection of V*G*W are computed as
C
C       BS = B*DW + Y*BW,  CS = CV*X + DV*C,  DS = DV*D*DW,
C
C     where X and Y satisfy the continuous-time Sylvester equations
C
C       AV*X - X*A  + BV*C = 0,
C       -A*Y + Y*AW + B*CW = 0.
C
C     The matrices of the stable projection of conj(V)*G*conj(W) are
C     computed using the explicit formulas established in [1].
C
C     For a continuous-time system, the matrices BS, CS and DS of
C     the stable projection are computed as
C
C       BS = B*DW' + Y*CW',  CS = BV'*X + DV'*C,  DS = DV'*D*DW',
C
C     where X and Y satisfy the continuous-time Sylvester equations
C
C       AV'*X + X*A   + CV'*C = 0,
C         A*Y + Y*AW' + B*BW' = 0.
C
C     For a discrete-time system, the matrices BS, CS and DS of
C     the stable projection are computed as
C
C       BS = B*DW' + A*Y*CW',  CS = BV'*X*A + DV'*C,
C       DS = DV'*D*DW' + BV'*X*B*DW' + DV'*C*Y*CW' + BV'*X*A*Y*CW',
C
C     where X and Y satisfy the discrete-time Sylvester equations
C
C       AV'*X*A + CV'*C = X,
C       A*Y*AW' + B*BW' = Y.
C
C     REFERENCES
C
C     [1] Varga A.
C         Explicit formulas for an efficient implementation
C         of the frequency-weighting model reduction approach.
C         Proc. 1993 European Control Conference, Groningen, NL,
C         pp. 693-696, 1993.
C
C     NUMERICAL ASPECTS
C
C     The implemented methods rely on numerically stable algorithms.
C
C     FURTHER COMMENTS
C
C     The matrix A must be stable, but its stability is not checked by
C     this routine.
C
C     CONTRIBUTORS
C
C     A. Varga, German Aerospace Center, Oberpfaffenhofen, April 2000.
C     D. Sima, University of Bucharest, May 2000.
C     V. Sima, Research Institute for Informatics, Bucharest, May 2000.
C     Based on the RASP routines SFRLW, SFRLW1, SFRRW and SFRRW1,
C     by A. Varga, 1992.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Frequency weighting, model reduction, multivariable system,
C     state-space model, state-space representation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER        DICO, JOB, WEIGHT
      INTEGER          INFO, IWARN, LDA, LDAV, LDAW, LDB, LDBV, LDBW,
     $                 LDC, LDCV, LDCW, LDD, LDDV, LDDW, LDWORK, M, N,
     $                 NV, NW, P
C     .. Array Arguments ..
      DOUBLE PRECISION A(LDA,*),   B(LDB,*),   C(LDC,*),   D(LDD,*),
     $                 AV(LDAV,*), BV(LDBV,*), CV(LDCV,*), DV(LDDV,*),
     $                 AW(LDAW,*), BW(LDBW,*), CW(LDCW,*), DW(LDDW,*),
     $                 DWORK(*)
C     .. Local Scalars
      LOGICAL          CONJS, DISCR, FRWGHT, LEFTW, RIGHTW
      DOUBLE PRECISION SCALE, WORK
      INTEGER          I, IA, IB, IERR, KW, LDW, LDWN, LW
C     .. External Functions ..
      LOGICAL          LSAME
      DOUBLE PRECISION DLAPY2
      EXTERNAL         DLAPY2, LSAME
C     .. External Subroutines ..
      EXTERNAL         DGEMM, DLACPY, DTRSYL, SB04PY, TB01WD, XERBLA
C     .. Executable Statements ..
C
      CONJS  = LSAME( JOB,    'C' )
      DISCR  = LSAME( DICO,   'D' )
      LEFTW  = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' )
      RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' )
      FRWGHT = LEFTW .OR. RIGHTW
C
      IWARN = 0
      INFO  = 0
      IF ( DISCR .AND. CONJS ) THEN
         IA = 2*NV
         IB = 2*NW
      ELSE
         IA = 0
         IB = 0
      END IF
      LW = 1
      IF( LEFTW )
     $   LW = MAX( LW, NV*( NV + 5 ), NV*N + MAX( IA, P*N, P*M ) )
      IF( RIGHTW )
     $   LW = MAX( LW, NW*( NW + 5 ), NW*N + MAX( IB, M*N, P*M ) )
C
C     Test the input scalar arguments.
C
      IF( .NOT. ( LSAME( JOB, 'N' ) .OR. CONJS ) ) THEN
         INFO = -1
      ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( NV.LT.0 ) THEN
         INFO = -5
      ELSE IF( NW.LT.0 ) THEN
         INFO = -6
      ELSE IF( M.LT.0 ) THEN
         INFO = -7
      ELSE IF( P.LT.0 ) THEN
         INFO = -8
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -12
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -14
      ELSE IF( LDD.LT.MAX( 1, P ) ) THEN
         INFO = -16
      ELSE IF( LDAV.LT.1 .OR. ( LEFTW  .AND. LDAV.LT.NV ) ) THEN
         INFO = -18
      ELSE IF( LDBV.LT.1 .OR. ( LEFTW  .AND. LDBV.LT.NV ) ) THEN
         INFO = -20
      ELSE IF( LDCV.LT.1 .OR. ( LEFTW  .AND. LDCV.LT.P  ) ) THEN
         INFO = -22
      ELSE IF( LDDV.LT.1 .OR. ( LEFTW  .AND. LDDV.LT.P  ) ) THEN
         INFO = -24
      ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN
         INFO = -26
      ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN
         INFO = -28
      ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M  ) ) THEN
         INFO = -30
      ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M  ) ) THEN
         INFO = -32
      ELSE IF( LDWORK.LT.LW ) THEN
         INFO = -34
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB09KX', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( .NOT.FRWGHT .OR. MIN( M, P ).EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      WORK = ONE
      IF( LEFTW .AND. NV.GT.0 ) THEN
C
C        Reduce AV to a real Schur form using an orthogonal similarity
C        transformation AV <- Q'*AV*Q and apply the transformation to
C        BV and CV: BV <- Q'*BV and CV <- CV*Q.
C
C        Workspace needed:  NV*(NV+5);
C                           prefer larger.
C
         KW = NV*( NV + 2 ) + 1
         CALL TB01WD( NV, P, P, AV, LDAV, BV, LDBV, CV, LDCV,
     $                DWORK(2*NV+1), NV, DWORK, DWORK(NV+1), DWORK(KW),
     $                LDWORK-KW+1, IERR )
         IF( IERR.NE.0 ) THEN
            INFO = 1
            RETURN
         END IF
         WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) )
C
         IF( CONJS ) THEN
C
C           Check the stability of the eigenvalues of AV.
C
            IF ( DISCR ) THEN
               DO 10 I = 1, NV
                  IF( DLAPY2( DWORK(I), DWORK(NV+I) ).GE.ONE) THEN
                     IWARN = 1
                     GO TO 50
                  END IF
   10          CONTINUE
            ELSE
               DO 20 I = 1, NV
                  IF( DWORK(I).GE.ZERO ) THEN
                     IWARN = 1
                     GO TO 50
                  END IF
   20          CONTINUE
            END IF
         ELSE
C
C           Check the anti-stability of the eigenvalues of AV.
C
            IF ( DISCR ) THEN
               DO 30 I = 1, NV
                  IF( DLAPY2( DWORK(I), DWORK(NV+I) ).LE.ONE) THEN
                     IWARN = 1
                     GO TO 50
                  END IF
   30          CONTINUE
            ELSE
               DO 40 I = 1, NV
                  IF( DWORK(I).LE.ZERO ) THEN
                     IWARN = 1
                     GO TO 50
                  END IF
   40          CONTINUE
            END IF
         END IF
   50    CONTINUE
C
      END IF
C
      IF( RIGHTW .AND. NW.GT.0 ) THEN
C
C        Reduce AW to a real Schur form using an orthogonal similarity
C        transformation AW <- T'*AW*T and apply the transformation to
C        BW and CW: BW <- T'*BW and CW <- CW*T.
C
C        Workspace needed:  NW*(NW+5);
C                           prefer larger.
C
         KW = NW*( NW + 2 ) + 1
         CALL TB01WD( NW, M, M, AW, LDAW, BW, LDBW, CW, LDCW,
     $                DWORK(2*NW+1), NW, DWORK, DWORK(NW+1), DWORK(KW),
     $                LDWORK-KW+1, IERR )
         IF( IERR.NE.0 ) THEN
            INFO = 2
            RETURN
         END IF
         WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) )
C
         IF( CONJS ) THEN
C
C           Check the stability of the eigenvalues of AW.
C
            IF ( DISCR ) THEN
               DO 60 I = 1, NW
                  IF( DLAPY2( DWORK(I), DWORK(NW+I) ).GE.ONE) THEN
                     IWARN = IWARN + 2
                     GO TO 100
                  END IF
   60          CONTINUE
            ELSE
               DO 70 I = 1, NW
                  IF( DWORK(I).GE.ZERO ) THEN
                     IWARN = IWARN + 2
                     GO TO 100
                  END IF
   70          CONTINUE
            END IF
         ELSE
C
C           Check the anti-stability of the eigenvalues of AW.
C
            IF ( DISCR ) THEN
               DO 80 I = 1, NW
                  IF( DLAPY2( DWORK(I), DWORK(NW+I) ).LE.ONE) THEN
                     IWARN = IWARN + 2
                     GO TO 100
                  END IF
   80          CONTINUE
            ELSE
               DO 90 I = 1, NW
                  IF( DWORK(I).LE.ZERO ) THEN
                     IWARN = IWARN + 2
                     GO TO 100
                  END IF
   90          CONTINUE
            END IF
         END IF
  100    CONTINUE
      END IF
C
      IF( LEFTW ) THEN
         LDW = MAX( NV, 1 )
         KW  = NV*N + 1
         IF( CONJS ) THEN
C
C           Compute the projection of conj(V)*G.
C
C           Total workspace needed:  NV*N + MAX( a, P*N, P*M ), where
C                                    a = 0,    if DICO = 'C',
C                                    a = 2*NV, if DICO = 'D'.
C
C           Compute -CV'*C.
C           Workspace needed: NV*N.
C
            CALL DGEMM( 'T', 'N', NV, N, P, -ONE, CV, LDCV, C, LDC,
     $                  ZERO, DWORK, LDW )
C
            IF( DISCR ) THEN
C
C              Compute X and SCALE satisfying
C
C              AV'*X*A - X = -SCALE*CV'*C.
C
C              Additional workspace needed: 2*NV.
C
               CALL SB04PY( 'T', 'N', -1, NV, N, AV, LDAV, A, LDA,
     $                      DWORK, LDW, SCALE, DWORK(KW), IERR )
               IF( IERR.NE.0 ) THEN
                  INFO = 3
                  RETURN
               END IF
C
C              Construct C <- DV'*C + BV'*X*A/SCALE,
C                        D <- DV'*D + BV'*X*B/SCALE.
C
C              Additional workspace needed: MAX( P*N, P*M ).
C
C              C <- DV'*C.
C
               CALL DGEMM( 'T', 'N', P, N, P, ONE, DV, LDDV, C, LDC,
     $                      ZERO, DWORK(KW), P )
               CALL DLACPY( 'F', P, N, DWORK(KW), P, C, LDC )
C
C              D <- DV'*D.
C
               CALL DGEMM( 'T', 'N', P, M, P, ONE, DV, LDDV, D, LDD,
     $                      ZERO, DWORK(KW), P )
               CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD )
C
C              C <- C + BV'*X*A/SCALE.
C
               CALL DGEMM( 'T', 'N', P, N, NV, ONE / SCALE, BV, LDBV,
     $                     DWORK, LDW, ZERO, DWORK(KW), P )
               CALL DGEMM( 'N', 'N', P, N, N, ONE, DWORK(KW), P, A, LDA,
     $                     ONE, C, LDC )
C
C              D <- D + BV'*X*B/SCALE.
C
               CALL DGEMM( 'N', 'N', P, M, N, ONE, DWORK(KW), P, B, LDB,
     $                     ONE, D, LDD )
            ELSE
C
C              Compute X and SCALE satisfying
C
C              AV'*X + X*A + SCALE*CV'*C = 0.
C
               CALL DTRSYL( 'T', 'N', 1, NV, N, AV, LDAV, A, LDA,
     $                      DWORK, LDW, SCALE, IERR )
               IF( IERR.NE.0 ) THEN
                  INFO = 3
                  RETURN
               END IF
C
C              Construct C and D.
C              Additional workspace needed: MAX( P*N, P*M ).
C
C              Construct C <- BV'*X/SCALE + DV'*C.
C
               CALL DGEMM( 'T', 'N', P, N, P, ONE, DV, LDDV, C, LDC,
     $                     ZERO, DWORK(KW), P )
               CALL DLACPY( 'F', P, N, DWORK(KW), P, C, LDC )
               CALL DGEMM( 'T', 'N', P, N, NV, ONE / SCALE, BV, LDBV,
     $                     DWORK, LDW, ONE, C, LDC )
C
C              Construct D <- DV'*D.
C
               CALL DGEMM( 'T', 'N', P, M, P, ONE, DV, LDDV, D, LDD,
     $                     ZERO, DWORK(KW), P )
               CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD )
            END IF
         ELSE
C
C           Compute the projection of V*G.
C
C           Total workspace needed:  NV*N + MAX( P*N, P*M ).
C
C           Compute -BV*C.
C           Workspace needed: NV*N.
C
            CALL DGEMM( 'N', 'N', NV, N, P, -ONE, BV, LDBV, C, LDC,
     $                  ZERO, DWORK, LDW )
C
C           Compute X and SCALE satisfying
C
C           AV*X - X*A + SCALE*BV*C = 0.
C
            CALL DTRSYL( 'N', 'N', -1, NV, N, AV, LDAV, A, LDA,
     $                   DWORK, LDW, SCALE, IERR )
            IF( IERR.NE.0 ) THEN
               INFO = 3
               RETURN
            END IF
C
C           Construct C <- CV*X/SCALE + DV*C.
C
            CALL DGEMM( 'N', 'N', P, N, P, ONE, DV, LDDV, C, LDC,
     $                  ZERO, DWORK(KW), P )
            CALL DLACPY( 'F', P, N, DWORK(KW), P, C, LDC )
            CALL DGEMM( 'N', 'N', P, N, NV, ONE / SCALE, CV, LDCV,
     $                  DWORK, LDW, ONE, C, LDC )
C
C           Construct D <- DV*D.
C
            CALL DGEMM( 'N', 'N', P, M, P, ONE, DV, LDDV, D, LDD,
     $                  ZERO, DWORK(KW), P )
            CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD )
         END IF
      END IF
C
      IF( RIGHTW ) THEN
         LDWN = MAX( N, 1 )
         KW   = N*NW + 1
         IF( CONJS ) THEN
C
C           Compute the projection of G*conj(W) or of conj(V)*G*conj(W).
C
C           Total workspace needed:  NW*N + MAX( b, M*N, P*M ), where
C                                    b = 0,    if DICO = 'C',
C                                    b = 2*NW, if DICO = 'D'.
C
C           Compute -BW*B'.
C           Workspace needed: N*NW.
C
            LDW = MAX( NW, 1 )
            CALL DGEMM( 'N', 'T', NW, N, M, -ONE, BW, LDBW, B, LDB,
     $                  ZERO, DWORK, LDW )
C
            IF( DISCR ) THEN
C
C              Compute Y' and SCALE satisfying
C
C              AW*Y'*A' - Y' = -SCALE*BW*B'.
C
C              Additional workspace needed: 2*NW.
C
               CALL SB04PY( 'N', 'T', -1, NW, N, AW, LDAW, A, LDA,
     $                      DWORK, LDW, SCALE, DWORK(KW), IERR )
               IF( IERR.NE.0 ) THEN
                  INFO = 4
                  RETURN
               END IF
C
C              Construct B <- B*DW' + A*Y*CW'/SCALE,
C                        D <- D*DW' + C*Y*CW'/SCALE.
C
C              Additional workspace needed: MAX( N*M, P*M ).
C
C              B <- B*DW'.
C
               CALL DGEMM( 'N', 'T', N, M, M, ONE, B, LDB, DW, LDDW,
     $                     ZERO, DWORK(KW), LDWN )
               CALL DLACPY( 'F', N, M, DWORK(KW), LDWN, B, LDB )
C
C              D <- D*DW'.
C
               CALL DGEMM( 'N', 'T', P, M, M, ONE, D, LDD, DW, LDDW,
     $                    ZERO, DWORK(KW), P )
               CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD )
C
C              B <- B + A*Y*CW'/SCALE.
C
               CALL DGEMM( 'T', 'T', N, M, NW, ONE / SCALE, DWORK, LDW,
     $                     CW, LDCW, ZERO, DWORK(KW), LDWN )
               CALL DGEMM( 'N', 'N', N, M, N, ONE, A, LDA,
     $                     DWORK(KW), LDWN, ONE, B, LDB )
C
C              D <- D + C*Y*CW'/SCALE.
C
               CALL DGEMM( 'N', 'N', P, M, N, ONE, C, LDC,
     $                     DWORK(KW), LDWN, ONE, D, LDD )
            ELSE
C
C              Compute Y' and SCALE satisfying
C
C              AW*Y' + Y'*A' + SCALE*BW*B' = 0.
C
               CALL DTRSYL( 'N', 'T', 1, NW, N, AW, LDAW, A, LDA,
     $                      DWORK, LDW, SCALE, IERR )
               IF( IERR.NE.0 ) THEN
                  INFO = 4
                  RETURN
               END IF
C
C              Construct B and D.
C              Additional workspace needed: MAX( N*M, P*M ).
C
C              Construct B <- B*DW' + Y*CW'/SCALE.
C
               CALL DGEMM( 'N', 'T', N, M, M, ONE, B, LDB, DW, LDDW,
     $                     ZERO, DWORK(KW), LDWN )
               CALL DLACPY( 'F', N, M, DWORK(KW), LDWN, B, LDB )
               CALL DGEMM( 'T', 'T', N, M, NW, ONE / SCALE, DWORK, LDW,
     $                     CW, LDCW, ONE, B, LDB)
C
C              D <- D*DW'.
C
               CALL DGEMM( 'N', 'T', P, M, M, ONE, D, LDD, DW, LDDW,
     $                     ZERO, DWORK(KW), P )
               CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD )
            END IF
         ELSE
C
C           Compute the projection of G*W or of V*G*W.
C
C           Total workspace needed:  NW*N + MAX( M*N, P*M ).
C
C           Compute B*CW.
C           Workspace needed: N*NW.
C
            CALL DGEMM( 'N', 'N', N, NW, M, ONE, B, LDB, CW, LDCW,
     $                  ZERO, DWORK, LDWN )
C
C           Compute Y and SCALE satisfying
C
C           A*Y - Y*AW - SCALE*B*CW = 0.
C
            CALL DTRSYL( 'N', 'N', -1, N, NW, A, LDA, AW, LDAW,
     $                   DWORK, LDWN, SCALE, IERR )
            IF( IERR.NE.0 ) THEN
               INFO = 4
               RETURN
            END IF
C
C           Construct B and D.
C           Additional workspace needed: MAX( N*M, P*M ).
C           Construct B <- B*DW + Y*BW/SCALE.
C
            CALL DGEMM( 'N', 'N', N, M, M, ONE, B, LDB, DW, LDDW,
     $                  ZERO, DWORK(KW), LDWN )
            CALL DLACPY( 'F', N, M, DWORK(KW), LDWN, B, LDB )
            CALL DGEMM( 'N', 'N', N, M, NW, ONE / SCALE, DWORK, LDWN,
     $                  BW, LDBW, ONE, B, LDB)
C
C           D <- D*DW.
C
            CALL DGEMM( 'N', 'N', P, M, M, ONE, D, LDD, DW, LDDW,
     $                  ZERO, DWORK(KW), P )
            CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD )
         END IF
      END IF
C
      DWORK(1) = MAX( WORK, DBLE( LW ) )
C
      RETURN
C *** Last line of AB09KX ***
      END
