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