170 SUBROUTINE ctprfs( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X,
172 $ FERR, BERR, WORK, RWORK, INFO )
179 CHARACTER DIAG, TRANS, UPLO
180 INTEGER INFO, LDB, LDX, N, NRHS
183 REAL BERR( * ), FERR( * ), RWORK( * )
184 COMPLEX AP( * ), B( LDB, * ), WORK( * ), X( LDX, * )
191 PARAMETER ( ZERO = 0.0e+0 )
193 parameter( one = ( 1.0e+0, 0.0e+0 ) )
196 LOGICAL NOTRAN, NOUNIT, UPPER
197 CHARACTER TRANSN, TRANST
198 INTEGER I, J, K, KASE, KC, NZ
199 REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
210 INTRINSIC abs, aimag, max, real
215 EXTERNAL lsame, slamch
221 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( zdum ) )
228 upper = lsame( uplo,
'U' )
229 notran = lsame( trans,
'N' )
230 nounit = lsame( diag,
'N' )
232 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
234 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans,
'T' ) .AND. .NOT.
235 $ lsame( trans,
'C' ) )
THEN
237 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag,
'U' ) )
THEN
239 ELSE IF( n.LT.0 )
THEN
241 ELSE IF( nrhs.LT.0 )
THEN
243 ELSE IF( ldb.LT.max( 1, n ) )
THEN
245 ELSE IF( ldx.LT.max( 1, n ) )
THEN
249 CALL xerbla(
'CTPRFS', -info )
255 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
274 eps = slamch(
'Epsilon' )
275 safmin = slamch(
'Safe minimum' )
276 safe1 = real( nz )*safmin
286 CALL ccopy( n, x( 1, j ), 1, work, 1 )
287 CALL ctpmv( uplo, trans, diag, n, ap, work, 1 )
288 CALL caxpy( n, -one, b( 1, j ), 1, work, 1 )
300 rwork( i ) = cabs1( b( i, j ) )
311 xk = cabs1( x( k, j ) )
313 rwork( i ) = rwork( i ) +
314 $ cabs1( ap( kc+i-1 ) )*xk
320 xk = cabs1( x( k, j ) )
322 rwork( i ) = rwork( i ) +
323 $ cabs1( ap( kc+i-1 ) )*xk
325 rwork( k ) = rwork( k ) + xk
333 xk = cabs1( x( k, j ) )
335 rwork( i ) = rwork( i ) +
336 $ cabs1( ap( kc+i-k ) )*xk
342 xk = cabs1( x( k, j ) )
344 rwork( i ) = rwork( i ) +
345 $ cabs1( ap( kc+i-k ) )*xk
347 rwork( k ) = rwork( k ) + xk
362 s = s + cabs1( ap( kc+i-1 ) )*cabs1( x( i, j ) )
364 rwork( k ) = rwork( k ) + s
369 s = cabs1( x( k, j ) )
371 s = s + cabs1( ap( kc+i-1 ) )*cabs1( x( i, j ) )
373 rwork( k ) = rwork( k ) + s
383 s = s + cabs1( ap( kc+i-k ) )*cabs1( x( i, j ) )
385 rwork( k ) = rwork( k ) + s
390 s = cabs1( x( k, j ) )
392 s = s + cabs1( ap( kc+i-k ) )*cabs1( x( i, j ) )
394 rwork( k ) = rwork( k ) + s
402 IF( rwork( i ).GT.safe2 )
THEN
403 s = max( s, cabs1( work( i ) ) / rwork( i ) )
405 s = max( s, ( cabs1( work( i ) )+safe1 ) /
406 $ ( rwork( i )+safe1 ) )
434 IF( rwork( i ).GT.safe2 )
THEN
435 rwork( i ) = cabs1( work( i ) ) + real( nz )*
438 rwork( i ) = cabs1( work( i ) ) + real( nz )*
439 $ eps*rwork( i ) + safe1
445 CALL clacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
451 CALL ctpsv( uplo, transt, diag, n, ap, work, 1 )
453 work( i ) = rwork( i )*work( i )
460 work( i ) = rwork( i )*work( i )
462 CALL ctpsv( uplo, transn, diag, n, ap, work, 1 )
471 lstres = max( lstres, cabs1( x( i, j ) ) )
474 $ ferr( j ) = ferr( j ) / lstres
subroutine ctprfs(uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CTPRFS