163 SUBROUTINE ddrvge( 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
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 )
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( 1
x, a,
', N =', i5,
', type ', i2,
', test(', i2,
') =',
708 9998
FORMAT( 1
x, a,
', FACT=''', a1,
''', TRANS=''', a1,
''', N=', i5,
709 $
', type ', i2,
', test(', i1,
')=', g12.5 )
710 9997
FORMAT( 1
x, a,
', FACT=''', a1,
''', TRANS=''', a1,
''', N=', i5,
711 $
', EQUED=''', a1,
''', type ', i2,
', test(', i1,
')=',
LOGICAL function lsame(CA, CB)
LSAME
subroutine dgetri(N, A, LDA, IPIV, WORK, LWORK, INFO)
DGETRI
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine derrvx(PATH, NUNIT)
DERRVX
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 ddrvge(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, IWORK, NOUT)
DDRVGE
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 dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
subroutine dgeequ(M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO)
DGEEQU
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 ...
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
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 ...
DOUBLE PRECISION function dget06(RCOND, RCONDC)
DGET06
subroutine dget01(M, N, A, LDA, AFAC, LDAFAC, IPIV, RWORK, RESID)
DGET01
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine dget07(TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, CHKFERR, BERR, RESLTS)
DGET07
subroutine aladhd(IOUNIT, PATH)
ALADHD
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
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 ...
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
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...
subroutine dget02(TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
DGET02
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 dgetrf(M, N, A, LDA, IPIV, INFO)
DGETRF