180 SUBROUTINE csprfs( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX,
181 $ ferr, berr, work, rwork, info )
190 INTEGER info, ldb, ldx, n, nrhs
194 REAL berr( * ), ferr( * ), rwork( * )
195 COMPLEX afp( * ), ap( * ),
b( ldb, * ), work( * ),
203 parameter( itmax = 5 )
205 parameter( zero = 0.0e+0 )
207 parameter( one = ( 1.0e+0, 0.0e+0 ) )
209 parameter( two = 2.0e+0 )
211 parameter( three = 3.0e+0 )
215 INTEGER count, i, ik,
j, k, kase, kk, nz
216 REAL eps, lstres, s, safe1, safe2, safmin, xk
226 INTRINSIC abs, aimag, max, real
237 cabs1( zdum ) = abs(
REAL( ZDUM ) ) + abs( aimag( zdum ) )
244 upper =
lsame( uplo,
'U' )
245 IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
247 ELSE IF( n.LT.0 )
THEN
249 ELSE IF( nrhs.LT.0 )
THEN
251 ELSE IF( ldb.LT.max( 1, n ) )
THEN
253 ELSE IF( ldx.LT.max( 1, n ) )
THEN
257 CALL
xerbla(
'CSPRFS', -info )
263 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
275 safmin =
slamch(
'Safe minimum' )
291 CALL
ccopy( n,
b( 1,
j ), 1, work, 1 )
292 CALL
cspmv( uplo, n, -one, ap, x( 1,
j ), 1, one, work, 1 )
304 rwork( i ) = cabs1(
b( i,
j ) )
313 xk = cabs1( x( k,
j ) )
316 rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
317 s = s + cabs1( ap( ik ) )*cabs1( x( i,
j ) )
320 rwork( k ) = rwork( k ) + cabs1( ap( kk+k-1 ) )*xk + s
326 xk = cabs1( x( k,
j ) )
327 rwork( k ) = rwork( k ) + cabs1( ap( kk ) )*xk
330 rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
331 s = s + cabs1( ap( ik ) )*cabs1( x( i,
j ) )
334 rwork( k ) = rwork( k ) + s
340 IF( rwork( i ).GT.safe2 )
THEN
341 s = max( s, cabs1( work( i ) ) / rwork( i ) )
343 s = max( s, ( cabs1( work( i ) )+safe1 ) /
344 $ ( rwork( i )+safe1 ) )
355 IF( berr(
j ).GT.eps .AND. two*berr(
j ).LE.lstres .AND.
356 $ count.LE.itmax )
THEN
360 CALL
csptrs( uplo, n, 1, afp, ipiv, work, n, info )
361 CALL
caxpy( n, one, work, 1, x( 1,
j ), 1 )
390 IF( rwork( i ).GT.safe2 )
THEN
391 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
393 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
400 CALL
clacn2( n, work( n+1 ), work, ferr(
j ), kase, isave )
406 CALL
csptrs( uplo, n, 1, afp, ipiv, work, n, info )
408 work( i ) = rwork( i )*work( i )
410 ELSE IF( kase.EQ.2 )
THEN
415 work( i ) = rwork( i )*work( i )
417 CALL
csptrs( uplo, n, 1, afp, ipiv, work, n, info )
426 lstres = max( lstres, cabs1( x( i,
j ) ) )
429 $ ferr(
j ) = ferr(
j ) / lstres
subroutine caxpy(N, CA, CX, INCX, CY, INCY)
CAXPY
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
logical function lsame(CA, CB)
LSAME
subroutine cspmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
CSPMV computes a matrix-vector product for complex vectors using a complex symmetric packed matrix ...
real function slamch(CMACH)
SLAMCH
subroutine csprfs(UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CSPRFS
subroutine csptrs(UPLO, N, NRHS, AP, IPIV, B, LDB, INFO)
CSPTRS
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine clacn2(N, V, X, EST, KASE, ISAVE)
CLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...