LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
clarfb.f
Go to the documentation of this file.
1 *> \brief \b CLARFB applies a block reflector or its conjugate-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 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 September 2012
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.2) --
199 * -- LAPACK is a software package provided by Univ. of Tennessee, --
200 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
201 * September 2012
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  lastc = ilaclc( m, n, c, ldc )
385 *
386 * W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK)
387 *
388 * W := C2**H
389 *
390  DO 70 j = 1, k
391  CALL ccopy( lastc, c( m-k+j, 1 ), ldc,
392  $ work( 1, j ), 1 )
393  CALL clacgv( lastc, work( 1, j ), 1 )
394  70 continue
395 *
396 * W := W * V2
397 *
398  CALL ctrmm( 'Right', 'Upper', 'No transpose', 'Unit',
399  $ lastc, k, one, v( m-k+1, 1 ), ldv,
400  $ work, ldwork )
401  IF( m.GT.k ) THEN
402 *
403 * W := W + C1**H*V1
404 *
405  CALL cgemm( 'Conjugate transpose', 'No transpose',
406  $ lastc, k, m-k, one, c, ldc, v, ldv,
407  $ one, work, ldwork )
408  END IF
409 *
410 * W := W * T**H or W * T
411 *
412  CALL ctrmm( 'Right', 'Lower', transt, 'Non-unit',
413  $ lastc, k, one, t, ldt, work, ldwork )
414 *
415 * C := C - V * W**H
416 *
417  IF( m.GT.k ) THEN
418 *
419 * C1 := C1 - V1 * W**H
420 *
421  CALL cgemm( 'No transpose', 'Conjugate transpose',
422  $ m-k, lastc, k, -one, v, ldv, work, ldwork,
423  $ one, c, ldc )
424  END IF
425 *
426 * W := W * V2**H
427 *
428  CALL ctrmm( 'Right', 'Upper', 'Conjugate transpose',
429  $ 'Unit', lastc, k, one, v( m-k+1, 1 ), ldv,
430  $ work, ldwork )
431 *
432 * C2 := C2 - W**H
433 *
434  DO 90 j = 1, k
435  DO 80 i = 1, lastc
436  c( m-k+j, i ) = c( m-k+j, i ) -
437  $ conjg( work( i, j ) )
438  80 continue
439  90 continue
440 *
441  ELSE IF( lsame( side, 'R' ) ) THEN
442 *
443 * Form C * H or C * H**H where C = ( C1 C2 )
444 *
445  lastc = ilaclr( m, n, c, ldc )
446 *
447 * W := C * V = (C1*V1 + C2*V2) (stored in WORK)
448 *
449 * W := C2
450 *
451  DO 100 j = 1, k
452  CALL ccopy( lastc, c( 1, n-k+j ), 1,
453  $ work( 1, j ), 1 )
454  100 continue
455 *
456 * W := W * V2
457 *
458  CALL ctrmm( 'Right', 'Upper', 'No transpose', 'Unit',
459  $ lastc, k, one, v( n-k+1, 1 ), ldv,
460  $ work, ldwork )
461  IF( n.GT.k ) THEN
462 *
463 * W := W + C1 * V1
464 *
465  CALL cgemm( 'No transpose', 'No transpose',
466  $ lastc, k, n-k,
467  $ one, c, ldc, v, ldv, one, work, ldwork )
468  END IF
469 *
470 * W := W * T or W * T**H
471 *
472  CALL ctrmm( 'Right', 'Lower', trans, 'Non-unit',
473  $ lastc, k, one, t, ldt, work, ldwork )
474 *
475 * C := C - W * V**H
476 *
477  IF( n.GT.k ) THEN
478 *
479 * C1 := C1 - W * V1**H
480 *
481  CALL cgemm( 'No transpose', 'Conjugate transpose',
482  $ lastc, n-k, k, -one, work, ldwork, v, ldv,
483  $ one, c, ldc )
484  END IF
485 *
486 * W := W * V2**H
487 *
488  CALL ctrmm( 'Right', 'Upper', 'Conjugate transpose',
489  $ 'Unit', lastc, k, one, v( n-k+1, 1 ), ldv,
490  $ work, ldwork )
491 *
492 * C2 := C2 - W
493 *
494  DO 120 j = 1, k
495  DO 110 i = 1, lastc
496  c( i, n-k+j ) = c( i, n-k+j )
497  $ - work( i, j )
498  110 continue
499  120 continue
500  END IF
501  END IF
502 *
503  ELSE IF( lsame( storev, 'R' ) ) THEN
504 *
505  IF( lsame( direct, 'F' ) ) THEN
506 *
507 * Let V = ( V1 V2 ) (V1: first K columns)
508 * where V1 is unit upper triangular.
509 *
510  IF( lsame( side, 'L' ) ) THEN
511 *
512 * Form H * C or H**H * C where C = ( C1 )
513 * ( C2 )
514 *
515  lastv = max( k, ilaclc( k, m, v, ldv ) )
516  lastc = ilaclc( lastv, n, c, ldc )
517 *
518 * W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
519 *
520 * W := C1**H
521 *
522  DO 130 j = 1, k
523  CALL ccopy( lastc, c( j, 1 ), ldc, work( 1, j ), 1 )
524  CALL clacgv( lastc, work( 1, j ), 1 )
525  130 continue
526 *
527 * W := W * V1**H
528 *
529  CALL ctrmm( 'Right', 'Upper', 'Conjugate transpose',
530  $ 'Unit', lastc, k, one, v, ldv, work, ldwork )
531  IF( lastv.GT.k ) THEN
532 *
533 * W := W + C2**H*V2**H
534 *
535  CALL cgemm( 'Conjugate transpose',
536  $ 'Conjugate transpose', lastc, k, lastv-k,
537  $ one, c( k+1, 1 ), ldc, v( 1, k+1 ), ldv,
538  $ one, work, ldwork )
539  END IF
540 *
541 * W := W * T**H or W * T
542 *
543  CALL ctrmm( 'Right', 'Upper', transt, 'Non-unit',
544  $ lastc, k, one, t, ldt, work, ldwork )
545 *
546 * C := C - V**H * W**H
547 *
548  IF( lastv.GT.k ) THEN
549 *
550 * C2 := C2 - V2**H * W**H
551 *
552  CALL cgemm( 'Conjugate transpose',
553  $ 'Conjugate transpose', lastv-k, lastc, k,
554  $ -one, v( 1, k+1 ), ldv, work, ldwork,
555  $ one, c( k+1, 1 ), ldc )
556  END IF
557 *
558 * W := W * V1
559 *
560  CALL ctrmm( 'Right', 'Upper', 'No transpose', 'Unit',
561  $ lastc, k, one, v, ldv, work, ldwork )
562 *
563 * C1 := C1 - W**H
564 *
565  DO 150 j = 1, k
566  DO 140 i = 1, lastc
567  c( j, i ) = c( j, i ) - conjg( work( i, j ) )
568  140 continue
569  150 continue
570 *
571  ELSE IF( lsame( side, 'R' ) ) THEN
572 *
573 * Form C * H or C * H**H where C = ( C1 C2 )
574 *
575  lastv = max( k, ilaclc( k, n, v, ldv ) )
576  lastc = ilaclr( m, lastv, c, ldc )
577 *
578 * W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK)
579 *
580 * W := C1
581 *
582  DO 160 j = 1, k
583  CALL ccopy( lastc, c( 1, j ), 1, work( 1, j ), 1 )
584  160 continue
585 *
586 * W := W * V1**H
587 *
588  CALL ctrmm( 'Right', 'Upper', 'Conjugate transpose',
589  $ 'Unit', lastc, k, one, v, ldv, work, ldwork )
590  IF( lastv.GT.k ) THEN
591 *
592 * W := W + C2 * V2**H
593 *
594  CALL cgemm( 'No transpose', 'Conjugate transpose',
595  $ lastc, k, lastv-k, one, c( 1, k+1 ), ldc,
596  $ v( 1, k+1 ), ldv, one, work, ldwork )
597  END IF
598 *
599 * W := W * T or W * T**H
600 *
601  CALL ctrmm( 'Right', 'Upper', trans, 'Non-unit',
602  $ lastc, k, one, t, ldt, work, ldwork )
603 *
604 * C := C - W * V
605 *
606  IF( lastv.GT.k ) THEN
607 *
608 * C2 := C2 - W * V2
609 *
610  CALL cgemm( 'No transpose', 'No transpose',
611  $ lastc, lastv-k, k,
612  $ -one, work, ldwork, v( 1, k+1 ), ldv,
613  $ one, c( 1, k+1 ), ldc )
614  END IF
615 *
616 * W := W * V1
617 *
618  CALL ctrmm( 'Right', 'Upper', 'No transpose', 'Unit',
619  $ lastc, k, one, v, ldv, work, ldwork )
620 *
621 * C1 := C1 - W
622 *
623  DO 180 j = 1, k
624  DO 170 i = 1, lastc
625  c( i, j ) = c( i, j ) - work( i, j )
626  170 continue
627  180 continue
628 *
629  END IF
630 *
631  ELSE
632 *
633 * Let V = ( V1 V2 ) (V2: last K columns)
634 * where V2 is unit lower triangular.
635 *
636  IF( lsame( side, 'L' ) ) THEN
637 *
638 * Form H * C or H**H * C where C = ( C1 )
639 * ( C2 )
640 *
641  lastc = ilaclc( m, n, c, ldc )
642 *
643 * W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
644 *
645 * W := C2**H
646 *
647  DO 190 j = 1, k
648  CALL ccopy( lastc, c( m-k+j, 1 ), ldc,
649  $ work( 1, j ), 1 )
650  CALL clacgv( lastc, work( 1, j ), 1 )
651  190 continue
652 *
653 * W := W * V2**H
654 *
655  CALL ctrmm( 'Right', 'Lower', 'Conjugate transpose',
656  $ 'Unit', lastc, k, one, v( 1, m-k+1 ), ldv,
657  $ work, ldwork )
658  IF( m.GT.k ) THEN
659 *
660 * W := W + C1**H * V1**H
661 *
662  CALL cgemm( 'Conjugate transpose',
663  $ 'Conjugate transpose', lastc, k, m-k,
664  $ one, c, ldc, v, ldv, one, work, ldwork )
665  END IF
666 *
667 * W := W * T**H or W * T
668 *
669  CALL ctrmm( 'Right', 'Lower', transt, 'Non-unit',
670  $ lastc, k, one, t, ldt, work, ldwork )
671 *
672 * C := C - V**H * W**H
673 *
674  IF( m.GT.k ) THEN
675 *
676 * C1 := C1 - V1**H * W**H
677 *
678  CALL cgemm( 'Conjugate transpose',
679  $ 'Conjugate transpose', m-k, lastc, k,
680  $ -one, v, ldv, work, ldwork, one, c, ldc )
681  END IF
682 *
683 * W := W * V2
684 *
685  CALL ctrmm( 'Right', 'Lower', 'No transpose', 'Unit',
686  $ lastc, k, one, v( 1, m-k+1 ), ldv,
687  $ work, ldwork )
688 *
689 * C2 := C2 - W**H
690 *
691  DO 210 j = 1, k
692  DO 200 i = 1, lastc
693  c( m-k+j, i ) = c( m-k+j, i ) -
694  $ conjg( work( i, j ) )
695  200 continue
696  210 continue
697 *
698  ELSE IF( lsame( side, 'R' ) ) THEN
699 *
700 * Form C * H or C * H**H where C = ( C1 C2 )
701 *
702  lastc = ilaclr( m, n, c, ldc )
703 *
704 * W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK)
705 *
706 * W := C2
707 *
708  DO 220 j = 1, k
709  CALL ccopy( lastc, c( 1, n-k+j ), 1,
710  $ work( 1, j ), 1 )
711  220 continue
712 *
713 * W := W * V2**H
714 *
715  CALL ctrmm( 'Right', 'Lower', 'Conjugate transpose',
716  $ 'Unit', lastc, k, one, v( 1, n-k+1 ), ldv,
717  $ work, ldwork )
718  IF( n.GT.k ) THEN
719 *
720 * W := W + C1 * V1**H
721 *
722  CALL cgemm( 'No transpose', 'Conjugate transpose',
723  $ lastc, k, n-k, one, c, ldc, v, ldv, one,
724  $ work, ldwork )
725  END IF
726 *
727 * W := W * T or W * T**H
728 *
729  CALL ctrmm( 'Right', 'Lower', trans, 'Non-unit',
730  $ lastc, k, one, t, ldt, work, ldwork )
731 *
732 * C := C - W * V
733 *
734  IF( n.GT.k ) THEN
735 *
736 * C1 := C1 - W * V1
737 *
738  CALL cgemm( 'No transpose', 'No transpose',
739  $ lastc, n-k, k, -one, work, ldwork, v, ldv,
740  $ one, c, ldc )
741  END IF
742 *
743 * W := W * V2
744 *
745  CALL ctrmm( 'Right', 'Lower', 'No transpose', 'Unit',
746  $ lastc, k, one, v( 1, n-k+1 ), ldv,
747  $ work, ldwork )
748 *
749 * C1 := C1 - W
750 *
751  DO 240 j = 1, k
752  DO 230 i = 1, lastc
753  c( i, n-k+j ) = c( i, n-k+j ) - work( i, j )
754  230 continue
755  240 continue
756 *
757  END IF
758 *
759  END IF
760  END IF
761 *
762  return
763 *
764 * End of CLARFB
765 *
766  END