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