1: *> \brief \b DLARFB applies a block reflector or its transpose to a general rectangular matrix.
2: *
3: * =========== DOCUMENTATION ===========
4: *
5: * Online html documentation available at
6: * http://www.netlib.org/lapack/explore-html/
7: *
8: *> \htmlonly
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">
15: *> [TXT]</a>
16: *> \endhtmlonly
17: *
18: * Definition:
19: * ===========
20: *
21: * SUBROUTINE DLARFB( 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: * DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ),
30: * $ WORK( LDWORK, * )
31: * ..
32: *
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).
95: *> If SIDE = 'L', M >= K >= 0;
96: *> if SIDE = 'R', N >= K >= 0.
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: *
159: *> \author Univ. of Tennessee
160: *> \author Univ. of California Berkeley
161: *> \author Univ. of Colorado Denver
162: *> \author NAG Ltd.
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: * =====================================================================
195: SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
196: $ T, LDT, C, LDC, WORK, LDWORK )
197: *
198: * -- LAPACK auxiliary routine --
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
219: INTEGER I, J
220: * ..
221: * .. External Functions ..
222: LOGICAL LSAME
223: EXTERNAL LSAME
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: *
251: * Form H * C or H**T * C where C = ( C1 )
252: * ( C2 )
253: *
254: * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
255: *
256: * W := C1**T
257: *
258: DO 10 J = 1, K
259: CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
260: 10 CONTINUE
261: *
262: * W := W * V1
263: *
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 )
273: END IF
274: *
275: * W := W * T**T or W * T
276: *
277: CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
278: $ ONE, T, LDT, WORK, LDWORK )
279: *
280: * C := C - V * W**T
281: *
282: IF( M.GT.K ) THEN
283: *
284: * C2 := C2 - V2 * W**T
285: *
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 )
289: END IF
290: *
291: * W := W * V1**T
292: *
293: CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
294: $ ONE, V, LDV, WORK, LDWORK )
295: *
296: * C1 := C1 - W**T
297: *
298: DO 30 J = 1, K
299: DO 20 I = 1, N
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: *
306: * Form C * H or C * H**T where C = ( C1 C2 )
307: *
308: * W := C * V = (C1*V1 + C2*V2) (stored in WORK)
309: *
310: * W := C1
311: *
312: DO 40 J = 1, K
313: CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
314: 40 CONTINUE
315: *
316: * W := W * V1
317: *
318: CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
319: $ K, ONE, V, LDV, WORK, LDWORK )
320: IF( N.GT.K ) THEN
321: *
322: * W := W + C2 * V2
323: *
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 )
327: END IF
328: *
329: * W := W * T or W * T**T
330: *
331: CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
332: $ ONE, T, LDT, WORK, LDWORK )
333: *
334: * C := C - W * V**T
335: *
336: IF( N.GT.K ) THEN
337: *
338: * C2 := C2 - W * V2**T
339: *
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 )
343: END IF
344: *
345: * W := W * V1**T
346: *
347: CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
348: $ ONE, V, LDV, WORK, LDWORK )
349: *
350: * C1 := C1 - W
351: *
352: DO 60 J = 1, K
353: DO 50 I = 1, M
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: *
367: * Form H * C or H**T * C where C = ( C1 )
368: * ( C2 )
369: *
370: * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
371: *
372: * W := C2**T
373: *
374: DO 70 J = 1, K
375: CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
376: 70 CONTINUE
377: *
378: * W := W * V2
379: *
380: CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
381: $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
382: IF( M.GT.K ) THEN
383: *
384: * W := W + C1**T * V1
385: *
386: CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
387: $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
388: END IF
389: *
390: * W := W * T**T or W * T
391: *
392: CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
393: $ ONE, T, LDT, WORK, LDWORK )
394: *
395: * C := C - V * W**T
396: *
397: IF( M.GT.K ) THEN
398: *
399: * C1 := C1 - V1 * W**T
400: *
401: CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
402: $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
403: END IF
404: *
405: * W := W * V2**T
406: *
407: CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
408: $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
409: *
410: * C2 := C2 - W**T
411: *
412: DO 90 J = 1, K
413: DO 80 I = 1, N
414: C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
415: 80 CONTINUE
416: 90 CONTINUE
417: *
418: ELSE IF( LSAME( SIDE, 'R' ) ) THEN
419: *
420: * Form C * H or C * H**T where C = ( C1 C2 )
421: *
422: * W := C * V = (C1*V1 + C2*V2) (stored in WORK)
423: *
424: * W := C2
425: *
426: DO 100 J = 1, K
427: CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
428: 100 CONTINUE
429: *
430: * W := W * V2
431: *
432: CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
433: $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
434: IF( N.GT.K ) THEN
435: *
436: * W := W + C1 * V1
437: *
438: CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
439: $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
440: END IF
441: *
442: * W := W * T or W * T**T
443: *
444: CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
445: $ ONE, T, LDT, WORK, LDWORK )
446: *
447: * C := C - W * V**T
448: *
449: IF( N.GT.K ) THEN
450: *
451: * C1 := C1 - W * V1**T
452: *
453: CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
454: $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
455: END IF
456: *
457: * W := W * V2**T
458: *
459: CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
460: $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
461: *
462: * C2 := C2 - W
463: *
464: DO 120 J = 1, K
465: DO 110 I = 1, M
466: C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
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: *
481: * Form H * C or H**T * C where C = ( C1 )
482: * ( C2 )
483: *
484: * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
485: *
486: * W := C1**T
487: *
488: DO 130 J = 1, K
489: CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
490: 130 CONTINUE
491: *
492: * W := W * V1**T
493: *
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 )
503: END IF
504: *
505: * W := W * T**T or W * T
506: *
507: CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
508: $ ONE, T, LDT, WORK, LDWORK )
509: *
510: * C := C - V**T * W**T
511: *
512: IF( M.GT.K ) THEN
513: *
514: * C2 := C2 - V2**T * W**T
515: *
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 )
519: END IF
520: *
521: * W := W * V1
522: *
523: CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
524: $ K, ONE, V, LDV, WORK, LDWORK )
525: *
526: * C1 := C1 - W**T
527: *
528: DO 150 J = 1, K
529: DO 140 I = 1, N
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: *
536: * Form C * H or C * H**T where C = ( C1 C2 )
537: *
538: * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
539: *
540: * W := C1
541: *
542: DO 160 J = 1, K
543: CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
544: 160 CONTINUE
545: *
546: * W := W * V1**T
547: *
548: CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
549: $ ONE, V, LDV, WORK, LDWORK )
550: IF( N.GT.K ) THEN
551: *
552: * W := W + C2 * V2**T
553: *
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 )
557: END IF
558: *
559: * W := W * T or W * T**T
560: *
561: CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
562: $ ONE, T, LDT, WORK, LDWORK )
563: *
564: * C := C - W * V
565: *
566: IF( N.GT.K ) THEN
567: *
568: * C2 := C2 - W * V2
569: *
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 )
573: END IF
574: *
575: * W := W * V1
576: *
577: CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
578: $ K, ONE, V, LDV, WORK, LDWORK )
579: *
580: * C1 := C1 - W
581: *
582: DO 180 J = 1, K
583: DO 170 I = 1, M
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: *
597: * Form H * C or H**T * C where C = ( C1 )
598: * ( C2 )
599: *
600: * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
601: *
602: * W := C2**T
603: *
604: DO 190 J = 1, K
605: CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
606: 190 CONTINUE
607: *
608: * W := W * V2**T
609: *
610: CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
611: $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
612: IF( M.GT.K ) THEN
613: *
614: * W := W + C1**T * V1**T
615: *
616: CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
617: $ C, LDC, V, LDV, ONE, WORK, LDWORK )
618: END IF
619: *
620: * W := W * T**T or W * T
621: *
622: CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
623: $ ONE, T, LDT, WORK, LDWORK )
624: *
625: * C := C - V**T * W**T
626: *
627: IF( M.GT.K ) THEN
628: *
629: * C1 := C1 - V1**T * W**T
630: *
631: CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
632: $ V, LDV, WORK, LDWORK, ONE, C, LDC )
633: END IF
634: *
635: * W := W * V2
636: *
637: CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
638: $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
639: *
640: * C2 := C2 - W**T
641: *
642: DO 210 J = 1, K
643: DO 200 I = 1, N
644: C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
645: 200 CONTINUE
646: 210 CONTINUE
647: *
648: ELSE IF( LSAME( SIDE, 'R' ) ) THEN
649: *
650: * Form C * H or C * H' where C = ( C1 C2 )
651: *
652: * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
653: *
654: * W := C2
655: *
656: DO 220 J = 1, K
657: CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
658: 220 CONTINUE
659: *
660: * W := W * V2**T
661: *
662: CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
663: $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
664: IF( N.GT.K ) THEN
665: *
666: * W := W + C1 * V1**T
667: *
668: CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
669: $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
670: END IF
671: *
672: * W := W * T or W * T**T
673: *
674: CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
675: $ ONE, T, LDT, WORK, LDWORK )
676: *
677: * C := C - W * V
678: *
679: IF( N.GT.K ) THEN
680: *
681: * C1 := C1 - W * V1
682: *
683: CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K,
684: $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
685: END IF
686: *
687: * W := W * V2
688: *
689: CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
690: $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
691: *
692: * C1 := C1 - W
693: *
694: DO 240 J = 1, K
695: DO 230 I = 1, M
696: C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
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