183 SUBROUTINE cporfs( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X,
184 $ ldx, ferr, berr, work, rwork, info )
193 INTEGER info, lda, ldaf, ldb, ldx, n, nrhs
196 REAL berr( * ), ferr( * ), rwork( * )
197 COMPLEX a( lda, * ), af( ldaf, * ),
b( ldb, * ),
198 $ work( * ), x( ldx, * )
205 parameter( itmax = 5 )
207 parameter( zero = 0.0e+0 )
209 parameter( one = ( 1.0e+0, 0.0e+0 ) )
211 parameter( two = 2.0e+0 )
213 parameter( three = 3.0e+0 )
217 INTEGER count, i,
j, k, kase, nz
218 REAL eps, lstres, s, safe1, safe2, safmin, xk
228 INTRINSIC abs, aimag, max, real
239 cabs1( zdum ) = abs(
REAL( ZDUM ) ) + abs( aimag( zdum ) )
246 upper =
lsame( uplo,
'U' )
247 IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
249 ELSE IF( n.LT.0 )
THEN
251 ELSE IF( nrhs.LT.0 )
THEN
253 ELSE IF( lda.LT.max( 1, n ) )
THEN
255 ELSE IF( ldaf.LT.max( 1, n ) )
THEN
257 ELSE IF( ldb.LT.max( 1, n ) )
THEN
259 ELSE IF( ldx.LT.max( 1, n ) )
THEN
263 CALL
xerbla(
'CPORFS', -info )
269 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
281 safmin =
slamch(
'Safe minimum' )
297 CALL
ccopy( n,
b( 1,
j ), 1, work, 1 )
298 CALL
chemv( uplo, n, -one, a, lda, x( 1,
j ), 1, one, work, 1 )
310 rwork( i ) = cabs1(
b( i,
j ) )
318 xk = cabs1( x( k,
j ) )
320 rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
321 s = s + cabs1( a( i, k ) )*cabs1( x( i,
j ) )
323 rwork( k ) = rwork( k ) + abs(
REAL( A( K, K ) ) )*xk + s
328 xk = cabs1( x( k,
j ) )
329 rwork( k ) = rwork( k ) + abs(
REAL( A( K, K ) ) )*xk
331 rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
332 s = s + cabs1( a( i, k ) )*cabs1( x( i,
j ) )
334 rwork( k ) = rwork( k ) + s
339 IF( rwork( i ).GT.safe2 )
THEN
340 s = max( s, cabs1( work( i ) ) / rwork( i ) )
342 s = max( s, ( cabs1( work( i ) )+safe1 ) /
343 $ ( rwork( i )+safe1 ) )
354 IF( berr(
j ).GT.eps .AND. two*berr(
j ).LE.lstres .AND.
355 $ count.LE.itmax )
THEN
359 CALL
cpotrs( uplo, n, 1, af, ldaf, work, n, info )
360 CALL
caxpy( n, one, work, 1, x( 1,
j ), 1 )
389 IF( rwork( i ).GT.safe2 )
THEN
390 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
392 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
399 CALL
clacn2( n, work( n+1 ), work, ferr(
j ), kase, isave )
405 CALL
cpotrs( uplo, n, 1, af, ldaf, work, n, info )
407 work( i ) = rwork( i )*work( i )
409 ELSE IF( kase.EQ.2 )
THEN
414 work( i ) = rwork( i )*work( i )
416 CALL
cpotrs( uplo, n, 1, af, ldaf, work, n, info )
425 lstres = max( lstres, cabs1( x( i,
j ) ) )
428 $ 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 chemv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CHEMV
real function slamch(CMACH)
SLAMCH
subroutine cporfs(UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CPORFS
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine cpotrs(UPLO, N, NRHS, A, LDA, B, LDB, INFO)
CPOTRS
subroutine clacn2(N, V, X, EST, KASE, ISAVE)
CLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...