208 SUBROUTINE dgtrfs( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2,
209 $ ipiv,
b, ldb,
x, ldx, ferr, berr, work, iwork,
219 INTEGER info, ldb, ldx, n, nrhs
222 INTEGER ipiv( * ), iwork( * )
223 DOUBLE PRECISION b( ldb, * ), berr( * ), d( * ), df( * ),
224 $ dl( * ), dlf( * ), du( * ), du2( * ), duf( * ),
225 $ ferr( * ), work( * ),
x( ldx, * )
232 parameter( itmax = 5 )
233 DOUBLE PRECISION zero, one
234 parameter( zero = 0.0d+0, one = 1.0d+0 )
236 parameter( two = 2.0d+0 )
237 DOUBLE PRECISION three
238 parameter( three = 3.0d+0 )
242 CHARACTER transn, transt
243 INTEGER count, i,
j, kase, nz
244 DOUBLE PRECISION eps, lstres, s, safe1, safe2, safmin
265 notran =
lsame( trans,
'N' )
266 IF( .NOT.notran .AND. .NOT.
lsame( trans,
'T' ) .AND. .NOT.
267 $
lsame( trans,
'C' ) )
THEN
269 ELSE IF( n.LT.0 )
THEN
271 ELSE IF( nrhs.LT.0 )
THEN
273 ELSE IF( ldb.LT.max( 1, n ) )
THEN
275 ELSE IF( ldx.LT.max( 1, n ) )
THEN
279 CALL
xerbla(
'DGTRFS', -info )
285 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
305 safmin =
dlamch(
'Safe minimum' )
322 CALL
dcopy( n,
b( 1,
j ), 1, work( n+1 ), 1 )
323 CALL
dlagtm( trans, n, 1, -one, dl, d, du,
x( 1,
j ), ldx, one,
331 work( 1 ) = abs(
b( 1,
j ) ) + abs( d( 1 )*
x( 1,
j ) )
333 work( 1 ) = abs(
b( 1,
j ) ) + abs( d( 1 )*
x( 1,
j ) ) +
334 $ abs( du( 1 )*
x( 2,
j ) )
336 work( i ) = abs(
b( i,
j ) ) +
337 $ abs( dl( i-1 )*
x( i-1,
j ) ) +
338 $ abs( d( i )*
x( i,
j ) ) +
339 $ abs( du( i )*
x( i+1,
j ) )
341 work( n ) = abs(
b( n,
j ) ) +
342 $ abs( dl( n-1 )*
x( n-1,
j ) ) +
343 $ abs( d( n )*
x( n,
j ) )
347 work( 1 ) = abs(
b( 1,
j ) ) + abs( d( 1 )*
x( 1,
j ) )
349 work( 1 ) = abs(
b( 1,
j ) ) + abs( d( 1 )*
x( 1,
j ) ) +
350 $ abs( dl( 1 )*
x( 2,
j ) )
352 work( i ) = abs(
b( i,
j ) ) +
353 $ abs( du( i-1 )*
x( i-1,
j ) ) +
354 $ abs( d( i )*
x( i,
j ) ) +
355 $ abs( dl( i )*
x( i+1,
j ) )
357 work( n ) = abs(
b( n,
j ) ) +
358 $ abs( du( n-1 )*
x( n-1,
j ) ) +
359 $ abs( d( n )*
x( n,
j ) )
374 IF( work( i ).GT.safe2 )
THEN
375 s = max( s, abs( work( n+i ) ) / work( i ) )
377 s = max( s, ( abs( work( n+i ) )+safe1 ) /
378 $ ( work( i )+safe1 ) )
389 IF( berr(
j ).GT.eps .AND. two*berr(
j ).LE.lstres .AND.
390 $ count.LE.itmax )
THEN
394 CALL
dgttrs( trans, n, 1, dlf, df, duf, du2, ipiv,
395 $ work( n+1 ), n, info )
396 CALL
daxpy( n, one, work( n+1 ), 1,
x( 1,
j ), 1 )
425 IF( work( i ).GT.safe2 )
THEN
426 work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
428 work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
434 CALL
dlacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr(
j ),
441 CALL
dgttrs( transt, n, 1, dlf, df, duf, du2, ipiv,
442 $ work( n+1 ), n, info )
444 work( n+i ) = work( i )*work( n+i )
451 work( n+i ) = work( i )*work( n+i )
453 CALL
dgttrs( transn, n, 1, dlf, df, duf, du2, ipiv,
454 $ work( n+1 ), n, info )
463 lstres = max( lstres, abs(
x( i,
j ) ) )
466 $ ferr(
j ) = ferr(
j ) / lstres
LOGICAL function lsame(CA, CB)
LSAME
subroutine dgtrfs(TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
DGTRFS
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dlagtm(TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB)
DLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix...
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine daxpy(N, DA, DX, INCX, DY, INCY)
DAXPY
subroutine dlacn2(N, V, X, ISGN, EST, KASE, ISAVE)
DLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
subroutine dgttrs(TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO)
DGTTRS