162 SUBROUTINE schksp( 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 = 10 )
191 parameter( ntests = 8 )
194 LOGICAL trfcon, zerot
195 CHARACTER dist, packit, type, uplo, xtype
197 INTEGER i, i1, i2, imat, in, info, ioff, irhs, iuplo,
198 $ izero,
j, k, kl, ku, lda, mode, n, nerrs,
199 $ nfail, nimat, npp, nrhs, nrun, nt
200 REAL anorm, cndnum, rcond, rcondc
204 INTEGER iseed( 4 ), iseedy( 4 )
205 REAL result( ntests )
227 COMMON / infoc / infot, nunit, ok, lerr
228 COMMON / srnamc / srnamt
231 DATA iseedy / 1988, 1989, 1990, 1991 /
232 DATA uplos /
'U',
'L' /
238 path( 1: 1 ) =
'Single precision'
244 iseed( i ) = iseedy( i )
250 $ CALL
serrsy( path, nout )
264 DO 160 imat = 1, nimat
268 IF( .NOT.dotype( imat ) )
273 zerot = imat.GE.3 .AND. imat.LE.6
274 IF( zerot .AND. n.LT.imat-2 )
280 uplo = uplos( iuplo )
281 IF(
lsame( uplo,
'U' ) )
THEN
290 CALL
slatb4( path, imat, n, n, type, kl, ku, anorm, mode,
294 CALL
slatms( n, n, dist, iseed, type, rwork, mode,
295 $ cndnum, anorm, kl, ku, packit, a, lda, work,
301 CALL
alaerh( path,
'SLATMS', info, 0, uplo, n, n, -1,
302 $ -1, -1, imat, nfail, nerrs, nout )
312 ELSE IF( imat.EQ.4 )
THEN
322 IF( iuplo.EQ.1 )
THEN
323 ioff = ( izero-1 )*izero / 2
324 DO 20 i = 1, izero - 1
334 DO 40 i = 1, izero - 1
345 IF( iuplo.EQ.1 )
THEN
376 CALL
scopy( npp, a, 1, afac, 1 )
378 CALL
ssptrf( uplo, n, afac, iwork, info )
386 IF( iwork( k ).LT.0 )
THEN
387 IF( iwork( k ).NE.-k )
THEN
391 ELSE IF( iwork( k ).NE.k )
THEN
400 $ CALL
alaerh( path,
'SSPTRF', info, k, uplo, n, n, -1,
401 $ -1, -1, imat, nfail, nerrs, nout )
411 CALL
sspt01( uplo, n, a, afac, iwork, ainv, lda, rwork,
418 IF( .NOT.trfcon )
THEN
419 CALL
scopy( npp, afac, 1, ainv, 1 )
421 CALL
ssptri( uplo, n, ainv, iwork, work, info )
426 $ CALL
alaerh( path,
'SSPTRI', info, 0, uplo, n, n,
427 $ -1, -1, -1, imat, nfail, nerrs, nout )
429 CALL
sppt03( uplo, n, a, ainv, work, lda, rwork,
430 $ rcondc, result( 2 ) )
438 IF( result( k ).GE.thresh )
THEN
439 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
440 $ CALL
alahd( nout, path )
441 WRITE( nout, fmt = 9999 )uplo, n, imat, k,
462 CALL
slarhs( path, xtype, uplo,
' ', n, n, kl, ku,
463 $ nrhs, a, lda, xact, lda,
b, lda, iseed,
465 CALL
slacpy(
'Full', n, nrhs,
b, lda,
x, lda )
468 CALL
ssptrs( uplo, n, nrhs, afac, iwork,
x, lda,
474 $ CALL
alaerh( path,
'SSPTRS', info, 0, uplo, n, n,
475 $ -1, -1, nrhs, imat, nfail, nerrs,
478 CALL
slacpy(
'Full', n, nrhs,
b, lda, work, lda )
479 CALL
sppt02( uplo, n, nrhs, a,
x, lda, work, lda,
480 $ rwork, result( 3 ) )
485 CALL
sget04( n, nrhs,
x, lda, xact, lda, rcondc,
492 CALL
ssprfs( uplo, n, nrhs, a, afac, iwork,
b, lda,
x,
493 $ lda, rwork, rwork( nrhs+1 ), work,
494 $ iwork( n+1 ), info )
499 $ CALL
alaerh( path,
'SSPRFS', info, 0, uplo, n, n,
500 $ -1, -1, nrhs, imat, nfail, nerrs,
503 CALL
sget04( n, nrhs,
x, lda, xact, lda, rcondc,
505 CALL
sppt05( uplo, n, nrhs, a,
b, lda,
x, lda, xact,
506 $ lda, rwork, rwork( nrhs+1 ),
513 IF( result( k ).GE.thresh )
THEN
514 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
515 $ CALL
alahd( nout, path )
516 WRITE( nout, fmt = 9998 )uplo, n, nrhs, imat,
528 anorm =
slansp(
'1', uplo, n, a, rwork )
530 CALL
sspcon( uplo, n, afac, iwork, anorm, rcond, work,
531 $ iwork( n+1 ), info )
536 $ CALL
alaerh( path,
'SSPCON', info, 0, uplo, n, n, -1,
537 $ -1, -1, imat, nfail, nerrs, nout )
539 result( 8 ) =
sget06( rcond, rcondc )
543 IF( result( 8 ).GE.thresh )
THEN
544 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
545 $ CALL
alahd( nout, path )
546 WRITE( nout, fmt = 9999 )uplo, n, imat, 8,
557 CALL
alasum( path, nout, nfail, nrun, nerrs )
559 9999
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', type ', i2,
', test ',
560 $ i2,
', ratio =', g12.5 )
561 9998
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NRHS=', i3,
', type ',
562 $ 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.
LOGICAL function lsame(CA, CB)
LSAME
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 ssprfs(UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
SSPRFS
subroutine schksp(DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
SCHKSP
subroutine ssptri(UPLO, N, AP, IPIV, WORK, INFO)
SSPTRI
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 alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine serrsy(PATH, NUNIT)
SERRSY
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine ssptrf(UPLO, N, AP, IPIV, INFO)
SSPTRF
subroutine sspt01(UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID)
SSPT01
subroutine sppt03(UPLO, N, A, AINV, WORK, LDWORK, RWORK, RCOND, RESID)
SPPT03
subroutine sspcon(UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, INFO)
SSPCON
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine ssptrs(UPLO, N, NRHS, AP, IPIV, B, LDB, INFO)
SSPTRS
subroutine sppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SPPT05
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4