C
C SPDX-License-Identifier: BSD-3-Clause
C
      SUBROUTINE MB04WU( TRANQ1, TRANQ2, M, N, K, Q1, LDQ1, Q2, LDQ2,
     $                   CS, TAU, DWORK, LDWORK, INFO )
C
C     PURPOSE
C
C     To generate a matrix Q with orthogonal columns (spanning an
C     isotropic subspace), which is defined as the first n columns
C     of a product of symplectic reflectors and Givens rotations,
C
C         Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) )
C             diag( H(2),H(2) ) G(2) diag( F(2),F(2) )
C                               ....
C             diag( H(k),H(k) ) G(k) diag( F(k),F(k) ).
C
C     The matrix Q is returned in terms of its first 2*M rows
C
C                      [  op( Q1 )   op( Q2 ) ]
C                  Q = [                      ].
C                      [ -op( Q2 )   op( Q1 ) ]
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TRANQ1  CHARACTER*1
C             Specifies the form of op( Q1 ) as follows:
C             = 'N':  op( Q1 ) = Q1;
C             = 'T':  op( Q1 ) = Q1';
C             = 'C':  op( Q1 ) = Q1'.
C
C     TRANQ2  CHARACTER*1
C             Specifies the form of op( Q2 ) as follows:
C             = 'N':  op( Q2 ) = Q2;
C             = 'T':  op( Q2 ) = Q2';
C             = 'C':  op( Q2 ) = Q2'.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrices Q1 and Q2. M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrices Q1 and Q2.
C             M >= N >= 0.
C
C     K       (input) INTEGER
C             The number of symplectic Givens rotations whose product
C             partly defines the matrix Q. N >= K >= 0.
C
C     Q1      (input/output) DOUBLE PRECISION array, dimension
C                     (LDQ1,N) if TRANQ1 = 'N',
C                     (LDQ1,M) if TRANQ1 = 'T' or TRANQ1 = 'C'
C             On entry with TRANQ1 = 'N', the leading M-by-K part of
C             this array must contain in its i-th column the vector
C             which defines the elementary reflector F(i).
C             On entry with TRANQ1 = 'T' or TRANQ1 = 'C', the leading
C             K-by-M part of this array must contain in its i-th row
C             the vector which defines the elementary reflector F(i).
C             On exit with TRANQ1 = 'N', the leading M-by-N part of this
C             array contains the matrix Q1.
C             On exit with TRANQ1 = 'T' or TRANQ1 = 'C', the leading
C             N-by-M part of this array contains the matrix Q1'.
C
C     LDQ1    INTEGER
C             The leading dimension of the array Q1.
C             LDQ1 >= MAX(1,M),  if TRANQ1 = 'N';
C             LDQ1 >= MAX(1,N),  if TRANQ1 = 'T' or TRANQ1 = 'C'.
C
C     Q2      (input/output) DOUBLE PRECISION array, dimension
C                     (LDQ2,N) if TRANQ2 = 'N',
C                     (LDQ2,M) if TRANQ2 = 'T' or TRANQ2 = 'C'
C             On entry with TRANQ2 = 'N', the leading M-by-K part of
C             this array must contain in its i-th column the vector
C             which defines the elementary reflector H(i) and, on the
C             diagonal, the scalar factor of H(i).
C             On entry with TRANQ2 = 'T' or TRANQ2 = 'C', the leading
C             K-by-M part of this array must contain in its i-th row the
C             vector which defines the elementary reflector H(i) and, on
C             the diagonal, the scalar factor of H(i).
C             On exit with TRANQ2 = 'N', the leading M-by-N part of this
C             array contains the matrix Q2.
C             On exit with TRANQ2 = 'T' or TRANQ2 = 'C', the leading
C             N-by-M part of this array contains the matrix Q2'.
C
C     LDQ2    INTEGER
C             The leading dimension of the array Q2.
C             LDQ2 >= MAX(1,M),  if TRANQ2 = 'N';
C             LDQ2 >= MAX(1,N),  if TRANQ2 = 'T' or TRANQ2 = 'C'.
C
C     CS      (input) DOUBLE PRECISION array, dimension (2*K)
C             On entry, the first 2*K elements of this array must
C             contain the cosines and sines of the symplectic Givens
C             rotations G(i).
C
C     TAU     (input) DOUBLE PRECISION array, dimension (K)
C             On entry, the first K elements of this array must
C             contain the scalar factors of the elementary reflectors
C             F(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 = -13,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= MAX(1,M+N).
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] Bunse-Gerstner, A.
C         Matrix factorizations for symplectic QR-like methods.
C         Linear Algebra Appl., 83, pp. 49-77, 1986.
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 DOSGSQ).
C
C     KEYWORDS
C
C     Elementary matrix operations, orthogonal symplectic matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     .. Scalar Arguments ..
      CHARACTER         TRANQ1, TRANQ2
      INTEGER           INFO, K, LDQ1, LDQ2, LDWORK, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION  CS(*), DWORK(*), Q1(LDQ1,*), Q2(LDQ2,*), TAU(*)
C     .. Local Scalars ..
      LOGICAL           LTRQ1, LTRQ2
      INTEGER           I, J
      DOUBLE PRECISION  NU
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DLARF, DLASET, DROT, DSCAL, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      INFO  = 0
      LTRQ1 = LSAME( TRANQ1,'T' ) .OR. LSAME( TRANQ1,'C' )
      LTRQ2 = LSAME( TRANQ2,'T' ) .OR. LSAME( TRANQ2,'C' )
C
C     Check the scalar input parameters.
C
      IF ( .NOT.( LTRQ1 .OR. LSAME( TRANQ1, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.( LTRQ2 .OR. LSAME( TRANQ2, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF ( M.LT.0 ) THEN
         INFO = -3
      ELSE IF ( N.LT.0 .OR. N.GT.M ) THEN
         INFO = -4
      ELSE IF ( K.LT.0 .OR. K.GT.N ) THEN
         INFO = -5
      ELSE IF ( ( LTRQ1 .AND. LDQ1.LT.MAX( 1, N ) ) .OR.
     $     ( .NOT.LTRQ1 .AND. LDQ1.LT.MAX( 1, M ) ) ) THEN
         INFO = -7
      ELSE IF ( ( LTRQ2 .AND. LDQ2.LT.MAX( 1, N ) ) .OR.
     $     ( .NOT.LTRQ2 .AND. LDQ2.LT.MAX( 1, M ) ) ) THEN
         INFO = -9
      ELSE IF ( LDWORK.LT.MAX( 1,M + N ) ) THEN
         DWORK(1) = DBLE( MAX( 1,M + N ) )
         INFO = -13
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04WU', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Initialize columns K+1:N to columns of the unit matrix.
C
      DO 20 J = K + 1, N
         DO 10 I = 1, M
            Q1(I,J) = ZERO
   10    CONTINUE
         Q1(J,J) = ONE
   20 CONTINUE
      CALL DLASET( 'All', M, N-K, ZERO, ZERO, Q2(1,K+1), LDQ2 )
C
      IF ( LTRQ1.AND.LTRQ2 ) THEN
         DO 50 I = K, 1, -1
C
C           Apply F(I) to Q1(I+1:N,I:M) and Q2(I+1:N,I:M) from the
C           right.
C
            CALL DCOPY( M-I+1, Q2(I,I), LDQ2, DWORK, 1 )
            IF ( I.LT.N ) THEN
               Q1(I,I) = ONE
               CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), LDQ1, TAU(I),
     $                     Q1(I+1,I), LDQ1, DWORK(M+1) )
               CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), LDQ1, TAU(I),
     $                     Q2(I+1,I), LDQ2, DWORK(M+1) )
            END IF
            IF ( I.LT.M )
     $         CALL DSCAL( M-I, -TAU(I), Q1(I,I+1), LDQ1 )
            Q1(I,I) = ONE - TAU(I)
C
C           Set Q1(I,1:I-1) and Q2(I,1:M) to zero.
C
            DO 30 J = 1, I - 1
               Q1(I,J) = ZERO
   30       CONTINUE
            DO 40 J = 1, M
               Q2(I,J) = ZERO
   40       CONTINUE
C
C           Apply G(I) to Q1(I:N,I) and Q2(I:N,I) from the right.
C
            CALL DROT( N-I+1, Q1(I,I), 1, Q2(I,I), 1, CS(2*I-1),
     $                 CS(2*I) )
C
C           Apply H(I) to Q1(I:N,I:M) and Q2(I:N,I:M) from the right.
C
            NU = DWORK(1)
            DWORK(1) = ONE
            CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q1(I,I),
     $                  LDQ1, DWORK(M+1) )
            CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q2(I,I),
     $                  LDQ2, DWORK(M+1) )
   50    CONTINUE
      ELSE IF ( LTRQ1 ) THEN
         DO 80 I = K, 1, -1
C
C           Apply F(I) to Q1(I+1:N,I:M) from the right and to
C           Q2(I:M,I+1:N) from the left.
C
            CALL DCOPY( M-I+1, Q2(I,I), 1, DWORK, 1 )
            IF ( I.LT.N ) THEN
               Q1(I,I) = ONE
               CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), LDQ1, TAU(I),
     $                     Q1(I+1,I), LDQ1, DWORK(M+1) )
               CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), LDQ1, TAU(I),
     $                     Q2(I,I+1), LDQ2, DWORK(M+1) )
            END IF
            IF ( I.LT.M )
     $         CALL DSCAL( M-I, -TAU(I), Q1(I,I+1), LDQ1 )
            Q1(I,I) = ONE - TAU(I)
C
C           Set Q1(I,1:I-1) and Q2(1:M,I) to zero.
C
            DO 60 J = 1, I - 1
               Q1(I,J) = ZERO
   60       CONTINUE
            DO 70 J = 1, M
               Q2(J,I) = ZERO
   70       CONTINUE
C
C           Apply G(I) to Q1(I:N,I) from the right and to Q2(I,I:N)
C           from the left.
C
            CALL DROT( N-I+1, Q1(I,I), 1, Q2(I,I), LDQ2, CS(2*I-1),
     $                 CS(2*I) )
C
C           Apply H(I) to Q1(I:N,I:M) from the right and to Q2(I:M,I:N)
C           from the left.
C
            NU = DWORK(1)
            DWORK(1) = ONE
            CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q1(I,I),
     $                  LDQ1, DWORK(M+1) )
            CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q2(I,I),
     $                  LDQ2, DWORK(M+1) )
   80    CONTINUE
      ELSE IF ( LTRQ2 ) THEN
         DO 110 I = K, 1, -1
C
C           Apply F(I) to Q1(I:M,I+1:N) from the left and to
C           Q2(I+1:N,I:M) from the right.
C
            CALL DCOPY( M-I+1, Q2(I,I), LDQ2, DWORK, 1 )
            IF ( I.LT.N ) THEN
               Q1(I,I) = ONE
               CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), 1, TAU(I),
     $                     Q1(I,I+1), LDQ1, DWORK(M+1) )
               CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), 1, TAU(I),
     $                     Q2(I+1,I), LDQ2, DWORK(M+1) )
            END IF
            IF ( I.LT.M )
     $         CALL DSCAL( M-I, -TAU(I), Q1(I+1,I), 1 )
            Q1(I,I) = ONE - TAU(I)
C
C           Set Q1(1:I-1,I) and Q2(I,1:M) to zero.
C
            DO 90 J = 1, I - 1
               Q1(J,I) = ZERO
   90       CONTINUE
            DO 100 J = 1, M
               Q2(I,J) = ZERO
  100       CONTINUE
C
C           Apply G(I) to Q1(I,I:N) from the left and to Q2(I:N,I)
C           from the right.
C
            CALL DROT( N-I+1, Q1(I,I), LDQ1, Q2(I,I), 1, CS(2*I-1),
     $                 CS(2*I) )
C
C           Apply H(I) to Q1(I:M,I:N) from the left and to Q2(I:N,I:M)
C           from the left.
C
            NU = DWORK(1)
            DWORK(1) = ONE
            CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q1(I,I),
     $                  LDQ1, DWORK(M+1) )
            CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q2(I,I),
     $                  LDQ2, DWORK(M+1) )
  110    CONTINUE
      ELSE
         DO 140 I = K, 1, -1
C
C           Apply F(I) to Q1(I:M,I+1:N) and Q2(I:M,I+1:N) from the left.
C
            CALL DCOPY( M-I+1, Q2(I,I), 1, DWORK, 1 )
            IF ( I.LT.N ) THEN
               Q1(I,I) = ONE
               CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), 1, TAU(I),
     $                     Q1(I,I+1), LDQ1, DWORK(M+1) )
               CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), 1, TAU(I),
     $                     Q2(I,I+1), LDQ2, DWORK(M+1) )
            END IF
            IF ( I.LT.M )
     $         CALL DSCAL( M-I, -TAU(I), Q1(I+1,I), 1 )
            Q1(I,I) = ONE - TAU(I)
C
C           Set Q1(1:I-1,I) and Q2(1:M,I) to zero.
C
            DO 120 J = 1, I - 1
               Q1(J,I) = ZERO
  120       CONTINUE
            DO 130 J = 1, M
               Q2(J,I) = ZERO
  130       CONTINUE
C
C           Apply G(I) to Q1(I,I:N) and Q2(I,I:N) from the left.
C
            CALL DROT( N-I+1, Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1),
     $                 CS(2*I) )
C
C           Apply H(I) to Q1(I:M,I:N) and Q2(I:M,I:N) from the left.
C
            NU = DWORK(1)
            DWORK(1) = ONE
            CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q1(I,I),
     $                  LDQ1, DWORK(M+1) )
            CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q2(I,I),
     $                  LDQ2, DWORK(M+1) )
  140    CONTINUE
      END IF
      DWORK(1) = DBLE( MAX( 1, M+N ) )
C *** Last line of MB04WU ***
      END
