001:       SUBROUTINE CLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
002:      $                   T, LDT, C, LDC, WORK, LDWORK )
003:       IMPLICIT NONE
004: *
005: *  -- LAPACK auxiliary routine (version 3.2) --
006: *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
007: *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
008: *     November 2006
009: *
010: *     .. Scalar Arguments ..
011:       CHARACTER          DIRECT, SIDE, STOREV, TRANS
012:       INTEGER            K, LDC, LDT, LDV, LDWORK, M, N
013: *     ..
014: *     .. Array Arguments ..
015:       COMPLEX            C( LDC, * ), T( LDT, * ), V( LDV, * ),
016:      $                   WORK( LDWORK, * )
017: *     ..
018: *
019: *  Purpose
020: *  =======
021: *
022: *  CLARFB applies a complex block reflector H or its transpose H' to a
023: *  complex M-by-N matrix C, from either the left or the right.
024: *
025: *  Arguments
026: *  =========
027: *
028: *  SIDE    (input) CHARACTER*1
029: *          = 'L': apply H or H' from the Left
030: *          = 'R': apply H or H' from the Right
031: *
032: *  TRANS   (input) CHARACTER*1
033: *          = 'N': apply H (No transpose)
034: *          = 'C': apply H' (Conjugate transpose)
035: *
036: *  DIRECT  (input) CHARACTER*1
037: *          Indicates how H is formed from a product of elementary
038: *          reflectors
039: *          = 'F': H = H(1) H(2) . . . H(k) (Forward)
040: *          = 'B': H = H(k) . . . H(2) H(1) (Backward)
041: *
042: *  STOREV  (input) CHARACTER*1
043: *          Indicates how the vectors which define the elementary
044: *          reflectors are stored:
045: *          = 'C': Columnwise
046: *          = 'R': Rowwise
047: *
048: *  M       (input) INTEGER
049: *          The number of rows of the matrix C.
050: *
051: *  N       (input) INTEGER
052: *          The number of columns of the matrix C.
053: *
054: *  K       (input) INTEGER
055: *          The order of the matrix T (= the number of elementary
056: *          reflectors whose product defines the block reflector).
057: *
058: *  V       (input) COMPLEX array, dimension
059: *                                (LDV,K) if STOREV = 'C'
060: *                                (LDV,M) if STOREV = 'R' and SIDE = 'L'
061: *                                (LDV,N) if STOREV = 'R' and SIDE = 'R'
062: *          The matrix V. See further details.
063: *
064: *  LDV     (input) INTEGER
065: *          The leading dimension of the array V.
066: *          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
067: *          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
068: *          if STOREV = 'R', LDV >= K.
069: *
070: *  T       (input) COMPLEX array, dimension (LDT,K)
071: *          The triangular K-by-K matrix T in the representation of the
072: *          block reflector.
073: *
074: *  LDT     (input) INTEGER
075: *          The leading dimension of the array T. LDT >= K.
076: *
077: *  C       (input/output) COMPLEX array, dimension (LDC,N)
078: *          On entry, the M-by-N matrix C.
079: *          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
080: *
081: *  LDC     (input) INTEGER
082: *          The leading dimension of the array C. LDC >= max(1,M).
083: *
084: *  WORK    (workspace) COMPLEX array, dimension (LDWORK,K)
085: *
086: *  LDWORK  (input) INTEGER
087: *          The leading dimension of the array WORK.
088: *          If SIDE = 'L', LDWORK >= max(1,N);
089: *          if SIDE = 'R', LDWORK >= max(1,M).
090: *
091: *  =====================================================================
092: *
093: *     .. Parameters ..
094:       COMPLEX            ONE
095:       PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
096: *     ..
097: *     .. Local Scalars ..
098:       CHARACTER          TRANST
099:       INTEGER            I, J, LASTV, LASTC
100: *     ..
101: *     .. External Functions ..
102:       LOGICAL            LSAME
103:       INTEGER            ILACLR, ILACLC
104:       EXTERNAL           LSAME, ILACLR, ILACLC
105: *     ..
106: *     .. External Subroutines ..
107:       EXTERNAL           CCOPY, CGEMM, CLACGV, CTRMM
108: *     ..
109: *     .. Intrinsic Functions ..
110:       INTRINSIC          CONJG
111: *     ..
112: *     .. Executable Statements ..
113: *
114: *     Quick return if possible
115: *
116:       IF( M.LE.0 .OR. N.LE.0 )
117:      $   RETURN
118: *
119:       IF( LSAME( TRANS, 'N' ) ) THEN
120:          TRANST = 'C'
121:       ELSE
122:          TRANST = 'N'
123:       END IF
124: *
125:       IF( LSAME( STOREV, 'C' ) ) THEN
126: *
127:          IF( LSAME( DIRECT, 'F' ) ) THEN
128: *
129: *           Let  V =  ( V1 )    (first K rows)
130: *                     ( V2 )
131: *           where  V1  is unit lower triangular.
132: *
133:             IF( LSAME( SIDE, 'L' ) ) THEN
134: *
135: *              Form  H * C  or  H' * C  where  C = ( C1 )
136: *                                                  ( C2 )
137: *
138:                LASTV = MAX( K, ILACLR( M, K, V, LDV ) )
139:                LASTC = ILACLC( LASTV, N, C, LDC )
140: *
141: *              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
142: *
143: *              W := C1'
144: *
145:                DO 10 J = 1, K
146:                   CALL CCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
147:                   CALL CLACGV( LASTC, WORK( 1, J ), 1 )
148:    10          CONTINUE
149: *
150: *              W := W * V1
151: *
152:                CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
153:      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
154:                IF( LASTV.GT.K ) THEN
155: *
156: *                 W := W + C2'*V2
157: *
158:                   CALL CGEMM( 'Conjugate transpose', 'No transpose',
159:      $                 LASTC, K, LASTV-K, ONE, C( K+1, 1 ), LDC,
160:      $                 V( K+1, 1 ), LDV, ONE, WORK, LDWORK )
161:                END IF
162: *
163: *              W := W * T'  or  W * T
164: *
165:                CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
166:      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
167: *
168: *              C := C - V * W'
169: *
170:                IF( M.GT.K ) THEN
171: *
172: *                 C2 := C2 - V2 * W'
173: *
174:                   CALL CGEMM( 'No transpose', 'Conjugate transpose',
175:      $                 LASTV-K, LASTC, K, -ONE, V( K+1, 1 ), LDV,
176:      $                 WORK, LDWORK, ONE, C( K+1, 1 ), LDC )
177:                END IF
178: *
179: *              W := W * V1'
180: *
181:                CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
182:      $              'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
183: *
184: *              C1 := C1 - W'
185: *
186:                DO 30 J = 1, K
187:                   DO 20 I = 1, LASTC
188:                      C( J, I ) = C( J, I ) - CONJG( WORK( I, J ) )
189:    20             CONTINUE
190:    30          CONTINUE
191: *
192:             ELSE IF( LSAME( SIDE, 'R' ) ) THEN
193: *
194: *              Form  C * H  or  C * H'  where  C = ( C1  C2 )
195: *
196:                LASTV = MAX( K, ILACLR( N, K, V, LDV ) )
197:                LASTC = ILACLR( M, LASTV, C, LDC )
198: *
199: *              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
200: *
201: *              W := C1
202: *
203:                DO 40 J = 1, K
204:                   CALL CCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
205:    40          CONTINUE
206: *
207: *              W := W * V1
208: *
209:                CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
210:      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
211:                IF( LASTV.GT.K ) THEN
212: *
213: *                 W := W + C2 * V2
214: *
215:                   CALL CGEMM( 'No transpose', 'No transpose',
216:      $                 LASTC, K, LASTV-K,
217:      $                 ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
218:      $                 ONE, WORK, LDWORK )
219:                END IF
220: *
221: *              W := W * T  or  W * T'
222: *
223:                CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
224:      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
225: *
226: *              C := C - W * V'
227: *
228:                IF( LASTV.GT.K ) THEN
229: *
230: *                 C2 := C2 - W * V2'
231: *
232:                   CALL CGEMM( 'No transpose', 'Conjugate transpose',
233:      $                 LASTC, LASTV-K, K,
234:      $                 -ONE, WORK, LDWORK, V( K+1, 1 ), LDV,
235:      $                 ONE, C( 1, K+1 ), LDC )
236:                END IF
237: *
238: *              W := W * V1'
239: *
240:                CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
241:      $              'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
242: *
243: *              C1 := C1 - W
244: *
245:                DO 60 J = 1, K
246:                   DO 50 I = 1, LASTC
247:                      C( I, J ) = C( I, J ) - WORK( I, J )
248:    50             CONTINUE
249:    60          CONTINUE
250:             END IF
251: *
252:          ELSE
253: *
254: *           Let  V =  ( V1 )
255: *                     ( V2 )    (last K rows)
256: *           where  V2  is unit upper triangular.
257: *
258:             IF( LSAME( SIDE, 'L' ) ) THEN
259: *
260: *              Form  H * C  or  H' * C  where  C = ( C1 )
261: *                                                  ( C2 )
262: *
263:                LASTV = MAX( K, ILACLR( M, K, V, LDV ) )
264:                LASTC = ILACLC( LASTV, N, C, LDC )
265: *
266: *              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
267: *
268: *              W := C2'
269: *
270:                DO 70 J = 1, K
271:                   CALL CCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
272:      $                 WORK( 1, J ), 1 )
273:                   CALL CLACGV( LASTC, WORK( 1, J ), 1 )
274:    70          CONTINUE
275: *
276: *              W := W * V2
277: *
278:                CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
279:      $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
280:      $              WORK, LDWORK )
281:                IF( LASTV.GT.K ) THEN
282: *
283: *                 W := W + C1'*V1
284: *
285:                   CALL CGEMM( 'Conjugate transpose', 'No transpose',
286:      $                 LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
287:      $                 ONE, WORK, LDWORK )
288:                END IF
289: *
290: *              W := W * T'  or  W * T
291: *
292:                CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
293:      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
294: *
295: *              C := C - V * W'
296: *
297:                IF( LASTV.GT.K ) THEN
298: *
299: *                 C1 := C1 - V1 * W'
300: *
301:                   CALL CGEMM( 'No transpose', 'Conjugate transpose',
302:      $                 LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
303:      $                 ONE, C, LDC )
304:                END IF
305: *
306: *              W := W * V2'
307: *
308:                CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
309:      $              'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
310:      $              WORK, LDWORK )
311: *
312: *              C2 := C2 - W'
313: *
314:                DO 90 J = 1, K
315:                   DO 80 I = 1, LASTC
316:                      C( LASTV-K+J, I ) = C( LASTV-K+J, I ) -
317:      $                               CONJG( WORK( I, J ) )
318:    80             CONTINUE
319:    90          CONTINUE
320: *
321:             ELSE IF( LSAME( SIDE, 'R' ) ) THEN
322: *
323: *              Form  C * H  or  C * H'  where  C = ( C1  C2 )
324: *
325:                LASTV = MAX( K, ILACLR( N, K, V, LDV ) )
326:                LASTC = ILACLR( M, LASTV, C, LDC )
327: *
328: *              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
329: *
330: *              W := C2
331: *
332:                DO 100 J = 1, K
333:                   CALL CCOPY( LASTC, C( 1, LASTV-K+J ), 1,
334:      $                 WORK( 1, J ), 1 )
335:   100          CONTINUE
336: *
337: *              W := W * V2
338: *
339:                CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
340:      $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
341:      $              WORK, LDWORK )
342:                IF( LASTV.GT.K ) THEN
343: *
344: *                 W := W + C1 * V1
345: *
346:                   CALL CGEMM( 'No transpose', 'No transpose',
347:      $                 LASTC, K, LASTV-K,
348:      $                 ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
349:                END IF
350: *
351: *              W := W * T  or  W * T'
352: *
353:                CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
354:      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
355: *
356: *              C := C - W * V'
357: *
358:                IF( LASTV.GT.K ) THEN
359: *
360: *                 C1 := C1 - W * V1'
361: *
362:                   CALL CGEMM( 'No transpose', 'Conjugate transpose',
363:      $                 LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
364:      $                 ONE, C, LDC )
365:                END IF
366: *
367: *              W := W * V2'
368: *
369:                CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
370:      $              'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
371:      $              WORK, LDWORK )
372: *
373: *              C2 := C2 - W
374: *
375:                DO 120 J = 1, K
376:                   DO 110 I = 1, LASTC
377:                      C( I, LASTV-K+J ) = C( I, LASTV-K+J )
378:      $                    - WORK( I, J )
379:   110             CONTINUE
380:   120          CONTINUE
381:             END IF
382:          END IF
383: *
384:       ELSE IF( LSAME( STOREV, 'R' ) ) THEN
385: *
386:          IF( LSAME( DIRECT, 'F' ) ) THEN
387: *
388: *           Let  V =  ( V1  V2 )    (V1: first K columns)
389: *           where  V1  is unit upper triangular.
390: *
391:             IF( LSAME( SIDE, 'L' ) ) THEN
392: *
393: *              Form  H * C  or  H' * C  where  C = ( C1 )
394: *                                                  ( C2 )
395: *
396:                LASTV = MAX( K, ILACLC( K, M, V, LDV ) )
397:                LASTC = ILACLC( LASTV, N, C, LDC )
398: *
399: *              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
400: *
401: *              W := C1'
402: *
403:                DO 130 J = 1, K
404:                   CALL CCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
405:                   CALL CLACGV( LASTC, WORK( 1, J ), 1 )
406:   130          CONTINUE
407: *
408: *              W := W * V1'
409: *
410:                CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
411:      $                     'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
412:                IF( LASTV.GT.K ) THEN
413: *
414: *                 W := W + C2'*V2'
415: *
416:                   CALL CGEMM( 'Conjugate transpose',
417:      $                 'Conjugate transpose', LASTC, K, LASTV-K,
418:      $                 ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV,
419:      $                 ONE, WORK, LDWORK )
420:                END IF
421: *
422: *              W := W * T'  or  W * T
423: *
424:                CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
425:      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
426: *
427: *              C := C - V' * W'
428: *
429:                IF( LASTV.GT.K ) THEN
430: *
431: *                 C2 := C2 - V2' * W'
432: *
433:                   CALL CGEMM( 'Conjugate transpose',
434:      $                 'Conjugate transpose', LASTV-K, LASTC, K,
435:      $                 -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
436:      $                 ONE, C( K+1, 1 ), LDC )
437:                END IF
438: *
439: *              W := W * V1
440: *
441:                CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
442:      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
443: *
444: *              C1 := C1 - W'
445: *
446:                DO 150 J = 1, K
447:                   DO 140 I = 1, LASTC
448:                      C( J, I ) = C( J, I ) - CONJG( WORK( I, J ) )
449:   140             CONTINUE
450:   150          CONTINUE
451: *
452:             ELSE IF( LSAME( SIDE, 'R' ) ) THEN
453: *
454: *              Form  C * H  or  C * H'  where  C = ( C1  C2 )
455: *
456:                LASTV = MAX( K, ILACLC( K, N, V, LDV ) )
457:                LASTC = ILACLR( M, LASTV, C, LDC )
458: *
459: *              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
460: *
461: *              W := C1
462: *
463:                DO 160 J = 1, K
464:                   CALL CCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
465:   160          CONTINUE
466: *
467: *              W := W * V1'
468: *
469:                CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
470:      $                     'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
471:                IF( LASTV.GT.K ) THEN
472: *
473: *                 W := W + C2 * V2'
474: *
475:                   CALL CGEMM( 'No transpose', 'Conjugate transpose',
476:      $                 LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC,
477:      $                 V( 1, K+1 ), LDV, ONE, WORK, LDWORK )
478:                END IF
479: *
480: *              W := W * T  or  W * T'
481: *
482:                CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
483:      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
484: *
485: *              C := C - W * V
486: *
487:                IF( LASTV.GT.K ) THEN
488: *
489: *                 C2 := C2 - W * V2
490: *
491:                   CALL CGEMM( 'No transpose', 'No transpose',
492:      $                 LASTC, LASTV-K, K,
493:      $                 -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
494:      $                 ONE, C( 1, K+1 ), LDC )
495:                END IF
496: *
497: *              W := W * V1
498: *
499:                CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
500:      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
501: *
502: *              C1 := C1 - W
503: *
504:                DO 180 J = 1, K
505:                   DO 170 I = 1, LASTC
506:                      C( I, J ) = C( I, J ) - WORK( I, J )
507:   170             CONTINUE
508:   180          CONTINUE
509: *
510:             END IF
511: *
512:          ELSE
513: *
514: *           Let  V =  ( V1  V2 )    (V2: last K columns)
515: *           where  V2  is unit lower triangular.
516: *
517:             IF( LSAME( SIDE, 'L' ) ) THEN
518: *
519: *              Form  H * C  or  H' * C  where  C = ( C1 )
520: *                                                  ( C2 )
521: *
522:                LASTV = MAX( K, ILACLC( K, M, V, LDV ) )
523:                LASTC = ILACLC( LASTV, N, C, LDC )
524: *
525: *              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
526: *
527: *              W := C2'
528: *
529:                DO 190 J = 1, K
530:                   CALL CCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
531:      $                 WORK( 1, J ), 1 )
532:                   CALL CLACGV( LASTC, WORK( 1, J ), 1 )
533:   190          CONTINUE
534: *
535: *              W := W * V2'
536: *
537:                CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
538:      $              'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
539:      $              WORK, LDWORK )
540:                IF( LASTV.GT.K ) THEN
541: *
542: *                 W := W + C1'*V1'
543: *
544:                   CALL CGEMM( 'Conjugate transpose',
545:      $                 'Conjugate transpose', LASTC, K, LASTV-K,
546:      $                 ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
547:                END IF
548: *
549: *              W := W * T'  or  W * T
550: *
551:                CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
552:      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
553: *
554: *              C := C - V' * W'
555: *
556:                IF( LASTV.GT.K ) THEN
557: *
558: *                 C1 := C1 - V1' * W'
559: *
560:                   CALL CGEMM( 'Conjugate transpose',
561:      $                 'Conjugate transpose', LASTV-K, LASTC, K,
562:      $                 -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
563:                END IF
564: *
565: *              W := W * V2
566: *
567:                CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
568:      $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
569:      $              WORK, LDWORK )
570: *
571: *              C2 := C2 - W'
572: *
573:                DO 210 J = 1, K
574:                   DO 200 I = 1, LASTC
575:                      C( LASTV-K+J, I ) = C( LASTV-K+J, I ) -
576:      $                               CONJG( WORK( I, J ) )
577:   200             CONTINUE
578:   210          CONTINUE
579: *
580:             ELSE IF( LSAME( SIDE, 'R' ) ) THEN
581: *
582: *              Form  C * H  or  C * H'  where  C = ( C1  C2 )
583: *
584:                LASTV = MAX( K, ILACLC( K, N, V, LDV ) )
585:                LASTC = ILACLR( M, LASTV, C, LDC )
586: *
587: *              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
588: *
589: *              W := C2
590: *
591:                DO 220 J = 1, K
592:                   CALL CCOPY( LASTC, C( 1, LASTV-K+J ), 1,
593:      $                 WORK( 1, J ), 1 )
594:   220          CONTINUE
595: *
596: *              W := W * V2'
597: *
598:                CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
599:      $              'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
600:      $              WORK, LDWORK )
601:                IF( LASTV.GT.K ) THEN
602: *
603: *                 W := W + C1 * V1'
604: *
605:                   CALL CGEMM( 'No transpose', 'Conjugate transpose',
606:      $                 LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, ONE,
607:      $                 WORK, LDWORK )
608:                END IF
609: *
610: *              W := W * T  or  W * T'
611: *
612:                CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
613:      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
614: *
615: *              C := C - W * V
616: *
617:                IF( LASTV.GT.K ) THEN
618: *
619: *                 C1 := C1 - W * V1
620: *
621:                   CALL CGEMM( 'No transpose', 'No transpose',
622:      $                 LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
623:      $                 ONE, C, LDC )
624:                END IF
625: *
626: *              W := W * V2
627: *
628:                CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
629:      $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
630:      $              WORK, LDWORK )
631: *
632: *              C1 := C1 - W
633: *
634:                DO 240 J = 1, K
635:                   DO 230 I = 1, LASTC
636:                      C( I, LASTV-K+J ) = C( I, LASTV-K+J )
637:      $                    - WORK( I, J )
638:   230             CONTINUE
639:   240          CONTINUE
640: *
641:             END IF
642: *
643:          END IF
644:       END IF
645: *
646:       RETURN
647: *
648: *     End of CLARFB
649: *
650:       END
651: