166 SUBROUTINE sdrvge( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
167 $ a, afac, asav,
b, bsav, x, xact, s, work,
168 $ rwork, iwork, nout )
177 INTEGER nmax, nn, nout, nrhs
182 INTEGER iwork( * ), nval( * )
183 REAL a( * ), afac( * ), asav( * ),
b( * ),
184 $ bsav( * ), rwork( * ), s( * ), work( * ),
192 parameter( one = 1.0e+0, zero = 0.0e+0 )
194 parameter( ntypes = 11 )
196 parameter( ntests = 7 )
198 parameter( ntran = 3 )
201 LOGICAL equil, nofact, prefac, trfcon, zerot
202 CHARACTER dist, equed, fact, trans, type, xtype
204 INTEGER i, iequed, ifact, imat, in, info, ioff, itran,
205 $ izero, k, k1, kl, ku, lda, lwork, mode, n, nb,
206 $ nbmin, nerrs, nfact, nfail, nimat, nrun, nt,
208 REAL ainvnm, amax, anorm, anormi, anormo, cndnum,
209 $ colcnd, rcond, rcondc, rcondi, rcondo, roldc,
210 $ roldi, roldo, rowcnd, rpvgrw, rpvgrw_svxx
213 CHARACTER equeds( 4 ), facts( 3 ), transs( ntran )
214 INTEGER iseed( 4 ), iseedy( 4 )
215 REAL result( ntests ), berr( nrhs ),
216 $ errbnds_n( nrhs, 3 ), errbnds_c( nrhs, 3 )
239 COMMON / infoc / infot, nunit, ok, lerr
240 COMMON / srnamc / srnamt
243 DATA iseedy / 1988, 1989, 1990, 1991 /
244 DATA transs /
'N',
'T',
'C' /
245 DATA facts /
'F',
'N',
'E' /
246 DATA equeds /
'N',
'R',
'C',
'B' /
252 path( 1: 1 ) =
'Single precision'
258 iseed( i ) = iseedy( i )
264 $ CALL
serrvx( path, nout )
284 DO 80 imat = 1, nimat
288 IF( .NOT.dotype( imat ) )
293 zerot = imat.GE.5 .AND. imat.LE.7
294 IF( zerot .AND. n.LT.imat-4 )
300 CALL
slatb4( path, imat, n, n, type, kl, ku, anorm, mode,
302 rcondc = one / cndnum
305 CALL
slatms( n, n, dist, iseed, type, rwork, mode, cndnum,
306 $ anorm, kl, ku,
'No packing', a, lda, work,
312 CALL
alaerh( path,
'SLATMS', info, 0,
' ', n, n, -1, -1,
313 $ -1, imat, nfail, nerrs, nout )
323 ELSE IF( imat.EQ.6 )
THEN
328 ioff = ( izero-1 )*lda
334 CALL
slaset(
'Full', n, n-izero+1, zero, zero,
343 CALL
slacpy(
'Full', n, n, a, lda, asav, lda )
346 equed = equeds( iequed )
347 IF( iequed.EQ.1 )
THEN
353 DO 60 ifact = 1, nfact
354 fact = facts( ifact )
355 prefac =
lsame( fact,
'F' )
356 nofact =
lsame( fact,
'N' )
357 equil =
lsame( fact,
'E' )
365 ELSE IF( .NOT.nofact )
THEN
372 CALL
slacpy(
'Full', n, n, asav, lda, afac, lda )
373 IF( equil .OR. iequed.GT.1 )
THEN
378 CALL
sgeequ( n, n, afac, lda, s, s( n+1 ),
379 $ rowcnd, colcnd, amax, info )
380 IF( info.EQ.0 .AND. n.GT.0 )
THEN
381 IF(
lsame( equed,
'R' ) )
THEN
384 ELSE IF(
lsame( equed,
'C' ) )
THEN
387 ELSE IF(
lsame( equed,
'B' ) )
THEN
394 CALL
slaqge( n, n, afac, lda, s, s( n+1 ),
395 $ rowcnd, colcnd, amax, equed )
409 anormo =
slange(
'1', n, n, afac, lda, rwork )
410 anormi =
slange(
'I', n, n, afac, lda, rwork )
414 CALL
sgetrf( n, n, afac, lda, iwork, info )
418 CALL
slacpy(
'Full', n, n, afac, lda, a, lda )
419 lwork = nmax*max( 3, nrhs )
420 CALL
sgetri( n, a, lda, iwork, work, lwork, info )
424 ainvnm =
slange(
'1', n, n, a, lda, rwork )
425 IF( anormo.LE.zero .OR. ainvnm.LE.zero )
THEN
428 rcondo = ( one / anormo ) / ainvnm
433 ainvnm =
slange(
'I', n, n, a, lda, rwork )
434 IF( anormi.LE.zero .OR. ainvnm.LE.zero )
THEN
437 rcondi = ( one / anormi ) / ainvnm
441 DO 50 itran = 1, ntran
445 trans = transs( itran )
446 IF( itran.EQ.1 )
THEN
454 CALL
slacpy(
'Full', n, n, asav, lda, a, lda )
459 CALL
slarhs( path, xtype,
'Full', trans, n, n, kl,
460 $ ku, nrhs, a, lda, xact, lda,
b, lda,
463 CALL
slacpy(
'Full', n, nrhs,
b, lda, bsav, lda )
465 IF( nofact .AND. itran.EQ.1 )
THEN
472 CALL
slacpy(
'Full', n, n, a, lda, afac, lda )
473 CALL
slacpy(
'Full', n, nrhs,
b, lda, x, lda )
476 CALL
sgesv( n, nrhs, afac, lda, iwork, x, lda,
482 $ CALL
alaerh( path,
'SGESV ', info, izero,
483 $
' ', n, n, -1, -1, nrhs, imat,
484 $ nfail, nerrs, nout )
489 CALL
sget01( n, n, a, lda, afac, lda, iwork,
490 $ rwork, result( 1 ) )
492 IF( izero.EQ.0 )
THEN
496 CALL
slacpy(
'Full', n, nrhs,
b, lda, work,
498 CALL
sget02(
'No transpose', n, n, nrhs, a,
499 $ lda, x, lda, work, lda, rwork,
504 CALL
sget04( n, nrhs, x, lda, xact, lda,
505 $ rcondc, result( 3 ) )
513 IF( result( k ).GE.thresh )
THEN
514 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
515 $ CALL
aladhd( nout, path )
516 WRITE( nout, fmt = 9999 )
'SGESV ', n,
517 $ imat, k, result( k )
527 $ CALL
slaset(
'Full', n, n, zero, zero, afac,
529 CALL
slaset(
'Full', n, nrhs, zero, zero, x, lda )
530 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
535 CALL
slaqge( n, n, a, lda, s, s( n+1 ), rowcnd,
536 $ colcnd, amax, equed )
543 CALL
sgesvx( fact, trans, n, nrhs, a, lda, afac,
544 $ lda, iwork, equed, s, s( n+1 ),
b,
545 $ lda, x, lda, rcond, rwork,
546 $ rwork( nrhs+1 ), work, iwork( n+1 ),
552 $ CALL
alaerh( path,
'SGESVX', info, izero,
553 $ fact // trans, n, n, -1, -1, nrhs,
554 $ imat, nfail, nerrs, nout )
560 rpvgrw =
slantr(
'M',
'U',
'N', info, info,
562 IF( rpvgrw.EQ.zero )
THEN
565 rpvgrw =
slange(
'M', n, info, a, lda,
569 rpvgrw =
slantr(
'M',
'U',
'N', n, n, afac, lda,
571 IF( rpvgrw.EQ.zero )
THEN
574 rpvgrw =
slange(
'M', n, n, a, lda, work ) /
578 result( 7 ) = abs( rpvgrw-work( 1 ) ) /
579 $ max( work( 1 ), rpvgrw ) /
582 IF( .NOT.prefac )
THEN
587 CALL
sget01( n, n, a, lda, afac, lda, iwork,
588 $ rwork( 2*nrhs+1 ), result( 1 ) )
599 CALL
slacpy(
'Full', n, nrhs, bsav, lda, work,
601 CALL
sget02( trans, n, n, nrhs, asav, lda, x,
602 $ lda, work, lda, rwork( 2*nrhs+1 ),
607 IF( nofact .OR. ( prefac .AND.
lsame( equed,
609 CALL
sget04( n, nrhs, x, lda, xact, lda,
610 $ rcondc, result( 3 ) )
612 IF( itran.EQ.1 )
THEN
617 CALL
sget04( n, nrhs, x, lda, xact, lda,
618 $ roldc, result( 3 ) )
624 CALL
sget07( trans, n, nrhs, asav, lda,
b, lda,
625 $ x, lda, xact, lda, rwork, .true.,
626 $ rwork( nrhs+1 ), result( 4 ) )
634 result( 6 ) =
sget06( rcond, rcondc )
639 IF( .NOT.trfcon )
THEN
641 IF( result( k ).GE.thresh )
THEN
642 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
643 $ CALL
aladhd( nout, path )
645 WRITE( nout, fmt = 9997 )
'SGESVX',
646 $ fact, trans, n, equed, imat, k,
649 WRITE( nout, fmt = 9998 )
'SGESVX',
650 $ fact, trans, n, imat, k, result( k )
657 IF( result( 1 ).GE.thresh .AND. .NOT.prefac )
659 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
660 $ CALL
aladhd( nout, path )
662 WRITE( nout, fmt = 9997 )
'SGESVX', fact,
663 $ trans, n, equed, imat, 1, result( 1 )
665 WRITE( nout, fmt = 9998 )
'SGESVX', fact,
666 $ trans, n, imat, 1, result( 1 )
671 IF( result( 6 ).GE.thresh )
THEN
672 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
673 $ CALL
aladhd( nout, path )
675 WRITE( nout, fmt = 9997 )
'SGESVX', fact,
676 $ trans, n, equed, imat, 6, result( 6 )
678 WRITE( nout, fmt = 9998 )
'SGESVX', fact,
679 $ trans, n, imat, 6, result( 6 )
684 IF( result( 7 ).GE.thresh )
THEN
685 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
686 $ CALL
aladhd( nout, path )
688 WRITE( nout, fmt = 9997 )
'SGESVX', fact,
689 $ trans, n, equed, imat, 7, result( 7 )
691 WRITE( nout, fmt = 9998 )
'SGESVX', fact,
692 $ trans, n, imat, 7, result( 7 )
704 CALL
slacpy(
'Full', n, n, asav, lda, a, lda )
705 CALL
slacpy(
'Full', n, nrhs, bsav, lda,
b, lda )
708 $ CALL
slaset(
'Full', n, n, zero, zero, afac,
710 CALL
slaset(
'Full', n, nrhs, zero, zero, x, lda )
711 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
716 CALL
slaqge( n, n, a, lda, s, s( n+1 ), rowcnd,
717 $ colcnd, amax, equed )
725 CALL
sgesvxx( fact, trans, n, nrhs, a, lda, afac,
726 $ lda, iwork, equed, s, s( n+1 ),
b, lda, x,
727 $ lda, rcond, rpvgrw_svxx, berr, n_err_bnds,
728 $ errbnds_n, errbnds_c, 0, zero, work,
729 $ iwork( n+1 ), info )
733 IF( info.EQ.n+1 ) goto 50
734 IF( info.NE.izero )
THEN
735 CALL
alaerh( path,
'SGESVXX', info, izero,
736 $ fact // trans, n, n, -1, -1, nrhs,
737 $ imat, nfail, nerrs, nout )
745 IF ( info .GT. 0 .AND. info .LT. n+1 )
THEN
747 $ (n, info, a, lda, afac, lda)
750 $ (n, n, a, lda, afac, lda)
753 result( 7 ) = abs( rpvgrw-rpvgrw_svxx ) /
754 $ max( rpvgrw_svxx, rpvgrw ) /
757 IF( .NOT.prefac )
THEN
762 CALL
sget01( n, n, a, lda, afac, lda, iwork,
763 $ rwork( 2*nrhs+1 ), result( 1 ) )
774 CALL
slacpy(
'Full', n, nrhs, bsav, lda, work,
776 CALL
sget02( trans, n, n, nrhs, asav, lda, x,
777 $ lda, work, lda, rwork( 2*nrhs+1 ),
782 IF( nofact .OR. ( prefac .AND.
lsame( equed,
784 CALL
sget04( n, nrhs, x, lda, xact, lda,
785 $ rcondc, result( 3 ) )
787 IF( itran.EQ.1 )
THEN
792 CALL
sget04( n, nrhs, x, lda, xact, lda,
793 $ roldc, result( 3 ) )
802 result( 6 ) =
sget06( rcond, rcondc )
807 IF( .NOT.trfcon )
THEN
809 IF( result( k ).GE.thresh )
THEN
810 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
811 $ CALL
aladhd( nout, path )
813 WRITE( nout, fmt = 9997 )
'SGESVXX',
814 $ fact, trans, n, equed, imat, k,
817 WRITE( nout, fmt = 9998 )
'SGESVXX',
818 $ fact, trans, n, imat, k, result( k )
825 IF( result( 1 ).GE.thresh .AND. .NOT.prefac )
827 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
828 $ CALL
aladhd( nout, path )
830 WRITE( nout, fmt = 9997 )
'SGESVXX', fact,
831 $ trans, n, equed, imat, 1, result( 1 )
833 WRITE( nout, fmt = 9998 )
'SGESVXX', fact,
834 $ trans, n, imat, 1, result( 1 )
839 IF( result( 6 ).GE.thresh )
THEN
840 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
841 $ CALL
aladhd( nout, path )
843 WRITE( nout, fmt = 9997 )
'SGESVXX', fact,
844 $ trans, n, equed, imat, 6, result( 6 )
846 WRITE( nout, fmt = 9998 )
'SGESVXX', fact,
847 $ trans, n, imat, 6, result( 6 )
852 IF( result( 7 ).GE.thresh )
THEN
853 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
854 $ CALL
aladhd( nout, path )
856 WRITE( nout, fmt = 9997 )
'SGESVXX', fact,
857 $ trans, n, equed, imat, 7, result( 7 )
859 WRITE( nout, fmt = 9998 )
'SGESVXX', fact,
860 $ trans, n, imat, 7, result( 7 )
876 CALL
alasvm( path, nout, nfail, nrun, nerrs )
883 9999
FORMAT( 1x, a,
', N =', i5,
', type ', i2,
', test(', i2,
') =',
885 9998
FORMAT( 1x, a,
', FACT=''', a1,
''', TRANS=''', a1,
''', N=', i5,
886 $
', type ', i2,
', test(', i1,
')=', g12.5 )
887 9997
FORMAT( 1x, a,
', FACT=''', a1,
''', TRANS=''', a1,
''', N=', i5,
888 $
', 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
subroutine sebchvxx(THRESH, PATH)
SEBCHVXX
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
real function sla_gerpvgrw(N, NCOLS, A, LDA, AF, LDAF)
SLA_GERPVGRW
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 sgesvxx(FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO)
SGESVXX computes the solution to system of linear equations A * X = B for GE matrices ...
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