161 SUBROUTINE sdrvge( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
162 $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK,
163 $ RWORK, IWORK, NOUT )
171 INTEGER NMAX, NN, NOUT, NRHS
176 INTEGER IWORK( * ), NVAL( * )
177 REAL A( * ), AFAC( * ), ASAV( * ), B( * ),
178 $ bsav( * ), rwork( * ), s( * ), work( * ),
186 PARAMETER ( ONE = 1.0e+0, zero = 0.0e+0 )
188 parameter( ntypes = 11 )
190 parameter( ntests = 7 )
192 parameter( ntran = 3 )
195 LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT
196 CHARACTER DIST, EQUED, FACT, TRANS,
TYPE, XTYPE
198 INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, ITRAN,
199 $ izero, k, k1, kl, ku, lda, lwork, mode, n, nb,
200 $ nbmin, nerrs, nfact, nfail, nimat, nrun, nt
201 REAL AINVNM, AMAX, ANORM, ANORMI, ANORMO, CNDNUM,
202 $ COLCND, RCOND, RCONDC, RCONDI, RCONDO, ROLDC,
203 $ roldi, roldo, rowcnd, rpvgrw
206 CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN )
207 INTEGER ISEED( 4 ), ISEEDY( 4 )
208 REAL RESULT( NTESTS )
212 REAL SGET06, SLAMCH, SLANGE, SLANTR
213 EXTERNAL lsame, sget06, slamch, slange, slantr
230 COMMON / infoc / infot, nunit, ok, lerr
231 COMMON / srnamc / srnamt
234 DATA iseedy / 1988, 1989, 1990, 1991 /
235 DATA transs /
'N',
'T',
'C' /
236 DATA facts /
'F',
'N',
'E' /
237 DATA equeds /
'N',
'R',
'C',
'B' /
243 path( 1: 1 ) =
'Single precision'
249 iseed( i ) = iseedy( i )
255 $
CALL serrvx( path, nout )
275 DO 80 imat = 1, nimat
279 IF( .NOT.dotype( imat ) )
284 zerot = imat.GE.5 .AND. imat.LE.7
285 IF( zerot .AND. n.LT.imat-4 )
291 CALL slatb4( path, imat, n, n,
TYPE, kl, ku, anorm, mode,
293 rcondc = one / cndnum
296 CALL slatms( n, n, dist, iseed,
TYPE, rwork, mode, cndnum,
297 $ anorm, kl, ku,
'No packing', a, lda, work,
303 CALL alaerh( path,
'SLATMS', info, 0,
' ', n, n, -1, -1,
304 $ -1, imat, nfail, nerrs, nout )
314 ELSE IF( imat.EQ.6 )
THEN
319 ioff = ( izero-1 )*lda
325 CALL slaset(
'Full', n, n-izero+1, zero, zero,
334 CALL slacpy(
'Full', n, n, a, lda, asav, lda )
337 equed = equeds( iequed )
338 IF( iequed.EQ.1 )
THEN
344 DO 60 ifact = 1, nfact
345 fact = facts( ifact )
346 prefac = lsame( fact,
'F' )
347 nofact = lsame( fact,
'N' )
348 equil = lsame( fact,
'E' )
356 ELSE IF( .NOT.nofact )
THEN
363 CALL slacpy(
'Full', n, n, asav, lda, afac, lda )
364 IF( equil .OR. iequed.GT.1 )
THEN
369 CALL sgeequ( n, n, afac, lda, s, s( n+1 ),
370 $ rowcnd, colcnd, amax, info )
371 IF( info.EQ.0 .AND. n.GT.0 )
THEN
372 IF( lsame( equed,
'R' ) )
THEN
375 ELSE IF( lsame( equed,
'C' ) )
THEN
378 ELSE IF( lsame( equed,
'B' ) )
THEN
385 CALL slaqge( n, n, afac, lda, s, s( n+1 ),
386 $ rowcnd, colcnd, amax, equed )
400 anormo = slange(
'1', n, n, afac, lda, rwork )
401 anormi = slange(
'I', n, n, afac, lda, rwork )
406 CALL sgetrf( n, n, afac, lda, iwork, info )
410 CALL slacpy(
'Full', n, n, afac, lda, a, lda )
411 lwork = nmax*max( 3, nrhs )
413 CALL sgetri( n, a, lda, iwork, work, lwork, info )
417 ainvnm = slange(
'1', n, n, a, lda, rwork )
418 IF( anormo.LE.zero .OR. ainvnm.LE.zero )
THEN
421 rcondo = ( one / anormo ) / ainvnm
426 ainvnm = slange(
'I', n, n, a, lda, rwork )
427 IF( anormi.LE.zero .OR. ainvnm.LE.zero )
THEN
430 rcondi = ( one / anormi ) / ainvnm
434 DO 50 itran = 1, ntran
438 trans = transs( itran )
439 IF( itran.EQ.1 )
THEN
447 CALL slacpy(
'Full', n, n, asav, lda, a, lda )
452 CALL slarhs( path, xtype,
'Full', trans, n, n, kl,
453 $ ku, nrhs, a, lda, xact, lda, b, lda,
456 CALL slacpy(
'Full', n, nrhs, b, lda, bsav, lda )
458 IF( nofact .AND. itran.EQ.1 )
THEN
465 CALL slacpy(
'Full', n, n, a, lda, afac, lda )
466 CALL slacpy(
'Full', n, nrhs, b, lda, x, lda )
469 CALL sgesv( n, nrhs, afac, lda, iwork, x, lda,
475 $
CALL alaerh( path,
'SGESV ', info, izero,
476 $
' ', n, n, -1, -1, nrhs, imat,
477 $ nfail, nerrs, nout )
482 CALL sget01( n, n, a, lda, afac, lda, iwork,
483 $ rwork, result( 1 ) )
485 IF( izero.EQ.0 )
THEN
489 CALL slacpy(
'Full', n, nrhs, b, lda, work,
491 CALL sget02(
'No transpose', n, n, nrhs, a,
492 $ lda, x, lda, work, lda, rwork,
497 CALL sget04( n, nrhs, x, lda, xact, lda,
498 $ rcondc, result( 3 ) )
506 IF( result( k ).GE.thresh )
THEN
507 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
508 $
CALL aladhd( nout, path )
509 WRITE( nout, fmt = 9999 )
'SGESV ', n,
510 $ imat, k, result( k )
520 $
CALL slaset(
'Full', n, n, zero, zero, afac,
522 CALL slaset(
'Full', n, nrhs, zero, zero, x, lda )
523 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
528 CALL slaqge( n, n, a, lda, s, s( n+1 ), rowcnd,
529 $ colcnd, amax, equed )
536 CALL sgesvx( fact, trans, n, nrhs, a, lda, afac,
537 $ lda, iwork, equed, s, s( n+1 ), b,
538 $ lda, x, lda, rcond, rwork,
539 $ rwork( nrhs+1 ), work, iwork( n+1 ),
545 $
CALL alaerh( path,
'SGESVX', info, izero,
546 $ fact // trans, n, n, -1, -1, nrhs,
547 $ imat, nfail, nerrs, nout )
552 IF( info.NE.0 .AND. info.LE.n)
THEN
553 rpvgrw = slantr(
'M',
'U',
'N', info, info,
555 IF( rpvgrw.EQ.zero )
THEN
558 rpvgrw = slange(
'M', n, info, a, lda,
562 rpvgrw = slantr(
'M',
'U',
'N', n, n, afac, lda,
564 IF( rpvgrw.EQ.zero )
THEN
567 rpvgrw = slange(
'M', n, n, a, lda, work ) /
571 result( 7 ) = abs( rpvgrw-work( 1 ) ) /
572 $ max( work( 1 ), rpvgrw ) /
575 IF( .NOT.prefac )
THEN
580 CALL sget01( n, n, a, lda, afac, lda, iwork,
581 $ rwork( 2*nrhs+1 ), result( 1 ) )
592 CALL slacpy(
'Full', n, nrhs, bsav, lda, work,
594 CALL sget02( trans, n, n, nrhs, asav, lda, x,
595 $ lda, work, lda, rwork( 2*nrhs+1 ),
600 IF( nofact .OR. ( prefac .AND. lsame( equed,
602 CALL sget04( n, nrhs, x, lda, xact, lda,
603 $ rcondc, result( 3 ) )
605 IF( itran.EQ.1 )
THEN
610 CALL sget04( n, nrhs, x, lda, xact, lda,
611 $ roldc, result( 3 ) )
617 CALL sget07( trans, n, nrhs, asav, lda, b, lda,
618 $ x, lda, xact, lda, rwork, .true.,
619 $ rwork( nrhs+1 ), result( 4 ) )
627 result( 6 ) = sget06( rcond, rcondc )
632 IF( .NOT.trfcon )
THEN
634 IF( result( k ).GE.thresh )
THEN
635 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
636 $
CALL aladhd( nout, path )
638 WRITE( nout, fmt = 9997 )
'SGESVX',
639 $ fact, trans, n, equed, imat, k,
642 WRITE( nout, fmt = 9998 )
'SGESVX',
643 $ fact, trans, n, imat, k, result( k )
648 nrun = nrun + ntests - k1 + 1
650 IF( result( 1 ).GE.thresh .AND. .NOT.prefac )
652 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
653 $
CALL aladhd( nout, path )
655 WRITE( nout, fmt = 9997 )
'SGESVX', fact,
656 $ trans, n, equed, imat, 1, result( 1 )
658 WRITE( nout, fmt = 9998 )
'SGESVX', fact,
659 $ trans, n, imat, 1, result( 1 )
664 IF( result( 6 ).GE.thresh )
THEN
665 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
666 $
CALL aladhd( nout, path )
668 WRITE( nout, fmt = 9997 )
'SGESVX', fact,
669 $ trans, n, equed, imat, 6, result( 6 )
671 WRITE( nout, fmt = 9998 )
'SGESVX', fact,
672 $ trans, n, imat, 6, result( 6 )
677 IF( result( 7 ).GE.thresh )
THEN
678 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
679 $
CALL aladhd( nout, path )
681 WRITE( nout, fmt = 9997 )
'SGESVX', fact,
682 $ trans, n, equed, imat, 7, result( 7 )
684 WRITE( nout, fmt = 9998 )
'SGESVX', fact,
685 $ trans, n, imat, 7, result( 7 )
701 CALL alasvm( path, nout, nfail, nrun, nerrs )
703 9999
FORMAT( 1x, a,
', N =', i5,
', type ', i2,
', test(', i2,
') =',
705 9998
FORMAT( 1x, a,
', FACT=''', a1,
''', TRANS=''', a1,
''', N=', i5,
706 $
', type ', i2,
', test(', i1,
')=', g12.5 )
707 9997
FORMAT( 1x, a,
', FACT=''', a1,
''', TRANS=''', a1,
''', N=', i5,
708 $
', 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 slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine aladhd(IOUNIT, PATH)
ALADHD
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
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 sgetri(N, A, LDA, IPIV, WORK, LWORK, INFO)
SGETRI
subroutine sgeequ(M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO)
SGEEQU
subroutine sgetrf(M, N, A, LDA, IPIV, INFO)
SGETRF
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 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 sget02(TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
SGET02
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
subroutine serrvx(PATH, NUNIT)
SERRVX
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
subroutine sdrvge(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, IWORK, NOUT)
SDRVGE
subroutine sget01(M, N, A, LDA, AFAC, LDAFAC, IPIV, RWORK, RESID)
SGET01
subroutine sget07(TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, CHKFERR, BERR, RESLTS)
SGET07