162 SUBROUTINE schkpp( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
163 $ nmax, a, afac, ainv,
b,
x, xact, work, rwork,
173 INTEGER nmax, nn, nns, nout
178 INTEGER iwork( * ), nsval( * ), nval( * )
179 REAL a( * ), afac( * ), ainv( * ),
b( * ),
180 $ rwork( * ), work( * ),
x( * ), xact( * )
187 parameter( zero = 0.0e+0 )
189 parameter( ntypes = 9 )
191 parameter( ntests = 8 )
195 CHARACTER dist, packit, type, uplo, xtype
197 INTEGER i, imat, in, info, ioff, irhs, iuplo, izero, k,
198 $ kl, ku, lda, mode, n, nerrs, nfail, nimat, npp,
200 REAL anorm, cndnum, rcond, rcondc
203 CHARACTER packs( 2 ), uplos( 2 )
204 INTEGER iseed( 4 ), iseedy( 4 )
205 REAL result( ntests )
223 COMMON / infoc / infot, nunit, ok, lerr
224 COMMON / srnamc / srnamt
230 DATA iseedy / 1988, 1989, 1990, 1991 /
231 DATA uplos /
'U',
'L' / , packs /
'C',
'R' /
237 path( 1: 1 ) =
'Single precision'
243 iseed( i ) = iseedy( i )
249 $ CALL
serrpo( path, nout )
262 DO 100 imat = 1, nimat
266 IF( .NOT.dotype( imat ) )
271 zerot = imat.GE.3 .AND. imat.LE.5
272 IF( zerot .AND. n.LT.imat-2 )
278 uplo = uplos( iuplo )
279 packit = packs( iuplo )
284 CALL
slatb4( path, imat, n, n, type, kl, ku, anorm, mode,
288 CALL
slatms( n, n, dist, iseed, type, rwork, mode,
289 $ cndnum, anorm, kl, ku, packit, a, lda, work,
295 CALL
alaerh( path,
'SLATMS', info, 0, uplo, n, n, -1,
296 $ -1, -1, imat, nfail, nerrs, nout )
306 ELSE IF( imat.EQ.4 )
THEN
314 IF( iuplo.EQ.1 )
THEN
315 ioff = ( izero-1 )*izero / 2
316 DO 20 i = 1, izero - 1
326 DO 40 i = 1, izero - 1
342 CALL
scopy( npp, a, 1, afac, 1 )
344 CALL
spptrf( uplo, n, afac, info )
348 IF( info.NE.izero )
THEN
349 CALL
alaerh( path,
'SPPTRF', info, izero, uplo, n, n,
350 $ -1, -1, -1, imat, nfail, nerrs, nout )
362 CALL
scopy( npp, afac, 1, ainv, 1 )
363 CALL
sppt01( uplo, n, a, ainv, rwork, result( 1 ) )
368 CALL
scopy( npp, afac, 1, ainv, 1 )
370 CALL
spptri( uplo, n, ainv, info )
375 $ CALL
alaerh( path,
'SPPTRI', info, 0, uplo, n, n, -1,
376 $ -1, -1, imat, nfail, nerrs, nout )
378 CALL
sppt03( uplo, n, a, ainv, work, lda, rwork, rcondc,
385 IF( result( k ).GE.thresh )
THEN
386 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
387 $ CALL
alahd( nout, path )
388 WRITE( nout, fmt = 9999 )uplo, n, imat, k,
402 CALL
slarhs( path, xtype, uplo,
' ', n, n, kl, ku,
403 $ nrhs, a, lda, xact, lda,
b, lda, iseed,
405 CALL
slacpy(
'Full', n, nrhs,
b, lda,
x, lda )
408 CALL
spptrs( uplo, n, nrhs, afac,
x, lda, info )
413 $ CALL
alaerh( path,
'SPPTRS', info, 0, uplo, n, n,
414 $ -1, -1, nrhs, imat, nfail, nerrs,
417 CALL
slacpy(
'Full', n, nrhs,
b, lda, work, lda )
418 CALL
sppt02( uplo, n, nrhs, a,
x, lda, work, lda,
419 $ rwork, result( 3 ) )
424 CALL
sget04( n, nrhs,
x, lda, xact, lda, rcondc,
431 CALL
spprfs( uplo, n, nrhs, a, afac,
b, lda,
x, lda,
432 $ rwork, rwork( nrhs+1 ), work, iwork,
438 $ CALL
alaerh( path,
'SPPRFS', info, 0, uplo, n, n,
439 $ -1, -1, nrhs, imat, nfail, nerrs,
442 CALL
sget04( n, nrhs,
x, lda, xact, lda, rcondc,
444 CALL
sppt05( uplo, n, nrhs, a,
b, lda,
x, lda, xact,
445 $ lda, rwork, rwork( nrhs+1 ),
452 IF( result( k ).GE.thresh )
THEN
453 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
454 $ CALL
alahd( nout, path )
455 WRITE( nout, fmt = 9998 )uplo, n, nrhs, imat,
466 anorm =
slansp(
'1', uplo, n, a, rwork )
468 CALL
sppcon( uplo, n, afac, anorm, rcond, work, iwork,
474 $ CALL
alaerh( path,
'SPPCON', info, 0, uplo, n, n, -1,
475 $ -1, -1, imat, nfail, nerrs, nout )
477 result( 8 ) =
sget06( rcond, rcondc )
481 IF( result( 8 ).GE.thresh )
THEN
482 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
483 $ CALL
alahd( nout, path )
484 WRITE( nout, fmt = 9999 )uplo, n, imat, 8,
495 CALL
alasum( path, nout, nfail, nrun, nerrs )
497 9999
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', type ', i2,
', test ',
498 $ i2,
', ratio =', g12.5 )
499 9998
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NRHS=', i3,
', type ',
500 $ i2,
', test(', i2,
') =', g12.5 )
REAL function slansp(NORM, UPLO, N, AP, WORK)
SLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric matrix supplied in packed form.
subroutine alahd(IOUNIT, PATH)
ALAHD
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
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine sppt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
SPPT02
REAL function sget06(RCOND, RCONDC)
SGET06
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
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
subroutine serrpo(PATH, NUNIT)
SERRPO
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine spprfs(UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
SPPRFS
subroutine sppcon(UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO)
SPPCON
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine sppt03(UPLO, N, A, AINV, WORK, LDWORK, RWORK, RCOND, RESID)
SPPT03
subroutine sppt01(UPLO, N, A, AFAC, RWORK, RESID)
SPPT01
subroutine schkpp(DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
SCHKPP
subroutine sppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SPPT05
subroutine spptrf(UPLO, N, AP, INFO)
SPPTRF
subroutine spptri(UPLO, N, AP, INFO)
SPPTRI
subroutine spptrs(UPLO, N, NRHS, AP, B, LDB, INFO)
SPPTRS
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4