![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SLARZB 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 *> \htmlonly 00009 *> Download SLARZB + dependencies 00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slarzb.f"> 00011 *> [TGZ]</a> 00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slarzb.f"> 00013 *> [ZIP]</a> 00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slarzb.f"> 00015 *> [TXT]</a> 00016 *> \endhtmlonly 00017 * 00018 * Definition: 00019 * =========== 00020 * 00021 * SUBROUTINE SLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, 00022 * LDV, T, LDT, C, LDC, WORK, LDWORK ) 00023 * 00024 * .. Scalar Arguments .. 00025 * CHARACTER DIRECT, SIDE, STOREV, TRANS 00026 * INTEGER K, L, LDC, LDT, LDV, LDWORK, M, N 00027 * .. 00028 * .. Array Arguments .. 00029 * REAL C( LDC, * ), T( LDT, * ), V( LDV, * ), 00030 * $ WORK( LDWORK, * ) 00031 * .. 00032 * 00033 * 00034 *> \par Purpose: 00035 * ============= 00036 *> 00037 *> \verbatim 00038 *> 00039 *> SLARZB applies a real block reflector H or its transpose H**T to 00040 *> a real distributed M-by-N C from the left or the right. 00041 *> 00042 *> Currently, only STOREV = 'R' and DIRECT = 'B' are supported. 00043 *> \endverbatim 00044 * 00045 * Arguments: 00046 * ========== 00047 * 00048 *> \param[in] SIDE 00049 *> \verbatim 00050 *> SIDE is CHARACTER*1 00051 *> = 'L': apply H or H**T from the Left 00052 *> = 'R': apply H or H**T from the Right 00053 *> \endverbatim 00054 *> 00055 *> \param[in] TRANS 00056 *> \verbatim 00057 *> TRANS is CHARACTER*1 00058 *> = 'N': apply H (No transpose) 00059 *> = 'C': apply H**T (Transpose) 00060 *> \endverbatim 00061 *> 00062 *> \param[in] DIRECT 00063 *> \verbatim 00064 *> DIRECT is CHARACTER*1 00065 *> Indicates how H is formed from a product of elementary 00066 *> reflectors 00067 *> = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet) 00068 *> = 'B': H = H(k) . . . H(2) H(1) (Backward) 00069 *> \endverbatim 00070 *> 00071 *> \param[in] STOREV 00072 *> \verbatim 00073 *> STOREV is CHARACTER*1 00074 *> Indicates how the vectors which define the elementary 00075 *> reflectors are stored: 00076 *> = 'C': Columnwise (not supported yet) 00077 *> = 'R': Rowwise 00078 *> \endverbatim 00079 *> 00080 *> \param[in] M 00081 *> \verbatim 00082 *> M is INTEGER 00083 *> The number of rows of the matrix C. 00084 *> \endverbatim 00085 *> 00086 *> \param[in] N 00087 *> \verbatim 00088 *> N is INTEGER 00089 *> The number of columns of the matrix C. 00090 *> \endverbatim 00091 *> 00092 *> \param[in] K 00093 *> \verbatim 00094 *> K is INTEGER 00095 *> The order of the matrix T (= the number of elementary 00096 *> reflectors whose product defines the block reflector). 00097 *> \endverbatim 00098 *> 00099 *> \param[in] L 00100 *> \verbatim 00101 *> L is INTEGER 00102 *> The number of columns of the matrix V containing the 00103 *> meaningful part of the Householder reflectors. 00104 *> If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. 00105 *> \endverbatim 00106 *> 00107 *> \param[in] V 00108 *> \verbatim 00109 *> V is REAL array, dimension (LDV,NV). 00110 *> If STOREV = 'C', NV = K; if STOREV = 'R', NV = L. 00111 *> \endverbatim 00112 *> 00113 *> \param[in] LDV 00114 *> \verbatim 00115 *> LDV is INTEGER 00116 *> The leading dimension of the array V. 00117 *> If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K. 00118 *> \endverbatim 00119 *> 00120 *> \param[in] T 00121 *> \verbatim 00122 *> T is REAL array, dimension (LDT,K) 00123 *> The triangular K-by-K matrix T in the representation of the 00124 *> block reflector. 00125 *> \endverbatim 00126 *> 00127 *> \param[in] LDT 00128 *> \verbatim 00129 *> LDT is INTEGER 00130 *> The leading dimension of the array T. LDT >= K. 00131 *> \endverbatim 00132 *> 00133 *> \param[in,out] C 00134 *> \verbatim 00135 *> C is REAL array, dimension (LDC,N) 00136 *> On entry, the M-by-N matrix C. 00137 *> On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T. 00138 *> \endverbatim 00139 *> 00140 *> \param[in] LDC 00141 *> \verbatim 00142 *> LDC is INTEGER 00143 *> The leading dimension of the array C. LDC >= max(1,M). 00144 *> \endverbatim 00145 *> 00146 *> \param[out] WORK 00147 *> \verbatim 00148 *> WORK is REAL array, dimension (LDWORK,K) 00149 *> \endverbatim 00150 *> 00151 *> \param[in] LDWORK 00152 *> \verbatim 00153 *> LDWORK is INTEGER 00154 *> The leading dimension of the array WORK. 00155 *> If SIDE = 'L', LDWORK >= max(1,N); 00156 *> if SIDE = 'R', LDWORK >= max(1,M). 00157 *> \endverbatim 00158 * 00159 * Authors: 00160 * ======== 00161 * 00162 *> \author Univ. of Tennessee 00163 *> \author Univ. of California Berkeley 00164 *> \author Univ. of Colorado Denver 00165 *> \author NAG Ltd. 00166 * 00167 *> \date November 2011 00168 * 00169 *> \ingroup realOTHERcomputational 00170 * 00171 *> \par Contributors: 00172 * ================== 00173 *> 00174 *> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA 00175 * 00176 *> \par Further Details: 00177 * ===================== 00178 *> 00179 *> \verbatim 00180 *> \endverbatim 00181 *> 00182 * ===================================================================== 00183 SUBROUTINE SLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, 00184 $ LDV, T, LDT, C, LDC, WORK, LDWORK ) 00185 * 00186 * -- LAPACK computational routine (version 3.4.0) -- 00187 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00188 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00189 * November 2011 00190 * 00191 * .. Scalar Arguments .. 00192 CHARACTER DIRECT, SIDE, STOREV, TRANS 00193 INTEGER K, L, LDC, LDT, LDV, LDWORK, M, N 00194 * .. 00195 * .. Array Arguments .. 00196 REAL C( LDC, * ), T( LDT, * ), V( LDV, * ), 00197 $ WORK( LDWORK, * ) 00198 * .. 00199 * 00200 * ===================================================================== 00201 * 00202 * .. Parameters .. 00203 REAL ONE 00204 PARAMETER ( ONE = 1.0E+0 ) 00205 * .. 00206 * .. Local Scalars .. 00207 CHARACTER TRANST 00208 INTEGER I, INFO, J 00209 * .. 00210 * .. External Functions .. 00211 LOGICAL LSAME 00212 EXTERNAL LSAME 00213 * .. 00214 * .. External Subroutines .. 00215 EXTERNAL SCOPY, SGEMM, STRMM, XERBLA 00216 * .. 00217 * .. Executable Statements .. 00218 * 00219 * Quick return if possible 00220 * 00221 IF( M.LE.0 .OR. N.LE.0 ) 00222 $ RETURN 00223 * 00224 * Check for currently supported options 00225 * 00226 INFO = 0 00227 IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN 00228 INFO = -3 00229 ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN 00230 INFO = -4 00231 END IF 00232 IF( INFO.NE.0 ) THEN 00233 CALL XERBLA( 'SLARZB', -INFO ) 00234 RETURN 00235 END IF 00236 * 00237 IF( LSAME( TRANS, 'N' ) ) THEN 00238 TRANST = 'T' 00239 ELSE 00240 TRANST = 'N' 00241 END IF 00242 * 00243 IF( LSAME( SIDE, 'L' ) ) THEN 00244 * 00245 * Form H * C or H**T * C 00246 * 00247 * W( 1:n, 1:k ) = C( 1:k, 1:n )**T 00248 * 00249 DO 10 J = 1, K 00250 CALL SCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 00251 10 CONTINUE 00252 * 00253 * W( 1:n, 1:k ) = W( 1:n, 1:k ) + ... 00254 * C( m-l+1:m, 1:n )**T * V( 1:k, 1:l )**T 00255 * 00256 IF( L.GT.0 ) 00257 $ CALL SGEMM( 'Transpose', 'Transpose', N, K, L, ONE, 00258 $ C( M-L+1, 1 ), LDC, V, LDV, ONE, WORK, LDWORK ) 00259 * 00260 * W( 1:n, 1:k ) = W( 1:n, 1:k ) * T**T or W( 1:m, 1:k ) * T 00261 * 00262 CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, ONE, T, 00263 $ LDT, WORK, LDWORK ) 00264 * 00265 * C( 1:k, 1:n ) = C( 1:k, 1:n ) - W( 1:n, 1:k )**T 00266 * 00267 DO 30 J = 1, N 00268 DO 20 I = 1, K 00269 C( I, J ) = C( I, J ) - WORK( J, I ) 00270 20 CONTINUE 00271 30 CONTINUE 00272 * 00273 * C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... 00274 * V( 1:k, 1:l )**T * W( 1:n, 1:k )**T 00275 * 00276 IF( L.GT.0 ) 00277 $ CALL SGEMM( 'Transpose', 'Transpose', L, N, K, -ONE, V, LDV, 00278 $ WORK, LDWORK, ONE, C( M-L+1, 1 ), LDC ) 00279 * 00280 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 00281 * 00282 * Form C * H or C * H**T 00283 * 00284 * W( 1:m, 1:k ) = C( 1:m, 1:k ) 00285 * 00286 DO 40 J = 1, K 00287 CALL SCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 00288 40 CONTINUE 00289 * 00290 * W( 1:m, 1:k ) = W( 1:m, 1:k ) + ... 00291 * C( 1:m, n-l+1:n ) * V( 1:k, 1:l )**T 00292 * 00293 IF( L.GT.0 ) 00294 $ CALL SGEMM( 'No transpose', 'Transpose', M, K, L, ONE, 00295 $ C( 1, N-L+1 ), LDC, V, LDV, ONE, WORK, LDWORK ) 00296 * 00297 * W( 1:m, 1:k ) = W( 1:m, 1:k ) * T or W( 1:m, 1:k ) * T**T 00298 * 00299 CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, ONE, T, 00300 $ LDT, WORK, LDWORK ) 00301 * 00302 * C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k ) 00303 * 00304 DO 60 J = 1, K 00305 DO 50 I = 1, M 00306 C( I, J ) = C( I, J ) - WORK( I, J ) 00307 50 CONTINUE 00308 60 CONTINUE 00309 * 00310 * C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... 00311 * W( 1:m, 1:k ) * V( 1:k, 1:l ) 00312 * 00313 IF( L.GT.0 ) 00314 $ CALL SGEMM( 'No transpose', 'No transpose', M, L, K, -ONE, 00315 $ WORK, LDWORK, V, LDV, ONE, C( 1, N-L+1 ), LDC ) 00316 * 00317 END IF 00318 * 00319 RETURN 00320 * 00321 * End of SLARZB 00322 * 00323 END