163 SUBROUTINE sdrvge( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
164 $ a, afac, asav,
b, bsav, x, xact, s, work,
165 $ rwork, iwork, nout )
174 INTEGER nmax, nn, nout, nrhs
179 INTEGER iwork( * ), nval( * )
180 REAL a( * ), afac( * ), asav( * ),
b( * ),
181 $ bsav( * ), rwork( * ), s( * ), work( * ),
189 parameter( one = 1.0e+0, zero = 0.0e+0 )
191 parameter( ntypes = 11 )
193 parameter( ntests = 7 )
195 parameter( ntran = 3 )
198 LOGICAL equil, nofact, prefac, trfcon, zerot
199 CHARACTER dist, equed, fact, trans, type, xtype
201 INTEGER i, iequed, ifact, imat, in, info, ioff, itran,
202 $ izero, k, k1, kl, ku, lda, lwork, mode, n, nb,
203 $ nbmin, nerrs, nfact, nfail, nimat, nrun, nt
204 REAL ainvnm, amax, anorm, anormi, anormo, cndnum,
205 $ colcnd, rcond, rcondc, rcondi, rcondo, roldc,
206 $ roldi, roldo, rowcnd, rpvgrw
209 CHARACTER equeds( 4 ), facts( 3 ), transs( ntran )
210 INTEGER iseed( 4 ), iseedy( 4 )
211 REAL result( ntests )
233 COMMON / infoc / infot, nunit, ok, lerr
234 COMMON / srnamc / srnamt
237 DATA iseedy / 1988, 1989, 1990, 1991 /
238 DATA transs /
'N',
'T',
'C' /
239 DATA facts /
'F',
'N',
'E' /
240 DATA equeds /
'N',
'R',
'C',
'B' /
246 path( 1: 1 ) =
'Single precision'
252 iseed( i ) = iseedy( i )
258 $ CALL
serrvx( path, nout )
278 DO 80 imat = 1, nimat
282 IF( .NOT.dotype( imat ) )
287 zerot = imat.GE.5 .AND. imat.LE.7
288 IF( zerot .AND. n.LT.imat-4 )
294 CALL
slatb4( path, imat, n, n, type, kl, ku, anorm, mode,
296 rcondc = one / cndnum
299 CALL
slatms( n, n, dist, iseed, type, rwork, mode, cndnum,
300 $ anorm, kl, ku,
'No packing', a, lda, work,
306 CALL
alaerh( path,
'SLATMS', info, 0,
' ', n, n, -1, -1,
307 $ -1, imat, nfail, nerrs, nout )
317 ELSE IF( imat.EQ.6 )
THEN
322 ioff = ( izero-1 )*lda
328 CALL
slaset(
'Full', n, n-izero+1, zero, zero,
337 CALL
slacpy(
'Full', n, n, a, lda, asav, lda )
340 equed = equeds( iequed )
341 IF( iequed.EQ.1 )
THEN
347 DO 60 ifact = 1, nfact
348 fact = facts( ifact )
349 prefac =
lsame( fact,
'F' )
350 nofact =
lsame( fact,
'N' )
351 equil =
lsame( fact,
'E' )
359 ELSE IF( .NOT.nofact )
THEN
366 CALL
slacpy(
'Full', n, n, asav, lda, afac, lda )
367 IF( equil .OR. iequed.GT.1 )
THEN
372 CALL
sgeequ( n, n, afac, lda, s, s( n+1 ),
373 $ rowcnd, colcnd, amax, info )
374 IF( info.EQ.0 .AND. n.GT.0 )
THEN
375 IF(
lsame( equed,
'R' ) )
THEN
378 ELSE IF(
lsame( equed,
'C' ) )
THEN
381 ELSE IF(
lsame( equed,
'B' ) )
THEN
388 CALL
slaqge( n, n, afac, lda, s, s( n+1 ),
389 $ rowcnd, colcnd, amax, equed )
403 anormo =
slange(
'1', n, n, afac, lda, rwork )
404 anormi =
slange(
'I', n, n, afac, lda, rwork )
409 CALL
sgetrf( n, n, afac, lda, iwork, info )
413 CALL
slacpy(
'Full', n, n, afac, lda, a, lda )
414 lwork = nmax*max( 3, nrhs )
416 CALL
sgetri( n, a, lda, iwork, work, lwork, info )
420 ainvnm =
slange(
'1', n, n, a, lda, rwork )
421 IF( anormo.LE.zero .OR. ainvnm.LE.zero )
THEN
424 rcondo = ( one / anormo ) / ainvnm
429 ainvnm =
slange(
'I', n, n, a, lda, rwork )
430 IF( anormi.LE.zero .OR. ainvnm.LE.zero )
THEN
433 rcondi = ( one / anormi ) / ainvnm
437 DO 50 itran = 1, ntran
441 trans = transs( itran )
442 IF( itran.EQ.1 )
THEN
450 CALL
slacpy(
'Full', n, n, asav, lda, a, lda )
455 CALL
slarhs( path, xtype,
'Full', trans, n, n, kl,
456 $ ku, nrhs, a, lda, xact, lda,
b, lda,
459 CALL
slacpy(
'Full', n, nrhs,
b, lda, bsav, lda )
461 IF( nofact .AND. itran.EQ.1 )
THEN
468 CALL
slacpy(
'Full', n, n, a, lda, afac, lda )
469 CALL
slacpy(
'Full', n, nrhs,
b, lda, x, lda )
472 CALL
sgesv( n, nrhs, afac, lda, iwork, x, lda,
478 $ CALL
alaerh( path,
'SGESV ', info, izero,
479 $
' ', n, n, -1, -1, nrhs, imat,
480 $ nfail, nerrs, nout )
485 CALL
sget01( n, n, a, lda, afac, lda, iwork,
486 $ rwork, result( 1 ) )
488 IF( izero.EQ.0 )
THEN
492 CALL
slacpy(
'Full', n, nrhs,
b, lda, work,
494 CALL
sget02(
'No transpose', n, n, nrhs, a,
495 $ lda, x, lda, work, lda, rwork,
500 CALL
sget04( n, nrhs, x, lda, xact, lda,
501 $ rcondc, result( 3 ) )
509 IF( result( k ).GE.thresh )
THEN
510 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
511 $ CALL
aladhd( nout, path )
512 WRITE( nout, fmt = 9999 )
'SGESV ', n,
513 $ imat, k, result( k )
523 $ CALL
slaset(
'Full', n, n, zero, zero, afac,
525 CALL
slaset(
'Full', n, nrhs, zero, zero, x, lda )
526 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
531 CALL
slaqge( n, n, a, lda, s, s( n+1 ), rowcnd,
532 $ colcnd, amax, equed )
539 CALL
sgesvx( fact, trans, n, nrhs, a, lda, afac,
540 $ lda, iwork, equed, s, s( n+1 ),
b,
541 $ lda, x, lda, rcond, rwork,
542 $ rwork( nrhs+1 ), work, iwork( n+1 ),
548 $ CALL
alaerh( path,
'SGESVX', info, izero,
549 $ fact // trans, n, n, -1, -1, nrhs,
550 $ imat, nfail, nerrs, nout )
555 IF( info.NE.0 .AND. info.LE.n)
THEN
556 rpvgrw =
slantr(
'M',
'U',
'N', info, info,
558 IF( rpvgrw.EQ.zero )
THEN
561 rpvgrw =
slange(
'M', n, info, a, lda,
565 rpvgrw =
slantr(
'M',
'U',
'N', n, n, afac, lda,
567 IF( rpvgrw.EQ.zero )
THEN
570 rpvgrw =
slange(
'M', n, n, a, lda, work ) /
574 result( 7 ) = abs( rpvgrw-work( 1 ) ) /
575 $ max( work( 1 ), rpvgrw ) /
578 IF( .NOT.prefac )
THEN
583 CALL
sget01( n, n, a, lda, afac, lda, iwork,
584 $ rwork( 2*nrhs+1 ), result( 1 ) )
595 CALL
slacpy(
'Full', n, nrhs, bsav, lda, work,
597 CALL
sget02( trans, n, n, nrhs, asav, lda, x,
598 $ lda, work, lda, rwork( 2*nrhs+1 ),
603 IF( nofact .OR. ( prefac .AND.
lsame( equed,
605 CALL
sget04( n, nrhs, x, lda, xact, lda,
606 $ rcondc, result( 3 ) )
608 IF( itran.EQ.1 )
THEN
613 CALL
sget04( n, nrhs, x, lda, xact, lda,
614 $ roldc, result( 3 ) )
620 CALL
sget07( trans, n, nrhs, asav, lda,
b, lda,
621 $ x, lda, xact, lda, rwork, .true.,
622 $ rwork( nrhs+1 ), result( 4 ) )
630 result( 6 ) =
sget06( rcond, rcondc )
635 IF( .NOT.trfcon )
THEN
637 IF( result( k ).GE.thresh )
THEN
638 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
639 $ CALL
aladhd( nout, path )
641 WRITE( nout, fmt = 9997 )
'SGESVX',
642 $ fact, trans, n, equed, imat, k,
645 WRITE( nout, fmt = 9998 )
'SGESVX',
646 $ fact, trans, n, imat, k, result( k )
653 IF( result( 1 ).GE.thresh .AND. .NOT.prefac )
655 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
656 $ CALL
aladhd( nout, path )
658 WRITE( nout, fmt = 9997 )
'SGESVX', fact,
659 $ trans, n, equed, imat, 1, result( 1 )
661 WRITE( nout, fmt = 9998 )
'SGESVX', fact,
662 $ trans, n, imat, 1, result( 1 )
667 IF( result( 6 ).GE.thresh )
THEN
668 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
669 $ CALL
aladhd( nout, path )
671 WRITE( nout, fmt = 9997 )
'SGESVX', fact,
672 $ trans, n, equed, imat, 6, result( 6 )
674 WRITE( nout, fmt = 9998 )
'SGESVX', fact,
675 $ trans, n, imat, 6, result( 6 )
680 IF( result( 7 ).GE.thresh )
THEN
681 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
682 $ CALL
aladhd( nout, path )
684 WRITE( nout, fmt = 9997 )
'SGESVX', fact,
685 $ trans, n, equed, imat, 7, result( 7 )
687 WRITE( nout, fmt = 9998 )
'SGESVX', fact,
688 $ trans, n, imat, 7, result( 7 )
704 CALL
alasvm( path, nout, nfail, nrun, nerrs )
706 9999
FORMAT( 1x, a,
', N =', i5,
', type ', i2,
', test(', i2,
') =',
708 9998
FORMAT( 1x, a,
', FACT=''', a1,
''', TRANS=''', a1,
''', N=', i5,
709 $
', type ', i2,
', test(', i1,
')=', g12.5 )
710 9997
FORMAT( 1x, a,
', FACT=''', a1,
''', TRANS=''', a1,
''', N=', i5,
711 $
', EQUED=''', a1,
''', type ', i2,
', test(', i1,
')=',
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 alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
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 sgesv(N, NRHS, A, LDA, IPIV, B, LDB, INFO)
SGESV computes the solution to system of linear equations A * X = B for GE matrices (simple driver) ...
subroutine sgesvx(FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO)
SGESVX computes the solution to system of linear equations A * X = B for GE matrices ...
subroutine slaqge(M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED)
SLAQGE scales a general rectangular matrix, using row and column scaling factors computed by sgeequ...
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 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
logical function lsame(CA, CB)
LSAME
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
real function slamch(CMACH)
SLAMCH
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine aladhd(IOUNIT, PATH)
ALADHD
subroutine sgeequ(M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO)
SGEEQU
subroutine sget01(M, N, A, LDA, AFAC, LDAFAC, IPIV, RWORK, RESID)
SGET01
subroutine serrvx(PATH, NUNIT)
SERRVX
subroutine sdrvge(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, IWORK, NOUT)
SDRVGE
real function slantr(NORM, UPLO, DIAG, M, N, A, LDA, WORK)
SLANTR 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 slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4