LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
dlarfb.f
Go to the documentation of this file.
1 *> \brief \b DLARFB
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 November 2011
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.4.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 * November 2011
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, lastv, lastc
221 * ..
222 * .. External Functions ..
223  LOGICAL lsame
224  INTEGER iladlr, iladlc
225  EXTERNAL lsame, iladlr, iladlc
226 * ..
227 * .. External Subroutines ..
228  EXTERNAL dcopy, dgemm, dtrmm
229 * ..
230 * .. Executable Statements ..
231 *
232 * Quick return if possible
233 *
234  IF( m.LE.0 .OR. n.LE.0 )
235  $ RETURN
236 *
237  IF( lsame( trans, 'N' ) ) THEN
238  transt = 'T'
239  ELSE
240  transt = 'N'
241  END IF
242 *
243  IF( lsame( storev, 'C' ) ) THEN
244 *
245  IF( lsame( direct, 'F' ) ) THEN
246 *
247 * Let V = ( V1 ) (first K rows)
248 * ( V2 )
249 * where V1 is unit lower triangular.
250 *
251  IF( lsame( side, 'L' ) ) THEN
252 *
253 * Form H * C or H**T * C where C = ( C1 )
254 * ( C2 )
255 *
256  lastv = max( k, iladlr( m, k, v, ldv ) )
257  lastc = iladlc( lastv, n, c, ldc )
258 *
259 * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
260 *
261 * W := C1**T
262 *
263  DO 10 j = 1, k
264  CALL dcopy( lastc, c( j, 1 ), ldc, work( 1, j ), 1 )
265  10 CONTINUE
266 *
267 * W := W * V1
268 *
269  CALL dtrmm( 'Right', 'Lower', 'No transpose', 'Unit',
270  $ lastc, k, one, v, ldv, work, ldwork )
271  IF( lastv.GT.k ) THEN
272 *
273 * W := W + C2**T *V2
274 *
275  CALL dgemm( 'Transpose', 'No transpose',
276  $ lastc, k, lastv-k,
277  $ one, c( k+1, 1 ), ldc, v( k+1, 1 ), ldv,
278  $ one, work, ldwork )
279  END IF
280 *
281 * W := W * T**T or W * T
282 *
283  CALL dtrmm( 'Right', 'Upper', transt, 'Non-unit',
284  $ lastc, k, one, t, ldt, work, ldwork )
285 *
286 * C := C - V * W**T
287 *
288  IF( lastv.GT.k ) THEN
289 *
290 * C2 := C2 - V2 * W**T
291 *
292  CALL dgemm( 'No transpose', 'Transpose',
293  $ lastv-k, lastc, k,
294  $ -one, v( k+1, 1 ), ldv, work, ldwork, one,
295  $ c( k+1, 1 ), ldc )
296  END IF
297 *
298 * W := W * V1**T
299 *
300  CALL dtrmm( 'Right', 'Lower', 'Transpose', 'Unit',
301  $ lastc, k, one, v, ldv, work, ldwork )
302 *
303 * C1 := C1 - W**T
304 *
305  DO 30 j = 1, k
306  DO 20 i = 1, lastc
307  c( j, i ) = c( j, i ) - work( i, j )
308  20 CONTINUE
309  30 CONTINUE
310 *
311  ELSE IF( lsame( side, 'R' ) ) THEN
312 *
313 * Form C * H or C * H**T where C = ( C1 C2 )
314 *
315  lastv = max( k, iladlr( n, k, v, ldv ) )
316  lastc = iladlr( m, lastv, c, ldc )
317 *
318 * W := C * V = (C1*V1 + C2*V2) (stored in WORK)
319 *
320 * W := C1
321 *
322  DO 40 j = 1, k
323  CALL dcopy( lastc, c( 1, j ), 1, work( 1, j ), 1 )
324  40 CONTINUE
325 *
326 * W := W * V1
327 *
328  CALL dtrmm( 'Right', 'Lower', 'No transpose', 'Unit',
329  $ lastc, k, one, v, ldv, work, ldwork )
330  IF( lastv.GT.k ) THEN
331 *
332 * W := W + C2 * V2
333 *
334  CALL dgemm( 'No transpose', 'No transpose',
335  $ lastc, k, lastv-k,
336  $ one, c( 1, k+1 ), ldc, v( k+1, 1 ), ldv,
337  $ one, work, ldwork )
338  END IF
339 *
340 * W := W * T or W * T**T
341 *
342  CALL dtrmm( 'Right', 'Upper', trans, 'Non-unit',
343  $ lastc, k, one, t, ldt, work, ldwork )
344 *
345 * C := C - W * V**T
346 *
347  IF( lastv.GT.k ) THEN
348 *
349 * C2 := C2 - W * V2**T
350 *
351  CALL dgemm( 'No transpose', 'Transpose',
352  $ lastc, lastv-k, k,
353  $ -one, work, ldwork, v( k+1, 1 ), ldv, one,
354  $ c( 1, k+1 ), ldc )
355  END IF
356 *
357 * W := W * V1**T
358 *
359  CALL dtrmm( 'Right', 'Lower', 'Transpose', 'Unit',
360  $ lastc, k, one, v, ldv, work, ldwork )
361 *
362 * C1 := C1 - W
363 *
364  DO 60 j = 1, k
365  DO 50 i = 1, lastc
366  c( i, j ) = c( i, j ) - work( i, j )
367  50 CONTINUE
368  60 CONTINUE
369  END IF
370 *
371  ELSE
372 *
373 * Let V = ( V1 )
374 * ( V2 ) (last K rows)
375 * where V2 is unit upper triangular.
376 *
377  IF( lsame( side, 'L' ) ) THEN
378 *
379 * Form H * C or H**T * C where C = ( C1 )
380 * ( C2 )
381 *
382  lastv = max( k, iladlr( m, k, v, ldv ) )
383  lastc = iladlc( lastv, n, c, ldc )
384 *
385 * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
386 *
387 * W := C2**T
388 *
389  DO 70 j = 1, k
390  CALL dcopy( lastc, c( lastv-k+j, 1 ), ldc,
391  $ work( 1, j ), 1 )
392  70 CONTINUE
393 *
394 * W := W * V2
395 *
396  CALL dtrmm( 'Right', 'Upper', 'No transpose', 'Unit',
397  $ lastc, k, one, v( lastv-k+1, 1 ), ldv,
398  $ work, ldwork )
399  IF( lastv.GT.k ) THEN
400 *
401 * W := W + C1**T*V1
402 *
403  CALL dgemm( 'Transpose', 'No transpose',
404  $ lastc, k, lastv-k, one, c, ldc, v, ldv,
405  $ one, work, ldwork )
406  END IF
407 *
408 * W := W * T**T or W * T
409 *
410  CALL dtrmm( 'Right', 'Lower', transt, 'Non-unit',
411  $ lastc, k, one, t, ldt, work, ldwork )
412 *
413 * C := C - V * W**T
414 *
415  IF( lastv.GT.k ) THEN
416 *
417 * C1 := C1 - V1 * W**T
418 *
419  CALL dgemm( 'No transpose', 'Transpose',
420  $ lastv-k, lastc, k, -one, v, ldv, work, ldwork,
421  $ one, c, ldc )
422  END IF
423 *
424 * W := W * V2**T
425 *
426  CALL dtrmm( 'Right', 'Upper', 'Transpose', 'Unit',
427  $ lastc, k, one, v( lastv-k+1, 1 ), ldv,
428  $ work, ldwork )
429 *
430 * C2 := C2 - W**T
431 *
432  DO 90 j = 1, k
433  DO 80 i = 1, lastc
434  c( lastv-k+j, i ) = c( lastv-k+j, i ) - work(i, j)
435  80 CONTINUE
436  90 CONTINUE
437 *
438  ELSE IF( lsame( side, 'R' ) ) THEN
439 *
440 * Form C * H or C * H**T where C = ( C1 C2 )
441 *
442  lastv = max( k, iladlr( n, k, v, ldv ) )
443  lastc = iladlr( m, lastv, c, ldc )
444 *
445 * W := C * V = (C1*V1 + C2*V2) (stored in WORK)
446 *
447 * W := C2
448 *
449  DO 100 j = 1, k
450  CALL dcopy( lastc, c( 1, n-k+j ), 1, work( 1, j ), 1 )
451  100 CONTINUE
452 *
453 * W := W * V2
454 *
455  CALL dtrmm( 'Right', 'Upper', 'No transpose', 'Unit',
456  $ lastc, k, one, v( lastv-k+1, 1 ), ldv,
457  $ work, ldwork )
458  IF( lastv.GT.k ) THEN
459 *
460 * W := W + C1 * V1
461 *
462  CALL dgemm( 'No transpose', 'No transpose',
463  $ lastc, k, lastv-k, one, c, ldc, v, ldv,
464  $ one, work, ldwork )
465  END IF
466 *
467 * W := W * T or W * T**T
468 *
469  CALL dtrmm( 'Right', 'Lower', trans, 'Non-unit',
470  $ lastc, k, one, t, ldt, work, ldwork )
471 *
472 * C := C - W * V**T
473 *
474  IF( lastv.GT.k ) THEN
475 *
476 * C1 := C1 - W * V1**T
477 *
478  CALL dgemm( 'No transpose', 'Transpose',
479  $ lastc, lastv-k, k, -one, work, ldwork, v, ldv,
480  $ one, c, ldc )
481  END IF
482 *
483 * W := W * V2**T
484 *
485  CALL dtrmm( 'Right', 'Upper', 'Transpose', 'Unit',
486  $ lastc, k, one, v( lastv-k+1, 1 ), ldv,
487  $ work, ldwork )
488 *
489 * C2 := C2 - W
490 *
491  DO 120 j = 1, k
492  DO 110 i = 1, lastc
493  c( i, lastv-k+j ) = c( i, lastv-k+j ) - work(i, j)
494  110 CONTINUE
495  120 CONTINUE
496  END IF
497  END IF
498 *
499  ELSE IF( lsame( storev, 'R' ) ) THEN
500 *
501  IF( lsame( direct, 'F' ) ) THEN
502 *
503 * Let V = ( V1 V2 ) (V1: first K columns)
504 * where V1 is unit upper triangular.
505 *
506  IF( lsame( side, 'L' ) ) THEN
507 *
508 * Form H * C or H**T * C where C = ( C1 )
509 * ( C2 )
510 *
511  lastv = max( k, iladlc( k, m, v, ldv ) )
512  lastc = iladlc( lastv, n, c, ldc )
513 *
514 * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
515 *
516 * W := C1**T
517 *
518  DO 130 j = 1, k
519  CALL dcopy( lastc, c( j, 1 ), ldc, work( 1, j ), 1 )
520  130 CONTINUE
521 *
522 * W := W * V1**T
523 *
524  CALL dtrmm( 'Right', 'Upper', 'Transpose', 'Unit',
525  $ lastc, k, one, v, ldv, work, ldwork )
526  IF( lastv.GT.k ) THEN
527 *
528 * W := W + C2**T*V2**T
529 *
530  CALL dgemm( 'Transpose', 'Transpose',
531  $ lastc, k, lastv-k,
532  $ one, c( k+1, 1 ), ldc, v( 1, k+1 ), ldv,
533  $ one, work, ldwork )
534  END IF
535 *
536 * W := W * T**T or W * T
537 *
538  CALL dtrmm( 'Right', 'Upper', transt, 'Non-unit',
539  $ lastc, k, one, t, ldt, work, ldwork )
540 *
541 * C := C - V**T * W**T
542 *
543  IF( lastv.GT.k ) THEN
544 *
545 * C2 := C2 - V2**T * W**T
546 *
547  CALL dgemm( 'Transpose', 'Transpose',
548  $ lastv-k, lastc, k,
549  $ -one, v( 1, k+1 ), ldv, work, ldwork,
550  $ one, c( k+1, 1 ), ldc )
551  END IF
552 *
553 * W := W * V1
554 *
555  CALL dtrmm( 'Right', 'Upper', 'No transpose', 'Unit',
556  $ lastc, k, one, v, ldv, work, ldwork )
557 *
558 * C1 := C1 - W**T
559 *
560  DO 150 j = 1, k
561  DO 140 i = 1, lastc
562  c( j, i ) = c( j, i ) - work( i, j )
563  140 CONTINUE
564  150 CONTINUE
565 *
566  ELSE IF( lsame( side, 'R' ) ) THEN
567 *
568 * Form C * H or C * H**T where C = ( C1 C2 )
569 *
570  lastv = max( k, iladlc( k, n, v, ldv ) )
571  lastc = iladlr( m, lastv, c, ldc )
572 *
573 * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
574 *
575 * W := C1
576 *
577  DO 160 j = 1, k
578  CALL dcopy( lastc, c( 1, j ), 1, work( 1, j ), 1 )
579  160 CONTINUE
580 *
581 * W := W * V1**T
582 *
583  CALL dtrmm( 'Right', 'Upper', 'Transpose', 'Unit',
584  $ lastc, k, one, v, ldv, work, ldwork )
585  IF( lastv.GT.k ) THEN
586 *
587 * W := W + C2 * V2**T
588 *
589  CALL dgemm( 'No transpose', 'Transpose',
590  $ lastc, k, lastv-k,
591  $ one, c( 1, k+1 ), ldc, v( 1, k+1 ), ldv,
592  $ one, work, ldwork )
593  END IF
594 *
595 * W := W * T or W * T**T
596 *
597  CALL dtrmm( 'Right', 'Upper', trans, 'Non-unit',
598  $ lastc, k, one, t, ldt, work, ldwork )
599 *
600 * C := C - W * V
601 *
602  IF( lastv.GT.k ) THEN
603 *
604 * C2 := C2 - W * V2
605 *
606  CALL dgemm( 'No transpose', 'No transpose',
607  $ lastc, lastv-k, k,
608  $ -one, work, ldwork, v( 1, k+1 ), ldv,
609  $ one, c( 1, k+1 ), ldc )
610  END IF
611 *
612 * W := W * V1
613 *
614  CALL dtrmm( 'Right', 'Upper', 'No transpose', 'Unit',
615  $ lastc, k, one, v, ldv, work, ldwork )
616 *
617 * C1 := C1 - W
618 *
619  DO 180 j = 1, k
620  DO 170 i = 1, lastc
621  c( i, j ) = c( i, j ) - work( i, j )
622  170 CONTINUE
623  180 CONTINUE
624 *
625  END IF
626 *
627  ELSE
628 *
629 * Let V = ( V1 V2 ) (V2: last K columns)
630 * where V2 is unit lower triangular.
631 *
632  IF( lsame( side, 'L' ) ) THEN
633 *
634 * Form H * C or H**T * C where C = ( C1 )
635 * ( C2 )
636 *
637  lastv = max( k, iladlc( k, m, v, ldv ) )
638  lastc = iladlc( lastv, n, c, ldc )
639 *
640 * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
641 *
642 * W := C2**T
643 *
644  DO 190 j = 1, k
645  CALL dcopy( lastc, c( lastv-k+j, 1 ), ldc,
646  $ work( 1, j ), 1 )
647  190 CONTINUE
648 *
649 * W := W * V2**T
650 *
651  CALL dtrmm( 'Right', 'Lower', 'Transpose', 'Unit',
652  $ lastc, k, one, v( 1, lastv-k+1 ), ldv,
653  $ work, ldwork )
654  IF( lastv.GT.k ) THEN
655 *
656 * W := W + C1**T * V1**T
657 *
658  CALL dgemm( 'Transpose', 'Transpose',
659  $ lastc, k, lastv-k, one, c, ldc, v, ldv,
660  $ one, work, ldwork )
661  END IF
662 *
663 * W := W * T**T or W * T
664 *
665  CALL dtrmm( 'Right', 'Lower', transt, 'Non-unit',
666  $ lastc, k, one, t, ldt, work, ldwork )
667 *
668 * C := C - V**T * W**T
669 *
670  IF( lastv.GT.k ) THEN
671 *
672 * C1 := C1 - V1**T * W**T
673 *
674  CALL dgemm( 'Transpose', 'Transpose',
675  $ lastv-k, lastc, k, -one, v, ldv, work, ldwork,
676  $ one, c, ldc )
677  END IF
678 *
679 * W := W * V2
680 *
681  CALL dtrmm( 'Right', 'Lower', 'No transpose', 'Unit',
682  $ lastc, k, one, v( 1, lastv-k+1 ), ldv,
683  $ work, ldwork )
684 *
685 * C2 := C2 - W**T
686 *
687  DO 210 j = 1, k
688  DO 200 i = 1, lastc
689  c( lastv-k+j, i ) = c( lastv-k+j, i ) - work(i, j)
690  200 CONTINUE
691  210 CONTINUE
692 *
693  ELSE IF( lsame( side, 'R' ) ) THEN
694 *
695 * Form C * H or C * H**T where C = ( C1 C2 )
696 *
697  lastv = max( k, iladlc( k, n, v, ldv ) )
698  lastc = iladlr( m, lastv, c, ldc )
699 *
700 * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
701 *
702 * W := C2
703 *
704  DO 220 j = 1, k
705  CALL dcopy( lastc, c( 1, lastv-k+j ), 1,
706  $ work( 1, j ), 1 )
707  220 CONTINUE
708 *
709 * W := W * V2**T
710 *
711  CALL dtrmm( 'Right', 'Lower', 'Transpose', 'Unit',
712  $ lastc, k, one, v( 1, lastv-k+1 ), ldv,
713  $ work, ldwork )
714  IF( lastv.GT.k ) THEN
715 *
716 * W := W + C1 * V1**T
717 *
718  CALL dgemm( 'No transpose', 'Transpose',
719  $ lastc, k, lastv-k, one, c, ldc, v, ldv,
720  $ one, work, ldwork )
721  END IF
722 *
723 * W := W * T or W * T**T
724 *
725  CALL dtrmm( 'Right', 'Lower', trans, 'Non-unit',
726  $ lastc, k, one, t, ldt, work, ldwork )
727 *
728 * C := C - W * V
729 *
730  IF( lastv.GT.k ) THEN
731 *
732 * C1 := C1 - W * V1
733 *
734  CALL dgemm( 'No transpose', 'No transpose',
735  $ lastc, lastv-k, k, -one, work, ldwork, v, ldv,
736  $ one, c, ldc )
737  END IF
738 *
739 * W := W * V2
740 *
741  CALL dtrmm( 'Right', 'Lower', 'No transpose', 'Unit',
742  $ lastc, k, one, v( 1, lastv-k+1 ), ldv,
743  $ work, ldwork )
744 *
745 * C1 := C1 - W
746 *
747  DO 240 j = 1, k
748  DO 230 i = 1, lastc
749  c( i, lastv-k+j ) = c( i, lastv-k+j ) - work(i, j)
750  230 CONTINUE
751  240 CONTINUE
752 *
753  END IF
754 *
755  END IF
756  END IF
757 *
758  RETURN
759 *
760 * End of DLARFB
761 *
762  END