174 SUBROUTINE ctprfs( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX,
175 $ ferr, berr, work, rwork, info )
183 CHARACTER DIAG, TRANS, UPLO
184 INTEGER INFO, LDB, LDX, N, NRHS
187 REAL BERR( * ), FERR( * ), RWORK( * )
188 COMPLEX AP( * ), B( ldb, * ), WORK( * ), X( ldx, * )
195 parameter ( zero = 0.0e+0 )
197 parameter ( one = ( 1.0e+0, 0.0e+0 ) )
200 LOGICAL NOTRAN, NOUNIT, UPPER
201 CHARACTER TRANSN, TRANST
202 INTEGER I, J, K, KASE, KC, NZ
203 REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
213 INTRINSIC abs, aimag, max, real
218 EXTERNAL lsame, slamch
224 cabs1( zdum ) = abs(
REAL( ZDUM ) ) + abs( AIMAG( zdum ) )
231 upper = lsame( uplo,
'U' )
232 notran = lsame( trans,
'N' )
233 nounit = lsame( diag,
'N' )
235 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
237 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans,
'T' ) .AND. .NOT.
238 $ lsame( trans,
'C' ) )
THEN
240 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag,
'U' ) )
THEN
242 ELSE IF( n.LT.0 )
THEN
244 ELSE IF( nrhs.LT.0 )
THEN
246 ELSE IF( ldb.LT.max( 1, n ) )
THEN
248 ELSE IF( ldx.LT.max( 1, n ) )
THEN
252 CALL xerbla(
'CTPRFS', -info )
258 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
277 eps = slamch(
'Epsilon' )
278 safmin = slamch(
'Safe minimum' )
289 CALL ccopy( n, x( 1, j ), 1, work, 1 )
290 CALL ctpmv( uplo, trans, diag, n, ap, work, 1 )
291 CALL caxpy( n, -one, b( 1, j ), 1, work, 1 )
303 rwork( i ) = cabs1( b( i, j ) )
314 xk = cabs1( x( k, j ) )
316 rwork( i ) = rwork( i ) +
317 $ cabs1( ap( kc+i-1 ) )*xk
323 xk = cabs1( x( k, j ) )
325 rwork( i ) = rwork( i ) +
326 $ cabs1( ap( kc+i-1 ) )*xk
328 rwork( k ) = rwork( k ) + xk
336 xk = cabs1( x( k, j ) )
338 rwork( i ) = rwork( i ) +
339 $ cabs1( ap( kc+i-k ) )*xk
345 xk = cabs1( x( k, j ) )
347 rwork( i ) = rwork( i ) +
348 $ cabs1( ap( kc+i-k ) )*xk
350 rwork( k ) = rwork( k ) + xk
365 s = s + cabs1( ap( kc+i-1 ) )*cabs1( x( i, j ) )
367 rwork( k ) = rwork( k ) + s
372 s = cabs1( x( k, j ) )
374 s = s + cabs1( ap( kc+i-1 ) )*cabs1( x( i, j ) )
376 rwork( k ) = rwork( k ) + s
386 s = s + cabs1( ap( kc+i-k ) )*cabs1( x( i, j ) )
388 rwork( k ) = rwork( k ) + s
393 s = cabs1( x( k, j ) )
395 s = s + cabs1( ap( kc+i-k ) )*cabs1( x( i, j ) )
397 rwork( k ) = rwork( k ) + s
405 IF( rwork( i ).GT.safe2 )
THEN
406 s = max( s, cabs1( work( i ) ) / rwork( i ) )
408 s = max( s, ( cabs1( work( i ) )+safe1 ) /
409 $ ( rwork( i )+safe1 ) )
437 IF( rwork( i ).GT.safe2 )
THEN
438 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
440 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
447 CALL clacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
453 CALL ctpsv( uplo, transt, diag, n, ap, work, 1 )
455 work( i ) = rwork( i )*work( i )
462 work( i ) = rwork( i )*work( i )
464 CALL ctpsv( uplo, transn, diag, n, ap, work, 1 )
473 lstres = max( lstres, cabs1( x( i, j ) ) )
476 $ ferr( j ) = ferr( j ) / lstres
subroutine ctpmv(UPLO, TRANS, DIAG, N, AP, X, INCX)
CTPMV
subroutine ctprfs(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CTPRFS
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine clacn2(N, V, X, EST, KASE, ISAVE)
CLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine ctpsv(UPLO, TRANS, DIAG, N, AP, X, INCX)
CTPSV
subroutine caxpy(N, CA, CX, INCX, CY, INCY)
CAXPY