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 )
414 c( m-k+j, i ) = c( m-k+j, i ) - work( i, j )
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 )
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
subroutine dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
DGEMM
subroutine dlarfb(side, trans, direct, storev, m, n, k, v, ldv, t, ldt, c, ldc, work, ldwork)
DLARFB applies a block reflector or its transpose to a general rectangular matrix.
subroutine dtrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
DTRMM