SRC/dgemlqt.f

   1 *> \brief \b DGEMLQT
   2 *
   3 *  =========== DOCUMENTATION ===========
   4 *
   5 * Online html documentation available at
   6 *            http://www.netlib.org/lapack/explore-html/
   7 *
   8 *> \htmlonly
   9 *> Download DGEMQRT + dependencies
  10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgemlqt.f">
  11 *> [TGZ]</a>
  12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgemlqt.f">
  13 *> [ZIP]</a>
  14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgemlqt.f">
  15 *> [TXT]</a>
  16 *> \endhtmlonly
  17 *
  18 *  Definition:
  19 *  ===========
  20 *
  21 *       SUBROUTINE DGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT,
  22 *                          C, LDC, WORK, INFO )
  23 *
  24 *       .. Scalar Arguments ..
  25 *       CHARACTER SIDE, TRANS
  26 *       INTEGER   INFO, K, LDV, LDC, M, N, MB, LDT
  27 *       ..
  28 *       .. Array Arguments ..
  29 *       DOUBLE PRECISION V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * )
  30 *       ..
  31 *
  32 *
  33 *> \par Purpose:
  34 *  =============
  35 *>
  36 *> \verbatim
  37 *>
  38 *> DGEMQRT overwrites the general real M-by-N matrix C with
  39 *>
  40 *>                 SIDE = 'L'     SIDE = 'R'
  41 *> TRANS = 'N':      Q C            C Q
  42 *> TRANS = 'T':   Q**T C            C Q**T
  43 *>
  44 *> where Q is a real orthogonal matrix defined as the product of K
  45 *> elementary reflectors:
  46 *>
  47 *>       Q = H(1) H(2) . . . H(K) = I - V T V**T
  48 *>
  49 *> generated using the compact WY representation as returned by DGELQT.
  50 *>
  51 *> Q is of order M if SIDE = 'L' and of order N  if SIDE = 'R'.
  52 *> \endverbatim
  53 *
  54 *  Arguments:
  55 *  ==========
  56 *
  57 *> \param[in] SIDE
  58 *> \verbatim
  59 *>          SIDE is CHARACTER*1
  60 *>          = 'L': apply Q or Q**T from the Left;
  61 *>          = 'R': apply Q or Q**T from the Right.
  62 *> \endverbatim
  63 *>
  64 *> \param[in] TRANS
  65 *> \verbatim
  66 *>          TRANS is CHARACTER*1
  67 *>          = 'N':  No transpose, apply Q;
  68 *>          = 'C':  Transpose, apply Q**T.
  69 *> \endverbatim
  70 *>
  71 *> \param[in] M
  72 *> \verbatim
  73 *>          M is INTEGER
  74 *>          The number of rows of the matrix C. M >= 0.
  75 *> \endverbatim
  76 *>
  77 *> \param[in] N
  78 *> \verbatim
  79 *>          N is INTEGER
  80 *>          The number of columns of the matrix C. N >= 0.
  81 *> \endverbatim
  82 *>
  83 *> \param[in] K
  84 *> \verbatim
  85 *>          K is INTEGER
  86 *>          The number of elementary reflectors whose product defines
  87 *>          the matrix Q.
  88 *>          If SIDE = 'L', M >= K >= 0;
  89 *>          if SIDE = 'R', N >= K >= 0.
  90 *> \endverbatim
  91 *>
  92 *> \param[in] MB
  93 *> \verbatim
  94 *>          MB is INTEGER
  95 *>          The block size used for the storage of T.  K >= MB >= 1.
  96 *>          This must be the same value of MB used to generate T
  97 *>          in DGELQT.
  98 *> \endverbatim
  99 *>
 100 *> \param[in] V
 101 *> \verbatim
 102 *>          V is DOUBLE PRECISION array, dimension (LDV,K)
 103 *>          The i-th row must contain the vector which defines the
 104 *>          elementary reflector H(i), for i = 1,2,...,k, as returned by
 105 *>          DGELQT in the first K rows of its array argument A.
 106 *> \endverbatim
 107 *>
 108 *> \param[in] LDV
 109 *> \verbatim
 110 *>          LDV is INTEGER
 111 *>          The leading dimension of the array V.
 112 *>          If SIDE = 'L', LDA >= max(1,M);
 113 *>          if SIDE = 'R', LDA >= max(1,N).
 114 *> \endverbatim
 115 *>
 116 *> \param[in] T
 117 *> \verbatim
 118 *>          T is DOUBLE PRECISION array, dimension (LDT,K)
 119 *>          The upper triangular factors of the block reflectors
 120 *>          as returned by DGELQT, stored as a MB-by-M matrix.
 121 *> \endverbatim
 122 *>
 123 *> \param[in] LDT
 124 *> \verbatim
 125 *>          LDT is INTEGER
 126 *>          The leading dimension of the array T.  LDT >= MB.
 127 *> \endverbatim
 128 *>
 129 *> \param[in,out] C
 130 *> \verbatim
 131 *>          C is DOUBLE PRECISION array, dimension (LDC,N)
 132 *>          On entry, the M-by-N matrix C.
 133 *>          On exit, C is overwritten by Q C, Q**T C, C Q**T or C Q.
 134 *> \endverbatim
 135 *>
 136 *> \param[in] LDC
 137 *> \verbatim
 138 *>          LDC is INTEGER
 139 *>          The leading dimension of the array C. LDC >= max(1,M).
 140 *> \endverbatim
 141 *>
 142 *> \param[out] WORK
 143 *> \verbatim
 144 *>          WORK is DOUBLE PRECISION array. The dimension of
 145 *>          WORK is N*MB if SIDE = 'L', or  M*MB if SIDE = 'R'.
 146 *> \endverbatim
 147 *>
 148 *> \param[out] INFO
 149 *> \verbatim
 150 *>          INFO is INTEGER
 151 *>          = 0:  successful exit
 152 *>          < 0:  if INFO = -i, the i-th argument had an illegal value
 153 *> \endverbatim
 154 *
 155 *  Authors:
 156 *  ========
 157 *
 158 *> \author Univ. of Tennessee
 159 *> \author Univ. of California Berkeley
 160 *> \author Univ. of Colorado Denver
 161 *> \author NAG Ltd.
 162 *
 163 *> \date November 2013
 164 *
 165 *> \ingroup doubleGEcomputational
 166 *
 167 *  =====================================================================
 168       SUBROUTINE DGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT,
 169      $                   C, LDC, WORK, INFO )
 170 *
 171 *  -- LAPACK computational routine (version 3.5.0) --
 172 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
 173 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
 174 *     November 2013
 175 *
 176 *     .. Scalar Arguments ..
 177       CHARACTER SIDE, TRANS
 178       INTEGER   INFO, K, LDV, LDC, M, N, MB, LDT
 179 *     ..
 180 *     .. Array Arguments ..
 181       DOUBLE PRECISION V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * )
 182 *     ..
 183 *
 184 *  =====================================================================
 185 *
 186 *     ..
 187 *     .. Local Scalars ..
 188       LOGICAL            LEFT, RIGHT, TRAN, NOTRAN
 189       INTEGER            I, IB, LDWORK, KF, Q
 190 *     ..
 191 *     .. External Functions ..
 192       LOGICAL            LSAME
 193       EXTERNAL           LSAME
 194 *     ..
 195 *     .. External Subroutines ..
 196       EXTERNAL           XERBLA, DLARFB
 197 *     ..
 198 *     .. Intrinsic Functions ..
 199       INTRINSIC          MAX, MIN
 200 *     ..
 201 *     .. Executable Statements ..
 202 *
 203 *     .. Test the input arguments ..
 204 *
 205       INFO   = 0
 206       LEFT   = LSAME( SIDE,  'L' )
 207       RIGHT  = LSAME( SIDE,  'R' )
 208       TRAN   = LSAME( TRANS, 'T' )
 209       NOTRAN = LSAME( TRANS, 'N' )
 210 *
 211       IF( LEFT ) THEN
 212          LDWORK = MAX( 1, N )
 213       ELSE IF ( RIGHT ) THEN
 214          LDWORK = MAX( 1, M )
 215       END IF
 216       IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
 217          INFO = -1
 218       ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
 219          INFO = -2
 220       ELSE IF( M.LT.0 ) THEN
 221          INFO = -3
 222       ELSE IF( N.LT.0 ) THEN
 223          INFO = -4
 224       ELSE IF( K.LT.0) THEN
 225          INFO = -5
 226       ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0)) THEN
 227          INFO = -6
 228       ELSE IF( LDV.LT.MAX( 1, K ) ) THEN
 229           INFO = -8
 230       ELSE IF( LDT.LT.MB ) THEN
 231          INFO = -10
 232       ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
 233          INFO = -12
 234       END IF
 235 *
 236       IF( INFO.NE.0 ) THEN
 237          CALL XERBLA( 'DGEMLQT', -INFO )
 238          RETURN
 239       END IF
 240 *
 241 *     .. Quick return if possible ..
 242 *
 243       IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN
 244 *
 245       IF( LEFT .AND. NOTRAN ) THEN
 246 *
 247          DO I = 1, K, MB
 248             IB = MIN( MB, K-I+1 )
 249             CALL DLARFB( 'L', 'T', 'F', 'R', M-I+1, N, IB,
 250      $                   V( I, I ), LDV, T( 1, I ), LDT,
 251      $                   C( I, 1 ), LDC, WORK, LDWORK )
 252          END DO
 253 *
 254       ELSE IF( RIGHT .AND. TRAN ) THEN
 255 *
 256          DO I = 1, K, MB
 257             IB = MIN( MB, K-I+1 )
 258             CALL DLARFB( 'R', 'N', 'F', 'R', M, N-I+1, IB,
 259      $                   V( I, I ), LDV, T( 1, I ), LDT,
 260      $                   C( 1, I ), LDC, WORK, LDWORK )
 261          END DO
 262 *
 263       ELSE IF( LEFT .AND. TRAN ) THEN
 264 *
 265          KF = ((K-1)/MB)*MB+1
 266          DO I = KF, 1, -MB
 267             IB = MIN( MB, K-I+1 )
 268             CALL DLARFB( 'L', 'N', 'F', 'R', M-I+1, N, IB,
 269      $                   V( I, I ), LDV, T( 1, I ), LDT,
 270      $                   C( I, 1 ), LDC, WORK, LDWORK )
 271          END DO
 272 *
 273       ELSE IF( RIGHT .AND. NOTRAN ) THEN
 274 *
 275          KF = ((K-1)/MB)*MB+1
 276          DO I = KF, 1, -MB
 277             IB = MIN( MB, K-I+1 )
 278             CALL DLARFB( 'R', 'T', 'F', 'R', M, N-I+1, IB,
 279      $                   V( I, I ), LDV, T( 1, I ), LDT,
 280      $                   C( 1, I ), LDC, WORK, LDWORK )
 281          END DO
 282 *
 283       END IF
 284 *
 285       RETURN
 286 *
 287 *     End of DGEMLQT
 288 *
 289       END