156 SUBROUTINE schktp( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
157 $ nmax, ap, ainvp,
b,
x, xact, work, rwork,
167 INTEGER nmax, nn, nns, nout
172 INTEGER iwork( * ), nsval( * ), nval( * )
173 REAL ainvp( * ), ap( * ),
b( * ), rwork( * ),
174 $ work( * ),
x( * ), xact( * )
180 INTEGER ntype1, ntypes
181 parameter( ntype1 = 10, ntypes = 18 )
183 parameter( ntests = 9 )
185 parameter( ntran = 3 )
187 parameter( one = 1.0e+0, zero = 0.0e+0 )
190 CHARACTER diag, norm, trans, uplo, xtype
192 INTEGER i, idiag, imat, in, info, irhs, itran, iuplo,
193 $ k, lap, lda, n, nerrs, nfail, nrhs, nrun
194 REAL ainvnm, anorm, rcond, rcondc, rcondi, rcondo,
198 CHARACTER transs( ntran ), uplos( 2 )
199 INTEGER iseed( 4 ), iseedy( 4 )
200 REAL result( ntests )
216 INTEGER infot, iounit
219 COMMON / infoc / infot, iounit, ok, lerr
220 COMMON / srnamc / srnamt
226 DATA iseedy / 1988, 1989, 1990, 1991 /
227 DATA uplos /
'U',
'L' / , transs /
'N',
'T',
'C' /
233 path( 1: 1 ) =
'Single precision'
239 iseed( i ) = iseedy( i )
245 $ CALL
serrtr( path, nout )
254 lap = lda*( lda+1 ) / 2
257 DO 70 imat = 1, ntype1
261 IF( .NOT.dotype( imat ) )
268 uplo = uplos( iuplo )
273 CALL
slattp( imat, uplo,
'No transpose', diag, iseed, n,
274 $ ap,
x, work, info )
278 IF(
lsame( diag,
'N' ) )
THEN
288 $ CALL
scopy( lap, ap, 1, ainvp, 1 )
290 CALL
stptri( uplo, diag, n, ainvp, info )
295 $ CALL
alaerh( path,
'STPTRI', info, 0, uplo // diag, n,
296 $ n, -1, -1, -1, imat, nfail, nerrs, nout )
300 anorm =
slantp(
'I', uplo, diag, n, ap, rwork )
301 ainvnm =
slantp(
'I', uplo, diag, n, ainvp, rwork )
302 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
305 rcondi = ( one / anorm ) / ainvnm
311 CALL
stpt01( uplo, diag, n, ap, ainvp, rcondo, rwork,
316 IF( result( 1 ).GE.thresh )
THEN
317 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
318 $ CALL
alahd( nout, path )
319 WRITE( nout, fmt = 9999 )uplo, diag, n, imat, 1,
329 DO 30 itran = 1, ntran
333 trans = transs( itran )
334 IF( itran.EQ.1 )
THEN
346 CALL
slarhs( path, xtype, uplo, trans, n, n, 0,
347 $ idiag, nrhs, ap, lap, xact, lda,
b,
350 CALL
slacpy(
'Full', n, nrhs,
b, lda,
x, lda )
353 CALL
stptrs( uplo, trans, diag, n, nrhs, ap,
x,
359 $ CALL
alaerh( path,
'STPTRS', info, 0,
360 $ uplo // trans // diag, n, n, -1,
361 $ -1, -1, imat, nfail, nerrs, nout )
363 CALL
stpt02( uplo, trans, diag, n, nrhs, ap,
x,
364 $ lda,
b, lda, work, result( 2 ) )
369 CALL
sget04( n, nrhs,
x, lda, xact, lda, rcondc,
377 CALL
stprfs( uplo, trans, diag, n, nrhs, ap,
b,
378 $ lda,
x, lda, rwork, rwork( nrhs+1 ),
379 $ work, iwork, info )
384 $ CALL
alaerh( path,
'STPRFS', info, 0,
385 $ uplo // trans // diag, n, n, -1,
386 $ -1, nrhs, imat, nfail, nerrs,
389 CALL
sget04( n, nrhs,
x, lda, xact, lda, rcondc,
391 CALL
stpt05( uplo, trans, diag, n, nrhs, ap,
b,
392 $ lda,
x, lda, xact, lda, rwork,
393 $ rwork( nrhs+1 ), result( 5 ) )
399 IF( result( k ).GE.thresh )
THEN
400 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
401 $ CALL
alahd( nout, path )
402 WRITE( nout, fmt = 9998 )uplo, trans, diag,
403 $ n, nrhs, imat, k, result( k )
415 IF( itran.EQ.1 )
THEN
424 CALL
stpcon( norm, uplo, diag, n, ap, rcond, work,
430 $ CALL
alaerh( path,
'STPCON', info, 0,
431 $ norm // uplo // diag, n, n, -1, -1,
432 $ -1, imat, nfail, nerrs, nout )
434 CALL
stpt06( rcond, rcondc, uplo, diag, n, ap, rwork,
439 IF( result( 7 ).GE.thresh )
THEN
440 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
441 $ CALL
alahd( nout, path )
442 WRITE( nout, fmt = 9997 )
'STPCON', norm, uplo,
443 $ diag, n, imat, 7, result( 7 )
453 DO 100 imat = ntype1 + 1, ntypes
457 IF( .NOT.dotype( imat ) )
464 uplo = uplos( iuplo )
465 DO 80 itran = 1, ntran
469 trans = transs( itran )
474 CALL
slattp( imat, uplo, trans, diag, iseed, n, ap,
x,
482 CALL
slatps( uplo, trans, diag,
'N', n, ap,
b, scale,
488 $ CALL
alaerh( path,
'SLATPS', info, 0,
489 $ uplo // trans // diag //
'N', n, n,
490 $ -1, -1, -1, imat, nfail, nerrs, nout )
492 CALL
stpt03( uplo, trans, diag, n, 1, ap, scale,
493 $ rwork, one,
b, lda,
x, lda, work,
499 CALL
scopy( n,
x, 1,
b( n+1 ), 1 )
500 CALL
slatps( uplo, trans, diag,
'Y', n, ap,
b( n+1 ),
501 $ scale, rwork, info )
506 $ CALL
alaerh( path,
'SLATPS', info, 0,
507 $ uplo // trans // diag //
'Y', n, n,
508 $ -1, -1, -1, imat, nfail, nerrs, nout )
510 CALL
stpt03( uplo, trans, diag, n, 1, ap, scale,
511 $ rwork, one,
b( n+1 ), lda,
x, lda, work,
517 IF( result( 8 ).GE.thresh )
THEN
518 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
519 $ CALL
alahd( nout, path )
520 WRITE( nout, fmt = 9996 )
'SLATPS', uplo, trans,
521 $ diag,
'N', n, imat, 8, result( 8 )
524 IF( result( 9 ).GE.thresh )
THEN
525 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
526 $ CALL
alahd( nout, path )
527 WRITE( nout, fmt = 9996 )
'SLATPS', uplo, trans,
528 $ diag,
'Y', n, imat, 9, result( 9 )
539 CALL
alasum( path, nout, nfail, nrun, nerrs )
541 9999
FORMAT(
' UPLO=''', a1,
''', DIAG=''', a1,
''', N=', i5,
542 $
', type ', i2,
', test(', i2,
')= ', g12.5 )
543 9998
FORMAT(
' UPLO=''', a1,
''', TRANS=''', a1,
''', DIAG=''', a1,
544 $
''', N=', i5,
''', NRHS=', i5,
', type ', i2,
', test(',
546 9997
FORMAT( 1
x, a,
'( ''', a1,
''', ''', a1,
''', ''', a1,
''',',
547 $ i5,
', ... ), type ', i2,
', test(', i2,
')=', g12.5 )
548 9996
FORMAT( 1
x, a,
'( ''', a1,
''', ''', a1,
''', ''', a1,
''', ''',
549 $ a1,
''',', i5,
', ... ), type ', i2,
', test(', i2,
')=',
LOGICAL function lsame(CA, CB)
LSAME
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine stptri(UPLO, DIAG, N, AP, INFO)
STPTRI
subroutine stpt01(UPLO, DIAG, N, AP, AINVP, RCOND, WORK, RESID)
STPT01
subroutine stprfs(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
STPRFS
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 stpt02(UPLO, TRANS, DIAG, N, NRHS, AP, X, LDX, B, LDB, WORK, RESID)
STPT02
subroutine slatps(UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, CNORM, INFO)
SLATPS solves a triangular system of equations with the matrix held in packed storage.
subroutine stpcon(NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, INFO)
STPCON
subroutine slattp(IMAT, UPLO, TRANS, DIAG, ISEED, N, A, B, WORK, INFO)
SLATTP
subroutine stpt05(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
STPT05
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 slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine stpt06(RCOND, RCONDC, UPLO, DIAG, N, AP, WORK, RAT)
STPT06
subroutine schktp(DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, AP, AINVP, B, X, XACT, WORK, RWORK, IWORK, NOUT)
SCHKTP
subroutine serrtr(PATH, NUNIT)
SERRTR
subroutine stptrs(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO)
STPTRS
subroutine stpt03(UPLO, TRANS, DIAG, N, NRHS, AP, SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID)
STPT03
REAL function slantp(NORM, UPLO, DIAG, N, AP, WORK)
SLANTP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a triangular matrix supplied in packed form.