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 = 10 )
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, BIGNUM, DLAMCH, DUMMY, RCOND,
202 $ RCONDC, RCONDI, RCONDO, RES, SCALE
205 CHARACTER TRANSS( NTRAN ), UPLOS( 2 )
206 INTEGER ISEED( 4 ), ISEEDY( 4 )
207 DOUBLE PRECISION RESULT( NTESTS ), SCALE3( 2 )
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'
242 bignum = dlamch(
'Overflow') / dlamch(
'Precision')
247 iseed( i ) = iseedy( i )
253 $
CALL derrtr( path, nout )
265 DO 80 imat = 1, ntype1
269 IF( .NOT.dotype( imat ) )
276 uplo = uplos( iuplo )
281 CALL dlattr( imat, uplo,
'No transpose', diag, iseed, n,
282 $ a, lda, x, work, info )
286 IF( lsame( diag,
'N' ) )
THEN
302 CALL dlacpy( uplo, n, n, a, lda, ainv, lda )
304 CALL dtrtri( uplo, diag, n, ainv, lda, info )
309 $
CALL alaerh( path,
'DTRTRI', info, 0, uplo // diag,
310 $ n, n, -1, -1, nb, imat, nfail, nerrs,
315 anorm = dlantr(
'I', uplo, diag, n, n, a, lda, rwork )
316 ainvnm = dlantr(
'I', uplo, diag, n, n, ainv, lda,
318 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
321 rcondi = ( one / anorm ) / ainvnm
328 CALL dtrt01( uplo, diag, n, a, lda, ainv, lda, rcondo,
329 $ rwork, result( 1 ) )
333 IF( result( 1 ).GE.thresh )
THEN
334 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
335 $
CALL alahd( nout, path )
336 WRITE( nout, fmt = 9999 )uplo, diag, n, nb, imat,
351 DO 30 itran = 1, ntran
355 trans = transs( itran )
356 IF( itran.EQ.1 )
THEN
368 CALL dlarhs( path, xtype, uplo, trans, n, n, 0,
369 $ idiag, nrhs, a, lda, xact, lda, b,
372 CALL dlacpy(
'Full', n, nrhs, b, lda, x, lda )
375 CALL dtrtrs( uplo, trans, diag, n, nrhs, a, lda,
381 $
CALL alaerh( path,
'DTRTRS', info, 0,
382 $ uplo // trans // diag, n, n, -1,
383 $ -1, nrhs, imat, nfail, nerrs,
391 CALL dtrt02( uplo, trans, diag, n, nrhs, a, lda,
392 $ x, lda, b, lda, work, result( 2 ) )
397 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
405 CALL dtrrfs( uplo, trans, diag, n, nrhs, a, lda,
406 $ b, lda, x, lda, rwork,
407 $ rwork( nrhs+1 ), work, iwork,
413 $
CALL alaerh( path,
'DTRRFS', info, 0,
414 $ uplo // trans // diag, n, n, -1,
415 $ -1, nrhs, imat, nfail, nerrs,
418 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
420 CALL dtrt05( uplo, trans, diag, n, nrhs, a, lda,
421 $ b, lda, x, lda, xact, lda, rwork,
422 $ rwork( nrhs+1 ), result( 5 ) )
428 IF( result( k ).GE.thresh )
THEN
429 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
430 $
CALL alahd( nout, path )
431 WRITE( nout, fmt = 9998 )uplo, trans,
432 $ diag, n, nrhs, imat, k, result( k )
444 IF( itran.EQ.1 )
THEN
452 CALL dtrcon( norm, uplo, diag, n, a, lda, rcond,
453 $ work, iwork, info )
458 $
CALL alaerh( path,
'DTRCON', info, 0,
459 $ norm // uplo // diag, n, n, -1, -1,
460 $ -1, imat, nfail, nerrs, nout )
462 CALL dtrt06( rcond, rcondc, uplo, diag, n, a, lda,
463 $ rwork, result( 7 ) )
467 IF( result( 7 ).GE.thresh )
THEN
468 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
469 $
CALL alahd( nout, path )
470 WRITE( nout, fmt = 9997 )norm, uplo, n, imat,
482 DO 110 imat = ntype1 + 1, ntypes
486 IF( .NOT.dotype( imat ) )
493 uplo = uplos( iuplo )
494 DO 90 itran = 1, ntran
498 trans = transs( itran )
503 CALL dlattr( imat, uplo, trans, diag, iseed, n, a,
504 $ lda, x, work, info )
510 CALL dcopy( n, x, 1, b, 1 )
511 CALL dlatrs( uplo, trans, diag,
'N', n, a, lda, b,
512 $ scale, rwork, info )
517 $
CALL alaerh( path,
'DLATRS', info, 0,
518 $ uplo // trans // diag //
'N', n, n,
519 $ -1, -1, -1, imat, nfail, nerrs, nout )
521 CALL dtrt03( uplo, trans, diag, n, 1, a, lda, scale,
522 $ rwork, one, b, lda, x, lda, work,
528 CALL dcopy( n, x, 1, b( n+1 ), 1 )
529 CALL dlatrs( uplo, trans, diag,
'Y', n, a, lda,
530 $ b( n+1 ), scale, rwork, info )
535 $
CALL alaerh( path,
'DLATRS', info, 0,
536 $ uplo // trans // diag //
'Y', n, n,
537 $ -1, -1, -1, imat, nfail, nerrs, nout )
539 CALL dtrt03( uplo, trans, diag, n, 1, a, lda, scale,
540 $ rwork, one, b( n+1 ), lda, x, lda, work,
547 CALL dcopy( n, x, 1, b, 1 )
548 CALL dcopy( n, x, 1, b( n+1 ), 1 )
549 CALL dscal( n, bignum, b( n+1 ), 1 )
550 CALL dlatrs3( uplo, trans, diag,
'N', n, 2, a, lda,
551 $ b, max(1, n), scale3, rwork, work, nmax,
557 $
CALL alaerh( path,
'DLATRS3', info, 0,
558 $ uplo // trans // diag //
'N', n, n,
559 $ -1, -1, -1, imat, nfail, nerrs, nout )
560 CALL dtrt03( uplo, trans, diag, n, 1, a, lda,
561 $ scale3( 1 ), rwork, one, b( 1 ), lda,
562 $ x, lda, work, result( 10 ) )
563 CALL dscal( n, bignum, x, 1 )
564 CALL dtrt03( uplo, trans, diag, n, 1, a, lda,
565 $ scale3( 2 ), rwork, one, b( n+1 ), lda,
566 $ x, lda, work, res )
567 result( 10 ) = max( result( 10 ), res )
572 IF( result( 8 ).GE.thresh )
THEN
573 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
574 $
CALL alahd( nout, path )
575 WRITE( nout, fmt = 9996 )
'DLATRS', uplo, trans,
576 $ diag,
'N', n, imat, 8, result( 8 )
579 IF( result( 9 ).GE.thresh )
THEN
580 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
581 $
CALL alahd( nout, path )
582 WRITE( nout, fmt = 9996 )
'DLATRS', uplo, trans,
583 $ diag,
'Y', n, imat, 9, result( 9 )
586 IF( result( 10 ).GE.thresh )
THEN
587 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
588 $
CALL alahd( nout, path )
589 WRITE( nout, fmt = 9996 )
'DLATRS3', uplo, trans,
590 $ diag,
'N', n, imat, 10, result( 10 )
601 CALL alasum( path, nout, nfail, nrun, nerrs )
603 9999
FORMAT(
' UPLO=''', a1,
''', DIAG=''', a1,
''', N=', i5,
', NB=',
604 $ i4,
', type ', i2,
', test(', i2,
')= ', g12.5 )
605 9998
FORMAT(
' UPLO=''', a1,
''', TRANS=''', a1,
''', DIAG=''', a1,
606 $
''', N=', i5,
', NB=', i4,
', type ', i2,
', test(',
608 9997
FORMAT(
' NORM=''', a1,
''', UPLO =''', a1,
''', N=', i5,
',',
609 $ 11x,
' type ', i2,
', test(', i2,
')=', g12.5 )
610 9996
FORMAT( 1x, a,
'( ''', a1,
''', ''', a1,
''', ''', a1,
''', ''',
611 $ a1,
''',', i5,
', ... ), type ', i2,
', test(', i2,
')=',
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
subroutine dlarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
DLARHS
subroutine xlaenv(ispec, nvalue)
XLAENV
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
subroutine alahd(iounit, path)
ALAHD
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 dget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
DGET04
subroutine dlattr(imat, uplo, trans, diag, iseed, n, a, lda, b, work, info)
DLATTR
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 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 dtrt06(rcond, rcondc, uplo, diag, n, a, lda, work, rat)
DTRT06
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
subroutine dlacpy(uplo, m, n, a, lda, b, ldb)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dlatrs3(uplo, trans, diag, normin, n, nrhs, a, lda, x, ldx, scale, cnorm, work, lwork, info)
DLATRS3 solves a triangular system of equations with the scale factors set to prevent overflow.
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 dscal(n, da, dx, incx)
DSCAL
subroutine dtrcon(norm, uplo, diag, n, a, lda, rcond, work, iwork, info)
DTRCON
subroutine dtrrfs(uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, ldx, ferr, berr, work, iwork, info)
DTRRFS
subroutine dtrtri(uplo, diag, n, a, lda, info)
DTRTRI
subroutine dtrtrs(uplo, trans, diag, n, nrhs, a, lda, b, ldb, info)
DTRTRS