|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, 00002 $ T, LDT, C, LDC, WORK, LDWORK ) 00003 IMPLICIT NONE 00004 * 00005 * -- LAPACK auxiliary routine (version 3.2) -- 00006 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00007 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00008 * November 2006 00009 * 00010 * .. Scalar Arguments .. 00011 CHARACTER DIRECT, SIDE, STOREV, TRANS 00012 INTEGER K, LDC, LDT, LDV, LDWORK, M, N 00013 * .. 00014 * .. Array Arguments .. 00015 REAL C( LDC, * ), T( LDT, * ), V( LDV, * ), 00016 $ WORK( LDWORK, * ) 00017 * .. 00018 * 00019 * Purpose 00020 * ======= 00021 * 00022 * SLARFB applies a real block reflector H or its transpose H' to a 00023 * real m by n matrix C, from either the left or the right. 00024 * 00025 * Arguments 00026 * ========= 00027 * 00028 * SIDE (input) CHARACTER*1 00029 * = 'L': apply H or H' from the Left 00030 * = 'R': apply H or H' from the Right 00031 * 00032 * TRANS (input) CHARACTER*1 00033 * = 'N': apply H (No transpose) 00034 * = 'T': apply H' (Transpose) 00035 * 00036 * DIRECT (input) CHARACTER*1 00037 * Indicates how H is formed from a product of elementary 00038 * reflectors 00039 * = 'F': H = H(1) H(2) . . . H(k) (Forward) 00040 * = 'B': H = H(k) . . . H(2) H(1) (Backward) 00041 * 00042 * STOREV (input) CHARACTER*1 00043 * Indicates how the vectors which define the elementary 00044 * reflectors are stored: 00045 * = 'C': Columnwise 00046 * = 'R': Rowwise 00047 * 00048 * M (input) INTEGER 00049 * The number of rows of the matrix C. 00050 * 00051 * N (input) INTEGER 00052 * The number of columns of the matrix C. 00053 * 00054 * K (input) INTEGER 00055 * The order of the matrix T (= the number of elementary 00056 * reflectors whose product defines the block reflector). 00057 * 00058 * V (input) REAL array, dimension 00059 * (LDV,K) if STOREV = 'C' 00060 * (LDV,M) if STOREV = 'R' and SIDE = 'L' 00061 * (LDV,N) if STOREV = 'R' and SIDE = 'R' 00062 * The matrix V. See further details. 00063 * 00064 * LDV (input) INTEGER 00065 * The leading dimension of the array V. 00066 * If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); 00067 * if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); 00068 * if STOREV = 'R', LDV >= K. 00069 * 00070 * T (input) REAL array, dimension (LDT,K) 00071 * The triangular k by k matrix T in the representation of the 00072 * block reflector. 00073 * 00074 * LDT (input) INTEGER 00075 * The leading dimension of the array T. LDT >= K. 00076 * 00077 * C (input/output) REAL array, dimension (LDC,N) 00078 * On entry, the m by n matrix C. 00079 * On exit, C is overwritten by H*C or H'*C or C*H or C*H'. 00080 * 00081 * LDC (input) INTEGER 00082 * The leading dimension of the array C. LDA >= max(1,M). 00083 * 00084 * WORK (workspace) REAL array, dimension (LDWORK,K) 00085 * 00086 * LDWORK (input) INTEGER 00087 * The leading dimension of the array WORK. 00088 * If SIDE = 'L', LDWORK >= max(1,N); 00089 * if SIDE = 'R', LDWORK >= max(1,M). 00090 * 00091 * ===================================================================== 00092 * 00093 * .. Parameters .. 00094 REAL ONE 00095 PARAMETER ( ONE = 1.0E+0 ) 00096 * .. 00097 * .. Local Scalars .. 00098 CHARACTER TRANST 00099 INTEGER I, J, LASTV, LASTC 00100 * .. 00101 * .. External Functions .. 00102 LOGICAL LSAME 00103 INTEGER ILASLR, ILASLC 00104 EXTERNAL LSAME, ILASLR, ILASLC 00105 * .. 00106 * .. External Subroutines .. 00107 EXTERNAL SCOPY, SGEMM, STRMM 00108 * .. 00109 * .. Executable Statements .. 00110 * 00111 * Quick return if possible 00112 * 00113 IF( M.LE.0 .OR. N.LE.0 ) 00114 $ RETURN 00115 * 00116 IF( LSAME( TRANS, 'N' ) ) THEN 00117 TRANST = 'T' 00118 ELSE 00119 TRANST = 'N' 00120 END IF 00121 * 00122 IF( LSAME( STOREV, 'C' ) ) THEN 00123 * 00124 IF( LSAME( DIRECT, 'F' ) ) THEN 00125 * 00126 * Let V = ( V1 ) (first K rows) 00127 * ( V2 ) 00128 * where V1 is unit lower triangular. 00129 * 00130 IF( LSAME( SIDE, 'L' ) ) THEN 00131 * 00132 * Form H * C or H' * C where C = ( C1 ) 00133 * ( C2 ) 00134 * 00135 LASTV = MAX( K, ILASLR( M, K, V, LDV ) ) 00136 LASTC = ILASLC( LASTV, N, C, LDC ) 00137 * 00138 * W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) 00139 * 00140 * W := C1' 00141 * 00142 DO 10 J = 1, K 00143 CALL SCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 00144 10 CONTINUE 00145 * 00146 * W := W * V1 00147 * 00148 CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', 00149 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00150 IF( LASTV.GT.K ) THEN 00151 * 00152 * W := W + C2'*V2 00153 * 00154 CALL SGEMM( 'Transpose', 'No transpose', 00155 $ LASTC, K, LASTV-K, 00156 $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, 00157 $ ONE, WORK, LDWORK ) 00158 END IF 00159 * 00160 * W := W * T' or W * T 00161 * 00162 CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit', 00163 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00164 * 00165 * C := C - V * W' 00166 * 00167 IF( LASTV.GT.K ) THEN 00168 * 00169 * C2 := C2 - V2 * W' 00170 * 00171 CALL SGEMM( 'No transpose', 'Transpose', 00172 $ LASTV-K, LASTC, K, 00173 $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, 00174 $ C( K+1, 1 ), LDC ) 00175 END IF 00176 * 00177 * W := W * V1' 00178 * 00179 CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', 00180 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00181 * 00182 * C1 := C1 - W' 00183 * 00184 DO 30 J = 1, K 00185 DO 20 I = 1, LASTC 00186 C( J, I ) = C( J, I ) - WORK( I, J ) 00187 20 CONTINUE 00188 30 CONTINUE 00189 * 00190 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 00191 * 00192 * Form C * H or C * H' where C = ( C1 C2 ) 00193 * 00194 LASTV = MAX( K, ILASLR( N, K, V, LDV ) ) 00195 LASTC = ILASLR( M, LASTV, C, LDC ) 00196 * 00197 * W := C * V = (C1*V1 + C2*V2) (stored in WORK) 00198 * 00199 * W := C1 00200 * 00201 DO 40 J = 1, K 00202 CALL SCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) 00203 40 CONTINUE 00204 * 00205 * W := W * V1 00206 * 00207 CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', 00208 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00209 IF( LASTV.GT.K ) THEN 00210 * 00211 * W := W + C2 * V2 00212 * 00213 CALL SGEMM( 'No transpose', 'No transpose', 00214 $ LASTC, K, LASTV-K, 00215 $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, 00216 $ ONE, WORK, LDWORK ) 00217 END IF 00218 * 00219 * W := W * T or W * T' 00220 * 00221 CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit', 00222 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00223 * 00224 * C := C - W * V' 00225 * 00226 IF( LASTV.GT.K ) THEN 00227 * 00228 * C2 := C2 - W * V2' 00229 * 00230 CALL SGEMM( 'No transpose', 'Transpose', 00231 $ LASTC, LASTV-K, K, 00232 $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, 00233 $ C( 1, K+1 ), LDC ) 00234 END IF 00235 * 00236 * W := W * V1' 00237 * 00238 CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', 00239 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00240 * 00241 * C1 := C1 - W 00242 * 00243 DO 60 J = 1, K 00244 DO 50 I = 1, LASTC 00245 C( I, J ) = C( I, J ) - WORK( I, J ) 00246 50 CONTINUE 00247 60 CONTINUE 00248 END IF 00249 * 00250 ELSE 00251 * 00252 * Let V = ( V1 ) 00253 * ( V2 ) (last K rows) 00254 * where V2 is unit upper triangular. 00255 * 00256 IF( LSAME( SIDE, 'L' ) ) THEN 00257 * 00258 * Form H * C or H' * C where C = ( C1 ) 00259 * ( C2 ) 00260 * 00261 LASTV = MAX( K, ILASLR( M, K, V, LDV ) ) 00262 LASTC = ILASLC( LASTV, N, C, LDC ) 00263 * 00264 * W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) 00265 * 00266 * W := C2' 00267 * 00268 DO 70 J = 1, K 00269 CALL SCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, 00270 $ WORK( 1, J ), 1 ) 00271 70 CONTINUE 00272 * 00273 * W := W * V2 00274 * 00275 CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', 00276 $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, 00277 $ WORK, LDWORK ) 00278 IF( LASTV.GT.K ) THEN 00279 * 00280 * W := W + C1'*V1 00281 * 00282 CALL SGEMM( 'Transpose', 'No transpose', 00283 $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, 00284 $ ONE, WORK, LDWORK ) 00285 END IF 00286 * 00287 * W := W * T' or W * T 00288 * 00289 CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', 00290 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00291 * 00292 * C := C - V * W' 00293 * 00294 IF( LASTV.GT.K ) THEN 00295 * 00296 * C1 := C1 - V1 * W' 00297 * 00298 CALL SGEMM( 'No transpose', 'Transpose', 00299 $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, 00300 $ ONE, C, LDC ) 00301 END IF 00302 * 00303 * W := W * V2' 00304 * 00305 CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', 00306 $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, 00307 $ WORK, LDWORK ) 00308 * 00309 * C2 := C2 - W' 00310 * 00311 DO 90 J = 1, K 00312 DO 80 I = 1, LASTC 00313 C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J) 00314 80 CONTINUE 00315 90 CONTINUE 00316 * 00317 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 00318 * 00319 * Form C * H or C * H' where C = ( C1 C2 ) 00320 * 00321 LASTV = MAX( K, ILASLR( N, K, V, LDV ) ) 00322 LASTC = ILASLR( M, LASTV, C, LDC ) 00323 * 00324 * W := C * V = (C1*V1 + C2*V2) (stored in WORK) 00325 * 00326 * W := C2 00327 * 00328 DO 100 J = 1, K 00329 CALL SCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 00330 100 CONTINUE 00331 * 00332 * W := W * V2 00333 * 00334 CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', 00335 $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, 00336 $ WORK, LDWORK ) 00337 IF( LASTV.GT.K ) THEN 00338 * 00339 * W := W + C1 * V1 00340 * 00341 CALL SGEMM( 'No transpose', 'No transpose', 00342 $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, 00343 $ ONE, WORK, LDWORK ) 00344 END IF 00345 * 00346 * W := W * T or W * T' 00347 * 00348 CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', 00349 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00350 * 00351 * C := C - W * V' 00352 * 00353 IF( LASTV.GT.K ) THEN 00354 * 00355 * C1 := C1 - W * V1' 00356 * 00357 CALL SGEMM( 'No transpose', 'Transpose', 00358 $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, 00359 $ ONE, C, LDC ) 00360 END IF 00361 * 00362 * W := W * V2' 00363 * 00364 CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', 00365 $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, 00366 $ WORK, LDWORK ) 00367 * 00368 * C2 := C2 - W 00369 * 00370 DO 120 J = 1, K 00371 DO 110 I = 1, LASTC 00372 C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J) 00373 110 CONTINUE 00374 120 CONTINUE 00375 END IF 00376 END IF 00377 * 00378 ELSE IF( LSAME( STOREV, 'R' ) ) THEN 00379 * 00380 IF( LSAME( DIRECT, 'F' ) ) THEN 00381 * 00382 * Let V = ( V1 V2 ) (V1: first K columns) 00383 * where V1 is unit upper triangular. 00384 * 00385 IF( LSAME( SIDE, 'L' ) ) THEN 00386 * 00387 * Form H * C or H' * C where C = ( C1 ) 00388 * ( C2 ) 00389 * 00390 LASTV = MAX( K, ILASLC( K, M, V, LDV ) ) 00391 LASTC = ILASLC( LASTV, N, C, LDC ) 00392 * 00393 * W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) 00394 * 00395 * W := C1' 00396 * 00397 DO 130 J = 1, K 00398 CALL SCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 00399 130 CONTINUE 00400 * 00401 * W := W * V1' 00402 * 00403 CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', 00404 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00405 IF( LASTV.GT.K ) THEN 00406 * 00407 * W := W + C2'*V2' 00408 * 00409 CALL SGEMM( 'Transpose', 'Transpose', 00410 $ LASTC, K, LASTV-K, 00411 $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, 00412 $ ONE, WORK, LDWORK ) 00413 END IF 00414 * 00415 * W := W * T' or W * T 00416 * 00417 CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit', 00418 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00419 * 00420 * C := C - V' * W' 00421 * 00422 IF( LASTV.GT.K ) THEN 00423 * 00424 * C2 := C2 - V2' * W' 00425 * 00426 CALL SGEMM( 'Transpose', 'Transpose', 00427 $ LASTV-K, LASTC, K, 00428 $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, 00429 $ ONE, C( K+1, 1 ), LDC ) 00430 END IF 00431 * 00432 * W := W * V1 00433 * 00434 CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', 00435 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00436 * 00437 * C1 := C1 - W' 00438 * 00439 DO 150 J = 1, K 00440 DO 140 I = 1, LASTC 00441 C( J, I ) = C( J, I ) - WORK( I, J ) 00442 140 CONTINUE 00443 150 CONTINUE 00444 * 00445 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 00446 * 00447 * Form C * H or C * H' where C = ( C1 C2 ) 00448 * 00449 LASTV = MAX( K, ILASLC( K, N, V, LDV ) ) 00450 LASTC = ILASLR( M, LASTV, C, LDC ) 00451 * 00452 * W := C * V' = (C1*V1' + C2*V2') (stored in WORK) 00453 * 00454 * W := C1 00455 * 00456 DO 160 J = 1, K 00457 CALL SCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) 00458 160 CONTINUE 00459 * 00460 * W := W * V1' 00461 * 00462 CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', 00463 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00464 IF( LASTV.GT.K ) THEN 00465 * 00466 * W := W + C2 * V2' 00467 * 00468 CALL SGEMM( 'No transpose', 'Transpose', 00469 $ LASTC, K, LASTV-K, 00470 $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, 00471 $ ONE, WORK, LDWORK ) 00472 END IF 00473 * 00474 * W := W * T or W * T' 00475 * 00476 CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit', 00477 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00478 * 00479 * C := C - W * V 00480 * 00481 IF( LASTV.GT.K ) THEN 00482 * 00483 * C2 := C2 - W * V2 00484 * 00485 CALL SGEMM( 'No transpose', 'No transpose', 00486 $ LASTC, LASTV-K, K, 00487 $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, 00488 $ ONE, C( 1, K+1 ), LDC ) 00489 END IF 00490 * 00491 * W := W * V1 00492 * 00493 CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', 00494 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00495 * 00496 * C1 := C1 - W 00497 * 00498 DO 180 J = 1, K 00499 DO 170 I = 1, LASTC 00500 C( I, J ) = C( I, J ) - WORK( I, J ) 00501 170 CONTINUE 00502 180 CONTINUE 00503 * 00504 END IF 00505 * 00506 ELSE 00507 * 00508 * Let V = ( V1 V2 ) (V2: last K columns) 00509 * where V2 is unit lower triangular. 00510 * 00511 IF( LSAME( SIDE, 'L' ) ) THEN 00512 * 00513 * Form H * C or H' * C where C = ( C1 ) 00514 * ( C2 ) 00515 * 00516 LASTV = MAX( K, ILASLC( K, M, V, LDV ) ) 00517 LASTC = ILASLC( LASTV, N, C, LDC ) 00518 * 00519 * W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) 00520 * 00521 * W := C2' 00522 * 00523 DO 190 J = 1, K 00524 CALL SCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, 00525 $ WORK( 1, J ), 1 ) 00526 190 CONTINUE 00527 * 00528 * W := W * V2' 00529 * 00530 CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', 00531 $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, 00532 $ WORK, LDWORK ) 00533 IF( LASTV.GT.K ) THEN 00534 * 00535 * W := W + C1'*V1' 00536 * 00537 CALL SGEMM( 'Transpose', 'Transpose', 00538 $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, 00539 $ ONE, WORK, LDWORK ) 00540 END IF 00541 * 00542 * W := W * T' or W * T 00543 * 00544 CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', 00545 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00546 * 00547 * C := C - V' * W' 00548 * 00549 IF( LASTV.GT.K ) THEN 00550 * 00551 * C1 := C1 - V1' * W' 00552 * 00553 CALL SGEMM( 'Transpose', 'Transpose', 00554 $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, 00555 $ ONE, C, LDC ) 00556 END IF 00557 * 00558 * W := W * V2 00559 * 00560 CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', 00561 $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, 00562 $ WORK, LDWORK ) 00563 * 00564 * C2 := C2 - W' 00565 * 00566 DO 210 J = 1, K 00567 DO 200 I = 1, LASTC 00568 C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J) 00569 200 CONTINUE 00570 210 CONTINUE 00571 * 00572 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 00573 * 00574 * Form C * H or C * H' where C = ( C1 C2 ) 00575 * 00576 LASTV = MAX( K, ILASLC( K, N, V, LDV ) ) 00577 LASTC = ILASLR( M, LASTV, C, LDC ) 00578 * 00579 * W := C * V' = (C1*V1' + C2*V2') (stored in WORK) 00580 * 00581 * W := C2 00582 * 00583 DO 220 J = 1, K 00584 CALL SCOPY( LASTC, C( 1, LASTV-K+J ), 1, 00585 $ WORK( 1, J ), 1 ) 00586 220 CONTINUE 00587 * 00588 * W := W * V2' 00589 * 00590 CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', 00591 $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, 00592 $ WORK, LDWORK ) 00593 IF( LASTV.GT.K ) THEN 00594 * 00595 * W := W + C1 * V1' 00596 * 00597 CALL SGEMM( 'No transpose', 'Transpose', 00598 $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, 00599 $ ONE, WORK, LDWORK ) 00600 END IF 00601 * 00602 * W := W * T or W * T' 00603 * 00604 CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', 00605 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00606 * 00607 * C := C - W * V 00608 * 00609 IF( LASTV.GT.K ) THEN 00610 * 00611 * C1 := C1 - W * V1 00612 * 00613 CALL SGEMM( 'No transpose', 'No transpose', 00614 $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, 00615 $ ONE, C, LDC ) 00616 END IF 00617 * 00618 * W := W * V2 00619 * 00620 CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', 00621 $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, 00622 $ WORK, LDWORK ) 00623 * 00624 * C1 := C1 - W 00625 * 00626 DO 240 J = 1, K 00627 DO 230 I = 1, LASTC 00628 C( I, LASTV-K+J ) = C( I, LASTV-K+J ) 00629 $ - WORK( I, J ) 00630 230 CONTINUE 00631 240 CONTINUE 00632 * 00633 END IF 00634 * 00635 END IF 00636 END IF 00637 * 00638 RETURN 00639 * 00640 * End of SLARFB 00641 * 00642 END
1.7.3 
