209 SUBROUTINE zgtrfs( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2,
210 $ ipiv, b, ldb, x, ldx, ferr, berr, work, rwork,
220 INTEGER INFO, LDB, LDX, N, NRHS
224 DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
225 COMPLEX*16 B( ldb, * ), D( * ), DF( * ), DL( * ),
226 $ dlf( * ), du( * ), du2( * ), duf( * ),
227 $ work( * ), x( ldx, * )
234 parameter ( itmax = 5 )
235 DOUBLE PRECISION ZERO, ONE
236 parameter ( zero = 0.0d+0, one = 1.0d+0 )
238 parameter ( two = 2.0d+0 )
239 DOUBLE PRECISION THREE
240 parameter ( three = 3.0d+0 )
244 CHARACTER TRANSN, TRANST
245 INTEGER COUNT, I, J, KASE, NZ
246 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN
256 INTRINSIC abs, dble, dcmplx, dimag, max
260 DOUBLE PRECISION DLAMCH
261 EXTERNAL lsame, dlamch
264 DOUBLE PRECISION CABS1
267 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
274 notran = lsame( trans,
'N' )
275 IF( .NOT.notran .AND. .NOT.lsame( trans,
'T' ) .AND. .NOT.
276 $ lsame( trans,
'C' ) )
THEN
278 ELSE IF( n.LT.0 )
THEN
280 ELSE IF( nrhs.LT.0 )
THEN
282 ELSE IF( ldb.LT.max( 1, n ) )
THEN
284 ELSE IF( ldx.LT.max( 1, n ) )
THEN
288 CALL xerbla(
'ZGTRFS', -info )
294 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
313 eps = dlamch(
'Epsilon' )
314 safmin = dlamch(
'Safe minimum' )
331 CALL zcopy( n, b( 1, j ), 1, work, 1 )
332 CALL zlagtm( trans, n, 1, -one, dl, d, du, x( 1, j ), ldx, one,
340 rwork( 1 ) = cabs1( b( 1, j ) ) +
341 $ cabs1( d( 1 ) )*cabs1( x( 1, j ) )
343 rwork( 1 ) = cabs1( b( 1, j ) ) +
344 $ cabs1( d( 1 ) )*cabs1( x( 1, j ) ) +
345 $ cabs1( du( 1 ) )*cabs1( x( 2, j ) )
347 rwork( i ) = cabs1( b( i, j ) ) +
348 $ cabs1( dl( i-1 ) )*cabs1( x( i-1, j ) ) +
349 $ cabs1( d( i ) )*cabs1( x( i, j ) ) +
350 $ cabs1( du( i ) )*cabs1( x( i+1, j ) )
352 rwork( n ) = cabs1( b( n, j ) ) +
353 $ cabs1( dl( n-1 ) )*cabs1( x( n-1, j ) ) +
354 $ cabs1( d( n ) )*cabs1( x( n, j ) )
358 rwork( 1 ) = cabs1( b( 1, j ) ) +
359 $ cabs1( d( 1 ) )*cabs1( x( 1, j ) )
361 rwork( 1 ) = cabs1( b( 1, j ) ) +
362 $ cabs1( d( 1 ) )*cabs1( x( 1, j ) ) +
363 $ cabs1( dl( 1 ) )*cabs1( x( 2, j ) )
365 rwork( i ) = cabs1( b( i, j ) ) +
366 $ cabs1( du( i-1 ) )*cabs1( x( i-1, j ) ) +
367 $ cabs1( d( i ) )*cabs1( x( i, j ) ) +
368 $ cabs1( dl( i ) )*cabs1( x( i+1, j ) )
370 rwork( n ) = cabs1( b( n, j ) ) +
371 $ cabs1( du( n-1 ) )*cabs1( x( n-1, j ) ) +
372 $ cabs1( d( n ) )*cabs1( x( n, j ) )
387 IF( rwork( i ).GT.safe2 )
THEN
388 s = max( s, cabs1( work( i ) ) / rwork( i ) )
390 s = max( s, ( cabs1( work( i ) )+safe1 ) /
391 $ ( rwork( i )+safe1 ) )
402 IF( berr( j ).GT.eps .AND. two*berr( j ).LE.lstres .AND.
403 $ count.LE.itmax )
THEN
407 CALL zgttrs( trans, n, 1, dlf, df, duf, du2, ipiv, work, n,
409 CALL zaxpy( n, dcmplx( one ), work, 1, x( 1, j ), 1 )
438 IF( rwork( i ).GT.safe2 )
THEN
439 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
441 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
448 CALL zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
454 CALL zgttrs( transt, n, 1, dlf, df, duf, du2, ipiv, work,
457 work( i ) = rwork( i )*work( i )
464 work( i ) = rwork( i )*work( i )
466 CALL zgttrs( transn, n, 1, dlf, df, duf, du2, ipiv, work,
476 lstres = max( lstres, cabs1( x( i, j ) ) )
479 $ ferr( j ) = ferr( j ) / lstres
subroutine zgttrs(TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO)
ZGTTRS
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
subroutine zlacn2(N, V, X, EST, KASE, ISAVE)
ZLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zlagtm(TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB)
ZLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix...
subroutine zaxpy(N, ZA, ZX, INCX, ZY, INCY)
ZAXPY
subroutine zgtrfs(TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
ZGTRFS