SRC/cunglq.f

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