1 *> \brief \b ZLARFB 2 * 3 * =========== DOCUMENTATION =========== 4 * 5 * Online html documentation available at 6 * http://www.netlib.org/lapack/explore-html/ 7 * 8 *> \htmlonly 9 *> Download ZLARFB + dependencies 10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarfb.f"> 11 *> [TGZ]</a> 12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarfb.f"> 13 *> [ZIP]</a> 14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarfb.f"> 15 *> [TXT]</a> 16 *> \endhtmlonly 17 * 18 * Definition: 19 * =========== 20 * 21 * SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, 22 * T, LDT, C, LDC, WORK, LDWORK ) 23 * 24 * .. Scalar Arguments .. 25 * CHARACTER DIRECT, SIDE, STOREV, TRANS 26 * INTEGER K, LDC, LDT, LDV, LDWORK, M, N 27 * .. 28 * .. Array Arguments .. 29 * COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), 30 * $ WORK( LDWORK, * ) 31 * .. 32 * 33 * 34 *> \par Purpose: 35 * ============= 36 *> 37 *> \verbatim 38 *> 39 *> ZLARFB applies a complex block reflector H or its transpose H**H to a 40 *> complex M-by-N matrix C, from either the left or the right. 41 *> \endverbatim 42 * 43 * Arguments: 44 * ========== 45 * 46 *> \param[in] SIDE 47 *> \verbatim 48 *> SIDE is CHARACTER*1 49 *> = 'L': apply H or H**H from the Left 50 *> = 'R': apply H or H**H from the Right 51 *> \endverbatim 52 *> 53 *> \param[in] TRANS 54 *> \verbatim 55 *> TRANS is CHARACTER*1 56 *> = 'N': apply H (No transpose) 57 *> = 'C': apply H**H (Conjugate transpose) 58 *> \endverbatim 59 *> 60 *> \param[in] DIRECT 61 *> \verbatim 62 *> DIRECT is CHARACTER*1 63 *> Indicates how H is formed from a product of elementary 64 *> reflectors 65 *> = 'F': H = H(1) H(2) . . . H(k) (Forward) 66 *> = 'B': H = H(k) . . . H(2) H(1) (Backward) 67 *> \endverbatim 68 *> 69 *> \param[in] STOREV 70 *> \verbatim 71 *> STOREV is CHARACTER*1 72 *> Indicates how the vectors which define the elementary 73 *> reflectors are stored: 74 *> = 'C': Columnwise 75 *> = 'R': Rowwise 76 *> \endverbatim 77 *> 78 *> \param[in] M 79 *> \verbatim 80 *> M is INTEGER 81 *> The number of rows of the matrix C. 82 *> \endverbatim 83 *> 84 *> \param[in] N 85 *> \verbatim 86 *> N is INTEGER 87 *> The number of columns of the matrix C. 88 *> \endverbatim 89 *> 90 *> \param[in] K 91 *> \verbatim 92 *> K is INTEGER 93 *> The order of the matrix T (= the number of elementary 94 *> reflectors whose product defines the block reflector). 95 *> \endverbatim 96 *> 97 *> \param[in] V 98 *> \verbatim 99 *> V is COMPLEX*16 array, dimension 100 *> (LDV,K) if STOREV = 'C' 101 *> (LDV,M) if STOREV = 'R' and SIDE = 'L' 102 *> (LDV,N) if STOREV = 'R' and SIDE = 'R' 103 *> See Further Details. 104 *> \endverbatim 105 *> 106 *> \param[in] LDV 107 *> \verbatim 108 *> LDV is INTEGER 109 *> The leading dimension of the array V. 110 *> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); 111 *> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); 112 *> if STOREV = 'R', LDV >= K. 113 *> \endverbatim 114 *> 115 *> \param[in] T 116 *> \verbatim 117 *> T is COMPLEX*16 array, dimension (LDT,K) 118 *> The triangular K-by-K matrix T in the representation of the 119 *> block reflector. 120 *> \endverbatim 121 *> 122 *> \param[in] LDT 123 *> \verbatim 124 *> LDT is INTEGER 125 *> The leading dimension of the array T. LDT >= K. 126 *> \endverbatim 127 *> 128 *> \param[in,out] C 129 *> \verbatim 130 *> C is COMPLEX*16 array, dimension (LDC,N) 131 *> On entry, the M-by-N matrix C. 132 *> On exit, C is overwritten by H*C or H**H*C or C*H or C*H**H. 133 *> \endverbatim 134 *> 135 *> \param[in] LDC 136 *> \verbatim 137 *> LDC is INTEGER 138 *> The leading dimension of the array C. LDC >= max(1,M). 139 *> \endverbatim 140 *> 141 *> \param[out] WORK 142 *> \verbatim 143 *> WORK is COMPLEX*16 array, dimension (LDWORK,K) 144 *> \endverbatim 145 *> 146 *> \param[in] LDWORK 147 *> \verbatim 148 *> LDWORK is INTEGER 149 *> The leading dimension of the array WORK. 150 *> If SIDE = 'L', LDWORK >= max(1,N); 151 *> if SIDE = 'R', LDWORK >= max(1,M). 152 *> \endverbatim 153 * 154 * Authors: 155 * ======== 156 * 157 *> \author Univ. of Tennessee 158 *> \author Univ. of California Berkeley 159 *> \author Univ. of Colorado Denver 160 *> \author NAG Ltd. 161 * 162 *> \date November 2011 163 * 164 *> \ingroup complex16OTHERauxiliary 165 * 166 *> \par Further Details: 167 * ===================== 168 *> 169 *> \verbatim 170 *> 171 *> The shape of the matrix V and the storage of the vectors which define 172 *> the H(i) is best illustrated by the following example with n = 5 and 173 *> k = 3. The elements equal to 1 are not stored; the corresponding 174 *> array elements are modified but restored on exit. The rest of the 175 *> array is not used. 176 *> 177 *> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': 178 *> 179 *> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) 180 *> ( v1 1 ) ( 1 v2 v2 v2 ) 181 *> ( v1 v2 1 ) ( 1 v3 v3 ) 182 *> ( v1 v2 v3 ) 183 *> ( v1 v2 v3 ) 184 *> 185 *> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': 186 *> 187 *> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) 188 *> ( v1 v2 v3 ) ( v2 v2 v2 1 ) 189 *> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) 190 *> ( 1 v3 ) 191 *> ( 1 ) 192 *> \endverbatim 193 *> 194 * ===================================================================== 195 SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, 196 $ T, LDT, C, LDC, WORK, LDWORK ) 197 * 198 * -- LAPACK auxiliary routine (version 3.4.0) -- 199 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 200 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 201 * November 2011 202 * 203 * .. Scalar Arguments .. 204 CHARACTER DIRECT, SIDE, STOREV, TRANS 205 INTEGER K, LDC, LDT, LDV, LDWORK, M, N 206 * .. 207 * .. Array Arguments .. 208 COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), 209 $ WORK( LDWORK, * ) 210 * .. 211 * 212 * ===================================================================== 213 * 214 * .. Parameters .. 215 COMPLEX*16 ONE 216 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 217 * .. 218 * .. Local Scalars .. 219 CHARACTER TRANST 220 INTEGER I, J, LASTV, LASTC 221 * .. 222 * .. External Functions .. 223 LOGICAL LSAME 224 INTEGER ILAZLR, ILAZLC 225 EXTERNAL LSAME, ILAZLR, ILAZLC 226 * .. 227 * .. External Subroutines .. 228 EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM 229 * .. 230 * .. Intrinsic Functions .. 231 INTRINSIC DCONJG 232 * .. 233 * .. Executable Statements .. 234 * 235 * Quick return if possible 236 * 237 IF( M.LE.0 .OR. N.LE.0 ) 238 $ RETURN 239 * 240 IF( LSAME( TRANS, 'N' ) ) THEN 241 TRANST = 'C' 242 ELSE 243 TRANST = 'N' 244 END IF 245 * 246 IF( LSAME( STOREV, 'C' ) ) THEN 247 * 248 IF( LSAME( DIRECT, 'F' ) ) THEN 249 * 250 * Let V = ( V1 ) (first K rows) 251 * ( V2 ) 252 * where V1 is unit lower triangular. 253 * 254 IF( LSAME( SIDE, 'L' ) ) THEN 255 * 256 * Form H * C or H**H * C where C = ( C1 ) 257 * ( C2 ) 258 * 259 LASTV = MAX( K, ILAZLR( M, K, V, LDV ) ) 260 LASTC = ILAZLC( LASTV, N, C, LDC ) 261 * 262 * W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) 263 * 264 * W := C1**H 265 * 266 DO 10 J = 1, K 267 CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 268 CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) 269 10 CONTINUE 270 * 271 * W := W * V1 272 * 273 CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', 274 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 275 IF( LASTV.GT.K ) THEN 276 * 277 * W := W + C2**H *V2 278 * 279 CALL ZGEMM( 'Conjugate transpose', 'No transpose', 280 $ LASTC, K, LASTV-K, ONE, C( K+1, 1 ), LDC, 281 $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK ) 282 END IF 283 * 284 * W := W * T**H or W * T 285 * 286 CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', 287 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 288 * 289 * C := C - V * W**H 290 * 291 IF( M.GT.K ) THEN 292 * 293 * C2 := C2 - V2 * W**H 294 * 295 CALL ZGEMM( 'No transpose', 'Conjugate transpose', 296 $ LASTV-K, LASTC, K, 297 $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, 298 $ ONE, C( K+1, 1 ), LDC ) 299 END IF 300 * 301 * W := W * V1**H 302 * 303 CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', 304 $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) 305 * 306 * C1 := C1 - W**H 307 * 308 DO 30 J = 1, K 309 DO 20 I = 1, LASTC 310 C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) 311 20 CONTINUE 312 30 CONTINUE 313 * 314 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 315 * 316 * Form C * H or C * H**H where C = ( C1 C2 ) 317 * 318 LASTV = MAX( K, ILAZLR( N, K, V, LDV ) ) 319 LASTC = ILAZLR( M, LASTV, C, LDC ) 320 * 321 * W := C * V = (C1*V1 + C2*V2) (stored in WORK) 322 * 323 * W := C1 324 * 325 DO 40 J = 1, K 326 CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) 327 40 CONTINUE 328 * 329 * W := W * V1 330 * 331 CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', 332 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 333 IF( LASTV.GT.K ) THEN 334 * 335 * W := W + C2 * V2 336 * 337 CALL ZGEMM( 'No transpose', 'No transpose', 338 $ LASTC, K, LASTV-K, 339 $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, 340 $ ONE, WORK, LDWORK ) 341 END IF 342 * 343 * W := W * T or W * T**H 344 * 345 CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', 346 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 347 * 348 * C := C - W * V**H 349 * 350 IF( LASTV.GT.K ) THEN 351 * 352 * C2 := C2 - W * V2**H 353 * 354 CALL ZGEMM( 'No transpose', 'Conjugate transpose', 355 $ LASTC, LASTV-K, K, 356 $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, 357 $ ONE, C( 1, K+1 ), LDC ) 358 END IF 359 * 360 * W := W * V1**H 361 * 362 CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', 363 $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) 364 * 365 * C1 := C1 - W 366 * 367 DO 60 J = 1, K 368 DO 50 I = 1, LASTC 369 C( I, J ) = C( I, J ) - WORK( I, J ) 370 50 CONTINUE 371 60 CONTINUE 372 END IF 373 * 374 ELSE 375 * 376 * Let V = ( V1 ) 377 * ( V2 ) (last K rows) 378 * where V2 is unit upper triangular. 379 * 380 IF( LSAME( SIDE, 'L' ) ) THEN 381 * 382 * Form H * C or H**H * C where C = ( C1 ) 383 * ( C2 ) 384 * 385 LASTV = MAX( K, ILAZLR( M, K, V, LDV ) ) 386 LASTC = ILAZLC( LASTV, N, C, LDC ) 387 * 388 * W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) 389 * 390 * W := C2**H 391 * 392 DO 70 J = 1, K 393 CALL ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, 394 $ WORK( 1, J ), 1 ) 395 CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) 396 70 CONTINUE 397 * 398 * W := W * V2 399 * 400 CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', 401 $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, 402 $ WORK, LDWORK ) 403 IF( LASTV.GT.K ) THEN 404 * 405 * W := W + C1**H*V1 406 * 407 CALL ZGEMM( 'Conjugate transpose', 'No transpose', 408 $ LASTC, K, LASTV-K, 409 $ ONE, C, LDC, V, LDV, 410 $ ONE, WORK, LDWORK ) 411 END IF 412 * 413 * W := W * T**H or W * T 414 * 415 CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', 416 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 417 * 418 * C := C - V * W**H 419 * 420 IF( LASTV.GT.K ) THEN 421 * 422 * C1 := C1 - V1 * W**H 423 * 424 CALL ZGEMM( 'No transpose', 'Conjugate transpose', 425 $ LASTV-K, LASTC, K, 426 $ -ONE, V, LDV, WORK, LDWORK, 427 $ ONE, C, LDC ) 428 END IF 429 * 430 * W := W * V2**H 431 * 432 CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', 433 $ 'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, 434 $ WORK, LDWORK ) 435 * 436 * C2 := C2 - W**H 437 * 438 DO 90 J = 1, K 439 DO 80 I = 1, LASTC 440 C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - 441 $ DCONJG( WORK( I, J ) ) 442 80 CONTINUE 443 90 CONTINUE 444 * 445 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 446 * 447 * Form C * H or C * H**H where C = ( C1 C2 ) 448 * 449 LASTV = MAX( K, ILAZLR( N, K, V, LDV ) ) 450 LASTC = ILAZLR( M, LASTV, C, LDC ) 451 * 452 * W := C * V = (C1*V1 + C2*V2) (stored in WORK) 453 * 454 * W := C2 455 * 456 DO 100 J = 1, K 457 CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1, 458 $ WORK( 1, J ), 1 ) 459 100 CONTINUE 460 * 461 * W := W * V2 462 * 463 CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', 464 $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, 465 $ WORK, LDWORK ) 466 IF( LASTV.GT.K ) THEN 467 * 468 * W := W + C1 * V1 469 * 470 CALL ZGEMM( 'No transpose', 'No transpose', 471 $ LASTC, K, LASTV-K, 472 $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) 473 END IF 474 * 475 * W := W * T or W * T**H 476 * 477 CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', 478 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 479 * 480 * C := C - W * V**H 481 * 482 IF( LASTV.GT.K ) THEN 483 * 484 * C1 := C1 - W * V1**H 485 * 486 CALL ZGEMM( 'No transpose', 'Conjugate transpose', 487 $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, 488 $ ONE, C, LDC ) 489 END IF 490 * 491 * W := W * V2**H 492 * 493 CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', 494 $ 'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, 495 $ WORK, LDWORK ) 496 * 497 * C2 := C2 - W 498 * 499 DO 120 J = 1, K 500 DO 110 I = 1, LASTC 501 C( I, LASTV-K+J ) = C( I, LASTV-K+J ) 502 $ - WORK( I, J ) 503 110 CONTINUE 504 120 CONTINUE 505 END IF 506 END IF 507 * 508 ELSE IF( LSAME( STOREV, 'R' ) ) THEN 509 * 510 IF( LSAME( DIRECT, 'F' ) ) THEN 511 * 512 * Let V = ( V1 V2 ) (V1: first K columns) 513 * where V1 is unit upper triangular. 514 * 515 IF( LSAME( SIDE, 'L' ) ) THEN 516 * 517 * Form H * C or H**H * C where C = ( C1 ) 518 * ( C2 ) 519 * 520 LASTV = MAX( K, ILAZLC( K, M, V, LDV ) ) 521 LASTC = ILAZLC( LASTV, N, C, LDC ) 522 * 523 * W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) 524 * 525 * W := C1**H 526 * 527 DO 130 J = 1, K 528 CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 529 CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) 530 130 CONTINUE 531 * 532 * W := W * V1**H 533 * 534 CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', 535 $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) 536 IF( LASTV.GT.K ) THEN 537 * 538 * W := W + C2**H*V2**H 539 * 540 CALL ZGEMM( 'Conjugate transpose', 541 $ 'Conjugate transpose', LASTC, K, LASTV-K, 542 $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, 543 $ ONE, WORK, LDWORK ) 544 END IF 545 * 546 * W := W * T**H or W * T 547 * 548 CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', 549 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 550 * 551 * C := C - V**H * W**H 552 * 553 IF( LASTV.GT.K ) THEN 554 * 555 * C2 := C2 - V2**H * W**H 556 * 557 CALL ZGEMM( 'Conjugate transpose', 558 $ 'Conjugate transpose', LASTV-K, LASTC, K, 559 $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, 560 $ ONE, C( K+1, 1 ), LDC ) 561 END IF 562 * 563 * W := W * V1 564 * 565 CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', 566 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 567 * 568 * C1 := C1 - W**H 569 * 570 DO 150 J = 1, K 571 DO 140 I = 1, LASTC 572 C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) 573 140 CONTINUE 574 150 CONTINUE 575 * 576 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 577 * 578 * Form C * H or C * H**H where C = ( C1 C2 ) 579 * 580 LASTV = MAX( K, ILAZLC( K, N, V, LDV ) ) 581 LASTC = ILAZLR( M, LASTV, C, LDC ) 582 * 583 * W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) 584 * 585 * W := C1 586 * 587 DO 160 J = 1, K 588 CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) 589 160 CONTINUE 590 * 591 * W := W * V1**H 592 * 593 CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', 594 $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) 595 IF( LASTV.GT.K ) THEN 596 * 597 * W := W + C2 * V2**H 598 * 599 CALL ZGEMM( 'No transpose', 'Conjugate transpose', 600 $ LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC, 601 $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK ) 602 END IF 603 * 604 * W := W * T or W * T**H 605 * 606 CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', 607 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 608 * 609 * C := C - W * V 610 * 611 IF( LASTV.GT.K ) THEN 612 * 613 * C2 := C2 - W * V2 614 * 615 CALL ZGEMM( 'No transpose', 'No transpose', 616 $ LASTC, LASTV-K, K, 617 $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, 618 $ ONE, C( 1, K+1 ), LDC ) 619 END IF 620 * 621 * W := W * V1 622 * 623 CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', 624 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 625 * 626 * C1 := C1 - W 627 * 628 DO 180 J = 1, K 629 DO 170 I = 1, LASTC 630 C( I, J ) = C( I, J ) - WORK( I, J ) 631 170 CONTINUE 632 180 CONTINUE 633 * 634 END IF 635 * 636 ELSE 637 * 638 * Let V = ( V1 V2 ) (V2: last K columns) 639 * where V2 is unit lower triangular. 640 * 641 IF( LSAME( SIDE, 'L' ) ) THEN 642 * 643 * Form H * C or H**H * C where C = ( C1 ) 644 * ( C2 ) 645 * 646 LASTV = MAX( K, ILAZLC( K, M, V, LDV ) ) 647 LASTC = ILAZLC( LASTV, N, C, LDC ) 648 * 649 * W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) 650 * 651 * W := C2**H 652 * 653 DO 190 J = 1, K 654 CALL ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, 655 $ WORK( 1, J ), 1 ) 656 CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) 657 190 CONTINUE 658 * 659 * W := W * V2**H 660 * 661 CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', 662 $ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, 663 $ WORK, LDWORK ) 664 IF( LASTV.GT.K ) THEN 665 * 666 * W := W + C1**H * V1**H 667 * 668 CALL ZGEMM( 'Conjugate transpose', 669 $ 'Conjugate transpose', LASTC, K, LASTV-K, 670 $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) 671 END IF 672 * 673 * W := W * T**H or W * T 674 * 675 CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', 676 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 677 * 678 * C := C - V**H * W**H 679 * 680 IF( LASTV.GT.K ) THEN 681 * 682 * C1 := C1 - V1**H * W**H 683 * 684 CALL ZGEMM( 'Conjugate transpose', 685 $ 'Conjugate transpose', LASTV-K, LASTC, K, 686 $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) 687 END IF 688 * 689 * W := W * V2 690 * 691 CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', 692 $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, 693 $ WORK, LDWORK ) 694 * 695 * C2 := C2 - W**H 696 * 697 DO 210 J = 1, K 698 DO 200 I = 1, LASTC 699 C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - 700 $ DCONJG( WORK( I, J ) ) 701 200 CONTINUE 702 210 CONTINUE 703 * 704 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 705 * 706 * Form C * H or C * H**H where C = ( C1 C2 ) 707 * 708 LASTV = MAX( K, ILAZLC( K, N, V, LDV ) ) 709 LASTC = ILAZLR( M, LASTV, C, LDC ) 710 * 711 * W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) 712 * 713 * W := C2 714 * 715 DO 220 J = 1, K 716 CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1, 717 $ WORK( 1, J ), 1 ) 718 220 CONTINUE 719 * 720 * W := W * V2**H 721 * 722 CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', 723 $ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, 724 $ WORK, LDWORK ) 725 IF( LASTV.GT.K ) THEN 726 * 727 * W := W + C1 * V1**H 728 * 729 CALL ZGEMM( 'No transpose', 'Conjugate transpose', 730 $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, ONE, 731 $ WORK, LDWORK ) 732 END IF 733 * 734 * W := W * T or W * T**H 735 * 736 CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', 737 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 738 * 739 * C := C - W * V 740 * 741 IF( LASTV.GT.K ) THEN 742 * 743 * C1 := C1 - W * V1 744 * 745 CALL ZGEMM( 'No transpose', 'No transpose', 746 $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, 747 $ ONE, C, LDC ) 748 END IF 749 * 750 * W := W * V2 751 * 752 CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', 753 $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, 754 $ WORK, LDWORK ) 755 * 756 * C1 := C1 - W 757 * 758 DO 240 J = 1, K 759 DO 230 I = 1, LASTC 760 C( I, LASTV-K+J ) = C( I, LASTV-K+J ) 761 $ - WORK( I, J ) 762 230 CONTINUE 763 240 CONTINUE 764 * 765 END IF 766 * 767 END IF 768 END IF 769 * 770 RETURN 771 * 772 * End of ZLARFB 773 * 774 END 775
