SRC/sgemlq.f

   1 *
   2 *  Definition:
   3 *  ===========
   4 *
   5 *      SUBROUTINE SGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1,
   6 *     $                LWORK1, C, LDC, WORK2, LWORK2, INFO )
   7 *
   8 *
   9 *     .. Scalar Arguments ..
  10 *      CHARACTER         SIDE, TRANS
  11 *      INTEGER           INFO, LDA, M, N, K, MB, NB, LWORK1, LWORK2, LDC
  12 *     ..
  13 *     .. Array Arguments ..
  14 *      REAL              A( LDA, * ), WORK1( * ), C(LDC, * ),
  15 *     $                  WORK2( * )
  16 *> \par Purpose:
  17 *  =============
  18 *>
  19 *> \verbatim
  20 *>
  21 *>     DGEMLQ overwrites the general real M-by-N matrix C with
  22 *>
  23 *>
  24 *>                    SIDE = 'L'     SIDE = 'R'
  25 *>    TRANS = 'N':      Q * C          C * Q
  26 *>    TRANS = 'T':      Q**T * C       C * Q**T
  27 *>    where Q is a real orthogonal matrix defined as the product
  28 *>    of blocked elementary reflectors computed by short wide LQ
  29 *>    factorization (DGELQ)
  30 *> \endverbatim
  31 *
  32 *  Arguments:
  33 *  ==========
  34 *
  35 *> \param[in] SIDE
  36 *>          SIDE is CHARACTER*1
  37 *>          = 'L': apply Q or Q**T from the Left;
  38 *>          = 'R': apply Q or Q**T from the Right.
  39 *>
  40 *> \param[in] TRANS
  41 *>          TRANS is CHARACTER*1
  42 *>          = 'N':  No transpose, apply Q;
  43 *>          = 'T':  Transpose, apply Q**T.
  44 *> \param[in] M
  45 *> \verbatim
  46 *>          M is INTEGER
  47 *>          The number of rows of the matrix A.  M >=0.
  48 *> \endverbatim
  49 *>
  50 *> \param[in] N
  51 *> \verbatim
  52 *>          N is INTEGER
  53 *>          The number of columns of the matrix C. N >= M.
  54 *> \endverbatim
  55 *>
  56 *> \param[in] K
  57 *> \verbatim
  58 *>          K is INTEGER
  59 *>          The number of elementary reflectors whose product defines
  60 *>          the matrix Q.
  61 *>          M >= K >= 0;
  62 *>
  63 *> \endverbatim
  64 *>
  65 *> \param[in,out] A
  66 *> \verbatim
  67 *>          A is REAL array, dimension (LDA,K)
  68 *>          The i-th row must contain the vector which defines the blocked
  69 *>          elementary reflector H(i), for i = 1,2,...,k, as returned by
  70 *>          DLASWLQ in the first k rows of its array argument A.
  71 *> \endverbatim
  72 *>
  73 *> \param[in] LDA
  74 *> \verbatim
  75 *>          LDA is INTEGER
  76 *>          The leading dimension of the array A.
  77 *>          If SIDE = 'L', LDA >= max(1,M);
  78 *>          if SIDE = 'R', LDA >= max(1,N).
  79 *> \endverbatim
  80 *>
  81 *> \param[in] WORK1
  82 *> \verbatim
  83 *>          WORK1 is REAL array, dimension (MAX(1,LWORK1)) is
  84 *>          returned by GEQR.
  85 *> \endverbatim
  86 *>
  87 *> \param[in] LWORK1
  88 *> \verbatim
  89 *>          LWORK1 is INTEGER
  90 *>          The dimension of the array WORK1.
  91 *> \endverbatim
  92 *>
  93 *> \param[in,out] C
  94 *>          C is REAL array, dimension (LDC,N)
  95 *>          On entry, the M-by-N matrix C.
  96 *>          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
  97 *> \param[in] LDC
  98 *>          LDC is INTEGER
  99 *>          The leading dimension of the array C. LDC >= max(1,M).
 100 *>
 101 *> \param[out] WORK2
 102 *> \verbatim
 103 *>         (workspace) REAL array, dimension (MAX(1,LWORK2))
 104 *>
 105 *> \endverbatim
 106 *> \param[in] LWORK2
 107 *> \verbatim
 108 *>          LWORK2 is INTEGER
 109 *>          The dimension of the array WORK2.
 110 *>          If LWORK2 = -1, then a workspace query is assumed; the routine
 111 *>          only calculates the optimal size of the WORK2 array, returns
 112 *>          this value as the third entry of the WORK2 array (WORK2(1)),
 113 *>          and no error message related to LWORK2 is issued by XERBLA.
 114 *>
 115 *> \endverbatim
 116 *> \param[out] INFO
 117 *> \verbatim
 118 *>          INFO is INTEGER
 119 *>          = 0:  successful exit
 120 *>          < 0:  if INFO = -i, the i-th argument had an illegal value
 121 *> \endverbatim
 122 *
 123 *  Authors:
 124 *  ========
 125 *
 126 *> \author Univ. of Tennessee
 127 *> \author Univ. of California Berkeley
 128 *> \author Univ. of Colorado Denver
 129 *> \author NAG Ltd.
 130 *
 131 *> \par Further Details:
 132 *  =====================
 133 *>
 134 *> \verbatim
 135 *>  Depending on the matrix dimensions M and N, and row and column
 136 *>  block sizes MB and NB returned by ILAENV, GELQ will use either
 137 *>  LASWLQ(if the matrix is short-and-wide) or GELQT to compute
 138 *>  the LQ decomposition.
 139 *>  The output of LASWLQ or GELQT representing Q is stored in A and in
 140 *>  array WORK1(6:LWORK1) for later use.
 141 *>  WORK1(2:5) contains the matrix dimensions M,N and block sizes MB, NB
 142 *>  which are needed to interpret A and WORK1(6:LWORK1) for later use.
 143 *>  WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
 144 *>  decide whether LASWLQ or GELQT was used is the same as used below in
 145 *>  GELQ. For a detailed description of A and WORK1(6:LWORK1), see
 146 *>  Further Details in LASWLQ or GELQT.
 147 *> \endverbatim
 148 *>
 149 *  =====================================================================
 150       SUBROUTINE SGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
 151      $      C, LDC, WORK2, LWORK2, INFO )
 152 *
 153 *  -- LAPACK computational routine (version 3.5.0) --
 154 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
 155 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
 156 *     November 2013
 157 *
 158 *     .. Scalar Arguments ..
 159       CHARACTER         SIDE, TRANS
 160       INTEGER           INFO, LDA, M, N, K, LWORK1, LWORK2, LDC
 161 *     ..
 162 *     .. Array Arguments ..
 163       REAL              A( LDA, * ), C( LDC, * ), WORK1( * ), WORK2( * )
 164 *     ..
 165 *
 166 * =====================================================================
 167 *
 168 *     ..
 169 *     .. Local Scalars ..
 170       LOGICAL    LEFT, RIGHT, TRAN, NOTRAN, LQUERY
 171       INTEGER    I, II, KK, MB, NB, LW, NBLCKS, MN
 172 *     ..
 173 *     .. External Functions ..
 174       LOGICAL            LSAME
 175       EXTERNAL           LSAME
 176 *     .. External Subroutines ..
 177       EXTERNAL           STPMLQT, SGEMLQT, XERBLA
 178 *     .. Intrinsic Functions ..
 179       INTRINSIC          INT, MAX, MIN, MOD
 180 *     ..
 181 *     .. Executable Statements ..
 182 *
 183 *     Test the input arguments
 184 *
 185       LQUERY  = LWORK2.LT.0
 186       NOTRAN  = LSAME( TRANS, 'N' )
 187       TRAN    = LSAME( TRANS, 'T' )
 188       LEFT    = LSAME( SIDE, 'L' )
 189       RIGHT   = LSAME( SIDE, 'R' )
 190 *
 191       MB = INT(WORK1(4))
 192       NB = INT(WORK1(5))
 193       IF (LEFT) THEN
 194         LW = N * MB
 195         MN = M
 196       ELSE
 197         LW = M * MB
 198         MN = N
 199       END IF
 200       IF ((NB.GT.K).AND.(MN.GT.K)) THEN
 201         IF(MOD(MN-K, NB-K).EQ.0) THEN
 202           NBLCKS = (MN-K)/(NB-K)
 203         ELSE
 204           NBLCKS = (MN-K)/(NB-K) + 1
 205         END IF
 206       ELSE
 207         NBLCKS = 1
 208       END IF
 209 *
 210       INFO = 0
 211       IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
 212          INFO = -1
 213       ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
 214          INFO = -2
 215       ELSE IF( M.LT.0 ) THEN
 216         INFO = -3
 217       ELSE IF( N.LT.0) THEN
 218         INFO = -4
 219       ELSE IF( K.LT.0 ) THEN
 220         INFO = -5
 221       ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
 222         INFO = -7
 223       ELSE IF( LWORK1.LT.MAX( 1, MB*K*NBLCKS+5 )) THEN
 224         INFO = -9
 225       ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
 226          INFO = -11
 227       ELSE IF(( LWORK2.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN
 228         INFO = -13
 229       END IF
 230 *
 231       IF( INFO.EQ.0)  THEN
 232         WORK2(1) = LW
 233       END IF
 234       IF( INFO.NE.0 ) THEN
 235         CALL XERBLA( 'SGEMLQ', -INFO )
 236         RETURN
 237       ELSE IF (LQUERY) THEN
 238         RETURN
 239       END IF
 240 *
 241 *     Quick return if possible
 242 *
 243       IF( MIN(M,N,K).EQ.0 ) THEN
 244         RETURN
 245       END IF
 246 *
 247       IF((LEFT.AND.M.LE.K).OR.(RIGHT.AND.N.LE.K).OR.(NB.LE.K).OR.
 248      $   (NB.GE.MAX(M,N,K))) THEN
 249         CALL SGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA,
 250      $        WORK1(6), MB, C, LDC, WORK2, INFO)
 251       ELSE
 252         CALL SLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, WORK1(6),
 253      $    MB, C, LDC, WORK2, LWORK2, INFO )
 254       END IF
 255 *
 256       WORK2(1) = LW
 257       RETURN
 258 *
 259 *     End of SGEMLQ
 260 *
 261       END