C
C SPDX-License-Identifier: BSD-3-Clause
C
      SUBROUTINE MB02JD( JOB, K, L, M, N, P, S, TC, LDTC, TR, LDTR, Q,
     $                   LDQ, R, LDR, DWORK, LDWORK, INFO )
C
C     PURPOSE
C
C     To compute a lower triangular matrix R and a matrix Q with
C     Q^T Q = I such that
C                                    T
C                           T  =  Q R ,
C
C     where T is a K*M-by-L*N block Toeplitz matrix with blocks of size
C     (K,L). The first column of T will be denoted by TC and the first
C     row by TR. It is assumed that the first MIN(M*K, N*L) columns of T
C     have full rank.
C
C     By subsequent calls of this routine the factors Q and R can be
C     computed block column by block column.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the output of the routine as follows:
C             = 'Q':  computes Q and R;
C             = 'R':  only computes R.
C
C     Input/Output Parameters
C
C     K       (input)  INTEGER
C             The number of rows in one block of T.  K >= 0.
C
C     L       (input)  INTEGER
C             The number of columns in one block of T.  L >= 0.
C
C     M       (input)  INTEGER
C             The number of blocks in one block column of T.  M >= 0.
C
C     N       (input)  INTEGER
C             The number of blocks in one block row of T.  N >= 0.
C
C     P       (input)  INTEGER
C             The number of previously computed block columns of R.
C             P*L < MIN( M*K,N*L ) + L and P >= 0.
C
C     S       (input)  INTEGER
C             The number of block columns of R to compute.
C             (P+S)*L < MIN( M*K,N*L ) + L and S >= 0.
C
C     TC      (input) DOUBLE PRECISION array, dimension (LDTC, L)
C             On entry, if P = 0, the leading M*K-by-L part of this
C             array must contain the first block column of T.
C
C     LDTC    INTEGER
C             The leading dimension of the array TC.
C             LDTC >= MAX(1,M*K).
C
C     TR      (input)  DOUBLE PRECISION array, dimension (LDTR,(N-1)*L)
C             On entry, if P = 0, the leading K-by-(N-1)*L part of this
C             array must contain the first block row of T without the
C             leading K-by-L block.
C
C     LDTR    INTEGER
C             The leading dimension of the array TR.
C             LDTR >= MAX(1,K).
C
C     Q       (input/output)  DOUBLE PRECISION array, dimension
C                             (LDQ,MIN( S*L, MIN( M*K,N*L )-P*L ))
C             On entry, if JOB = 'Q'  and  P > 0, the leading M*K-by-L
C             part of this array must contain the last block column of Q
C             from a previous call of this routine.
C             On exit, if JOB = 'Q'  and  INFO = 0, the leading
C             M*K-by-MIN( S*L, MIN( M*K,N*L )-P*L ) part of this array
C             contains the P-th to (P+S)-th block columns of the factor
C             Q.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.
C             LDQ >= MAX(1,M*K), if JOB = 'Q';
C             LDQ >= 1,          if JOB = 'R'.
C
C     R       (input/output)  DOUBLE PRECISION array, dimension
C                             (LDR,MIN( S*L, MIN( M*K,N*L )-P*L ))
C             On entry, if P > 0, the leading (N-P+1)*L-by-L
C             part of this array must contain the nozero part of the
C             last block column of R from a previous call of this
C             routine.
C             One exit, if INFO = 0, the leading
C             MIN( N, N-P+1 )*L-by-MIN( S*L, MIN( M*K,N*L )-P*L )
C             part of this array contains the nonzero parts of the P-th
C             to (P+S)-th block columns of the lower triangular
C             factor R.
C             Note that elements in the strictly upper triangular part
C             will not be referenced.
C
C     LDR     INTEGER
C             The leading dimension of the array R.
C             LDR >= MAX( 1, MIN( N, N-P+1 )*L )
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C             On exit, if INFO = -17,  DWORK(1) returns the minimum
C             value of LDWORK.
C             If JOB = 'Q', the first 1 + ( (N-1)*L + M*K )*( 2*K + L )
C             elements of DWORK should be preserved during successive
C             calls of the routine.
C             If JOB = 'R', the first 1 + (N-1)*L*( 2*K + L ) elements
C             of DWORK should be preserved during successive calls of
C             the routine.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             JOB = 'Q':
C                LDWORK >= 1 + ( M*K + ( N - 1 )*L )*( L + 2*K ) + 6*L
C                            + MAX( M*K,( N - MAX( 1,P )*L ) );
C             JOB = 'R':
C                If P = 0,
C                   LDWORK >= MAX( 1 + ( N - 1 )*L*( L + 2*K ) + 6*L
C                                    + (N-1)*L, M*K*( L + 1 ) + L );
C                If P > 0,
C                   LDWORK >= 1 + (N-1)*L*( L + 2*K ) + 6*L + (N-P)*L.
C             For optimum performance LDWORK should be larger.
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             = 1:  the full rank condition for the first MIN(M*K, N*L)
C                   columns of T is (numerically) violated.
C
C     METHOD
C
C     Block Householder transformations and modified hyperbolic
C     rotations are used in the Schur algorithm [1], [2].
C
C     REFERENCES
C
C     [1] Kailath, T. and Sayed, A.
C         Fast Reliable Algorithms for Matrices with Structure.
C         SIAM Publications, Philadelphia, 1999.
C
C     [2] Kressner, D. and Van Dooren, P.
C         Factorizations and linear system solvers for matrices with
C         Toeplitz structure.
C         SLICOT Working Note 2000-2, 2000.
C
C     NUMERICAL ASPECTS
C
C     The implemented method yields a factor R which has comparable
C     accuracy with the Cholesky factor of T^T * T. Q is implicitly
C     computed from the formula Q = T * inv(R^T R) * R, i.e., for ill
C     conditioned problems this factor is of very limited value.
C                                 2
C     The algorithm requires 0(K*L *M*N) floating point operations.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Berlin, Germany, May 2001.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, June 2001.
C     D. Kressner, Technical Univ. Berlin, Germany, July 2002.
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004,
C     Aug. 2011.
C
C     KEYWORDS
C
C     Elementary matrix operations, Householder transformation, matrix
C     operations, Toeplitz matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOB
      INTEGER           INFO, K, L, LDQ, LDR, LDTC, LDTR, LDWORK,
     $                  M, N, P, S
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(LDWORK), Q(LDQ,*), R(LDR,*), TC(LDTC,*),
     $                  TR(LDTR,*)
C     .. Local Scalars ..
      INTEGER           COLR, I, IERR, KK, LEN, NB, NBMIN, PDQ, PDW,
     $                  PNQ, PNR, PRE, PT, RNK, SHFR, STPS, WRKMIN,
     $                  WRKOPT
      LOGICAL           COMPQ, LQUERY
C     .. Local Arrays ..
      INTEGER           IPVT(1)
C     .. External Functions ..
      LOGICAL           LSAME
      INTEGER           ILAENV
      EXTERNAL          ILAENV, LSAME
C     .. External Subroutines ..
      EXTERNAL          DGELQF, DGEQRF, DLACPY, DLASET, DORGQR, MA02AD,
     $                  MB02CU, MB02CV, MB02KD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX, MIN
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      INFO  = 0
      COMPQ = LSAME( JOB, 'Q' )
      IF ( COMPQ ) THEN
         WRKMIN = 1 + ( M*K + ( N - 1 )*L )*( L + 2*K ) + 6*L
     $              + MAX( M*K, ( N - MAX( 1, P ) )*L )
      ELSE
         WRKMIN = 1 + ( N - 1 )*L*( L + 2*K ) + 6*L
     $              + ( N - MAX( P, 1 ) )*L
         IF ( P.EQ.0 ) THEN
            WRKMIN = MAX( WRKMIN, M*K*( L + 1 ) + L )
         END IF
      END IF
C
C     Check the scalar input parameters.
C
      IF ( .NOT.( COMPQ .OR. LSAME( JOB, 'R' ) ) ) THEN
         INFO = -1
      ELSE IF ( K.LT.0 ) THEN
         INFO = -2
      ELSE IF ( L.LT.0 ) THEN
         INFO = -3
      ELSE IF ( M.LT.0 ) THEN
         INFO = -4
      ELSE IF ( N.LT.0 ) THEN
         INFO = -5
      ELSE IF ( P*L.GE.MIN( M*K, N*L ) + L .OR. P.LT.0 ) THEN
         INFO = -6
      ELSE IF ( ( P + S )*L.GE.MIN( M*K, N*L ) + L .OR. S.LT.0  ) THEN
         INFO = -7
      ELSE IF ( LDTC.LT.MAX( 1, M*K ) ) THEN
         INFO = -9
      ELSE IF ( LDTR.LT.MAX( 1, K ) ) THEN
         INFO = -11
      ELSE IF ( LDQ.LT.1 .OR. ( COMPQ .AND. LDQ.LT.M*K ) ) THEN
         INFO = -13
      ELSE IF ( LDR.LT.MAX( 1, MIN( N, N - P + 1 )*L ) ) THEN
         INFO = -15
      ELSE
         LQUERY = LDWORK.EQ.-1
         IF ( LQUERY ) THEN
            WRKOPT = 1
            IF ( M*K.LE.L ) THEN
               PDW = M*K*L + M*K
               CALL DGEQRF( M*K, L, DWORK, M*K, DWORK, DWORK, -1, IERR )
               WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW )
               CALL DORGQR( M*K, M*K, M*K, DWORK, M*K, DWORK, DWORK, -1,
     $                      IERR )
               WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW )
               IF ( N.GT.1 ) THEN
                  PDW = M*K*M*K
                  CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, M*K,
     $                         ONE, ZERO, TC, LDTC, TR, LDTR, DWORK,
     $                         M*K, R, LDR, DWORK, -1, IERR )
                  WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW )
               END IF
C
            ELSE IF ( P.EQ.0 ) THEN
               IF ( COMPQ ) THEN
                  CALL DGEQRF( M*K, L, Q, LDQ, DWORK, DWORK, -1, IERR )
                  WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + L )
                  CALL DORGQR( M*K, L, L, Q, LDQ, DWORK, DWORK, -1,
     $                        IERR )
                  WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + L )
                  IF ( N.GT.1 ) THEN
                     CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L,
     $                            ONE, ZERO, TC, LDTC, TR, LDTR, Q, LDQ,
     $                            R, LDR, DWORK, LDWORK, IERR )
                     WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
                  END IF
               ELSE
                  PDW = M*K*L
                  CALL DGEQRF( M*K, L, DWORK, M*K, DWORK, DWORK, -1,
     $                        IERR )
                  WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW + L )
                  CALL DORGQR( M*K, L, L, DWORK, M*K, DWORK, DWORK, -1,
     $                         IERR )
                  WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW + L )
                  IF ( N.GT.1 ) THEN
                     CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L,
     $                            ONE, ZERO, TC, LDTC, TR, LDTR, DWORK,
     $                            M*K, R, LDR, DWORK, -1, IERR )
                     WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW )
                  END IF
               END IF
               PRE = 1
            END IF
C
            IF ( M*K.GT.L .OR. P.GT.0 .OR.
     $         ( P.EQ.0 .AND. N.GT.1 ) ) THEN
               PRE = MAX( 1, P )
               IF ( COMPQ ) THEN
                  PDW = ( 2*K + L )*( ( N - 1 )*L + M*K ) + 1
                  LEN = MAX( L + M*K, ( N - PRE + 1 )*L )
               ELSE
                  PDW = ( 2*K + L )*( N - 1 )*L + 1
                  LEN = ( N - PRE + 1 )*L
               END IF
C
               CALL DGELQF( LEN, L, DWORK, MAX( 1, LEN ), DWORK, DWORK,
     $                      -1, IERR )
               WRKOPT = MAX( WRKOPT, PDW + 6*L + INT( DWORK(1) ) )
            END IF
         ELSE IF ( LDWORK.LT.WRKMIN ) THEN
            DWORK(1) = DBLE( WRKMIN )
            INFO = -17
         END IF
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO .NE. 0 ) THEN
         CALL XERBLA( 'MB02JD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MIN( M, N, K*L, S ) .EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Catch M*K <= L.
C
      WRKOPT = 1
      IF ( M*K.LE.L ) THEN
         CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K )
         PDW = M*K*L + 1
         CALL DGEQRF( M*K, L, DWORK, M*K, DWORK(PDW),
     $                DWORK(PDW+M*K), LDWORK-PDW-M*K+1, IERR )
         WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+M*K) ) + PDW + M*K - 1 )
         CALL MA02AD( 'Upper part', M*K, L, DWORK, M*K, R, LDR )
         CALL DORGQR( M*K, M*K, M*K, DWORK, M*K, DWORK(PDW),
     $                DWORK(PDW+M*K), LDWORK-PDW-M*K+1, IERR )
         WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+M*K) ) + PDW + M*K - 1 )
         IF ( COMPQ ) THEN
            CALL DLACPY( 'All', M*K, M*K, DWORK, M*K, Q, LDQ )
         END IF
         PDW = M*K*M*K + 1
         IF ( N.GT.1 ) THEN
            CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, M*K, ONE,
     $                   ZERO, TC, LDTC, TR, LDTR, DWORK, M*K, R(L+1,1),
     $                   LDR, DWORK(PDW), LDWORK-PDW+1, IERR )
            WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 )
         END IF
         DWORK(1) = DBLE( WRKOPT )
         RETURN
      END IF
C
C     Compute the generator if P = 0.
C
      IF ( P.EQ.0 ) THEN
C
C        1st column of the generator.
C
         IF ( COMPQ ) THEN
            CALL DLACPY( 'All', M*K, L, TC, LDTC, Q, LDQ )
            CALL DGEQRF( M*K, L, Q, LDQ, DWORK, DWORK(L+1),
     $                   LDWORK-L, IERR )
            WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L )
            CALL MA02AD( 'Upper part', L, L, Q, LDQ, R, LDR )
            CALL DORGQR( M*K, L, L, Q, LDQ, DWORK, DWORK(L+1), LDWORK-L,
     $                  IERR )
            WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L )
            IF ( N.GT.1 ) THEN
               CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L, ONE,
     $                      ZERO, TC, LDTC, TR, LDTR, Q, LDQ, R(L+1,1),
     $                      LDR, DWORK, LDWORK, IERR )
               WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
            END IF
         ELSE
            PDW = M*K*L + 1
            CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K )
            CALL DGEQRF( M*K, L, DWORK, M*K, DWORK(PDW), DWORK(PDW+L),
     $                   LDWORK-PDW-L+1, IERR )
            WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+L) ) + PDW + L - 1 )
            CALL MA02AD( 'Upper part', L, L, DWORK, M*K, R, LDR )
            CALL DORGQR( M*K, L, L, DWORK, M*K, DWORK(PDW),
     $                   DWORK(PDW+L), LDWORK-PDW-L+1, IERR )
            WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+L) ) + PDW + L - 1 )
            IF ( N.GT.1 ) THEN
               CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L, ONE,
     $                      ZERO, TC, LDTC, TR, LDTR, DWORK, M*K,
     $                      R(L+1,1), LDR, DWORK(PDW), LDWORK-PDW+1,
     $                      IERR )
               WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 )
            END IF
         END IF
C
C        Quick return if N = 1.
C
         IF ( N.EQ.1 ) THEN
            DWORK(1) = DBLE( WRKOPT )
            RETURN
         END IF
C
C        2nd column of the generator.
C
         PNR = ( N - 1 )*L*K + 2
         CALL MA02AD( 'All', K, (N-1)*L, TR, LDTR, DWORK(2), (N-1)*L )
C
C        3rd and 4th column of the generator.
C
         CALL DLACPY( 'All', (N-1)*L, L, R(L+1,1), LDR, DWORK(PNR),
     $                (N-1)*L )
         PT  = ( M - 1 )*K + 1
         PDW = PNR + ( N - 1 )*L*L
C
         DO 10  I = 1, MIN( M, N-1 )
            CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW),
     $                   (N-1)*L )
            PT  = PT  - K
            PDW = PDW + L
   10    CONTINUE
C
         PT = 1
C
         DO 20  I = M + 1, N - 1
            CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW),
     $                   (N-1)*L )
            PT  = PT  + L
            PDW = PDW + L
   20    CONTINUE
C
         IF ( COMPQ ) THEN
            PDQ = ( 2*K + L )*( N - 1 )*L + 2
            PDW = ( 2*K + L )*( ( N - 1 )*L + M*K ) + 2
            PNQ = PDQ + M*K*K
            CALL DLASET( 'All', K, K, ZERO, ONE, DWORK(PDQ), M*K )
            CALL DLASET( 'All', (M-1)*K, K, ZERO, ZERO, DWORK(PDQ+K),
     $                   M*K )
            CALL DLACPY( 'All', M*K, L, Q, LDQ, DWORK(PNQ), M*K )
            CALL DLASET( 'All', M*K, K, ZERO, ZERO, DWORK(PNQ+M*L*K),
     $                   M*K )
         ELSE
            PDW = ( 2*K + L )*( N - 1 )*L + 2
         END IF
         PRE  = 1
         STPS = S - 1
      ELSE
C
C        Set workspace pointers.
C
         PNR = ( N - 1 )*L*K + 2
         IF ( COMPQ ) THEN
            PDQ = ( 2*K + L )*( N - 1 )*L + 2
            PDW = ( 2*K + L )*( ( N - 1 )*L + M*K ) + 2
            PNQ = PDQ + M*K*K
         ELSE
            PDW = ( 2*K + L )*( N - 1 )*L + 2
         END IF
         PRE  = P
         STPS = S
      END IF
C
C     Determine suitable size for the block Housholder reflectors.
C
      IF ( COMPQ ) THEN
         LEN = MAX( L + M*K, ( N - PRE + 1 )*L )
      ELSE
         LEN = ( N - PRE + 1 )*L
      END IF
      NB    = MIN( ( LDWORK - PDW - 6*L + 1 ) / LEN, L )
      NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', LEN, L, -1, -1 ) )
      IF ( NB.LT.NBMIN )  NB = 0
      COLR = L + 1
C
C     Generator reduction process.
C
      LEN  = ( N - PRE )*L
      SHFR = ( PRE - 1 )*L
      DO 30  I = PRE, PRE + STPS - 1
C
C        IF M*K < N*L the last block might have less than L columns.
C
         KK = MIN( L, M*K - I*L )
         CALL DLACPY( 'Lower', LEN, KK, R(COLR-L,COLR-L), LDR,
     $                R(COLR,COLR), LDR )
         CALL MB02CU( 'Column', KK, KK+K, L+K, NB, R(COLR,COLR), LDR,
     $                 DWORK(SHFR+2), (N-1)*L, DWORK(PNR+SHFR), (N-1)*L,
     $                 RNK, IPVT, DWORK(PDW), ZERO, DWORK(PDW+6*L),
     $                 LDWORK-PDW-6*L+1, IERR )
         IF ( IERR.NE.0 )  THEN
C
C           Error return:  The rank condition is (numerically) not
C                          satisfied.
C
            INFO = 1
            RETURN
         END IF
         IF ( LEN.GT.KK ) THEN
            CALL MB02CV( 'Column', 'NoStructure', KK, LEN-KK, KK+K, L+K,
     $                   NB, -1, R(COLR,COLR), LDR, DWORK(SHFR+2),
     $                   (N-1)*L, DWORK(PNR+SHFR), (N-1)*L,
     $                   R(COLR+KK,COLR), LDR, DWORK(SHFR+KK+2),
     $                   (N-1)*L, DWORK(PNR+SHFR+KK), (N-1)*L,
     $                   DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1,
     $                   IERR )
         END IF
         IF ( COMPQ ) THEN
            CALL DLASET( 'All', K, KK, ZERO, ZERO, Q(1,COLR), LDQ )
            IF ( M.GT.1 ) THEN
               CALL DLACPY( 'All', (M-1)*K, KK, Q(1,COLR-L), LDQ,
     $                      Q(K+1,COLR), LDQ )
            END IF
            CALL MB02CV( 'Column', 'NoStructure', KK, M*K, KK+K, L+K,
     $                   NB, -1, R(COLR,COLR), LDR, DWORK(SHFR+2),
     $                   (N-1)*L, DWORK(PNR+SHFR), (N-1)*L, Q(1,COLR),
     $                   LDQ, DWORK(PDQ), M*K, DWORK(PNQ), M*K,
     $                   DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1,
     $                   IERR )
         END IF
         LEN  = LEN  - L
         COLR = COLR + L
         SHFR = SHFR + L
   30 CONTINUE
C
      DWORK(1) = DBLE( WRKOPT )
      RETURN
C
C *** Last line of MB02JD ***
      END
