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
LOGICAL function lsame(CA, CB)
LSAME
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
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
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
INTEGER function idamax(N, DX, INCX)
IDAMAX