195 SUBROUTINE clarfb( 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 COMPLEX C( LDC, * ), T( LDT, * ), V( LDV, * ),
215 parameter( one = ( 1.0e+0, 0.0e+0 ) )
235 IF( m.LE.0 .OR. n.LE.0 )
238 IF( lsame( trans,
'N' ) )
THEN
244 IF( lsame( storev,
'C' ) )
THEN
246 IF( lsame( direct,
'F' ) )
THEN
252 IF( lsame( side,
'L' ) )
THEN
262 CALL ccopy( n, c( j, 1 ), ldc, work( 1, j ), 1 )
263 CALL clacgv( n, work( 1, j ), 1 )
268 CALL ctrmm(
'Right',
'Lower',
'No transpose',
'Unit', n,
269 $ k, one, v, ldv, work, ldwork )
274 CALL cgemm(
'Conjugate transpose',
'No transpose', n,
275 $ k, m-k, one, c( k+1, 1 ), ldc,
276 $ v( k+1, 1 ), ldv, one, work, ldwork )
281 CALL ctrmm(
'Right',
'Upper', transt,
'Non-unit', n, k,
282 $ one, t, ldt, work, ldwork )
290 CALL cgemm(
'No transpose',
'Conjugate transpose',
291 $ m-k, n, k, -one, v( k+1, 1 ), ldv, work,
292 $ ldwork, one, c( k+1, 1 ), ldc )
297 CALL ctrmm(
'Right',
'Lower',
'Conjugate transpose',
298 $
'Unit', n, k, one, v, ldv, work, ldwork )
304 c( j, i ) = c( j, i ) - conjg( work( i, j ) )
308 ELSE IF( lsame( side,
'R' ) )
THEN
317 CALL ccopy( m, c( 1, j ), 1, work( 1, j ), 1 )
322 CALL ctrmm(
'Right',
'Lower',
'No transpose',
'Unit', m,
323 $ k, one, v, ldv, work, ldwork )
328 CALL cgemm(
'No transpose',
'No transpose', m, k, n-k,
329 $ one, c( 1, k+1 ), ldc, v( k+1, 1 ), ldv,
330 $ one, work, ldwork )
335 CALL ctrmm(
'Right',
'Upper', trans,
'Non-unit', m, k,
336 $ one, t, ldt, work, ldwork )
344 CALL cgemm(
'No transpose',
'Conjugate transpose', m,
345 $ n-k, k, -one, work, ldwork, v( k+1, 1 ),
346 $ ldv, one, c( 1, k+1 ), ldc )
351 CALL ctrmm(
'Right',
'Lower',
'Conjugate transpose',
352 $
'Unit', m, k, one, v, ldv, work, ldwork )
358 c( i, j ) = c( i, j ) - work( i, j )
369 IF( lsame( side,
'L' ) )
THEN
379 CALL ccopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 )
380 CALL clacgv( n, work( 1, j ), 1 )
385 CALL ctrmm(
'Right',
'Upper',
'No transpose',
'Unit', n,
386 $ k, one, v( m-k+1, 1 ), ldv, work, ldwork )
391 CALL cgemm(
'Conjugate transpose',
'No transpose', n,
392 $ k, m-k, one, c, ldc, v, ldv, one, work,
398 CALL ctrmm(
'Right',
'Lower', transt,
'Non-unit', n, k,
399 $ one, t, ldt, work, ldwork )
407 CALL cgemm(
'No transpose',
'Conjugate transpose',
408 $ m-k, n, k, -one, v, ldv, work, ldwork,
414 CALL ctrmm(
'Right',
'Upper',
'Conjugate transpose',
415 $
'Unit', n, k, one, v( m-k+1, 1 ), ldv, work,
422 c( m-k+j, i ) = c( m-k+j, i ) -
423 $ conjg( work( i, j ) )
427 ELSE IF( lsame( side,
'R' ) )
THEN
436 CALL ccopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 )
441 CALL ctrmm(
'Right',
'Upper',
'No transpose',
'Unit', m,
442 $ k, one, v( n-k+1, 1 ), ldv, work, ldwork )
447 CALL cgemm(
'No transpose',
'No transpose', m, k, n-k,
448 $ one, c, ldc, v, ldv, one, work, ldwork )
453 CALL ctrmm(
'Right',
'Lower', trans,
'Non-unit', m, k,
454 $ one, t, ldt, work, ldwork )
462 CALL cgemm(
'No transpose',
'Conjugate transpose', m,
463 $ n-k, k, -one, work, ldwork, v, ldv, one,
469 CALL ctrmm(
'Right',
'Upper',
'Conjugate transpose',
470 $
'Unit', m, k, one, v( n-k+1, 1 ), ldv, work,
477 c( i, n-k+j ) = c( i, n-k+j ) - work( i, j )
483 ELSE IF( lsame( storev,
'R' ) )
THEN
485 IF( lsame( direct,
'F' ) )
THEN
490 IF( lsame( side,
'L' ) )
THEN
500 CALL ccopy( n, c( j, 1 ), ldc, work( 1, j ), 1 )
501 CALL clacgv( n, work( 1, j ), 1 )
506 CALL ctrmm(
'Right',
'Upper',
'Conjugate transpose',
507 $
'Unit', n, k, one, v, ldv, work, ldwork )
512 CALL cgemm(
'Conjugate transpose',
513 $
'Conjugate transpose', n, k, m-k, one,
514 $ c( k+1, 1 ), ldc, v( 1, k+1 ), ldv, one,
520 CALL ctrmm(
'Right',
'Upper', transt,
'Non-unit', n, k,
521 $ one, t, ldt, work, ldwork )
529 CALL cgemm(
'Conjugate transpose',
530 $
'Conjugate transpose', m-k, n, k, -one,
531 $ v( 1, k+1 ), ldv, work, ldwork, one,
537 CALL ctrmm(
'Right',
'Upper',
'No transpose',
'Unit', n,
538 $ k, one, v, ldv, work, ldwork )
544 c( j, i ) = c( j, i ) - conjg( work( i, j ) )
548 ELSE IF( lsame( side,
'R' ) )
THEN
557 CALL ccopy( m, c( 1, j ), 1, work( 1, j ), 1 )
562 CALL ctrmm(
'Right',
'Upper',
'Conjugate transpose',
563 $
'Unit', m, k, one, v, ldv, work, ldwork )
568 CALL cgemm(
'No transpose',
'Conjugate transpose', m,
569 $ k, n-k, one, c( 1, k+1 ), ldc,
570 $ v( 1, k+1 ), ldv, one, work, ldwork )
575 CALL ctrmm(
'Right',
'Upper', trans,
'Non-unit', m, k,
576 $ one, t, ldt, work, ldwork )
584 CALL cgemm(
'No transpose',
'No transpose', m, n-k, k,
585 $ -one, work, ldwork, v( 1, k+1 ), ldv, one,
591 CALL ctrmm(
'Right',
'Upper',
'No transpose',
'Unit', m,
592 $ k, one, v, ldv, work, ldwork )
598 c( i, j ) = c( i, j ) - work( i, j )
609 IF( lsame( side,
'L' ) )
THEN
619 CALL ccopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 )
620 CALL clacgv( n, work( 1, j ), 1 )
625 CALL ctrmm(
'Right',
'Lower',
'Conjugate transpose',
626 $
'Unit', n, k, one, v( 1, m-k+1 ), ldv, work,
632 CALL cgemm(
'Conjugate transpose',
633 $
'Conjugate transpose', n, k, m-k, one, c,
634 $ ldc, v, ldv, one, work, ldwork )
639 CALL ctrmm(
'Right',
'Lower', transt,
'Non-unit', n, k,
640 $ one, t, ldt, work, ldwork )
648 CALL cgemm(
'Conjugate transpose',
649 $
'Conjugate transpose', m-k, n, k, -one, v,
650 $ ldv, work, ldwork, one, c, ldc )
655 CALL ctrmm(
'Right',
'Lower',
'No transpose',
'Unit', n,
656 $ k, one, v( 1, m-k+1 ), ldv, work, ldwork )
662 c( m-k+j, i ) = c( m-k+j, i ) -
663 $ conjg( work( i, j ) )
667 ELSE IF( lsame( side,
'R' ) )
THEN
676 CALL ccopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 )
681 CALL ctrmm(
'Right',
'Lower',
'Conjugate transpose',
682 $
'Unit', m, k, one, v( 1, n-k+1 ), ldv, work,
688 CALL cgemm(
'No transpose',
'Conjugate transpose', m,
689 $ k, n-k, one, c, ldc, v, ldv, one, work,
695 CALL ctrmm(
'Right',
'Lower', trans,
'Non-unit', m, k,
696 $ one, t, ldt, work, ldwork )
704 CALL cgemm(
'No transpose',
'No transpose', m, n-k, k,
705 $ -one, work, ldwork, v, ldv, one, c, ldc )
710 CALL ctrmm(
'Right',
'Lower',
'No transpose',
'Unit', m,
711 $ k, one, v( 1, n-k+1 ), ldv, work, ldwork )
717 c( i, n-k+j ) = c( i, n-k+j ) - work( i, j )
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM
subroutine ctrmm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
CTRMM
subroutine clacgv(N, X, INCX)
CLACGV conjugates a complex vector.
subroutine clarfb(SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, T, LDT, C, LDC, WORK, LDWORK)
CLARFB applies a block reflector or its conjugate-transpose to a general rectangular matrix.