166 SUBROUTINE schktr( 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
182 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
183 REAL 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 )
197 parameter( one = 1.0e0, zero = 0.0e0 )
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 REAL AINVNM, ANORM, DUMMY, RCOND, RCONDC, RCONDI,
208 CHARACTER TRANSS( ntran ), UPLOS( 2 )
209 INTEGER ISEED( 4 ), ISEEDY( 4 )
210 REAL RESULT( ntests )
215 EXTERNAL lsame, slantr
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 ) =
'Single precision'
249 iseed( i ) = iseedy( i )
255 $ CALL
serrtr( path, nout )
267 DO 80 imat = 1, ntype1
271 IF( .NOT.dotype( imat ) )
278 uplo = uplos( iuplo )
283 CALL
slattr( imat, uplo,
'No transpose', diag, iseed, n,
284 $ a, lda, x, work, info )
288 IF( lsame( diag,
'N' ) )
THEN
304 CALL
slacpy( uplo, n, n, a, lda, ainv, lda )
306 CALL
strtri( uplo, diag, n, ainv, lda, info )
311 $ CALL
alaerh( path,
'STRTRI', info, 0, uplo // diag,
312 $ n, n, -1, -1, nb, imat, nfail, nerrs,
317 anorm = slantr(
'I', uplo, diag, n, n, a, lda, rwork )
318 ainvnm = slantr(
'I', uplo, diag, n, n, ainv, lda,
320 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
323 rcondi = ( one / anorm ) / ainvnm
330 CALL
strt01( 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
slarhs( path, xtype, uplo, trans, n, n, 0,
371 $ idiag, nrhs, a, lda, xact, lda, b,
374 CALL
slacpy(
'Full', n, nrhs, b, lda, x, lda )
377 CALL
strtrs( uplo, trans, diag, n, nrhs, a, lda,
383 $ CALL
alaerh( path,
'STRTRS', info, 0,
384 $ uplo // trans // diag, n, n, -1,
385 $ -1, nrhs, imat, nfail, nerrs,
393 CALL
strt02( uplo, trans, diag, n, nrhs, a, lda,
394 $ x, lda, b, lda, work, result( 2 ) )
399 CALL
sget04( n, nrhs, x, lda, xact, lda, rcondc,
407 CALL
strrfs( uplo, trans, diag, n, nrhs, a, lda,
408 $ b, lda, x, lda, rwork,
409 $ rwork( nrhs+1 ), work, iwork,
415 $ CALL
alaerh( path,
'STRRFS', info, 0,
416 $ uplo // trans // diag, n, n, -1,
417 $ -1, nrhs, imat, nfail, nerrs,
420 CALL
sget04( n, nrhs, x, lda, xact, lda, rcondc,
422 CALL
strt05( 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
strcon( norm, uplo, diag, n, a, lda, rcond,
455 $ work, iwork, info )
460 $ CALL
alaerh( path,
'STRCON', info, 0,
461 $ norm // uplo // diag, n, n, -1, -1,
462 $ -1, imat, nfail, nerrs, nout )
464 CALL
strt06( 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
slattr( imat, uplo, trans, diag, iseed, n, a,
506 $ lda, x, work, info )
512 CALL
scopy( n, x, 1, b, 1 )
513 CALL
slatrs( uplo, trans, diag,
'N', n, a, lda, b,
514 $ scale, rwork, info )
519 $ CALL
alaerh( path,
'SLATRS', info, 0,
520 $ uplo // trans // diag //
'N', n, n,
521 $ -1, -1, -1, imat, nfail, nerrs, nout )
523 CALL
strt03( uplo, trans, diag, n, 1, a, lda, scale,
524 $ rwork, one, b, lda, x, lda, work,
530 CALL
scopy( n, x, 1, b( n+1 ), 1 )
531 CALL
slatrs( uplo, trans, diag,
'Y', n, a, lda,
532 $ b( n+1 ), scale, rwork, info )
537 $ CALL
alaerh( path,
'SLATRS', info, 0,
538 $ uplo // trans // diag //
'Y', n, n,
539 $ -1, -1, -1, imat, nfail, nerrs, nout )
541 CALL
strt03( 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 )
'SLATRS', 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 )
'SLATRS', 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 strt03(UPLO, TRANS, DIAG, N, NRHS, A, LDA, SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID)
STRT03
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine strt06(RCOND, RCONDC, UPLO, DIAG, N, A, LDA, WORK, RAT)
STRT06
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
subroutine strcon(NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, IWORK, INFO)
STRCON
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine strt01(UPLO, DIAG, N, A, LDA, AINV, LDAINV, RCOND, WORK, RESID)
STRT01
subroutine strt02(UPLO, TRANS, DIAG, N, NRHS, A, LDA, X, LDX, B, LDB, WORK, RESID)
STRT02
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
subroutine slatrs(UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, CNORM, INFO)
SLATRS solves a triangular system of equations with the scale factor set to prevent overflow...
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine strtrs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO)
STRTRS
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine strtri(UPLO, DIAG, N, A, LDA, INFO)
STRTRI
subroutine slattr(IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B, WORK, INFO)
SLATTR
subroutine schktr(DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, A, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
SCHKTR
subroutine strt05(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
STRT05
subroutine serrtr(PATH, NUNIT)
SERRTR
subroutine strrfs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
STRRFS