164 SUBROUTINE dchktr( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
165 $ THRESH, TSTERR, NMAX, A, AINV, B, X, XACT,
166 $ WORK, RWORK, IWORK, NOUT )
174 INTEGER NMAX, NN, NNB, NNS, NOUT
175 DOUBLE PRECISION THRESH
179 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
180 DOUBLE PRECISION A( * ), AINV( * ), B( * ), RWORK( * ),
181 $ work( * ), x( * ), xact( * )
187 INTEGER NTYPE1, NTYPES
188 PARAMETER ( NTYPE1 = 10, ntypes = 18 )
190 parameter( ntests = 9 )
192 parameter( ntran = 3 )
193 DOUBLE PRECISION ONE, ZERO
194 parameter( one = 1.0d0, zero = 0.0d0 )
197 CHARACTER DIAG, NORM, TRANS, UPLO, XTYPE
199 INTEGER I, IDIAG, IMAT, IN, INB, INFO, IRHS, ITRAN,
200 $ iuplo, k, lda, n, nb, nerrs, nfail, nrhs, nrun
201 DOUBLE PRECISION AINVNM, ANORM, DUMMY, RCOND, RCONDC, RCONDI,
205 CHARACTER TRANSS( NTRAN ), UPLOS( 2 )
206 INTEGER ISEED( 4 ), ISEEDY( 4 )
207 DOUBLE PRECISION RESULT( NTESTS )
211 DOUBLE PRECISION DLANTR
212 EXTERNAL lsame, dlantr
223 INTEGER INFOT, IOUNIT
226 COMMON / infoc / infot, iounit, ok, lerr
227 COMMON / srnamc / srnamt
233 DATA iseedy / 1988, 1989, 1990, 1991 /
234 DATA uplos /
'U',
'L' / , transs /
'N',
'T',
'C' /
240 path( 1: 1 ) =
'Double precision'
246 iseed( i ) = iseedy( i )
252 $
CALL derrtr( path, nout )
264 DO 80 imat = 1, ntype1
268 IF( .NOT.dotype( imat ) )
275 uplo = uplos( iuplo )
280 CALL dlattr( imat, uplo,
'No transpose', diag, iseed, n,
281 $ a, lda, x, work, info )
285 IF( lsame( diag,
'N' ) )
THEN
301 CALL dlacpy( uplo, n, n, a, lda, ainv, lda )
303 CALL dtrtri( uplo, diag, n, ainv, lda, info )
308 $
CALL alaerh( path,
'DTRTRI', info, 0, uplo // diag,
309 $ n, n, -1, -1, nb, imat, nfail, nerrs,
314 anorm = dlantr(
'I', uplo, diag, n, n, a, lda, rwork )
315 ainvnm = dlantr(
'I', uplo, diag, n, n, ainv, lda,
317 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
320 rcondi = ( one / anorm ) / ainvnm
327 CALL dtrt01( uplo, diag, n, a, lda, ainv, lda, rcondo,
328 $ rwork, result( 1 ) )
332 IF( result( 1 ).GE.thresh )
THEN
333 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
334 $
CALL alahd( nout, path )
335 WRITE( nout, fmt = 9999 )uplo, diag, n, nb, imat,
350 DO 30 itran = 1, ntran
354 trans = transs( itran )
355 IF( itran.EQ.1 )
THEN
367 CALL dlarhs( path, xtype, uplo, trans, n, n, 0,
368 $ idiag, nrhs, a, lda, xact, lda, b,
371 CALL dlacpy(
'Full', n, nrhs, b, lda, x, lda )
374 CALL dtrtrs( uplo, trans, diag, n, nrhs, a, lda,
380 $
CALL alaerh( path,
'DTRTRS', info, 0,
381 $ uplo // trans // diag, n, n, -1,
382 $ -1, nrhs, imat, nfail, nerrs,
390 CALL dtrt02( uplo, trans, diag, n, nrhs, a, lda,
391 $ x, lda, b, lda, work, result( 2 ) )
396 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
404 CALL dtrrfs( uplo, trans, diag, n, nrhs, a, lda,
405 $ b, lda, x, lda, rwork,
406 $ rwork( nrhs+1 ), work, iwork,
412 $
CALL alaerh( path,
'DTRRFS', info, 0,
413 $ uplo // trans // diag, n, n, -1,
414 $ -1, nrhs, imat, nfail, nerrs,
417 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
419 CALL dtrt05( uplo, trans, diag, n, nrhs, a, lda,
420 $ b, lda, x, lda, xact, lda, rwork,
421 $ rwork( nrhs+1 ), result( 5 ) )
427 IF( result( k ).GE.thresh )
THEN
428 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
429 $
CALL alahd( nout, path )
430 WRITE( nout, fmt = 9998 )uplo, trans,
431 $ diag, n, nrhs, imat, k, result( k )
443 IF( itran.EQ.1 )
THEN
451 CALL dtrcon( norm, uplo, diag, n, a, lda, rcond,
452 $ work, iwork, info )
457 $
CALL alaerh( path,
'DTRCON', info, 0,
458 $ norm // uplo // diag, n, n, -1, -1,
459 $ -1, imat, nfail, nerrs, nout )
461 CALL dtrt06( rcond, rcondc, uplo, diag, n, a, lda,
462 $ rwork, result( 7 ) )
466 IF( result( 7 ).GE.thresh )
THEN
467 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
468 $
CALL alahd( nout, path )
469 WRITE( nout, fmt = 9997 )norm, uplo, n, imat,
481 DO 110 imat = ntype1 + 1, ntypes
485 IF( .NOT.dotype( imat ) )
492 uplo = uplos( iuplo )
493 DO 90 itran = 1, ntran
497 trans = transs( itran )
502 CALL dlattr( imat, uplo, trans, diag, iseed, n, a,
503 $ lda, x, work, info )
509 CALL dcopy( n, x, 1, b, 1 )
510 CALL dlatrs( uplo, trans, diag,
'N', n, a, lda, b,
511 $ scale, rwork, info )
516 $
CALL alaerh( path,
'DLATRS', info, 0,
517 $ uplo // trans // diag //
'N', n, n,
518 $ -1, -1, -1, imat, nfail, nerrs, nout )
520 CALL dtrt03( uplo, trans, diag, n, 1, a, lda, scale,
521 $ rwork, one, b, lda, x, lda, work,
527 CALL dcopy( n, x, 1, b( n+1 ), 1 )
528 CALL dlatrs( uplo, trans, diag,
'Y', n, a, lda,
529 $ b( n+1 ), scale, rwork, info )
534 $
CALL alaerh( path,
'DLATRS', info, 0,
535 $ uplo // trans // diag //
'Y', n, n,
536 $ -1, -1, -1, imat, nfail, nerrs, nout )
538 CALL dtrt03( uplo, trans, diag, n, 1, a, lda, scale,
539 $ rwork, one, b( n+1 ), lda, x, lda, work,
545 IF( result( 8 ).GE.thresh )
THEN
546 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
547 $
CALL alahd( nout, path )
548 WRITE( nout, fmt = 9996 )
'DLATRS', uplo, trans,
549 $ diag,
'N', n, imat, 8, result( 8 )
552 IF( result( 9 ).GE.thresh )
THEN
553 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
554 $
CALL alahd( nout, path )
555 WRITE( nout, fmt = 9996 )
'DLATRS', uplo, trans,
556 $ diag,
'Y', n, imat, 9, result( 9 )
567 CALL alasum( path, nout, nfail, nrun, nerrs )
569 9999
FORMAT(
' UPLO=''', a1,
''', DIAG=''', a1,
''', N=', i5,
', NB=',
570 $ i4,
', type ', i2,
', test(', i2,
')= ', g12.5 )
571 9998
FORMAT(
' UPLO=''', a1,
''', TRANS=''', a1,
''', DIAG=''', a1,
572 $
''', N=', i5,
', NB=', i4,
', type ', i2,
',
573 $ test(', i2,
')= ', g12.5 )
574 9997
FORMAT(
' NORM=''', a1,
''', UPLO =''', a1,
''', N=', i5,
',',
575 $ 11x,
' type ', i2,
', test(', i2,
')=', g12.5 )
576 9996
FORMAT( 1x, a,
'( ''', a1,
''', ''', a1,
''', ''', a1,
''', ''',
577 $ 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 alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
DLARHS
subroutine dlattr(IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B, WORK, INFO)
DLATTR
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
subroutine dtrt01(UPLO, DIAG, N, A, LDA, AINV, LDAINV, RCOND, WORK, RESID)
DTRT01
subroutine dtrt02(UPLO, TRANS, DIAG, N, NRHS, A, LDA, X, LDX, B, LDB, WORK, RESID)
DTRT02
subroutine dtrt06(RCOND, RCONDC, UPLO, DIAG, N, A, LDA, WORK, RAT)
DTRT06
subroutine dchktr(DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, A, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
DCHKTR
subroutine derrtr(PATH, NUNIT)
DERRTR
subroutine dtrt03(UPLO, TRANS, DIAG, N, NRHS, A, LDA, SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID)
DTRT03
subroutine dtrt05(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DTRT05
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 dtrrfs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
DTRRFS
subroutine dtrtrs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO)
DTRTRS
subroutine dtrtri(UPLO, DIAG, N, A, LDA, INFO)
DTRTRI
subroutine dtrcon(NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, IWORK, INFO)
DTRCON