156 SUBROUTINE dchktp( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
157 $ nmax, ap, ainvp,
b,
x, xact, work, rwork,
167 INTEGER nmax, nn, nns, nout
168 DOUBLE PRECISION thresh
172 INTEGER iwork( * ), nsval( * ), nval( * )
173 DOUBLE PRECISION 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 )
186 DOUBLE PRECISION one, zero
187 parameter( one = 1.0d+0, zero = 0.0d+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 DOUBLE PRECISION ainvnm, anorm, rcond, rcondc, rcondi, rcondo,
198 CHARACTER transs( ntran ), uplos( 2 )
199 INTEGER iseed( 4 ), iseedy( 4 )
200 DOUBLE PRECISION 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 ) =
'Double precision'
239 iseed( i ) = iseedy( i )
245 $ CALL
derrtr( 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
dlattp( imat, uplo,
'No transpose', diag, iseed, n,
274 $ ap,
x, work, info )
278 IF(
lsame( diag,
'N' ) )
THEN
288 $ CALL
dcopy( lap, ap, 1, ainvp, 1 )
290 CALL
dtptri( uplo, diag, n, ainvp, info )
295 $ CALL
alaerh( path,
'DTPTRI', info, 0, uplo // diag, n,
296 $ n, -1, -1, -1, imat, nfail, nerrs, nout )
300 anorm =
dlantp(
'I', uplo, diag, n, ap, rwork )
301 ainvnm =
dlantp(
'I', uplo, diag, n, ainvp, rwork )
302 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
305 rcondi = ( one / anorm ) / ainvnm
311 CALL
dtpt01( 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
dlarhs( path, xtype, uplo, trans, n, n, 0,
347 $ idiag, nrhs, ap, lap, xact, lda,
b,
350 CALL
dlacpy(
'Full', n, nrhs,
b, lda,
x, lda )
353 CALL
dtptrs( uplo, trans, diag, n, nrhs, ap,
x,
359 $ CALL
alaerh( path,
'DTPTRS', info, 0,
360 $ uplo // trans // diag, n, n, -1,
361 $ -1, -1, imat, nfail, nerrs, nout )
363 CALL
dtpt02( uplo, trans, diag, n, nrhs, ap,
x,
364 $ lda,
b, lda, work, result( 2 ) )
369 CALL
dget04( n, nrhs,
x, lda, xact, lda, rcondc,
377 CALL
dtprfs( uplo, trans, diag, n, nrhs, ap,
b,
378 $ lda,
x, lda, rwork, rwork( nrhs+1 ),
379 $ work, iwork, info )
384 $ CALL
alaerh( path,
'DTPRFS', info, 0,
385 $ uplo // trans // diag, n, n, -1,
386 $ -1, nrhs, imat, nfail, nerrs,
389 CALL
dget04( n, nrhs,
x, lda, xact, lda, rcondc,
391 CALL
dtpt05( 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
dtpcon( norm, uplo, diag, n, ap, rcond, work,
430 $ CALL
alaerh( path,
'DTPCON', info, 0,
431 $ norm // uplo // diag, n, n, -1, -1,
432 $ -1, imat, nfail, nerrs, nout )
434 CALL
dtpt06( 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 )
'DTPCON', 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
dlattp( imat, uplo, trans, diag, iseed, n, ap,
x,
482 CALL
dlatps( uplo, trans, diag,
'N', n, ap,
b, scale,
488 $ CALL
alaerh( path,
'DLATPS', info, 0,
489 $ uplo // trans // diag //
'N', n, n,
490 $ -1, -1, -1, imat, nfail, nerrs, nout )
492 CALL
dtpt03( uplo, trans, diag, n, 1, ap, scale,
493 $ rwork, one,
b, lda,
x, lda, work,
499 CALL
dcopy( n,
x, 1,
b( n+1 ), 1 )
500 CALL
dlatps( uplo, trans, diag,
'Y', n, ap,
b( n+1 ),
501 $ scale, rwork, info )
506 $ CALL
alaerh( path,
'DLATPS', info, 0,
507 $ uplo // trans // diag //
'Y', n, n,
508 $ -1, -1, -1, imat, nfail, nerrs, nout )
510 CALL
dtpt03( 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 )
'DLATPS', 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 )
'DLATPS', 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,
')=',
subroutine dtptri(UPLO, DIAG, N, AP, INFO)
DTPTRI
subroutine dlatps(UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, CNORM, INFO)
DLATPS solves a triangular system of equations with the matrix held in packed storage.
LOGICAL function lsame(CA, CB)
LSAME
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine dtpt01(UPLO, DIAG, N, AP, AINVP, RCOND, WORK, RESID)
DTPT01
subroutine derrtr(PATH, NUNIT)
DERRTR
subroutine dtpt05(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DTPT05
DOUBLE PRECISION function dlantp(NORM, UPLO, DIAG, N, AP, WORK)
DLANTP 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.
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine dlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
DLARHS
subroutine dtpcon(NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, INFO)
DTPCON
subroutine dtptrs(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO)
DTPTRS
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine dlattp(IMAT, UPLO, TRANS, DIAG, ISEED, N, A, B, WORK, INFO)
DLATTP
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine dchktp(DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, AP, AINVP, B, X, XACT, WORK, RWORK, IWORK, NOUT)
DCHKTP
subroutine dtpt02(UPLO, TRANS, DIAG, N, NRHS, AP, X, LDX, B, LDB, WORK, RESID)
DTPT02
subroutine dtpt03(UPLO, TRANS, DIAG, N, NRHS, AP, SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID)
DTPT03
subroutine dtprfs(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
DTPRFS
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
subroutine dtpt06(RCOND, RCONDC, UPLO, DIAG, N, AP, WORK, RAT)
DTPT06