191 SUBROUTINE dsyrfs( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
192 $
x, ldx, ferr, berr, work, iwork, info )
201 INTEGER info, lda, ldaf, ldb, ldx, n, nrhs
204 INTEGER ipiv( * ), iwork( * )
205 DOUBLE PRECISION a( lda, * ), af( ldaf, * ),
b( ldb, * ),
206 $ berr( * ), ferr( * ), work( * ),
x( ldx, * )
213 parameter( itmax = 5 )
214 DOUBLE PRECISION zero
215 parameter( zero = 0.0d+0 )
217 parameter( one = 1.0d+0 )
219 parameter( two = 2.0d+0 )
220 DOUBLE PRECISION three
221 parameter( three = 3.0d+0 )
225 INTEGER count, i,
j, k, kase, nz
226 DOUBLE PRECISION eps, lstres, s, safe1, safe2, safmin, xk
247 upper =
lsame( uplo,
'U' )
248 IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
250 ELSE IF( n.LT.0 )
THEN
252 ELSE IF( nrhs.LT.0 )
THEN
254 ELSE IF( lda.LT.max( 1, n ) )
THEN
256 ELSE IF( ldaf.LT.max( 1, n ) )
THEN
258 ELSE IF( ldb.LT.max( 1, n ) )
THEN
260 ELSE IF( ldx.LT.max( 1, n ) )
THEN
264 CALL
xerbla(
'DSYRFS', -info )
270 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
282 safmin =
dlamch(
'Safe minimum' )
298 CALL
dcopy( n,
b( 1,
j ), 1, work( n+1 ), 1 )
299 CALL
dsymv( uplo, n, -one, a, lda,
x( 1,
j ), 1, one,
312 work( i ) = abs(
b( i,
j ) )
320 xk = abs(
x( k,
j ) )
322 work( i ) = work( i ) + abs( a( i, k ) )*xk
323 s = s + abs( a( i, k ) )*abs(
x( i,
j ) )
325 work( k ) = work( k ) + abs( a( k, k ) )*xk + s
330 xk = abs(
x( k,
j ) )
331 work( k ) = work( k ) + abs( a( k, k ) )*xk
333 work( i ) = work( i ) + abs( a( i, k ) )*xk
334 s = s + abs( a( i, k ) )*abs(
x( i,
j ) )
336 work( k ) = work( k ) + s
341 IF( work( i ).GT.safe2 )
THEN
342 s = max( s, abs( work( n+i ) ) / work( i ) )
344 s = max( s, ( abs( work( n+i ) )+safe1 ) /
345 $ ( work( i )+safe1 ) )
356 IF( berr(
j ).GT.eps .AND. two*berr(
j ).LE.lstres .AND.
357 $ count.LE.itmax )
THEN
361 CALL
dsytrs( uplo, n, 1, af, ldaf, ipiv, work( n+1 ), n,
363 CALL
daxpy( n, one, work( n+1 ), 1,
x( 1,
j ), 1 )
392 IF( work( i ).GT.safe2 )
THEN
393 work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
395 work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
401 CALL
dlacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr(
j ),
408 CALL
dsytrs( uplo, n, 1, af, ldaf, ipiv, work( n+1 ), n,
411 work( n+i ) = work( i )*work( n+i )
413 ELSE IF( kase.EQ.2 )
THEN
418 work( n+i ) = work( i )*work( n+i )
420 CALL
dsytrs( uplo, n, 1, af, ldaf, ipiv, work( n+1 ), n,
430 lstres = max( lstres, abs(
x( i,
j ) ) )
433 $ ferr(
j ) = ferr(
j ) / lstres
LOGICAL function lsame(CA, CB)
LSAME
subroutine dsyrfs(UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
DSYRFS
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine daxpy(N, DA, DX, INCX, DY, INCY)
DAXPY
subroutine dlacn2(N, V, X, ISGN, EST, KASE, ISAVE)
DLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...
subroutine dsytrs(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
DSYTRS
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
subroutine dsymv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
DSYMV