|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE ZLARFB( 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 COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), 00016 $ WORK( LDWORK, * ) 00017 * .. 00018 * 00019 * Purpose 00020 * ======= 00021 * 00022 * ZLARFB applies a complex block reflector H or its transpose H' to a 00023 * complex 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 * = 'C': apply H' (Conjugate 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) COMPLEX*16 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) COMPLEX*16 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) COMPLEX*16 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. LDC >= max(1,M). 00083 * 00084 * WORK (workspace) COMPLEX*16 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 COMPLEX*16 ONE 00095 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 00096 * .. 00097 * .. Local Scalars .. 00098 CHARACTER TRANST 00099 INTEGER I, J, LASTV, LASTC 00100 * .. 00101 * .. External Functions .. 00102 LOGICAL LSAME 00103 INTEGER ILAZLR, ILAZLC 00104 EXTERNAL LSAME, ILAZLR, ILAZLC 00105 * .. 00106 * .. External Subroutines .. 00107 EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM 00108 * .. 00109 * .. Intrinsic Functions .. 00110 INTRINSIC DCONJG 00111 * .. 00112 * .. Executable Statements .. 00113 * 00114 * Quick return if possible 00115 * 00116 IF( M.LE.0 .OR. N.LE.0 ) 00117 $ RETURN 00118 * 00119 IF( LSAME( TRANS, 'N' ) ) THEN 00120 TRANST = 'C' 00121 ELSE 00122 TRANST = 'N' 00123 END IF 00124 * 00125 IF( LSAME( STOREV, 'C' ) ) THEN 00126 * 00127 IF( LSAME( DIRECT, 'F' ) ) THEN 00128 * 00129 * Let V = ( V1 ) (first K rows) 00130 * ( V2 ) 00131 * where V1 is unit lower triangular. 00132 * 00133 IF( LSAME( SIDE, 'L' ) ) THEN 00134 * 00135 * Form H * C or H' * C where C = ( C1 ) 00136 * ( C2 ) 00137 * 00138 LASTV = MAX( K, ILAZLR( M, K, V, LDV ) ) 00139 LASTC = ILAZLC( LASTV, N, C, LDC ) 00140 * 00141 * W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) 00142 * 00143 * W := C1' 00144 * 00145 DO 10 J = 1, K 00146 CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 00147 CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) 00148 10 CONTINUE 00149 * 00150 * W := W * V1 00151 * 00152 CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', 00153 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00154 IF( LASTV.GT.K ) THEN 00155 * 00156 * W := W + C2'*V2 00157 * 00158 CALL ZGEMM( 'Conjugate transpose', 'No transpose', 00159 $ LASTC, K, LASTV-K, ONE, C( K+1, 1 ), LDC, 00160 $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK ) 00161 END IF 00162 * 00163 * W := W * T' or W * T 00164 * 00165 CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', 00166 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00167 * 00168 * C := C - V * W' 00169 * 00170 IF( M.GT.K ) THEN 00171 * 00172 * C2 := C2 - V2 * W' 00173 * 00174 CALL ZGEMM( 'No transpose', 'Conjugate transpose', 00175 $ LASTV-K, LASTC, K, 00176 $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, 00177 $ ONE, C( K+1, 1 ), LDC ) 00178 END IF 00179 * 00180 * W := W * V1' 00181 * 00182 CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', 00183 $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00184 * 00185 * C1 := C1 - W' 00186 * 00187 DO 30 J = 1, K 00188 DO 20 I = 1, LASTC 00189 C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) 00190 20 CONTINUE 00191 30 CONTINUE 00192 * 00193 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 00194 * 00195 * Form C * H or C * H' where C = ( C1 C2 ) 00196 * 00197 LASTV = MAX( K, ILAZLR( N, K, V, LDV ) ) 00198 LASTC = ILAZLR( M, LASTV, C, LDC ) 00199 * 00200 * W := C * V = (C1*V1 + C2*V2) (stored in WORK) 00201 * 00202 * W := C1 00203 * 00204 DO 40 J = 1, K 00205 CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) 00206 40 CONTINUE 00207 * 00208 * W := W * V1 00209 * 00210 CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', 00211 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00212 IF( LASTV.GT.K ) THEN 00213 * 00214 * W := W + C2 * V2 00215 * 00216 CALL ZGEMM( 'No transpose', 'No transpose', 00217 $ LASTC, K, LASTV-K, 00218 $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, 00219 $ ONE, WORK, LDWORK ) 00220 END IF 00221 * 00222 * W := W * T or W * T' 00223 * 00224 CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', 00225 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00226 * 00227 * C := C - W * V' 00228 * 00229 IF( LASTV.GT.K ) THEN 00230 * 00231 * C2 := C2 - W * V2' 00232 * 00233 CALL ZGEMM( 'No transpose', 'Conjugate transpose', 00234 $ LASTC, LASTV-K, K, 00235 $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, 00236 $ ONE, C( 1, K+1 ), LDC ) 00237 END IF 00238 * 00239 * W := W * V1' 00240 * 00241 CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', 00242 $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00243 * 00244 * C1 := C1 - W 00245 * 00246 DO 60 J = 1, K 00247 DO 50 I = 1, LASTC 00248 C( I, J ) = C( I, J ) - WORK( I, J ) 00249 50 CONTINUE 00250 60 CONTINUE 00251 END IF 00252 * 00253 ELSE 00254 * 00255 * Let V = ( V1 ) 00256 * ( V2 ) (last K rows) 00257 * where V2 is unit upper triangular. 00258 * 00259 IF( LSAME( SIDE, 'L' ) ) THEN 00260 * 00261 * Form H * C or H' * C where C = ( C1 ) 00262 * ( C2 ) 00263 * 00264 LASTV = MAX( K, ILAZLR( M, K, V, LDV ) ) 00265 LASTC = ILAZLC( LASTV, N, C, LDC ) 00266 * 00267 * W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) 00268 * 00269 * W := C2' 00270 * 00271 DO 70 J = 1, K 00272 CALL ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, 00273 $ WORK( 1, J ), 1 ) 00274 CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) 00275 70 CONTINUE 00276 * 00277 * W := W * V2 00278 * 00279 CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', 00280 $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, 00281 $ WORK, LDWORK ) 00282 IF( LASTV.GT.K ) THEN 00283 * 00284 * W := W + C1'*V1 00285 * 00286 CALL ZGEMM( 'Conjugate transpose', 'No transpose', 00287 $ LASTC, K, LASTV-K, 00288 $ ONE, C, LDC, V, LDV, 00289 $ ONE, WORK, LDWORK ) 00290 END IF 00291 * 00292 * W := W * T' or W * T 00293 * 00294 CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', 00295 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00296 * 00297 * C := C - V * W' 00298 * 00299 IF( LASTV.GT.K ) THEN 00300 * 00301 * C1 := C1 - V1 * W' 00302 * 00303 CALL ZGEMM( 'No transpose', 'Conjugate transpose', 00304 $ LASTV-K, LASTC, K, 00305 $ -ONE, V, LDV, WORK, LDWORK, 00306 $ ONE, C, LDC ) 00307 END IF 00308 * 00309 * W := W * V2' 00310 * 00311 CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', 00312 $ 'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, 00313 $ WORK, LDWORK ) 00314 * 00315 * C2 := C2 - W' 00316 * 00317 DO 90 J = 1, K 00318 DO 80 I = 1, LASTC 00319 C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - 00320 $ DCONJG( WORK( I, J ) ) 00321 80 CONTINUE 00322 90 CONTINUE 00323 * 00324 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 00325 * 00326 * Form C * H or C * H' where C = ( C1 C2 ) 00327 * 00328 LASTV = MAX( K, ILAZLR( N, K, V, LDV ) ) 00329 LASTC = ILAZLR( M, LASTV, C, LDC ) 00330 * 00331 * W := C * V = (C1*V1 + C2*V2) (stored in WORK) 00332 * 00333 * W := C2 00334 * 00335 DO 100 J = 1, K 00336 CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1, 00337 $ WORK( 1, J ), 1 ) 00338 100 CONTINUE 00339 * 00340 * W := W * V2 00341 * 00342 CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', 00343 $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, 00344 $ WORK, LDWORK ) 00345 IF( LASTV.GT.K ) THEN 00346 * 00347 * W := W + C1 * V1 00348 * 00349 CALL ZGEMM( 'No transpose', 'No transpose', 00350 $ LASTC, K, LASTV-K, 00351 $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) 00352 END IF 00353 * 00354 * W := W * T or W * T' 00355 * 00356 CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', 00357 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00358 * 00359 * C := C - W * V' 00360 * 00361 IF( LASTV.GT.K ) THEN 00362 * 00363 * C1 := C1 - W * V1' 00364 * 00365 CALL ZGEMM( 'No transpose', 'Conjugate transpose', 00366 $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, 00367 $ ONE, C, LDC ) 00368 END IF 00369 * 00370 * W := W * V2' 00371 * 00372 CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', 00373 $ 'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, 00374 $ WORK, LDWORK ) 00375 * 00376 * C2 := C2 - W 00377 * 00378 DO 120 J = 1, K 00379 DO 110 I = 1, LASTC 00380 C( I, LASTV-K+J ) = C( I, LASTV-K+J ) 00381 $ - WORK( I, J ) 00382 110 CONTINUE 00383 120 CONTINUE 00384 END IF 00385 END IF 00386 * 00387 ELSE IF( LSAME( STOREV, 'R' ) ) THEN 00388 * 00389 IF( LSAME( DIRECT, 'F' ) ) THEN 00390 * 00391 * Let V = ( V1 V2 ) (V1: first K columns) 00392 * where V1 is unit upper triangular. 00393 * 00394 IF( LSAME( SIDE, 'L' ) ) THEN 00395 * 00396 * Form H * C or H' * C where C = ( C1 ) 00397 * ( C2 ) 00398 * 00399 LASTV = MAX( K, ILAZLC( K, M, V, LDV ) ) 00400 LASTC = ILAZLC( LASTV, N, C, LDC ) 00401 * 00402 * W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) 00403 * 00404 * W := C1' 00405 * 00406 DO 130 J = 1, K 00407 CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 00408 CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) 00409 130 CONTINUE 00410 * 00411 * W := W * V1' 00412 * 00413 CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', 00414 $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00415 IF( LASTV.GT.K ) THEN 00416 * 00417 * W := W + C2'*V2' 00418 * 00419 CALL ZGEMM( 'Conjugate transpose', 00420 $ 'Conjugate transpose', LASTC, K, LASTV-K, 00421 $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, 00422 $ ONE, WORK, LDWORK ) 00423 END IF 00424 * 00425 * W := W * T' or W * T 00426 * 00427 CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', 00428 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00429 * 00430 * C := C - V' * W' 00431 * 00432 IF( LASTV.GT.K ) THEN 00433 * 00434 * C2 := C2 - V2' * W' 00435 * 00436 CALL ZGEMM( 'Conjugate transpose', 00437 $ 'Conjugate transpose', LASTV-K, LASTC, K, 00438 $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, 00439 $ ONE, C( K+1, 1 ), LDC ) 00440 END IF 00441 * 00442 * W := W * V1 00443 * 00444 CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', 00445 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00446 * 00447 * C1 := C1 - W' 00448 * 00449 DO 150 J = 1, K 00450 DO 140 I = 1, LASTC 00451 C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) 00452 140 CONTINUE 00453 150 CONTINUE 00454 * 00455 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 00456 * 00457 * Form C * H or C * H' where C = ( C1 C2 ) 00458 * 00459 LASTV = MAX( K, ILAZLC( K, N, V, LDV ) ) 00460 LASTC = ILAZLR( M, LASTV, C, LDC ) 00461 * 00462 * W := C * V' = (C1*V1' + C2*V2') (stored in WORK) 00463 * 00464 * W := C1 00465 * 00466 DO 160 J = 1, K 00467 CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) 00468 160 CONTINUE 00469 * 00470 * W := W * V1' 00471 * 00472 CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', 00473 $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00474 IF( LASTV.GT.K ) THEN 00475 * 00476 * W := W + C2 * V2' 00477 * 00478 CALL ZGEMM( 'No transpose', 'Conjugate transpose', 00479 $ LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC, 00480 $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK ) 00481 END IF 00482 * 00483 * W := W * T or W * T' 00484 * 00485 CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', 00486 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00487 * 00488 * C := C - W * V 00489 * 00490 IF( LASTV.GT.K ) THEN 00491 * 00492 * C2 := C2 - W * V2 00493 * 00494 CALL ZGEMM( 'No transpose', 'No transpose', 00495 $ LASTC, LASTV-K, K, 00496 $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, 00497 $ ONE, C( 1, K+1 ), LDC ) 00498 END IF 00499 * 00500 * W := W * V1 00501 * 00502 CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', 00503 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00504 * 00505 * C1 := C1 - W 00506 * 00507 DO 180 J = 1, K 00508 DO 170 I = 1, LASTC 00509 C( I, J ) = C( I, J ) - WORK( I, J ) 00510 170 CONTINUE 00511 180 CONTINUE 00512 * 00513 END IF 00514 * 00515 ELSE 00516 * 00517 * Let V = ( V1 V2 ) (V2: last K columns) 00518 * where V2 is unit lower triangular. 00519 * 00520 IF( LSAME( SIDE, 'L' ) ) THEN 00521 * 00522 * Form H * C or H' * C where C = ( C1 ) 00523 * ( C2 ) 00524 * 00525 LASTV = MAX( K, ILAZLC( K, M, V, LDV ) ) 00526 LASTC = ILAZLC( LASTV, N, C, LDC ) 00527 * 00528 * W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) 00529 * 00530 * W := C2' 00531 * 00532 DO 190 J = 1, K 00533 CALL ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, 00534 $ WORK( 1, J ), 1 ) 00535 CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) 00536 190 CONTINUE 00537 * 00538 * W := W * V2' 00539 * 00540 CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', 00541 $ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, 00542 $ WORK, LDWORK ) 00543 IF( LASTV.GT.K ) THEN 00544 * 00545 * W := W + C1'*V1' 00546 * 00547 CALL ZGEMM( 'Conjugate transpose', 00548 $ 'Conjugate transpose', LASTC, K, LASTV-K, 00549 $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) 00550 END IF 00551 * 00552 * W := W * T' or W * T 00553 * 00554 CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', 00555 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00556 * 00557 * C := C - V' * W' 00558 * 00559 IF( LASTV.GT.K ) THEN 00560 * 00561 * C1 := C1 - V1' * W' 00562 * 00563 CALL ZGEMM( 'Conjugate transpose', 00564 $ 'Conjugate transpose', LASTV-K, LASTC, K, 00565 $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) 00566 END IF 00567 * 00568 * W := W * V2 00569 * 00570 CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', 00571 $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, 00572 $ WORK, LDWORK ) 00573 * 00574 * C2 := C2 - W' 00575 * 00576 DO 210 J = 1, K 00577 DO 200 I = 1, LASTC 00578 C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - 00579 $ DCONJG( WORK( I, J ) ) 00580 200 CONTINUE 00581 210 CONTINUE 00582 * 00583 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 00584 * 00585 * Form C * H or C * H' where C = ( C1 C2 ) 00586 * 00587 LASTV = MAX( K, ILAZLC( K, N, V, LDV ) ) 00588 LASTC = ILAZLR( M, LASTV, C, LDC ) 00589 * 00590 * W := C * V' = (C1*V1' + C2*V2') (stored in WORK) 00591 * 00592 * W := C2 00593 * 00594 DO 220 J = 1, K 00595 CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1, 00596 $ WORK( 1, J ), 1 ) 00597 220 CONTINUE 00598 * 00599 * W := W * V2' 00600 * 00601 CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', 00602 $ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, 00603 $ WORK, LDWORK ) 00604 IF( LASTV.GT.K ) THEN 00605 * 00606 * W := W + C1 * V1' 00607 * 00608 CALL ZGEMM( 'No transpose', 'Conjugate transpose', 00609 $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, ONE, 00610 $ WORK, LDWORK ) 00611 END IF 00612 * 00613 * W := W * T or W * T' 00614 * 00615 CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', 00616 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00617 * 00618 * C := C - W * V 00619 * 00620 IF( LASTV.GT.K ) THEN 00621 * 00622 * C1 := C1 - W * V1 00623 * 00624 CALL ZGEMM( 'No transpose', 'No transpose', 00625 $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, 00626 $ ONE, C, LDC ) 00627 END IF 00628 * 00629 * W := W * V2 00630 * 00631 CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', 00632 $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, 00633 $ WORK, LDWORK ) 00634 * 00635 * C1 := C1 - W 00636 * 00637 DO 240 J = 1, K 00638 DO 230 I = 1, LASTC 00639 C( I, LASTV-K+J ) = C( I, LASTV-K+J ) 00640 $ - WORK( I, J ) 00641 230 CONTINUE 00642 240 CONTINUE 00643 * 00644 END IF 00645 * 00646 END IF 00647 END IF 00648 * 00649 RETURN 00650 * 00651 * End of ZLARFB 00652 * 00653 END
1.7.3 
