183 SUBROUTINE cptrfs( UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX,
184 $ ferr, berr, work, rwork, info )
193 INTEGER INFO, LDB, LDX, N, NRHS
196 REAL BERR( * ), D( * ), DF( * ), FERR( * ),
198 COMPLEX B( ldb, * ), E( * ), EF( * ), WORK( * ),
206 parameter ( itmax = 5 )
208 parameter ( zero = 0.0e+0 )
210 parameter ( one = 1.0e+0 )
212 parameter ( two = 2.0e+0 )
214 parameter ( three = 3.0e+0 )
218 INTEGER COUNT, I, IX, J, NZ
219 REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN
220 COMPLEX BI, CX, DX, EX, ZDUM
226 EXTERNAL lsame, isamax, slamch
232 INTRINSIC abs, aimag, cmplx, conjg, max, real
238 cabs1( zdum ) = abs(
REAL( ZDUM ) ) + abs( AIMAG( zdum ) )
245 upper = lsame( uplo,
'U' )
246 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
248 ELSE IF( n.LT.0 )
THEN
250 ELSE IF( nrhs.LT.0 )
THEN
252 ELSE IF( ldb.LT.max( 1, n ) )
THEN
254 ELSE IF( ldx.LT.max( 1, n ) )
THEN
258 CALL xerbla(
'CPTRFS', -info )
264 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
275 eps = slamch(
'Epsilon' )
276 safmin = slamch(
'Safe minimum' )
296 dx = d( 1 )*x( 1, j )
298 rwork( 1 ) = cabs1( bi ) + cabs1( dx )
301 dx = d( 1 )*x( 1, j )
302 ex = e( 1 )*x( 2, j )
303 work( 1 ) = bi - dx - ex
304 rwork( 1 ) = cabs1( bi ) + cabs1( dx ) +
305 $ cabs1( e( 1 ) )*cabs1( x( 2, j ) )
308 cx = conjg( e( i-1 ) )*x( i-1, j )
309 dx = d( i )*x( i, j )
310 ex = e( i )*x( i+1, j )
311 work( i ) = bi - cx - dx - ex
312 rwork( i ) = cabs1( bi ) +
313 $ cabs1( e( i-1 ) )*cabs1( x( i-1, j ) ) +
314 $ cabs1( dx ) + cabs1( e( i ) )*
315 $ cabs1( x( i+1, j ) )
318 cx = conjg( e( n-1 ) )*x( n-1, j )
319 dx = d( n )*x( n, j )
320 work( n ) = bi - cx - dx
321 rwork( n ) = cabs1( bi ) + cabs1( e( n-1 ) )*
322 $ cabs1( x( n-1, j ) ) + cabs1( dx )
327 dx = d( 1 )*x( 1, j )
329 rwork( 1 ) = cabs1( bi ) + cabs1( dx )
332 dx = d( 1 )*x( 1, j )
333 ex = conjg( e( 1 ) )*x( 2, j )
334 work( 1 ) = bi - dx - ex
335 rwork( 1 ) = cabs1( bi ) + cabs1( dx ) +
336 $ cabs1( e( 1 ) )*cabs1( x( 2, j ) )
339 cx = e( i-1 )*x( i-1, j )
340 dx = d( i )*x( i, j )
341 ex = conjg( e( i ) )*x( i+1, j )
342 work( i ) = bi - cx - dx - ex
343 rwork( i ) = cabs1( bi ) +
344 $ cabs1( e( i-1 ) )*cabs1( x( i-1, j ) ) +
345 $ cabs1( dx ) + cabs1( e( i ) )*
346 $ cabs1( x( i+1, j ) )
349 cx = e( n-1 )*x( n-1, j )
350 dx = d( n )*x( n, j )
351 work( n ) = bi - cx - dx
352 rwork( n ) = cabs1( bi ) + cabs1( e( n-1 ) )*
353 $ cabs1( x( n-1, j ) ) + cabs1( dx )
368 IF( rwork( i ).GT.safe2 )
THEN
369 s = max( s, cabs1( work( i ) ) / rwork( i ) )
371 s = max( s, ( cabs1( work( i ) )+safe1 ) /
372 $ ( rwork( i )+safe1 ) )
383 IF( berr( j ).GT.eps .AND. two*berr( j ).LE.lstres .AND.
384 $ count.LE.itmax )
THEN
388 CALL cpttrs( uplo, n, 1, df, ef, work, n, info )
389 CALL caxpy( n, cmplx( one ), work, 1, x( 1, j ), 1 )
414 IF( rwork( i ).GT.safe2 )
THEN
415 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
417 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
421 ix = isamax( n, rwork, 1 )
422 ferr( j ) = rwork( ix )
437 rwork( i ) = one + rwork( i-1 )*abs( ef( i-1 ) )
442 rwork( n ) = rwork( n ) / df( n )
443 DO 80 i = n - 1, 1, -1
444 rwork( i ) = rwork( i ) / df( i ) +
445 $ rwork( i+1 )*abs( ef( i ) )
450 ix = isamax( n, rwork, 1 )
451 ferr( j ) = ferr( j )*abs( rwork( ix ) )
457 lstres = max( lstres, abs( x( i, j ) ) )
460 $ ferr( j ) = ferr( j ) / lstres
subroutine cpttrs(UPLO, N, NRHS, D, E, B, LDB, INFO)
CPTTRS
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cptrfs(UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CPTRFS
subroutine caxpy(N, CA, CX, INCX, CY, INCY)
CAXPY