SRC/sgemlqt.f

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