195 SUBROUTINE slarfb( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
196 $ T, LDT, C, LDC, WORK, LDWORK )
203 CHARACTER DIRECT, SIDE, STOREV, TRANS
204 INTEGER K, LDC, LDT, LDV, , M, N
207 REAL C( LDC, * ), T( LDT, * ), V( LDV, * ),
215 parameter( one = 1.0e+0 )
232 IF( m.LE.0 .OR. n.LE.0 )
235 IF( lsame( trans,
'N' ) )
THEN
241 IF( lsame( storev,
'C' ) )
THEN
243 IF( lsame( direct,
'F' ) )
THEN
249 IF( lsame( side,
'L' ) )
THEN
259 CALL scopy( n, c( j, 1 ), ldc, work( 1, j ), 1 )
264 CALL strmm(
'Right',
'Lower',
'No transpose',
'Unit', n,
265 $ k, one, v, ldv, work, ldwork )
270 CALL sgemm(
'Transpose',
'No transpose', n, k, m-k,
271 $ one, c( k+1, 1 ), ldc, v( k+1, 1 ), ldv,
272 $ one, work, ldwork )
277 CALL strmm(
'Right',
'Upper', transt,
'Non-unit', n, k,
278 $ one, t, ldt, work, ldwork )
286 CALL sgemm(
'No transpose',
'Transpose', m-k, n, k,
287 $ -one, v( k+1, 1 ), ldv, work, ldwork, one,
293 CALL strmm(
'Right',
'Lower',
'Transpose',
'Unit', n, k,
294 $ one, v, ldv, work, ldwork )
300 c( j, i ) = c( j, i ) - work( i, j )
304 ELSE IF( lsame( side,
'R' ) )
THEN
313 CALL scopy( m, c( 1, j ), 1, work( 1, j ), 1 )
318 CALL strmm(
'Right',
'Lower',
'No transpose',
'Unit', m,
319 $ k, one, v, ldv, work, ldwork )
324 CALL sgemm(
'No transpose',
'No transpose', m, k, n-k,
325 $ one, c( 1, k+1 ), ldc, v( k+1, 1 ), ldv,
326 $ one, work, ldwork )
331 CALL strmm(
'Right',
'Upper', trans,
'Non-unit', m, k,
332 $ one, t, ldt, work, ldwork )
340 CALL sgemm(
'No transpose',
'Transpose', m, n-k, k,
341 $ -one, work, ldwork, v( k+1, 1 ), ldv, one,
347 CALL strmm(
'Right',
'Lower',
'Transpose',
'Unit', m, k,
348 $ one, v, ldv, work, ldwork )
354 c( i, j ) = c( i, j ) - work( i, j )
365 IF( lsame( side,
'L' ) )
THEN
375 CALL scopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 )
380 CALL strmm(
'Right',
'Upper',
'No transpose',
'Unit', n,
381 $ k, one, v( m-k+1, 1 ), ldv, work, ldwork )
386 CALL sgemm(
'Transpose',
'No transpose', n, k, m-k,
387 $ one, c, ldc, v, ldv, one, work, ldwork )
392 CALL strmm(
'Right',
'Lower', transt,
'Non-unit', n
393 $ one, t, ldt, work, ldwork )
401 CALL sgemm(
'No transpose',
'Transpose', m-k, n, k,
402 $ -one, v, ldv, work, ldwork, one, c, ldc )
407 CALL strmm(
'Right',
'Upper',
'Transpose',
'Unit', n, k,
414 c( m-k+j, i ) = c( m-k+j, i ) - work( i, j )
418 ELSE IF( lsame( side,
'R' ) )
THEN
427 CALL scopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 )
432 CALL strmm(
'Right',
'Upper',
'No transpose',
'Unit', m,
433 $ k, one, v( n-k+1, 1 ), ldv, work, ldwork )
438 CALL sgemm(
'No transpose',
'No transpose', m, k, n-k,
439 $ one, c, ldc, v, ldv, one, work, ldwork )
444 CALL strmm(
'Right',
'Lower', trans,
'Non-unit', m, k,
445 $ one, t, ldt, work, ldwork )
453 CALL sgemm(
'No transpose',
'Transpose', m, n-k, k,
454 $ -one, work, ldwork, v, ldv, one, c, ldc )
459 CALL strmm(
'Right',
'Upper',
'Transpose',
'Unit', m, k,
460 $ one, v( n-k+1, 1 ), ldv, work, ldwork )
466 c( i, n-k+j ) = c( i, n-k+j ) - work( i, j )
472 ELSE IF( lsame( storev,
'R' ) )
THEN
474 IF( lsame( direct,
'F' ) )
THEN
479 IF( lsame( side,
'L' ) )
THEN
489 CALL scopy( n, c( j, 1 ), ldc, work( 1, j ), 1 )
494 CALL strmm(
'Right',
'Upper',
'Transpose',
'Unit', n, k,
495 $ one, v, ldv, work, ldwork )
500 CALL sgemm(
'Transpose',
'Transpose', n, k, m-k, one,
501 $ c( k+1, 1 ), ldc, v( 1, k+1 ), ldv, one,
507 CALL strmm(
'Right',
'Upper', transt,
'Non-unit', n, k,
508 $ one, t, ldt, work, ldwork )
516 CALL sgemm(
'Transpose',
'Transpose', m-k, n, k, -one,
517 $ v( 1, k+1 ), ldv, work, ldwork, one,
523 CALL strmm(
'Right',
'Upper',
'No transpose',
'Unit', n,
524 $ k, one, v, ldv, work, ldwork )
530 c( j, i ) = c( j, i ) - work( i, j )
534 ELSE IF( lsame( side,
'R' ) )
THEN
543 CALL scopy( m, c( 1, j ), 1, work( 1, j ), 1 )
548 CALL strmm(
'Right',
'Upper',
'Transpose', 'unit
', M, K,
549 $ ONE, V, LDV, WORK, LDWORK )
554 CALL SGEMM( 'no transpose
', 'transpose
', M, K, N-K,
555 $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
556 $ ONE, WORK, LDWORK )
561 CALL STRMM( 'right
', 'upper
', TRANS, 'non-unit
', M, K,
562 $ ONE, T, LDT, WORK, LDWORK )
570 CALL SGEMM( 'no transpose
', 'no transpose
', M, N-K, K,
571 $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
577 CALL STRMM( 'right
', 'upper
', 'no transpose
', 'unit
', M,
578 $ K, ONE, V, LDV, WORK, LDWORK )
584 C( I, J ) = C( I, J ) - WORK( I, J )
595 IF( LSAME( SIDE, 'l
' ) ) THEN
605 CALL SCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
610 CALL STRMM( 'right
', 'lower
', 'transpose
', 'unit
', N, K,
611 $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
616 CALL SGEMM( 'transpose
', 'transpose
', N, K, M-K, ONE,
617 $ C, LDC, V, LDV, ONE, WORK, LDWORK )
622 CALL STRMM( 'right
', 'lower
', TRANST, 'non-unit
', N, K,
623 $ ONE, T, LDT, WORK, LDWORK )
631 CALL SGEMM( 'transpose
', 'transpose
', M-K, N, K, -ONE,
632 $ V, LDV, WORK, LDWORK, ONE, C, LDC )
637 CALL STRMM( 'right
', 'lower
', 'no transpose
', 'unit
', N,
638 $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
644 C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
648 ELSE IF( LSAME( SIDE, 'r
' ) ) THEN
657 CALL SCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
662 CALL STRMM( 'right
', 'lower
', 'transpose
', 'unit
', M, K,
663 $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
668 CALL SGEMM( 'no transpose
', 'transpose
', M, K, N-K,
669 $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
674 CALL STRMM( 'right
', 'lower
', TRANS, 'non-unit
', M, K,
675 $ ONE, T, LDT, WORK, LDWORK )
683 CALL SGEMM( 'no transpose
', 'no transpose
', M, N-K, K,
684 $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
689 CALL STRMM( 'right
', 'lower
', 'no transpose
', 'unit
', M,
690 $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
696 C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )