SRC/ztpmlqt.f

   1 *> \brief \b ZTPMLQT
   2 *
   3 *  =========== DOCUMENTATION ===========
   4 *
   5 * Online html documentation available at
   6 *            http://www.netlib.org/lapack/explore-html/
   7 *
   8 *> \htmlonly
   9 *> Download DTPMQRT + dependencies
  10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztpmlqt.f">
  11 *> [TGZ]</a>
  12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztpmlqt.f">
  13 *> [ZIP]</a>
  14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztpmlqt.f">
  15 *> [TXT]</a>
  16 *> \endhtmlonly
  17 *
  18 *  Definition:
  19 *  ===========
  20 *
  21 *       SUBROUTINE ZTPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT,
  22 *                           A, LDA, B, LDB, WORK, INFO )
  23 *
  24 *       .. Scalar Arguments ..
  25 *       CHARACTER SIDE, TRANS
  26 *       INTEGER   INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT
  27 *       ..
  28 *       .. Array Arguments ..
  29 *       COMPLEX*16         V( LDV, * ), A( LDA, * ), B( LDB, * ),
  30 *      $                   T( LDT, * ), WORK( * )
  31 *       ..
  32 *
  33 *
  34 *> \par Purpose:
  35 *  =============
  36 *>
  37 *> \verbatim
  38 *>
  39 *> ZTPMQRT applies a complex orthogonal matrix Q obtained from a
  40 *> "triangular-pentagonal" real block reflector H to a general
  41 *> real matrix C, which consists of two blocks A and B.
  42 *> \endverbatim
  43 *
  44 *  Arguments:
  45 *  ==========
  46 *
  47 *> \param[in] SIDE
  48 *> \verbatim
  49 *>          SIDE is CHARACTER*1
  50 *>          = 'L': apply Q or Q**C from the Left;
  51 *>          = 'R': apply Q or Q**C from the Right.
  52 *> \endverbatim
  53 *>
  54 *> \param[in] TRANS
  55 *> \verbatim
  56 *>          TRANS is CHARACTER*1
  57 *>          = 'N':  No transpose, apply Q;
  58 *>          = 'C':  Transpose, apply Q**C.
  59 *> \endverbatim
  60 *>
  61 *> \param[in] M
  62 *> \verbatim
  63 *>          M is INTEGER
  64 *>          The number of rows of the matrix B. M >= 0.
  65 *> \endverbatim
  66 *>
  67 *> \param[in] N
  68 *> \verbatim
  69 *>          N is INTEGER
  70 *>          The number of columns of the matrix B. N >= 0.
  71 *> \endverbatim
  72 *>
  73 *> \param[in] K
  74 *> \verbatim
  75 *>          K is INTEGER
  76 *>          The number of elementary reflectors whose product defines
  77 *>          the matrix Q.
  78 *> \endverbatim
  79 *>
  80 *> \param[in] L
  81 *> \verbatim
  82 *>          L is INTEGER
  83 *>          The order of the trapezoidal part of V.
  84 *>          K >= L >= 0.  See Further Details.
  85 *> \endverbatim
  86 *>
  87 *> \param[in] MB
  88 *> \verbatim
  89 *>          MB is INTEGER
  90 *>          The block size used for the storage of T.  K >= MB >= 1.
  91 *>          This must be the same value of MB used to generate T
  92 *>          in DTPLQT.
  93 *> \endverbatim
  94 *>
  95 *> \param[in] V
  96 *> \verbatim
  97 *>          V is COMPLEX*16 array, dimension (LDA,K)
  98 *>          The i-th row must contain the vector which defines the
  99 *>          elementary reflector H(i), for i = 1,2,...,k, as returned by
 100 *>          DTPLQT in B.  See Further Details.
 101 *> \endverbatim
 102 *>
 103 *> \param[in] LDV
 104 *> \verbatim
 105 *>          LDV is INTEGER
 106 *>          The leading dimension of the array V.
 107 *>          If SIDE = 'L', LDV >= max(1,M);
 108 *>          if SIDE = 'R', LDV >= max(1,N).
 109 *> \endverbatim
 110 *>
 111 *> \param[in] T
 112 *> \verbatim
 113 *>          T is COMPLEX*16 array, dimension (LDT,K)
 114 *>          The upper triangular factors of the block reflectors
 115 *>          as returned by DTPLQT, stored as a MB-by-K matrix.
 116 *> \endverbatim
 117 *>
 118 *> \param[in] LDT
 119 *> \verbatim
 120 *>          LDT is INTEGER
 121 *>          The leading dimension of the array T.  LDT >= MB.
 122 *> \endverbatim
 123 *>
 124 *> \param[in,out] A
 125 *> \verbatim
 126 *>          A is COMPLEX*16 array, dimension
 127 *>          (LDA,N) if SIDE = 'L' or
 128 *>          (LDA,K) if SIDE = 'R'
 129 *>          On entry, the K-by-N or M-by-K matrix A.
 130 *>          On exit, A is overwritten by the corresponding block of
 131 *>          Q*C or Q**C*C or C*Q or C*Q**C.  See Further Details.
 132 *> \endverbatim
 133 *>
 134 *> \param[in] LDA
 135 *> \verbatim
 136 *>          LDA is INTEGER
 137 *>          The leading dimension of the array A.
 138 *>          If SIDE = 'L', LDC >= max(1,K);
 139 *>          If SIDE = 'R', LDC >= max(1,M).
 140 *> \endverbatim
 141 *>
 142 *> \param[in,out] B
 143 *> \verbatim
 144 *>          B is COMPLEX*16 array, dimension (LDB,N)
 145 *>          On entry, the M-by-N matrix B.
 146 *>          On exit, B is overwritten by the corresponding block of
 147 *>          Q*C or Q**C*C or C*Q or C*Q**C.  See Further Details.
 148 *> \endverbatim
 149 *>
 150 *> \param[in] LDB
 151 *> \verbatim
 152 *>          LDB is INTEGER
 153 *>          The leading dimension of the array B.
 154 *>          LDB >= max(1,M).
 155 *> \endverbatim
 156 *>
 157 *> \param[out] WORK
 158 *> \verbatim
 159 *>          WORK is COMPLEX*16 array. The dimension of WORK is
 160 *>           N*MB if SIDE = 'L', or  M*MB if SIDE = 'R'.
 161 *> \endverbatim
 162 *>
 163 *> \param[out] INFO
 164 *> \verbatim
 165 *>          INFO is INTEGER
 166 *>          = 0:  successful exit
 167 *>          < 0:  if INFO = -i, the i-th argument had an illegal value
 168 *> \endverbatim
 169 *
 170 *  Authors:
 171 *  ========
 172 *
 173 *> \author Univ. of Tennessee
 174 *> \author Univ. of California Berkeley
 175 *> \author Univ. of Colorado Denver
 176 *> \author NAG Ltd.
 177 *
 178 *> \date November 2015
 179 *
 180 *> \ingroup doubleOTHERcomputational
 181 *
 182 *> \par Further Details:
 183 *  =====================
 184 *>
 185 *> \verbatim
 186 *>
 187 *>  The columns of the pentagonal matrix V contain the elementary reflectors
 188 *>  H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a
 189 *>  trapezoidal block V2:
 190 *>
 191 *>        V = [V1] [V2].
 192 *>
 193 *>
 194 *>  The size of the trapezoidal block V2 is determined by the parameter L,
 195 *>  where 0 <= L <= K; V2 is lower trapezoidal, consisting of the first L
 196 *>  rows of a K-by-K upper triangular matrix.  If L=K, V2 is lower triangular;
 197 *>  if L=0, there is no trapezoidal block, hence V = V1 is rectangular.
 198 *>
 199 *>  If SIDE = 'L':  C = [A]  where A is K-by-N,  B is M-by-N and V is K-by-M.
 200 *>                      [B]
 201 *>
 202 *>  If SIDE = 'R':  C = [A B]  where A is M-by-K, B is M-by-N and V is K-by-N.
 203 *>
 204 *>  The real orthogonal matrix Q is formed from V and T.
 205 *>
 206 *>  If TRANS='N' and SIDE='L', C is on exit replaced with Q * C.
 207 *>
 208 *>  If TRANS='C' and SIDE='L', C is on exit replaced with Q**C * C.
 209 *>
 210 *>  If TRANS='N' and SIDE='R', C is on exit replaced with C * Q.
 211 *>
 212 *>  If TRANS='C' and SIDE='R', C is on exit replaced with C * Q**C.
 213 *> \endverbatim
 214 *>
 215 *  =====================================================================
 216       SUBROUTINE ZTPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT,
 217      $                    A, LDA, B, LDB, WORK, INFO )
 218 *
 219 *  -- LAPACK computational routine (version 3.6.0) --
 220 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
 221 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
 222 *     November 2015
 223 *
 224 *     .. Scalar Arguments ..
 225       CHARACTER SIDE, TRANS
 226       INTEGER   INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT
 227 *     ..
 228 *     .. Array Arguments ..
 229       COMPLEX*16         V( LDV, * ), A( LDA, * ), B( LDB, * ),
 230      $                   T( LDT, * ), WORK( * )
 231 *     ..
 232 *
 233 *  =====================================================================
 234 *
 235 *     ..
 236 *     .. Local Scalars ..
 237       LOGICAL            LEFT, RIGHT, TRAN, NOTRAN
 238       INTEGER            I, IB, NB, LB, KF, LDAQ
 239 *     ..
 240 *     .. External Functions ..
 241       LOGICAL            LSAME
 242       EXTERNAL           LSAME
 243 *     ..
 244 *     .. External Subroutines ..
 245       EXTERNAL           XERBLA, ZTPRFB
 246 *     ..
 247 *     .. Intrinsic Functions ..
 248       INTRINSIC          MAX, MIN
 249 *     ..
 250 *     .. Executable Statements ..
 251 *
 252 *     .. Test the input arguments ..
 253 *
 254       INFO   = 0
 255       LEFT   = LSAME( SIDE,  'L' )
 256       RIGHT  = LSAME( SIDE,  'R' )
 257       TRAN   = LSAME( TRANS, 'C' )
 258       NOTRAN = LSAME( TRANS, 'N' )
 259 *
 260       IF ( LEFT ) THEN
 261          LDAQ = MAX( 1, K )
 262       ELSE IF ( RIGHT ) THEN
 263          LDAQ = MAX( 1, M )
 264       END IF
 265       IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
 266          INFO = -1
 267       ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
 268          INFO = -2
 269       ELSE IF( M.LT.0 ) THEN
 270          INFO = -3
 271       ELSE IF( N.LT.0 ) THEN
 272          INFO = -4
 273       ELSE IF( K.LT.0 ) THEN
 274          INFO = -5
 275       ELSE IF( L.LT.0 .OR. L.GT.K ) THEN
 276          INFO = -6
 277       ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0) ) THEN
 278          INFO = -7
 279       ELSE IF( LDV.LT.K ) THEN
 280          INFO = -9
 281       ELSE IF( LDT.LT.MB ) THEN
 282          INFO = -11
 283       ELSE IF( LDA.LT.LDAQ ) THEN
 284          INFO = -13
 285       ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
 286          INFO = -15
 287       END IF
 288 *
 289       IF( INFO.NE.0 ) THEN
 290          CALL XERBLA( 'ZTPMLQT', -INFO )
 291          RETURN
 292       END IF
 293 *
 294 *     .. Quick return if possible ..
 295 *
 296       IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN
 297 *
 298       IF( LEFT .AND. NOTRAN ) THEN
 299 *
 300          DO I = 1, K, MB
 301             IB = MIN( MB, K-I+1 )
 302             NB = MIN( M-L+I+IB-1, M )
 303             IF( I.GE.L ) THEN
 304                LB = 0
 305             ELSE
 306                LB = 0
 307             END IF
 308             CALL ZTPRFB( 'L', 'C', 'F', 'R', NB, N, IB, LB,
 309      $                   V( I, 1 ), LDV, T( 1, I ), LDT,
 310      $                   A( I, 1 ), LDA, B, LDB, WORK, IB )
 311          END DO
 312 *
 313       ELSE IF( RIGHT .AND. TRAN ) THEN
 314 *
 315          DO I = 1, K, MB
 316             IB = MIN( MB, K-I+1 )
 317             NB = MIN( N-L+I+IB-1, N )
 318             IF( I.GE.L ) THEN
 319                LB = 0
 320             ELSE
 321                LB = NB-N+L-I+1
 322             END IF
 323             CALL ZTPRFB( 'R', 'N', 'F', 'R', M, NB, IB, LB,
 324      $                   V( I, 1 ), LDV, T( 1, I ), LDT,
 325      $                   A( 1, I ), LDA, B, LDB, WORK, M )
 326          END DO
 327 *
 328       ELSE IF( LEFT .AND. TRAN ) THEN
 329 *
 330          KF = ((K-1)/MB)*MB+1
 331          DO I = KF, 1, -MB
 332             IB = MIN( MB, K-I+1 )
 333             NB = MIN( M-L+I+IB-1, M )
 334             IF( I.GE.L ) THEN
 335                LB = 0
 336             ELSE
 337                LB = 0
 338             END IF
 339             CALL ZTPRFB( 'L', 'N', 'F', 'R', NB, N, IB, LB,
 340      $                   V( I, 1 ), LDV, T( 1, I ), LDT,
 341      $                   A( I, 1 ), LDA, B, LDB, WORK, IB )
 342          END DO
 343 *
 344       ELSE IF( RIGHT .AND. NOTRAN ) THEN
 345 *
 346          KF = ((K-1)/MB)*MB+1
 347          DO I = KF, 1, -MB
 348             IB = MIN( MB, K-I+1 )
 349             NB = MIN( N-L+I+IB-1, N )
 350             IF( I.GE.L ) THEN
 351                LB = 0
 352             ELSE
 353                LB = NB-N+L-I+1
 354             END IF
 355             CALL ZTPRFB( 'R', 'C', 'F', 'R', M, NB, IB, LB,
 356      $                   V( I, 1 ), LDV, T( 1, I ), LDT,
 357      $                   A( 1, I ), LDA, B, LDB, WORK, M )
 358          END DO
 359 *
 360       END IF
 361 *
 362       RETURN
 363 *
 364 *     End of ZTPMLQT
 365 *
 366       END