184 SUBROUTINE schkge( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS,
185 $ nsval, thresh, tsterr, nmax, a, afac, ainv,
b,
186 $ x, xact, work, rwork, iwork, nout )
195 INTEGER nm, nmax, nn, nnb, nns, nout
200 INTEGER iwork( * ), mval( * ), nbval( * ), nsval( * ),
202 REAL a( * ), afac( * ), ainv( * ),
b( * ),
203 $ rwork( * ), work( * ), x( * ), xact( * )
210 parameter( one = 1.0e+0, zero = 0.0e+0 )
212 parameter( ntypes = 11 )
214 parameter( ntests = 8 )
216 parameter( ntran = 3 )
219 LOGICAL trfcon, zerot
220 CHARACTER dist, norm, trans, type, xtype
222 INTEGER i, im, imat, in, inb, info, ioff, irhs, itran,
223 $ izero, k, kl, ku, lda, lwork, m, mode, n, nb,
224 $ nerrs, nfail, nimat, nrhs, nrun, nt
225 REAL ainvnm, anorm, anormi, anormo, cndnum, dummy,
226 $ rcond, rcondc, rcondi, rcondo
229 CHARACTER transs( ntran )
230 INTEGER iseed( 4 ), iseedy( 4 )
231 REAL result( ntests )
252 COMMON / infoc / infot, nunit, ok, lerr
253 COMMON / srnamc / srnamt
256 DATA iseedy / 1988, 1989, 1990, 1991 / ,
257 $ transs /
'N',
'T',
'C' /
263 path( 1: 1 ) =
'Single precision'
269 iseed( i ) = iseedy( i )
276 $ CALL
serrge( path, nout )
292 IF( m.LE.0 .OR. n.LE.0 )
295 DO 100 imat = 1, nimat
299 IF( .NOT.dotype( imat ) )
304 zerot = imat.GE.5 .AND. imat.LE.7
305 IF( zerot .AND. n.LT.imat-4 )
311 CALL
slatb4( path, imat, m, n, type, kl, ku, anorm, mode,
315 CALL
slatms( m, n, dist, iseed, type, rwork, mode,
316 $ cndnum, anorm, kl, ku,
'No packing', a, lda,
322 CALL
alaerh( path,
'SLATMS', info, 0,
' ', m, n, -1,
323 $ -1, -1, imat, nfail, nerrs, nout )
333 ELSE IF( imat.EQ.6 )
THEN
336 izero = min( m, n ) / 2 + 1
338 ioff = ( izero-1 )*lda
344 CALL
slaset(
'Full', m, n-izero+1, zero, zero,
365 CALL
slacpy(
'Full', m, n, a, lda, afac, lda )
367 CALL
sgetrf( m, n, afac, lda, iwork, info )
372 $ CALL
alaerh( path,
'SGETRF', info, izero,
' ', m,
373 $ n, -1, -1, nb, imat, nfail, nerrs,
380 CALL
slacpy(
'Full', m, n, afac, lda, ainv, lda )
381 CALL
sget01( m, n, a, lda, ainv, lda, iwork, rwork,
389 IF( m.EQ.n .AND. info.EQ.0 )
THEN
390 CALL
slacpy(
'Full', n, n, afac, lda, ainv, lda )
393 lwork = nmax*max( 3, nrhs )
394 CALL
sgetri( n, ainv, lda, iwork, work, lwork,
400 $ CALL
alaerh( path,
'SGETRI', info, 0,
' ', n, n,
401 $ -1, -1, nb, imat, nfail, nerrs,
408 CALL
sget03( n, a, lda, ainv, lda, work, lda,
409 $ rwork, rcondo, result( 2 ) )
410 anormo =
slange(
'O', m, n, a, lda, rwork )
414 anormi =
slange(
'I', m, n, a, lda, rwork )
415 ainvnm =
slange(
'I', n, n, ainv, lda, rwork )
416 IF( anormi.LE.zero .OR. ainvnm.LE.zero )
THEN
419 rcondi = ( one / anormi ) / ainvnm
427 anormo =
slange(
'O', m, n, a, lda, rwork )
428 anormi =
slange(
'I', m, n, a, lda, rwork )
437 IF( result( k ).GE.thresh )
THEN
438 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
439 $ CALL
alahd( nout, path )
440 WRITE( nout, fmt = 9999 )m, n, nb, imat, k,
451 IF( inb.GT.1 .OR. m.NE.n )
460 DO 50 itran = 1, ntran
461 trans = transs( itran )
462 IF( itran.EQ.1 )
THEN
472 CALL
slarhs( path, xtype,
' ', trans, n, n, kl,
473 $ ku, nrhs, a, lda, xact, lda,
b,
477 CALL
slacpy(
'Full', n, nrhs,
b, lda, x, lda )
479 CALL
sgetrs( trans, n, nrhs, afac, lda, iwork,
485 $ CALL
alaerh( path,
'SGETRS', info, 0, trans,
486 $ n, n, -1, -1, nrhs, imat, nfail,
489 CALL
slacpy(
'Full', n, nrhs,
b, lda, work,
491 CALL
sget02( trans, n, n, nrhs, a, lda, x, lda,
492 $ work, lda, rwork, result( 3 ) )
497 CALL
sget04( n, nrhs, x, lda, xact, lda, rcondc,
505 CALL
sgerfs( trans, n, nrhs, a, lda, afac, lda,
506 $ iwork,
b, lda, x, lda, rwork,
507 $ rwork( nrhs+1 ), work,
508 $ iwork( n+1 ), info )
513 $ CALL
alaerh( path,
'SGERFS', info, 0, trans,
514 $ n, n, -1, -1, nrhs, imat, nfail,
517 CALL
sget04( n, nrhs, x, lda, xact, lda, rcondc,
519 CALL
sget07( trans, n, nrhs, a, lda,
b, lda, x,
520 $ lda, xact, lda, rwork, .true.,
521 $ rwork( nrhs+1 ), result( 6 ) )
527 IF( result( k ).GE.thresh )
THEN
528 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
529 $ CALL
alahd( nout, path )
530 WRITE( nout, fmt = 9998 )trans, n, nrhs,
531 $ imat, k, result( k )
544 IF( itran.EQ.1 )
THEN
554 CALL
sgecon( norm, n, afac, lda, anorm, rcond,
555 $ work, iwork( n+1 ), info )
560 $ CALL
alaerh( path,
'SGECON', info, 0, norm, n,
561 $ n, -1, -1, -1, imat, nfail, nerrs,
568 result( 8 ) =
sget06( rcond, rcondc )
573 IF( result( 8 ).GE.thresh )
THEN
574 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
575 $ CALL
alahd( nout, path )
576 WRITE( nout, fmt = 9997 )norm, n, imat, 8,
589 CALL
alasum( path, nout, nfail, nrun, nerrs )
591 9999
FORMAT(
' M = ', i5,
', N =', i5,
', NB =', i4,
', type ', i2,
592 $
', test(', i2,
') =', g12.5 )
593 9998
FORMAT(
' TRANS=''', a1,
''', N =', i5,
', NRHS=', i3,
', type ',
594 $ i2,
', test(', i2,
') =', g12.5 )
595 9997
FORMAT(
' NORM =''', a1,
''', N =', i5,
',', 10x,
' type ', i2,
596 $
', test(', i2,
') =', g12.5 )
subroutine schkge(DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
SCHKGE
subroutine serrge(PATH, NUNIT)
SERRGE
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine sgetrs(TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
SGETRS
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine sgetri(N, A, LDA, IPIV, WORK, LWORK, INFO)
SGETRI
real function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine sget02(TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
SGET02
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
subroutine sgetrf(M, N, A, LDA, IPIV, INFO)
SGETRF
real function sget06(RCOND, RCONDC)
SGET06
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine sget03(N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, RCOND, RESID)
SGET03
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
subroutine sget07(TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, CHKFERR, BERR, RESLTS)
SGET07
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
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 sgecon(NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO)
SGECON
subroutine sget01(M, N, A, LDA, AFAC, LDAFAC, IPIV, RWORK, RESID)
SGET01
subroutine sgerfs(TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
SGERFS
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4