179 SUBROUTINE zporfs( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X,
180 $ LDX, FERR, BERR, WORK, RWORK, INFO )
188 INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
191 DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
192 COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
193 $ work( * ), x( ldx, * )
200 parameter( itmax = 5 )
201 DOUBLE PRECISION ZERO
202 parameter( zero = 0.0d+0 )
204 parameter( one = ( 1.0d+0, 0.0d+0 ) )
206 parameter( two = 2.0d+0 )
207 DOUBLE PRECISION THREE
208 parameter( three = 3.0d+0 )
212 INTEGER COUNT, I, J, K, KASE, NZ
213 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
224 INTRINSIC abs, dble, dimag, max
228 DOUBLE PRECISION DLAMCH
229 EXTERNAL lsame, dlamch
232 DOUBLE PRECISION CABS1
235 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
242 upper = lsame( uplo,
'U' )
243 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
245 ELSE IF( n.LT.0 )
THEN
247 ELSE IF( nrhs.LT.0 )
THEN
249 ELSE IF( lda.LT.max( 1, n ) )
THEN
251 ELSE IF( ldaf.LT.max( 1, n ) )
THEN
253 ELSE IF( ldb.LT.max( 1, n ) )
THEN
255 ELSE IF( ldx.LT.max( 1, n ) )
THEN
259 CALL xerbla(
'ZPORFS', -info )
265 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
276 eps = dlamch(
'Epsilon' )
277 safmin = dlamch(
'Safe minimum' )
293 CALL zcopy( n, b( 1, j ), 1, work, 1 )
294 CALL zhemv( uplo, n, -one, a, lda, x( 1, j ), 1, one, work,
307 rwork( i ) = cabs1( b( i, j ) )
315 xk = cabs1( x( k, j ) )
317 rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
318 s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
320 rwork( k ) = rwork( k ) + abs( dble( a( k, k ) ) )*xk + s
325 xk = cabs1( x( k, j ) )
326 rwork( k ) = rwork( k ) + abs( dble( a( k, k ) ) )*xk
328 rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
329 s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
331 rwork( k ) = rwork( k ) + s
336 IF( rwork( i ).GT.safe2 )
THEN
337 s = max( s, cabs1( work( i ) ) / rwork( i ) )
339 s = max( s, ( cabs1( work( i ) )+safe1 ) /
340 $ ( rwork( i )+safe1 ) )
351 IF( berr( j ).GT.eps .AND. two*berr( j ).LE.lstres .AND.
352 $ count.LE.itmax )
THEN
356 CALL zpotrs( uplo, n, 1, af, ldaf, work, n, info )
357 CALL zaxpy( n, one, work, 1, x( 1, j ), 1 )
386 IF( rwork( i ).GT.safe2 )
THEN
387 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
389 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
396 CALL zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
402 CALL zpotrs( uplo, n, 1, af, ldaf, work, n, info )
404 work( i ) = rwork( i )*work( i )
406 ELSE IF( kase.EQ.2 )
THEN
411 work( i ) = rwork( i )*work( i )
413 CALL zpotrs( uplo, n, 1, af, ldaf, work, n, info )
422 lstres = max( lstres, cabs1( x( i, j ) ) )
425 $ ferr( j ) = ferr( j ) / lstres
subroutine zporfs(uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, ldx, ferr, berr, work, rwork, info)
ZPORFS