208 SUBROUTINE sgtrfs( 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 REAL b( ldb, * ), berr( * ), d( * ), df( * ),
224 $ dl( * ), dlf( * ), du( * ), du2( * ), duf( * ),
225 $ ferr( * ), work( * ), x( ldx, * )
232 parameter( itmax = 5 )
234 parameter( zero = 0.0e+0, one = 1.0e+0 )
236 parameter( two = 2.0e+0 )
238 parameter( three = 3.0e+0 )
242 CHARACTER transn, transt
243 INTEGER count, i,
j, kase, nz
244 REAL 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(
'SGTRFS', -info )
285 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
305 safmin =
slamch(
'Safe minimum' )
322 CALL
scopy( n,
b( 1,
j ), 1, work( n+1 ), 1 )
323 CALL
slagtm( 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
sgttrs( trans, n, 1, dlf, df, duf, du2, ipiv,
395 $ work( n+1 ), n, info )
396 CALL
saxpy( 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
slacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr(
j ),
441 CALL
sgttrs( 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
sgttrs( 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
subroutine sgtrfs(TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
SGTRFS
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
logical function lsame(CA, CB)
LSAME
subroutine saxpy(N, SA, SX, INCX, SY, INCY)
SAXPY
subroutine sgttrs(TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO)
SGTTRS
real function slamch(CMACH)
SLAMCH
subroutine slacn2(N, V, X, ISGN, EST, KASE, ISAVE)
SLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine slagtm(TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB)
SLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix...