![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b CUNGQL 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 *> \htmlonly 00009 *> Download CUNGQL + dependencies 00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cungql.f"> 00011 *> [TGZ]</a> 00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cungql.f"> 00013 *> [ZIP]</a> 00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cungql.f"> 00015 *> [TXT]</a> 00016 *> \endhtmlonly 00017 * 00018 * Definition: 00019 * =========== 00020 * 00021 * SUBROUTINE CUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) 00022 * 00023 * .. Scalar Arguments .. 00024 * INTEGER INFO, K, LDA, LWORK, M, N 00025 * .. 00026 * .. Array Arguments .. 00027 * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) 00028 * .. 00029 * 00030 * 00031 *> \par Purpose: 00032 * ============= 00033 *> 00034 *> \verbatim 00035 *> 00036 *> CUNGQL generates an M-by-N complex matrix Q with orthonormal columns, 00037 *> which is defined as the last N columns of a product of K elementary 00038 *> reflectors of order M 00039 *> 00040 *> Q = H(k) . . . H(2) H(1) 00041 *> 00042 *> as returned by CGEQLF. 00043 *> \endverbatim 00044 * 00045 * Arguments: 00046 * ========== 00047 * 00048 *> \param[in] M 00049 *> \verbatim 00050 *> M is INTEGER 00051 *> The number of rows of the matrix Q. M >= 0. 00052 *> \endverbatim 00053 *> 00054 *> \param[in] N 00055 *> \verbatim 00056 *> N is INTEGER 00057 *> The number of columns of the matrix Q. M >= N >= 0. 00058 *> \endverbatim 00059 *> 00060 *> \param[in] K 00061 *> \verbatim 00062 *> K is INTEGER 00063 *> The number of elementary reflectors whose product defines the 00064 *> matrix Q. N >= K >= 0. 00065 *> \endverbatim 00066 *> 00067 *> \param[in,out] A 00068 *> \verbatim 00069 *> A is COMPLEX array, dimension (LDA,N) 00070 *> On entry, the (n-k+i)-th column must contain the vector which 00071 *> defines the elementary reflector H(i), for i = 1,2,...,k, as 00072 *> returned by CGEQLF in the last k columns of its array 00073 *> argument A. 00074 *> On exit, the M-by-N matrix Q. 00075 *> \endverbatim 00076 *> 00077 *> \param[in] LDA 00078 *> \verbatim 00079 *> LDA is INTEGER 00080 *> The first dimension of the array A. LDA >= max(1,M). 00081 *> \endverbatim 00082 *> 00083 *> \param[in] TAU 00084 *> \verbatim 00085 *> TAU is COMPLEX array, dimension (K) 00086 *> TAU(i) must contain the scalar factor of the elementary 00087 *> reflector H(i), as returned by CGEQLF. 00088 *> \endverbatim 00089 *> 00090 *> \param[out] WORK 00091 *> \verbatim 00092 *> WORK is COMPLEX array, dimension (MAX(1,LWORK)) 00093 *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. 00094 *> \endverbatim 00095 *> 00096 *> \param[in] LWORK 00097 *> \verbatim 00098 *> LWORK is INTEGER 00099 *> The dimension of the array WORK. LWORK >= max(1,N). 00100 *> For optimum performance LWORK >= N*NB, where NB is the 00101 *> optimal blocksize. 00102 *> 00103 *> If LWORK = -1, then a workspace query is assumed; the routine 00104 *> only calculates the optimal size of the WORK array, returns 00105 *> this value as the first entry of the WORK array, and no error 00106 *> message related to LWORK is issued by XERBLA. 00107 *> \endverbatim 00108 *> 00109 *> \param[out] INFO 00110 *> \verbatim 00111 *> INFO is INTEGER 00112 *> = 0: successful exit 00113 *> < 0: if INFO = -i, the i-th argument has an illegal value 00114 *> \endverbatim 00115 * 00116 * Authors: 00117 * ======== 00118 * 00119 *> \author Univ. of Tennessee 00120 *> \author Univ. of California Berkeley 00121 *> \author Univ. of Colorado Denver 00122 *> \author NAG Ltd. 00123 * 00124 *> \date November 2011 00125 * 00126 *> \ingroup complexOTHERcomputational 00127 * 00128 * ===================================================================== 00129 SUBROUTINE CUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) 00130 * 00131 * -- LAPACK computational routine (version 3.4.0) -- 00132 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00133 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00134 * November 2011 00135 * 00136 * .. Scalar Arguments .. 00137 INTEGER INFO, K, LDA, LWORK, M, N 00138 * .. 00139 * .. Array Arguments .. 00140 COMPLEX A( LDA, * ), TAU( * ), WORK( * ) 00141 * .. 00142 * 00143 * ===================================================================== 00144 * 00145 * .. Parameters .. 00146 COMPLEX ZERO 00147 PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) 00148 * .. 00149 * .. Local Scalars .. 00150 LOGICAL LQUERY 00151 INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT, 00152 $ NB, NBMIN, NX 00153 * .. 00154 * .. External Subroutines .. 00155 EXTERNAL CLARFB, CLARFT, CUNG2L, XERBLA 00156 * .. 00157 * .. Intrinsic Functions .. 00158 INTRINSIC MAX, MIN 00159 * .. 00160 * .. External Functions .. 00161 INTEGER ILAENV 00162 EXTERNAL ILAENV 00163 * .. 00164 * .. Executable Statements .. 00165 * 00166 * Test the input arguments 00167 * 00168 INFO = 0 00169 LQUERY = ( LWORK.EQ.-1 ) 00170 IF( M.LT.0 ) THEN 00171 INFO = -1 00172 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN 00173 INFO = -2 00174 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN 00175 INFO = -3 00176 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 00177 INFO = -5 00178 END IF 00179 * 00180 IF( INFO.EQ.0 ) THEN 00181 IF( N.EQ.0 ) THEN 00182 LWKOPT = 1 00183 ELSE 00184 NB = ILAENV( 1, 'CUNGQL', ' ', M, N, K, -1 ) 00185 LWKOPT = N*NB 00186 END IF 00187 WORK( 1 ) = LWKOPT 00188 * 00189 IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN 00190 INFO = -8 00191 END IF 00192 END IF 00193 * 00194 IF( INFO.NE.0 ) THEN 00195 CALL XERBLA( 'CUNGQL', -INFO ) 00196 RETURN 00197 ELSE IF( LQUERY ) THEN 00198 RETURN 00199 END IF 00200 * 00201 * Quick return if possible 00202 * 00203 IF( N.LE.0 ) THEN 00204 RETURN 00205 END IF 00206 * 00207 NBMIN = 2 00208 NX = 0 00209 IWS = N 00210 IF( NB.GT.1 .AND. NB.LT.K ) THEN 00211 * 00212 * Determine when to cross over from blocked to unblocked code. 00213 * 00214 NX = MAX( 0, ILAENV( 3, 'CUNGQL', ' ', M, N, K, -1 ) ) 00215 IF( NX.LT.K ) THEN 00216 * 00217 * Determine if workspace is large enough for blocked code. 00218 * 00219 LDWORK = N 00220 IWS = LDWORK*NB 00221 IF( LWORK.LT.IWS ) THEN 00222 * 00223 * Not enough workspace to use optimal NB: reduce NB and 00224 * determine the minimum value of NB. 00225 * 00226 NB = LWORK / LDWORK 00227 NBMIN = MAX( 2, ILAENV( 2, 'CUNGQL', ' ', M, N, K, -1 ) ) 00228 END IF 00229 END IF 00230 END IF 00231 * 00232 IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN 00233 * 00234 * Use blocked code after the first block. 00235 * The last kk columns are handled by the block method. 00236 * 00237 KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) 00238 * 00239 * Set A(m-kk+1:m,1:n-kk) to zero. 00240 * 00241 DO 20 J = 1, N - KK 00242 DO 10 I = M - KK + 1, M 00243 A( I, J ) = ZERO 00244 10 CONTINUE 00245 20 CONTINUE 00246 ELSE 00247 KK = 0 00248 END IF 00249 * 00250 * Use unblocked code for the first or only block. 00251 * 00252 CALL CUNG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) 00253 * 00254 IF( KK.GT.0 ) THEN 00255 * 00256 * Use blocked code 00257 * 00258 DO 50 I = K - KK + 1, K, NB 00259 IB = MIN( NB, K-I+1 ) 00260 IF( N-K+I.GT.1 ) THEN 00261 * 00262 * Form the triangular factor of the block reflector 00263 * H = H(i+ib-1) . . . H(i+1) H(i) 00264 * 00265 CALL CLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, 00266 $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK ) 00267 * 00268 * Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left 00269 * 00270 CALL CLARFB( 'Left', 'No transpose', 'Backward', 00271 $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB, 00272 $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, 00273 $ WORK( IB+1 ), LDWORK ) 00274 END IF 00275 * 00276 * Apply H to rows 1:m-k+i+ib-1 of current block 00277 * 00278 CALL CUNG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA, 00279 $ TAU( I ), WORK, IINFO ) 00280 * 00281 * Set rows m-k+i+ib:m of current block to zero 00282 * 00283 DO 40 J = N - K + I, N - K + I + IB - 1 00284 DO 30 L = M - K + I + IB, M 00285 A( L, J ) = ZERO 00286 30 CONTINUE 00287 40 CONTINUE 00288 50 CONTINUE 00289 END IF 00290 * 00291 WORK( 1 ) = IWS 00292 RETURN 00293 * 00294 * End of CUNGQL 00295 * 00296 END