174 INTEGER nmax, nn, nout, nrhs
175 DOUBLE PRECISION thresh
179 INTEGER iwork( * ), nval( * )
180 DOUBLE PRECISION a( * ), afac( * ), asav( * ), b( * ),
181 $ bsav( * ), rwork( * ), s( * ), work( * ),
188 DOUBLE PRECISION one, zero
189 parameter ( one = 1.0d+0, zero = 0.0d+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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 ) =
'Double precision'
252 iseed( i ) = iseedy( i )
258 $
CALL derrvx( 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 dlatb4( path, imat, n, n,
TYPE, kl, ku, anorm, mode,
296 rcondc = one / cndnum
299 CALL dlatms( n, n, dist, iseed,
TYPE, rwork, mode, cndnum,
300 $ anorm, kl, ku,
'No packing', a, lda, work,
306 CALL alaerh( path,
'DLATMS', 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 dlaset(
'Full', n, n-izero+1, zero, zero,
337 CALL dlacpy(
'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 dlacpy(
'Full', n, n, asav, lda, afac, lda )
367 IF( equil .OR. iequed.GT.1 )
THEN
372 CALL dgeequ( 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 dlaqge( n, n, afac, lda, s, s( n+1 ),
389 $ rowcnd, colcnd, amax, equed )
403 anormo =
dlange(
'1', n, n, afac, lda, rwork )
404 anormi =
dlange(
'I', n, n, afac, lda, rwork )
409 CALL dgetrf( n, n, afac, lda, iwork, info )
413 CALL dlacpy(
'Full', n, n, afac, lda, a, lda )
414 lwork = nmax*max( 3, nrhs )
416 CALL dgetri( n, a, lda, iwork, work, lwork, info )
420 ainvnm =
dlange(
'1', n, n, a, lda, rwork )
421 IF( anormo.LE.zero .OR. ainvnm.LE.zero )
THEN
424 rcondo = ( one / anormo ) / ainvnm
429 ainvnm =
dlange(
'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 dlacpy(
'Full', n, n, asav, lda, a, lda )
455 CALL dlarhs( path, xtype,
'Full', trans, n, n, kl,
456 $ ku, nrhs, a, lda, xact, lda, b, lda,
459 CALL dlacpy(
'Full', n, nrhs, b, lda, bsav, lda )
461 IF( nofact .AND. itran.EQ.1 )
THEN
468 CALL dlacpy(
'Full', n, n, a, lda, afac, lda )
469 CALL dlacpy(
'Full', n, nrhs, b, lda, x, lda )
472 CALL dgesv( n, nrhs, afac, lda, iwork, x, lda,
478 $
CALL alaerh( path,
'DGESV ', info, izero,
479 $
' ', n, n, -1, -1, nrhs, imat,
480 $ nfail, nerrs, nout )
485 CALL dget01( n, n, a, lda, afac, lda, iwork,
486 $ rwork, result( 1 ) )
488 IF( izero.EQ.0 )
THEN
492 CALL dlacpy(
'Full', n, nrhs, b, lda, work,
494 CALL dget02(
'No transpose', n, n, nrhs, a,
495 $ lda, x, lda, work, lda, rwork,
500 CALL dget04( 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 )
'DGESV ', n,
513 $ imat, k, result( k )
523 $
CALL dlaset(
'Full', n, n, zero, zero, afac,
525 CALL dlaset(
'Full', n, nrhs, zero, zero, x, lda )
526 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
531 CALL dlaqge( n, n, a, lda, s, s( n+1 ), rowcnd,
532 $ colcnd, amax, equed )
539 CALL dgesvx( 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,
'DGESVX', 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 =
dlantr(
'M',
'U',
'N', info, info,
558 IF( rpvgrw.EQ.zero )
THEN
561 rpvgrw =
dlange(
'M', n, info, a, lda,
565 rpvgrw =
dlantr(
'M',
'U',
'N', n, n, afac, lda,
567 IF( rpvgrw.EQ.zero )
THEN
570 rpvgrw =
dlange(
'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 dget01( n, n, a, lda, afac, lda, iwork,
584 $ rwork( 2*nrhs+1 ), result( 1 ) )
595 CALL dlacpy(
'Full', n, nrhs, bsav, lda, work,
597 CALL dget02( 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 dget04( n, nrhs, x, lda, xact, lda,
606 $ rcondc, result( 3 ) )
608 IF( itran.EQ.1 )
THEN
613 CALL dget04( n, nrhs, x, lda, xact, lda,
614 $ roldc, result( 3 ) )
620 CALL dget07( trans, n, nrhs, asav, lda, b, lda,
621 $ x, lda, xact, lda, rwork, .true.,
622 $ rwork( nrhs+1 ), result( 4 ) )
630 result( 6 ) =
dget06( 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 )
'DGESVX',
642 $ fact, trans, n, equed, imat, k,
645 WRITE( nout, fmt = 9998 )
'DGESVX',
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 )
'DGESVX', fact,
659 $ trans, n, equed, imat, 1, result( 1 )
661 WRITE( nout, fmt = 9998 )
'DGESVX', 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 )
'DGESVX', fact,
672 $ trans, n, equed, imat, 6, result( 6 )
674 WRITE( nout, fmt = 9998 )
'DGESVX', 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 )
'DGESVX', fact,
685 $ trans, n, equed, imat, 7, result( 7 )
687 WRITE( nout, fmt = 9998 )
'DGESVX', 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 dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
double precision function dlamch(CMACH)
DLAMCH
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine dgetrf(M, N, A, LDA, IPIV, INFO)
DGETRF
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine dlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
DLARHS
subroutine dlaqge(M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED)
DLAQGE scales a general rectangular matrix, using row and column scaling factors computed by sgeequ...
subroutine dgetri(N, A, LDA, IPIV, WORK, LWORK, INFO)
DGETRI
subroutine dgeequ(M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO)
DGEEQU
subroutine dget01(M, N, A, LDA, AFAC, LDAFAC, IPIV, RWORK, RESID)
DGET01
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
double precision function dlantr(NORM, UPLO, DIAG, M, N, A, LDA, WORK)
DLANTR 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 xlaenv(ISPEC, NVALUE)
XLAENV
double precision function dlange(NORM, M, N, A, LDA, WORK)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine dget07(TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, CHKFERR, BERR, RESLTS)
DGET07
subroutine dgesvx(FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO)
DGESVX computes the solution to system of linear equations A * X = B for GE matrices ...
subroutine dgesv(N, NRHS, A, LDA, IPIV, B, LDB, INFO)
DGESV computes the solution to system of linear equations A * X = B for GE matrices ...
subroutine dget02(TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
DGET02
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
subroutine aladhd(IOUNIT, PATH)
ALADHD
logical function lsame(CA, CB)
LSAME
subroutine derrvx(PATH, NUNIT)
DERRVX
double precision function dget06(RCOND, RCONDC)
DGET06
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS