1 SUBROUTINE cporfs( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X,
2 $ ldx, ferr, berr, work, rwork, info )
14 INTEGER info, lda, ldaf, ldb, ldx, n, nrhs
17 REAL berr( * ), ferr( * ), rwork( * )
18 COMPLEX a( lda, * ), af( ldaf, * ), b( ldb, * ),
19 $ work( * ), x( ldx, * )
108 parameter( itmax = 5 )
110 parameter( zero = 0.0e+0 )
112 parameter( one = ( 1.0e+0, 0.0e+0 ) )
114 parameter( two = 2.0e+0 )
116 parameter( three = 3.0e+0 )
120 INTEGER count, i, j, k, kase, nz, plasma_uplo
121 REAL eps, lstres, s, safe1, safe2, safmin, xk
131 INTRINSIC abs, aimag,
max, real
136 EXTERNAL lsame, slamch
142 cabs1( zdum ) = abs(
REAL( ZDUM ) ) + abs( aimag( zdum ) )
149 upper = lsame(
uplo,
'U' )
150 IF( .NOT.upper .AND. .NOT.lsame(
uplo,
'L' ) )
THEN
152 ELSE IF( n.LT.0 )
THEN
154 ELSE IF( nrhs.LT.0 )
THEN
156 ELSE IF( lda.LT.
max( 1, n ) )
THEN
158 ELSE IF( ldaf.LT.
max( 1, n ) )
THEN
160 ELSE IF( ldb.LT.
max( 1, n ) )
THEN
162 ELSE IF( ldx.LT.
max( 1, n ) )
THEN
166 CALL
xerbla(
'CPORFS', -info )
172 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
180 IF ( lsame(
uplo,
'U' ) )
THEN
181 plasma_uplo = plasmaupper
183 plasma_uplo = plasmalower
189 eps = slamch(
'Epsilon' )
190 safmin = slamch(
'Safe minimum' )
206 CALL ccopy( n, b( 1, j ), 1, work, 1 )
207 CALL chemv(
uplo, n, -one, a, lda, x( 1, j ), 1, one, work, 1 )
219 rwork( i ) = cabs1( b( i, j ) )
227 xk = cabs1( x( k, j ) )
229 rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
230 s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
232 rwork( k ) = rwork( k ) + abs(
REAL( A( K, K ) ) )*xk + s
237 xk = cabs1( x( k, j ) )
238 rwork( k ) = rwork( k ) + abs(
REAL( A( K, K ) ) )*xk
240 rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
241 s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
243 rwork( k ) = rwork( k ) + s
248 IF( rwork( i ).GT.safe2 )
THEN
249 s =
max( s, cabs1( work( i ) ) / rwork( i ) )
251 s =
max( s, ( cabs1( work( i ) )+safe1 ) /
252 $ ( rwork( i )+safe1 ) )
263 IF( berr( j ).GT.eps .AND. two*berr( j ).LE.lstres .AND.
264 $ count.LE.itmax )
THEN
270 CALL caxpy( n, one, work, 1, x( 1, j ), 1 )
299 IF( rwork( i ).GT.safe2 )
THEN
300 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
302 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
309 CALL
clacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
318 work( i ) = rwork( i )*work( i )
320 ELSE IF( kase.EQ.2 )
THEN
325 work( i ) = rwork( i )*work( i )
328 $ work( n+1 ), n, info )
337 lstres =
max( lstres, cabs1( x( i, j ) ) )
340 $ ferr( j ) = ferr( j ) / lstres