Annotation of rpl/lapack/lapack/dlarfb.f, revision 1.21
1.12 bertrand 1: *> \brief \b DLARFB applies a block reflector or its transpose to a general rectangular matrix.
1.9 bertrand 2: *
3: * =========== DOCUMENTATION ===========
4: *
1.17 bertrand 5: * Online html documentation available at
6: * http://www.netlib.org/lapack/explore-html/
1.9 bertrand 7: *
8: *> \htmlonly
1.17 bertrand 9: *> Download DLARFB + dependencies
10: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlarfb.f">
11: *> [TGZ]</a>
12: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlarfb.f">
13: *> [ZIP]</a>
14: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlarfb.f">
1.9 bertrand 15: *> [TXT]</a>
1.17 bertrand 16: *> \endhtmlonly
1.9 bertrand 17: *
18: * Definition:
19: * ===========
20: *
21: * SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
22: * T, LDT, C, LDC, WORK, LDWORK )
1.17 bertrand 23: *
1.9 bertrand 24: * .. Scalar Arguments ..
25: * CHARACTER DIRECT, SIDE, STOREV, TRANS
26: * INTEGER K, LDC, LDT, LDV, LDWORK, M, N
27: * ..
28: * .. Array Arguments ..
29: * DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ),
30: * $ WORK( LDWORK, * )
31: * ..
1.17 bertrand 32: *
1.9 bertrand 33: *
34: *> \par Purpose:
35: * =============
36: *>
37: *> \verbatim
38: *>
39: *> DLARFB applies a real block reflector H or its transpose H**T to a
40: *> real 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**T from the Left
50: *> = 'R': apply H or H**T from the Right
51: *> \endverbatim
52: *>
53: *> \param[in] TRANS
54: *> \verbatim
55: *> TRANS is CHARACTER*1
56: *> = 'N': apply H (No transpose)
57: *> = 'T': apply H**T (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).
1.20 bertrand 95: *> If SIDE = 'L', M >= K >= 0;
96: *> if SIDE = 'R', N >= K >= 0.
1.9 bertrand 97: *> \endverbatim
98: *>
99: *> \param[in] V
100: *> \verbatim
101: *> V is DOUBLE PRECISION array, dimension
102: *> (LDV,K) if STOREV = 'C'
103: *> (LDV,M) if STOREV = 'R' and SIDE = 'L'
104: *> (LDV,N) if STOREV = 'R' and SIDE = 'R'
105: *> The matrix V. See Further Details.
106: *> \endverbatim
107: *>
108: *> \param[in] LDV
109: *> \verbatim
110: *> LDV is INTEGER
111: *> The leading dimension of the array V.
112: *> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
113: *> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
114: *> if STOREV = 'R', LDV >= K.
115: *> \endverbatim
116: *>
117: *> \param[in] T
118: *> \verbatim
119: *> T is DOUBLE PRECISION array, dimension (LDT,K)
120: *> The triangular k by k matrix T in the representation of the
121: *> block reflector.
122: *> \endverbatim
123: *>
124: *> \param[in] LDT
125: *> \verbatim
126: *> LDT is INTEGER
127: *> The leading dimension of the array T. LDT >= K.
128: *> \endverbatim
129: *>
130: *> \param[in,out] C
131: *> \verbatim
132: *> C is DOUBLE PRECISION array, dimension (LDC,N)
133: *> On entry, the m by n matrix C.
134: *> On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T.
135: *> \endverbatim
136: *>
137: *> \param[in] LDC
138: *> \verbatim
139: *> LDC is INTEGER
140: *> The leading dimension of the array C. LDC >= max(1,M).
141: *> \endverbatim
142: *>
143: *> \param[out] WORK
144: *> \verbatim
145: *> WORK is DOUBLE PRECISION array, dimension (LDWORK,K)
146: *> \endverbatim
147: *>
148: *> \param[in] LDWORK
149: *> \verbatim
150: *> LDWORK is INTEGER
151: *> The leading dimension of the array WORK.
152: *> If SIDE = 'L', LDWORK >= max(1,N);
153: *> if SIDE = 'R', LDWORK >= max(1,M).
154: *> \endverbatim
155: *
156: * Authors:
157: * ========
158: *
1.17 bertrand 159: *> \author Univ. of Tennessee
160: *> \author Univ. of California Berkeley
161: *> \author Univ. of Colorado Denver
162: *> \author NAG Ltd.
1.9 bertrand 163: *
164: *> \ingroup doubleOTHERauxiliary
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: * =====================================================================
1.1 bertrand 195: SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
196: $ T, LDT, C, LDC, WORK, LDWORK )
197: *
1.21 ! bertrand 198: * -- LAPACK auxiliary routine --
1.1 bertrand 199: * -- LAPACK is a software package provided by Univ. of Tennessee, --
200: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
201: *
202: * .. Scalar Arguments ..
203: CHARACTER DIRECT, SIDE, STOREV, TRANS
204: INTEGER K, LDC, LDT, LDV, LDWORK, M, N
205: * ..
206: * .. Array Arguments ..
207: DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ),
208: $ WORK( LDWORK, * )
209: * ..
210: *
211: * =====================================================================
212: *
213: * .. Parameters ..
214: DOUBLE PRECISION ONE
215: PARAMETER ( ONE = 1.0D+0 )
216: * ..
217: * .. Local Scalars ..
218: CHARACTER TRANST
1.14 bertrand 219: INTEGER I, J
1.1 bertrand 220: * ..
221: * .. External Functions ..
222: LOGICAL LSAME
1.14 bertrand 223: EXTERNAL LSAME
1.1 bertrand 224: * ..
225: * .. External Subroutines ..
226: EXTERNAL DCOPY, DGEMM, DTRMM
227: * ..
228: * .. Executable Statements ..
229: *
230: * Quick return if possible
231: *
232: IF( M.LE.0 .OR. N.LE.0 )
233: $ RETURN
234: *
235: IF( LSAME( TRANS, 'N' ) ) THEN
236: TRANST = 'T'
237: ELSE
238: TRANST = 'N'
239: END IF
240: *
241: IF( LSAME( STOREV, 'C' ) ) THEN
242: *
243: IF( LSAME( DIRECT, 'F' ) ) THEN
244: *
245: * Let V = ( V1 ) (first K rows)
246: * ( V2 )
247: * where V1 is unit lower triangular.
248: *
249: IF( LSAME( SIDE, 'L' ) ) THEN
250: *
1.8 bertrand 251: * Form H * C or H**T * C where C = ( C1 )
252: * ( C2 )
1.1 bertrand 253: *
1.8 bertrand 254: * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
1.1 bertrand 255: *
1.8 bertrand 256: * W := C1**T
1.1 bertrand 257: *
258: DO 10 J = 1, K
1.14 bertrand 259: CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
1.1 bertrand 260: 10 CONTINUE
261: *
262: * W := W * V1
263: *
1.14 bertrand 264: CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
265: $ K, ONE, V, LDV, WORK, LDWORK )
266: IF( M.GT.K ) THEN
267: *
268: * W := W + C2**T * V2
269: *
270: CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
271: $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
272: $ ONE, WORK, LDWORK )
1.1 bertrand 273: END IF
274: *
1.8 bertrand 275: * W := W * T**T or W * T
1.1 bertrand 276: *
1.14 bertrand 277: CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
278: $ ONE, T, LDT, WORK, LDWORK )
1.1 bertrand 279: *
1.8 bertrand 280: * C := C - V * W**T
1.1 bertrand 281: *
1.14 bertrand 282: IF( M.GT.K ) THEN
1.1 bertrand 283: *
1.8 bertrand 284: * C2 := C2 - V2 * W**T
1.1 bertrand 285: *
1.14 bertrand 286: CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
287: $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
288: $ C( K+1, 1 ), LDC )
1.1 bertrand 289: END IF
290: *
1.8 bertrand 291: * W := W * V1**T
1.1 bertrand 292: *
1.14 bertrand 293: CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
294: $ ONE, V, LDV, WORK, LDWORK )
1.1 bertrand 295: *
1.8 bertrand 296: * C1 := C1 - W**T
1.1 bertrand 297: *
298: DO 30 J = 1, K
1.14 bertrand 299: DO 20 I = 1, N
1.1 bertrand 300: C( J, I ) = C( J, I ) - WORK( I, J )
301: 20 CONTINUE
302: 30 CONTINUE
303: *
304: ELSE IF( LSAME( SIDE, 'R' ) ) THEN
305: *
1.8 bertrand 306: * Form C * H or C * H**T where C = ( C1 C2 )
1.1 bertrand 307: *
308: * W := C * V = (C1*V1 + C2*V2) (stored in WORK)
309: *
310: * W := C1
311: *
312: DO 40 J = 1, K
1.14 bertrand 313: CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
1.1 bertrand 314: 40 CONTINUE
315: *
316: * W := W * V1
317: *
1.14 bertrand 318: CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
319: $ K, ONE, V, LDV, WORK, LDWORK )
320: IF( N.GT.K ) THEN
1.1 bertrand 321: *
322: * W := W + C2 * V2
323: *
1.14 bertrand 324: CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
325: $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
326: $ ONE, WORK, LDWORK )
1.1 bertrand 327: END IF
328: *
1.8 bertrand 329: * W := W * T or W * T**T
1.1 bertrand 330: *
1.14 bertrand 331: CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
332: $ ONE, T, LDT, WORK, LDWORK )
1.1 bertrand 333: *
1.8 bertrand 334: * C := C - W * V**T
1.1 bertrand 335: *
1.14 bertrand 336: IF( N.GT.K ) THEN
1.1 bertrand 337: *
1.8 bertrand 338: * C2 := C2 - W * V2**T
1.1 bertrand 339: *
1.14 bertrand 340: CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
341: $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
342: $ C( 1, K+1 ), LDC )
1.1 bertrand 343: END IF
344: *
1.8 bertrand 345: * W := W * V1**T
1.1 bertrand 346: *
1.14 bertrand 347: CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
348: $ ONE, V, LDV, WORK, LDWORK )
1.1 bertrand 349: *
350: * C1 := C1 - W
351: *
352: DO 60 J = 1, K
1.14 bertrand 353: DO 50 I = 1, M
1.1 bertrand 354: C( I, J ) = C( I, J ) - WORK( I, J )
355: 50 CONTINUE
356: 60 CONTINUE
357: END IF
358: *
359: ELSE
360: *
361: * Let V = ( V1 )
362: * ( V2 ) (last K rows)
363: * where V2 is unit upper triangular.
364: *
365: IF( LSAME( SIDE, 'L' ) ) THEN
366: *
1.8 bertrand 367: * Form H * C or H**T * C where C = ( C1 )
368: * ( C2 )
1.1 bertrand 369: *
1.8 bertrand 370: * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
1.1 bertrand 371: *
1.8 bertrand 372: * W := C2**T
1.1 bertrand 373: *
374: DO 70 J = 1, K
1.14 bertrand 375: CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
1.1 bertrand 376: 70 CONTINUE
377: *
378: * W := W * V2
379: *
1.14 bertrand 380: CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
381: $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
1.12 bertrand 382: IF( M.GT.K ) THEN
1.1 bertrand 383: *
1.14 bertrand 384: * W := W + C1**T * V1
1.1 bertrand 385: *
1.14 bertrand 386: CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
387: $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
1.1 bertrand 388: END IF
389: *
1.8 bertrand 390: * W := W * T**T or W * T
1.1 bertrand 391: *
1.14 bertrand 392: CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
393: $ ONE, T, LDT, WORK, LDWORK )
1.1 bertrand 394: *
1.8 bertrand 395: * C := C - V * W**T
1.1 bertrand 396: *
1.12 bertrand 397: IF( M.GT.K ) THEN
1.1 bertrand 398: *
1.8 bertrand 399: * C1 := C1 - V1 * W**T
1.1 bertrand 400: *
1.14 bertrand 401: CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
402: $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
1.1 bertrand 403: END IF
404: *
1.8 bertrand 405: * W := W * V2**T
1.1 bertrand 406: *
1.14 bertrand 407: CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
408: $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
1.1 bertrand 409: *
1.8 bertrand 410: * C2 := C2 - W**T
1.1 bertrand 411: *
412: DO 90 J = 1, K
1.14 bertrand 413: DO 80 I = 1, N
414: C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
1.1 bertrand 415: 80 CONTINUE
416: 90 CONTINUE
417: *
418: ELSE IF( LSAME( SIDE, 'R' ) ) THEN
419: *
1.8 bertrand 420: * Form C * H or C * H**T where C = ( C1 C2 )
1.1 bertrand 421: *
422: * W := C * V = (C1*V1 + C2*V2) (stored in WORK)
423: *
424: * W := C2
425: *
426: DO 100 J = 1, K
1.14 bertrand 427: CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
1.1 bertrand 428: 100 CONTINUE
429: *
430: * W := W * V2
431: *
1.14 bertrand 432: CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
433: $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
1.12 bertrand 434: IF( N.GT.K ) THEN
1.1 bertrand 435: *
436: * W := W + C1 * V1
437: *
1.14 bertrand 438: CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
439: $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
1.1 bertrand 440: END IF
441: *
1.8 bertrand 442: * W := W * T or W * T**T
1.1 bertrand 443: *
1.14 bertrand 444: CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
445: $ ONE, T, LDT, WORK, LDWORK )
1.1 bertrand 446: *
1.8 bertrand 447: * C := C - W * V**T
1.1 bertrand 448: *
1.12 bertrand 449: IF( N.GT.K ) THEN
1.1 bertrand 450: *
1.8 bertrand 451: * C1 := C1 - W * V1**T
1.1 bertrand 452: *
1.14 bertrand 453: CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
454: $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
1.1 bertrand 455: END IF
456: *
1.8 bertrand 457: * W := W * V2**T
1.1 bertrand 458: *
1.14 bertrand 459: CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
460: $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
1.1 bertrand 461: *
462: * C2 := C2 - W
463: *
464: DO 120 J = 1, K
1.14 bertrand 465: DO 110 I = 1, M
466: C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
1.1 bertrand 467: 110 CONTINUE
468: 120 CONTINUE
469: END IF
470: END IF
471: *
472: ELSE IF( LSAME( STOREV, 'R' ) ) THEN
473: *
474: IF( LSAME( DIRECT, 'F' ) ) THEN
475: *
476: * Let V = ( V1 V2 ) (V1: first K columns)
477: * where V1 is unit upper triangular.
478: *
479: IF( LSAME( SIDE, 'L' ) ) THEN
480: *
1.8 bertrand 481: * Form H * C or H**T * C where C = ( C1 )
482: * ( C2 )
1.1 bertrand 483: *
1.8 bertrand 484: * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
1.1 bertrand 485: *
1.8 bertrand 486: * W := C1**T
1.1 bertrand 487: *
488: DO 130 J = 1, K
1.14 bertrand 489: CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
1.1 bertrand 490: 130 CONTINUE
491: *
1.8 bertrand 492: * W := W * V1**T
1.1 bertrand 493: *
1.14 bertrand 494: CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
495: $ ONE, V, LDV, WORK, LDWORK )
496: IF( M.GT.K ) THEN
497: *
498: * W := W + C2**T * V2**T
499: *
500: CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
501: $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
502: $ WORK, LDWORK )
1.1 bertrand 503: END IF
504: *
1.8 bertrand 505: * W := W * T**T or W * T
1.1 bertrand 506: *
1.14 bertrand 507: CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
508: $ ONE, T, LDT, WORK, LDWORK )
1.1 bertrand 509: *
1.8 bertrand 510: * C := C - V**T * W**T
1.1 bertrand 511: *
1.14 bertrand 512: IF( M.GT.K ) THEN
1.1 bertrand 513: *
1.8 bertrand 514: * C2 := C2 - V2**T * W**T
1.1 bertrand 515: *
1.14 bertrand 516: CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
517: $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
518: $ C( K+1, 1 ), LDC )
1.1 bertrand 519: END IF
520: *
521: * W := W * V1
522: *
1.14 bertrand 523: CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
524: $ K, ONE, V, LDV, WORK, LDWORK )
1.1 bertrand 525: *
1.8 bertrand 526: * C1 := C1 - W**T
1.1 bertrand 527: *
528: DO 150 J = 1, K
1.14 bertrand 529: DO 140 I = 1, N
1.1 bertrand 530: C( J, I ) = C( J, I ) - WORK( I, J )
531: 140 CONTINUE
532: 150 CONTINUE
533: *
534: ELSE IF( LSAME( SIDE, 'R' ) ) THEN
535: *
1.8 bertrand 536: * Form C * H or C * H**T where C = ( C1 C2 )
1.1 bertrand 537: *
1.8 bertrand 538: * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
1.1 bertrand 539: *
540: * W := C1
541: *
542: DO 160 J = 1, K
1.14 bertrand 543: CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
1.1 bertrand 544: 160 CONTINUE
545: *
1.8 bertrand 546: * W := W * V1**T
1.1 bertrand 547: *
1.14 bertrand 548: CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
549: $ ONE, V, LDV, WORK, LDWORK )
550: IF( N.GT.K ) THEN
1.1 bertrand 551: *
1.8 bertrand 552: * W := W + C2 * V2**T
1.1 bertrand 553: *
1.14 bertrand 554: CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
555: $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
556: $ ONE, WORK, LDWORK )
1.1 bertrand 557: END IF
558: *
1.8 bertrand 559: * W := W * T or W * T**T
1.1 bertrand 560: *
1.14 bertrand 561: CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
562: $ ONE, T, LDT, WORK, LDWORK )
1.1 bertrand 563: *
564: * C := C - W * V
565: *
1.14 bertrand 566: IF( N.GT.K ) THEN
1.1 bertrand 567: *
568: * C2 := C2 - W * V2
569: *
1.14 bertrand 570: CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K,
571: $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
572: $ C( 1, K+1 ), LDC )
1.1 bertrand 573: END IF
574: *
575: * W := W * V1
576: *
1.14 bertrand 577: CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
578: $ K, ONE, V, LDV, WORK, LDWORK )
1.1 bertrand 579: *
580: * C1 := C1 - W
581: *
582: DO 180 J = 1, K
1.14 bertrand 583: DO 170 I = 1, M
1.1 bertrand 584: C( I, J ) = C( I, J ) - WORK( I, J )
585: 170 CONTINUE
586: 180 CONTINUE
587: *
588: END IF
589: *
590: ELSE
591: *
592: * Let V = ( V1 V2 ) (V2: last K columns)
593: * where V2 is unit lower triangular.
594: *
595: IF( LSAME( SIDE, 'L' ) ) THEN
596: *
1.8 bertrand 597: * Form H * C or H**T * C where C = ( C1 )
598: * ( C2 )
1.1 bertrand 599: *
1.8 bertrand 600: * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
1.1 bertrand 601: *
1.8 bertrand 602: * W := C2**T
1.1 bertrand 603: *
604: DO 190 J = 1, K
1.14 bertrand 605: CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
1.1 bertrand 606: 190 CONTINUE
607: *
1.8 bertrand 608: * W := W * V2**T
1.1 bertrand 609: *
1.14 bertrand 610: CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
611: $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
1.12 bertrand 612: IF( M.GT.K ) THEN
1.1 bertrand 613: *
1.8 bertrand 614: * W := W + C1**T * V1**T
1.1 bertrand 615: *
1.14 bertrand 616: CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
617: $ C, LDC, V, LDV, ONE, WORK, LDWORK )
1.1 bertrand 618: END IF
619: *
1.8 bertrand 620: * W := W * T**T or W * T
1.1 bertrand 621: *
1.14 bertrand 622: CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
623: $ ONE, T, LDT, WORK, LDWORK )
1.1 bertrand 624: *
1.8 bertrand 625: * C := C - V**T * W**T
1.1 bertrand 626: *
1.12 bertrand 627: IF( M.GT.K ) THEN
1.1 bertrand 628: *
1.8 bertrand 629: * C1 := C1 - V1**T * W**T
1.1 bertrand 630: *
1.14 bertrand 631: CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
632: $ V, LDV, WORK, LDWORK, ONE, C, LDC )
1.1 bertrand 633: END IF
634: *
635: * W := W * V2
636: *
1.14 bertrand 637: CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
638: $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
1.1 bertrand 639: *
1.8 bertrand 640: * C2 := C2 - W**T
1.1 bertrand 641: *
642: DO 210 J = 1, K
1.14 bertrand 643: DO 200 I = 1, N
644: C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
1.1 bertrand 645: 200 CONTINUE
646: 210 CONTINUE
647: *
648: ELSE IF( LSAME( SIDE, 'R' ) ) THEN
649: *
1.14 bertrand 650: * Form C * H or C * H' where C = ( C1 C2 )
1.1 bertrand 651: *
1.8 bertrand 652: * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
1.1 bertrand 653: *
654: * W := C2
655: *
656: DO 220 J = 1, K
1.14 bertrand 657: CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
1.1 bertrand 658: 220 CONTINUE
659: *
1.8 bertrand 660: * W := W * V2**T
1.1 bertrand 661: *
1.14 bertrand 662: CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
663: $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
1.12 bertrand 664: IF( N.GT.K ) THEN
1.1 bertrand 665: *
1.8 bertrand 666: * W := W + C1 * V1**T
1.1 bertrand 667: *
1.14 bertrand 668: CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
669: $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
1.1 bertrand 670: END IF
671: *
1.8 bertrand 672: * W := W * T or W * T**T
1.1 bertrand 673: *
1.14 bertrand 674: CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
675: $ ONE, T, LDT, WORK, LDWORK )
1.1 bertrand 676: *
677: * C := C - W * V
678: *
1.12 bertrand 679: IF( N.GT.K ) THEN
1.1 bertrand 680: *
681: * C1 := C1 - W * V1
682: *
1.14 bertrand 683: CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K,
684: $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
1.1 bertrand 685: END IF
686: *
687: * W := W * V2
688: *
1.14 bertrand 689: CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
690: $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
1.1 bertrand 691: *
692: * C1 := C1 - W
693: *
694: DO 240 J = 1, K
1.14 bertrand 695: DO 230 I = 1, M
696: C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
1.1 bertrand 697: 230 CONTINUE
698: 240 CONTINUE
699: *
700: END IF
701: *
702: END IF
703: END IF
704: *
705: RETURN
706: *
707: * End of DLARFB
708: *
709: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to dlarfb.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack