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,
481 CALL dcopy( n, x, 1, b, 1 )
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( 1x, a,
'( ''', a1,
''', ''', a1,
''', ''', a1,
''',',
547 $ i5,
', ... ), type ', i2,
', test(', i2,
')=', g12.5 )
548 9996
FORMAT( 1x, a,
'( ''', a1,
''', ''', a1,
''', ''', a1,
''', ''',
549 $ a1,
''',', i5,
', ... ), type ', i2,
', test(', i2,
')=',
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine alahd(IOUNIT, PATH)
ALAHD
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 dlattp(IMAT, UPLO, TRANS, DIAG, ISEED, N, A, B, WORK, INFO)
DLATTP
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
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.
subroutine dtpt06(RCOND, RCONDC, UPLO, DIAG, N, AP, WORK, RAT)
DTPT06
subroutine dtpt02(UPLO, TRANS, DIAG, N, NRHS, AP, X, LDX, B, LDB, WORK, RESID)
DTPT02
subroutine dtpt05(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DTPT05
subroutine dtprfs(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
DTPRFS
subroutine dtpcon(NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, INFO)
DTPCON
subroutine dtptrs(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO)
DTPTRS
subroutine dtpt01(UPLO, DIAG, N, AP, AINVP, RCOND, WORK, RESID)
DTPT01
subroutine dtptri(UPLO, DIAG, N, AP, INFO)
DTPTRI
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
subroutine derrtr(PATH, NUNIT)
DERRTR
logical function lsame(CA, CB)
LSAME
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 dtpt03(UPLO, TRANS, DIAG, N, NRHS, AP, SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID)
DTPT03
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM