C
C SPDX-License-Identifier: BSD-3-Clause
C
      DOUBLE PRECISION FUNCTION AB13DX( DICO, JOBE, JOBD, N, M, P,
     $                                  OMEGA, A, LDA, E, LDE, B, LDB,
     $                                  C, LDC, D, LDD, IWORK, DWORK,
     $                                  LDWORK, ZWORK, LZWORK, INFO )
C
C     PURPOSE
C
C     To compute the maximum singular value of a given continuous-time
C     or discrete-time transfer-function matrix, either standard or in
C     the descriptor form,
C
C                                     -1
C        G(lambda) = C*( lambda*E - A ) *B + D ,
C
C     for a given complex value lambda, where lambda = j*omega, in the
C     continuous-time case, and lambda = exp(j*omega), in the
C     discrete-time case. The matrices A, E, B, C, and D are real
C     matrices of appropriate dimensions. Matrix A must be in an upper
C     Hessenberg form, and if JOBE ='G', the matrix E must be upper
C     triangular. The matrices B and C must correspond to the system
C     in (generalized) Hessenberg form.
C
C     FUNCTION VALUE
C
C     AB13DX   DOUBLE PRECISION
C              The maximum singular value of G(lambda).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the system, as follows:
C             = 'C':  continuous-time system;
C             = 'D':  discrete-time system.
C
C     JOBE    CHARACTER*1
C             Specifies whether E is an upper triangular or an identity
C             matrix, as follows:
C             = 'G':  E is a general upper triangular matrix;
C             = 'I':  E is the identity matrix.
C
C     JOBD    CHARACTER*1
C             Specifies whether or not a non-zero matrix D appears in
C             the given state space model:
C             = 'D':  D is present;
C             = 'Z':  D is assumed a zero matrix.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the system.  N >= 0.
C
C     M       (input) INTEGER
C             The column size of the matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The row size of the matrix C.  P >= 0.
C
C     OMEGA   (input) DOUBLE PRECISION
C             The frequency value for which the calculations should be
C             done.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N upper Hessenberg part of this
C             array must contain the state dynamics matrix A in upper
C             Hessenberg form. The elements below the subdiagonal are
C             not referenced.
C             On exit, if M > 0, P > 0, OMEGA = 0, DICO = 'C', B <> 0,
C             and C <> 0, the leading N-by-N upper Hessenberg part of
C             this array contains the factors L and U from the LU
C             factorization of A (A = P*L*U); the unit diagonal elements
C             of L are not stored, L is lower bidiagonal, and P is
C             stored in IWORK (see SLICOT Library routine MB02SD).
C             Otherwise, this array is unchanged on exit.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     E       (input) DOUBLE PRECISION array, dimension (LDE,N)
C             If JOBE = 'G', the leading N-by-N upper triangular part of
C             this array must contain the upper triangular descriptor
C             matrix E of the system. The elements of the strict lower
C             triangular part of this array are not referenced.
C             If JOBE = 'I', then E is assumed to be the identity
C             matrix and is not referenced.
C
C     LDE     INTEGER
C             The leading dimension of the array E.
C             LDE >= MAX(1,N), if JOBE = 'G';
C             LDE >= 1,        if JOBE = 'I'.
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 system input matrix B.
C             On exit, if M > 0, P > 0, OMEGA = 0, DICO = 'C', B <> 0,
C             C <> 0, and INFO = 0 or N+1, the leading N-by-M part of
C             this array contains the solution of the system A*X = B.
C             Otherwise, this array is unchanged on exit.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= max(1,N).
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading P-by-N part of this array must contain the
C             system output matrix 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, if JOBD = 'D', the leading P-by-M part of this
C             array must contain the direct transmission matrix D.
C             On exit, if (N = 0, or B = 0, or C = 0) and JOBD = 'D',
C             or (OMEGA = 0, DICO = 'C', JOBD = 'D', and INFO = 0 or
C             N+1), the contents of this array is destroyed.
C             Otherwise, this array is unchanged on exit.
C             This array is not referenced if JOBD = 'Z'.
C
C     LDD     INTEGER
C             The leading dimension of array D.
C             LDD >= MAX(1,P), if JOBD = 'D';
C             LDD >= 1,        if JOBD = 'Z'.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK), where
C             LIWORK = N, if N > 0, M > 0, P > 0, B <> 0, and C <> 0;
C             LIWORK = 0, otherwise.
C             This array contains the pivot indices in the LU
C             factorization of the matrix lambda*E - A; for 1 <= i <= N,
C             row i of the matrix was interchanged with row IWORK(i).
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) contains the optimal value
C             of LDWORK, and DWORK(2), ..., DWORK(MIN(P,M)) contain the
C             singular values of G(lambda), except for the first one,
C             which is returned in the function value AB13DX.
C             If (N = 0, or B = 0, or C = 0) and JOBD = 'Z', the last
C             MIN(P,M)-1 zero singular values of G(lambda) are not
C             stored in DWORK(2), ..., DWORK(MIN(P,M)).
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= MAX(1, LDW1 + LDW2 ),
C             LDW1 = P*M, if N > 0, B <> 0, C <> 0, OMEGA = 0,
C                            DICO = 'C', and JOBD = 'Z';
C             LDW1 = 0,   otherwise;
C             LDW2 = MIN(P,M) + MAX(3*MIN(P,M) + MAX(P,M), 5*MIN(P,M)),
C                         if (N = 0, or B = 0, or C = 0) and JOBD = 'D',
C                         or (N > 0, B <> 0, C <> 0, OMEGA = 0, and
C                             DICO = 'C');
C             LDW2 = 0,   if (N = 0, or B = 0, or C = 0) and JOBD = 'Z',
C                         or MIN(P,M) = 0;
C             LDW2 = 6*MIN(P,M), otherwise.
C             For good performance, LDWORK must generally be larger.
C
C     ZWORK   COMPLEX*16 array, dimension (LZWORK)
C             On exit, if INFO = 0, ZWORK(1) contains the optimal
C             LZWORK.
C
C     LZWORK  INTEGER
C             The dimension of the array ZWORK.
C             LZWORK >= 1, if N = 0, or B = 0, or C = 0, or (OMEGA = 0
C                             and DICO = 'C') or MIN(P,M) = 0;
C             LZWORK >= MAX(1, (N+M)*(N+P) + 2*MIN(P,M) + MAX(P,M)),
C                          otherwise.
C             For good performance, LZWORK must generally 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             > 0:  if INFO = i, U(i,i) is exactly zero; the LU
C                   factorization of the matrix lambda*E - A has been
C                   completed, but the factor U is exactly singular,
C                   i.e., the matrix lambda*E - A is exactly singular;
C             = N+1:  the SVD algorithm for computing singular values
C                   did not converge.
C
C     METHOD
C
C     The routine implements standard linear algebra calculations,
C     taking problem structure into account. LAPACK Library routines
C     DGESVD and ZGESVD are used for finding the singular values.
C
C     CONTRIBUTORS
C
C     D. Sima, University of Bucharest, May 2001.
C     V. Sima, Research Institute for Informatics, Bucharest, May 2001.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Sep. 2005;
C     July 2022.
C
C     KEYWORDS
C
C     H-infinity optimal control, robust control, system norm.
C
C     ******************************************************************
C
C     .. Parameters ..
      COMPLEX*16         CONE
      PARAMETER          ( CONE = ( 1.0D0, 0.0D0 ) )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          DICO, JOBD, JOBE
      INTEGER            INFO, LDA, LDB, LDC, LDD, LDE, LDWORK, LZWORK,
     $                   M, N, P
      DOUBLE PRECISION   OMEGA
C     ..
C     .. Array Arguments ..
      COMPLEX*16         ZWORK(  * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   D( LDD, * ), DWORK(  * ), E( LDE, * )
      INTEGER            IWORK(  * )
C     ..
C     .. Local Scalars ..
      LOGICAL            DISCR, FULLE, NODYN, SPECL, WITHD
      INTEGER            I, ICB, ICC, ICD, ICWK, ID, IERR, IS, IWRK, J,
     $                   MAXPM, MAXWRK, MINCWR, MINPM, MINWRK
      DOUBLE PRECISION   BNORM, CNORM, LAMBDI, LAMBDR, UPD
C
C     .. External Functions ..
      DOUBLE PRECISION   DLANGE
      LOGICAL            LSAME
      EXTERNAL           DLANGE, LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGEMM, DGESVD, MB02RD, MB02RZ, MB02SD, MB02SZ,
     $                   XERBLA, ZGEMM, ZGESVD, ZLACP2
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          COS, DCMPLX, INT, MAX, MIN, SIN
C     ..
C     .. Executable Statements ..
C
C     Test the input scalar parameters.
C
      INFO  = 0
      DISCR = LSAME( DICO, 'D' )
      FULLE = LSAME( JOBE, 'G' )
      WITHD = LSAME( JOBD, 'D' )
C
      IF( .NOT. ( DISCR .OR. LSAME( DICO, 'C' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT. ( FULLE .OR. LSAME( JOBE, 'I' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) 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 = -9
      ELSE IF( LDE.LT.1 .OR. ( FULLE .AND. LDE.LT.N ) ) THEN
         INFO = -11
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -13
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -15
      ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN
         INFO = -17
      ELSE
         BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK )
         CNORM = DLANGE( '1-norm', P, N, C, LDC, DWORK )
         NODYN = N.EQ.0 .OR. MIN( BNORM, CNORM ).EQ.ZERO
         SPECL = .NOT.NODYN .AND. OMEGA.EQ.ZERO .AND. .NOT.DISCR
         MINPM = MIN( P, M )
         MAXPM = MAX( P, M )
C
C        Compute workspace.
C
         IF( MINPM.EQ.0 .OR. ( NODYN .AND. .NOT.WITHD ) ) THEN
            MINWRK = 0
         ELSE IF( SPECL .OR. ( NODYN .AND. WITHD ) ) THEN
            MINWRK = MAX( 4*MINPM + MAXPM, 6*MINPM )
            IF( SPECL .AND. .NOT.WITHD )
     $         MINWRK = MINWRK + P*M
         ELSE
            MINWRK = 6*MINPM
         END IF
         MINWRK = MAX( 1, MINWRK )
C
         IF( LDWORK.LT.MINWRK ) THEN
            INFO = -20
         ELSE
            IF( NODYN .OR. ( OMEGA.EQ.ZERO .AND. .NOT.DISCR ) .OR.
     $           MINPM.EQ.0 ) THEN
               MINCWR = 1
            ELSE
               MINCWR = MAX( 1, ( N + M )*( N + P ) +
     $                          2*MINPM + MAXPM )
            END IF
            IF( LZWORK.LT.MINCWR )
     $         INFO = -22
         END IF
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'AB13DX', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MINPM.EQ.0 ) THEN
         AB13DX = ZERO
C
         DWORK( 1 ) = ONE
         ZWORK( 1 ) = CONE
         RETURN
      END IF
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
      IS   = 1
      IWRK = IS + MINPM
C
      IF( NODYN ) THEN
C
C        No dynamics: Determine the maximum singular value of G = D .
C
         IF( WITHD ) THEN
C
C           Workspace: need   MIN(P,M) + MAX(3*MIN(P,M) + MAX(P,M),
C                                            5*MIN(P,M));
C                      prefer larger.
C
            CALL DGESVD( 'No Vectors', 'No Vectors', P, M, D, LDD,
     $                   DWORK( IS ), DWORK, P, DWORK, M, DWORK( IWRK ),
     $                   LDWORK-IWRK+1, IERR )
            IF( IERR.GT.0 ) THEN
               INFO = N + 1
               RETURN
            END IF
            AB13DX = DWORK( IS )
            MAXWRK = INT( DWORK( IWRK ) ) + IWRK - 1
         ELSE
            AB13DX = ZERO
            MAXWRK = 1
         END IF
C
         DWORK( 1 ) = MAXWRK
         ZWORK( 1 ) = CONE
         RETURN
      END IF
C
C     Determine the maximum singular value of
C        G(lambda) = C*inv(lambda*E - A)*B + D.
C     The (generalized) Hessenberg form of the system is used.
C
      IF( SPECL ) THEN
C
C        Special continuous-time case:
C        Determine the maximum singular value of the real matrix G(0).
C        Workspace: need   MIN(P,M) + MAX(3*MIN(P,M) + MAX(P,M),
C                                         5*MIN(P,M));
C                   prefer larger.
C
         CALL MB02SD( N, A, LDA, IWORK, IERR )
         IF( IERR.GT.0 ) THEN
            INFO = IERR
            DWORK( 1 ) = ONE
            ZWORK( 1 ) = CONE
            RETURN
         END IF
         CALL MB02RD( 'No Transpose', N, M, A, LDA, IWORK, B, LDB,
     $                IERR )
         IF( WITHD ) THEN
            CALL DGEMM(  'No Transpose', 'No Transpose', P, M, N, -ONE,
     $                   C, LDC, B, LDB, ONE, D, LDD )
            CALL DGESVD( 'No Vectors', 'No Vectors', P, M, D, LDD,
     $                   DWORK( IS ), DWORK, P, DWORK, M, DWORK( IWRK ),
     $                   LDWORK-IWRK+1, IERR )
         ELSE
C
C           Additional workspace: need   P*M.
C
            ID   = IWRK
            IWRK = ID + P*M
            CALL DGEMM(  'No Transpose', 'No Transpose', P, M, N, -ONE,
     $                   C, LDC, B, LDB, ZERO, DWORK( ID ), P )
            CALL DGESVD( 'No Vectors', 'No Vectors', P, M, DWORK( ID ),
     $                   P, DWORK( IS ), DWORK, P, DWORK, M,
     $                   DWORK( IWRK ), LDWORK-IWRK+1, IERR )
         END IF
         IF( IERR.GT.0 ) THEN
            INFO = N + 1
            RETURN
         END IF
C
         AB13DX = DWORK( IS )
         DWORK( 1 ) = INT( DWORK( IWRK ) ) + IWRK - 1
         ZWORK( 1 ) = CONE
         RETURN
      END IF
C
C     General case: Determine the maximum singular value of G(lambda).
C     Complex workspace:  need   N*N + N*M + P*N + P*M.
C
      ICB  = 1   + N*N
      ICC  = ICB + N*M
      ICD  = ICC + P*N
      ICWK = ICD + P*M
C
      IF( WITHD ) THEN
         UPD = ONE
      ELSE
         UPD = ZERO
      END IF
C
      IF( DISCR ) THEN
         LAMBDR = COS( OMEGA )
         LAMBDI = SIN( OMEGA )
C
C        Build lambda*E - A .
C
         IF( FULLE ) THEN
C
            DO 20 J = 1, N
C
               DO 10 I = 1, J
                  ZWORK( I+(J-1)*N ) =
     $               DCMPLX( LAMBDR*E( I, J ) - A( I, J ),
     $                       LAMBDI*E( I, J ) )
   10          CONTINUE
C
               IF( J.LT.N )
     $            ZWORK( J+1+(J-1)*N ) = DCMPLX( -A( J+1, J ), ZERO )
   20      CONTINUE
C
         ELSE
C
            DO 40 J = 1, N
C
               DO 30 I = 1, MIN( J+1, N )
                  ZWORK( I+(J-1)*N ) = DCMPLX( -A( I, J ), ZERO )
   30          CONTINUE
C
               ZWORK( J+(J-1)*N ) = DCMPLX( LAMBDR - A( J, J ), LAMBDI )
   40      CONTINUE
C
         END IF
C
      ELSE
C
C        Build j*omega*E - A.
C
         IF( FULLE ) THEN
C
            DO 60 J = 1, N
C
               DO 50 I = 1, J
                  ZWORK( I+(J-1)*N ) =
     $               DCMPLX( -A( I, J ), OMEGA*E( I, J ) )
   50         CONTINUE
C
               IF( J.LT.N )
     $            ZWORK( J+1+(J-1)*N ) = DCMPLX( -A( J+1, J ), ZERO )
   60      CONTINUE
C
         ELSE
C
            DO 80 J = 1, N
C
               DO 70 I = 1, MIN( J+1, N )
                  ZWORK( I+(J-1)*N ) = DCMPLX( -A( I, J ), ZERO )
   70          CONTINUE
C
               ZWORK( J+(J-1)*N ) = DCMPLX( -A( J, J ), OMEGA )
   80      CONTINUE
C
         END IF
C
      END IF
C
C     Build G(lambda) .
C
      CALL ZLACP2( 'Full', N, M, B, LDB, ZWORK( ICB ), N )
      CALL ZLACP2( 'Full', P, N, C, LDC, ZWORK( ICC ), P )
      IF( WITHD )
     $   CALL ZLACP2( 'Full', P, M, D, LDD, ZWORK( ICD ), P )
C
      CALL MB02SZ( N, ZWORK, N, IWORK, IERR )
      IF( IERR.GT.0 ) THEN
         INFO = IERR
         DWORK( 1 ) = ONE
         ZWORK( 1 ) = ICWK - 1
         RETURN
      END IF
      CALL MB02RZ( 'No Transpose', N, M, ZWORK, N, IWORK,
     $             ZWORK( ICB ), N, IERR )
      CALL ZGEMM(  'No Transpose', 'No Transpose', P, M, N, CONE,
     $             ZWORK( ICC ), P, ZWORK( ICB ), N,
     $             DCMPLX( UPD, ZERO ), ZWORK( ICD ), P )
C
C     Additional workspace, complex: need   2*MIN(P,M) + MAX(P,M);
C                                    prefer larger;
C                           real:    need   5*MIN(P,M).
C
      CALL ZGESVD( 'No Vectors', 'No Vectors', P, M, ZWORK( ICD ), P,
     $             DWORK( IS ), ZWORK, P, ZWORK, M, ZWORK( ICWK ),
     $             LZWORK-ICWK+1, DWORK( IWRK ), IERR )
      IF( IERR.GT.0 ) THEN
         INFO = N + 1
         RETURN
      END IF
      AB13DX = DWORK( IS )
C
      DWORK( 1 ) = 6*MINPM
      ZWORK( 1 ) = INT( ZWORK( ICWK ) ) + ICWK - 1
C
C     Some implementations of ZGESVD return a huge value for the optimal
C     workspace. If this is suspected, minimum workspace size is used. 
C
      IF( INT( ZWORK( ICWK ) ).GT.100*( 2*MINPM + MAXPM ) )
     $   ZWORK( 1 ) = MINCWR
      RETURN
C *** Last line of AB13DX ***
      END
