C
C SPDX-License-Identifier: BSD-3-Clause
C
      SUBROUTINE AB09DD( DICO, N, M, P, NR, A, LDA, B, LDB, C, LDC,
     $                   D, LDD, RCOND, IWORK, DWORK, INFO )
C
C     PURPOSE
C
C     To compute a reduced order model by using singular perturbation
C     approximation formulas.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the original system as follows:
C             = 'C':  continuous-time system;
C             = 'D':  discrete-time system.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The dimension of the state vector, i.e. the order of the
C             matrix A; also the number of rows of matrix B and the
C             number of columns of the matrix C.  N >= 0.
C
C     M       (input) INTEGER
C             The dimension of input vector, i.e. the number of columns
C             of matrices B and D.  M >= 0.
C
C     P       (input) INTEGER
C             The dimension of output vector, i.e. the number of rows of
C             matrices C and D.  P >= 0.
C
C     NR      (input) INTEGER
C             The order of the reduced order system.  N >= NR >= 0.
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 state dynamics matrix of the original system.
C             On exit, the leading NR-by-NR part of this array contains
C             the state dynamics matrix Ar of the reduced order system.
C
C     LDA     INTEGER
C             The leading dimension of 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/state matrix of the original system.
C             On exit, the leading NR-by-M part of this array contains
C             the input/state matrix Br of the reduced order system.
C
C     LDB     INTEGER
C             The leading dimension of 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 state/output matrix of the original system.
C             On exit, the leading P-by-NR part of this array contains
C             the state/output matrix Cr of the reduced order system.
C
C     LDC     INTEGER
C             The leading dimension of 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 input/output matrix of the original system.
C             On exit, the leading P-by-M part of this array contains
C             the input/output matrix Dr of the reduced order system.
C             If NR = 0 and the given system is stable, then D contains
C             the steady state gain of the system.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,P).
C
C     RCOND   (output) DOUBLE PRECISION
C             The reciprocal condition number of the matrix A22-g*I
C             (see METHOD).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (2*(N-NR))
C
C     DWORK   DOUBLE PRECISION array, dimension (4*(N-NR))
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 matrix A22-g*I (see METHOD) is numerically
C                  singular.
C
C     METHOD
C
C     Given the system (A,B,C,D), partition the system matrices as
C
C            ( A11 A12 )        ( B1 )
C        A = (         ) ,  B = (    ) ,  C = ( C1  C2 ),
C            ( A21 A22 )        ( B2 )
C
C     where A11 is NR-by-NR, B1 is NR-by-M, C1 is P-by-NR, and the other
C     submatrices have appropriate dimensions.
C
C     The matrices of the reduced order system (Ar,Br,Cr,Dr) are
C     computed according to the following residualization formulas:
C                                -1                               -1
C        Ar = A11 + A12*(g*I-A22)  *A21 ,  Br = B1 + A12*(g*I-A22)  *B2
C                              -1                               -1
C        Cr = C1 + C2*(g*I-A22)  *A21   ,  Dr = D + C2*(g*I-A22)  *B2
C
C     where g = 0 if DICO = 'C' and g = 1 if DICO = 'D'.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen,
C     March 1998.
C     Based on the RASP routine SRESID.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Model reduction, multivariable system, state-space model.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO
      INTEGER           INFO, LDA, LDB, LDC, LDD, M, N, NR, P
      DOUBLE PRECISION  RCOND
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*)
      INTEGER           IWORK(*)
C     .. Local Scalars
      LOGICAL           DISCR
      INTEGER           I, J, K, NS
      DOUBLE PRECISION  A22NRM
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANGE
      EXTERNAL          DLAMCH, DLANGE, LSAME
C     .. External Subroutines ..
      EXTERNAL          DGECON, DGEMM, DGETRF, DGETRS, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     .. Executable Statements ..
C
C     Check the input scalar arguments.
C
      INFO = 0
      DISCR = LSAME( DICO, 'D' )
      IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( P.LT.0 ) THEN
         INFO = -4
      ELSE IF( NR.LT.0 .OR. NR.GT.N ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -11
      ELSE IF( LDD.LT.MAX( 1, P ) ) THEN
         INFO = -13
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB09DD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( NR.EQ.N ) THEN
         RCOND = ONE
         RETURN
      END IF
C
      K  = NR + 1
      NS = N - NR
C
C     Compute: T = -A22   if  DICO = 'C' and
C              T = -A22+I if  DICO = 'D'.
C
      DO 20 J = K, N
         DO 10 I = K, N
            A(I,J) = -A(I,J)
   10    CONTINUE
         IF( DISCR ) A(J,J) = A(J,J) + ONE
   20 CONTINUE
C
C     Compute the LU decomposition of T.
C
      A22NRM = DLANGE( '1-norm', NS, NS, A(K,K), LDA, DWORK )
      CALL DGETRF( NS, NS, A(K,K), LDA, IWORK, INFO )
      IF( INFO.GT.0 ) THEN
C
C        Error return.
C
         RCOND = ZERO
         INFO = 1
         RETURN
      END IF
      CALL DGECON( '1-norm', NS, A(K,K), LDA, A22NRM, RCOND, DWORK,
     $             IWORK(NS+1), INFO )
      IF( RCOND.LE.DLAMCH('E') ) THEN
C
C        Error return.
C
         INFO = 1
         RETURN
      END IF
C
C     Compute A21 <- INV(T)*A21.
C
      CALL DGETRS( 'NoTranspose', NS, NR, A(K,K), LDA, IWORK, A(K,1),
     $             LDA, INFO )
C
C     Compute B2 <- INV(T)*B2.
C
      CALL DGETRS( 'NoTranspose', NS, M, A(K,K), LDA, IWORK, B(K,1),
     $             LDB, INFO )
C
C     Compute the residualized systems matrices.
C     Ar = A11 + A12*INV(T)*A21.
C
      CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, NS, ONE, A(1,K),
     $            LDA, A(K,1), LDA, ONE, A, LDA )
C
C     Br = B1 + A12*INV(T)*B2.
C
      CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, M, NS, ONE, A(1,K),
     $            LDA, B(K,1), LDB, ONE, B, LDB )
C
C     Cr = C1 + C2*INV(T)*A21.
C
      CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NR, NS, ONE, C(1,K),
     $            LDC, A(K,1), LDA, ONE, C, LDC )
C
C     Dr = D + C2*INV(T)*B2.
C
      CALL DGEMM( 'NoTranspose', 'NoTranspose', P, M, NS, ONE, C(1,K),
     $            LDC, B(K,1), LDB, ONE, D, LDD )
C
      RETURN
C *** Last line of AB09DD ***
      END
