![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b DTPMQRT 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 *> \htmlonly 00009 *> Download DTPMQRT + dependencies 00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dtpmqrt.f"> 00011 *> [TGZ]</a> 00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dtpmqrt.f"> 00013 *> [ZIP]</a> 00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dtpmqrt.f"> 00015 *> [TXT]</a> 00016 *> \endhtmlonly 00017 * 00018 * Definition: 00019 * =========== 00020 * 00021 * SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, 00022 * A, LDA, B, LDB, WORK, INFO ) 00023 * 00024 * .. Scalar Arguments .. 00025 * CHARACTER SIDE, TRANS 00026 * INTEGER INFO, K, LDV, LDA, LDB, M, N, L, NB, LDT 00027 * .. 00028 * .. Array Arguments .. 00029 * DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ), 00030 * $ T( LDT, * ), WORK( * ) 00031 * .. 00032 * 00033 * 00034 *> \par Purpose: 00035 * ============= 00036 *> 00037 *> \verbatim 00038 *> 00039 *> DTPMQRT applies a real orthogonal matrix Q obtained from a 00040 *> "triangular-pentagonal" real block reflector H to a general 00041 *> real matrix C, which consists of two blocks A and B. 00042 *> \endverbatim 00043 * 00044 * Arguments: 00045 * ========== 00046 * 00047 *> \param[in] SIDE 00048 *> \verbatim 00049 *> SIDE is CHARACTER*1 00050 *> = 'L': apply Q or Q**T from the Left; 00051 *> = 'R': apply Q or Q**T from the Right. 00052 *> \endverbatim 00053 *> 00054 *> \param[in] TRANS 00055 *> \verbatim 00056 *> TRANS is CHARACTER*1 00057 *> = 'N': No transpose, apply Q; 00058 *> = 'C': Transpose, apply Q**T. 00059 *> \endverbatim 00060 *> 00061 *> \param[in] M 00062 *> \verbatim 00063 *> M is INTEGER 00064 *> The number of rows of the matrix B. M >= 0. 00065 *> \endverbatim 00066 *> 00067 *> \param[in] N 00068 *> \verbatim 00069 *> N is INTEGER 00070 *> The number of columns of the matrix B. N >= 0. 00071 *> \endverbatim 00072 *> 00073 *> \param[in] K 00074 *> \verbatim 00075 *> K is INTEGER 00076 *> The number of elementary reflectors whose product defines 00077 *> the matrix Q. 00078 *> \endverbatim 00079 *> 00080 *> \param[in] L 00081 *> \verbatim 00082 *> L is INTEGER 00083 *> The order of the trapezoidal part of V. 00084 *> K >= L >= 0. See Further Details. 00085 *> \endverbatim 00086 *> 00087 *> \param[in] NB 00088 *> \verbatim 00089 *> NB is INTEGER 00090 *> The block size used for the storage of T. K >= NB >= 1. 00091 *> This must be the same value of NB used to generate T 00092 *> in CTPQRT. 00093 *> \endverbatim 00094 *> 00095 *> \param[in] V 00096 *> \verbatim 00097 *> V is DOUBLE PRECISION array, dimension (LDA,K) 00098 *> The i-th column must contain the vector which defines the 00099 *> elementary reflector H(i), for i = 1,2,...,k, as returned by 00100 *> CTPQRT in B. See Further Details. 00101 *> \endverbatim 00102 *> 00103 *> \param[in] LDV 00104 *> \verbatim 00105 *> LDV is INTEGER 00106 *> The leading dimension of the array V. 00107 *> If SIDE = 'L', LDV >= max(1,M); 00108 *> if SIDE = 'R', LDV >= max(1,N). 00109 *> \endverbatim 00110 *> 00111 *> \param[in] T 00112 *> \verbatim 00113 *> T is DOUBLE PRECISION array, dimension (LDT,K) 00114 *> The upper triangular factors of the block reflectors 00115 *> as returned by CTPQRT, stored as a NB-by-K matrix. 00116 *> \endverbatim 00117 *> 00118 *> \param[in] LDT 00119 *> \verbatim 00120 *> LDT is INTEGER 00121 *> The leading dimension of the array T. LDT >= NB. 00122 *> \endverbatim 00123 *> 00124 *> \param[in,out] A 00125 *> \verbatim 00126 *> A is DOUBLE PRECISION array, dimension 00127 *> (LDA,N) if SIDE = 'L' or 00128 *> (LDA,K) if SIDE = 'R' 00129 *> On entry, the K-by-N or M-by-K matrix A. 00130 *> On exit, A is overwritten by the corresponding block of 00131 *> Q*C or Q**T*C or C*Q or C*Q**T. See Further Details. 00132 *> \endverbatim 00133 *> 00134 *> \param[in] LDA 00135 *> \verbatim 00136 *> LDA is INTEGER 00137 *> The leading dimension of the array A. 00138 *> If SIDE = 'L', LDC >= max(1,K); 00139 *> If SIDE = 'R', LDC >= max(1,M). 00140 *> \endverbatim 00141 *> 00142 *> \param[in,out] B 00143 *> \verbatim 00144 *> B is DOUBLE PRECISION array, dimension (LDB,N) 00145 *> On entry, the M-by-N matrix B. 00146 *> On exit, B is overwritten by the corresponding block of 00147 *> Q*C or Q**T*C or C*Q or C*Q**T. See Further Details. 00148 *> \endverbatim 00149 *> 00150 *> \param[in] LDB 00151 *> \verbatim 00152 *> LDB is INTEGER 00153 *> The leading dimension of the array B. 00154 *> LDB >= max(1,M). 00155 *> \endverbatim 00156 *> 00157 *> \param[out] WORK 00158 *> \verbatim 00159 *> WORK is DOUBLE PRECISION array. The dimension of WORK is 00160 *> N*NB if SIDE = 'L', or M*NB if SIDE = 'R'. 00161 *> \endverbatim 00162 *> 00163 *> \param[out] INFO 00164 *> \verbatim 00165 *> INFO is INTEGER 00166 *> = 0: successful exit 00167 *> < 0: if INFO = -i, the i-th argument had an illegal value 00168 *> \endverbatim 00169 * 00170 * Authors: 00171 * ======== 00172 * 00173 *> \author Univ. of Tennessee 00174 *> \author Univ. of California Berkeley 00175 *> \author Univ. of Colorado Denver 00176 *> \author NAG Ltd. 00177 * 00178 *> \date April 2012 00179 * 00180 *> \ingroup doubleOTHERcomputational 00181 * 00182 *> \par Further Details: 00183 * ===================== 00184 *> 00185 *> \verbatim 00186 *> 00187 *> The columns of the pentagonal matrix V contain the elementary reflectors 00188 *> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a 00189 *> trapezoidal block V2: 00190 *> 00191 *> V = [V1] 00192 *> [V2]. 00193 *> 00194 *> The size of the trapezoidal block V2 is determined by the parameter L, 00195 *> where 0 <= L <= K; V2 is upper trapezoidal, consisting of the first L 00196 *> rows of a K-by-K upper triangular matrix. If L=K, V2 is upper triangular; 00197 *> if L=0, there is no trapezoidal block, hence V = V1 is rectangular. 00198 *> 00199 *> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is M-by-K. 00200 *> [B] 00201 *> 00202 *> If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is N-by-K. 00203 *> 00204 *> The real orthogonal matrix Q is formed from V and T. 00205 *> 00206 *> If TRANS='N' and SIDE='L', C is on exit replaced with Q * C. 00207 *> 00208 *> If TRANS='T' and SIDE='L', C is on exit replaced with Q**T * C. 00209 *> 00210 *> If TRANS='N' and SIDE='R', C is on exit replaced with C * Q. 00211 *> 00212 *> If TRANS='T' and SIDE='R', C is on exit replaced with C * Q**T. 00213 *> \endverbatim 00214 *> 00215 * ===================================================================== 00216 SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, 00217 $ A, LDA, B, LDB, WORK, INFO ) 00218 * 00219 * -- LAPACK computational routine (version 3.4.1) -- 00220 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00221 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00222 * April 2012 00223 * 00224 * .. Scalar Arguments .. 00225 CHARACTER SIDE, TRANS 00226 INTEGER INFO, K, LDV, LDA, LDB, M, N, L, NB, LDT 00227 * .. 00228 * .. Array Arguments .. 00229 DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ), 00230 $ T( LDT, * ), WORK( * ) 00231 * .. 00232 * 00233 * ===================================================================== 00234 * 00235 * .. 00236 * .. Local Scalars .. 00237 LOGICAL LEFT, RIGHT, TRAN, NOTRAN 00238 INTEGER I, IB, MB, LB, KF, Q 00239 * .. 00240 * .. External Functions .. 00241 LOGICAL LSAME 00242 EXTERNAL LSAME 00243 * .. 00244 * .. External Subroutines .. 00245 EXTERNAL XERBLA, DLARFB 00246 * .. 00247 * .. Intrinsic Functions .. 00248 INTRINSIC MAX, MIN 00249 * .. 00250 * .. Executable Statements .. 00251 * 00252 * .. Test the input arguments .. 00253 * 00254 INFO = 0 00255 LEFT = LSAME( SIDE, 'L' ) 00256 RIGHT = LSAME( SIDE, 'R' ) 00257 TRAN = LSAME( TRANS, 'T' ) 00258 NOTRAN = LSAME( TRANS, 'N' ) 00259 * 00260 IF( LEFT ) THEN 00261 Q = M 00262 ELSE IF ( RIGHT ) THEN 00263 Q = N 00264 END IF 00265 IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN 00266 INFO = -1 00267 ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN 00268 INFO = -2 00269 ELSE IF( M.LT.0 ) THEN 00270 INFO = -3 00271 ELSE IF( N.LT.0 ) THEN 00272 INFO = -4 00273 ELSE IF( K.LT.0 ) THEN 00274 INFO = -5 00275 ELSE IF( L.LT.0 .OR. L.GT.K ) THEN 00276 INFO = -6 00277 ELSE IF( NB.LT.1 .OR. NB.GT.K ) THEN 00278 INFO = -7 00279 ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN 00280 INFO = -9 00281 ELSE IF( LDT.LT.NB ) THEN 00282 INFO = -11 00283 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 00284 INFO = -13 00285 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN 00286 INFO = -15 00287 END IF 00288 * 00289 IF( INFO.NE.0 ) THEN 00290 CALL XERBLA( 'DTPMQRT', -INFO ) 00291 RETURN 00292 END IF 00293 * 00294 * .. Quick return if possible .. 00295 * 00296 IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN 00297 * 00298 IF( LEFT .AND. TRAN ) THEN 00299 * 00300 DO I = 1, K, NB 00301 IB = MIN( NB, K-I+1 ) 00302 MB = MIN( M-L+I+IB-1, M ) 00303 IF( I.GE.L ) THEN 00304 LB = 0 00305 ELSE 00306 LB = MB-M+L-I+1 00307 END IF 00308 CALL DTPRFB( 'L', 'T', 'F', 'C', MB, N, IB, LB, 00309 $ V( 1, I ), LDV, T( 1, I ), LDT, 00310 $ A( I, 1 ), LDA, B, LDB, WORK, IB ) 00311 END DO 00312 * 00313 ELSE IF( RIGHT .AND. NOTRAN ) THEN 00314 * 00315 DO I = 1, K, NB 00316 IB = MIN( NB, K-I+1 ) 00317 MB = MIN( N-L+I+IB-1, N ) 00318 IF( I.GE.L ) THEN 00319 LB = 0 00320 ELSE 00321 LB = MB-N+L-I+1 00322 END IF 00323 CALL DTPRFB( 'R', 'N', 'F', 'C', M, MB, IB, LB, 00324 $ V( 1, I ), LDV, T( 1, I ), LDT, 00325 $ A( 1, I ), LDA, B, LDB, WORK, M ) 00326 END DO 00327 * 00328 ELSE IF( LEFT .AND. NOTRAN ) THEN 00329 * 00330 KF = ((K-1)/NB)*NB+1 00331 DO I = KF, 1, -NB 00332 IB = MIN( NB, K-I+1 ) 00333 MB = MIN( M-L+I+IB-1, M ) 00334 IF( I.GE.L ) THEN 00335 LB = 0 00336 ELSE 00337 LB = MB-M+L-I+1 00338 END IF 00339 CALL DTPRFB( 'L', 'N', 'F', 'C', MB, N, IB, LB, 00340 $ V( 1, I ), LDV, T( 1, I ), LDT, 00341 $ A( I, 1 ), LDA, B, LDB, WORK, IB ) 00342 END DO 00343 * 00344 ELSE IF( RIGHT .AND. TRAN ) THEN 00345 * 00346 KF = ((K-1)/NB)*NB+1 00347 DO I = KF, 1, -NB 00348 IB = MIN( NB, K-I+1 ) 00349 MB = MIN( N-L+I+IB-1, N ) 00350 IF( I.GE.L ) THEN 00351 LB = 0 00352 ELSE 00353 LB = MB-N+L-I+1 00354 END IF 00355 CALL DTPRFB( 'R', 'T', 'F', 'C', M, MB, IB, LB, 00356 $ V( 1, I ), LDV, T( 1, I ), LDT, 00357 $ A( 1, I ), LDA, B, LDB, WORK, M ) 00358 END DO 00359 * 00360 END IF 00361 * 00362 RETURN 00363 * 00364 * End of DTPMQRT 00365 * 00366 END