1 SUBROUTINE zporfs( 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 DOUBLE PRECISION berr( * ), ferr( * ), rwork( * )
18 COMPLEX*16 a( lda, * ), af( ldaf, * ), b( ldb, * ),
19 $ work( * ), x( ldx, * )
108 parameter( itmax = 5 )
109 DOUBLE PRECISION zero
110 parameter( zero = 0.0d+0 )
112 parameter( one = ( 1.0d+0, 0.0d+0 ) )
114 parameter( two = 2.0d+0 )
115 DOUBLE PRECISION three
116 parameter( three = 3.0d+0 )
120 INTEGER count, i, j, k, kase, nz, plasma_uplo
121 DOUBLE PRECISION eps, lstres, s, safe1, safe2, safmin, xk
131 INTRINSIC abs, dble, dimag,
max
135 DOUBLE PRECISION dlamch
136 EXTERNAL lsame, dlamch
139 DOUBLE PRECISION cabs1
142 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( 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(
'ZPORFS', -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 = dlamch(
'Epsilon' )
190 safmin = dlamch(
'Safe minimum' )
206 CALL zcopy( n, b( 1, j ), 1, work, 1 )
207 CALL zhemv(
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( dble( a( k, k ) ) )*xk + s
237 xk = cabs1( x( k, j ) )
238 rwork( k ) = rwork( k ) + abs( dble( 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 zaxpy( 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
zlacn2( 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 )
337 lstres =
max( lstres, cabs1( x( i, j ) ) )
340 $ ferr( j ) = ferr( j ) / lstres