209 SUBROUTINE cgtrfs( 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 REAL BERR( * ), FERR( * ), RWORK( * )
225 COMPLEX B( ldb, * ), D( * ), DF( * ), DL( * ),
226 $ dlf( * ), du( * ), du2( * ), duf( * ),
227 $ work( * ), x( ldx, * )
234 parameter( itmax = 5 )
236 parameter( zero = 0.0e+0, one = 1.0e+0 )
238 parameter( two = 2.0e+0 )
240 parameter( three = 3.0e+0 )
244 CHARACTER TRANSN, TRANST
245 INTEGER COUNT, I, J, KASE, NZ
246 REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN
256 INTRINSIC abs, aimag, cmplx, max, real
261 EXTERNAL lsame, slamch
267 cabs1( zdum ) = abs(
REAL( ZDUM ) ) + abs( AIMAG( 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(
'CGTRFS', -info )
294 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
313 eps = slamch(
'Epsilon' )
314 safmin = slamch(
'Safe minimum' )
331 CALL
ccopy( n, b( 1, j ), 1, work, 1 )
332 CALL
clagtm( 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
cgttrs( trans, n, 1, dlf, df, duf, du2, ipiv, work, n,
409 CALL
caxpy( n, cmplx( 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
clacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
454 CALL
cgttrs( 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
cgttrs( transn, n, 1, dlf, df, duf, du2, ipiv, work,
476 lstres = max( lstres, cabs1( x( i, j ) ) )
479 $ ferr( j ) = ferr( j ) / lstres
subroutine caxpy(N, CA, CX, INCX, CY, INCY)
CAXPY
subroutine cgttrs(TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO)
CGTTRS
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine cgtrfs(TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CGTRFS
subroutine clagtm(TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB)
CLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix...
subroutine clacn2(N, V, X, EST, KASE, ISAVE)
CLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...