1: SUBROUTINE DLARFB( 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: DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ),
16: $ WORK( LDWORK, * )
17: * ..
18: *
19: * Purpose
20: * =======
21: *
22: * DLARFB applies a real block reflector H or its transpose H' to a
23: * real 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: * = 'T': apply H' (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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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. LDA >= max(1,M).
83: *
84: * WORK (workspace) DOUBLE PRECISION 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: DOUBLE PRECISION ONE
95: PARAMETER ( ONE = 1.0D+0 )
96: * ..
97: * .. Local Scalars ..
98: CHARACTER TRANST
99: INTEGER I, J, LASTV, LASTC
100: * ..
101: * .. External Functions ..
102: LOGICAL LSAME
103: INTEGER ILADLR, ILADLC
104: EXTERNAL LSAME, ILADLR, ILADLC
105: * ..
106: * .. External Subroutines ..
107: EXTERNAL DCOPY, DGEMM, DTRMM
108: * ..
109: * .. Executable Statements ..
110: *
111: * Quick return if possible
112: *
113: IF( M.LE.0 .OR. N.LE.0 )
114: $ RETURN
115: *
116: IF( LSAME( TRANS, 'N' ) ) THEN
117: TRANST = 'T'
118: ELSE
119: TRANST = 'N'
120: END IF
121: *
122: IF( LSAME( STOREV, 'C' ) ) THEN
123: *
124: IF( LSAME( DIRECT, 'F' ) ) THEN
125: *
126: * Let V = ( V1 ) (first K rows)
127: * ( V2 )
128: * where V1 is unit lower triangular.
129: *
130: IF( LSAME( SIDE, 'L' ) ) THEN
131: *
132: * Form H * C or H' * C where C = ( C1 )
133: * ( C2 )
134: *
135: LASTV = MAX( K, ILADLR( M, K, V, LDV ) )
136: LASTC = ILADLC( LASTV, N, C, LDC )
137: *
138: * W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK)
139: *
140: * W := C1'
141: *
142: DO 10 J = 1, K
143: CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
144: 10 CONTINUE
145: *
146: * W := W * V1
147: *
148: CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
149: $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
150: IF( LASTV.GT.K ) THEN
151: *
152: * W := W + C2'*V2
153: *
154: CALL DGEMM( 'Transpose', 'No transpose',
155: $ LASTC, K, LASTV-K,
156: $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
157: $ ONE, WORK, LDWORK )
158: END IF
159: *
160: * W := W * T' or W * T
161: *
162: CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
163: $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
164: *
165: * C := C - V * W'
166: *
167: IF( LASTV.GT.K ) THEN
168: *
169: * C2 := C2 - V2 * W'
170: *
171: CALL DGEMM( 'No transpose', 'Transpose',
172: $ LASTV-K, LASTC, K,
173: $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
174: $ C( K+1, 1 ), LDC )
175: END IF
176: *
177: * W := W * V1'
178: *
179: CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',
180: $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
181: *
182: * C1 := C1 - W'
183: *
184: DO 30 J = 1, K
185: DO 20 I = 1, LASTC
186: C( J, I ) = C( J, I ) - WORK( I, J )
187: 20 CONTINUE
188: 30 CONTINUE
189: *
190: ELSE IF( LSAME( SIDE, 'R' ) ) THEN
191: *
192: * Form C * H or C * H' where C = ( C1 C2 )
193: *
194: LASTV = MAX( K, ILADLR( N, K, V, LDV ) )
195: LASTC = ILADLR( M, LASTV, C, LDC )
196: *
197: * W := C * V = (C1*V1 + C2*V2) (stored in WORK)
198: *
199: * W := C1
200: *
201: DO 40 J = 1, K
202: CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
203: 40 CONTINUE
204: *
205: * W := W * V1
206: *
207: CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
208: $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
209: IF( LASTV.GT.K ) THEN
210: *
211: * W := W + C2 * V2
212: *
213: CALL DGEMM( 'No transpose', 'No transpose',
214: $ LASTC, K, LASTV-K,
215: $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
216: $ ONE, WORK, LDWORK )
217: END IF
218: *
219: * W := W * T or W * T'
220: *
221: CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
222: $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
223: *
224: * C := C - W * V'
225: *
226: IF( LASTV.GT.K ) THEN
227: *
228: * C2 := C2 - W * V2'
229: *
230: CALL DGEMM( 'No transpose', 'Transpose',
231: $ LASTC, LASTV-K, K,
232: $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
233: $ C( 1, K+1 ), LDC )
234: END IF
235: *
236: * W := W * V1'
237: *
238: CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',
239: $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
240: *
241: * C1 := C1 - W
242: *
243: DO 60 J = 1, K
244: DO 50 I = 1, LASTC
245: C( I, J ) = C( I, J ) - WORK( I, J )
246: 50 CONTINUE
247: 60 CONTINUE
248: END IF
249: *
250: ELSE
251: *
252: * Let V = ( V1 )
253: * ( V2 ) (last K rows)
254: * where V2 is unit upper triangular.
255: *
256: IF( LSAME( SIDE, 'L' ) ) THEN
257: *
258: * Form H * C or H' * C where C = ( C1 )
259: * ( C2 )
260: *
261: LASTV = MAX( K, ILADLR( M, K, V, LDV ) )
262: LASTC = ILADLC( LASTV, N, C, LDC )
263: *
264: * W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK)
265: *
266: * W := C2'
267: *
268: DO 70 J = 1, K
269: CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
270: $ WORK( 1, J ), 1 )
271: 70 CONTINUE
272: *
273: * W := W * V2
274: *
275: CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
276: $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
277: $ WORK, LDWORK )
278: IF( LASTV.GT.K ) THEN
279: *
280: * W := W + C1'*V1
281: *
282: CALL DGEMM( 'Transpose', 'No transpose',
283: $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
284: $ ONE, WORK, LDWORK )
285: END IF
286: *
287: * W := W * T' or W * T
288: *
289: CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
290: $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
291: *
292: * C := C - V * W'
293: *
294: IF( LASTV.GT.K ) THEN
295: *
296: * C1 := C1 - V1 * W'
297: *
298: CALL DGEMM( 'No transpose', 'Transpose',
299: $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
300: $ ONE, C, LDC )
301: END IF
302: *
303: * W := W * V2'
304: *
305: CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
306: $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
307: $ WORK, LDWORK )
308: *
309: * C2 := C2 - W'
310: *
311: DO 90 J = 1, K
312: DO 80 I = 1, LASTC
313: C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J)
314: 80 CONTINUE
315: 90 CONTINUE
316: *
317: ELSE IF( LSAME( SIDE, 'R' ) ) THEN
318: *
319: * Form C * H or C * H' where C = ( C1 C2 )
320: *
321: LASTV = MAX( K, ILADLR( N, K, V, LDV ) )
322: LASTC = ILADLR( M, LASTV, C, LDC )
323: *
324: * W := C * V = (C1*V1 + C2*V2) (stored in WORK)
325: *
326: * W := C2
327: *
328: DO 100 J = 1, K
329: CALL DCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
330: 100 CONTINUE
331: *
332: * W := W * V2
333: *
334: CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
335: $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
336: $ WORK, LDWORK )
337: IF( LASTV.GT.K ) THEN
338: *
339: * W := W + C1 * V1
340: *
341: CALL DGEMM( 'No transpose', 'No transpose',
342: $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
343: $ ONE, WORK, LDWORK )
344: END IF
345: *
346: * W := W * T or W * T'
347: *
348: CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
349: $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
350: *
351: * C := C - W * V'
352: *
353: IF( LASTV.GT.K ) THEN
354: *
355: * C1 := C1 - W * V1'
356: *
357: CALL DGEMM( 'No transpose', 'Transpose',
358: $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
359: $ ONE, C, LDC )
360: END IF
361: *
362: * W := W * V2'
363: *
364: CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
365: $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
366: $ WORK, LDWORK )
367: *
368: * C2 := C2 - W
369: *
370: DO 120 J = 1, K
371: DO 110 I = 1, LASTC
372: C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J)
373: 110 CONTINUE
374: 120 CONTINUE
375: END IF
376: END IF
377: *
378: ELSE IF( LSAME( STOREV, 'R' ) ) THEN
379: *
380: IF( LSAME( DIRECT, 'F' ) ) THEN
381: *
382: * Let V = ( V1 V2 ) (V1: first K columns)
383: * where V1 is unit upper triangular.
384: *
385: IF( LSAME( SIDE, 'L' ) ) THEN
386: *
387: * Form H * C or H' * C where C = ( C1 )
388: * ( C2 )
389: *
390: LASTV = MAX( K, ILADLC( K, M, V, LDV ) )
391: LASTC = ILADLC( LASTV, N, C, LDC )
392: *
393: * W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK)
394: *
395: * W := C1'
396: *
397: DO 130 J = 1, K
398: CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
399: 130 CONTINUE
400: *
401: * W := W * V1'
402: *
403: CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
404: $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
405: IF( LASTV.GT.K ) THEN
406: *
407: * W := W + C2'*V2'
408: *
409: CALL DGEMM( 'Transpose', 'Transpose',
410: $ LASTC, K, LASTV-K,
411: $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV,
412: $ ONE, WORK, LDWORK )
413: END IF
414: *
415: * W := W * T' or W * T
416: *
417: CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
418: $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
419: *
420: * C := C - V' * W'
421: *
422: IF( LASTV.GT.K ) THEN
423: *
424: * C2 := C2 - V2' * W'
425: *
426: CALL DGEMM( 'Transpose', 'Transpose',
427: $ LASTV-K, LASTC, K,
428: $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
429: $ ONE, C( K+1, 1 ), LDC )
430: END IF
431: *
432: * W := W * V1
433: *
434: CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
435: $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
436: *
437: * C1 := C1 - W'
438: *
439: DO 150 J = 1, K
440: DO 140 I = 1, LASTC
441: C( J, I ) = C( J, I ) - WORK( I, J )
442: 140 CONTINUE
443: 150 CONTINUE
444: *
445: ELSE IF( LSAME( SIDE, 'R' ) ) THEN
446: *
447: * Form C * H or C * H' where C = ( C1 C2 )
448: *
449: LASTV = MAX( K, ILADLC( K, N, V, LDV ) )
450: LASTC = ILADLR( M, LASTV, C, LDC )
451: *
452: * W := C * V' = (C1*V1' + C2*V2') (stored in WORK)
453: *
454: * W := C1
455: *
456: DO 160 J = 1, K
457: CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
458: 160 CONTINUE
459: *
460: * W := W * V1'
461: *
462: CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
463: $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
464: IF( LASTV.GT.K ) THEN
465: *
466: * W := W + C2 * V2'
467: *
468: CALL DGEMM( 'No transpose', 'Transpose',
469: $ LASTC, K, LASTV-K,
470: $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
471: $ ONE, WORK, LDWORK )
472: END IF
473: *
474: * W := W * T or W * T'
475: *
476: CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
477: $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
478: *
479: * C := C - W * V
480: *
481: IF( LASTV.GT.K ) THEN
482: *
483: * C2 := C2 - W * V2
484: *
485: CALL DGEMM( 'No transpose', 'No transpose',
486: $ LASTC, LASTV-K, K,
487: $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
488: $ ONE, C( 1, K+1 ), LDC )
489: END IF
490: *
491: * W := W * V1
492: *
493: CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
494: $ LASTC, K, ONE, V, LDV, WORK, LDWORK )
495: *
496: * C1 := C1 - W
497: *
498: DO 180 J = 1, K
499: DO 170 I = 1, LASTC
500: C( I, J ) = C( I, J ) - WORK( I, J )
501: 170 CONTINUE
502: 180 CONTINUE
503: *
504: END IF
505: *
506: ELSE
507: *
508: * Let V = ( V1 V2 ) (V2: last K columns)
509: * where V2 is unit lower triangular.
510: *
511: IF( LSAME( SIDE, 'L' ) ) THEN
512: *
513: * Form H * C or H' * C where C = ( C1 )
514: * ( C2 )
515: *
516: LASTV = MAX( K, ILADLC( K, M, V, LDV ) )
517: LASTC = ILADLC( LASTV, N, C, LDC )
518: *
519: * W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK)
520: *
521: * W := C2'
522: *
523: DO 190 J = 1, K
524: CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
525: $ WORK( 1, J ), 1 )
526: 190 CONTINUE
527: *
528: * W := W * V2'
529: *
530: CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',
531: $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
532: $ WORK, LDWORK )
533: IF( LASTV.GT.K ) THEN
534: *
535: * W := W + C1'*V1'
536: *
537: CALL DGEMM( 'Transpose', 'Transpose',
538: $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
539: $ ONE, WORK, LDWORK )
540: END IF
541: *
542: * W := W * T' or W * T
543: *
544: CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
545: $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
546: *
547: * C := C - V' * W'
548: *
549: IF( LASTV.GT.K ) THEN
550: *
551: * C1 := C1 - V1' * W'
552: *
553: CALL DGEMM( 'Transpose', 'Transpose',
554: $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
555: $ ONE, C, LDC )
556: END IF
557: *
558: * W := W * V2
559: *
560: CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
561: $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
562: $ WORK, LDWORK )
563: *
564: * C2 := C2 - W'
565: *
566: DO 210 J = 1, K
567: DO 200 I = 1, LASTC
568: C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J)
569: 200 CONTINUE
570: 210 CONTINUE
571: *
572: ELSE IF( LSAME( SIDE, 'R' ) ) THEN
573: *
574: * Form C * H or C * H' where C = ( C1 C2 )
575: *
576: LASTV = MAX( K, ILADLC( K, N, V, LDV ) )
577: LASTC = ILADLR( M, LASTV, C, LDC )
578: *
579: * W := C * V' = (C1*V1' + C2*V2') (stored in WORK)
580: *
581: * W := C2
582: *
583: DO 220 J = 1, K
584: CALL DCOPY( LASTC, C( 1, LASTV-K+J ), 1,
585: $ WORK( 1, J ), 1 )
586: 220 CONTINUE
587: *
588: * W := W * V2'
589: *
590: CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',
591: $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
592: $ WORK, LDWORK )
593: IF( LASTV.GT.K ) THEN
594: *
595: * W := W + C1 * V1'
596: *
597: CALL DGEMM( 'No transpose', 'Transpose',
598: $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
599: $ ONE, WORK, LDWORK )
600: END IF
601: *
602: * W := W * T or W * T'
603: *
604: CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
605: $ LASTC, K, ONE, T, LDT, WORK, LDWORK )
606: *
607: * C := C - W * V
608: *
609: IF( LASTV.GT.K ) THEN
610: *
611: * C1 := C1 - W * V1
612: *
613: CALL DGEMM( 'No transpose', 'No transpose',
614: $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
615: $ ONE, C, LDC )
616: END IF
617: *
618: * W := W * V2
619: *
620: CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
621: $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
622: $ WORK, LDWORK )
623: *
624: * C1 := C1 - W
625: *
626: DO 240 J = 1, K
627: DO 230 I = 1, LASTC
628: C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J)
629: 230 CONTINUE
630: 240 CONTINUE
631: *
632: END IF
633: *
634: END IF
635: END IF
636: *
637: RETURN
638: *
639: * End of DLARFB
640: *
641: 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