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: *> \endverbatim
96: *>
97: *> \param[in] V
98: *> \verbatim
99: *> V is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDC,N)
131: *> On entry, the m by n matrix C.
132: *> On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T.
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 DOUBLE PRECISION 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 June 2013
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 (version 3.7.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: * June 2013
202: *
203: * .. Scalar Arguments ..
204: CHARACTER DIRECT, SIDE, STOREV, TRANS
205: INTEGER K, LDC, LDT, LDV, LDWORK, M, N
206: * ..
207: * .. Array Arguments ..
208: DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ),
209: $ WORK( LDWORK, * )
210: * ..
211: *
212: * =====================================================================
213: *
214: * .. Parameters ..
215: DOUBLE PRECISION ONE
216: PARAMETER ( ONE = 1.0D+0 )
217: * ..
218: * .. Local Scalars ..
219: CHARACTER TRANST
220: INTEGER I, J
221: * ..
222: * .. External Functions ..
223: LOGICAL LSAME
224: EXTERNAL LSAME
225: * ..
226: * .. External Subroutines ..
227: EXTERNAL DCOPY, DGEMM, DTRMM
228: * ..
229: * .. Executable Statements ..
230: *
231: * Quick return if possible
232: *
233: IF( M.LE.0 .OR. N.LE.0 )
234: $ RETURN
235: *
236: IF( LSAME( TRANS, 'N' ) ) THEN
237: TRANST = 'T'
238: ELSE
239: TRANST = 'N'
240: END IF
241: *
242: IF( LSAME( STOREV, 'C' ) ) THEN
243: *
244: IF( LSAME( DIRECT, 'F' ) ) THEN
245: *
246: * Let V = ( V1 ) (first K rows)
247: * ( V2 )
248: * where V1 is unit lower triangular.
249: *
250: IF( LSAME( SIDE, 'L' ) ) THEN
251: *
252: * Form H * C or H**T * C where C = ( C1 )
253: * ( C2 )
254: *
255: * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
256: *
257: * W := C1**T
258: *
259: DO 10 J = 1, K
260: CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
261: 10 CONTINUE
262: *
263: * W := W * V1
264: *
265: CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
266: $ K, ONE, V, LDV, WORK, LDWORK )
267: IF( M.GT.K ) THEN
268: *
269: * W := W + C2**T * V2
270: *
271: CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
272: $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
273: $ ONE, WORK, LDWORK )
274: END IF
275: *
276: * W := W * T**T or W * T
277: *
278: CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
279: $ ONE, T, LDT, WORK, LDWORK )
280: *
281: * C := C - V * W**T
282: *
283: IF( M.GT.K ) THEN
284: *
285: * C2 := C2 - V2 * W**T
286: *
287: CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
288: $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
289: $ C( K+1, 1 ), LDC )
290: END IF
291: *
292: * W := W * V1**T
293: *
294: CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
295: $ ONE, V, LDV, WORK, LDWORK )
296: *
297: * C1 := C1 - W**T
298: *
299: DO 30 J = 1, K
300: DO 20 I = 1, N
301: C( J, I ) = C( J, I ) - WORK( I, J )
302: 20 CONTINUE
303: 30 CONTINUE
304: *
305: ELSE IF( LSAME( SIDE, 'R' ) ) THEN
306: *
307: * Form C * H or C * H**T where C = ( C1 C2 )
308: *
309: * W := C * V = (C1*V1 + C2*V2) (stored in WORK)
310: *
311: * W := C1
312: *
313: DO 40 J = 1, K
314: CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
315: 40 CONTINUE
316: *
317: * W := W * V1
318: *
319: CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
320: $ K, ONE, V, LDV, WORK, LDWORK )
321: IF( N.GT.K ) THEN
322: *
323: * W := W + C2 * V2
324: *
325: CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
326: $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
327: $ ONE, WORK, LDWORK )
328: END IF
329: *
330: * W := W * T or W * T**T
331: *
332: CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
333: $ ONE, T, LDT, WORK, LDWORK )
334: *
335: * C := C - W * V**T
336: *
337: IF( N.GT.K ) THEN
338: *
339: * C2 := C2 - W * V2**T
340: *
341: CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
342: $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
343: $ C( 1, K+1 ), LDC )
344: END IF
345: *
346: * W := W * V1**T
347: *
348: CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
349: $ ONE, V, LDV, WORK, LDWORK )
350: *
351: * C1 := C1 - W
352: *
353: DO 60 J = 1, K
354: DO 50 I = 1, M
355: C( I, J ) = C( I, J ) - WORK( I, J )
356: 50 CONTINUE
357: 60 CONTINUE
358: END IF
359: *
360: ELSE
361: *
362: * Let V = ( V1 )
363: * ( V2 ) (last K rows)
364: * where V2 is unit upper triangular.
365: *
366: IF( LSAME( SIDE, 'L' ) ) THEN
367: *
368: * Form H * C or H**T * C where C = ( C1 )
369: * ( C2 )
370: *
371: * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
372: *
373: * W := C2**T
374: *
375: DO 70 J = 1, K
376: CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
377: 70 CONTINUE
378: *
379: * W := W * V2
380: *
381: CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
382: $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
383: IF( M.GT.K ) THEN
384: *
385: * W := W + C1**T * V1
386: *
387: CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
388: $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
389: END IF
390: *
391: * W := W * T**T or W * T
392: *
393: CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
394: $ ONE, T, LDT, WORK, LDWORK )
395: *
396: * C := C - V * W**T
397: *
398: IF( M.GT.K ) THEN
399: *
400: * C1 := C1 - V1 * W**T
401: *
402: CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
403: $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
404: END IF
405: *
406: * W := W * V2**T
407: *
408: CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
409: $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
410: *
411: * C2 := C2 - W**T
412: *
413: DO 90 J = 1, K
414: DO 80 I = 1, N
415: C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
416: 80 CONTINUE
417: 90 CONTINUE
418: *
419: ELSE IF( LSAME( SIDE, 'R' ) ) THEN
420: *
421: * Form C * H or C * H**T where C = ( C1 C2 )
422: *
423: * W := C * V = (C1*V1 + C2*V2) (stored in WORK)
424: *
425: * W := C2
426: *
427: DO 100 J = 1, K
428: CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
429: 100 CONTINUE
430: *
431: * W := W * V2
432: *
433: CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
434: $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
435: IF( N.GT.K ) THEN
436: *
437: * W := W + C1 * V1
438: *
439: CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
440: $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
441: END IF
442: *
443: * W := W * T or W * T**T
444: *
445: CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
446: $ ONE, T, LDT, WORK, LDWORK )
447: *
448: * C := C - W * V**T
449: *
450: IF( N.GT.K ) THEN
451: *
452: * C1 := C1 - W * V1**T
453: *
454: CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
455: $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
456: END IF
457: *
458: * W := W * V2**T
459: *
460: CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
461: $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
462: *
463: * C2 := C2 - W
464: *
465: DO 120 J = 1, K
466: DO 110 I = 1, M
467: C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
468: 110 CONTINUE
469: 120 CONTINUE
470: END IF
471: END IF
472: *
473: ELSE IF( LSAME( STOREV, 'R' ) ) THEN
474: *
475: IF( LSAME( DIRECT, 'F' ) ) THEN
476: *
477: * Let V = ( V1 V2 ) (V1: first K columns)
478: * where V1 is unit upper triangular.
479: *
480: IF( LSAME( SIDE, 'L' ) ) THEN
481: *
482: * Form H * C or H**T * C where C = ( C1 )
483: * ( C2 )
484: *
485: * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
486: *
487: * W := C1**T
488: *
489: DO 130 J = 1, K
490: CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
491: 130 CONTINUE
492: *
493: * W := W * V1**T
494: *
495: CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
496: $ ONE, V, LDV, WORK, LDWORK )
497: IF( M.GT.K ) THEN
498: *
499: * W := W + C2**T * V2**T
500: *
501: CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
502: $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
503: $ WORK, LDWORK )
504: END IF
505: *
506: * W := W * T**T or W * T
507: *
508: CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
509: $ ONE, T, LDT, WORK, LDWORK )
510: *
511: * C := C - V**T * W**T
512: *
513: IF( M.GT.K ) THEN
514: *
515: * C2 := C2 - V2**T * W**T
516: *
517: CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
518: $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
519: $ C( K+1, 1 ), LDC )
520: END IF
521: *
522: * W := W * V1
523: *
524: CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
525: $ K, ONE, V, LDV, WORK, LDWORK )
526: *
527: * C1 := C1 - W**T
528: *
529: DO 150 J = 1, K
530: DO 140 I = 1, N
531: C( J, I ) = C( J, I ) - WORK( I, J )
532: 140 CONTINUE
533: 150 CONTINUE
534: *
535: ELSE IF( LSAME( SIDE, 'R' ) ) THEN
536: *
537: * Form C * H or C * H**T where C = ( C1 C2 )
538: *
539: * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
540: *
541: * W := C1
542: *
543: DO 160 J = 1, K
544: CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
545: 160 CONTINUE
546: *
547: * W := W * V1**T
548: *
549: CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
550: $ ONE, V, LDV, WORK, LDWORK )
551: IF( N.GT.K ) THEN
552: *
553: * W := W + C2 * V2**T
554: *
555: CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
556: $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
557: $ ONE, WORK, LDWORK )
558: END IF
559: *
560: * W := W * T or W * T**T
561: *
562: CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
563: $ ONE, T, LDT, WORK, LDWORK )
564: *
565: * C := C - W * V
566: *
567: IF( N.GT.K ) THEN
568: *
569: * C2 := C2 - W * V2
570: *
571: CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K,
572: $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
573: $ C( 1, K+1 ), LDC )
574: END IF
575: *
576: * W := W * V1
577: *
578: CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
579: $ K, ONE, V, LDV, WORK, LDWORK )
580: *
581: * C1 := C1 - W
582: *
583: DO 180 J = 1, K
584: DO 170 I = 1, M
585: C( I, J ) = C( I, J ) - WORK( I, J )
586: 170 CONTINUE
587: 180 CONTINUE
588: *
589: END IF
590: *
591: ELSE
592: *
593: * Let V = ( V1 V2 ) (V2: last K columns)
594: * where V2 is unit lower triangular.
595: *
596: IF( LSAME( SIDE, 'L' ) ) THEN
597: *
598: * Form H * C or H**T * C where C = ( C1 )
599: * ( C2 )
600: *
601: * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
602: *
603: * W := C2**T
604: *
605: DO 190 J = 1, K
606: CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
607: 190 CONTINUE
608: *
609: * W := W * V2**T
610: *
611: CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
612: $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
613: IF( M.GT.K ) THEN
614: *
615: * W := W + C1**T * V1**T
616: *
617: CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
618: $ C, LDC, V, LDV, ONE, WORK, LDWORK )
619: END IF
620: *
621: * W := W * T**T or W * T
622: *
623: CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
624: $ ONE, T, LDT, WORK, LDWORK )
625: *
626: * C := C - V**T * W**T
627: *
628: IF( M.GT.K ) THEN
629: *
630: * C1 := C1 - V1**T * W**T
631: *
632: CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
633: $ V, LDV, WORK, LDWORK, ONE, C, LDC )
634: END IF
635: *
636: * W := W * V2
637: *
638: CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
639: $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
640: *
641: * C2 := C2 - W**T
642: *
643: DO 210 J = 1, K
644: DO 200 I = 1, N
645: C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
646: 200 CONTINUE
647: 210 CONTINUE
648: *
649: ELSE IF( LSAME( SIDE, 'R' ) ) THEN
650: *
651: * Form C * H or C * H' where C = ( C1 C2 )
652: *
653: * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
654: *
655: * W := C2
656: *
657: DO 220 J = 1, K
658: CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
659: 220 CONTINUE
660: *
661: * W := W * V2**T
662: *
663: CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
664: $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
665: IF( N.GT.K ) THEN
666: *
667: * W := W + C1 * V1**T
668: *
669: CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
670: $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
671: END IF
672: *
673: * W := W * T or W * T**T
674: *
675: CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
676: $ ONE, T, LDT, WORK, LDWORK )
677: *
678: * C := C - W * V
679: *
680: IF( N.GT.K ) THEN
681: *
682: * C1 := C1 - W * V1
683: *
684: CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K,
685: $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
686: END IF
687: *
688: * W := W * V2
689: *
690: CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
691: $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
692: *
693: * C1 := C1 - W
694: *
695: DO 240 J = 1, K
696: DO 230 I = 1, M
697: C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
698: 230 CONTINUE
699: 240 CONTINUE
700: *
701: END IF
702: *
703: END IF
704: END IF
705: *
706: RETURN
707: *
708: * End of DLARFB
709: *
710: 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