195 SUBROUTINE dlarfb( 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, LDWORK, M, N
207 DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ),
215 parameter( one = 1.0d+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 dcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 )
264 CALL dtrmm(
'Right',
'Lower',
'No transpose',
'Unit', n,
265 $ k, one, v, ldv, work, ldwork )
270 CALL dgemm(
'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 dtrmm(
'Right',
'Upper', transt,
'Non-unit', n, k,
278 $ one, t, ldt, work, ldwork )
286 CALL dgemm(
'No transpose',
'Transpose', m-k, n, k,
287 $ -one, v( k+1, 1 ), ldv, work, ldwork, one,
293 CALL dtrmm(
'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 DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
318 CALL DTRMM( 'right
', 'lower
', 'no transpose
', 'unit
', M,
319 $ K, ONE, V, LDV, WORK, LDWORK )
324 CALL DGEMM( '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 DTRMM( 'right
', 'upper
', TRANS, 'non-unit
', M, K,
332 $ ONE, T, LDT, WORK, LDWORK )
340 CALL DGEMM( 'no transpose
', 'transpose
', M, N-K, K,
341 $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
347 CALL DTRMM( '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 DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
380 CALL DTRMM( 'right',
'Upper',
'No transpose',
'Unit', n,
381 $ k, one, v( m-k+1, 1 ), ldv, work, ldwork )
386 CALL dgemm(
'Transpose',
'No transpose', n, k, m-k,
387 $ one, c, ldc, v, ldv, one, work, ldwork )
392 CALL dtrmm(
'Right',
'Lower', transt,
'Non-unit', n, k,
393 $ one, t, ldt, work, ldwork )
401 CALL dgemm(
'No transpose',
'Transpose', m-k, n, k,
402 $ -one, v, ldv, work, ldwork, one, c, ldc )
407 CALL dtrmm(
'Right',
'Upper',
'Transpose',
'Unit', n, k,
408 $ one, v( m-k+1, 1 ), ldv, work, ldwork )
418 ELSE IF( lsame( side, 'r
' ) ) THEN
427 CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
432 CALL DTRMM( 'right
', 'upper
', 'no transpose
', 'unit
', M,
433 $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
438 CALL DGEMM( 'no transpose
', 'no transpose
', M, K, N-K,
439 $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
444 CALL DTRMM( 'right
', 'lower', trans,
'Non-unit', m, k,
445 $ one, t, ldt, work, ldwork )
453 CALL dgemm(
'No transpose',
'Transpose', m, n-k, k,
454 $ -one, work, ldwork, v, ldv, one, c, ldc )
459 CALL dtrmm(
'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 dcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 )
494 CALL dtrmm(
'Right',
'Upper',
'Transpose',
'Unit', n, k,
495 $ one, v, ldv, work, ldwork )
500 CALL dgemm(
'Transpose',
'Transpose', n, k, m-k, one,
501 $ c( k+1, 1 ), ldc, v( 1, k+1 ), ldv, one,
507 CALL dtrmm(
'Right',
'Upper', transt,
'Non-unit', n, k,
508 $ one, t, ldt, work, ldwork )
516 CALL dgemm(
'Transpose',
'Transpose', m-k, n, k, -one,
517 $ v( 1, k+1 ), ldv, work, ldwork, one,
523 CALL dtrmm(
'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 dcopy( m, c( 1, j ), 1, work( 1, j ), 1 )
548 CALL dtrmm(
'Right',
'Upper',
'Transpose',
'Unit', m, k,
549 $ one, v, ldv, work, ldwork )
554 CALL dgemm(
'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 dtrmm(
'Right',
'Upper', trans,
'Non-unit', m, k,
562 $ one, t, ldt, work, ldwork )
570 CALL dgemm(
'No transpose',
'No transpose', m, n-k, k,
571 $ -one, work, ldwork, v( 1, k+1 ), ldv, one,
577 CALL dtrmm(
'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 dcopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 )
610 CALL dtrmm(
'Right',
'Lower',
'Transpose',
'Unit', n, k,
611 $ one, v( 1, m-k+1 ), ldv, work, ldwork )
616 CALL dgemm(
'Transpose',
'Transpose', n, k, m-k, one,
617 $ c, ldc, v, ldv, one, work, ldwork )
622 CALL dtrmm(
'Right', 'lower
', TRANST, 'non-unit
', N, K,
623 $ ONE, T, LDT, WORK, LDWORK )
631 CALL DGEMM( 'transpose
', 'transpose
', M-K, N, K, -ONE,
632 $ V, LDV, WORK, LDWORK, ONE, C, LDC )
637 CALL DTRMM( '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 DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
662 CALL DTRMM( 'right
', 'lower
', 'transpose
', 'unit
', M, K,
663 $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
668 CALL DGEMM( 'no transpose
', 'transpose
', M, K, N-K,
669 $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
674 CALL DTRMM( 'right
', 'lower', trans,
'Non-unit', m, k,
675 $ one, t, ldt, work, ldwork )
683 CALL dgemm(
'No transpose',
'No transpose', m, n-k, k,
684 $ -one, work, ldwork, v, ldv, one, c, ldc )
689 CALL dtrmm(
'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 )