175 SUBROUTINE stprfs( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX,
176 $ ferr, berr, work, iwork, info )
184 CHARACTER diag, trans, uplo
185 INTEGER info, ldb, ldx, n, nrhs
189 REAL ap( * ),
b( ldb, * ), berr( * ), ferr( * ),
190 $ work( * ),
x( ldx, * )
197 parameter( zero = 0.0e+0 )
199 parameter( one = 1.0e+0 )
202 LOGICAL notran, nounit, upper
204 INTEGER i,
j, k, kase, kc, nz
205 REAL eps, lstres, s, safe1, safe2, safmin, xk
226 upper =
lsame( uplo,
'U' )
227 notran =
lsame( trans,
'N' )
228 nounit =
lsame( diag,
'N' )
230 IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
232 ELSE IF( .NOT.notran .AND. .NOT.
lsame( trans,
'T' ) .AND. .NOT.
233 $
lsame( trans,
'C' ) )
THEN
235 ELSE IF( .NOT.nounit .AND. .NOT.
lsame( diag,
'U' ) )
THEN
237 ELSE IF( n.LT.0 )
THEN
239 ELSE IF( nrhs.LT.0 )
THEN
241 ELSE IF( ldb.LT.max( 1, n ) )
THEN
243 ELSE IF( ldx.LT.max( 1, n ) )
THEN
247 CALL
xerbla(
'STPRFS', -info )
253 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
271 safmin =
slamch(
'Safe minimum' )
282 CALL
scopy( n,
x( 1,
j ), 1, work( n+1 ), 1 )
283 CALL
stpmv( uplo, trans, diag, n, ap, work( n+1 ), 1 )
284 CALL
saxpy( n, -one,
b( 1,
j ), 1, work( n+1 ), 1 )
296 work( i ) = abs(
b( i,
j ) )
307 xk = abs(
x( k,
j ) )
309 work( i ) = work( i ) + abs( ap( kc+i-1 ) )*xk
315 xk = abs(
x( k,
j ) )
317 work( i ) = work( i ) + abs( ap( kc+i-1 ) )*xk
319 work( k ) = work( k ) + xk
327 xk = abs(
x( k,
j ) )
329 work( i ) = work( i ) + abs( ap( kc+i-k ) )*xk
335 xk = abs(
x( k,
j ) )
337 work( i ) = work( i ) + abs( ap( kc+i-k ) )*xk
339 work( k ) = work( k ) + xk
354 s = s + abs( ap( kc+i-1 ) )*abs(
x( i,
j ) )
356 work( k ) = work( k ) + s
363 s = s + abs( ap( kc+i-1 ) )*abs(
x( i,
j ) )
365 work( k ) = work( k ) + s
375 s = s + abs( ap( kc+i-k ) )*abs(
x( i,
j ) )
377 work( k ) = work( k ) + s
384 s = s + abs( ap( kc+i-k ) )*abs(
x( i,
j ) )
386 work( k ) = work( k ) + s
394 IF( work( i ).GT.safe2 )
THEN
395 s = max( s, abs( work( n+i ) ) / work( i ) )
397 s = max( s, ( abs( work( n+i ) )+safe1 ) /
398 $ ( work( i )+safe1 ) )
426 IF( work( i ).GT.safe2 )
THEN
427 work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
429 work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
435 CALL
slacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr(
j ),
442 CALL
stpsv( uplo, transt, diag, n, ap, work( n+1 ), 1 )
444 work( n+i ) = work( i )*work( n+i )
451 work( n+i ) = work( i )*work( n+i )
453 CALL
stpsv( uplo, trans, diag, n, ap, work( n+1 ), 1 )
462 lstres = max( lstres, abs(
x( i,
j ) ) )
465 $ ferr(
j ) = ferr(
j ) / lstres
LOGICAL function lsame(CA, CB)
LSAME
subroutine stprfs(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
STPRFS
REAL function slamch(CMACH)
SLAMCH
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine saxpy(N, SA, SX, INCX, SY, INCY)
SAXPY
subroutine stpmv(UPLO, TRANS, DIAG, N, AP, X, INCX)
STPMV
subroutine slacn2(N, V, X, ISGN, EST, KASE, ISAVE)
SLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...
subroutine stpsv(UPLO, TRANS, DIAG, N, AP, X, INCX)
STPSV
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j