Annotation of rpl/lapack/lapack/zlarfb.f, revision 1.1
1.1 ! bertrand 1: SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
! 2: $ T, LDT, C, LDC, WORK, LDWORK )
! 3: IMPLICIT NONE
! 4: *
! 5: * -- LAPACK auxiliary routine (version 3.2) --
! 6: * -- LAPACK is a software package provided by Univ. of Tennessee, --
! 7: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
! 8: * November 2006
! 9: *
! 10: * .. Scalar Arguments ..
! 11: CHARACTER DIRECT, SIDE, STOREV, TRANS
! 12: INTEGER K, LDC, LDT, LDV, LDWORK, M, N
! 13: * ..
! 14: * .. Array Arguments ..
! 15: COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ),
! 16: $ WORK( LDWORK, * )
! 17: * ..
! 18: *
! 19: * Purpose
! 20: * =======
! 21: *
! 22: * ZLARFB applies a complex block reflector H or its transpose H' to a
! 23: * complex M-by-N matrix C, from either the left or the right.
! 24: *
! 25: * Arguments
! 26: * =========
! 27: *
! 28: * SIDE (input) CHARACTER*1
! 29: * = 'L': apply H or H' from the Left
! 30: * = 'R': apply H or H' from the Right
! 31: *
! 32: * TRANS (input) CHARACTER*1
! 33: * = 'N': apply H (No transpose)
! 34: * = 'C': apply H' (Conjugate transpose)
! 35: *
! 36: * DIRECT (input) CHARACTER*1
! 37: * Indicates how H is formed from a product of elementary
! 38: * reflectors
! 39: * = 'F': H = H(1) H(2) . . . H(k) (Forward)
! 40: * = 'B': H = H(k) . . . H(2) H(1) (Backward)
! 41: *
! 42: * STOREV (input) CHARACTER*1
! 43: * Indicates how the vectors which define the elementary
! 44: * reflectors are stored:
! 45: * = 'C': Columnwise
! 46: * = 'R': Rowwise
! 47: *
! 48: * M (input) INTEGER
! 49: * The number of rows of the matrix C.
! 50: *
! 51: * N (input) INTEGER
! 52: * The number of columns of the matrix C.
! 53: *
! 54: * K (input) INTEGER
! 55: * The order of the matrix T (= the number of elementary
! 56: * reflectors whose product defines the block reflector).
! 57: *
! 58: * V (input) COMPLEX*16 array, dimension
! 59: * (LDV,K) if STOREV = 'C'
! 60: * (LDV,M) if STOREV = 'R' and SIDE = 'L'
! 61: * (LDV,N) if STOREV = 'R' and SIDE = 'R'
! 62: * The matrix V. See further details.
! 63: *
! 64: * LDV (input) INTEGER
! 65: * The leading dimension of the array V.
! 66: * If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
! 67: * if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
! 68: * if STOREV = 'R', LDV >= K.
! 69: *
! 70: * T (input) COMPLEX*16 array, dimension (LDT,K)
! 71: * The triangular K-by-K matrix T in the representation of the
! 72: * block reflector.
! 73: *
! 74: * LDT (input) INTEGER
! 75: * The leading dimension of the array T. LDT >= K.
! 76: *
! 77: * C (input/output) COMPLEX*16 array, dimension (LDC,N)
! 78: * On entry, the M-by-N matrix C.
! 79: * On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
! 80: *
! 81: * LDC (input) INTEGER
! 82: * The leading dimension of the array C. LDC >= max(1,M).
! 83: *
! 84: * WORK (workspace) COMPLEX*16 array, dimension (LDWORK,K)
! 85: *
! 86: * LDWORK (input) INTEGER
! 87: * The leading dimension of the array WORK.
! 88: * If SIDE = 'L', LDWORK >= max(1,N);
! 89: * if SIDE = 'R', LDWORK >= max(1,M).
! 90: *
! 91: * =====================================================================
! 92: *
! 93: * .. Parameters ..
! 94: COMPLEX*16 ONE
! 95: PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
! 96: * ..
! 97: * .. Local Scalars ..
! 98: CHARACTER TRANST
! 99: INTEGER I, J, LASTV, LASTC
! 100: * ..
! 101: * .. External Functions ..
! 102: LOGICAL LSAME
! 103: INTEGER ILAZLR, ILAZLC
! 104: EXTERNAL LSAME, ILAZLR, ILAZLC
! 105: * ..
! 106: * .. External Subroutines ..
! 107: EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM
! 108: * ..
! 109: * .. Intrinsic Functions ..
! 110: INTRINSIC DCONJG
! 111: * ..
! 112: * .. Executable Statements ..
! 113: *
! 114: * Quick return if possible
! 115: *
! 116: IF( M.LE.0 .OR. N.LE.0 )
! 117: $ RETURN
! 118: *
! 119: IF( LSAME( TRANS, 'N' ) ) THEN
! 120: TRANST = 'C'
! 121: ELSE
! 122: TRANST = 'N'
! 123: END IF
! 124: *
! 125: IF( LSAME( STOREV, 'C' ) ) THEN
! 126: *
! 127: IF( LSAME( DIRECT, 'F' ) ) THEN
! 128: *
! 129: * Let V = ( V1 ) (first K rows)
! 130: * ( V2 )
! 131: * where V1 is unit lower triangular.
! 132: *
! 133: IF( LSAME( SIDE, 'L' ) ) THEN
! 134: *
! 135: * Form H * C or H' * C where C = ( C1 )
! 136: * ( C2 )
! 137: *
! 138: LASTV = MAX( K, ILAZLR( M, K, V, LDV ) )
! 139: LASTC = ILAZLC( LASTV, N, C, LDC )
! 140: *
! 141: * W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK)
! 142: *
! 143: * W := C1'
! 144: *
! 145: DO 10 J = 1, K
! 146: CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
! 147: CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
! 148: 10 CONTINUE
! 149: *
! 150: * W := W * V1
! 151: *
! 152: CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
! 153: $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
! 154: IF( LASTV.GT.K ) THEN
! 155: *
! 156: * W := W + C2'*V2
! 157: *
! 158: CALL ZGEMM( 'Conjugate transpose', 'No transpose',
! 159: $ LASTC, K, LASTV-K, ONE, C( K+1, 1 ), LDC,
! 160: $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK )
! 161: END IF
! 162: *
! 163: * W := W * T' or W * T
! 164: *
! 165: CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
! 166: $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
! 167: *
! 168: * C := C - V * W'
! 169: *
! 170: IF( M.GT.K ) THEN
! 171: *
! 172: * C2 := C2 - V2 * W'
! 173: *
! 174: CALL ZGEMM( 'No transpose', 'Conjugate transpose',
! 175: $ LASTV-K, LASTC, K,
! 176: $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK,
! 177: $ ONE, C( K+1, 1 ), LDC )
! 178: END IF
! 179: *
! 180: * W := W * V1'
! 181: *
! 182: CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
! 183: $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
! 184: *
! 185: * C1 := C1 - W'
! 186: *
! 187: DO 30 J = 1, K
! 188: DO 20 I = 1, LASTC
! 189: C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
! 190: 20 CONTINUE
! 191: 30 CONTINUE
! 192: *
! 193: ELSE IF( LSAME( SIDE, 'R' ) ) THEN
! 194: *
! 195: * Form C * H or C * H' where C = ( C1 C2 )
! 196: *
! 197: LASTV = MAX( K, ILAZLR( N, K, V, LDV ) )
! 198: LASTC = ILAZLR( M, LASTV, C, LDC )
! 199: *
! 200: * W := C * V = (C1*V1 + C2*V2) (stored in WORK)
! 201: *
! 202: * W := C1
! 203: *
! 204: DO 40 J = 1, K
! 205: CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
! 206: 40 CONTINUE
! 207: *
! 208: * W := W * V1
! 209: *
! 210: CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
! 211: $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
! 212: IF( LASTV.GT.K ) THEN
! 213: *
! 214: * W := W + C2 * V2
! 215: *
! 216: CALL ZGEMM( 'No transpose', 'No transpose',
! 217: $ LASTC, K, LASTV-K,
! 218: $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
! 219: $ ONE, WORK, LDWORK )
! 220: END IF
! 221: *
! 222: * W := W * T or W * T'
! 223: *
! 224: CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
! 225: $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
! 226: *
! 227: * C := C - W * V'
! 228: *
! 229: IF( LASTV.GT.K ) THEN
! 230: *
! 231: * C2 := C2 - W * V2'
! 232: *
! 233: CALL ZGEMM( 'No transpose', 'Conjugate transpose',
! 234: $ LASTC, LASTV-K, K,
! 235: $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV,
! 236: $ ONE, C( 1, K+1 ), LDC )
! 237: END IF
! 238: *
! 239: * W := W * V1'
! 240: *
! 241: CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
! 242: $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
! 243: *
! 244: * C1 := C1 - W
! 245: *
! 246: DO 60 J = 1, K
! 247: DO 50 I = 1, LASTC
! 248: C( I, J ) = C( I, J ) - WORK( I, J )
! 249: 50 CONTINUE
! 250: 60 CONTINUE
! 251: END IF
! 252: *
! 253: ELSE
! 254: *
! 255: * Let V = ( V1 )
! 256: * ( V2 ) (last K rows)
! 257: * where V2 is unit upper triangular.
! 258: *
! 259: IF( LSAME( SIDE, 'L' ) ) THEN
! 260: *
! 261: * Form H * C or H' * C where C = ( C1 )
! 262: * ( C2 )
! 263: *
! 264: LASTV = MAX( K, ILAZLR( M, K, V, LDV ) )
! 265: LASTC = ILAZLC( LASTV, N, C, LDC )
! 266: *
! 267: * W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK)
! 268: *
! 269: * W := C2'
! 270: *
! 271: DO 70 J = 1, K
! 272: CALL ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
! 273: $ WORK( 1, J ), 1 )
! 274: CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
! 275: 70 CONTINUE
! 276: *
! 277: * W := W * V2
! 278: *
! 279: CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
! 280: $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
! 281: $ WORK, LDWORK )
! 282: IF( LASTV.GT.K ) THEN
! 283: *
! 284: * W := W + C1'*V1
! 285: *
! 286: CALL ZGEMM( 'Conjugate transpose', 'No transpose',
! 287: $ LASTC, K, LASTV-K,
! 288: $ ONE, C, LDC, V, LDV,
! 289: $ ONE, WORK, LDWORK )
! 290: END IF
! 291: *
! 292: * W := W * T' or W * T
! 293: *
! 294: CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
! 295: $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
! 296: *
! 297: * C := C - V * W'
! 298: *
! 299: IF( LASTV.GT.K ) THEN
! 300: *
! 301: * C1 := C1 - V1 * W'
! 302: *
! 303: CALL ZGEMM( 'No transpose', 'Conjugate transpose',
! 304: $ LASTV-K, LASTC, K,
! 305: $ -ONE, V, LDV, WORK, LDWORK,
! 306: $ ONE, C, LDC )
! 307: END IF
! 308: *
! 309: * W := W * V2'
! 310: *
! 311: CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
! 312: $ 'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
! 313: $ WORK, LDWORK )
! 314: *
! 315: * C2 := C2 - W'
! 316: *
! 317: DO 90 J = 1, K
! 318: DO 80 I = 1, LASTC
! 319: C( LASTV-K+J, I ) = C( LASTV-K+J, I ) -
! 320: $ DCONJG( WORK( I, J ) )
! 321: 80 CONTINUE
! 322: 90 CONTINUE
! 323: *
! 324: ELSE IF( LSAME( SIDE, 'R' ) ) THEN
! 325: *
! 326: * Form C * H or C * H' where C = ( C1 C2 )
! 327: *
! 328: LASTV = MAX( K, ILAZLR( N, K, V, LDV ) )
! 329: LASTC = ILAZLR( M, LASTV, C, LDC )
! 330: *
! 331: * W := C * V = (C1*V1 + C2*V2) (stored in WORK)
! 332: *
! 333: * W := C2
! 334: *
! 335: DO 100 J = 1, K
! 336: CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1,
! 337: $ WORK( 1, J ), 1 )
! 338: 100 CONTINUE
! 339: *
! 340: * W := W * V2
! 341: *
! 342: CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
! 343: $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
! 344: $ WORK, LDWORK )
! 345: IF( LASTV.GT.K ) THEN
! 346: *
! 347: * W := W + C1 * V1
! 348: *
! 349: CALL ZGEMM( 'No transpose', 'No transpose',
! 350: $ LASTC, K, LASTV-K,
! 351: $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
! 352: END IF
! 353: *
! 354: * W := W * T or W * T'
! 355: *
! 356: CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
! 357: $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
! 358: *
! 359: * C := C - W * V'
! 360: *
! 361: IF( LASTV.GT.K ) THEN
! 362: *
! 363: * C1 := C1 - W * V1'
! 364: *
! 365: CALL ZGEMM( 'No transpose', 'Conjugate transpose',
! 366: $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
! 367: $ ONE, C, LDC )
! 368: END IF
! 369: *
! 370: * W := W * V2'
! 371: *
! 372: CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
! 373: $ 'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
! 374: $ WORK, LDWORK )
! 375: *
! 376: * C2 := C2 - W
! 377: *
! 378: DO 120 J = 1, K
! 379: DO 110 I = 1, LASTC
! 380: C( I, LASTV-K+J ) = C( I, LASTV-K+J )
! 381: $ - WORK( I, J )
! 382: 110 CONTINUE
! 383: 120 CONTINUE
! 384: END IF
! 385: END IF
! 386: *
! 387: ELSE IF( LSAME( STOREV, 'R' ) ) THEN
! 388: *
! 389: IF( LSAME( DIRECT, 'F' ) ) THEN
! 390: *
! 391: * Let V = ( V1 V2 ) (V1: first K columns)
! 392: * where V1 is unit upper triangular.
! 393: *
! 394: IF( LSAME( SIDE, 'L' ) ) THEN
! 395: *
! 396: * Form H * C or H' * C where C = ( C1 )
! 397: * ( C2 )
! 398: *
! 399: LASTV = MAX( K, ILAZLC( K, M, V, LDV ) )
! 400: LASTC = ILAZLC( LASTV, N, C, LDC )
! 401: *
! 402: * W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK)
! 403: *
! 404: * W := C1'
! 405: *
! 406: DO 130 J = 1, K
! 407: CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
! 408: CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
! 409: 130 CONTINUE
! 410: *
! 411: * W := W * V1'
! 412: *
! 413: CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
! 414: $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
! 415: IF( LASTV.GT.K ) THEN
! 416: *
! 417: * W := W + C2'*V2'
! 418: *
! 419: CALL ZGEMM( 'Conjugate transpose',
! 420: $ 'Conjugate transpose', LASTC, K, LASTV-K,
! 421: $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV,
! 422: $ ONE, WORK, LDWORK )
! 423: END IF
! 424: *
! 425: * W := W * T' or W * T
! 426: *
! 427: CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
! 428: $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
! 429: *
! 430: * C := C - V' * W'
! 431: *
! 432: IF( LASTV.GT.K ) THEN
! 433: *
! 434: * C2 := C2 - V2' * W'
! 435: *
! 436: CALL ZGEMM( 'Conjugate transpose',
! 437: $ 'Conjugate transpose', LASTV-K, LASTC, K,
! 438: $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
! 439: $ ONE, C( K+1, 1 ), LDC )
! 440: END IF
! 441: *
! 442: * W := W * V1
! 443: *
! 444: CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
! 445: $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
! 446: *
! 447: * C1 := C1 - W'
! 448: *
! 449: DO 150 J = 1, K
! 450: DO 140 I = 1, LASTC
! 451: C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
! 452: 140 CONTINUE
! 453: 150 CONTINUE
! 454: *
! 455: ELSE IF( LSAME( SIDE, 'R' ) ) THEN
! 456: *
! 457: * Form C * H or C * H' where C = ( C1 C2 )
! 458: *
! 459: LASTV = MAX( K, ILAZLC( K, N, V, LDV ) )
! 460: LASTC = ILAZLR( M, LASTV, C, LDC )
! 461: *
! 462: * W := C * V' = (C1*V1' + C2*V2') (stored in WORK)
! 463: *
! 464: * W := C1
! 465: *
! 466: DO 160 J = 1, K
! 467: CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
! 468: 160 CONTINUE
! 469: *
! 470: * W := W * V1'
! 471: *
! 472: CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
! 473: $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
! 474: IF( LASTV.GT.K ) THEN
! 475: *
! 476: * W := W + C2 * V2'
! 477: *
! 478: CALL ZGEMM( 'No transpose', 'Conjugate transpose',
! 479: $ LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC,
! 480: $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK )
! 481: END IF
! 482: *
! 483: * W := W * T or W * T'
! 484: *
! 485: CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
! 486: $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
! 487: *
! 488: * C := C - W * V
! 489: *
! 490: IF( LASTV.GT.K ) THEN
! 491: *
! 492: * C2 := C2 - W * V2
! 493: *
! 494: CALL ZGEMM( 'No transpose', 'No transpose',
! 495: $ LASTC, LASTV-K, K,
! 496: $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
! 497: $ ONE, C( 1, K+1 ), LDC )
! 498: END IF
! 499: *
! 500: * W := W * V1
! 501: *
! 502: CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
! 503: $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
! 504: *
! 505: * C1 := C1 - W
! 506: *
! 507: DO 180 J = 1, K
! 508: DO 170 I = 1, LASTC
! 509: C( I, J ) = C( I, J ) - WORK( I, J )
! 510: 170 CONTINUE
! 511: 180 CONTINUE
! 512: *
! 513: END IF
! 514: *
! 515: ELSE
! 516: *
! 517: * Let V = ( V1 V2 ) (V2: last K columns)
! 518: * where V2 is unit lower triangular.
! 519: *
! 520: IF( LSAME( SIDE, 'L' ) ) THEN
! 521: *
! 522: * Form H * C or H' * C where C = ( C1 )
! 523: * ( C2 )
! 524: *
! 525: LASTV = MAX( K, ILAZLC( K, M, V, LDV ) )
! 526: LASTC = ILAZLC( LASTV, N, C, LDC )
! 527: *
! 528: * W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK)
! 529: *
! 530: * W := C2'
! 531: *
! 532: DO 190 J = 1, K
! 533: CALL ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
! 534: $ WORK( 1, J ), 1 )
! 535: CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
! 536: 190 CONTINUE
! 537: *
! 538: * W := W * V2'
! 539: *
! 540: CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
! 541: $ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
! 542: $ WORK, LDWORK )
! 543: IF( LASTV.GT.K ) THEN
! 544: *
! 545: * W := W + C1'*V1'
! 546: *
! 547: CALL ZGEMM( 'Conjugate transpose',
! 548: $ 'Conjugate transpose', LASTC, K, LASTV-K,
! 549: $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
! 550: END IF
! 551: *
! 552: * W := W * T' or W * T
! 553: *
! 554: CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
! 555: $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
! 556: *
! 557: * C := C - V' * W'
! 558: *
! 559: IF( LASTV.GT.K ) THEN
! 560: *
! 561: * C1 := C1 - V1' * W'
! 562: *
! 563: CALL ZGEMM( 'Conjugate transpose',
! 564: $ 'Conjugate transpose', LASTV-K, LASTC, K,
! 565: $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
! 566: END IF
! 567: *
! 568: * W := W * V2
! 569: *
! 570: CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
! 571: $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
! 572: $ WORK, LDWORK )
! 573: *
! 574: * C2 := C2 - W'
! 575: *
! 576: DO 210 J = 1, K
! 577: DO 200 I = 1, LASTC
! 578: C( LASTV-K+J, I ) = C( LASTV-K+J, I ) -
! 579: $ DCONJG( WORK( I, J ) )
! 580: 200 CONTINUE
! 581: 210 CONTINUE
! 582: *
! 583: ELSE IF( LSAME( SIDE, 'R' ) ) THEN
! 584: *
! 585: * Form C * H or C * H' where C = ( C1 C2 )
! 586: *
! 587: LASTV = MAX( K, ILAZLC( K, N, V, LDV ) )
! 588: LASTC = ILAZLR( M, LASTV, C, LDC )
! 589: *
! 590: * W := C * V' = (C1*V1' + C2*V2') (stored in WORK)
! 591: *
! 592: * W := C2
! 593: *
! 594: DO 220 J = 1, K
! 595: CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1,
! 596: $ WORK( 1, J ), 1 )
! 597: 220 CONTINUE
! 598: *
! 599: * W := W * V2'
! 600: *
! 601: CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
! 602: $ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
! 603: $ WORK, LDWORK )
! 604: IF( LASTV.GT.K ) THEN
! 605: *
! 606: * W := W + C1 * V1'
! 607: *
! 608: CALL ZGEMM( 'No transpose', 'Conjugate transpose',
! 609: $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, ONE,
! 610: $ WORK, LDWORK )
! 611: END IF
! 612: *
! 613: * W := W * T or W * T'
! 614: *
! 615: CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
! 616: $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
! 617: *
! 618: * C := C - W * V
! 619: *
! 620: IF( LASTV.GT.K ) THEN
! 621: *
! 622: * C1 := C1 - W * V1
! 623: *
! 624: CALL ZGEMM( 'No transpose', 'No transpose',
! 625: $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
! 626: $ ONE, C, LDC )
! 627: END IF
! 628: *
! 629: * W := W * V2
! 630: *
! 631: CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
! 632: $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
! 633: $ WORK, LDWORK )
! 634: *
! 635: * C1 := C1 - W
! 636: *
! 637: DO 240 J = 1, K
! 638: DO 230 I = 1, LASTC
! 639: C( I, LASTV-K+J ) = C( I, LASTV-K+J )
! 640: $ - WORK( I, J )
! 641: 230 CONTINUE
! 642: 240 CONTINUE
! 643: *
! 644: END IF
! 645: *
! 646: END IF
! 647: END IF
! 648: *
! 649: RETURN
! 650: *
! 651: * End of ZLARFB
! 652: *
! 653: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to zlarfb.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack