166 SUBROUTINE ddrvge( 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
178 DOUBLE PRECISION thresh
182 INTEGER iwork( * ), nval( * )
183 DOUBLE PRECISION a( * ), afac( * ), asav( * ),
b( * ),
184 $ bsav( * ), rwork( * ), s( * ), work( * ),
191 DOUBLE PRECISION one, zero
192 parameter( one = 1.0d+0, zero = 0.0d+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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 ) =
'Double precision'
258 iseed( i ) = iseedy( i )
264 $ CALL
derrvx( 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
dlatb4( path, imat, n, n, type, kl, ku, anorm, mode,
302 rcondc = one / cndnum
305 CALL
dlatms( n, n, dist, iseed, type, rwork, mode, cndnum,
306 $ anorm, kl, ku,
'No packing', a, lda, work,
312 CALL
alaerh( path,
'DLATMS', 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
dlaset(
'Full', n, n-izero+1, zero, zero,
343 CALL
dlacpy(
'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
dlacpy(
'Full', n, n, asav, lda, afac, lda )
373 IF( equil .OR. iequed.GT.1 )
THEN
378 CALL
dgeequ( 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
dlaqge( n, n, afac, lda, s, s( n+1 ),
395 $ rowcnd, colcnd, amax, equed )
409 anormo =
dlange(
'1', n, n, afac, lda, rwork )
410 anormi =
dlange(
'I', n, n, afac, lda, rwork )
414 CALL
dgetrf( n, n, afac, lda, iwork, info )
418 CALL
dlacpy(
'Full', n, n, afac, lda, a, lda )
419 lwork = nmax*max( 3, nrhs )
420 CALL
dgetri( n, a, lda, iwork, work, lwork, info )
424 ainvnm =
dlange(
'1', n, n, a, lda, rwork )
425 IF( anormo.LE.zero .OR. ainvnm.LE.zero )
THEN
428 rcondo = ( one / anormo ) / ainvnm
433 ainvnm =
dlange(
'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
dlacpy(
'Full', n, n, asav, lda, a, lda )
459 CALL
dlarhs( path, xtype,
'Full', trans, n, n, kl,
460 $ ku, nrhs, a, lda, xact, lda,
b, lda,
463 CALL
dlacpy(
'Full', n, nrhs,
b, lda, bsav, lda )
465 IF( nofact .AND. itran.EQ.1 )
THEN
472 CALL
dlacpy(
'Full', n, n, a, lda, afac, lda )
473 CALL
dlacpy(
'Full', n, nrhs,
b, lda, x, lda )
476 CALL
dgesv( n, nrhs, afac, lda, iwork, x, lda,
482 $ CALL
alaerh( path,
'DGESV ', info, izero,
483 $
' ', n, n, -1, -1, nrhs, imat,
484 $ nfail, nerrs, nout )
489 CALL
dget01( n, n, a, lda, afac, lda, iwork,
490 $ rwork, result( 1 ) )
492 IF( izero.EQ.0 )
THEN
496 CALL
dlacpy(
'Full', n, nrhs,
b, lda, work,
498 CALL
dget02(
'No transpose', n, n, nrhs, a,
499 $ lda, x, lda, work, lda, rwork,
504 CALL
dget04( 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 )
'DGESV ', n,
517 $ imat, k, result( k )
527 $ CALL
dlaset(
'Full', n, n, zero, zero, afac,
529 CALL
dlaset(
'Full', n, nrhs, zero, zero, x, lda )
530 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
535 CALL
dlaqge( n, n, a, lda, s, s( n+1 ), rowcnd,
536 $ colcnd, amax, equed )
543 CALL
dgesvx( 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,
'DGESVX', info, izero,
553 $ fact // trans, n, n, -1, -1, nrhs,
554 $ imat, nfail, nerrs, nout )
560 rpvgrw =
dlantr(
'M',
'U',
'N', info, info,
562 IF( rpvgrw.EQ.zero )
THEN
565 rpvgrw =
dlange(
'M', n, info, a, lda,
569 rpvgrw =
dlantr(
'M',
'U',
'N', n, n, afac, lda,
571 IF( rpvgrw.EQ.zero )
THEN
574 rpvgrw =
dlange(
'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
dget01( n, n, a, lda, afac, lda, iwork,
588 $ rwork( 2*nrhs+1 ), result( 1 ) )
599 CALL
dlacpy(
'Full', n, nrhs, bsav, lda, work,
601 CALL
dget02( 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
dget04( n, nrhs, x, lda, xact, lda,
610 $ rcondc, result( 3 ) )
612 IF( itran.EQ.1 )
THEN
617 CALL
dget04( n, nrhs, x, lda, xact, lda,
618 $ roldc, result( 3 ) )
624 CALL
dget07( trans, n, nrhs, asav, lda,
b, lda,
625 $ x, lda, xact, lda, rwork, .true.,
626 $ rwork( nrhs+1 ), result( 4 ) )
634 result( 6 ) =
dget06( 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 )
'DGESVX',
646 $ fact, trans, n, equed, imat, k,
649 WRITE( nout, fmt = 9998 )
'DGESVX',
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 )
'DGESVX', fact,
663 $ trans, n, equed, imat, 1, result( 1 )
665 WRITE( nout, fmt = 9998 )
'DGESVX', 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 )
'DGESVX', fact,
676 $ trans, n, equed, imat, 6, result( 6 )
678 WRITE( nout, fmt = 9998 )
'DGESVX', 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 )
'DGESVX', fact,
689 $ trans, n, equed, imat, 7, result( 7 )
691 WRITE( nout, fmt = 9998 )
'DGESVX', fact,
692 $ trans, n, imat, 7, result( 7 )
704 CALL
dlacpy(
'Full', n, n, asav, lda, a, lda )
705 CALL
dlacpy(
'Full', n, nrhs, bsav, lda,
b, lda )
708 $ CALL
dlaset(
'Full', n, n, zero, zero, afac,
710 CALL
dlaset(
'Full', n, nrhs, zero, zero, x, lda )
711 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
716 CALL
dlaqge( n, n, a, lda, s, s( n+1 ), rowcnd,
717 $ colcnd, amax, equed )
725 CALL
dgesvxx( 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,
'DGESVXX', 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
dget01( n, n, a, lda, afac, lda, iwork,
763 $ rwork( 2*nrhs+1 ), result( 1 ) )
774 CALL
dlacpy(
'Full', n, nrhs, bsav, lda, work,
776 CALL
dget02( 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
dget04( n, nrhs, x, lda, xact, lda,
785 $ rcondc, result( 3 ) )
787 IF( itran.EQ.1 )
THEN
792 CALL
dget04( n, nrhs, x, lda, xact, lda,
793 $ roldc, result( 3 ) )
802 result( 6 ) =
dget06( 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 )
'DGESVXX',
814 $ fact, trans, n, equed, imat, k,
817 WRITE( nout, fmt = 9998 )
'DGESVXX',
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 )
'DGESVXX', fact,
831 $ trans, n, equed, imat, 1, result( 1 )
833 WRITE( nout, fmt = 9998 )
'DGESVXX', 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 )
'DGESVXX', fact,
844 $ trans, n, equed, imat, 6, result( 6 )
846 WRITE( nout, fmt = 9998 )
'DGESVXX', 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 )
'DGESVXX', fact,
857 $ trans, n, equed, imat, 7, result( 7 )
859 WRITE( nout, fmt = 9998 )
'DGESVXX', 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,
')=',
double precision function dla_gerpvgrw(N, NCOLS, A, LDA, AF, LDAF)
DLA_GERPVGRW
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
subroutine dgesvxx(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)
DGESVXX computes the solution to system of linear equations A * X = B for GE matrices ...
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 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.
logical function lsame(CA, CB)
LSAME
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 debchvxx(THRESH, PATH)
DEBCHVXX
subroutine aladhd(IOUNIT, PATH)
ALADHD
double precision function dlamch(CMACH)
DLAMCH
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 ...
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