183 SUBROUTINE slarzb( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V,
184 $ ldv, t, ldt, c, ldc, work, ldwork )
192 CHARACTER direct, side, storev, trans
193 INTEGER k, l, ldc, ldt, ldv, ldwork, m, n
196 REAL c( ldc, * ), t( ldt, * ), v( ldv, * ),
204 parameter( one = 1.0e+0 )
221 IF( m.LE.0 .OR. n.LE.0 )
227 IF( .NOT.
lsame( direct,
'B' ) )
THEN
229 ELSE IF( .NOT.
lsame( storev,
'R' ) )
THEN
233 CALL
xerbla(
'SLARZB', -info )
237 IF(
lsame( trans,
'N' ) )
THEN
243 IF(
lsame( side,
'L' ) )
THEN
250 CALL
scopy( n, c(
j, 1 ), ldc, work( 1,
j ), 1 )
257 $ CALL
sgemm(
'Transpose',
'Transpose', n, k, l, one,
258 $ c( m-l+1, 1 ), ldc, v, ldv, one, work, ldwork )
262 CALL
strmm(
'Right',
'Lower', transt,
'Non-unit', n, k, one, t,
263 $ ldt, work, ldwork )
269 c( i,
j ) = c( i,
j ) - work(
j, i )
277 $ CALL
sgemm(
'Transpose',
'Transpose', l, n, k, -one, v, ldv,
278 $ work, ldwork, one, c( m-l+1, 1 ), ldc )
280 ELSE IF(
lsame( side,
'R' ) )
THEN
287 CALL
scopy( m, c( 1,
j ), 1, work( 1,
j ), 1 )
294 $ CALL
sgemm(
'No transpose',
'Transpose', m, k, l, one,
295 $ c( 1, n-l+1 ), ldc, v, ldv, one, work, ldwork )
299 CALL
strmm(
'Right',
'Lower', trans,
'Non-unit', m, k, one, t,
300 $ ldt, work, ldwork )
306 c( i,
j ) = c( i,
j ) - work( i,
j )
314 $ CALL
sgemm(
'No transpose',
'No transpose', m, l, k, -one,
315 $ work, ldwork, v, ldv, one, c( 1, n-l+1 ), ldc )
LOGICAL function lsame(CA, CB)
LSAME
subroutine slarzb(SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, C, LDC, WORK, LDWORK)
SLARZB applies a block reflector or its transpose to a general matrix.
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine strmm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
STRMM
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j