146 SUBROUTINE schkpt( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
147 $ a, d, e,
b, x, xact, work, rwork, nout )
156 INTEGER nn, nns, nout
161 INTEGER nsval( * ), nval( * )
162 REAL a( * ),
b( * ), d( * ), e( * ), rwork( * ),
163 $ work( * ), x( * ), xact( * )
170 parameter( one = 1.0e+0, zero = 0.0e+0 )
172 parameter( ntypes = 12 )
174 parameter( ntests = 7 )
180 INTEGER i, ia, imat, in, info, irhs, ix, izero,
j, k,
181 $ kl, ku, lda, mode, n, nerrs, nfail, nimat,
183 REAL ainvnm, anorm, cond, dmax, rcond, rcondc
186 INTEGER iseed( 4 ), iseedy( 4 )
187 REAL result( ntests ), z( 3 )
209 COMMON / infoc / infot, nunit, ok, lerr
210 COMMON / srnamc / srnamt
213 DATA iseedy / 0, 0, 0, 1 /
217 path( 1: 1 ) =
'Single precision'
223 iseed( i ) = iseedy( i )
229 $ CALL
serrgt( path, nout )
242 DO 100 imat = 1, nimat
246 IF( n.GT.0 .AND. .NOT.dotype( imat ) )
251 CALL
slatb4( path, imat, n, n, type, kl, ku, anorm, mode,
254 zerot = imat.GE.8 .AND. imat.LE.10
261 CALL
slatms( n, n, dist, iseed, type, rwork, mode, cond,
262 $ anorm, kl, ku,
'B', a, 2, work, info )
267 CALL
alaerh( path,
'SLATMS', info, 0,
' ', n, n, kl,
268 $ ku, -1, imat, nfail, nerrs, nout )
288 IF( .NOT.zerot .OR. .NOT.dotype( 7 ) )
THEN
292 CALL
slarnv( 2, iseed, n, d )
293 CALL
slarnv( 2, iseed, n-1, e )
298 d( 1 ) = abs( d( 1 ) )
300 d( 1 ) = abs( d( 1 ) ) + abs( e( 1 ) )
301 d( n ) = abs( d( n ) ) + abs( e( n-1 ) )
303 d( i ) = abs( d( i ) ) + abs( e( i ) ) +
312 CALL
sscal( n, anorm / dmax, d, 1 )
313 CALL
sscal( n-1, anorm / dmax, e, 1 )
315 ELSE IF( izero.GT.0 )
THEN
320 IF( izero.EQ.1 )
THEN
324 ELSE IF( izero.EQ.n )
THEN
328 e( izero-1 ) = z( 1 )
346 ELSE IF( imat.EQ.9 )
THEN
354 ELSE IF( imat.EQ.10 )
THEN
356 IF( izero.GT.1 )
THEN
357 z( 1 ) = e( izero-1 )
367 CALL
scopy( n, d, 1, d( n+1 ), 1 )
369 $ CALL
scopy( n-1, e, 1, e( n+1 ), 1 )
375 CALL
spttrf( n, d( n+1 ), e( n+1 ), info )
379 IF( info.NE.izero )
THEN
380 CALL
alaerh( path,
'SPTTRF', info, izero,
' ', n, n, -1,
381 $ -1, -1, imat, nfail, nerrs, nout )
390 CALL
sptt01( n, d, e, d( n+1 ), e( n+1 ), work,
395 IF( result( 1 ).GE.thresh )
THEN
396 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
397 $ CALL
alahd( nout, path )
398 WRITE( nout, fmt = 9999 )n, imat, 1, result( 1 )
407 anorm =
slanst(
'1', n, d, e )
418 CALL
spttrs( n, 1, d( n+1 ), e( n+1 ), x, lda, info )
419 ainvnm = max( ainvnm,
sasum( n, x, 1 ) )
421 rcondc = one / max( one, anorm*ainvnm )
430 CALL
slarnv( 2, iseed, n, xact( ix ) )
436 CALL
slaptm( n, nrhs, one, d, e, xact, lda, zero,
b,
442 CALL
slacpy(
'Full', n, nrhs,
b, lda, x, lda )
443 CALL
spttrs( n, nrhs, d( n+1 ), e( n+1 ), x, lda, info )
448 $ CALL
alaerh( path,
'SPTTRS', info, 0,
' ', n, n, -1,
449 $ -1, nrhs, imat, nfail, nerrs, nout )
451 CALL
slacpy(
'Full', n, nrhs,
b, lda, work, lda )
452 CALL
sptt02( n, nrhs, d, e, x, lda, work, lda,
458 CALL
sget04( n, nrhs, x, lda, xact, lda, rcondc,
465 CALL
sptrfs( n, nrhs, d, e, d( n+1 ), e( n+1 ),
b, lda,
466 $ x, lda, rwork, rwork( nrhs+1 ), work, info )
471 $ CALL
alaerh( path,
'SPTRFS', info, 0,
' ', n, n, -1,
472 $ -1, nrhs, imat, nfail, nerrs, nout )
474 CALL
sget04( n, nrhs, x, lda, xact, lda, rcondc,
476 CALL
sptt05( n, nrhs, d, e,
b, lda, x, lda, xact, lda,
477 $ rwork, rwork( nrhs+1 ), result( 5 ) )
483 IF( result( k ).GE.thresh )
THEN
484 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
485 $ CALL
alahd( nout, path )
486 WRITE( nout, fmt = 9998 )n, nrhs, imat, k,
500 CALL
sptcon( n, d( n+1 ), e( n+1 ), anorm, rcond, rwork,
506 $ CALL
alaerh( path,
'SPTCON', info, 0,
' ', n, n, -1, -1,
507 $ -1, imat, nfail, nerrs, nout )
509 result( 7 ) =
sget06( rcond, rcondc )
513 IF( result( 7 ).GE.thresh )
THEN
514 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
515 $ CALL
alahd( nout, path )
516 WRITE( nout, fmt = 9999 )n, imat, 7, result( 7 )
525 CALL
alasum( path, nout, nfail, nrun, nerrs )
527 9999
FORMAT(
' N =', i5,
', type ', i2,
', test ', i2,
', ratio = ',
529 9998
FORMAT(
' N =', i5,
', NRHS=', i3,
', type ', i2,
', test(', i2,
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine spttrs(N, NRHS, D, E, B, LDB, INFO)
SPTTRS
integer function isamax(N, SX, INCX)
ISAMAX
real function sasum(N, SX, INCX)
SASUM
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
real function sget06(RCOND, RCONDC)
SGET06
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine sptrfs(N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, INFO)
SPTRFS
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine schkpt(DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, A, D, E, B, X, XACT, WORK, RWORK, NOUT)
SCHKPT
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine sptt02(N, NRHS, D, E, X, LDX, B, LDB, RESID)
SPTT02
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
real function slanst(NORM, N, D, E)
SLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric tridiagonal matrix.
subroutine sptt01(N, D, E, DF, EF, WORK, RESID)
SPTT01
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine spttrf(N, D, E, INFO)
SPTTRF
subroutine sptcon(N, D, E, ANORM, RCOND, WORK, INFO)
SPTCON
subroutine sptt05(N, NRHS, D, E, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SPTT05
subroutine slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine slaptm(N, NRHS, ALPHA, D, E, X, LDX, BETA, B, LDB)
SLAPTM
subroutine serrgt(PATH, NUNIT)
SERRGT
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
subroutine sscal(N, SA, SX, INCX)
SSCAL