001:       SUBROUTINE SLARFB( 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:       REAL               C( LDC, * ), T( LDT, * ), V( LDV, * ),
016:      $                   WORK( LDWORK, * )
017: *     ..
018: *
019: *  Purpose
020: *  =======
021: *
022: *  SLARFB applies a real block reflector H or its transpose H' to a
023: *  real 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: *          = 'T': apply H' (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) REAL 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) REAL 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) REAL 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. LDA >= max(1,M).
083: *
084: *  WORK    (workspace) REAL 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:       REAL               ONE
095:       PARAMETER          ( ONE = 1.0E+0 )
096: *     ..
097: *     .. Local Scalars ..
098:       CHARACTER          TRANST
099:       INTEGER            I, J, LASTV, LASTC
100: *     ..
101: *     .. External Functions ..
102:       LOGICAL            LSAME
103:       INTEGER            ILASLR, ILASLC
104:       EXTERNAL           LSAME, ILASLR, ILASLC
105: *     ..
106: *     .. External Subroutines ..
107:       EXTERNAL           SCOPY, SGEMM, STRMM
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, ILASLR( M, K, V, LDV ) )
136:                LASTC = ILASLC( 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 SCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
144:    10          CONTINUE
145: *
146: *              W := W * V1
147: *
148:                CALL STRMM( '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 SGEMM( '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 STRMM( '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 SGEMM( '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 STRMM( '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, ILASLR( N, K, V, LDV ) )
195:                LASTC = ILASLR( 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 SCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
203:    40          CONTINUE
204: *
205: *              W := W * V1
206: *
207:                CALL STRMM( '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 SGEMM( '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 STRMM( '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 SGEMM( '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 STRMM( '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, ILASLR( M, K, V, LDV ) )
262:                LASTC = ILASLC( 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 SCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
270:      $                 WORK( 1, J ), 1 )
271:    70          CONTINUE
272: *
273: *              W := W * V2
274: *
275:                CALL STRMM( '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 SGEMM( '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 STRMM( '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 SGEMM( '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 STRMM( '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, ILASLR( N, K, V, LDV ) )
322:                LASTC = ILASLR( 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 SCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
330:   100          CONTINUE
331: *
332: *              W := W * V2
333: *
334:                CALL STRMM( '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 SGEMM( '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 STRMM( '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 SGEMM( '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 STRMM( '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, ILASLC( K, M, V, LDV ) )
391:                LASTC = ILASLC( 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 SCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
399:   130          CONTINUE
400: *
401: *              W := W * V1'
402: *
403:                CALL STRMM( '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 SGEMM( '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 STRMM( '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 SGEMM( '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 STRMM( '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, ILASLC( K, N, V, LDV ) )
450:                LASTC = ILASLR( 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 SCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
458:   160          CONTINUE
459: *
460: *              W := W * V1'
461: *
462:                CALL STRMM( '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 SGEMM( '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 STRMM( '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 SGEMM( '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 STRMM( '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, ILASLC( K, M, V, LDV ) )
517:                LASTC = ILASLC( 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 SCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
525:      $                 WORK( 1, J ), 1 )
526:   190          CONTINUE
527: *
528: *              W := W * V2'
529: *
530:                CALL STRMM( '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 SGEMM( '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 STRMM( '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 SGEMM( '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 STRMM( '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, ILASLC( K, N, V, LDV ) )
577:                LASTC = ILASLR( 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 SCOPY( LASTC, C( 1, LASTV-K+J ), 1,
585:      $                 WORK( 1, J ), 1 )
586:   220          CONTINUE
587: *
588: *              W := W * V2'
589: *
590:                CALL STRMM( '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 SGEMM( '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 STRMM( '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 SGEMM( '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 STRMM( '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 )
629:      $                    - WORK( I, J )
630:   230             CONTINUE
631:   240          CONTINUE
632: *
633:             END IF
634: *
635:          END IF
636:       END IF
637: *
638:       RETURN
639: *
640: *     End of SLARFB
641: *
642:       END
643: