SRC/dorgqr.f

   1 *> \brief \b DORGQR
   2 *
   3 *  =========== DOCUMENTATION ===========
   4 *
   5 * Online html documentation available at
   6 *            http://www.netlib.org/lapack/explore-html/
   7 *
   8 *> \htmlonly
   9 *> Download DORGQR + dependencies
  10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorgqr.f">
  11 *> [TGZ]</a>
  12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorgqr.f">
  13 *> [ZIP]</a>
  14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorgqr.f">
  15 *> [TXT]</a>
  16 *> \endhtmlonly
  17 *
  18 *  Definition:
  19 *  ===========
  20 *
  21 *       SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
  22 *
  23 *       .. Scalar Arguments ..
  24 *       INTEGER            INFO, K, LDA, LWORK, M, N
  25 *       ..
  26 *       .. Array Arguments ..
  27 *       DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
  28 *       ..
  29 *
  30 *
  31 *> \par Purpose:
  32 *  =============
  33 *>
  34 *> \verbatim
  35 *>
  36 *> DORGQR generates an M-by-N real matrix Q with orthonormal columns,
  37 *> which is defined as the first N columns of a product of K elementary
  38 *> reflectors of order M
  39 *>
  40 *>       Q  =  H(1) H(2) . . . H(k)
  41 *>
  42 *> as returned by DGEQRF.
  43 *> \endverbatim
  44 *
  45 *  Arguments:
  46 *  ==========
  47 *
  48 *> \param[in] M
  49 *> \verbatim
  50 *>          M is INTEGER
  51 *>          The number of rows of the matrix Q. M >= 0.
  52 *> \endverbatim
  53 *>
  54 *> \param[in] N
  55 *> \verbatim
  56 *>          N is INTEGER
  57 *>          The number of columns of the matrix Q. M >= N >= 0.
  58 *> \endverbatim
  59 *>
  60 *> \param[in] K
  61 *> \verbatim
  62 *>          K is INTEGER
  63 *>          The number of elementary reflectors whose product defines the
  64 *>          matrix Q. N >= K >= 0.
  65 *> \endverbatim
  66 *>
  67 *> \param[in,out] A
  68 *> \verbatim
  69 *>          A is DOUBLE PRECISION array, dimension (LDA,N)
  70 *>          On entry, the i-th column must contain the vector which
  71 *>          defines the elementary reflector H(i), for i = 1,2,...,k, as
  72 *>          returned by DGEQRF in the first k columns of its array
  73 *>          argument A.
  74 *>          On exit, the M-by-N matrix Q.
  75 *> \endverbatim
  76 *>
  77 *> \param[in] LDA
  78 *> \verbatim
  79 *>          LDA is INTEGER
  80 *>          The first dimension of the array A. LDA >= max(1,M).
  81 *> \endverbatim
  82 *>
  83 *> \param[in] TAU
  84 *> \verbatim
  85 *>          TAU is DOUBLE PRECISION array, dimension (K)
  86 *>          TAU(i) must contain the scalar factor of the elementary
  87 *>          reflector H(i), as returned by DGEQRF.
  88 *> \endverbatim
  89 *>
  90 *> \param[out] WORK
  91 *> \verbatim
  92 *>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
  93 *>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
  94 *> \endverbatim
  95 *>
  96 *> \param[in] LWORK
  97 *> \verbatim
  98 *>          LWORK is INTEGER
  99 *>          The dimension of the array WORK. LWORK >= max(1,N).
 100 *>          For optimum performance LWORK >= N*NB, where NB is the
 101 *>          optimal blocksize.
 102 *>
 103 *>          If LWORK = -1, then a workspace query is assumed; the routine
 104 *>          only calculates the optimal size of the WORK array, returns
 105 *>          this value as the first entry of the WORK array, and no error
 106 *>          message related to LWORK is issued by XERBLA.
 107 *> \endverbatim
 108 *>
 109 *> \param[out] INFO
 110 *> \verbatim
 111 *>          INFO is INTEGER
 112 *>          = 0:  successful exit
 113 *>          < 0:  if INFO = -i, the i-th argument has an illegal value
 114 *> \endverbatim
 115 *
 116 *  Authors:
 117 *  ========
 118 *
 119 *> \author Univ. of Tennessee
 120 *> \author Univ. of California Berkeley
 121 *> \author Univ. of Colorado Denver
 122 *> \author NAG Ltd.
 123 *
 124 *> \date November 2011
 125 *
 126 *> \ingroup doubleOTHERcomputational
 127 *
 128 *  =====================================================================
 129       SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
 130 *
 131 *  -- LAPACK computational routine (version 3.4.0) --
 132 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
 133 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
 134 *     November 2011
 135 *
 136 *     .. Scalar Arguments ..
 137       INTEGER            INFO, K, LDA, LWORK, M, N
 138 *     ..
 139 *     .. Array Arguments ..
 140       DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
 141 *     ..
 142 *
 143 *  =====================================================================
 144 *
 145 *     .. Parameters ..
 146       DOUBLE PRECISION   ZERO
 147       PARAMETER          ( ZERO = 0.0D+0 )
 148 *     ..
 149 *     .. Local Scalars ..
 150       LOGICAL            LQUERY
 151       INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
 152      $                   LWKOPT, NB, NBMIN, NX
 153 *     ..
 154 *     .. External Subroutines ..
 155       EXTERNAL           DLARFB, DLARFT, DORG2R, XERBLA
 156 *     ..
 157 *     .. Intrinsic Functions ..
 158       INTRINSIC          MAX, MIN
 159 *     ..
 160 *     .. External Functions ..
 161       INTEGER            ILAENV
 162       EXTERNAL           ILAENV
 163 *     ..
 164 *     .. Executable Statements ..
 165 *
 166 *     Test the input arguments
 167 *
 168       INFO = 0
 169       NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 )
 170       LWKOPT = MAX( 1, N )*NB
 171       WORK( 1 ) = LWKOPT
 172       LQUERY = ( LWORK.EQ.-1 )
 173       IF( M.LT.0 ) THEN
 174          INFO = -1
 175       ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
 176          INFO = -2
 177       ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
 178          INFO = -3
 179       ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
 180          INFO = -5
 181       ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
 182          INFO = -8
 183       END IF
 184       IF( INFO.NE.0 ) THEN
 185          CALL XERBLA( 'DORGQR', -INFO )
 186          RETURN
 187       ELSE IF( LQUERY ) THEN
 188          RETURN
 189       END IF
 190 *
 191 *     Quick return if possible
 192 *
 193       IF( N.LE.0 ) THEN
 194          WORK( 1 ) = 1
 195          RETURN
 196       END IF
 197 *
 198       NBMIN = 2
 199       NX = 0
 200       IWS = N
 201       IF( NB.GT.1 .AND. NB.LT.K ) THEN
 202 *
 203 *        Determine when to cross over from blocked to unblocked code.
 204 *
 205          NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) )
 206          IF( NX.LT.K ) THEN
 207 *
 208 *           Determine if workspace is large enough for blocked code.
 209 *
 210             LDWORK = N
 211             IWS = LDWORK*NB
 212             IF( LWORK.LT.IWS ) THEN
 213 *
 214 *              Not enough workspace to use optimal NB:  reduce NB and
 215 *              determine the minimum value of NB.
 216 *
 217                NB = LWORK / LDWORK
 218                NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) )
 219             END IF
 220          END IF
 221       END IF
 222 *
 223       IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
 224 *
 225 *        Use blocked code after the last block.
 226 *        The first kk columns are handled by the block method.
 227 *
 228          KI = ( ( K-NX-1 ) / NB )*NB
 229          KK = MIN( K, KI+NB )
 230 *
 231 *        Set A(1:kk,kk+1:n) to zero.
 232 *
 233          DO 20 J = KK + 1, N
 234             DO 10 I = 1, KK
 235                A( I, J ) = ZERO
 236    10       CONTINUE
 237    20    CONTINUE
 238       ELSE
 239          KK = 0
 240       END IF
 241 *
 242 *     Use unblocked code for the last or only block.
 243 *
 244       IF( KK.LT.N )
 245      $   CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
 246      $                TAU( KK+1 ), WORK, IINFO )
 247 *
 248       IF( KK.GT.0 ) THEN
 249 *
 250 *        Use blocked code
 251 *
 252          DO 50 I = KI + 1, 1, -NB
 253             IB = MIN( NB, K-I+1 )
 254             IF( I+IB.LE.N ) THEN
 255 *
 256 *              Form the triangular factor of the block reflector
 257 *              H = H(i) H(i+1) . . . H(i+ib-1)
 258 *
 259                CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB,
 260      $                      A( I, I ), LDA, TAU( I ), WORK, LDWORK )
 261 *
 262 *              Apply H to A(i:m,i+ib:n) from the left
 263 *
 264                CALL DLARFB( 'Left', 'No transpose', 'Forward',
 265      $                      'Columnwise', M-I+1, N-I-IB+1, IB,
 266      $                      A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ),
 267      $                      LDA, WORK( IB+1 ), LDWORK )
 268             END IF
 269 *
 270 *           Apply H to rows i:m of current block
 271 *
 272             CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK,
 273      $                   IINFO )
 274 *
 275 *           Set rows 1:i-1 of current block to zero
 276 *
 277             DO 40 J = I, I + IB - 1
 278                DO 30 L = 1, I - 1
 279                   A( L, J ) = ZERO
 280    30          CONTINUE
 281    40       CONTINUE
 282    50    CONTINUE
 283       END IF
 284 *
 285       WORK( 1 ) = IWS
 286       RETURN
 287 *
 288 *     End of DORGQR
 289 *
 290       END