C
C SPDX-License-Identifier: BSD-3-Clause
C
      SUBROUTINE TC04AD( LERI, M, P, INDEX, PCOEFF, LDPCO1, LDPCO2,
     $                   QCOEFF, LDQCO1, LDQCO2, N, RCOND, A, LDA, B,
     $                   LDB, C, LDC, D, LDD, IWORK, DWORK, LDWORK,
     $                   INFO )
C
C     PURPOSE
C
C     To find a state-space representation (A,B,C,D) with the same
C     transfer matrix T(s) as that of a given left or right polynomial
C     matrix representation, i.e.
C
C        C*inv(sI-A)*B + D = T(s) = inv(P(s))*Q(s) = Q(s)*inv(P(s)).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     LERI    CHARACTER*1
C             Indicates whether a left polynomial matrix representation
C             or a right polynomial matrix representation is input as
C             follows:
C             = 'L':  A left matrix fraction is input;
C             = 'R':  A right matrix fraction is input.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     INDEX   (input) INTEGER array, dimension (MAX(M,P))
C             If LERI = 'L', INDEX(I), I = 1,2,...,P, must contain the
C             maximum degree of the polynomials in the I-th row of the
C             denominator matrix P(s) of the given left polynomial
C             matrix representation.
C             If LERI = 'R', INDEX(I), I = 1,2,...,M, must contain the
C             maximum degree of the polynomials in the I-th column of
C             the denominator matrix P(s) of the given right polynomial
C             matrix representation.
C
C     PCOEFF  (input) DOUBLE PRECISION array, dimension
C             (LDPCO1,LDPCO2,kpcoef), where kpcoef = MAX(INDEX(I)) + 1.
C             If LERI = 'L' then porm = P, otherwise porm = M.
C             The leading porm-by-porm-by-kpcoef part of this array must
C             contain the coefficients of the denominator matrix P(s).
C             PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1)
C             of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if
C             LERI = 'L' then iorj = I, otherwise iorj = J.
C             Thus for LERI = 'L', P(s) =
C             diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...).
C             If LERI = 'R', PCOEFF is modified by the routine but
C             restored on exit.
C
C     LDPCO1  INTEGER
C             The leading dimension of array PCOEFF.
C             LDPCO1 >= MAX(1,P) if LERI = 'L',
C             LDPCO1 >= MAX(1,M) if LERI = 'R'.
C
C     LDPCO2  INTEGER
C             The second dimension of array PCOEFF.
C             LDPCO2 >= MAX(1,P) if LERI = 'L',
C             LDPCO2 >= MAX(1,M) if LERI = 'R'.
C
C     QCOEFF  (input) DOUBLE PRECISION array, dimension
C             (LDQCO1,LDQCO2,kpcoef)
C             If LERI = 'L' then porp = M, otherwise porp = P.
C             The leading porm-by-porp-by-kpcoef part of this array must
C             contain the coefficients of the numerator matrix Q(s).
C             QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K).
C             If LERI = 'R', QCOEFF is modified by the routine but
C             restored on exit.
C
C     LDQCO1  INTEGER
C             The leading dimension of array QCOEFF.
C             LDQCO1 >= MAX(1,P)   if LERI = 'L',
C             LDQCO1 >= MAX(1,M,P) if LERI = 'R'.
C
C     LDQCO2  INTEGER
C             The second dimension of array QCOEFF.
C             LDQCO2 >= MAX(1,M)   if LERI = 'L',
C             LDQCO2 >= MAX(1,M,P) if LERI = 'R'.
C
C     N       (output) INTEGER
C             The order of the resulting state-space representation.
C                          porm
C             That is, N = SUM INDEX(I).
C                          I=1
C
C     RCOND   (output) DOUBLE PRECISION
C             The estimated reciprocal of the condition number of the
C             leading row (if LERI = 'L') or the leading column (if
C             LERI = 'R') coefficient matrix of P(s).
C             If RCOND is nearly zero, P(s) is nearly row or column
C             non-proper.
C
C     A       (output) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array contains the state
C             dynamics matrix A.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (output) DOUBLE PRECISION array, dimension (LDB,MAX(M,P))
C             The leading N-by-M part of this array contains the
C             input/state matrix B; the remainder of the leading
C             N-by-MAX(M,P) part is used as internal workspace.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (output) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading P-by-N part of this array contains the
C             state/output matrix C; the remainder of the leading
C             MAX(M,P)-by-N part is used as internal workspace.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,M,P).
C
C     D       (output) DOUBLE PRECISION array, dimension (LDD,MAX(M,P))
C             The leading P-by-M part of this array contains the direct
C             transmission matrix D; the remainder of the leading
C             MAX(M,P)-by-MAX(M,P) part is used as internal workspace.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,M,P).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (2*MAX(M,P))
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,MAX(M,P)*(MAX(M,P)+4)).
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 P(s) is not row (if LERI = 'L') or column
C                   (if LERI = 'R') proper. Consequently, no state-space
C                   representation is calculated.
C
C     METHOD
C
C     The method for a left matrix fraction will be described here;
C     right matrix fractions are dealt with by obtaining the dual left
C     polynomial matrix representation and constructing an equivalent
C     state-space representation for this. The first step is to check
C     if the denominator matrix P(s) is row proper; if it is not then
C     the routine returns with the Error Indicator (INFO) set to 1.
C     Otherwise, Wolovich's Observable  Structure Theorem is used to
C     construct a state-space representation (A,B,C,D) in observable
C     companion form. The sizes of the blocks of matrix A and matrix C
C     here are precisely the row degrees of P(s), while their
C     'non-trivial' columns are given easily from its coefficients.
C     Similarly, the matrix D is obtained from the leading coefficients
C     of P(s) and of the numerator matrix Q(s), while matrix B is given
C     by the relation Sbar(s)B = Q(s) - P(s)D, where Sbar(s) is a
C     polynomial matrix whose (j,k)(th) element is given by
C
C                  j-u(k-1)-1
C               ( s           , j = u(k-1)+1,u(k-1)+2,....,u(k)
C     Sbar    = (
C        j,k    (           0 , otherwise
C
C             k
C     u(k) = SUM d , k = 1,2,...,M and d ,d ,...,d  are the
C            i=1  i                     1  2      M
C     controllability indices. For convenience in solving this, C' and B
C     are initially set up to contain the coefficients of P(s) and Q(s),
C     respectively, stored by rows.
C
C     REFERENCES
C
C     [1] Wolovich, W.A.
C         Linear Multivariate Systems, (Theorem 4.3.3).
C         Springer-Verlag, 1974.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996.
C     Supersedes Release 2.0 routine TC01BD by T.W.C.Williams, Kingston
C     Polytechnic, United Kingdom, March 1982.
C
C     REVISIONS
C
C     February 22, 1998 (changed the name of TC01ND).
C     May 12, 1998.
C
C     KEYWORDS
C
C     Coprime matrix fraction, elementary polynomial operations,
C     polynomial matrix, state-space representation, transfer matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         LERI
      INTEGER           INFO, LDA, LDB, LDC, LDD, LDPCO1, LDPCO2,
     $                  LDQCO1, LDQCO2, LDWORK, M, N, P
      DOUBLE PRECISION  RCOND
C     .. Array Arguments ..
      INTEGER           INDEX(*), IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*),
     $                  DWORK(*), PCOEFF(LDPCO1,LDPCO2,*),
     $                  QCOEFF(LDQCO1,LDQCO2,*)
C     .. Local Scalars ..
      LOGICAL           LLERI
      INTEGER           I, IA, IBIAS, J, JA, JC, JW, JWORK, LDW, K,
     $                  KPCOEF, KSTOP, MAXIND, MINDEX, MWORK, PWORK,
     $                  WRKOPT
      DOUBLE PRECISION  DWNORM
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANGE
      EXTERNAL          LSAME, DLAMCH, DLANGE
C     .. External Subroutines ..
      EXTERNAL          AB07MD, DCOPY, DGECON, DGEMM, DGETRF, DGETRI,
     $                  DGETRS, DLACPY, DLASET, TC01OD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX
C     .. Executable Statements ..
C
      INFO = 0
      LLERI = LSAME( LERI, 'L' )
      MINDEX = MAX( M, P )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 ) THEN
         INFO = -3
      ELSE IF( ( LLERI .AND. LDPCO1.LT.MAX( 1, P ) ) .OR.
     $    ( .NOT.LLERI .AND. LDPCO1.LT.MAX( 1, M ) ) ) THEN
         INFO = -6
      ELSE IF( ( LLERI .AND. LDPCO2.LT.MAX( 1, P ) ) .OR.
     $    ( .NOT.LLERI .AND. LDPCO2.LT.MAX( 1, M ) ) ) THEN
         INFO = -7
      ELSE IF( ( LLERI .AND. LDQCO1.LT.MAX( 1, P ) ) .OR.
     $    ( .NOT.LLERI .AND. LDQCO1.LT.MAX( 1, MINDEX ) ) ) THEN
         INFO = -9
      ELSE IF( ( LLERI .AND. LDQCO2.LT.MAX( 1, M ) ) .OR.
     $    ( .NOT.LLERI .AND. LDQCO2.LT.MAX( 1, MINDEX ) ) ) THEN
         INFO = -10
      END IF
C
      N = 0
      IF ( INFO.EQ.0 ) THEN
         IF ( LLERI ) THEN
            PWORK = P
            MWORK = M
         ELSE
            PWORK = M
            MWORK = P
         END IF
C
         MAXIND = 0
         DO 10 I = 1, PWORK
            N = N + INDEX(I)
            IF ( INDEX(I).GT.MAXIND ) MAXIND = INDEX(I)
   10    CONTINUE
         KPCOEF = MAXIND + 1
      END IF
C
      IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -14
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -16
      ELSE IF( LDC.LT.MAX( 1, MINDEX ) ) THEN
         INFO = -18
      ELSE IF( LDD.LT.MAX( 1, MINDEX ) ) THEN
         INFO = -20
      ELSE IF( LDWORK.LT.MAX( 1, MINDEX*( MINDEX + 4 ) ) ) THEN
         INFO = -23
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TC04AD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( M.EQ.0 .OR. P.EQ.0 ) THEN
         N = 0
         RCOND = ONE
         DWORK(1) = ONE
         RETURN
      END IF
C
      IF ( .NOT.LLERI ) THEN
C
C        Initialization for right matrix fraction: obtain the dual
C        system.
C
         CALL TC01OD( 'R', M, P, KPCOEF, PCOEFF, LDPCO1, LDPCO2,
     $                QCOEFF, LDQCO1, LDQCO2, INFO )
      END IF
C
C     Store leading row coefficient matrix of P(s).
C
      LDW = MAX( 1, PWORK )
      CALL DLACPY( 'Full', PWORK, PWORK, PCOEFF, LDPCO1, DWORK, LDW )
C
C     Check if P(s) is row proper: if not, exit.
C
      DWNORM = DLANGE( '1-norm', PWORK, PWORK, DWORK, LDW, DWORK )
C
      CALL DGETRF( PWORK, PWORK, DWORK, LDW, IWORK, INFO )
C
C     Workspace: need  PWORK*(PWORK + 4).
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      JWORK = LDW*PWORK + 1
C
      CALL DGECON( '1-norm', PWORK, DWORK, LDW, DWNORM, RCOND,
     $             DWORK(JWORK), IWORK(PWORK+1), INFO )
C
      WRKOPT = MAX( 1, PWORK*(PWORK + 4) )
C
      IF ( RCOND.LE.DLAMCH( 'Epsilon' ) ) THEN
C
C        Error return: P(s) is not row proper.
C
         INFO = 1
         RETURN
      ELSE
C
C        Calculate the order of equivalent state-space representation,
C        and initialize A.
C
         CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
C
         DWORK(JWORK) = ONE
         IF ( N.GT.1 ) CALL DCOPY( N-1, DWORK(JWORK), 0, A(2,1), LDA+1 )
C
C        Find the PWORK ordered 'non-trivial' columns row by row,
C        in PWORK row blocks, the I-th having INDEX(I) rows.
C
         IBIAS = 2
C
         DO 50 I = 1, PWORK
            KSTOP = INDEX(I) + 1
            IF ( KSTOP.NE.1 ) THEN
               IBIAS = IBIAS + INDEX(I)
C
C              These rows given from the lower coefficients of row I
C              of P(s).
C
               DO 40 K = 2, KSTOP
                  IA = IBIAS - K
C
                  DO 20 J = 1, PWORK
                     DWORK(JWORK+J-1) = -PCOEFF(I,J,K)
   20             CONTINUE
C
                  CALL DGETRS( 'Transpose', PWORK, 1, DWORK, LDW,
     $                         IWORK, DWORK(JWORK), LDW, INFO )
C
                  JA = 0
C
                  DO 30 J = 1, PWORK
                     IF ( INDEX(J).NE.0 ) THEN
                        JA = JA + INDEX(J)
                        A(IA,JA) = DWORK(JWORK+J-1)
                     END IF
   30             CONTINUE
C
C                 Also, set up B and C (temporarily) for use when
C                 finding B.
C
                  CALL DCOPY( MWORK, QCOEFF(I,1,K), LDQCO1, B(IA,1),
     $                        LDB )
                  CALL DCOPY( PWORK, PCOEFF(I,1,K), LDPCO1, C(1,IA), 1 )
   40          CONTINUE
C
            END IF
   50    CONTINUE
C
C        Calculate D from the leading coefficients of P and Q.
C
         CALL DLACPY( 'Full', PWORK, MWORK, QCOEFF, LDQCO1, D, LDD )
C
         CALL DGETRS( 'No transpose', PWORK, MWORK, DWORK, LDW, IWORK,
     $                D, LDD, INFO )
C
C        For B and C as set up above, desired B = B - (C' * D).
C
         CALL DGEMM( 'Transpose', 'No transpose', N, MWORK, PWORK, -ONE,
     $               C, LDC, D, LDD, ONE, B, LDB )
C
C        Finally, calculate C: zero, apart from ...
C
         CALL DLASET( 'Full', PWORK, N, ZERO, ZERO, C, LDC )
C
C        PWORK ordered 'non-trivial' columns, equal to those
C        of inv(DWORK).
C
C        Workspace: need   PWORK*(PWORK + 1);
C                   prefer PWORK*PWORK + PWORK*NB.
C
         CALL DGETRI( PWORK, DWORK, LDW, IWORK, DWORK(JWORK),
     $                LDWORK-JWORK+1, INFO )
C
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
         JC = 0
         JW = 1
C
         DO 60 J = 1, PWORK
            IF ( INDEX(J).NE.0 ) THEN
               JC = JC + INDEX(J)
               CALL DCOPY( PWORK, DWORK(JW), 1, C(1,JC), 1 )
            END IF
            JW = JW + LDW
   60    CONTINUE
C
      END IF
C
C     For right matrix fraction, return to original (dual of dual)
C     system.
C
      IF ( .NOT.LLERI ) THEN
         CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1,
     $                LDPCO2, QCOEFF, LDQCO1, LDQCO2, INFO )
C
C        Also, obtain dual of state-space representation.
C
         CALL AB07MD( 'D', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D,
     $                LDD, INFO )
      END IF
C
C     Set optimal workspace dimension.
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of TC04AD ***
      END
