C
C SPDX-License-Identifier: BSD-3-Clause
C
      SUBROUTINE TG01ID( JOBOBS, COMPQ, COMPZ, N, M, P, A, LDA, E, LDE,
     $                   B, LDB, C, LDC, Q, LDQ, Z, LDZ, NOBSV, NIUOBS,
     $                   NLBLCK, CTAU, TOL, IWORK, DWORK, INFO )
C
C     PURPOSE
C
C     To compute orthogonal transformation matrices Q and Z which
C     reduce the N-th order descriptor system (A-lambda*E,B,C)
C     to the form
C
C                ( Ano  * )             ( Eno  * )           ( Bno )
C       Q'*A*Z = (        ) ,  Q'*E*Z = (        ) ,  Q'*B = (     ) ,
C                ( 0   Ao )             ( 0   Eo )           ( Bo  )
C
C          C*Z = ( 0   Co ) ,
C
C     where the NOBSV-th order descriptor system (Ao-lambda*Eo,Bo,Co)
C     is a finite and/or infinite observable. The pencil
C     Ano - lambda*Eno is regular of order N-NOBSV and contains the
C     unobservable finite and/or infinite eigenvalues of the pencil
C     A-lambda*E.
C
C     For JOBOBS = 'O' or 'I', the pencil ( Eo-lambda*Ao ) has full
C                                         (      Co      )
C     column rank NOBSV for all finite lambda and is in a staircase form
C     with
C                     _      _            _      _
C                   ( Ek,k   Ek,k-1   ... Ek,2   Ek,1   )
C                   ( _      _            _      _      )
C       ( Eo ) =    ( Ek-1,k Ek-1,k-1 ... Ek-1,2 Ek-1,1 ) ,  (1)
C       ( Co )      (     ...         ... _      _      )
C                   (  0       0      ... E1,2   E1,1   )
C                   (                            _      )
C                   (  0       0      ... 0      E0,1   )
C                     _          _      _
C                   ( Ak,k  ...  Ak,2   Ak,1 )
C                   (       ...  _      _    )
C         Ao      = (   0   ...  A2,2   A2,1 ) ,             (2)
C                   (                   _    )
C                   (   0   ...    0    A1,1 )
C           _
C     where Ei-1,i is a CTAU(i-1)-by-CTAU(i) full column rank matrix
C                            _
C     (with CTAU(0) = P) and Ai,i is a CTAU(i)-by-CTAU(i)
C     upper triangular matrix.
C
C     For JOBOBS = 'F', the pencil ( Ao-lambda*Eo ) has full
C                                  (      Co      )
C     column rank NOBSV for all finite lambda and is in a staircase form
C     with
C                     _      _            _      _
C                   ( Ak,k   Ak,k-1   ... Ak,2   Ak,1   )
C                   ( _      _            _      _      )
C       ( Ao ) =    ( Ak-1,k Ak-1,k-1 ... Ak-1,2 Ak-1,1 ) ,  (3)
C       ( Co )      (     ...         ... _      _      )
C                   (  0       0      ... A1,2   A1,1   )
C                   (                            _      )
C                   (  0       0      ... 0      A0,1   )
C                     _          _      _
C                   ( Ek,k  ...  Ek,2   Ek,1 )
C                   (       ...  _      _    )
C         Eo      = (   0   ...  E2,2   E2,1 ) ,             (4)
C                   (                   _    )
C                   (   0   ...    0    E1,1 )
C           _
C     where Ai-1,i is a CTAU(i-1)-by-CTAU(i) full column rank matrix
C                            _
C     (with CTAU(0) = P) and Ei,i is a CTAU(i)-by-CTAU(i)
C     upper triangular matrix.
C
C     For JOBOBS = 'O', the (N-NOBSV)-by-(N-NOBSV) regular pencil
C     Ano - lambda*Eno has the form
C
C                         ( Afno - lambda*Efno         *          )
C      Ano - lambda*Eno = (                                       ) ,
C                         (        0           Aino - lambda*Eino )
C
C     where:
C       1) the NIUOBS-by-NIUOBS regular pencil Aino - lambda*Eino,
C          with Aino upper triangular and nonsingular, contains the
C          unobservable infinite eigenvalues of A - lambda*E;
C       2) the (N-NOBSV-NIUOBS)-by-(N-NOBSV-NIUOBS) regular pencil
C          Afno - lambda*Efno, with Efno upper triangular and
C          nonsingular, contains the unobservable finite
C          eigenvalues of A - lambda*E.
C
C     Note: The significance of the two diagonal blocks can be
C           interchanged by calling the routine with the
C           arguments A and E interchanged. In this case,
C           Aino - lambda*Eino contains the unobservable zero
C           eigenvalues of A - lambda*E, while Afno - lambda*Efno
C           contains the unobservable nonzero finite and infinite
C           eigenvalues of A - lambda*E.
C
C     For JOBOBS = 'F', the pencil Ano - lambda*Eno has the form
C
C        Ano - lambda*Eno = Afno - lambda*Efno ,
C
C     where the regular pencil Afno - lambda*Efno, with Efno
C     upper triangular and nonsingular, contains the unobservable
C     finite eigenvalues of A - lambda*E.
C
C     For JOBOBS = 'I', the pencil Ano - lambda*Eno has the form
C
C        Ano - lambda*Eno = Aino - lambda*Eino ,
C
C     where the regular pencil Aino - lambda*Eino, with Aino
C     upper triangular and nonsingular, contains the unobservable
C     nonzero finite and infinite eigenvalues of A - lambda*E.
C
C     The left and/or right orthogonal transformations Q and Z
C     performed to reduce the system matrices can be optionally
C     accumulated.
C
C     The reduced order descriptor system (Ao-lambda*Eo,Bo,Co) has
C     the same transfer-function matrix as the original system
C     (A-lambda*E,B,C).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBOBS   CHARACTER*1
C             = 'O':  separate both finite and infinite unobservable
C                     eigenvalues;
C             = 'F':  separate only finite unobservable eigenvalues;
C             = 'I':  separate only nonzero finite and infinite
C                     unobservable eigenvalues.
C
C     COMPQ   CHARACTER*1
C             = 'N':  do not compute Q;
C             = 'I':  Q is initialized to the unit matrix, and the
C                     orthogonal matrix Q is returned;
C             = 'U':  Q must contain an orthogonal matrix Q1 on entry,
C                     and the product Q1*Q is returned.
C
C     COMPZ   CHARACTER*1
C             = 'N':  do not compute Z;
C             = 'I':  Z is initialized to the unit matrix, and the
C                     orthogonal matrix Z is returned;
C             = 'U':  Z must contain an orthogonal matrix Z1 on entry,
C                     and the product Z1*Z is returned.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The dimension of the descriptor state vector; also the
C             order of square matrices A and E, the number of rows of
C             matrix B, and the number of columns of matrix C.  N >= 0.
C
C     M       (input) INTEGER
C             The dimension of descriptor system input vector; also the
C             number of columns of matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The dimension of descriptor system output vector; also the
C             number of rows of matrix C.  P >= 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 N-by-N state matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the transformed state matrix Q'*A*Z,
C
C                                ( Ano  *  )
C                       Q'*A*Z = (         ) ,
C                                ( 0    Ao )
C
C             where Ao is NOBSV-by-NOBSV and Ano is
C             (N-NOBSV)-by-(N-NOBSV).
C             If JOBOBS = 'F', the matrix ( Ao ) is in the observability
C                                         ( Co )
C             staircase form (3).
C             If JOBOBS = 'O' or 'I', the submatrix Ao is upper
C             triangular.
C             If JOBOBS = 'O', the submatrix Ano has the form
C
C                             ( Afno   *  )
C                       Ano = (           ) ,
C                             (  0   Aino )
C
C             where the NIUOBS-by-NIUOBS matrix Aino is nonsingular and
C             upper triangular.
C             If JOBOBS = 'I', Ano is nonsingular and upper triangular.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading N-by-N part of this array must
C             contain the N-by-N descriptor matrix E.
C             On exit, the leading N-by-N part of this array contains
C             the transformed state matrix Q'*E*Z,
C
C                                ( Eno  *  )
C                       Q'*E*Z = (         ) ,
C                                ( 0    Eo )
C
C             where Eo is NOBSV-by-NOBSV and Eno is
C             (N-NOBSV)-by-(N-NOBSV).
C             If JOBOBS = 'O' or 'I', the matrix ( Eo ) is in the
C                                                ( Co )
C             observability staircase form (1).
C             If JOBOBS = 'F', the submatrix Eo is upper triangular.
C             If JOBOBS = 'O', the Eno matrix has the form
C
C                             ( Efno   *  )
C                       Eno = (           ) ,
C                             (  0   Eino )
C
C             where the NIUOBS-by-NIUOBS matrix Eino is nilpotent
C             and the (N-NOBSV-NIUOBS)-by-(N-NOBSV-NIUOBS) matrix Efno
C             is nonsingular and upper triangular.
C             If JOBOBS = 'F', Eno is nonsingular and upper triangular.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C             (LDB,MAX(M,P))
C             On entry, the leading N-by-M part of this array must
C             contain the N-by-M input matrix B.
C             On exit, the leading N-by-M part of this array contains
C             the transformed input matrix Q'*B.
C
C     LDB     INTEGER
C             The leading dimension of array B.
C             LDB >= MAX(1,N) if M > 0 or LDB >= 1 if M = 0.
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 C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed matrix
C
C                     C*Z = (  0   Co ) ,
C
C             where Co is P-by-NOBSV.
C             If JOBOBS = 'O' or 'I', the matrix ( Eo ) is in the
C                                                ( Co )
C             observability staircase form (1).
C             If JOBOBS = 'F', the matrix ( Ao ) is in the observability
C                                         ( Co )
C             staircase form (3).
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,M,P).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
C             If COMPQ = 'N': Q is not referenced.
C             If COMPQ = 'I': on entry, Q need not be set;
C                             on exit, the leading N-by-N part of this
C                             array contains the orthogonal matrix Q,
C                             where Q' is the product of transformations
C                             which are applied to A, E, and B on
C                             the left.
C             If COMPQ = 'U': on entry, the leading N-by-N part of this
C                             array must contain an orthogonal matrix
C                             Qc;
C                             on exit, the leading N-by-N part of this
C                             array contains the orthogonal matrix
C                             Qc*Q.
C
C     LDQ     INTEGER
C             The leading dimension of array Q.
C             LDQ >= 1,        if COMPQ = 'N';
C             LDQ >= MAX(1,N), if COMPQ = 'U' or 'I'.
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
C             If COMPZ = 'N': Z is not referenced.
C             If COMPZ = 'I': on entry, Z need not be set;
C                             on exit, the leading N-by-N part of this
C                             array contains the orthogonal matrix Z,
C                             which is the product of transformations
C                             applied to A, E, and C on the right.
C             If COMPZ = 'U': on entry, the leading N-by-N part of this
C                             array must contain an orthogonal matrix
C                             Zc;
C                             on exit, the leading N-by-N part of this
C                             array contains the orthogonal matrix
C                             Zc*Z.
C
C     LDZ     INTEGER
C             The leading dimension of array Z.
C             LDZ >= 1,        if COMPZ = 'N';
C             LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'.
C
C     NOBSV   (output) INTEGER
C             The order of the reduced matrices Ao and Eo, and the
C             number of columns of reduced matrix Co; also the order of
C             observable part of the pair (C, A-lambda*E).
C
C     NIUOBS  (output) INTEGER
C             For JOBOBS = 'O', the order of the reduced matrices
C             Aino and Eino; also the number of unobservable
C             infinite eigenvalues of the pencil A - lambda*E.
C             For JOBOBS = 'F' or 'I', NIUOBS has no significance
C             and is set to zero.
C
C     NLBLCK  (output) INTEGER
C             For JOBOBS = 'O' or 'I', the number k, of full column rank
C                    _
C             blocks Ei-1,i in the staircase form of the pencil
C             (Eo-lambda*Ao) (see (1) and (2)).
C             (    Co      )
C             For JOBOBS = 'F', the number k, of full column rank blocks
C             _
C             Ai-1,i in the staircase form of the pencil (Ao-lambda*Eo)
C                                                        (     Co     )
C             (see (3) and (4)).
C
C     CTAU    (output) INTEGER array, dimension (N)
C             CTAU(i), for i = 1, ..., NLBLCK, is the column dimension
C                                           _         _
C             of the full column rank block Ei-1,i or Ai-1,i in the
C             staircase form (1) or (3) for JOBOBS = 'O' or 'I', or
C             for JOBOBS = 'F', respectively.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used in rank determinations when
C             transforming (A'-lambda*E',C')'. If the user sets TOL > 0,
C             then the given value of TOL is used as a lower bound for
C             reciprocal condition numbers in rank determinations; 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 EPS
C             is the machine precision (see LAPACK Library routine
C             DLAMCH).  TOL < 1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (P)
C
C     DWORK   DOUBLE PRECISION array, dimension (MAX(N,2*P))
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
C     METHOD
C
C     The subroutine is based on the dual of the reduction
C     algorithms of [1].
C
C     REFERENCES
C
C     [1] A. Varga
C         Computation of Irreducible Generalized State-Space
C         Realizations.
C         Kybernetika, vol. 26, pp. 89-106, 1990.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable and requires
C     0( N**3 )  floating point operations.
C
C     FURTHER COMMENTS
C
C     If the system matrices A, E and C are badly scaled, it is
C     generally recommendable to scale them with the SLICOT routine
C     TG01AD, before calling TG01ID.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     March 1999. Based on the RASP routine RPDSCF.
C
C     REVISIONS
C
C     July 1999, V. Sima, Research Institute for Informatics, Bucharest.
C     May 2003, March 2004, V. Sima.
C
C     KEYWORDS
C
C     Observability, minimal realization, orthogonal canonical form,
C     orthogonal transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          COMPQ, COMPZ, JOBOBS
      INTEGER            INFO, LDA, LDB, LDC, LDE, LDQ, LDZ,
     $                   M, N, NIUOBS, NLBLCK, NOBSV, P
      DOUBLE PRECISION   TOL
C     .. Array Arguments ..
      INTEGER            CTAU( * ), IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, *  ),
     $                   DWORK( * ), E( LDE, * ), Q( LDQ, * ),
     $                   Z( LDZ, * )
C     .. Local Scalars ..
      CHARACTER          JOBQ, JOBZ
      LOGICAL            FINOBS, ILQ, ILZ, INFOBS
      INTEGER            I, ICOMPQ, ICOMPZ, LBA, LBE, NR
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM(1)
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           AB07MD, DSWAP, MA02BD, MA02CD, TB01XD,
     $                   TG01HX, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C
C     .. Executable Statements ..
C
C     Decode JOBOBS.
C
      IF( LSAME( JOBOBS, 'O') ) THEN
         FINOBS = .TRUE.
         INFOBS = .TRUE.
      ELSE IF( LSAME( JOBOBS, 'F') ) THEN
         FINOBS = .TRUE.
         INFOBS = .FALSE.
      ELSE IF( LSAME( JOBOBS, 'I') ) THEN
         FINOBS = .FALSE.
         INFOBS = .TRUE.
      ELSE
         FINOBS = .FALSE.
         INFOBS = .FALSE.
      END IF
C
C     Decode COMPQ.
C
      IF( LSAME( COMPQ, 'N' ) ) THEN
         ILQ = .FALSE.
         ICOMPQ = 1
      ELSE IF( LSAME( COMPQ, 'U' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 2
      ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 3
      ELSE
         ICOMPQ = 0
      END IF
C
C     Decode COMPZ.
C
      IF( LSAME( COMPZ, 'N' ) ) THEN
         ILZ = .FALSE.
         ICOMPZ = 1
      ELSE IF( LSAME( COMPZ, 'U' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 2
      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 3
      ELSE
         ICOMPZ = 0
      END IF
C
C     Test the input scalar parameters.
C
      INFO = 0
      IF( .NOT.FINOBS .AND. .NOT.INFOBS ) THEN
         INFO = -1
      ELSE IF( ICOMPQ.LE.0 ) THEN
         INFO = -2
      ELSE IF( ICOMPZ.LE.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( M.LT.0 ) THEN
         INFO = -5
      ELSE IF( P.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.N ) ) THEN
         INFO = -12
      ELSE IF( LDC.LT.MAX( 1, M, P ) ) THEN
         INFO = -14
      ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN
         INFO = -16
      ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
         INFO = -18
      ELSE IF( TOL.GE.ONE ) THEN
         INFO = -23
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'TG01ID', -INFO )
         RETURN
      END IF
C
      JOBQ = COMPQ
      JOBZ = COMPZ
C
C     Build the dual system.
C
      CALL AB07MD( 'Z', N, M, P, A, LDA, B, LDB, C, LDC, DUM, 1,
     $             INFO )
      DO 10 I = 2, N
         CALL DSWAP( I-1, E(I,1), LDE, E(1,I), 1 )
   10 CONTINUE
C
      IF( FINOBS ) THEN
C
C        Perform finite observability form reduction.
C
         CALL TG01HX( JOBZ, JOBQ, N, N, P, M, N, MAX( 0, N-1 ), A, LDA,
     $                E, LDE, B, LDB, C, LDC, Z, LDZ, Q, LDQ, NR,
     $                NLBLCK, CTAU, TOL, IWORK, DWORK, INFO )
         IF( NLBLCK.GT.1 ) THEN
            LBA = CTAU(1) + CTAU(2) - 1
         ELSE IF( NLBLCK.EQ.1 ) THEN
            LBA = CTAU(1) - 1
         ELSE
            LBA = 0
         END IF
         IF( ILQ ) JOBQ = 'U'
         IF( ILZ ) JOBZ = 'U'
         LBE = 0
      ELSE
         NR = N
         LBA = MAX( 0, N-1 )
         LBE = LBA
      END IF
C
      IF( INFOBS ) THEN
C
C        Perform infinite observability form reduction.
C
         CALL TG01HX( JOBZ, JOBQ, N, N, P, M, NR, LBA, E, LDE,
     $                A, LDA, B, LDB, C, LDC, Z, LDZ, Q, LDQ, NOBSV,
     $                NLBLCK, CTAU, TOL, IWORK, DWORK, INFO )
         IF( FINOBS ) THEN
            NIUOBS = NR - NOBSV
         ELSE
            NIUOBS = 0
         END IF
         IF( NLBLCK.GT.1 ) THEN
            LBE = CTAU(1) + CTAU(2) - 1
         ELSE IF( NLBLCK.EQ.1 ) THEN
            LBE = CTAU(1) - 1
         ELSE
            LBE = 0
         END IF
         LBA = 0
      ELSE
         NOBSV = NR
         NIUOBS = 0
      END IF
C
C     Compute the pertransposed dual system exploiting matrix shapes.
C
      LBA = MAX( LBA, NIUOBS-1, N-NOBSV-NIUOBS-1 )
      IF ( P.EQ.0 .OR. NR.EQ.0 )
     $   LBE = MAX( 0, N - 1 )
      CALL TB01XD( 'Z', N, P, M, LBA, MAX( 0, N-1 ), A, LDA, B, LDB,
     $             C, LDC, DUM, 1, INFO )
      CALL MA02CD( N, LBE, MAX( 0, N-1 ), E, LDE )
      IF( ILZ ) CALL MA02BD( 'Right', N, N, Z, LDZ )
      IF( ILQ ) CALL MA02BD( 'Right', N, N, Q, LDQ )
      RETURN
C *** Last line of TG01ID ***
      END
