C
C SPDX-License-Identifier: BSD-3-Clause
C
      SUBROUTINE MB04WR( JOB, TRANS, N, ILO, Q1, LDQ1, Q2, LDQ2, CS,
     $                   TAU, DWORK, LDWORK, INFO )
C
C     PURPOSE
C
C     To generate orthogonal symplectic matrices U or V, defined as
C     products of symplectic reflectors and Givens rotations
C
C     U = diag( HU(1),HU(1) )  GU(1)  diag( FU(1),FU(1) )
C         diag( HU(2),HU(2) )  GU(2)  diag( FU(2),FU(2) )
C                              ....
C         diag( HU(n),HU(n) )  GU(n)  diag( FU(n),FU(n) ),
C
C     V = diag( HV(1),HV(1) )       GV(1)   diag( FV(1),FV(1) )
C         diag( HV(2),HV(2) )       GV(2)   diag( FV(2),FV(2) )
C                                   ....
C         diag( HV(n-1),HV(n-1) )  GV(n-1)  diag( FV(n-1),FV(n-1) ),
C
C     as returned by the SLICOT Library routines MB04TS or MB04TB. The
C     matrices U and V are returned in terms of their first N/2 rows:
C
C                 [  U1   U2 ]           [  V1   V2 ]
C             U = [          ],      V = [          ].
C                 [ -U2   U1 ]           [ -V2   V1 ]
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     JOB     CHARACTER*1
C             Specifies whether the matrix U or the matrix V is
C             required:
C             = 'U':  generate U;
C             = 'V':  generate V.
C
C     TRANS   CHARACTER*1
C             If  JOB = 'U'  then TRANS must have the same value as
C             the argument TRANA in the previous call of MB04TS or
C             MB04TB.
C             If  JOB = 'V'  then TRANS must have the same value as
C             the argument TRANB in the previous call of MB04TS or
C             MB04TB.
C
C     N       (input) INTEGER
C             The order of the matrices Q1 and Q2. N >= 0.
C
C     ILO     (input) INTEGER
C             ILO must have the same value as in the previous call of
C             MB04TS or MB04TB. U and V are equal to the unit matrix
C             except in the submatrices
C             U([ilo:n n+ilo:2*n], [ilo:n n+ilo:2*n]) and
C             V([ilo+1:n n+ilo+1:2*n], [ilo+1:n n+ilo+1:2*n]),
C             respectively.
C             1 <= ILO <= N, if N > 0; ILO = 1, if N = 0.
C
C     Q1      (input/output) DOUBLE PRECISION array, dimension (LDQ1,N)
C             On entry, if  JOB = 'U'  and  TRANS = 'N'  then the
C             leading N-by-N part of this array must contain in its i-th
C             column the vector which defines the elementary reflector
C             FU(i).
C             If  JOB = 'U'  and  TRANS = 'T'  or  TRANS = 'C' then the
C             leading N-by-N part of this array must contain in its i-th
C             row the vector which defines the elementary reflector
C             FU(i).
C             If  JOB = 'V'  and  TRANS = 'N'  then the leading N-by-N
C             part of this array must contain in its i-th row the vector
C             which defines the elementary reflector FV(i).
C             If  JOB = 'V'  and  TRANS = 'T'  or  TRANS = 'C' then the
C             leading N-by-N part of this array must contain in its i-th
C             column the vector which defines the elementary reflector
C             FV(i).
C             On exit, if  JOB = 'U'  and  TRANS = 'N'  then the leading
C             N-by-N part of this array contains the matrix U1.
C             If  JOB = 'U'  and  TRANS = 'T'  or  TRANS = 'C' then the
C             leading N-by-N part of this array contains the matrix
C             U1**T.
C             If  JOB = 'V'  and  TRANS = 'N'  then the leading N-by-N
C             part of this array contains the matrix V1**T.
C             If  JOB = 'V'  and  TRANS = 'T'  or  TRANS = 'C' then the
C             leading N-by-N part of this array contains the matrix V1.
C
C     LDQ1    INTEGER
C             The leading dimension of the array Q1.  LDQ1 >= MAX(1,N).
C
C     Q2      (input/output) DOUBLE PRECISION array, dimension (LDQ2,N)
C             On entry, if  JOB = 'U'  then the leading N-by-N part of
C             this array must contain in its i-th column the vector
C             which defines the elementary reflector HU(i).
C             If  JOB = 'V'  then the leading N-by-N part of this array
C             must contain in its i-th row the vector which defines the
C             elementary reflector HV(i).
C             On exit, if  JOB = 'U'  then the leading N-by-N part of
C             this array contains the matrix U2.
C             If  JOB = 'V'  then the leading N-by-N part of this array
C             contains the matrix V2**T.
C
C     LDQ2    INTEGER
C             The leading dimension of the array Q2.  LDQ2 >= MAX(1,N).
C
C     CS      (input) DOUBLE PRECISION array, dimension (2N)
C             On entry, if  JOB = 'U'  then the first 2N elements of
C             this array must contain the cosines and sines of the
C             symplectic Givens rotations GU(i).
C             If  JOB = 'V'  then the first 2N-2 elements of this array
C             must contain the cosines and sines of the symplectic
C             Givens rotations GV(i).
C
C     TAU     (input) DOUBLE PRECISION array, dimension (N)
C             On entry, if  JOB = 'U'  then the first N elements of
C             this array must contain the scalar factors of the
C             elementary reflectors FU(i).
C             If  JOB = 'V'  then the first N-1 elements of this array
C             must contain the scalar factors of the elementary
C             reflectors FV(i).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK.
C             On exit, if  INFO = -12,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1,2*(N-ILO+1)).
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
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     REFERENCES
C
C     [1] Benner, P., Mehrmann, V., and Xu, H.
C         A numerically stable, structure preserving method for
C         computing the eigenvalues of real Hamiltonian or symplectic
C         pencils. Numer. Math., Vol 78 (3), pp. 329-358, 1998.
C
C     [2] Kressner, D.
C         Block algorithms for orthogonal symplectic factorizations.
C         BIT, 43 (4), pp. 775-790, 2003.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSGSU).
C     V. Sima, Aug. 2011.
C
C     KEYWORDS
C
C     Elementary matrix operations, Hamiltonian matrix, orthogonal
C     symplectic matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     .. Scalar Arguments ..
      CHARACTER         JOB, TRANS
      INTEGER           ILO, INFO, LDQ1, LDQ2, LDWORK, N
C     .. Array Arguments ..
      DOUBLE PRECISION  CS(*), DWORK(*), Q1(LDQ1,*), Q2(LDQ2,*), TAU(*)
C     .. Local Scalars ..
      LOGICAL           COMPU, LQUERY, LTRAN
      INTEGER           I, IERR, J, MINWRK, NH, WRKOPT
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DLASET, MB04WD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX
C
C     .. Executable Statements ..
C
C     Check the scalar input parameters.
C
      INFO  = 0
      LTRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
      COMPU = LSAME( JOB, 'U' )
      IF ( .NOT.COMPU .AND. .NOT.LSAME( JOB, 'V' ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.LTRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN
         INFO = -2
      ELSE IF ( N.LT.0 ) THEN
         INFO = -3
      ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF ( LDQ1.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF ( LDQ2.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE
         LQUERY = LDWORK.EQ.-1
         IF ( COMPU ) THEN
            NH = N - ILO + 1
         ELSE
            NH = N - ILO
         END IF
         MINWRK = MAX( 1, 2*NH )
         IF ( LQUERY ) THEN
            IF ( NH.LT.0 ) THEN
               WRKOPT = ONE
            ELSE
               CALL MB04WD( TRANS, TRANS, NH, NH, NH, Q1, LDQ1, Q2,
     $                      LDQ2, CS, TAU, DWORK, -1, IERR )
               WRKOPT = MAX( MINWRK, INT( DWORK(1) ) ) 
            END IF
            DWORK(1) = DBLE( WRKOPT )
            RETURN
         ELSE IF ( LDWORK.LT.MINWRK ) THEN
            DWORK(1) = DBLE( MINWRK )
            INFO = -12
         END IF
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04WR', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      IF ( COMPU ) THEN
         CALL DLASET( 'All', N, ILO-1, ZERO, ONE, Q1, LDQ1 )
         CALL DLASET( 'All', ILO-1, N-ILO+1, ZERO, ZERO, Q1(1,ILO),
     $                LDQ1 )
         CALL DLASET( 'All', N, ILO-1, ZERO, ZERO, Q2, LDQ2 )
         CALL DLASET( 'All', ILO-1, N-ILO+1, ZERO, ZERO, Q2(1,ILO),
     $                LDQ2 )
      END IF
      IF ( COMPU .AND. .NOT.LTRAN ) THEN
C
C        Generate U1 and U2.
C
         CALL MB04WD( 'No Transpose', 'No Transpose', NH, NH, NH,
     $                Q1(ILO,ILO), LDQ1, Q2(ILO,ILO), LDQ2, CS(ILO),
     $                TAU(ILO), DWORK, LDWORK, IERR )
      ELSE IF ( COMPU.AND.LTRAN ) THEN
C
C        Generate U1**T and U2.
C
         CALL MB04WD( 'Transpose', 'No Transpose', NH, NH, NH,
     $                Q1(ILO,ILO), LDQ1, Q2(ILO,ILO), LDQ2, CS(ILO),
     $                TAU(ILO), DWORK, LDWORK, IERR )
      ELSE IF ( .NOT.COMPU .AND. .NOT.LTRAN ) THEN
C
C        Generate V1**T and V2**T.
C
C        Shift the vectors which define the elementary reflectors one
C        column to the bottom, and set the first ilo rows and
C        columns to those of the unit matrix.
C
         DO 40  I = 1, N
            DO 10  J = N, MAX( I, ILO )+1, -1
               Q1(J,I) = ZERO
   10       CONTINUE
            DO 20  J = MAX( I, ILO ), ILO+1, -1
               Q1(J,I) = Q1(J-1,I)
   20       CONTINUE
            DO 30  J = ILO, 1, -1
               Q1(J,I) = ZERO
   30       CONTINUE
            IF ( I.LE.ILO )  Q1(I,I) = ONE
   40    CONTINUE
         DO 80  I = 1, N
            DO 50  J = N, MAX( I, ILO )+1, -1
               Q2(J,I) = ZERO
   50       CONTINUE
            DO 60  J = MAX( I, ILO ), ILO+1, -1
               Q2(J,I) = Q2(J-1,I)
   60       CONTINUE
            DO 70  J = ILO, 1, -1
               Q2(J,I) = ZERO
   70       CONTINUE
   80    CONTINUE
C
         IF ( NH.GT.0 ) THEN
            CALL MB04WD( 'Transpose', 'Transpose', NH, NH, NH,
     $                   Q1(ILO+1,ILO+1), LDQ1, Q2(ILO+1,ILO+1), LDQ2,
     $                   CS(ILO), TAU(ILO), DWORK, LDWORK, IERR )
         ELSE
            DWORK(1) = ONE
         END IF
      ELSE IF ( .NOT.COMPU .AND. LTRAN ) THEN
C
C        Generate V1 and V2**T.
C
C        Shift the vectors which define the elementary reflectors one
C        column to the right/bottom, and set the first ilo rows and
C        columns to those of the unit matrix.
C
         DO 110  J = N, ILO + 1, -1
            DO 90  I = 1, J-1
               Q1(I,J) = ZERO
   90       CONTINUE
            DO 100  I = J+1, N
               Q1(I,J) = Q1(I,J-1)
  100       CONTINUE
  110    CONTINUE
         CALL DLASET( 'All', N, ILO, ZERO, ONE, Q1, LDQ1 )
         DO 150 I = 1, N
            DO 120  J = N, MAX( I, ILO )+1, -1
               Q2(J,I) = ZERO
  120       CONTINUE
            DO 130  J = MAX( I, ILO ), ILO+1, -1
               Q2(J,I) = Q2(J-1,I)
  130       CONTINUE
            DO 140  J = ILO, 1, -1
               Q2(J,I) = ZERO
  140       CONTINUE
  150    CONTINUE
C
         IF ( NH.GT.0 ) THEN
            CALL MB04WD( 'No Transpose', 'Transpose', NH, NH, NH,
     $                   Q1(ILO+1,ILO+1), LDQ1, Q2(ILO+1,ILO+1), LDQ2,
     $                   CS(ILO), TAU(ILO), DWORK, LDWORK, IERR )
         ELSE
            DWORK(1) = ONE
         END IF
      END IF
      RETURN
C *** Last line of MB04WR ***
      END
