183 SUBROUTINE zptrfs( 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 DOUBLE PRECISION berr( * ), d( * ), df( * ), ferr( * ),
198 COMPLEX*16 b( ldb, * ), e( * ), ef( * ), work( * ),
206 parameter( itmax = 5 )
207 DOUBLE PRECISION zero
208 parameter( zero = 0.0d+0 )
210 parameter( one = 1.0d+0 )
212 parameter( two = 2.0d+0 )
213 DOUBLE PRECISION three
214 parameter( three = 3.0d+0 )
218 INTEGER count, i, ix,
j, nz
219 DOUBLE PRECISION eps, lstres, s, safe1, safe2, safmin
220 COMPLEX*16 bi, cx, dx, ex, zdum
232 INTRINSIC abs, dble, dcmplx, dconjg, dimag, max
235 DOUBLE PRECISION cabs1
238 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( 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(
'ZPTRFS', -info )
264 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
276 safmin =
dlamch(
'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 = dconjg( 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 = dconjg( 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 = dconjg( 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 = dconjg( 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
zpttrs( uplo, n, 1, df, ef, work, n, info )
389 CALL
zaxpy( n, dcmplx( 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 =
idamax( 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 =
idamax( 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 zpttrs(UPLO, N, NRHS, D, E, B, LDB, INFO)
ZPTTRS
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
logical function lsame(CA, CB)
LSAME
subroutine zptrfs(UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
ZPTRFS
subroutine zaxpy(N, ZA, ZX, INCX, ZY, INCY)
ZAXPY
double precision function dlamch(CMACH)
DLAMCH
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
integer function idamax(N, DX, INCX)
IDAMAX