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 )
651 nrun = nrun + ntests - k1 + 1
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 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 alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine sget07(TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, CHKFERR, BERR, RESLTS)
SGET07
subroutine sget02(TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
SGET02
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 slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
real function sget06(RCOND, RCONDC)
SGET06
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
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 slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
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 sgetrf(M, N, A, LDA, IPIV, INFO)
SGETRF
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 sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
subroutine aladhd(IOUNIT, PATH)
ALADHD
subroutine sget01(M, N, A, LDA, AFAC, LDAFAC, IPIV, RWORK, RESID)
SGET01
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 serrvx(PATH, NUNIT)
SERRVX
subroutine sgeequ(M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO)
SGEEQU
real function slamch(CMACH)
SLAMCH
subroutine sgetri(N, A, LDA, IPIV, WORK, LWORK, INFO)
SGETRI
logical function lsame(CA, CB)
LSAME