clarfb.f revision 7faaa9f3f0df9d23790277834d426c3d992ac3ba
1*> \brief \b CLARFB 2* 3* =========== DOCUMENTATION =========== 4* 5* Online html documentation available at 6* http://www.netlib.org/lapack/explore-html/ 7* 8*> \htmlonly 9*> Download CLARFB + dependencies 10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/clarfb.f"> 11*> [TGZ]</a> 12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/clarfb.f"> 13*> [ZIP]</a> 14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/clarfb.f"> 15*> [TXT]</a> 16*> \endhtmlonly 17* 18* Definition: 19* =========== 20* 21* SUBROUTINE CLARFB( 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 C( LDC, * ), T( LDT, * ), V( LDV, * ), 30* $ WORK( LDWORK, * ) 31* .. 32* 33* 34*> \par Purpose: 35* ============= 36*> 37*> \verbatim 38*> 39*> CLARFB 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 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*> The matrix V. 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 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 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 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 complexOTHERauxiliary 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 CLARFB( 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 C( LDC, * ), T( LDT, * ), V( LDV, * ), 209 $ WORK( LDWORK, * ) 210* .. 211* 212* ===================================================================== 213* 214* .. Parameters .. 215 COMPLEX ONE 216 PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) 217* .. 218* .. Local Scalars .. 219 CHARACTER TRANST 220 INTEGER I, J, LASTV, LASTC 221* .. 222* .. External Functions .. 223 LOGICAL LSAME 224 INTEGER ILACLR, ILACLC 225 EXTERNAL LSAME, ILACLR, ILACLC 226* .. 227* .. External Subroutines .. 228 EXTERNAL CCOPY, CGEMM, CLACGV, CTRMM 229* .. 230* .. Intrinsic Functions .. 231 INTRINSIC CONJG 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, ILACLR( M, K, V, LDV ) ) 260 LASTC = ILACLC( 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 CCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 268 CALL CLACGV( LASTC, WORK( 1, J ), 1 ) 269 10 CONTINUE 270* 271* W := W * V1 272* 273 CALL CTRMM( '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 CGEMM( '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 CTRMM( '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 CGEMM( 'No transpose', 'Conjugate transpose', 296 $ LASTV-K, LASTC, K, -ONE, V( K+1, 1 ), LDV, 297 $ WORK, LDWORK, ONE, C( K+1, 1 ), LDC ) 298 END IF 299* 300* W := W * V1**H 301* 302 CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose', 303 $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) 304* 305* C1 := C1 - W**H 306* 307 DO 30 J = 1, K 308 DO 20 I = 1, LASTC 309 C( J, I ) = C( J, I ) - CONJG( WORK( I, J ) ) 310 20 CONTINUE 311 30 CONTINUE 312* 313 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 314* 315* Form C * H or C * H**H where C = ( C1 C2 ) 316* 317 LASTV = MAX( K, ILACLR( N, K, V, LDV ) ) 318 LASTC = ILACLR( M, LASTV, C, LDC ) 319* 320* W := C * V = (C1*V1 + C2*V2) (stored in WORK) 321* 322* W := C1 323* 324 DO 40 J = 1, K 325 CALL CCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) 326 40 CONTINUE 327* 328* W := W * V1 329* 330 CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', 331 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 332 IF( LASTV.GT.K ) THEN 333* 334* W := W + C2 * V2 335* 336 CALL CGEMM( 'No transpose', 'No transpose', 337 $ LASTC, K, LASTV-K, 338 $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, 339 $ ONE, WORK, LDWORK ) 340 END IF 341* 342* W := W * T or W * T**H 343* 344 CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit', 345 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 346* 347* C := C - W * V**H 348* 349 IF( LASTV.GT.K ) THEN 350* 351* C2 := C2 - W * V2**H 352* 353 CALL CGEMM( 'No transpose', 'Conjugate transpose', 354 $ LASTC, LASTV-K, K, 355 $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, 356 $ ONE, C( 1, K+1 ), LDC ) 357 END IF 358* 359* W := W * V1**H 360* 361 CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose', 362 $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) 363* 364* C1 := C1 - W 365* 366 DO 60 J = 1, K 367 DO 50 I = 1, LASTC 368 C( I, J ) = C( I, J ) - WORK( I, J ) 369 50 CONTINUE 370 60 CONTINUE 371 END IF 372* 373 ELSE 374* 375* Let V = ( V1 ) 376* ( V2 ) (last K rows) 377* where V2 is unit upper triangular. 378* 379 IF( LSAME( SIDE, 'L' ) ) THEN 380* 381* Form H * C or H**H * C where C = ( C1 ) 382* ( C2 ) 383* 384 LASTV = MAX( K, ILACLR( M, K, V, LDV ) ) 385 LASTC = ILACLC( LASTV, N, C, LDC ) 386* 387* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) 388* 389* W := C2**H 390* 391 DO 70 J = 1, K 392 CALL CCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, 393 $ WORK( 1, J ), 1 ) 394 CALL CLACGV( LASTC, WORK( 1, J ), 1 ) 395 70 CONTINUE 396* 397* W := W * V2 398* 399 CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', 400 $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, 401 $ WORK, LDWORK ) 402 IF( LASTV.GT.K ) THEN 403* 404* W := W + C1**H*V1 405* 406 CALL CGEMM( 'Conjugate transpose', 'No transpose', 407 $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, 408 $ ONE, WORK, LDWORK ) 409 END IF 410* 411* W := W * T**H or W * T 412* 413 CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit', 414 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 415* 416* C := C - V * W**H 417* 418 IF( LASTV.GT.K ) THEN 419* 420* C1 := C1 - V1 * W**H 421* 422 CALL CGEMM( 'No transpose', 'Conjugate transpose', 423 $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, 424 $ ONE, C, LDC ) 425 END IF 426* 427* W := W * V2**H 428* 429 CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose', 430 $ 'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, 431 $ WORK, LDWORK ) 432* 433* C2 := C2 - W**H 434* 435 DO 90 J = 1, K 436 DO 80 I = 1, LASTC 437 C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - 438 $ CONJG( WORK( I, J ) ) 439 80 CONTINUE 440 90 CONTINUE 441* 442 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 443* 444* Form C * H or C * H**H where C = ( C1 C2 ) 445* 446 LASTV = MAX( K, ILACLR( N, K, V, LDV ) ) 447 LASTC = ILACLR( M, LASTV, C, LDC ) 448* 449* W := C * V = (C1*V1 + C2*V2) (stored in WORK) 450* 451* W := C2 452* 453 DO 100 J = 1, K 454 CALL CCOPY( LASTC, C( 1, LASTV-K+J ), 1, 455 $ WORK( 1, J ), 1 ) 456 100 CONTINUE 457* 458* W := W * V2 459* 460 CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', 461 $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, 462 $ WORK, LDWORK ) 463 IF( LASTV.GT.K ) THEN 464* 465* W := W + C1 * V1 466* 467 CALL CGEMM( 'No transpose', 'No transpose', 468 $ LASTC, K, LASTV-K, 469 $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) 470 END IF 471* 472* W := W * T or W * T**H 473* 474 CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit', 475 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 476* 477* C := C - W * V**H 478* 479 IF( LASTV.GT.K ) THEN 480* 481* C1 := C1 - W * V1**H 482* 483 CALL CGEMM( 'No transpose', 'Conjugate transpose', 484 $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, 485 $ ONE, C, LDC ) 486 END IF 487* 488* W := W * V2**H 489* 490 CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose', 491 $ 'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, 492 $ WORK, LDWORK ) 493* 494* C2 := C2 - W 495* 496 DO 120 J = 1, K 497 DO 110 I = 1, LASTC 498 C( I, LASTV-K+J ) = C( I, LASTV-K+J ) 499 $ - WORK( I, J ) 500 110 CONTINUE 501 120 CONTINUE 502 END IF 503 END IF 504* 505 ELSE IF( LSAME( STOREV, 'R' ) ) THEN 506* 507 IF( LSAME( DIRECT, 'F' ) ) THEN 508* 509* Let V = ( V1 V2 ) (V1: first K columns) 510* where V1 is unit upper triangular. 511* 512 IF( LSAME( SIDE, 'L' ) ) THEN 513* 514* Form H * C or H**H * C where C = ( C1 ) 515* ( C2 ) 516* 517 LASTV = MAX( K, ILACLC( K, M, V, LDV ) ) 518 LASTC = ILACLC( LASTV, N, C, LDC ) 519* 520* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) 521* 522* W := C1**H 523* 524 DO 130 J = 1, K 525 CALL CCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 526 CALL CLACGV( LASTC, WORK( 1, J ), 1 ) 527 130 CONTINUE 528* 529* W := W * V1**H 530* 531 CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose', 532 $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) 533 IF( LASTV.GT.K ) THEN 534* 535* W := W + C2**H*V2**H 536* 537 CALL CGEMM( 'Conjugate transpose', 538 $ 'Conjugate transpose', LASTC, K, LASTV-K, 539 $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, 540 $ ONE, WORK, LDWORK ) 541 END IF 542* 543* W := W * T**H or W * T 544* 545 CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit', 546 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 547* 548* C := C - V**H * W**H 549* 550 IF( LASTV.GT.K ) THEN 551* 552* C2 := C2 - V2**H * W**H 553* 554 CALL CGEMM( 'Conjugate transpose', 555 $ 'Conjugate transpose', LASTV-K, LASTC, K, 556 $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, 557 $ ONE, C( K+1, 1 ), LDC ) 558 END IF 559* 560* W := W * V1 561* 562 CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', 563 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 564* 565* C1 := C1 - W**H 566* 567 DO 150 J = 1, K 568 DO 140 I = 1, LASTC 569 C( J, I ) = C( J, I ) - CONJG( WORK( I, J ) ) 570 140 CONTINUE 571 150 CONTINUE 572* 573 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 574* 575* Form C * H or C * H**H where C = ( C1 C2 ) 576* 577 LASTV = MAX( K, ILACLC( K, N, V, LDV ) ) 578 LASTC = ILACLR( M, LASTV, C, LDC ) 579* 580* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) 581* 582* W := C1 583* 584 DO 160 J = 1, K 585 CALL CCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) 586 160 CONTINUE 587* 588* W := W * V1**H 589* 590 CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose', 591 $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) 592 IF( LASTV.GT.K ) THEN 593* 594* W := W + C2 * V2**H 595* 596 CALL CGEMM( 'No transpose', 'Conjugate transpose', 597 $ LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC, 598 $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK ) 599 END IF 600* 601* W := W * T or W * T**H 602* 603 CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit', 604 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 605* 606* C := C - W * V 607* 608 IF( LASTV.GT.K ) THEN 609* 610* C2 := C2 - W * V2 611* 612 CALL CGEMM( 'No transpose', 'No transpose', 613 $ LASTC, LASTV-K, K, 614 $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, 615 $ ONE, C( 1, K+1 ), LDC ) 616 END IF 617* 618* W := W * V1 619* 620 CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', 621 $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) 622* 623* C1 := C1 - W 624* 625 DO 180 J = 1, K 626 DO 170 I = 1, LASTC 627 C( I, J ) = C( I, J ) - WORK( I, J ) 628 170 CONTINUE 629 180 CONTINUE 630* 631 END IF 632* 633 ELSE 634* 635* Let V = ( V1 V2 ) (V2: last K columns) 636* where V2 is unit lower triangular. 637* 638 IF( LSAME( SIDE, 'L' ) ) THEN 639* 640* Form H * C or H**H * C where C = ( C1 ) 641* ( C2 ) 642* 643 LASTV = MAX( K, ILACLC( K, M, V, LDV ) ) 644 LASTC = ILACLC( LASTV, N, C, LDC ) 645* 646* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) 647* 648* W := C2**H 649* 650 DO 190 J = 1, K 651 CALL CCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, 652 $ WORK( 1, J ), 1 ) 653 CALL CLACGV( LASTC, WORK( 1, J ), 1 ) 654 190 CONTINUE 655* 656* W := W * V2**H 657* 658 CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose', 659 $ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, 660 $ WORK, LDWORK ) 661 IF( LASTV.GT.K ) THEN 662* 663* W := W + C1**H * V1**H 664* 665 CALL CGEMM( 'Conjugate transpose', 666 $ 'Conjugate transpose', LASTC, K, LASTV-K, 667 $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) 668 END IF 669* 670* W := W * T**H or W * T 671* 672 CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit', 673 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 674* 675* C := C - V**H * W**H 676* 677 IF( LASTV.GT.K ) THEN 678* 679* C1 := C1 - V1**H * W**H 680* 681 CALL CGEMM( 'Conjugate transpose', 682 $ 'Conjugate transpose', LASTV-K, LASTC, K, 683 $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) 684 END IF 685* 686* W := W * V2 687* 688 CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', 689 $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, 690 $ WORK, LDWORK ) 691* 692* C2 := C2 - W**H 693* 694 DO 210 J = 1, K 695 DO 200 I = 1, LASTC 696 C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - 697 $ CONJG( WORK( I, J ) ) 698 200 CONTINUE 699 210 CONTINUE 700* 701 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 702* 703* Form C * H or C * H**H where C = ( C1 C2 ) 704* 705 LASTV = MAX( K, ILACLC( K, N, V, LDV ) ) 706 LASTC = ILACLR( M, LASTV, C, LDC ) 707* 708* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) 709* 710* W := C2 711* 712 DO 220 J = 1, K 713 CALL CCOPY( LASTC, C( 1, LASTV-K+J ), 1, 714 $ WORK( 1, J ), 1 ) 715 220 CONTINUE 716* 717* W := W * V2**H 718* 719 CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose', 720 $ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, 721 $ WORK, LDWORK ) 722 IF( LASTV.GT.K ) THEN 723* 724* W := W + C1 * V1**H 725* 726 CALL CGEMM( 'No transpose', 'Conjugate transpose', 727 $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, ONE, 728 $ WORK, LDWORK ) 729 END IF 730* 731* W := W * T or W * T**H 732* 733 CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit', 734 $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) 735* 736* C := C - W * V 737* 738 IF( LASTV.GT.K ) THEN 739* 740* C1 := C1 - W * V1 741* 742 CALL CGEMM( 'No transpose', 'No transpose', 743 $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, 744 $ ONE, C, LDC ) 745 END IF 746* 747* W := W * V2 748* 749 CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', 750 $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, 751 $ WORK, LDWORK ) 752* 753* C1 := C1 - W 754* 755 DO 240 J = 1, K 756 DO 230 I = 1, LASTC 757 C( I, LASTV-K+J ) = C( I, LASTV-K+J ) 758 $ - WORK( I, J ) 759 230 CONTINUE 760 240 CONTINUE 761* 762 END IF 763* 764 END IF 765 END IF 766* 767 RETURN 768* 769* End of CLARFB 770* 771 END 772