![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b ZLARFB 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 *> \htmlonly 00009 *> Download ZLARFB + dependencies 00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarfb.f"> 00011 *> [TGZ]</a> 00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarfb.f"> 00013 *> [ZIP]</a> 00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarfb.f"> 00015 *> [TXT]</a> 00016 *> \endhtmlonly 00017 * 00018 * Definition: 00019 * =========== 00020 * 00021 * SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, 00022 * T, LDT, C, LDC, WORK, LDWORK ) 00023 * 00024 * .. Scalar Arguments .. 00025 * CHARACTER DIRECT, SIDE, STOREV, TRANS 00026 * INTEGER K, LDC, LDT, LDV, LDWORK, M, N 00027 * .. 00028 * .. Array Arguments .. 00029 * COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), 00030 * $ WORK( LDWORK, * ) 00031 * .. 00032 * 00033 * 00034 *> \par Purpose: 00035 * ============= 00036 *> 00037 *> \verbatim 00038 *> 00039 *> ZLARFB applies a complex block reflector H or its transpose H**H to a 00040 *> complex M-by-N matrix C, from either the left or the right. 00041 *> \endverbatim 00042 * 00043 * Arguments: 00044 * ========== 00045 * 00046 *> \param[in] SIDE 00047 *> \verbatim 00048 *> SIDE is CHARACTER*1 00049 *> = 'L': apply H or H**H from the Left 00050 *> = 'R': apply H or H**H from the Right 00051 *> \endverbatim 00052 *> 00053 *> \param[in] TRANS 00054 *> \verbatim 00055 *> TRANS is CHARACTER*1 00056 *> = 'N': apply H (No transpose) 00057 *> = 'C': apply H**H (Conjugate transpose) 00058 *> \endverbatim 00059 *> 00060 *> \param[in] DIRECT 00061 *> \verbatim 00062 *> DIRECT is CHARACTER*1 00063 *> Indicates how H is formed from a product of elementary 00064 *> reflectors 00065 *> = 'F': H = H(1) H(2) . . . H(k) (Forward) 00066 *> = 'B': H = H(k) . . . H(2) H(1) (Backward) 00067 *> \endverbatim 00068 *> 00069 *> \param[in] STOREV 00070 *> \verbatim 00071 *> STOREV is CHARACTER*1 00072 *> Indicates how the vectors which define the elementary 00073 *> reflectors are stored: 00074 *> = 'C': Columnwise 00075 *> = 'R': Rowwise 00076 *> \endverbatim 00077 *> 00078 *> \param[in] M 00079 *> \verbatim 00080 *> M is INTEGER 00081 *> The number of rows of the matrix C. 00082 *> \endverbatim 00083 *> 00084 *> \param[in] N 00085 *> \verbatim 00086 *> N is INTEGER 00087 *> The number of columns of the matrix C. 00088 *> \endverbatim 00089 *> 00090 *> \param[in] K 00091 *> \verbatim 00092 *> K is INTEGER 00093 *> The order of the matrix T (= the number of elementary 00094 *> reflectors whose product defines the block reflector). 00095 *> \endverbatim 00096 *> 00097 *> \param[in] V 00098 *> \verbatim 00099 *> V is COMPLEX*16 array, dimension 00100 *> (LDV,K) if STOREV = 'C' 00101 *> (LDV,M) if STOREV = 'R' and SIDE = 'L' 00102 *> (LDV,N) if STOREV = 'R' and SIDE = 'R' 00103 *> See Further Details. 00104 *> \endverbatim 00105 *> 00106 *> \param[in] LDV 00107 *> \verbatim 00108 *> LDV is INTEGER 00109 *> The leading dimension of the array V. 00110 *> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); 00111 *> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); 00112 *> if STOREV = 'R', LDV >= K. 00113 *> \endverbatim 00114 *> 00115 *> \param[in] T 00116 *> \verbatim 00117 *> T is COMPLEX*16 array, dimension (LDT,K) 00118 *> The triangular K-by-K matrix T in the representation of the 00119 *> block reflector. 00120 *> \endverbatim 00121 *> 00122 *> \param[in] LDT 00123 *> \verbatim 00124 *> LDT is INTEGER 00125 *> The leading dimension of the array T. LDT >= K. 00126 *> \endverbatim 00127 *> 00128 *> \param[in,out] C 00129 *> \verbatim 00130 *> C is COMPLEX*16 array, dimension (LDC,N) 00131 *> On entry, the M-by-N matrix C. 00132 *> On exit, C is overwritten by H*C or H**H*C or C*H or C*H**H. 00133 *> \endverbatim 00134 *> 00135 *> \param[in] LDC 00136 *> \verbatim 00137 *> LDC is INTEGER 00138 *> The leading dimension of the array C. LDC >= max(1,M). 00139 *> \endverbatim 00140 *> 00141 *> \param[out] WORK 00142 *> \verbatim 00143 *> WORK is COMPLEX*16 array, dimension (LDWORK,K) 00144 *> \endverbatim 00145 *> 00146 *> \param[in] LDWORK 00147 *> \verbatim 00148 *> LDWORK is INTEGER 00149 *> The leading dimension of the array WORK. 00150 *> If SIDE = 'L', LDWORK >= max(1,N); 00151 *> if SIDE = 'R', LDWORK >= max(1,M). 00152 *> \endverbatim 00153 * 00154 * Authors: 00155 * ======== 00156 * 00157 *> \author Univ. of Tennessee 00158 *> \author Univ. of California Berkeley 00159 *> \author Univ. of Colorado Denver 00160 *> \author NAG Ltd. 00161 * 00162 *> \date November 2011 00163 * 00164 *> \ingroup complex16OTHERauxiliary 00165 * 00166 *> \par Further Details: 00167 * ===================== 00168 *> 00169 *> \verbatim 00170 *> 00171 *> The shape of the matrix V and the storage of the vectors which define 00172 *> the H(i) is best illustrated by the following example with n = 5 and 00173 *> k = 3. The elements equal to 1 are not stored; the corresponding 00174 *> array elements are modified but restored on exit. The rest of the 00175 *> array is not used. 00176 *> 00177 *> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': 00178 *> 00179 *> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) 00180 *> ( v1 1 ) ( 1 v2 v2 v2 ) 00181 *> ( v1 v2 1 ) ( 1 v3 v3 ) 00182 *> ( v1 v2 v3 ) 00183 *> ( v1 v2 v3 ) 00184 *> 00185 *> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': 00186 *> 00187 *> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) 00188 *> ( v1 v2 v3 ) ( v2 v2 v2 1 ) 00189 *> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) 00190 *> ( 1 v3 ) 00191 *> ( 1 ) 00192 *> \endverbatim 00193 *> 00194 * ===================================================================== 00195 SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, 00196 $ T, LDT, C, LDC, WORK, LDWORK ) 00197 * 00198 * -- LAPACK auxiliary routine (version 3.4.0) -- 00199 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00200 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00201 * November 2011 00202 * 00203 * .. Scalar Arguments .. 00204 CHARACTER DIRECT, SIDE, STOREV, TRANS 00205 INTEGER K, LDC, LDT, LDV, LDWORK, M, N 00206 * .. 00207 * .. Array Arguments .. 00208 COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), 00209 $ WORK( LDWORK, * ) 00210 * .. 00211 * 00212 * ===================================================================== 00213 * 00214 * .. Parameters .. 00215 COMPLEX*16 ONE 00216 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 00217 * .. 00218 * .. Local Scalars .. 00219 CHARACTER TRANST 00220 INTEGER I, J, LASTV, LASTC 00221 * .. 00222 * .. External Functions .. 00223 LOGICAL LSAME 00224 INTEGER ILAZLR, ILAZLC 00225 EXTERNAL LSAME, ILAZLR, ILAZLC 00226 * .. 00227 * .. External Subroutines .. 00228 EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM 00229 * .. 00230 * .. Intrinsic Functions .. 00231 INTRINSIC DCONJG 00232 * .. 00233 * .. Executable Statements .. 00234 * 00235 * Quick return if possible 00236 * 00237 IF( M.LE.0 .OR. N.LE.0 ) 00238 $ RETURN 00239 * 00240 IF( LSAME( TRANS, 'N' ) ) THEN 00241 TRANST = 'C' 00242 ELSE 00243 TRANST = 'N' 00244 END IF 00245 * 00246 IF( LSAME( STOREV, 'C' ) ) THEN 00247 * 00248 IF( LSAME( DIRECT, 'F' ) ) THEN 00249 * 00250 * Let V = ( V1 ) (first K rows) 00251 * ( V2 ) 00252 * where V1 is unit lower triangular. 00253 * 00254 IF( LSAME( SIDE, 'L' ) ) THEN 00255 * 00256 * Form H * C or H**H * C where C = ( C1 ) 00257 * ( C2 ) 00258 * 00259 LASTV = MAX( K, ILAZLR( M, K, V, LDV ) ) 00260 LASTC = ILAZLC( LASTV, N, C, LDC ) 00261 * 00262 * W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) 00263 * 00264 * W := C1**H 00265 * 00266 DO 10 J = 1, K 00267 CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 00268 CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) 00269 10 CONTINUE 00270 * 00271 * W := W * V1 00272 * 00273 CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', 00274 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00275 IF( LASTV.GT.K ) THEN 00276 * 00277 * W := W + C2**H *V2 00278 * 00279 CALL ZGEMM( 'Conjugate transpose', 'No transpose', 00280 $ LASTC, K, LASTV-K, ONE, C( K+1, 1 ), LDC, 00281 $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK ) 00282 END IF 00283 * 00284 * W := W * T**H or W * T 00285 * 00286 CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', 00287 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00288 * 00289 * C := C - V * W**H 00290 * 00291 IF( M.GT.K ) THEN 00292 * 00293 * C2 := C2 - V2 * W**H 00294 * 00295 CALL ZGEMM( 'No transpose', 'Conjugate transpose', 00296 $ LASTV-K, LASTC, K, 00297 $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, 00298 $ ONE, C( K+1, 1 ), LDC ) 00299 END IF 00300 * 00301 * W := W * V1**H 00302 * 00303 CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', 00304 $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00305 * 00306 * C1 := C1 - W**H 00307 * 00308 DO 30 J = 1, K 00309 DO 20 I = 1, LASTC 00310 C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) 00311 20 CONTINUE 00312 30 CONTINUE 00313 * 00314 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 00315 * 00316 * Form C * H or C * H**H where C = ( C1 C2 ) 00317 * 00318 LASTV = MAX( K, ILAZLR( N, K, V, LDV ) ) 00319 LASTC = ILAZLR( M, LASTV, C, LDC ) 00320 * 00321 * W := C * V = (C1*V1 + C2*V2) (stored in WORK) 00322 * 00323 * W := C1 00324 * 00325 DO 40 J = 1, K 00326 CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) 00327 40 CONTINUE 00328 * 00329 * W := W * V1 00330 * 00331 CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', 00332 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00333 IF( LASTV.GT.K ) THEN 00334 * 00335 * W := W + C2 * V2 00336 * 00337 CALL ZGEMM( 'No transpose', 'No transpose', 00338 $ LASTC, K, LASTV-K, 00339 $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, 00340 $ ONE, WORK, LDWORK ) 00341 END IF 00342 * 00343 * W := W * T or W * T**H 00344 * 00345 CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', 00346 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00347 * 00348 * C := C - W * V**H 00349 * 00350 IF( LASTV.GT.K ) THEN 00351 * 00352 * C2 := C2 - W * V2**H 00353 * 00354 CALL ZGEMM( 'No transpose', 'Conjugate transpose', 00355 $ LASTC, LASTV-K, K, 00356 $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, 00357 $ ONE, C( 1, K+1 ), LDC ) 00358 END IF 00359 * 00360 * W := W * V1**H 00361 * 00362 CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', 00363 $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00364 * 00365 * C1 := C1 - W 00366 * 00367 DO 60 J = 1, K 00368 DO 50 I = 1, LASTC 00369 C( I, J ) = C( I, J ) - WORK( I, J ) 00370 50 CONTINUE 00371 60 CONTINUE 00372 END IF 00373 * 00374 ELSE 00375 * 00376 * Let V = ( V1 ) 00377 * ( V2 ) (last K rows) 00378 * where V2 is unit upper triangular. 00379 * 00380 IF( LSAME( SIDE, 'L' ) ) THEN 00381 * 00382 * Form H * C or H**H * C where C = ( C1 ) 00383 * ( C2 ) 00384 * 00385 LASTV = MAX( K, ILAZLR( M, K, V, LDV ) ) 00386 LASTC = ILAZLC( LASTV, N, C, LDC ) 00387 * 00388 * W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) 00389 * 00390 * W := C2**H 00391 * 00392 DO 70 J = 1, K 00393 CALL ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, 00394 $ WORK( 1, J ), 1 ) 00395 CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) 00396 70 CONTINUE 00397 * 00398 * W := W * V2 00399 * 00400 CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', 00401 $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, 00402 $ WORK, LDWORK ) 00403 IF( LASTV.GT.K ) THEN 00404 * 00405 * W := W + C1**H*V1 00406 * 00407 CALL ZGEMM( 'Conjugate transpose', 'No transpose', 00408 $ LASTC, K, LASTV-K, 00409 $ ONE, C, LDC, V, LDV, 00410 $ ONE, WORK, LDWORK ) 00411 END IF 00412 * 00413 * W := W * T**H or W * T 00414 * 00415 CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', 00416 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00417 * 00418 * C := C - V * W**H 00419 * 00420 IF( LASTV.GT.K ) THEN 00421 * 00422 * C1 := C1 - V1 * W**H 00423 * 00424 CALL ZGEMM( 'No transpose', 'Conjugate transpose', 00425 $ LASTV-K, LASTC, K, 00426 $ -ONE, V, LDV, WORK, LDWORK, 00427 $ ONE, C, LDC ) 00428 END IF 00429 * 00430 * W := W * V2**H 00431 * 00432 CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', 00433 $ 'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, 00434 $ WORK, LDWORK ) 00435 * 00436 * C2 := C2 - W**H 00437 * 00438 DO 90 J = 1, K 00439 DO 80 I = 1, LASTC 00440 C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - 00441 $ DCONJG( WORK( I, J ) ) 00442 80 CONTINUE 00443 90 CONTINUE 00444 * 00445 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 00446 * 00447 * Form C * H or C * H**H where C = ( C1 C2 ) 00448 * 00449 LASTV = MAX( K, ILAZLR( N, K, V, LDV ) ) 00450 LASTC = ILAZLR( M, LASTV, C, LDC ) 00451 * 00452 * W := C * V = (C1*V1 + C2*V2) (stored in WORK) 00453 * 00454 * W := C2 00455 * 00456 DO 100 J = 1, K 00457 CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1, 00458 $ WORK( 1, J ), 1 ) 00459 100 CONTINUE 00460 * 00461 * W := W * V2 00462 * 00463 CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', 00464 $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, 00465 $ WORK, LDWORK ) 00466 IF( LASTV.GT.K ) THEN 00467 * 00468 * W := W + C1 * V1 00469 * 00470 CALL ZGEMM( 'No transpose', 'No transpose', 00471 $ LASTC, K, LASTV-K, 00472 $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) 00473 END IF 00474 * 00475 * W := W * T or W * T**H 00476 * 00477 CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', 00478 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00479 * 00480 * C := C - W * V**H 00481 * 00482 IF( LASTV.GT.K ) THEN 00483 * 00484 * C1 := C1 - W * V1**H 00485 * 00486 CALL ZGEMM( 'No transpose', 'Conjugate transpose', 00487 $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, 00488 $ ONE, C, LDC ) 00489 END IF 00490 * 00491 * W := W * V2**H 00492 * 00493 CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', 00494 $ 'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, 00495 $ WORK, LDWORK ) 00496 * 00497 * C2 := C2 - W 00498 * 00499 DO 120 J = 1, K 00500 DO 110 I = 1, LASTC 00501 C( I, LASTV-K+J ) = C( I, LASTV-K+J ) 00502 $ - WORK( I, J ) 00503 110 CONTINUE 00504 120 CONTINUE 00505 END IF 00506 END IF 00507 * 00508 ELSE IF( LSAME( STOREV, 'R' ) ) THEN 00509 * 00510 IF( LSAME( DIRECT, 'F' ) ) THEN 00511 * 00512 * Let V = ( V1 V2 ) (V1: first K columns) 00513 * where V1 is unit upper triangular. 00514 * 00515 IF( LSAME( SIDE, 'L' ) ) THEN 00516 * 00517 * Form H * C or H**H * C where C = ( C1 ) 00518 * ( C2 ) 00519 * 00520 LASTV = MAX( K, ILAZLC( K, M, V, LDV ) ) 00521 LASTC = ILAZLC( LASTV, N, C, LDC ) 00522 * 00523 * W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) 00524 * 00525 * W := C1**H 00526 * 00527 DO 130 J = 1, K 00528 CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 00529 CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) 00530 130 CONTINUE 00531 * 00532 * W := W * V1**H 00533 * 00534 CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', 00535 $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00536 IF( LASTV.GT.K ) THEN 00537 * 00538 * W := W + C2**H*V2**H 00539 * 00540 CALL ZGEMM( 'Conjugate transpose', 00541 $ 'Conjugate transpose', LASTC, K, LASTV-K, 00542 $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, 00543 $ ONE, WORK, LDWORK ) 00544 END IF 00545 * 00546 * W := W * T**H or W * T 00547 * 00548 CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', 00549 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00550 * 00551 * C := C - V**H * W**H 00552 * 00553 IF( LASTV.GT.K ) THEN 00554 * 00555 * C2 := C2 - V2**H * W**H 00556 * 00557 CALL ZGEMM( 'Conjugate transpose', 00558 $ 'Conjugate transpose', LASTV-K, LASTC, K, 00559 $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, 00560 $ ONE, C( K+1, 1 ), LDC ) 00561 END IF 00562 * 00563 * W := W * V1 00564 * 00565 CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', 00566 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00567 * 00568 * C1 := C1 - W**H 00569 * 00570 DO 150 J = 1, K 00571 DO 140 I = 1, LASTC 00572 C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) 00573 140 CONTINUE 00574 150 CONTINUE 00575 * 00576 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 00577 * 00578 * Form C * H or C * H**H where C = ( C1 C2 ) 00579 * 00580 LASTV = MAX( K, ILAZLC( K, N, V, LDV ) ) 00581 LASTC = ILAZLR( M, LASTV, C, LDC ) 00582 * 00583 * W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) 00584 * 00585 * W := C1 00586 * 00587 DO 160 J = 1, K 00588 CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) 00589 160 CONTINUE 00590 * 00591 * W := W * V1**H 00592 * 00593 CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', 00594 $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00595 IF( LASTV.GT.K ) THEN 00596 * 00597 * W := W + C2 * V2**H 00598 * 00599 CALL ZGEMM( 'No transpose', 'Conjugate transpose', 00600 $ LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC, 00601 $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK ) 00602 END IF 00603 * 00604 * W := W * T or W * T**H 00605 * 00606 CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', 00607 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00608 * 00609 * C := C - W * V 00610 * 00611 IF( LASTV.GT.K ) THEN 00612 * 00613 * C2 := C2 - W * V2 00614 * 00615 CALL ZGEMM( 'No transpose', 'No transpose', 00616 $ LASTC, LASTV-K, K, 00617 $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, 00618 $ ONE, C( 1, K+1 ), LDC ) 00619 END IF 00620 * 00621 * W := W * V1 00622 * 00623 CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', 00624 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 00625 * 00626 * C1 := C1 - W 00627 * 00628 DO 180 J = 1, K 00629 DO 170 I = 1, LASTC 00630 C( I, J ) = C( I, J ) - WORK( I, J ) 00631 170 CONTINUE 00632 180 CONTINUE 00633 * 00634 END IF 00635 * 00636 ELSE 00637 * 00638 * Let V = ( V1 V2 ) (V2: last K columns) 00639 * where V2 is unit lower triangular. 00640 * 00641 IF( LSAME( SIDE, 'L' ) ) THEN 00642 * 00643 * Form H * C or H**H * C where C = ( C1 ) 00644 * ( C2 ) 00645 * 00646 LASTV = MAX( K, ILAZLC( K, M, V, LDV ) ) 00647 LASTC = ILAZLC( LASTV, N, C, LDC ) 00648 * 00649 * W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) 00650 * 00651 * W := C2**H 00652 * 00653 DO 190 J = 1, K 00654 CALL ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, 00655 $ WORK( 1, J ), 1 ) 00656 CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) 00657 190 CONTINUE 00658 * 00659 * W := W * V2**H 00660 * 00661 CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', 00662 $ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, 00663 $ WORK, LDWORK ) 00664 IF( LASTV.GT.K ) THEN 00665 * 00666 * W := W + C1**H * V1**H 00667 * 00668 CALL ZGEMM( 'Conjugate transpose', 00669 $ 'Conjugate transpose', LASTC, K, LASTV-K, 00670 $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) 00671 END IF 00672 * 00673 * W := W * T**H or W * T 00674 * 00675 CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', 00676 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00677 * 00678 * C := C - V**H * W**H 00679 * 00680 IF( LASTV.GT.K ) THEN 00681 * 00682 * C1 := C1 - V1**H * W**H 00683 * 00684 CALL ZGEMM( 'Conjugate transpose', 00685 $ 'Conjugate transpose', LASTV-K, LASTC, K, 00686 $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) 00687 END IF 00688 * 00689 * W := W * V2 00690 * 00691 CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', 00692 $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, 00693 $ WORK, LDWORK ) 00694 * 00695 * C2 := C2 - W**H 00696 * 00697 DO 210 J = 1, K 00698 DO 200 I = 1, LASTC 00699 C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - 00700 $ DCONJG( WORK( I, J ) ) 00701 200 CONTINUE 00702 210 CONTINUE 00703 * 00704 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 00705 * 00706 * Form C * H or C * H**H where C = ( C1 C2 ) 00707 * 00708 LASTV = MAX( K, ILAZLC( K, N, V, LDV ) ) 00709 LASTC = ILAZLR( M, LASTV, C, LDC ) 00710 * 00711 * W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) 00712 * 00713 * W := C2 00714 * 00715 DO 220 J = 1, K 00716 CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1, 00717 $ WORK( 1, J ), 1 ) 00718 220 CONTINUE 00719 * 00720 * W := W * V2**H 00721 * 00722 CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', 00723 $ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, 00724 $ WORK, LDWORK ) 00725 IF( LASTV.GT.K ) THEN 00726 * 00727 * W := W + C1 * V1**H 00728 * 00729 CALL ZGEMM( 'No transpose', 'Conjugate transpose', 00730 $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, ONE, 00731 $ WORK, LDWORK ) 00732 END IF 00733 * 00734 * W := W * T or W * T**H 00735 * 00736 CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', 00737 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 00738 * 00739 * C := C - W * V 00740 * 00741 IF( LASTV.GT.K ) THEN 00742 * 00743 * C1 := C1 - W * V1 00744 * 00745 CALL ZGEMM( 'No transpose', 'No transpose', 00746 $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, 00747 $ ONE, C, LDC ) 00748 END IF 00749 * 00750 * W := W * V2 00751 * 00752 CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', 00753 $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, 00754 $ WORK, LDWORK ) 00755 * 00756 * C1 := C1 - W 00757 * 00758 DO 240 J = 1, K 00759 DO 230 I = 1, LASTC 00760 C( I, LASTV-K+J ) = C( I, LASTV-K+J ) 00761 $ - WORK( I, J ) 00762 230 CONTINUE 00763 240 CONTINUE 00764 * 00765 END IF 00766 * 00767 END IF 00768 END IF 00769 * 00770 RETURN 00771 * 00772 * End of ZLARFB 00773 * 00774 END