166 SUBROUTINE dchktr( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
167 $ thresh, tsterr, nmax, a, ainv,
b, x, xact,
168 $ work, rwork, iwork, nout )
177 INTEGER nmax, nn, nnb, nns, nout
178 DOUBLE PRECISION thresh
182 INTEGER iwork( * ), nbval( * ), nsval( * ), nval( * )
183 DOUBLE PRECISION a( * ), ainv( * ),
b( * ), rwork( * ),
184 $ work( * ), x( * ), xact( * )
190 INTEGER ntype1, ntypes
191 parameter( ntype1 = 10, ntypes = 18 )
193 parameter( ntests = 9 )
195 parameter( ntran = 3 )
196 DOUBLE PRECISION one, zero
197 parameter( one = 1.0d0, zero = 0.0d0 )
200 CHARACTER diag, norm, trans, uplo, xtype
202 INTEGER i, idiag, imat, in, inb, info, irhs, itran,
203 $ iuplo, k, lda, n, nb, nerrs, nfail, nrhs, nrun
204 DOUBLE PRECISION ainvnm, anorm, dummy, rcond, rcondc, rcondi,
208 CHARACTER transs( ntran ), uplos( 2 )
209 INTEGER iseed( 4 ), iseedy( 4 )
210 DOUBLE PRECISION result( ntests )
226 INTEGER infot, iounit
229 COMMON / infoc / infot, iounit, ok, lerr
230 COMMON / srnamc / srnamt
236 DATA iseedy / 1988, 1989, 1990, 1991 /
237 DATA uplos /
'U',
'L' / , transs /
'N',
'T',
'C' /
243 path( 1: 1 ) =
'Double precision'
249 iseed( i ) = iseedy( i )
255 $ CALL
derrtr( path, nout )
267 DO 80 imat = 1, ntype1
271 IF( .NOT.dotype( imat ) )
278 uplo = uplos( iuplo )
283 CALL
dlattr( imat, uplo,
'No transpose', diag, iseed, n,
284 $ a, lda, x, work, info )
288 IF(
lsame( diag,
'N' ) )
THEN
304 CALL
dlacpy( uplo, n, n, a, lda, ainv, lda )
306 CALL
dtrtri( uplo, diag, n, ainv, lda, info )
311 $ CALL
alaerh( path,
'DTRTRI', info, 0, uplo // diag,
312 $ n, n, -1, -1, nb, imat, nfail, nerrs,
317 anorm =
dlantr(
'I', uplo, diag, n, n, a, lda, rwork )
318 ainvnm =
dlantr(
'I', uplo, diag, n, n, ainv, lda,
320 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
323 rcondi = ( one / anorm ) / ainvnm
330 CALL
dtrt01( uplo, diag, n, a, lda, ainv, lda, rcondo,
331 $ rwork, result( 1 ) )
335 IF( result( 1 ).GE.thresh )
THEN
336 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
337 $ CALL
alahd( nout, path )
338 WRITE( nout, fmt = 9999 )uplo, diag, n, nb, imat,
353 DO 30 itran = 1, ntran
357 trans = transs( itran )
358 IF( itran.EQ.1 )
THEN
370 CALL
dlarhs( path, xtype, uplo, trans, n, n, 0,
371 $ idiag, nrhs, a, lda, xact, lda,
b,
374 CALL
dlacpy(
'Full', n, nrhs,
b, lda, x, lda )
377 CALL
dtrtrs( uplo, trans, diag, n, nrhs, a, lda,
383 $ CALL
alaerh( path,
'DTRTRS', info, 0,
384 $ uplo // trans // diag, n, n, -1,
385 $ -1, nrhs, imat, nfail, nerrs,
393 CALL
dtrt02( uplo, trans, diag, n, nrhs, a, lda,
394 $ x, lda,
b, lda, work, result( 2 ) )
399 CALL
dget04( n, nrhs, x, lda, xact, lda, rcondc,
407 CALL
dtrrfs( uplo, trans, diag, n, nrhs, a, lda,
408 $
b, lda, x, lda, rwork,
409 $ rwork( nrhs+1 ), work, iwork,
415 $ CALL
alaerh( path,
'DTRRFS', info, 0,
416 $ uplo // trans // diag, n, n, -1,
417 $ -1, nrhs, imat, nfail, nerrs,
420 CALL
dget04( n, nrhs, x, lda, xact, lda, rcondc,
422 CALL
dtrt05( uplo, trans, diag, n, nrhs, a, lda,
423 $
b, lda, x, lda, xact, lda, rwork,
424 $ rwork( nrhs+1 ), result( 5 ) )
430 IF( result( k ).GE.thresh )
THEN
431 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
432 $ CALL
alahd( nout, path )
433 WRITE( nout, fmt = 9998 )uplo, trans,
434 $ diag, n, nrhs, imat, k, result( k )
446 IF( itran.EQ.1 )
THEN
454 CALL
dtrcon( norm, uplo, diag, n, a, lda, rcond,
455 $ work, iwork, info )
460 $ CALL
alaerh( path,
'DTRCON', info, 0,
461 $ norm // uplo // diag, n, n, -1, -1,
462 $ -1, imat, nfail, nerrs, nout )
464 CALL
dtrt06( rcond, rcondc, uplo, diag, n, a, lda,
465 $ rwork, result( 7 ) )
469 IF( result( 7 ).GE.thresh )
THEN
470 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
471 $ CALL
alahd( nout, path )
472 WRITE( nout, fmt = 9997 )norm, uplo, n, imat,
484 DO 110 imat = ntype1 + 1, ntypes
488 IF( .NOT.dotype( imat ) )
495 uplo = uplos( iuplo )
496 DO 90 itran = 1, ntran
500 trans = transs( itran )
505 CALL
dlattr( imat, uplo, trans, diag, iseed, n, a,
506 $ lda, x, work, info )
512 CALL
dcopy( n, x, 1,
b, 1 )
513 CALL
dlatrs( uplo, trans, diag,
'N', n, a, lda,
b,
514 $ scale, rwork, info )
519 $ CALL
alaerh( path,
'DLATRS', info, 0,
520 $ uplo // trans // diag //
'N', n, n,
521 $ -1, -1, -1, imat, nfail, nerrs, nout )
523 CALL
dtrt03( uplo, trans, diag, n, 1, a, lda, scale,
524 $ rwork, one,
b, lda, x, lda, work,
530 CALL
dcopy( n, x, 1,
b( n+1 ), 1 )
531 CALL
dlatrs( uplo, trans, diag,
'Y', n, a, lda,
532 $
b( n+1 ), scale, rwork, info )
537 $ CALL
alaerh( path,
'DLATRS', info, 0,
538 $ uplo // trans // diag //
'Y', n, n,
539 $ -1, -1, -1, imat, nfail, nerrs, nout )
541 CALL
dtrt03( uplo, trans, diag, n, 1, a, lda, scale,
542 $ rwork, one,
b( n+1 ), lda, x, lda, work,
548 IF( result( 8 ).GE.thresh )
THEN
549 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
550 $ CALL
alahd( nout, path )
551 WRITE( nout, fmt = 9996 )
'DLATRS', uplo, trans,
552 $ diag,
'N', n, imat, 8, result( 8 )
555 IF( result( 9 ).GE.thresh )
THEN
556 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
557 $ CALL
alahd( nout, path )
558 WRITE( nout, fmt = 9996 )
'DLATRS', uplo, trans,
559 $ diag,
'Y', n, imat, 9, result( 9 )
570 CALL
alasum( path, nout, nfail, nrun, nerrs )
572 9999
FORMAT(
' UPLO=''', a1,
''', DIAG=''', a1,
''', N=', i5,
', NB=',
573 $ i4,
', type ', i2,
', test(', i2,
')= ', g12.5 )
574 9998
FORMAT(
' UPLO=''', a1,
''', TRANS=''', a1,
''', DIAG=''', a1,
575 $
''', N=', i5,
', NB=', i4,
', type ', i2,
',
576 $ test(', i2,
')= ', g12.5 )
577 9997
FORMAT(
' NORM=''', a1,
''', UPLO =''', a1,
''', N=', i5,
',',
578 $ 11x,
' type ', i2,
', test(', i2,
')=', g12.5 )
579 9996
FORMAT( 1x, a,
'( ''', a1,
''', ''', a1,
''', ''', a1,
''', ''',
580 $ a1,
''',', i5,
', ... ), type ', i2,
', test(', i2,
')=',
subroutine dtrt02(UPLO, TRANS, DIAG, N, NRHS, A, LDA, X, LDX, B, LDB, WORK, RESID)
DTRT02
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine dtrrfs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
DTRRFS
subroutine dtrt03(UPLO, TRANS, DIAG, N, NRHS, A, LDA, SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID)
DTRT03
subroutine derrtr(PATH, NUNIT)
DERRTR
subroutine dlatrs(UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, CNORM, INFO)
DLATRS solves a triangular system of equations with the scale factor set to prevent overflow...
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dlattr(IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B, WORK, INFO)
DLATTR
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 dtrt01(UPLO, DIAG, N, A, LDA, AINV, LDAINV, RCOND, WORK, RESID)
DTRT01
subroutine dtrcon(NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, IWORK, INFO)
DTRCON
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
double precision function dlantr(NORM, UPLO, DIAG, M, N, A, LDA, WORK)
DLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a trapezoidal or triangular matrix.
subroutine dtrtrs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO)
DTRTRS
logical function lsame(CA, CB)
LSAME
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine dtrt06(RCOND, RCONDC, UPLO, DIAG, N, A, LDA, WORK, RAT)
DTRT06
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 dtrt05(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DTRT05
subroutine dchktr(DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, A, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
DCHKTR
subroutine dtrtri(UPLO, DIAG, N, A, LDA, INFO)
DTRTRI