164 SUBROUTINE slarft( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
172 CHARACTER direct, storev
173 INTEGER k, ldt, ldv, n
176 REAL t( ldt, * ), tau( * ), v( ldv, * )
183 parameter( one = 1.0e+0, zero = 0.0e+0 )
186 INTEGER i,
j, prevlastv, lastv
202 IF(
lsame( direct,
'F' ) )
THEN
205 prevlastv = max( i, prevlastv )
206 IF( tau( i ).EQ.zero )
THEN
217 IF(
lsame( storev,
'C' ) )
THEN
219 DO lastv = n, i+1, -1
220 IF( v( lastv, i ).NE.zero )
EXIT
223 t(
j, i ) = -tau( i ) * v( i ,
j )
225 j = min( lastv, prevlastv )
229 CALL
sgemv(
'Transpose',
j-i, i-1, -tau( i ),
230 $ v( i+1, 1 ), ldv, v( i+1, i ), 1, one,
234 DO lastv = n, i+1, -1
235 IF( v( i, lastv ).NE.zero )
EXIT
238 t(
j, i ) = -tau( i ) * v(
j , i )
240 j = min( lastv, prevlastv )
244 CALL
sgemv(
'No transpose', i-1,
j-i, -tau( i ),
245 $ v( 1, i+1 ), ldv, v( i, i+1 ), ldv,
246 $ one, t( 1, i ), 1 )
251 CALL
strmv(
'Upper',
'No transpose',
'Non-unit', i-1, t,
252 $ ldt, t( 1, i ), 1 )
255 prevlastv = max( prevlastv, lastv )
264 IF( tau( i ).EQ.zero )
THEN
276 IF(
lsame( storev,
'C' ) )
THEN
279 IF( v( lastv, i ).NE.zero )
EXIT
282 t(
j, i ) = -tau( i ) * v( n-k+i ,
j )
284 j = max( lastv, prevlastv )
288 CALL
sgemv(
'Transpose', n-k+i-
j, k-i, -tau( i ),
289 $ v(
j, i+1 ), ldv, v(
j, i ), 1, one,
294 IF( v( i, lastv ).NE.zero )
EXIT
297 t(
j, i ) = -tau( i ) * v(
j, n-k+i )
299 j = max( lastv, prevlastv )
303 CALL
sgemv(
'No transpose', k-i, n-k+i-
j,
304 $ -tau( i ), v( i+1,
j ), ldv, v( i,
j ), ldv,
305 $ one, t( i+1, i ), 1 )
310 CALL
strmv(
'Lower',
'No transpose',
'Non-unit', k-i,
311 $ t( i+1, i+1 ), ldt, t( i+1, i ), 1 )
313 prevlastv = min( prevlastv, lastv )
LOGICAL function lsame(CA, CB)
LSAME
subroutine strmv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
STRMV
subroutine sgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
SGEMV
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine slarft(DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT)
SLARFT forms the triangular factor T of a block reflector H = I - vtvH