C ALGORITHM 648, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 13, NO. 1, P. 28 Brief information for DETEST 1986 version (sufficient for preliminary tests of the code without the timing facility). Implementation Steps -------------------- 1. In routine CONST in CONCLK.F insert a data statement suitable for your machine. (See implementation notes in STDOC.T or NSDOC.T. Sample settings are included in CONST in comments.) 2. Insert system calls to suppress underflow exceptions, and any other needed initialization, in the I=0 section of CONST. Again, sample code is included. 3. The program consisting of NSTTRU.F, NSDTST.F, NSTRUE.F, NSPROB.F and CONCLK.F should now compile and run, giving output similar to NSTTRU.O. 4. Similarly with STTTRU.F, STDTST.F, STTRUE.F, STPROB.F and CONCLK.F. 1. Purpose ------- Two packages are provided for assessing the performance of initial value solvers. The first package, whose main routine is NSDTST, is designed for assessing the performance of solvers suitable for non-stiff systems, while the second package, whose main routine is STDTST, is designed for assessing the performance of solvers suitable for stiff systems. Each package consists of a number of routines but the user need only be aware of the main routine and the routines FCN (and for the stiff package, PDERV), and STATS, whose role is explained below. In this document we will describe the use of STDTST (double precision version). The requirements and calling sequence of NSDTST are almost identical. In [4] the design of the testing package is discussed and guidance is given on the interpretation of the results it produces. A set of test problems, described in detail in [2,3], is incorporated in the stiff package. The code being tested is run on a selection of these problems at various tolerances. The user selects the problems and the tolerances, and also organizes the problems into groups for statistical reporting purposes, at his discretion. To test a code a user must write an interface routine called METHOD, described below, and then call STDTST with the desired options. Note that STDTST comes in a 'single' and a 'double' precision version. It is best if the version used matches the precision of the SOLVER under test. If this is not possible then great care must be exercised when constructing METHOD. The arguments of STDTST are, in any event, always single precision but those of METHOD are of single or double precision according to the version used. The package divides naturally into five parts: STDTST,CNTROL and various service routines organize the assembling, computation and reporting of statistics. STATS is the routine which 'instruments' the code being tested and passes statistics via COMMON to CNTROL and STDTST. FCN, PDERV, IVALU, EVALU describe the set of test problems. FCN gives the r.h.s. f(y) of the ODE system and PDERV gives the Jacobian matrix df/dy. (At present all the problems are posed in autonomous form). IVALU gives the initial conditions, scaling weights and other data about each problem. EVALU gives accurately computed values at the endpoint. DDCOMP and DSOLVE are standard (double precision) LU decomposition and backsolve routines for full matrices, compatible with the layout of the Jacobian produced by PDERV. They are used by TRUE but are available for use by the code being tested if desired. TRUE and its subordinate routines (alias the Addison-Enright code SECDER) form a reliable stiff solver for computing the 'true' global and local solutions when required. There is also a 'dummy' STDTST and STATS to help the user debug his METHOD routine (described below); a utility GENTIM which can be used on each new machine to generate timing data embedded in the code; and a utility GENWT which can be used if ever a user wishes to add further test problems to the set. Main Lines of Calling Hierarchy (user-supplied routines are in boxes) +--------+ | User's |---STDTST---CNTROL-----IVALU |Program | | +--------+ +--------+ | +------+ |'SOLVER'| |---|METHOD|----|(Code |->-+ | +------+ | being | | | | | tested)| | | | +--------+ |---FCN,PDERV | | | | STATS---TRUE--->--+ | +----EVALU We acknowledge valuable recommendations in Shampine's paper [5]. In particular the package will, by default, integrate each system in scaled form, scaling each solution component by its maximum observed value over the range of integration. That is, the change of variable -1 z = D y is done where D = diag(w(1), .., w(n)) and w(i) =max |i-th component of y| over the range. The problem -1 solved is then z' = D f(x,Dz). The weights w(i) were found by an accurate integration of each problem and are embedded in IVALU. Note that this scaling affects the norms which are used in measuring all errors, and thus can have a considerable effect on the accuracy in some of the problems. If the problem code in IDLIST (see below) is given a negative sign the system is solved in its 'natural' scaling, as was done in the 1975 version of DETEST. 2. Arguments to STDTST: --------- -- ------- TITLE (input) Character of length 80, holds name of method being tested. OPTION (input) Integer array of length 10, only elements 1 to 3 are used and are referred to henceforth as OPT, NORMEF and NRMTYP. (OPTION(4) is also used when OPT=4) OPT one of 1, 2, 3 or 4. OPT selects level of analysis required: 1 gives a report of the following at each tolerance used: - Total time per integration - Overhead time excluding function and Jacobian calls and matrix factorizations. - Number of function calls, Jacobian calls, matrix factorizations and successful steps over range - Global error at endpoint XEND, divided by TOL, ie. ||(computed y) - (true y)||/TOL at x=XEND The norm used throughout the package is that chosen by NRMTYP. 2 reports (in addition to the above statistics): - Maximum global error over range. The 'true' solution over the range is obtained by a reliable integrator at a more stringent tolerance. 3 reports (in addition to the above): - Maximum local error over range, ie. max over all meshpoints of LENRM = ||(computed y) - yloc||/ERRBND where yloc is the true local solution through the previous meshpoint, and ERRBND, the assumed error bound, is explained below. - Fraction of steps where LENRM exceeded 1. - Fraction of steps where LENRM exceeded 5. 4 reports (in addition to the above): - An analysis of the local error estimates used by SOLVER as the basis for its error control. Under development and described more fully in the actual code. NORMEF one of 0 1 or 2 , selects normalized efficiency statistics. These try to compensate for the fact that achieved accuracy may be much higher or lower than that requested by TOL, and this relationship is very problem- and method- dependent. For each problem, a least-squares fit is made of log10(actual error) vs log10(TOL) and used to estimate what the various cost statistics would be for an actual error of 10**n. This is achieved by interpolation, for those n such that 10**n lies within the range of accuracies achieved with the user-specified tolerances. 0 No normalized statistics 1 Normalized statistics are produced taking the 'actual error' used in the least squares fit to be the endpoint global error. 2 Normalized statistics are produced taking 'actual error' as the maximum global error over the range. N.B. In this case OPT must be at least 2. NRMTYP one of 1, 2 or 3, selects the norm used in assessing the size of local and global errors. It should be chosen by the user to agree with the norm used in SOLVER. We offer: 1 Max-norm. 2 2-norm (Euclidean norm). 3 r.m.s. norm, that is (2-norm of x)/sqrt(n) for an n-vector x. TOL (input) Real array, holds list of up to 10 tolerances to be used, in strictly decreasing order, with 0 as terminator. Each Problem is integrated at each tolerance in turn. Example: in calling program REAL TOL(11) DATA TOL/1E-1,1E-3,1E-5,1E-7,7*0E0/ requests the four tolerances .1, .001, .00001, .0000001. IDLIST (input) Integer array, holds list of groups of problems, and specifies for each one whether it is to be integrated in scaled or unscaled form (see General Notes above). Each problem is specified by a numeric code, 11 to 14 for problems A1 to A4, 21 to 25 for B1 to B5 etc. A zero terminates a group and two zeros terminate the list of groups. If the problem code is given a negative sign, the system is integrated in unscaled form; if a positive sign, in scaled form. Example: in calling program INTEGER IDLIST(7) DATA IDLIST/11,22,0,-31,-51,0,0/ specifies Group 1 consisting of Problems A1,B2 and Group 2 of Problems C1,E1. The first two are to be solved in the scaled form and the last two in unscaled form. The total length of the list including zeros must be at most 60 items. FLAG (output) Real. A nonzero value indicates that the call to STDTST was aborted because of argument errors, in which case the values of the decimal digits of FLAG indicate the error(s) that have occurred, as follows: 1: OPT invalid. 2: NORMEF invalid. 3: NORMEF = 2 was requested with OPT = 1. 4: A negative tolerance was supplied, or the list of tolerances was not in decreasing order. 5: The list of tolerances was empty or not terminated by a zero. 6: An invalid Problem-Id was found in IDLIST. 7: The list of groups in IDLIST is empty or is not terminated by two zeros or has more than the maximum allowed number (6) of groups. 8: NRMTYP invalid. Eg. a value FLAG = 0.245E 03 indicates that errors 2, 4 and 5 in the above list have occurred. Its value if nonzero is printed by STDTST anyway, but FLAG is meant to be inspected if further action of the main program depends on a successful call to STDTST. 3. Interface routine METHOD --------- ------- ------ This invokes the code being tested, call it SOLVER. The specification is SUBROUTINE METHOD(N,X,Y,XEND,TOL,HMAX,HSTART) INTEGER N DOUBLE PRECISION X,Y(N),XEND,TOL,HMAX,HSTART EXTERNAL FCN, PDERV METHOD is to be written by the user as a simple integrator to advance the solution of N differential equations from the initial values held in X,Y up to XEND, with an unweighted absolute error control of TOL. HMAX is a recommended maximum stepsize and HSTART is a recommended initial stepsize. If SOLVER can make use of these two parameters, the statistics will probably be more favorable and reliable, but their use is not crucial. The derivatives, and the analytical Jacobian matrix, of the problem are computed by package routines FCN and PDERV respectively. Thus certainly FCN, and in most cases PDERV, must be arguments to SOLVER, and they must be declared EXTERNAL in METHOD. METHOD should call SOLVER in one-step mode so that a call to the package routine STATS can be made after each successful step. If SOLVER does not have this facility, SOLVER must have a call to STATS inserted at the appropriate point in the code. Some calls to METHOD are intended to be aborted after a few integration steps by the STATS call setting X = XEND. Thus a test should be made after each call to STATS, of the form if STATS has set X = XEND then EXIT. NB: If the actual X argument to STATS is different from the X argument of METHOD (which may be necessary with some SOLVERs), ensure that the X argument of METHOD is set to XEND before exit, else the package will report 'METHOD failed to start'. The algorithm for METHOD should thus be of the form: - Declare all arguments and workspace expected by SOLVER - Set appropriate options including absolute error control and one-step mode - Initialize extra arguments if required - FOR each successful step DO - Call SOLVER( ... ,FCN,PDERV, ... ) EXIT if SOLVER is in trouble. - Set X,Y to the just computed meshpoint x and solution vector y - Set ERRBND to the bound that is satisfied by ||ERREST||, and hence is intended to be satisfied by ||LE||, at this step. - Set ERREST to the local error estimate vector (OPT=4 only) (See [4] for discussion and note that X,Y are ignored unless OPT.GE.2, ERRBND is ignored unless OPT.GE.3, and ERREST is ignored unless OPT.GE.4.) - Call STATS(X,Y,ERRBND,ERREST) - EXIT if X .ge. XEND. - ENDLOOP On normal exit X,Y must hold XEND and the solution at XEND. On exit because SOLVER was in trouble, X must hold the final point reached. On an exit forced by STATS, X must hold XEND. 4. Controlling the destination of output ----------- --- ----------- -- ------ The unit number on which the package writes its output is set by a call to one of the package routines, and you can find out what it is, by putting the statement IOUT = CONST(3) in your main program. Probably output will default to your terminal, which is good for debugging. For more serious work you may want to send output to a file. The statements IOUT = CONST(3) OPEN(IOUT, FILE=filename, other options.. ) will do this for you, assuming your Fortran I/O is consistent with the 1977 standard. 5. The routines FCN, PDERV --- -------- ---- ----- The specification of FCN is SUBROUTINE FCN(X,Y,YP) DOUBLE PRECISION X,Y(20),YP(20) On entry X holds the independent variable and Y holds the vector of dependent variables. On exit YP holds the vector of derivatives for the problem being solved (selected by a switch in COMMON). The specification for PDERV is SUBROUTINE PDERV(X,Y,DY) DOUBLE PRECISION X,Y(20),DY(400) where X and Y are as for FCN. The entries of the Jacobian matrix are stored in the first N**2 elements of DY with df(i)/dy(j) being stored in element i+(j-1)*N. Thus DY may be treated as if it were declared DIMENSION DY(N,N) 6. Function, Jacobian and LU Decomposition counts --------- -------- --- -- ------------- ------ These are maintained in three COMMON variables: COMMON/STCOM6/NFCN,NJAC,NLUD Each call to FCN, PDERV and DDCOMP increments NFCN, NJAC and NLUD by 1 respectively. If SOLVER uses its own linear algebra routines it is the user's responsibility to insert the above COMMON at an appropriate place in his code and set NLUD correctly. This may be done by incrementing it at each LU decomposition call, or by setting it equal to an independently maintained count before exit from METHOD. Similar comments apply to NJAC if SOLVER does its own Jacobian evaluation (eg. by numerical differencing). If a method does not use Jacobians, NJAC and NLUD may be used for gathering some other statistics. 7. Sample Program ------ ------- The following driver is the program used to generate the results of Fig. 4 of [4]. C SAMPLE DRIVER FOR STDTST, WITH ONE GROUP CONSISTING ONLY C OF PROBLEM E3 SOLVED IN SCALED FORM, AT FOUR TOLERANCES. C IN THIS CASE THE ARRAYS IDLIST, TOL NEED NOT BE SO LONG. C CHARACTER TITLE*80 INTEGER OPTION(10),IDLIST(60) REAL TOL(11) DATA TITLE/'SECDER, ADDISON-ENRIGHT SECOND DERIVATIVE METHOD'/ * , OPTION/2, 2, 1, 0, 6*0/ * , TOL/1E-2, 1E-4, 1E-6, 1E-8, 7*0E0/ * , IDLIST/53, 0, 58*0/ CALL STDTST(TITLE, OPTION, TOL, IDLIST, FLAG) STOP END C C SUBROUTINE METHOD(N,X,Y,XEND,TOL,HMAX,HSTART) C C DRIVER FOR THE SECDER CODE WHICH IS PART OF THE PACKAGE. C IT IS SOMEWHAT LENGTHY BECAUSE ITS INTERRUPT MECHANISM DOES C NOT ALLOW INTERRUPT IMMEDIATELY AFTER ACCEPTING A STEP. C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DOUBLE PRECISION X,Y(N),XEND,TOL,HMAX,HSTART EXTERNAL FCN,PDERV DOUBLE PRECISION C(20),YP(20,11),W(400),PD(400),WK(20,12) INTEGER INF(40) C COMMON/STCOM6/NFCN,NJAC,NLUD C DATA NDIM/20/ C IND=2 DO 20 I=1,5 INF(I)=0 C(I)=0.D0 20 CONTINUE C C SET ABS ERROR CONTROL: INF(1); INTERRUPT NO. 2: INF(5); C MIN,MAX & STARTING STEPSIZE: C(2),C(4),C(5). INF(1)=1 INF(5)=1 C(2)=1D-12 C(4)=HMAX C(5)=HSTART C 50 CALL TRUE(FCN,PDERV,NDIM,N,X,Y,XEND,TOL,IND,C,INF,YP,W,PD,WK) IF(IND.EQ.6)GOTO 50 C WRITE(5,999)X,Y,C(13),(WK(I,1),I=1,N) C999 FORMAT(20X,10F10.6) IF(IND.NE.5) GOTO 60 TEMP=C(13) C C(13),WK(*,1) ARE THE ABOUT-TO-BE-ACCEPTED X,Y. C WK(*,12) IS THE ERROR-ESTIMATE VECTOR, DELIVERED C BY A SMALL CHANGE IN 'TRUE'. CALL STATS(C(13),WK(1,1),TOL,WK(1,12)) IF(C(13).NE.TEMP) GOTO 70 GOTO 50 C 60 IF(IND.NE.3) GOTO 70 X = XEND GOTO 80 C C FAILURE EXIT OF SOME KIND: 70 X=C(13) C WRITE(IOUT,110)IND,(INF(I),I=9,15) C110 FORMAT(1H ,'IND,INF(9)..INF(15)=',8I10) 80 CONTINUE NLUD=INF(15) RETURN END * * * * * References ----------- * [1] W H Enright, 'Using a testing package for the automatic assessment of numerical methods for ODEs', in Performance Evaluation of Numerical Software, (Fosdick, ed), IFIP, North Holland Publ Co (1979) 199-213. * * [2] W H Enright and T E Hull, 'Comparing numerical methods for the solution of stiff systems of ODEs arising in chemistry', in Numerical Methods for Differential Systems (Lapidus and Schiesser, eds), Academic Press, New York (1976) 45-65. * [3] W H Enright, T E Hull and B Lindberg, 'Comparing numerical methods for stiff systems of ordinary differential equations', BIT 15(1975) 10-48. * [4] W H Enright and J D Pryce, 'A pair of packages for assessing initial value methods', University of Toronto Technical Report no. 167/83. * [5] L F Shampine 'Evaluation of a test set for stiff ODE solvers', TOMS 7(1981)409-420. * * * REAL FUNCTION CONST(I) C C********+*********+*********+*********+*********+*********+*********+** C .. Scalar Arguments .. INTEGER I C .. Local Scalars .. CHARACTER*32 MCNAME C .. Local Arrays .. REAL C(4) C .. Intrinsic Functions .. INTRINSIC ICHAR C .. Data statements .. C C CONST AND CLOCK ENCLOSE (WE HOPE) ALL THE MACHINE-DEPENDENT PARTS C OF THE STIFF AND NONSTIFF DETEST PACKAGES, EXCEPT THE TIMING C DATA IN THE IVALU ROUTINE OF EACH PACKAGE. C C CALLS WITH VALUES I=1 TO 4 RETURN THE FOLLOWING VALUES IN 'CONST': C I=1 UNIT ROUNDOFF APPROXIMATELY, IN THE PRECISION USED BY THE C ODE-SOLVING PART OF THE PACKAGE. C I=2 NUMBER NEAR UNDERFLOW THRESHOLD C I=3 STANDARD OUTPUT UNIT NUMBER C I=4 VALUE OF TSTTIM (USED IN CNTROL) C C CALLS WITH VALUES -1 TO -32 RETURN THE 'ICHAR' VALUE OF SUCCESSIVE C CHARACTERS OF THE NAME OF THE COMPUTER WE ARE RUNNING ON. (CLUMSY BUT C INTENDED TO ISOLATE MACHINE-DEPENDENCIES HERE) C C A CALL WITH I OUTSIDE THESE RANGES (DONE WITH I=0 NEAR THE HEAD OF TH C MAIN NSDTST & STDTST ROUTINES) RETURNS CONST=0 AND C 1. IS TO BE USED FOR MACHINE-DEPENDENT INITIALIZATIONS SUCH AS THE C SUPPRESSION OF UNDERFLOW MESSAGES. C C****** VALUES FOR IBM3033 MODEL N12 ****** CIBM DATA C/2.25E-16,1E-50,6.0,0.5/ C****** VALUES FOR DEC10 MODEL KL10 ****** CDEC DATA C /2.17E-19,1E-38,5.0,0.5/ DATA C/4*0.0/, MCNAME/ * '..PUT NAME OF COMPUTER HERE..'/ C .. Executable Statements .. C IF (I.GE.1 .AND. I.LE.4) THEN CONST = C(I) ELSE IF (I.LT.0) THEN CONST = ICHAR(MCNAME(-I:-I)) ELSE C SUPPRESS UNDERFLOW REPORTING (DEC): CDEC CALL ERRSET(0,6) C SUPPRESS UNDERFLOW REPORTING (IBM): CIBM CALL ERRSET(208,256,-1,0,0,208) C CONST = 0 END IF RETURN END C C********+*********+*********+*********+*********+*********+*********+** C REAL FUNCTION CLOCK(S) C .. Scalar Arguments .. REAL S C .. Executable Statements .. C C********+*********+*********+*********+*********+*********+*********+** C CLOCK IS 'RESET' TO 0 BY A CALL C S = CLOCK(0.0) C AND THEN (WITH S SET AS ABOVE) DELIVERS THE ELAPSED CPU SECONDS C SINCE LAST RESET, BY CALLS OF FORM C TIME = CLOCK(S) C C THIS WORKS ON AN IBM: CIBM CLOCK = UTTIMR(1) - S C THIS WORKS ON A DEC10 UNDER TOPS10 IN CONJUNCTION WITH THE C COMMAND "SET TIME LLL" AT MONITOR LEVEL WHERE LLL IS A C SUITABLE TIME LIMIT. CDEC CLOCK = -TIM2GO(S) -S C WHEN FIRST MOUNTING THE PACKAGE, LET IT RETURN ZERO AS BELOW: CLOCK = 0.0 RETURN END REAL FUNCTION CONST(I) C C********+*********+*********+*********+*********+*********+*********+** C .. Scalar Arguments .. INTEGER I C .. Local Scalars .. CHARACTER*32 MCNAME C .. Local Arrays .. REAL C(4) C .. Intrinsic Functions .. INTRINSIC ICHAR C .. Data statements .. C C CONST AND CLOCK ENCLOSE (WE HOPE) ALL THE MACHINE-DEPENDENT PARTS C OF THE STIFF AND NONSTIFF DETEST PACKAGES, EXCEPT THE TIMING C DATA IN THE IVALU ROUTINE OF EACH PACKAGE. C C CALLS WITH VALUES I=1 TO 4 RETURN THE FOLLOWING VALUES IN 'CONST': C I=1 UNIT ROUNDOFF APPROXIMATELY, IN THE PRECISION USED BY THE C ODE-SOLVING PART OF THE PACKAGE. C I=2 NUMBER NEAR UNDERFLOW THRESHOLD C I=3 STANDARD OUTPUT UNIT NUMBER C I=4 VALUE OF TSTTIM (USED IN CNTROL) C C CALLS WITH VALUES -1 TO -32 RETURN THE 'ICHAR' VALUE OF SUCCESSIVE C CHARACTERS OF THE NAME OF THE COMPUTER WE ARE RUNNING ON. (CLUMSY BUT C INTENDED TO ISOLATE MACHINE-DEPENDENCIES HERE) C C A CALL WITH I OUTSIDE THESE RANGES (DONE WITH I=0 NEAR THE HEAD OF TH C MAIN NSDTST & STDTST ROUTINES) RETURNS CONST=0 AND C 1. IS TO BE USED FOR MACHINE-DEPENDENT INITIALIZATIONS SUCH AS THE C SUPPRESSION OF UNDERFLOW MESSAGES. C C****** VALUES FOR IBM3033 MODEL N12 ****** CIBM DATA C/2.25E-16,1E-50,6.0,0.5/ C****** VALUES FOR DEC10 MODEL KL10 ****** CDEC DATA C /2.17E-19,1E-38,5.0,0.5/ DATA C/4*0.0/, MCNAME/ * '..PUT NAME OF COMPUTER HERE..'/ C .. Executable Statements .. C IF (I.GE.1 .AND. I.LE.4) THEN CONST = C(I) ELSE IF (I.LT.0) THEN CONST = ICHAR(MCNAME(-I:-I)) ELSE C SUPPRESS UNDERFLOW REPORTING (DEC): CDEC CALL ERRSET(0,6) C SUPPRESS UNDERFLOW REPORTING (IBM): CIBM CALL ERRSET(208,256,-1,0,0,208) C CONST = 0 END IF RETURN END C C********+*********+*********+*********+*********+*********+*********+** C REAL FUNCTION CLOCK(S) C .. Scalar Arguments .. REAL S C .. Executable Statements .. C C********+*********+*********+*********+*********+*********+*********+** C CLOCK IS 'RESET' TO 0 BY A CALL C S = CLOCK(0.0) C AND THEN (WITH S SET AS ABOVE) DELIVERS THE ELAPSED CPU SECONDS C SINCE LAST RESET, BY CALLS OF FORM C TIME = CLOCK(S) C C THIS WORKS ON AN IBM: CIBM CLOCK = UTTIMR(1) - S C THIS WORKS ON A DEC10 UNDER TOPS10 IN CONJUNCTION WITH THE C COMMAND "SET TIME LLL" AT MONITOR LEVEL WHERE LLL IS A C SUITABLE TIME LIMIT. CDEC CLOCK = -TIM2GO(S) -S C WHEN FIRST MOUNTING THE PACKAGE, LET IT RETURN ZERO AS BELOW: CLOCK = 0.0 RETURN END * * * Nonstiff DETEST 1986 version ----- ------ ---- ------- by W H Enright, and J D Pryce, Dept of Computer Science, School of Mathematics University of Toronto, University Walk Toronto M5S 1A4 Bristol BS8 1TW Canada England Tel (416) 978-6025 Tel (272) 303335 * Please inform the authors of any errors in code or documentation. * 1. General Notes ------- ----- * Nonstiff DETEST is a package to test the performance of initial-value codes for nonstiff differential systems. This code is a revision of the 1971 version, used to produce the results reported on in [2,4]. * A set of test problems, described in detail in [2], is incorporated in the package. The code being tested is run on a selection of these problems at various tolerances. The user selects the problems and the tolerances, and also organizes the problems into groups for statistical reporting purposes, at his discretion. * To test a code a user must write an interface routine called METHOD, described below, and then call NSDTST with the desired options. Note that NSDTST comes in a 'single' and a 'double' precision version for use according as the software under test is written in single or double precision. The arguments of NSDTST are single precision but METHOD must be implemented in the appropriate precision. * The package divides naturally into four parts: * NSDTST,CNTROL and various service routines organize the assembling, computation and reporting of statistics. * STATS is the routine which 'instruments' the code being tested and passes statistics via COMMON to CNTROL and NSDTST. * FCN, IVALU, EVALU describe the set of test problems. FCN gives the r.h.s. f(x,y) of the ODE system. IVALU gives the initial conditions, scaling weights and other data about each problem. EVALU gives accurately computed values at the endpoint. * TRUE and its subordinate routines (alias the Hull-Enright-Jackson code DVERK based on Verner's Runge-Kutta formulas) form a reliable nonstiff solver for computing the 'true' global and local solutions when required. * There is also a 'dummy' NSDTST and STATS to help the user debug his METHOD routine (described below); a utility NSGTIM which can be used on each new machine to generate timing data embedded in the code; and a utility NSGWT can be used if ever a user wishes to add further test problems to the set. * Main Lines of Calling Hierarchy (user-supplied routines are in boxes) * * * +--------+ | User's |---NSDTST---CNTROL-----IVALU |Program | | +--------+ +--------+ | +------+ |'SOLVER'| |---|METHOD|----|(Code |->-+ | +------+ | being | | | | | tested)| | | | +--------+ |---FCN | | | | STATS---TRUE--->--+ | +----EVALU * We acknowledge valuable recommendations in Shampine's paper [5]. In particular the package will, by default, integrate each system in scaled form, scaling each solution component by its maximum observed value over the range of integration. That is, the change of variable -1 z = D y is done where D = diag(w(1), .., w(n)) * and w(i) =max |i-th component of y| over the range. The problem -1 solved is then z' = D f(x,Dz). The weights w(i) were found by an accurate integration of each problem and are embedded in IVALU. Note that this scaling affects the norms which are used in measuring all errors, and thus can have a considerable effect on the accuracy in some of the problems. * If the problem code in IDLIST (see below) is given a negative sign the system is solved in its 'natural' scaling, as was done in the 1975 version of DETEST. * * References ----------- * [1] W H Enright, 'Using a testing package for the automatic assessment of numerical methods for ODEs', in Performance Evaluation of Numerical Software, (Fosdick, ed), IFIP, North Holland Publ Co (1979) 199-213. * [2] T E Hull, W H Enright, B M Fellen and A E Sedgwick, 'Comparing numerical methods for ordinary differential equations', SIAM J. Numer. Anal. 9(1972)603-637. * [3] W H Enright and J D Pryce, 'A pair of packages for assessing initial value methods', University of Toronto Technical Report no. 167/83. * [4] W H Enright and T E Hull, 'Test results on initial value methods for nonstiff ordinary differential equations', SIAM J. Numer. Anal. 13(1976)944-961. * [5] L F Shampine 'Evaluation of a test set for stiff ODE solvers', TOMS 7(1981)409-420. * * * * * * * * 2. Arguments to NSDTST: --------- -- ------- * TITLE (input) Character of length 80, holds name of method being tested. * OPTION (input) Integer array of length 10, only elements 1 to 3 are used and are referred to henceforth as OPT, NORMEF and NRMTYP. (OPTION(4) is also used when OPT=4) * OPT one of 1, 2, 3 or 4. OPT selects level of analysis required: 1 gives a report of the following at each tolerance used: - Total time per integration - Overhead time excluding function calls. - Number of function calls and successful steps over range. - Global error at endpoint XEND, divided by TOL, ie. ||(computed y) - (true y)||/TOL at x=XEND The norm used throughout the package is that chosen by NRMTYP. * 2 reports (in addition to the above statistics): - Maximum global error over range. The 'true' solution over the range is obtained by a reliable integrator at a more stringent tolerance. * 3 reports (in addition to the above): - Maximum local error over range, ie. max over all meshpoints of LENRM = ||(computed y) - yloc||/ERRBND where yloc is the true local solution through the previous meshpoint, and ERRBND, the assumed error bound, is explained below. - Fraction of steps where LENRM exceeded 1. - Fraction of steps where LENRM exceeded 5. * 4 reports (in addition to the above): - An analysis of the local error estimates used by SOLVER as the basis for its error control. At this level three assumptions are made. First, that at each step SOLVER forms two approximations, y and y*, to the local solution yloc at the new meshpoint, such that asymptotically as TOL->0, y* is 'more accurate' than y. Second, that the approximation which is taken as the computed solution at the new meshpoint is either always y* (in which case one says local extrapolation is used) or always y (in which case it is not used). The vector LE = y - yloc is the true local error in the 'less accurate' solution y, and ERREST = y - y* is an estimate of LE. It is assumed finally that the error control consists in keeping ||ERREST||, in an appropriate norm, below ERRBND at each step. * Note that some methods, such as Merson's method, cannot be regarded in this way. * At this level DETEST analyses how accurately ERREST approximates to LE, by forming a scatter plot of the values of r1 = ||ERREST - LE||/ERRBND (vertical axis) against r2 = ||ERREST||/ERRBND (horizontal) at each step. Note ERREST - LE = -(y* - yloc) = -LE*, say, so that LENRM defined above is r1 if local extrapolation is being done. For an 'ideal' error control strategy, we expect the plotted points to cluster near (1,0) on the graph, whether or not local extrapolation is used. * To use this level of analysis the user must: a) Ensure that the STATS call in METHOD delivers ERREST as defined above (with the correct sign!). b) Set OPTION(4) as follows. =0 Argument Y to STATS is y above (no local extrapolation). =1 Y is y* above (local extrapolation). * For each integration, a scatter plot is produced. Each of the ratios r1, r2 is put into one of 12 class-intervals -7 -7 -6 2 3 3 0<=r<2 , 2 <=r<2 , ..., 2 <=r<2 , 2 <=r= 2, and have a possibly more efficient code to put in its place. NSTL is relevant if you are interested in the algorithms used by the package, specifically the step-lumping process which takes place in STATS at stringent tolerances. * * * * 8. Subroutines in the Package ----------- -- --- ------- * In order of appearance in the files. The list also shows, for each routine, the other package routines and COMMON areas which it uses. A name in parentheses, like (FCN) denotes a routine which is called at one remove (eg. METHOD calls SOLVER which must call FCN) or which is passed as an argument rather than being an external reference (eg. FCN in TRUE). * In CONCLK file CONST calls: none CLOCK calls: none * In NSDTST file NSDTST calls: PARCHK LSQFIT RATIO EFSTAT CNTROL CONST ; NSCOM1 NSCOM3 PARCHK calls: none LSQFIT calls: none RATIO calls: none EFSTAT calls: none CNTROL calls: DIFNRM STATS CONST CLOCK IVALU EVALU METHOD PLOT ; NSCOM1 NSCOM2 NSCOM3 NSCOM5 NSCOM6 DIFNRM calls: none STATS calls: DIFNRM CONST TRUE FCN PLOT ; NSCOM1 NSCOM2 NSCOM3 NSCOM4 NSCOM6 PLOT calls: none * In NSTRUE file TRUE calls: CONST (FCN2 ) FCN2 calls: FCN * In NSPROB file IVALU calls: none EVALU calls: none FCN calls: ; NSCOM5 NSCOM6 * User-supplied METHOD calls: STATS (FCN ) * * 9. Definition of Common Areas and Dictionary of Data-flow ---------- -- ------ ----- --- ---------- -- --------- * The flow of information between those routines which use COMMON is indicated for each variable by the codes S: the variable is assigned a value (Set) in this routine, possibly by a call to another routine to which the variable is passed as an argument. A: the value is used (Accessed) in this routine. * For counters and similar variables, these codes are used instead of code S: I: the variable is Initialized in this routine. U: the variable is Updated in this routine. * * COMMON /NSCOM1/ passes information from NSDTST to CNTROL and STATS. * NSDTST | CNTROL | | STATS | | | DIFNRM | | | | S A A - ERRTOL DOUBLE. Copy of current error tolerance. S A A - OPT INTEGER. Copy of OPTION(1) argument of NSDTST. S - - A NRMTYP INTEGER. Copy of OPTION(3) argument of NSDTST. S - A - XTRAP INTEGER. Copy of OPTION(4) argument of NSDTST. S A - - ID INTEGER. Internal code of current problem, 1 for A1, ..., 13 for B3, etc. S A - - IWT INTEGER. Flag for scaling (+1: Scaled. -1: Unscaled) S - - - IOUT INTEGER. Standard output unit number. * * * * COMMON /NSCOM2/ communicates between CNTROL and STATS. * CNTROL | STATS | | S A XEND DOUBLE. End of integration range of current problem. A S HSTART DOUBLE. Initial stepsize passed to METHOD for integration proper. S A N INTEGER. No. of equations in current problem. S A IFLAG INTEGER. Set by CNTROL to inform STATS what it is to do: =0 METHOD is being timed. =1 Initializing call of STATS from CNTROL to set up NSCOM4. =2 Preliminary integration to determine HSTART, aborted after 2 steps. =3 Integration proper, compiling statistics. * * A SA INDL,INDG Error flags for the local and global 'true solutions' obtained by calls to routine TRUE. * * * * * COMMON /NSCOM3/ outputs statistics from CNTROL and STATS. * NSDTST | CNTROL | | STATS | | | A S - XFIN DOUBLE. Point of failure of METHOD if it doesn't reach XEND. A - S XTRUE DOUBLE. Point of failure of TRUE if any. If both local and global fail, point of global failure is returned. A S - TIME REAL. CPU time for one integration as measured by CLOCK function. A S - OVHD REAL. Equals TIME less estimated cost of FCN calls. A I U TRUTIM REAL. The time spent in calls to TRUE. Not relevant to performance of METHOD but measures the overhead incurred by the testing package when OPT = 2, 3 or 4. Not printed but available. A S - GEND REAL. Norm of global error of METHOD at XEND. * * A I U GEMX REAL. Maximum of global error over all lumped step meshpoints, ie. usually over all meshpoints of METHOD, except when ERRTOL is very small. A I U LEMXSC REAL. Maximum local error in units of ERRBND, over all lumped step meshpoints. A S - NFCN INTEGER. Copy of NFCN1, see /NSCOM6/. /NSCOM6/ A I U NSTP INTEGER. Counts (unlumped) steps taken by METHOD in current integration. - I U NSTL INTEGER. Counts lumped steps formed in current integration (see STATS). Not printed but available. A I U NDCV,NBAD INTEGER. Count lumped steps on which SOLVER's local error control was deceived, resp. badly deceived. A I U NTRU INTEGER. Counts lumped steps on which true local solution was successfully computed, hence valid local error statistics obtained. Used in computing 'fraction deceived' information. Reported if different from NSTP. Note NTRU <= NSTL <= NSTP. - S - NSTART INTEGER. No. of FCN calls needed by METHOD to start, ie. to do preliminary integration (2 steps). Not printed out but available. * * COMMON /NSCOM4/ is used only by STATS, to preserve information from one call of STATS to another. All variables are set and/or updated in STATS. * XOLD1 DOUBLE. Similar to XOLD but used in preliminary integration. XOLD,YOLD DOUBLE and DOUBLE array. Copy of METHOD's computed solution at end of previous lumped step. Used as actual arguments of TRUE local solution call. XOLDG,YOLDG DOUBLE and DOUBLE array. Hold 'true' global solution updated to end of previous lumped step. Used as actual arguments of TRUE global solution call. CG,PDG,WKG,WG,YPG,INFG Workspace for 'true' global solution. XT DOUBLE. Holds last METHOD meshpoint between calls to STATS. PRECIS DOUBLE. Holds 1000 * (unit roundoff) approx. ERLUMP DOUBLE. Accumulates METHOD's local error estimates to form an estimate over a lumped step. * * COMMON /NSCOM5/ passes information between CNTROL and FCN, (or any replacement a user may provide for FCN). * CNTROL | FCN | | * S A WT DOUBLE. Array of weights used to implement the 'scaled' integration option. S A IWT1,N1,ID1 INTEGER. Copies of IWT,N,ID in /NSCOM1/ or /NSCOM2/. * * COMMON /NSCOM6/ holds a counter. It is initialized in CNTROL, saved-and-restored in STATS, and eventually copied by CNTROL to the corresponding variable in /NSCOM3/. * CNTROL | STATS | | FCN | | | * IA AS U - - NFCN1 INTEGER. Counts calls to FCN. * * There is also a COMMON/NSCOM7/ used by the dummy (debugging) versions of NSDTST and STATS for communication. * SUBROUTINE NSDTST(TITLE,OPTION,TOL,IDLIST,FLAG) C C********+*********+*********+*********+*********+*********+*********+** C G E N E R A L D O C U M E N T A T I O N C--------+---------+---------+---------+---------+---------+---------+-- C C C C NONSTIFF DETEST 1986 VERSION C ----- ------ ---- ------- C BY W H ENRIGHT, AND J D PRYCE, C DEPT OF COMPUTER SCIENCE, SCHOOL OF MATHEMATICS C UNIVERSITY OF TORONTO, UNIVERSITY WALK C TORONTO M5S 1A4 BRISTOL BS8 1TW C CANADA ENGLAND C TEL (416) 978-6025 TEL (272) 303335 C C PLEASE INFORM THE AUTHORS OF ANY ERRORS IN CODE OR C DOCUMENTATION. C C 1. GENERAL NOTES C ------- ----- C C NONSTIFF DETEST IS A PACKAGE TO TEST THE PERFORMANCE OF INITIAL-VALUE C CODES FOR NONSTIFF DIFFERENTIAL SYSTEMS. THIS CODE IS A REVISION OF C THE 1971 VERSION, USED TO PRODUCE THE RESULTS REPORTED ON IN [2,4]. C C A SET OF TEST PROBLEMS, DESCRIBED IN DETAIL IN [2], IS INCORPORATED C IN THE PACKAGE. THE CODE BEING TESTED IS RUN ON A SELECTION OF THESE C PROBLEMS AT VARIOUS TOLERANCES. THE USER SELECTS THE PROBLEMS AND C THE TOLERANCES, AND ALSO ORGANIZES THE PROBLEMS INTO GROUPS FOR C STATISTICAL REPORTING PURPOSES, AT HIS DISCRETION. C C TO TEST A CODE A USER MUST WRITE AN INTERFACE ROUTINE CALLED METHOD, C DESCRIBED BELOW, AND THEN CALL NSDTST WITH THE DESIRED OPTIONS. NOTE C THAT NSDTST COMES IN A 'SINGLE' AND A 'DOUBLE' PRECISION VERSION FOR C USE ACCORDING AS THE SOFTWARE UNDER TEST IS WRITTEN IN SINGLE OR C DOUBLE PRECISION. THE ARGUMENTS OF NSDTST ARE SINGLE PRECISION BUT C METHOD MUST BE IMPLEMENTED IN THE APPROPRIATE PRECISION. C C THE PACKAGE DIVIDES NATURALLY INTO FOUR PARTS: C C NSDTST,CNTROL AND VARIOUS SERVICE ROUTINES C ORGANIZE THE ASSEMBLING, COMPUTATION AND REPORTING OF C STATISTICS. C C STATS C IS THE ROUTINE WHICH 'INSTRUMENTS' THE CODE BEING TESTED AND C PASSES STATISTICS VIA COMMON TO CNTROL AND NSDTST. C C FCN, IVALU, EVALU C DESCRIBE THE SET OF TEST PROBLEMS. FCN GIVES THE R.H.S. C F(X,Y) OF THE ODE SYSTEM. IVALU GIVES THE INITIAL CONDITIONS, C SCALING WEIGHTS AND OTHER DATA ABOUT EACH PROBLEM. EVALU C GIVES ACCURATELY COMPUTED VALUES AT THE ENDPOINT. C C TRUE AND ITS SUBORDINATE ROUTINES C (ALIAS THE HULL-ENRIGHT-JACKSON CODE DVERK BASED ON VERNER'S C RUNGE-KUTTA FORMULAS) FORM A RELIABLE NONSTIFF SOLVER FOR C COMPUTING THE 'TRUE' GLOBAL AND LOCAL SOLUTIONS WHEN REQUIRED. C C THERE IS ALSO A 'DUMMY' NSDTST AND STATS TO HELP THE USER DEBUG HIS C METHOD ROUTINE (DESCRIBED BELOW); A UTILITY NSGTIM WHICH CAN BE USED C ON EACH NEW MACHINE TO GENERATE TIMING DATA EMBEDDED IN THE CODE; AND C A UTILITY NSGWT CAN BE USED IF EVER A USER WISHES TO ADD FURTHER TEST C PROBLEMS TO THE SET. C C MAIN LINES OF CALLING HIERARCHY (USER-SUPPLIED ROUTINES ARE IN BOXES) C C C C +--------+ C | USER'S |---NSDTST---CNTROL-----IVALU C |PROGRAM | | +--------+ C +--------+ | +------+ |'SOLVER'| C |---|METHOD|----|(CODE |->-+ C | +------+ | BEING | | C | | | TESTED)| | C | | +--------+ |---FCN C | | | C | STATS---TRUE--->--+ C | C +----EVALU C C WE ACKNOWLEDGE VALUABLE RECOMMENDATIONS IN SHAMPINE'S PAPER [5]. IN C PARTICULAR THE PACKAGE WILL, BY DEFAULT, INTEGRATE EACH SYSTEM IN C SCALED FORM, SCALING EACH SOLUTION COMPONENT BY ITS MAXIMUM OBSERVED C VALUE OVER THE RANGE OF INTEGRATION. THAT IS, THE CHANGE OF VARIABLE C -1 C Z = D Y IS DONE WHERE C D = DIAG(W(1), .., W(N)) C C AND W(I) =MAX |I-TH COMPONENT OF Y| OVER THE RANGE. THE PROBLEM C -1 C SOLVED IS THEN Z' = D F(X,DZ). THE WEIGHTS W(I) WERE FOUND BY AN C ACCURATE INTEGRATION OF EACH PROBLEM AND ARE EMBEDDED IN IVALU. C NOTE THAT THIS SCALING AFFECTS THE NORMS WHICH ARE USED IN C MEASURING ALL ERRORS, AND THUS CAN HAVE A CONSIDERABLE EFFECT ON THE C ACCURACY IN SOME OF THE PROBLEMS. C C IF THE PROBLEM CODE IN IDLIST (SEE BELOW) IS GIVEN A NEGATIVE SIGN THE C SYSTEM IS SOLVED IN ITS 'NATURAL' SCALING, AS WAS DONE IN THE 1975 C VERSION OF DETEST. C C C REFERENCES C ----------- C C [1] W H ENRIGHT, 'USING A TESTING PACKAGE FOR THE AUTOMATIC C ASSESSMENT OF NUMERICAL METHODS FOR ODES', IN PERFORMANCE C EVALUATION OF NUMERICAL SOFTWARE, (FOSDICK, ED), IFIP, NORTH C HOLLAND PUBL CO (1979) 199-213. C C [2] T E HULL, W H ENRIGHT, B M FELLEN AND A E SEDGWICK, 'COMPARING C NUMERICAL METHODS FOR ORDINARY DIFFERENTIAL EQUATIONS', SIAM J. C NUMER. ANAL. 9(1972)603-637. C C [3] W H ENRIGHT AND J D PRYCE, 'A PAIR OF PACKAGES FOR ASSESSING C INITIAL VALUE METHODS', UNIVERSITY OF TORONTO TECHNICAL REPORT C NO. 167/83. C C [4] W H ENRIGHT AND T E HULL, 'TEST RESULTS ON INITIAL VALUE METHODS C FOR NONSTIFF ORDINARY DIFFERENTIAL EQUATIONS', SIAM J. NUMER. C ANAL. 13(1976)944-961. C C [5] L F SHAMPINE 'EVALUATION OF A TEST SET FOR STIFF ODE SOLVERS', C TOMS 7(1981)409-420. C C C C C C C C C 2. ARGUMENTS TO NSDTST: C --------- -- ------- C C TITLE (INPUT) CHARACTER OF LENGTH 80, HOLDS NAME OF METHOD BEING C TESTED. C C OPTION (INPUT) INTEGER ARRAY OF LENGTH 10, ONLY ELEMENTS 1 TO 3 ARE C USED AND ARE REFERRED TO HENCEFORTH AS OPT, NORMEF AND NRMTYP. C (OPTION(4) IS ALSO USED WHEN OPT=4) C C OPT ONE OF 1, 2, 3 OR 4. OPT SELECTS LEVEL OF ANALYSIS REQUIRED: C 1 GIVES A REPORT OF THE FOLLOWING AT EACH TOLERANCE USED: C - TOTAL TIME PER INTEGRATION C - OVERHEAD TIME EXCLUDING FUNCTION CALLS. C - NUMBER OF FUNCTION CALLS AND SUCCESSFUL STEPS OVER RANGE. C - GLOBAL ERROR AT ENDPOINT XEND, DIVIDED BY TOL, IE. C ||(COMPUTED Y) - (TRUE Y)||/TOL AT X=XEND C THE NORM USED THROUGHOUT THE PACKAGE IS THAT CHOSEN BY NRMTYP. C C 2 REPORTS (IN ADDITION TO THE ABOVE STATISTICS): C - MAXIMUM GLOBAL ERROR OVER RANGE. THE 'TRUE' SOLUTION OVER C THE RANGE IS OBTAINED BY A RELIABLE INTEGRATOR AT A MORE C STRINGENT TOLERANCE. C C 3 REPORTS (IN ADDITION TO THE ABOVE): C - MAXIMUM LOCAL ERROR OVER RANGE, IE. MAX OVER ALL MESHPOINTS C OF C LENRM = ||(COMPUTED Y) - YLOC||/ERRBND C WHERE YLOC IS THE TRUE LOCAL SOLUTION THROUGH THE PREVIOUS C MESHPOINT, AND ERRBND, THE ASSUMED ERROR BOUND, IS EXPLAINED C BELOW. C - FRACTION OF STEPS WHERE LENRM EXCEEDED 1. C - FRACTION OF STEPS WHERE LENRM EXCEEDED 5. C C 4 REPORTS (IN ADDITION TO THE ABOVE): C - AN ANALYSIS OF THE LOCAL ERROR ESTIMATES USED BY SOLVER AS THE C BASIS FOR ITS ERROR CONTROL. AT THIS LEVEL THREE ASSUMPTIONS C ARE MADE. FIRST, THAT AT EACH STEP SOLVER FORMS TWO C APPROXIMATIONS, Y AND Y*, TO THE LOCAL SOLUTION YLOC AT THE C NEW MESHPOINT, SUCH THAT ASYMPTOTICALLY AS TOL->0, Y* IS 'MORE C ACCURATE' THAN Y. SECOND, THAT THE APPROXIMATION WHICH IS C TAKEN AS THE COMPUTED SOLUTION AT THE NEW MESHPOINT IS EITHER C ALWAYS Y* (IN WHICH CASE ONE SAYS LOCAL EXTRAPOLATION IS USED) C OR ALWAYS Y (IN WHICH CASE IT IS NOT USED). THE VECTOR C LE = Y - YLOC C IS THE TRUE LOCAL ERROR IN THE 'LESS ACCURATE' SOLUTION Y, C AND C ERREST = Y - Y* C IS AN ESTIMATE OF LE. IT IS ASSUMED FINALLY THAT THE ERROR C CONTROL CONSISTS IN KEEPING ||ERREST||, IN AN APPROPRIATE C NORM, BELOW ERRBND AT EACH STEP. C C NOTE THAT SOME METHODS, SUCH AS MERSON'S METHOD, CANNOT BE C REGARDED IN THIS WAY. C C AT THIS LEVEL DETEST ANALYSES HOW ACCURATELY ERREST C APPROXIMATES TO LE, BY FORMING A SCATTER PLOT OF THE VALUES OF C R1 = ||ERREST - LE||/ERRBND (VERTICAL AXIS) AGAINST R2 = C ||ERREST||/ERRBND (HORIZONTAL) AT EACH STEP. NOTE ERREST - C LE = -(Y* - YLOC) = -LE*, SAY, SO THAT LENRM DEFINED ABOVE IS C R1 IF LOCAL EXTRAPOLATION IS BEING DONE. FOR AN 'IDEAL' ERROR C CONTROL STRATEGY, WE EXPECT THE PLOTTED POINTS TO CLUSTER NEAR C (1,0) ON THE GRAPH, WHETHER OR NOT LOCAL EXTRAPOLATION IS C USED. C C TO USE THIS LEVEL OF ANALYSIS THE USER MUST: C A) ENSURE THAT THE STATS CALL IN METHOD DELIVERS ERREST AS C DEFINED ABOVE (WITH THE CORRECT SIGN!). C B) SET OPTION(4) AS FOLLOWS. C =0 ARGUMENT Y TO STATS IS Y ABOVE (NO LOCAL EXTRAPOLATION). C =1 Y IS Y* ABOVE (LOCAL EXTRAPOLATION). C C FOR EACH INTEGRATION, A SCATTER PLOT IS PRODUCED. EACH OF THE C RATIOS R1, R2 IS PUT INTO ONE OF 12 CLASS-INTERVALS C -7 -7 -6 2 3 3 C 0<=R<2 , 2 <=R<2 , ..., 2 <=R<2 , 2 <=R= 2, AND HAVE A POSSIBLY MORE EFFICIENT C CODE TO PUT IN ITS PLACE. NSTL IS RELEVANT IF YOU ARE C INTERESTED IN THE ALGORITHMS USED BY THE PACKAGE, SPECIFICALLY THE C STEP-LUMPING PROCESS WHICH TAKES PLACE IN STATS AT STRINGENT C TOLERANCES. C C C C C 8. SUBROUTINES IN THE PACKAGE C ----------- -- --- ------- C C IN ORDER OF APPEARANCE IN THE FILES. THE LIST ALSO SHOWS, FOR EACH C ROUTINE, THE OTHER PACKAGE ROUTINES AND COMMON AREAS WHICH IT USES. A C NAME IN PARENTHESES, LIKE (FCN) DENOTES A ROUTINE WHICH IS CALLED AT C ONE REMOVE (EG. METHOD CALLS SOLVER WHICH MUST CALL FCN) OR WHICH IS C PASSED AS AN ARGUMENT RATHER THAN BEING AN EXTERNAL REFERENCE (EG. C FCN IN TRUE). C C IN CONCLK FILE C CONST CALLS: NONE C CLOCK CALLS: NONE C C IN NSDTST FILE C NSDTST CALLS: PARCHK LSQFIT RATIO EFSTAT CNTROL CONST ; NSCOM1 C NSCOM3 C PARCHK CALLS: NONE C LSQFIT CALLS: NONE C RATIO CALLS: NONE C EFSTAT CALLS: NONE C CNTROL CALLS: DIFNRM STATS CONST CLOCK IVALU EVALU METHOD PLOT ; C NSCOM1 NSCOM2 NSCOM3 NSCOM5 NSCOM6 C DIFNRM CALLS: NONE C STATS CALLS: DIFNRM CONST TRUE FCN PLOT ; NSCOM1 NSCOM2 NSCOM3 C NSCOM4 NSCOM6 C PLOT CALLS: NONE C C IN NSTRUE FILE C TRUE CALLS: CONST (FCN2 ) C FCN2 CALLS: FCN C C IN NSPROB FILE C IVALU CALLS: NONE C EVALU CALLS: NONE C FCN CALLS: ; NSCOM5 NSCOM6 C C USER-SUPPLIED C METHOD CALLS: STATS (FCN ) C C C 9. DEFINITION OF COMMON AREAS AND DICTIONARY OF DATA-FLOW C ---------- -- ------ ----- --- ---------- -- --------- C C THE FLOW OF INFORMATION BETWEEN THOSE ROUTINES WHICH USE COMMON IS C INDICATED FOR EACH VARIABLE BY THE CODES C S: THE VARIABLE IS ASSIGNED A VALUE (SET) IN THIS ROUTINE, POSSIBLY C BY A CALL TO ANOTHER ROUTINE TO WHICH THE VARIABLE IS PASSED AS C AN ARGUMENT. C A: THE VALUE IS USED (ACCESSED) IN THIS ROUTINE. C C FOR COUNTERS AND SIMILAR VARIABLES, THESE CODES ARE USED INSTEAD OF C CODE S: C I: THE VARIABLE IS INITIALIZED IN THIS ROUTINE. C U: THE VARIABLE IS UPDATED IN THIS ROUTINE. C C C COMMON /NSCOM1/ PASSES INFORMATION FROM NSDTST TO CNTROL AND STATS. C C NSDTST C | CNTROL C | | STATS C | | | DIFNRM C | | | | C S A A - ERRTOL DOUBLE. COPY OF CURRENT ERROR TOLERANCE. C S A A - OPT INTEGER. COPY OF OPTION(1) ARGUMENT OF NSDTST. C S - - A NRMTYP INTEGER. COPY OF OPTION(3) ARGUMENT OF NSDTST. C S - A - XTRAP INTEGER. COPY OF OPTION(4) ARGUMENT OF NSDTST. C S A - - ID INTEGER. INTERNAL CODE OF CURRENT PROBLEM, 1 FOR A1, C ..., 13 FOR B3, ETC. C S A - - IWT INTEGER. FLAG FOR SCALING (+1: SCALED. -1: C UNSCALED) C S - - - IOUT INTEGER. STANDARD OUTPUT UNIT NUMBER. C C C C C COMMON /NSCOM2/ COMMUNICATES BETWEEN CNTROL AND STATS. C C CNTROL C | STATS C | | C S A XEND DOUBLE. END OF INTEGRATION RANGE OF CURRENT PROBLEM. C A S HSTART DOUBLE. INITIAL STEPSIZE PASSED TO METHOD FOR C INTEGRATION PROPER. C S A N INTEGER. NO. OF EQUATIONS IN CURRENT PROBLEM. C S A IFLAG INTEGER. SET BY CNTROL TO INFORM STATS WHAT IT IS TO C DO: C =0 METHOD IS BEING TIMED. C =1 INITIALIZING CALL OF STATS FROM CNTROL TO SET UP C NSCOM4. C =2 PRELIMINARY INTEGRATION TO DETERMINE HSTART, ABORTED C AFTER 2 STEPS. C =3 INTEGRATION PROPER, COMPILING STATISTICS. C C C A SA INDL,INDG C ERROR FLAGS FOR THE LOCAL AND GLOBAL 'TRUE SOLUTIONS' C OBTAINED BY CALLS TO ROUTINE TRUE. C C C C C C COMMON /NSCOM3/ OUTPUTS STATISTICS FROM CNTROL AND STATS. C C NSDTST C | CNTROL C | | STATS C | | | C A S - XFIN DOUBLE. POINT OF FAILURE OF METHOD IF IT DOESN'T REACH C XEND. C A - S XTRUE DOUBLE. POINT OF FAILURE OF TRUE IF ANY. IF BOTH C LOCAL AND GLOBAL FAIL, POINT OF GLOBAL FAILURE IS C RETURNED. C A S - TIME REAL. CPU TIME FOR ONE INTEGRATION AS MEASURED BY C CLOCK FUNCTION. C A S - OVHD REAL. EQUALS TIME LESS ESTIMATED COST OF FCN CALLS. C A I U TRUTIM REAL. THE TIME SPENT IN CALLS TO TRUE. NOT RELEVANT C TO PERFORMANCE OF METHOD BUT MEASURES THE OVERHEAD C INCURRED BY THE TESTING PACKAGE WHEN OPT = 2, 3 OR 4. C NOT PRINTED BUT AVAILABLE. C A S - GEND REAL. NORM OF GLOBAL ERROR OF METHOD AT XEND. C C C A I U GEMX REAL. MAXIMUM OF GLOBAL ERROR OVER ALL LUMPED STEP C MESHPOINTS, IE. USUALLY OVER ALL MESHPOINTS OF METHOD, C EXCEPT WHEN ERRTOL IS VERY SMALL. C A I U LEMXSC REAL. MAXIMUM LOCAL ERROR IN UNITS OF ERRBND, OVER ALL C LUMPED STEP MESHPOINTS. C A S - NFCN INTEGER. COPY OF NFCN1, SEE /NSCOM6/. C /NSCOM6/ C A I U NSTP INTEGER. COUNTS (UNLUMPED) STEPS TAKEN BY METHOD IN C CURRENT INTEGRATION. C - I U NSTL INTEGER. COUNTS LUMPED STEPS FORMED IN CURRENT C INTEGRATION (SEE STATS). NOT PRINTED BUT AVAILABLE. C A I U NDCV,NBAD C INTEGER. COUNT LUMPED STEPS ON WHICH SOLVER'S LOCAL C ERROR CONTROL WAS DECEIVED, RESP. BADLY DECEIVED. C A I U NTRU INTEGER. COUNTS LUMPED STEPS ON WHICH TRUE LOCAL C SOLUTION WAS SUCCESSFULLY COMPUTED, HENCE VALID LOCAL C ERROR STATISTICS OBTAINED. USED IN COMPUTING 'FRACTION C DECEIVED' INFORMATION. REPORTED IF DIFFERENT FROM C NSTP. NOTE NTRU <= NSTL <= NSTP. C - S - NSTART INTEGER. NO. OF FCN CALLS NEEDED BY METHOD TO START, C IE. TO DO PRELIMINARY INTEGRATION (2 STEPS). NOT C PRINTED OUT BUT AVAILABLE. C C C COMMON /NSCOM4/ IS USED ONLY BY STATS, TO PRESERVE INFORMATION FROM C ONE CALL OF STATS TO ANOTHER. ALL VARIABLES ARE SET AND/OR UPDATED IN C STATS. C C XOLD1 DOUBLE. SIMILAR TO XOLD BUT USED IN PRELIMINARY C INTEGRATION. C XOLD,YOLD C DOUBLE AND DOUBLE ARRAY. COPY OF METHOD'S COMPUTED C SOLUTION AT END OF PREVIOUS LUMPED STEP. USED AS C ACTUAL ARGUMENTS OF TRUE LOCAL SOLUTION CALL. C XOLDG,YOLDG C DOUBLE AND DOUBLE ARRAY. HOLD 'TRUE' GLOBAL SOLUTION C UPDATED TO END OF PREVIOUS LUMPED STEP. USED AS ACTUAL C ARGUMENTS OF TRUE GLOBAL SOLUTION CALL. C CG,PDG,WKG,WG,YPG,INFG C WORKSPACE FOR 'TRUE' GLOBAL SOLUTION. C XT DOUBLE. HOLDS LAST METHOD MESHPOINT BETWEEN CALLS TO C STATS. C PRECIS DOUBLE. HOLDS 1000 * (UNIT ROUNDOFF) APPROX. C ERLUMP DOUBLE. ACCUMULATES METHOD'S LOCAL ERROR ESTIMATES TO C FORM AN ESTIMATE OVER A LUMPED STEP. C C C COMMON /NSCOM5/ PASSES INFORMATION BETWEEN CNTROL AND FCN, (OR ANY C REPLACEMENT A USER MAY PROVIDE FOR FCN). C C CNTROL C | FCN C | | C C S A WT DOUBLE. ARRAY OF WEIGHTS USED TO IMPLEMENT THE C 'SCALED' INTEGRATION OPTION. C S A IWT1,N1,ID1 C INTEGER. COPIES OF IWT,N,ID IN /NSCOM1/ OR /NSCOM2/. C C C COMMON /NSCOM6/ HOLDS A COUNTER. IT IS INITIALIZED IN CNTROL, C SAVED-AND-RESTORED IN STATS, AND EVENTUALLY COPIED BY CNTROL TO THE C CORRESPONDING VARIABLE IN /NSCOM3/. C C CNTROL C | STATS C | | FCN C | | | C C IA AS U - - NFCN1 INTEGER. COUNTS CALLS TO FCN. C C C THERE IS ALSO A COMMON/NSCOM7/ USED BY THE DUMMY (DEBUGGING) VERSIONS C OF NSDTST AND STATS FOR COMMUNICATION. C C--------+---------+---------+---------+---------+---------+---------+-- C E N D O F G E N E R A L D O C U M E N T A T I O N C********+*********+*********+*********+*********+*********+*********+** C C DESCRIPTION OF NSDTST C ----------- -- ------ C C ROUTINE NSDTST INTERPRETS THE LIST OF TOLERANCES AND LIST OF C GROUPS OF PROBLEMS SPECIFIED IN THE ARGUMENTS. USING CNTROL C TO GATHER INDIVIDUAL STATISTICS FOR ONE PROBLEM AT ONE C TOLERANCE, IT ORGANIZES THE FORMATION AND OUTPUT OF SUMMARY C STATISTICS. C INDIVIDUAL STATISTICS ARE INDEXED OVER TOLERANCES, PROBLEMS C AND GROUPS. C 'PROBLEMS-SUMMARY' MEANS SUM OF THESE OVER PROBLEMS IN A GROUP. C 'GROUPS-SUMMARY' MEANS SUM OF PROBLEMS-SUMMARY OVER ALL GROUPS. C 'OVERALL-SUMMARY' MEANS SUM OF GROUPS-SUMMARIES OVER ALL C TOLERANCES. C (READ 'MAX' FOR 'SUM' IN CASE OF SOME OF THE STATISTICS.) C C LOCAL VARIABLES C PSNFCN,PSNSTP,... HOLD THE SUMMARY OVER PROBLEMS IN A GROUP C OF NFCN,NSTP,... (SEE DESCRIPTION OF /NSCOM3/) AT ALL THE C TOLERANCES USED. C GSNFCN,... HOLD SUMMARY OVER GROUPS OF PSNFCN,... C OSNFCN,... HOLD OVERALL SUMMARY (OVER TOLERANCES) OF GSNFCN,... C C LGTOL HOLDS LOGARITHMS TO BASE 10 OF ELEMENTS OF ARRAY TOL, C AND LGGEMX,LGGEND HOLD LOGARITHMS OF CORRESPONDING GEMX C AND GEND VALUES, USED IN SMOOTHNESS CALCULATIONS. C NSNFCN,... STORE NFCN,... FOR ONE PROBLEM AT ALL TOLERANCES C USED, FOR USE IN NORMALIZED EFFICIENCY CALCULATIONS. C ERFLGE,ERFLG1 FLAG 'MISSING VALUES' IN SMOOTHNESS AND NORMALIZED C EFFICIENCY CALCULATIONS. C C C--------+---------+---------+---------+---------+---------+---------+-- C COMMON AREAS C--------+---------+---------+---------+---------+---------+---------+-- C1 C3 C .. Scalar Arguments .. REAL FLAG CHARACTER*80 TITLE C .. Array Arguments .. REAL TOL(11) INTEGER IDLIST(60), OPTION(10) C .. Scalars in Common .. DOUBLE PRECISION ERRTOL, XFIN, XTRUE REAL GEMX, GEND, LEMXSC, OVHD, TIME, TRUTIM INTEGER ID, IOUT, IWT, NBAD, NDCV, NFCN, NRMTYP, NSTART, * NSTL, NSTP, NTRU, OPT, XTRAP C .. Local Scalars .. REAL BIG, C, C1, CTEN, CTEN1, DUM, E, E1, FBADEC, * FDECEV, GEMXSC, GENDSC, OSLEMX, OSOVHD, OSTIME, * RES, RES1, TOLK INTEGER CMPLET, I, ICH, IDSUB, IID, INDG1, INDL1, * KCLASS, KGRP, KSYST, KTOL, NGRP, NOK, NOK1, * NORMEF, NSYST, NTOL, OSNBAD, OSNDCV, OSNFCN, * OSNSTP, OSNTRU CHARACTER BL CHARACTER*10 IDCLAS CHARACTER*32 MCNAME C .. Local Arrays .. REAL GSLEMX(10), GSOVHD(10), GSTIME(10), LGGEMX(10), * LGGEND(10), LGTOL(10), NSOVHD(10), NSTIME(10), * PSGEMX(10), PSGEND(10), PSLEMX(10), PSOVHD(10), * PSTIME(10) INTEGER GRPLST(2,6), GSNBAD(10), GSNDCV(10), GSNFCN(10), * GSNSTP(10), GSNTRU(10), NSNFCN(10), NSNSTP(10), * PSNBAD(10), PSNDCV(10), PSNFCN(10), PSNSTP(10), * PSNTRU(10) LOGICAL ERFLG1(10), ERFLGE(10) C .. External Functions .. REAL CONST, RATIO EXTERNAL CONST, RATIO C .. External Subroutines .. EXTERNAL CNTROL, EFSTAT, LSQFIT, PARCHK, PLOT C .. Intrinsic Functions .. INTRINSIC ALOG10, AMAX1, CHAR, DBLE, IABS, ISIGN C .. Common blocks .. COMMON /NSCOM1/ERRTOL, OPT, NRMTYP, XTRAP, ID, IWT, * IOUT COMMON /NSCOM3/XFIN, XTRUE, TIME, OVHD, TRUTIM, GEND, * GEMX, LEMXSC, NFCN, NSTP, NSTL, NDCV, NBAD, * NTRU, NSTART C .. Data statements .. CE C DATA IDCLAS/'ABCDEFGHIJ'/, BL/' '/, BIG/1.E20/ C .. Executable Statements .. C C--------+---------+---------+---------+---------+---------+---------+-- C COPY THE ENTRIES IN ARRAY 'OPTION'. C DO DUMMY CALL TO CONST TO INVOKE MACHINE-DEPENDENT INITIALIZ- C ATIONS. SET MACHINE NAME. SET OUTPUT UNIT NUMBER. C WRITE OUTPUT-HEADING. CALL ARGUMENT-CHECKING ROUTINE. C--------+---------+---------+---------+---------+---------+---------+-- OPT = OPTION(1) NORMEF = OPTION(2) NRMTYP = OPTION(3) XTRAP = OPTION(4) DUM = CONST(0) DO 20 I = 1, 32 ICH = CONST(-I) MCNAME(I:I) = CHAR(ICH) 20 CONTINUE IOUT = CONST(3) C WRITE (IOUT,FMT=99999) OPT, NORMEF, NRMTYP, MCNAME C CALL PARCHK(OPT,NORMEF,NRMTYP,TOL,IDLIST,NTOL,NGRP,GRPLST,LGTOL, * FLAG) IF (FLAG.EQ.0.) GO TO 40 WRITE (IOUT,FMT=99998) FLAG RETURN C C--------+---------+---------+---------+---------+---------+---------+-- C INITIALIZE OVERALL- AND GROUPS-SUMMARY STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- 40 OSTIME = 0. OSOVHD = 0. OSNFCN = 0 OSNSTP = 0 OSNTRU = 0 OSLEMX = 0. OSNDCV = 0 OSNBAD = 0 DO 60 I = 1, NTOL GSTIME(I) = 0. GSOVHD(I) = 0. GSNFCN(I) = 0 GSNSTP(I) = 0 GSNTRU(I) = 0 GSLEMX(I) = 0. GSNDCV(I) = 0 GSNBAD(I) = 0 60 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C LOOP OVER GROUPS OF PROBLEMS C--------+---------+---------+---------+---------+---------+---------+-- C DO 300 KGRP = 1, NGRP C C--------+---------+---------+---------+---------+---------+---------+-- C OUTPUT HEADING, ON NEW PAGE FOR GROUPS AFTER FIRST. C SELECT GROUP OF DIFFERENTIAL EQUATIONS. C GET NO. OF SYSTEMS IN THIS GROUP, & OFFSET FOR C POSITION OF ITEM IN GROUP WITHIN IDLIST. C INITIALIZE PROBLEM SUMMARY STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- IF (KGRP.GT.1) WRITE (IOUT,FMT=99997) WRITE (IOUT,FMT=99996) KGRP, TITLE C NSYST = GRPLST(1,KGRP) IDSUB = GRPLST(2,KGRP) C DO 80 I = 1, NTOL PSTIME(I) = 0. PSOVHD(I) = 0. PSNFCN(I) = 0 PSNSTP(I) = 0 PSNTRU(I) = 0 PSLEMX(I) = 0. PSNDCV(I) = 0 PSNBAD(I) = 0 PSGEMX(I) = 0. PSGEND(I) = 0. 80 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C LOOP OVER PROBLEMS WITHIN A GROUP C--------+---------+---------+---------+---------+---------+---------+-- DO 260 KSYST = 1, NSYST C--------+---------+---------+---------+---------+---------+---------+-- C GET NEXT PROBLEM-ID: C EXTRACT THE WEIGHTING OPTION (IWT=1 OR -1). C UNPACK ID INTO CLASSNAME + INDEX WITHIN CLASS AND TRANSLATE C INTO NSDTST INTERNAL ID BY SUBTRACTING 10: C--------+---------+---------+---------+---------+---------+---------+-- IDSUB = IDSUB + 1 ID = IDLIST(IDSUB) IWT = ISIGN(1,ID) ID = IABS(ID) KCLASS = (ID-1)/10 IID = ID - 10*KCLASS ID = ID - 10 IF (IWT.GT.0) WRITE (IOUT,FMT=99995) IDCLAS(KCLASS:KCLASS), * IID IF (IWT.LE.0) WRITE (IOUT,FMT=99994) IDCLAS(KCLASS:KCLASS), * IID WRITE (IOUT,FMT=99993) (BL,I=1,OPT) WRITE (IOUT,FMT=99992) (BL,I=1,OPT) C C--------+---------+---------+---------+---------+---------+---------+-- C LOOP OVER TOLERANCES FOR ONE PROBLEM C--------+---------+---------+---------+---------+---------+---------+-- DO 220 KTOL = 1, NTOL C--------+---------+---------+---------+---------+---------+---------+-- C CALL PLOT TO INITIALIZE LOCAL-ERROR SCATTER DIAGRAM C IF OPT=4. C CALL CNTROL TO ORGANIZE THE COLLECTION OF C STATISTICS. C ON EXIT FROM CNTROL THE VALUE OF CMPLET WILL C INDICATE WHETHER A FAILURE OCCURRED. C C CMPLET = 1 NO FAILURES. C CMPLET = 0 DETEST FAILED TO OBTAIN TRUE C LOCAL OR GLOBAL SOLUTION. C CMPLET = -1 METHOD FAILED TO REACH THE END C OF RANGE. C CMPLET = -2 DETEST FAILED AND SUBSEQUENTLY C METHOD FAILED. C CMPLET = -3 METHOD COULD NOT START THE C INTEGRATION. C CMPLET = -4 METHOD COMPLETED THE STATISTICS C GATHERING BUT FAILED IN TIMING LOOP. C C ON EXIT INDG1,INDL1 HOLD EXIT-FLAGS OF 'TRUE' C GLOBAL AND LOCAL SOLUTIONS RESPECTIVELY. C C ERFLGE(KTOL) IS TRUE IF METHOD FAILED TO REACH XEND. C ERFLG1(KTOL) IS TRUE IF EITHER METHOD OR C TRUE-SOLUTION FAILED TO REACH XEND (THUS INVALIDATING C GEMX AS DATA FOR SMOOTHNESS CALC WHEN NORMEF=2 ). C C IF CMPLET IS -4,-2,-1,0 OR 1 PRINT A LINE OF STATISTICS: C IF CMPLET ISNT 1, PRINT AN ERROR MESSAGE. C CALL PLOT TO PRINT LOCAL-ERROR SCATTER DIAGRAM C IF OPT=4 C NOTE IF METHOD FAILED TO REACH XEND, ANY STATISTICS FOR C THIS PROBLEM ARE PRINTED BUT DO NOT CONTRIBUTE TO THE C SUMMARY STATISTICS. CONVERSELY IF METHOD REACHED XEND, C ALL STATISTICS CONTRIBUTE TO THE SUMMARIES THOUGH GEMX, C LEMXSC,NDCV,NBAD,NTRU ONLY APPLY TO PART OF THE RANGE C IF 'TRUE' FAILED. C--------+---------+---------+---------+---------+---------+---------+-- C TOLK = TOL(KTOL) ERRTOL = DBLE(TOLK) IF (OPT.EQ.4) CALL PLOT(0.,0.,0) C CALL CNTROL(CMPLET,INDG1,INDL1) C ERFLGE(KTOL) = CMPLET .LT. 0 .AND. CMPLET .GT. -4 ERFLG1(KTOL) = CMPLET .LT. 1 .AND. CMPLET .GT. -4 GENDSC = BIG IF (ERFLGE(KTOL)) GO TO 100 GENDSC = GEND/TOLK LGGEND(KTOL) = ALOG10(AMAX1(GEND,.01*TOLK)) 100 CONTINUE GEMXSC = GEMX/TOLK FDECEV = RATIO(NDCV,NTRU) FBADEC = RATIO(NBAD,NTRU) C IF (CMPLET.EQ.-3) GO TO 120 IF (OPT.EQ.1) WRITE (IOUT,FMT=99991) LGTOL(KTOL), TIME, * OVHD, NFCN, NSTP, GENDSC IF (OPT.EQ.2) WRITE (IOUT,FMT=99991) LGTOL(KTOL), TIME, * OVHD, NFCN, NSTP, GENDSC, GEMXSC IF (OPT.GE.3) WRITE (IOUT,FMT=99991) LGTOL(KTOL), TIME, * OVHD, NFCN, NSTP, GENDSC, GEMXSC, LEMXSC, FDECEV, * FBADEC IF (OPT.GE.3 .AND. NSTP.NE.NTRU) WRITE (IOUT,FMT=99990) * NTRU 120 CONTINUE C C IF (CMPLET.EQ.-4) WRITE (IOUT,FMT=99989) IF (CMPLET.EQ.-3) WRITE (IOUT,FMT=99988) LGTOL(KTOL) C IF (CMPLET.EQ.-2) WRITE (IOUT,FMT=99987) XTRUE, INDG1, * INDL1, XFIN C IF (CMPLET.EQ.-1) WRITE (IOUT,FMT=99986) XFIN C IF (CMPLET.EQ.0) WRITE (IOUT,FMT=99985) XTRUE, INDG1, * INDL1 C IF (OPT.EQ.4) THEN C WRITE (IOUT,FMT=99984) XTRAP C CALL PLOT(0.,0.,2) END IF C FOR EVALUATING PERFORMANCE OF 'TRUE': C CALL TRUCHK(4,IDUM) C C--------+---------+---------+---------+---------+---------+---------+-- C UPDATE PROBLEMS-SUMMARY STATS IF METHOD REACHED XEND. C (IF IT DIDN'T, DON'T UPDATE THE LOCAL-ASSESSMENT INFO: C NTRU,LEMXSC,NDCV,NBAD. THIS IS AN ARBITRARY CHOICE, IT C MAKES IT SIMPLER TO EXPLAIN TO THE USER. C STORE NORMEF STATISTICS: C--------+---------+---------+---------+---------+---------+---------+-- C IF (ERFLGE(KTOL)) GO TO 180 PSTIME(KTOL) = PSTIME(KTOL) + TIME PSOVHD(KTOL) = PSOVHD(KTOL) + OVHD PSNFCN(KTOL) = PSNFCN(KTOL) + NFCN PSNSTP(KTOL) = PSNSTP(KTOL) + NSTP PSGEND(KTOL) = AMAX1(PSGEND(KTOL),GENDSC) C IF (OPT.LT.2) GO TO 140 PSGEMX(KTOL) = AMAX1(PSGEMX(KTOL),GEMXSC) LGGEMX(KTOL) = ALOG10(AMAX1(GEMX,.01*TOLK)) C 140 IF (OPT.LT.3) GO TO 160 PSNTRU(KTOL) = PSNTRU(KTOL) + NTRU PSLEMX(KTOL) = AMAX1(PSLEMX(KTOL),LEMXSC) PSNDCV(KTOL) = PSNDCV(KTOL) + NDCV PSNBAD(KTOL) = PSNBAD(KTOL) + NBAD 160 CONTINUE 180 CONTINUE C IF (NORMEF.EQ.0) GO TO 200 NSTIME(KTOL) = TIME NSOVHD(KTOL) = OVHD NSNFCN(KTOL) = NFCN NSNSTP(KTOL) = NSTP 200 CONTINUE C--------+---------+---------+---------+---------+---------+---------+-- C END OF LOOP OVER TOLERANCES FOR ONE PROBLEM C--------+---------+---------+---------+---------+---------+---------+-- 220 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C SMOOTHNESS AND NORMALIZED EFFICIENCY CALCULATIONS BEGIN C--------+---------+---------+---------+---------+---------+---------+-- WRITE (IOUT,FMT=99983) C WRITE (IOUT,FMT=99982) C CALL LSQFIT(LGTOL,LGGEND,ERFLGE,NTOL,NOK,C,E,RES) C CTEN = 10.**C IF (NOK.LE.2) WRITE (IOUT,FMT=99981) NOK C IF (NOK.GT.2) WRITE (IOUT,FMT=99980) CTEN, E, RES, NOK C IF (OPT.LT.2) GO TO 240 WRITE (IOUT,FMT=99979) C CALL LSQFIT(LGTOL,LGGEMX,ERFLG1,NTOL,NOK1,C1,E1,RES1) C CTEN1 = 10.**C1 IF (NOK1.LE.2) WRITE (IOUT,FMT=99981) NOK1 IF (NOK1.GT.2) WRITE (IOUT,FMT=99980) CTEN1, E1, RES1, NOK1 240 CONTINUE C IF (NORMEF.EQ.1) CALL EFSTAT(C,E,LGTOL,NTOL,NOK,ERFLGE, * 'ENDPOINT',IOUT,NSTIME,NSOVHD, * NSNFCN,NSNSTP) C IF (NORMEF.EQ.2) CALL EFSTAT(C1,E1,LGTOL,NTOL,NOK1,ERFLG1, * 'MAXIMUM ',IOUT,NSTIME,NSOVHD, * NSNFCN,NSNSTP) C C--------+---------+---------+---------+---------+---------+---------+-- C SMOOTHNESS AND NORMALIZED EFFICIENCY CALCULATIONS END C--------+---------+---------+---------+---------+---------+---------+-- C C--------+---------+---------+---------+---------+---------+---------+-- C END OF LOOP OVER PROBLEMS IN A GROUP. C--------+---------+---------+---------+---------+---------+---------+-- 260 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C OUTPUT PROBLEMS-SUMMARY STATISTICS C--------+---------+---------+---------+---------+---------+---------+-- C WRITE (IOUT,FMT=99978) KGRP WRITE (IOUT,FMT=99993) (BL,I=1,OPT) WRITE (IOUT,FMT=99992) (BL,I=1,OPT) DO 280 KTOL = 1, NTOL FDECEV = RATIO(PSNDCV(KTOL),PSNTRU(KTOL)) FBADEC = RATIO(PSNBAD(KTOL),PSNTRU(KTOL)) C IF (OPT.EQ.1) WRITE (IOUT,FMT=99991) LGTOL(KTOL), * PSTIME(KTOL), PSOVHD(KTOL), PSNFCN(KTOL), PSNSTP(KTOL), * PSGEND(KTOL) C IF (OPT.EQ.2) WRITE (IOUT,FMT=99991) LGTOL(KTOL), * PSTIME(KTOL), PSOVHD(KTOL), PSNFCN(KTOL), PSNSTP(KTOL), * PSGEND(KTOL), PSGEMX(KTOL) C IF (OPT.GE.3) WRITE (IOUT,FMT=99991) LGTOL(KTOL), * PSTIME(KTOL), PSOVHD(KTOL), PSNFCN(KTOL), PSNSTP(KTOL), * PSGEND(KTOL), PSGEMX(KTOL), PSLEMX(KTOL), FDECEV, FBADEC C IF (OPT.GE.3 .AND. PSNSTP(KTOL).NE.PSNTRU(KTOL)) * WRITE (IOUT,FMT=99990) PSNTRU(KTOL) C C--------+---------+---------+---------+---------+---------+---------+-- C UPDATE GROUPS-SUMMARY STATISTICS C--------+---------+---------+---------+---------+---------+---------+-- GSTIME(KTOL) = GSTIME(KTOL) + PSTIME(KTOL) GSOVHD(KTOL) = GSOVHD(KTOL) + PSOVHD(KTOL) GSNFCN(KTOL) = GSNFCN(KTOL) + PSNFCN(KTOL) GSNSTP(KTOL) = GSNSTP(KTOL) + PSNSTP(KTOL) C IF (OPT.LT.3) GO TO 280 GSNTRU(KTOL) = GSNTRU(KTOL) + PSNTRU(KTOL) GSLEMX(KTOL) = AMAX1(GSLEMX(KTOL),PSLEMX(KTOL)) GSNDCV(KTOL) = GSNDCV(KTOL) + PSNDCV(KTOL) GSNBAD(KTOL) = GSNBAD(KTOL) + PSNBAD(KTOL) 280 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C END OF LOOP OVER GROUPS C--------+---------+---------+---------+---------+---------+---------+-- 300 CONTINUE C C C--------+---------+---------+---------+---------+---------+---------+-- C OUTPUT HEADINGS FOR GROUPS- AND OVERALL-SUMMARY STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- WRITE (IOUT,FMT=99977) TITLE, (BL,I=1,OPT) WRITE (IOUT,FMT=99976) (BL,I=1,OPT) C--------+---------+---------+---------+---------+---------+---------+-- C OUTPUT GROUPS-SUMMARY STATISTICS C--------+---------+---------+---------+---------+---------+---------+-- IF (OPT.GE.3) GO TO 340 DO 320 I = 1, NTOL WRITE (IOUT,FMT=99975) LGTOL(I), GSTIME(I), GSOVHD(I), * GSNFCN(I), GSNSTP(I) 320 CONTINUE GO TO 380 340 DO 360 I = 1, NTOL FDECEV = RATIO(GSNDCV(I),GSNTRU(I)) FBADEC = RATIO(GSNBAD(I),GSNTRU(I)) WRITE (IOUT,FMT=99975) LGTOL(I), GSTIME(I), GSOVHD(I), * GSNFCN(I), GSNSTP(I), GSLEMX(I), FDECEV, FBADEC C IF (GSNSTP(I).NE.GSNTRU(I)) WRITE (IOUT,FMT=99990) GSNTRU(I) 360 CONTINUE 380 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C COMPUTE OVERALL-SUMMARY STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- DO 400 I = 1, NTOL OSTIME = OSTIME + GSTIME(I) OSOVHD = OSOVHD + GSOVHD(I) OSNFCN = OSNFCN + GSNFCN(I) OSNSTP = OSNSTP + GSNSTP(I) C IF (OPT.LT.3) GO TO 400 OSNTRU = OSNTRU + GSNTRU(I) OSNDCV = OSNDCV + GSNDCV(I) OSNBAD = OSNBAD + GSNBAD(I) OSLEMX = AMAX1(OSLEMX,GSLEMX(I)) 400 CONTINUE FDECEV = RATIO(OSNDCV,OSNTRU) FBADEC = RATIO(OSNBAD,OSNTRU) C--------+---------+---------+---------+---------+---------+---------+-- C OUTPUT OVERALL-SUMMARY STATISTICS C--------+---------+---------+---------+---------+---------+---------+-- IF (OPT.LT.3) WRITE (IOUT,FMT=99974) OSTIME, OSOVHD, OSNFCN, * OSNSTP C IF (OPT.GE.3) WRITE (IOUT,FMT=99974) OSTIME, OSOVHD, OSNFCN, * OSNSTP, OSLEMX, FDECEV, FBADEC C C RETURN C 99999 FORMAT ('0NONSTIFF DETEST PACKAGE OPTION=',I2,', NORMEF=',I2, * ', NRMTYP=',I2,19X,'ON ',A,//) 99998 FORMAT ('0PARAMETER ERRORS AS SHOWN BY FLAG=',E15.8,/' ',49('*') * ,//) 99997 FORMAT ('1') 99996 FORMAT ('0GROUP',I3,18X,A) 99995 FORMAT (/'0',A3,I1,' (SCALED)',/) 99994 FORMAT (/'0',A3,I1,' (UNSCALED)',/) 99993 FORMAT (' ',A1,6X,'LOG10',5X,'TIME',3X,'OVHD',5X,'FCN',4X,'NO OF', * 3X,'END PNT',A1,2X,'MAXIMUM',A1,2X,'MAXIMUM',3X,'FRACTION', * 3X,'FRACTION',A1) 99992 FORMAT (' ',A1,7X,'TOL',21X,'CALLS',3X,'STEPS',3X,'GLB ERR',A1,2X, * 'GLB ERR',A1,2X,'LOC ERR',3X,'DECEIVED',3X,'BAD DECV',A1) 99991 FORMAT ('0',6X,F6.2,2X,2F7.3,1X,2I8,2X,F8.2,1X,F9.2,1X,F9.3,1X, * F9.3,1X,F10.3,1X,F10.3) 99990 FORMAT (114X,'(LOC ASSESS ON',I4,')') 99989 FORMAT ('0',20X, * '***** UNEXPECTED FAILURE OF METHOD WHILE BEING TIMED *****' * ,/) 99988 FORMAT ('0',6X,F6.2,' *** METHOD FAILED TO START ***') 99987 FORMAT (15X,'TRUE-SOLUTION OF TEST PACKAGE FAILED AT X = ',1P, * E12.5,', ERROR FLAG (GLOBAL) ',I3,', (LOCAL) ',I3,/21X, * 'AND SUBSEQUENTLY METHOD FAILED AT X = ',1P,E12.5) 99986 FORMAT (21X,'METHOD FAILED AT X = ',1P,E12.5) 99985 FORMAT (21X,'TRUE-SOLUTION OF TEST PACKAGE FAILED AT X = ',1P, * E12.5,', ERROR FLAG (GLOBAL) ',I3,', (LOCAL) ',I3) 99984 FORMAT (/6X,'ERROR ESTIMATE ANALYSIS',10X, * 'EXTRAPOLATION (0=NO 1=YES):',I2,/11X, * 'HORIZONTAL AXIS: R1=||ERREST|| / ERRBND',/11X, * 'VERTICAL AXIS: R2 = ||ERROR IN ERREST|| / ERRBND',/11X, * 'PLOT SHOWS % STEPS WHERE (R1,R2) LAY',1X, * 'IN INDICATED PIGEONHOLE, A DOT MEANS UNDER 1%',/) 99983 FORMAT (/'0',17X,'SMOOTHNESS FIT OF LOG10(ERROR) VS LOG10(TOL)') 99982 FORMAT ('0',17X,'ENDPOINT GLOBAL ERROR') 99981 FORMAT (39X,I2,' VALUES, TOO FEW TO GET STATISTICS') 99980 FORMAT (39X,'=',1P,G10.3,' *(TOL**',0P,F6.3,') APPROX,',6X, * 'R.M.S. RESIDUAL=',1P,E8.1,' OVER',I3,' VALUES') 99979 FORMAT ('0',17X,'MAXIMUM GLOBAL ERROR') 99978 FORMAT (/'0SUMMARY OVER GROUP',I3) 99977 FORMAT ('1SUMMARY OVER ALL GROUPS',6X,A,//' ',A1,6X,'LOG10',5X, * 'TIME',3X,'OVHD',5X,'FCN',4X,'NO OF',2A1,'MAXIMUM',3X, * 'FRACTION',3X,'FRACTION',A1) 99976 FORMAT (' ',A1,7X,'TOL',21X,'CALLS',3X,'STEPS',2A1,'LOC ERR',3X, * 'DECEIVED',3X,'BAD DECV',A1) 99975 FORMAT ('0',6X,F6.2,2X,2F7.3,1X,2I8,1X,3F11.3) 99974 FORMAT ('0',5X,'OVERALL',/6X,'SUMMARY',2X,2F7.3,1X,2I8,1X,3F11.3) END C C C********+*********+*********+*********+*********+*********+*********+** C SUBROUTINE PARCHK(OPT,NORMEF,NRMTYP,TOL,IDLIST,NTOL,NGRP,GRPLST, * LGTOL,FLAG) C C********+*********+*********+*********+*********+*********+*********+** C ROUTINE TO DO PARAMETER CHECKS FOR REVISED NSDTST INTERFACE. C C INPUT: OPT,NORMEF,NRMTYP,TOL,IDLIST C VALID INPUT IS: C OPTION = 1 2 3 OR 4 C NORMEF = 0 1 OR 2 C NRMTYP = 1 2 OR 3 C TOL = LIST OF UP TO 10 POSITIVE REAL'S FOLLOWED BY A 0., C IN STRICTLY DECREASING ORDER C IDLIST = LIST OF GROUPS OF PROBLEM-IDS SEPARATED BY ZEROS C WITH 2 ZEROS AFTER LAST GROUP, AT MOST 60 ITEMS TOTAL. C EACH ID MAY HAVE A MINUS SIGN TO SELECT THE 'UNSCALED' C ERROR CONTROL OPTION. C VALID PROBLEM-IDS ARE IN RANGES C 11-15 21-25 31-35 41-45 51-55 61-65 C FOR PROBLEM CLASSES A1-A5 B1-B5 ETC. C OUTPUT: NTOL = NO. OF TOLERANCES IN TOL LIST C NGRP = NO. OF GROUPS IN IDLIST LIST C GRPLST(1,I) = SIZE OF I-TH GROUP OF PROBLEMS CC ... (2,I) = POINTER TO (START OF I-TH GROUP)-1 IN IDLIST C LGTOL(I) = LOG10(TOL(I)) C FLAG IS ERROR FLAG, 0.0 IF ALL OK, ELSE ITS DECIMAL DIGITS C INDICATE WHICH PARAMETER ERRORS WERE FOUND: C 1: OPT INVALID C 2: NORMEF INVALID C 3: NORMEF = 2 REQUESTED WITH OPT = 1 C 4: TOL(I) < 0, OR LIST NOT IN DECREASING ORDER C 5: TOL LIST EMPTY OR NOT TERMINATED BY ZERO C 6: INVALID PROBLEM-ID FOUND C 7: LIST OF GROUPS IN IDLIST EMPTY,NOT TERMINATED BY C 2 ZEROS OR HAS MORE THAN MAXGRP GROUPS C 8: NRMTYP INVALID C--------+---------+---------+---------+---------+---------+---------+-- C C .. Scalar Arguments .. REAL FLAG INTEGER NGRP, NORMEF, NRMTYP, NTOL, OPT C .. Array Arguments .. REAL LGTOL(10), TOL(11) INTEGER GRPLST(2,6), IDLIST(60) C .. Local Scalars .. REAL BIG, TOLPRV INTEGER ENDLST, I, ID, IID, ISAV, KCLASS, LENIDS, * LENTOL, MAXGRP, NCLASS C .. Local Arrays .. INTEGER NSYSTM(6) C .. Intrinsic Functions .. INTRINSIC ALOG10, IABS C .. Data statements .. DATA ENDLST/-1/, BIG/1E20/ DATA NCLASS/6/, NSYSTM/5, 5, 5, 5, 5, 5/, MAXGRP/6/, * LENTOL/11/, LENIDS/60/ C .. Executable Statements .. C FLAG = 0. IF (OPT.LT.1 .OR. OPT.GT.4) FLAG = 1. IF (NORMEF.LT.0 .OR. NORMEF.GT.2) FLAG = 10.*FLAG + 2. IF (OPT.EQ.1 .AND. NORMEF.EQ.2) FLAG = 10.*FLAG + 3. IF (NRMTYP.LT.1 .OR. NRMTYP.GT.3) FLAG = 10.*FLAG + 8. C C TOLERANCES: NTOL = 0 TOLPRV = BIG DO 20 I = 1, LENTOL IF (TOL(I).LT.0. .OR. TOL(I).GE.TOLPRV) FLAG = 10.*FLAG + 4. IF (TOL(I).EQ.0.) GO TO 40 NTOL = NTOL + 1 TOLPRV = TOL(I) 20 CONTINUE C C NO TERMINATING 0 IN TOLERANCE LIST: FLAG = 10.*FLAG + 5. C C CHECK FOR EMPTY TOLERANCE LIST: 40 IF (NTOL.EQ.0) FLAG = 10.*FLAG + 5. C C LIST OF GROUPS OF PROBLEMS: NGRP = 0 I = 0 C C WHILE NEXT ID IN LIST ISNT 0 OR END OF LIST: 60 I = I + 1 ID = ENDLST IF (I.LE.LENIDS) ID = IDLIST(I) C IF (ID.EQ.0) GO TO 160 IF (NGRP.GE.MAXGRP) GO TO 180 ISAV = I - 1 C C WHILE ID ISNT 0, GET ONE GROUP: 80 IF (ID.EQ.0) GO TO 140 IF (ID.EQ.ENDLST) GO TO 180 C TRANSLATE ID INTO CLASS & NUMBER WITHIN CLASS, C IGNORING SIGN (WHICH SELECTS SCALED/UNSCALED OPTION): ID = IABS(ID) KCLASS = (ID-1)/10 IID = ID - 10*KCLASS IF ( .NOT. (KCLASS.GE.1 .AND. KCLASS.LE.NCLASS)) GO TO 100 IF (IID.LE.NSYSTM(KCLASS)) GO TO 120 100 FLAG = 10.*FLAG + 6. 120 CONTINUE C GET NEXT ID AS ABOVE: I = I + 1 ID = ENDLST IF (I.LE.LENIDS) ID = IDLIST(I) GO TO 80 C C NEW GROUP FORMED: 140 NGRP = NGRP + 1 GRPLST(1,NGRP) = I - ISAV - 1 GRPLST(2,NGRP) = ISAV GO TO 60 C C CHECK IF NO GROUPS WERE SPECIFIED: 160 IF (NGRP.LE.0) GO TO 180 GO TO 200 C 180 FLAG = 10.*FLAG + 7. C C IF ALL OK, COMPUTE LOGS OF TOLERANCES: C 200 IF (FLAG.NE.0.) GO TO 240 DO 220 I = 1, NTOL LGTOL(I) = ALOG10(TOL(I)) 220 CONTINUE 240 RETURN END C C********+*********+*********+*********+*********+*********+*********+** C SUBROUTINE LSQFIT(X,Y,MISS,N,NN,C0,C1,RES) C .. Scalar Arguments .. REAL C0, C1, RES INTEGER N, NN C .. Array Arguments .. REAL X(N), Y(N) LOGICAL MISS(N) C .. Local Scalars .. REAL SX, SXX, SXY, SY, XNN INTEGER I C .. Intrinsic Functions .. INTRINSIC SQRT C .. Executable Statements .. C C********+*********+*********+*********+*********+*********+*********+** C FITS MODEL Y = C0 + C1*X TO DATA X(I),Y(I),I = 1..N WHERE DATA C FOR WHICH MISS(I) IS .TRUE. IS REGARDED AS MISSING. C C ON EXIT C X,Y,MISS,N ARE UNCHANGED. C NN = NO. OF NONMISSING VALUES C C0,C1 = FITTED COEFFICIENTS C RES = ROOT MEAN SQUARE RESIDUAL C C EXCEPT THAT IF NN.LE.1 NO COMPUTATION OF THE COEFFICIENTS IS DONE. C--------+---------+---------+---------+---------+---------+---------+-- C NN = 0 SX = 0. SY = 0. DO 20 I = 1, N IF (MISS(I)) GO TO 20 NN = NN + 1 SX = SX + X(I) SY = SY + Y(I) 20 CONTINUE IF (NN.LE.1) GO TO 80 XNN = NN SX = SX/XNN SY = SY/XNN SXX = 0. SXY = 0. DO 40 I = 1, N IF (MISS(I)) GO TO 40 SXX = SXX + (X(I)-SX)**2 SXY = SXY + (X(I)-SX)*(Y(I)-SY) 40 CONTINUE C1 = SXY/SXX C0 = SY - C1*SX RES = 0. DO 60 I = 1, N IF ( .NOT. MISS(I)) RES = RES + (Y(I)-SY-C1*(X(I)-SX))**2 60 CONTINUE C RES = SQRT(RES/XNN) C 80 RETURN END C C********+*********+*********+*********+*********+*********+*********+** C REAL FUNCTION RATIO(M,N) C C********+*********+*********+*********+*********+*********+*********+** C .. Scalar Arguments .. INTEGER M, N C .. Intrinsic Functions .. INTRINSIC FLOAT C .. Executable Statements .. RATIO = 1E20 IF (N.NE.0) RATIO = FLOAT(M)/FLOAT(N) RETURN END C C********+*********+*********+*********+*********+*********+*********+** C SUBROUTINE EFSTAT(C,E,LGTOL,NTOL,NOK,ERFLG,TITLE,IOUT,W1,W2,W3,W4) C C********+*********+*********+*********+*********+*********+*********+** C ROUTINE TO COMPUTE AND PRINT NORMALIZED EFFICIENCY STATISTICS. C C PARAMETERS (ALL INPUT): C C,E - COEFFICIENTS IN LEAST-SQUARES FIT OF ACHIEVED ACCURACY C (EITHER AT ENDPOINT OR MAX-OVER-RANGE) TO TOLERANCE. C LGTOL - LIST OF LOGS TO BASE 10 OF TOLERANCES C NTOL - NO. OF TOLERANCES. C NOK - NO. OF .FALSE. ENTRIES IN ERFLG (FROM LSQFIT CALL) C ERFLG - LOGICAL VECTOR INDICATING FOR WHICH TOLERANCES DATA C IS TO BE REGARDED AS MISSING. C TITLE C - IDENTIFYING CHARACTER STRING. C IOUT - OUTPUT UNIT NUMBER. C W1,...,W6 C - VECTORS OF STATISTICS, INDEXED OVER TOLERANCES, FOR C WHICH NORMALIZED STATISTICS ARE TO BE PRODUCED. C (NOTE SOME ARE REAL, SOME INTEGER: REFER TO ACTUAL CALL C IN NSDTST.) C IT IS ASSUMED THAT NTOL.LE.10, OTHERWISE ARRAY S MUST BE LONGER. C--------+---------+---------+---------+---------+---------+---------+-- C C LOCAL VARIABLES C .. Scalar Arguments .. REAL C, E INTEGER IOUT, NOK, NTOL CHARACTER*8 TITLE C .. Array Arguments .. REAL LGTOL(NTOL), W1(NTOL), W2(NTOL) INTEGER W3(NTOL), W4(NTOL) LOGICAL ERFLG(NTOL) C .. Local Scalars .. REAL EQVTOL, S0, THETA, W1INT, W2INT, X INTEGER I, MSINT, NHI, NLO, SHI, SINT, SLO, W3INT, W4INT C .. Local Arrays .. REAL S(10) C .. Intrinsic Functions .. INTRINSIC FLOAT, INT C .. Statement Functions .. INTEGER FLOOR C .. Statement Function definitions .. C C STATEMENT FUNCTION C FLOOR FUNCTION VALID IF ARGUMENT X.GE.-100 WHICH IS OK HERE. FLOOR(X) = INT(X+100.) - 100 C .. Executable Statements .. C IF (NOK.LE.2) GO TO 200 C C TRANSFORM THE LOG10(TOL)'S TO NORMALIZED-EFFICIENCY VARIABLE: DO 20 I = 1, NTOL S(I) = -(C+E*LGTOL(I)) 20 CONTINUE C C FIND SET OF CONSECUTIVE TOL'S FOR WHICH INTEGRATION SUCCEEDED: DO 40 NLO = 1, NTOL IF ( .NOT. ERFLG(NLO)) GO TO 60 40 CONTINUE C ELSE ALL INTEGRATIONS FOR THIS PROBLEM FAILED: GO TO 200 60 CONTINUE NHI = NLO - 1 DO 80 I = NLO, NTOL IF (ERFLG(I)) GO TO 100 NHI = I 80 CONTINUE 100 CONTINUE C IF (NHI.LE.NLO) GO TO 200 IF (E.LE.0.) GO TO 220 C C FORM RANGE OF INTEGER POWERS OF 10 FOR WHICH NORMALIZED STATISTICS C ARE TO BE PRINTED: SLO = -FLOOR(-S(NLO)+0.1) SHI = FLOOR(S(NHI)+0.1) IF (SHI.LT.SLO) GO TO 240 C WRITE (IOUT,FMT=99999) TITLE C C START OF LOOP TO PRINT A LINE OF STATISTICS FOR EACH POWER OF 10: I = NLO + 1 CC ... WHICH IS KNOWN TO BE .LE. NHI C DO 160 SINT = SLO, SHI S0 = FLOAT(SINT) C C MOVE INTERVAL S(I-1)..S(I) TO RIGHT WHILE S(I).LT.SINT: 120 IF (S(I).GE.S0 .OR. I.GE.NHI) GO TO 140 I = I + 1 GO TO 120 140 CONTINUE C NECESSARILY NOW NLO + 1 .LE. I .LE. NHI C C NOW DO INTERPOLATION (POSSIBLY EXTRAPOLATION A SHORT DISTANCE) C USING DATA FOR I AND I + 1: THETA = (S0-S(I-1))/(S(I)-S(I-1)) W1INT = W1(I-1) + THETA*(W1(I)-W1(I-1)) W2INT = W2(I-1) + THETA*(W2(I)-W2(I-1)) W3INT = W3(I-1) + THETA*(W3(I)-W3(I-1)) W4INT = W4(I-1) + THETA*(W4(I)-W4(I-1)) C MSINT = -SINT EQVTOL = -(C+S0)/E WRITE (IOUT,FMT=99998) MSINT, EQVTOL, W1INT, W2INT, W3INT, * W4INT C 160 CONTINUE C 180 RETURN C 200 WRITE (IOUT,FMT=99997) GO TO 180 C 220 WRITE (IOUT,FMT=99996) GO TO 180 C 240 WRITE (IOUT,FMT=99995) GO TO 180 C 99999 FORMAT (/'0',6X,'NORMALIZED EFFICIENCY - ',A8,' GLOBAL ERROR', * //7X,'EXPECTED',3X,'EQUIV',4X,'TIME',3X,'OVHD',5X,'FCN',4X, * 'NO OF',/7X,'ACCURACY',1X,'LOG10 TOL',17X,'CALLS',3X, * 'STEPS') 99998 FORMAT ('0',6X,'10**',I3,F8.2,F9.3,F7.3,1X,2I8) 99997 FORMAT ('0',10X,'NOT ENOUGH SUCCESSFUL INTEGRATIONS TO FORM',1X, * 'NORMALIZED STATISTICS') 99996 FORMAT ('0',10X,'DEPENDENCE OF ACCURACY ON TOLERANCE IS TOO',1X, * 'UNRELIABLE TO FORM NORMALIZED STATISTICS') 99995 FORMAT ('0',10X,'NO POWERS OF TEN WITHIN RANGE OF TOLERANCES',1X, * 'USED: NO NORMALIZED STATISTICS') END C C C********+*********+*********+*********+*********+*********+*********+** C SUBROUTINE CNTROL(CMPLET,INDG1,INDL1) C C********+*********+*********+*********+*********+*********+*********+** C CNTROL ORGANIZES THE CALLS TO METHOD NEEDED TO GATHER C STATISTICS FOR ONE PROBLEM AND ONE TOLERANCE AT THE LEVEL OF C DETAIL SPECIFIED BY OPT, WITH SCALING TURNED ON OR OFF BY IWT. C C ON EXIT FROM CNTROL C CMPLET INDICATES WHETHER A FAILURE OCCURRED: C CMPLET = 1 NO FAILURES. C CMPLET = 0 DETEST FAILED TO OBTAIN TRUE LOCAL OR GLOBAL C SOLUTION. C CMPLET = -1 METHOD FAILED TO REACH THE END OF RANGE. C CMPLET = -2 DETEST FAILED AND SUBSEQUENTLY METHOD FAILED C CMPLET = -3 METHOD COULD NOT START THE INTEGRATION. C CMPLET = -4 METHOD COMPLETED THE STATISTICS GATHERING CALL C BUT (UNEXPECTEDLY) FAILED IN THE TIMING LOOP. C C INDG1, INDL1 RETURN THE ERROR FLAGS OF THE 'TRUE' GLOBAL C AND LOCAL SOLUTIONS RESPECTIVELY. C C THE MAIN OUTPUT FROM CNTROL CONSISTS OF THE STATISTICS HELD C IN COMMON /NSCOM3/ C--------+---------+---------+---------+---------+---------+---------+-- C--------+---------+---------+---------+---------+---------+---------+-- C COMMON AREAS C--------+---------+---------+---------+---------+---------+---------+-- C1 C2 C3 C5 C6 C .. Scalar Arguments .. INTEGER CMPLET, INDG1, INDL1 C .. Scalars in Common .. DOUBLE PRECISION ERRTOL, HSTART, XEND, XFIN, XTRUE REAL GEMX, GEND, LEMXSC, OVHD, TIME, TRUTIM INTEGER ID, ID1, IFLAG, INDG, INDL, IOUT, IWT, IWT1, N, * N1, NBAD, NDCV, NFCN, NFCN1, NRMTYP, NSTART, * NSTL, NSTP, NTRU, OPT, XTRAP C .. Arrays in Common .. DOUBLE PRECISION WT(51) C .. Local Scalars .. DOUBLE PRECISION DUMMY, HINIT, HMAX, X, XSTART REAL FCNTIM, S, TIMCUM, TSTTIM INTEGER COUNT, I LOGICAL NOSTRT, OKMETH, TIMERR C .. Local Arrays .. DOUBLE PRECISION Y(51), YEND(51), YSTART(51) C .. External Functions .. REAL CLOCK, CONST, DIFNRM EXTERNAL CLOCK, CONST, DIFNRM C .. External Subroutines .. EXTERNAL EVALU, IVALU, METHOD, STATS C .. Intrinsic Functions .. INTRINSIC FLOAT C .. Common blocks .. COMMON /NSCOM1/ERRTOL, OPT, NRMTYP, XTRAP, ID, IWT, * IOUT COMMON /NSCOM2/XEND, HSTART, N, IFLAG, INDL, INDG COMMON /NSCOM3/XFIN, XTRUE, TIME, OVHD, TRUTIM, GEND, * GEMX, LEMXSC, NFCN, NSTP, NSTL, NDCV, NBAD, * NTRU, NSTART COMMON /NSCOM5/WT, IWT1, N1, ID1 COMMON /NSCOM6/NFCN1 C .. Executable Statements .. CE C C--------+---------+---------+---------+---------+---------+---------+-- C NOTE ON INDL, INDG IN /NSCOM2/: C THESE ARE ERROR INDICATORS FOR THE 'TRUE' LOCAL AND C GLOBAL SOLUTION RESPECTIVELY. THEY ARE SET INSIDE STATS C WHICH IS CALLED BY METHOD. C ON RETURN FROM METHOD, INDL IS: C 2 IF NO CALL TO TRUE TO COMPUTE LOCAL SOLUTION HAS C YET BEEN MADE (SET BY INITIALIZING CALL TO STATS). C .GT.0 IF ALL CALLS TO TRUE FOR CALCULATION OF LOCAL C SOLUTION WERE SUCCESSFUL. C .LT.0 IF AN UNSUCCESSFUL CALL TO TRUE FOR THE LOCAL C SOLUTION WAS MADE. C THE VALUE ON EXIT IF NOT 0 IS THE VALUE RETURNED IN THE C FLAG 'IND' OF SUBROUTINE TRUE. C INDG IS THE SAME, BUT FOR THE GLOBAL SOLUTION. C C INDL,INDG ARE USED ON RE-ENTRY TO STATS TO TEST IF A C FAILURE OF THE TRUE SOLUTIONS OCCURRED ON A PREVIOUS STEP C AND SHOULD THUS BE LEFT ALONE BETWEEN STEPS. C--------+---------+---------+---------+---------+---------+---------+-- C C ACTION OF THE ROUTINE: C CALL IVALU TO SET INTEGRATION PARAMETERS. C COPY N,ID,IWT INTO /NSCOM5/ FOR USE BY FCN. C SET IFLAG = 1 AND CALL STATS TO INITIALIZE ITS COMMON AREAS. C (THE ARGUMENTS FOR THIS CALL ARE DUMMIES.) C SET X,Y,NSTP,NFCN FOR USE IN STATS. SET IFLAG = 2 SO THAT C THE CALL TO METHOD WILL SET THE FIRST STEP SIZE (HSTART) C AND RETURN. C SET NSTART = NO. OF FCN CALLS NEEDED BY METHOD TO START. C--------+---------+---------+---------+---------+---------+---------+-- C CALL IVALU(N,XSTART,XEND,HINIT,HMAX,YSTART,FCNTIM,WT,IWT,ID) C N1 = N ID1 = ID IWT1 = IWT X = XSTART DO 20 I = 1, N Y(I) = YSTART(I) 20 CONTINUE C IFLAG = 1 CALL STATS(X,Y,DUMMY,Y) C NFCN1 = 0 NSTP = 0 IFLAG = 2 C CALL METHOD(N,X,Y,XEND,ERRTOL,HMAX,HINIT) C NOSTRT = X .LT. XEND NSTART = NFCN1 C--------+---------+---------+---------+---------+---------+---------+-- C INITIALIZE THE COUNTERS ETC. IN /NSCOM3/,/NSCOM6/. C IF METHOD FAILED TO START, SET FLAGS AND EXIT. C SET IFLAG = 3 SO THAT THE CALL TO METHOD WILL DO A COMPLETE C INTEGRATION, COMPILING STATISTICS ON EACH STEP. C START THE CLOCK. C--------+---------+---------+---------+---------+---------+---------+-- NFCN1 = 0 NSTP = 0 NSTL = 0 LEMXSC = 0. NDCV = 0 NBAD = 0 GEMX = 0. TRUTIM = 0. NTRU = 0 C IF (NOSTRT) GO TO 180 C X = XSTART DO 40 I = 1, N Y(I) = YSTART(I) 40 CONTINUE IFLAG = 3 S = CLOCK(0.0) C CALL METHOD(N,X,Y,XEND,ERRTOL,HMAX,HSTART) C TIME = CLOCK(S) OKMETH = X .GE. XEND XFIN = X NFCN = NFCN1 IF ( .NOT. OKMETH) GO TO 160 C--------+---------+---------+---------+---------+---------+---------+-- C IF OPT.GT.1, OR IF OPT = 1 BUT THE TIMING ESTIMATE ALREADY C OBTAINED WAS TOO SMALL TO BE RELIABLE, DO A TIMING COMPUTATION C PROVIDED THAT METHOD REACHED THE ENDPOINT IN THE PREVIOUS CALL. C SET IFLAG = 0, START THE CLOCK, AND CALL C METHOD SUFFICIENTLY MANY TIMES FOR THE SOLUTION TIME TO C BE OBTAINED ACCURATELY. COMPUTE THE OVERHEAD AS THE C TOTAL TIME EXCLUSIVE OF FUNCTION EVALUATIONS C--------+---------+---------+---------+---------+---------+---------+-- TSTTIM = CONST(4) TIMERR = .FALSE. IF (TSTTIM.LE.0) GO TO 120 IF (OPT.EQ.1 .AND. TIME.GE.0.5*TSTTIM) GO TO 120 COUNT = 0 IFLAG = 0 S = CLOCK(0.0) C--------+---------+---------+---------+---------+---------+---------+-- C LOOP TILL 'TSTTIM' TIME UNITS HAVE ELAPSED: C--------+---------+---------+---------+---------+---------+---------+-- 60 CONTINUE X = XSTART DO 80 I = 1, N Y(I) = YSTART(I) 80 CONTINUE CALL METHOD(N,X,Y,XEND,ERRTOL,HMAX,HSTART) TIMERR = X .LT. XEND IF (TIMERR) GO TO 100 TIMCUM = CLOCK(S) COUNT = COUNT + 1 IF (TIMCUM.LT.TSTTIM .AND. COUNT.LT.10) GO TO 60 C 100 IF (COUNT.GE.1) TIME = TIMCUM/FLOAT(COUNT) 120 CONTINUE C--------+---------+---------+---------+---------+---------+---------+-- C WE NOW HAVE A VALUE FOR TIME: THE ONE OBTAINED BEFORE THE C TIMING LOOP IF WE SKIPPED THE LATTER OR IN THE UNLIKELY C EVENT OF AN ERROR IN THE 1ST TIMING ITERATION; OTHERWISE C THE ONE FROM THE TIMING LOOP. C COMPUTE OVERHEAD AND ENDPOINT GLOBAL ERROR. C--------+---------+---------+---------+---------+---------+---------+-- OVHD = TIME - FLOAT(NFCN)*FCNTIM CALL EVALU(YEND,N,WT,IWT,ID) GEND = DIFNRM(YEND,Y,N) C IF (TIMERR) GO TO 200 C C--------+---------+---------+---------+---------+---------+---------+-- C SET THE OUTPUT VALUE OF CMPLET, INDG1 AND INDL1. C--------+---------+---------+---------+---------+---------+---------+-- CMPLET = 1 IF (INDL.LT.0 .OR. INDG.LT.0) CMPLET = 0 140 INDG1 = INDG INDL1 = INDL RETURN C C--------+---------+---------+---------+---------+---------+---------+-- C *********** ERROR EXITS *********** C--------+---------+---------+---------+---------+---------+---------+-- C METHOD FAILED TO REACH XEND C--------+---------+---------+---------+---------+---------+---------+-- 160 CMPLET = -1 IF (INDL.LT.0 .OR. INDG.LT.0) CMPLET = -2 TIME = 1E20 OVHD = 1E20 GEND = 1E20 GO TO 140 C C--------+---------+---------+---------+---------+---------+---------+-- C METHOD FAILED TO START C--------+---------+---------+---------+---------+---------+---------+-- 180 CMPLET = -3 NFCN = 0 TIME = 1E20 OVHD = 1E20 GEND = 1E20 GO TO 140 C--------+---------+---------+---------+---------+---------+---------+-- C INTEGRATION FAILED IN TIMING LOOP C--------+---------+---------+---------+---------+---------+---------+-- 200 CMPLET = -4 GO TO 140 END C C********+*********+*********+*********+*********+*********+*********+** C REAL FUNCTION DIFNRM(A,B,N) C1 C .. Scalar Arguments .. INTEGER N C .. Array Arguments .. DOUBLE PRECISION A(N), B(N) C .. Scalars in Common .. DOUBLE PRECISION ERRTOL INTEGER ID, IOUT, IWT, NRMTYP, OPT, XTRAP C .. Local Scalars .. INTEGER I C .. Intrinsic Functions .. INTRINSIC AMAX1, DABS, REAL, SQRT C .. Common blocks .. COMMON /NSCOM1/ERRTOL, OPT, NRMTYP, XTRAP, ID, IWT, * IOUT C .. Executable Statements .. C C********+*********+*********+*********+*********+*********+*********+** C NORM OF DIFFERENCE BETWEEN TWO DOUBLE PRECISION VECTORS, C SINGLE PRECISION RESULT. C NRMTYP=1,2,3 CHOOSES MAX-NORM, 2-NORM, R.M.S.-NORM. C--------+---------+---------+---------+---------+---------+---------+-- IF (NRMTYP.EQ.1) THEN DIFNRM = 0.0 DO 20 I = 1, N DIFNRM = AMAX1(DIFNRM,REAL(DABS(A(I)-B(I)))) 20 CONTINUE ELSE DIFNRM = 0.0 DO 40 I = 1, N DIFNRM = DIFNRM + REAL(DABS(A(I)-B(I)))**2 40 CONTINUE C IF (NRMTYP.EQ.2) DIFNRM = SQRT(DIFNRM) IF (NRMTYP.EQ.3) DIFNRM = SQRT(DIFNRM/N) END IF RETURN END C C********+*********+*********+*********+*********+*********+*********+** C SUBROUTINE STATS(X,Y,ERRBND,ERREST) C C********+*********+*********+*********+*********+*********+*********+** C STATS 'INSTRUMENTS' THE ODE-SOLVER BEING TESTED, BY COMPUTING C THE DEVIATION OF THE SOLUTION COMPUTED IN ROUTINE METHOD FROM C THE 'TRUE' GLOBAL AND LOCAL SOLUTIONS IF REQUESTED, AND BY C ACCUMULATING VARIOUS ASSOCIATED STATISTICS. IT ALSO PERFORMS C VARIOUS INITIALIZATION DUTIES, DEPENDING ON THE VALUE OF IFLAG C ON ENTRY. C C ON ENTRY C X,Y - MUST HOLD 'SOLVER' SOLUTION AT CURRENT STEP C ERREST- MUST HOLD ESTIMATED LOCAL ERROR VECTOR AT THIS STEP C DEFINED AS (COMPUTED Y) - (TRUE LOCAL SOLUTION AT NEW X). C SINCE ABSOLUTE ERROR-CONTROL IS SPECIFIED, THIS IS THE C VECTOR WHOSE NORM IS MAINTAINED BELOW ERRBND BY 'METHOD'. C IT IS ASSUMED THAT 'METHOD' USES ONE OF THE 3 NORMS C OFFERED BY THE PACKAGE, AND NRMTYP MUST BE SET SUITABLY. C ERRBND- MUST HOLD TOLERANCE BELOW WHICH THE NORM OF ERREST IS C BEING HELD AT THIS STEP. USUALLY SAME AS ERRTOL BUT WILL C BE DIFFERENT AND VARY WITH STEPSIZE IF (EG) A PER-UNIT- C STEP ERROR CRITERION IS USED. C C STORAGE FOR VARIOUS SOLUTIONS: C X,Y - CURRENT SOLUTION COMPUTED BY METHOD, PASSED IN C VIA ARGUMENT LIST. C XOLD,YOLD- VALUES OF X,Y AT AN OLD MESHPOINT OF METHOD, C USUALLY THE LAST ONE BUT OLDER IF A LUMPED C STEP IS BEING FORMED (SEE BELOW). C IF IFLAG = 0, NEITHER XOLD NOR YOLD IS USED. C YOLD IS NOT USED UNLESS STATISTICS ON LOCAL ERROR C ARE BEING COMPILED (IFLAG=3 AND OPT=3). C THE 'TRUE' LOCAL SOLUTION IS OBTAINED BY INTEG- C RATING FROM XOLD,YOLD TO THE CURRENT X. C XOLD,YOLD ARE USED AS THE ACTUAL ARGUMENTS IN THIS C INTEGRATION, AND ARE THEN UPDATED TO HOLD X,Y IN C PREPARATION FOR NEXT CALL TO STATS. C XT - LAST MESHPOINT OF METHOD. C XOLDG - INDEP VAR FOR 'TRUE' GLOBAL SOLUTION, IN COMMON. C YOLDG - 'TRUE' GLOBAL SOLUTION AT XOLDG, HELD IN COMMON. C UPDATED BY CALLING TRUE AT EACH CALL TO STATS IF C DETAILED STATISTICS ARE BEING COMPILED (IFLAG = 3) C YSTAR - ONLY USED IF OPT.EQ.4. IF SOLVER DOES NOT DO LOCAL C EXTRAPOLATION, WE FORM THE LOCALLY EXTRAPOLATED C SOLUTION IN YSTAR. C--------+---------+---------+---------+---------+---------+---------+-- C C--------+---------+---------+---------+---------+---------+---------+-- C COMMON AREAS C--------+---------+---------+---------+---------+---------+---------+-- C1 C2 C3 C4 C6 C .. Scalar Arguments .. DOUBLE PRECISION ERRBND, X C .. Array Arguments .. DOUBLE PRECISION ERREST(51), Y(51) C .. Scalars in Common .. DOUBLE PRECISION ERLUMP, ERRTOL, HSTART, PRECIS, XEND, XFIN, XOLD, * XOLD1, XOLDG, XT, XTRUE REAL GEMX, GEND, LEMXSC, OVHD, TIME, TRUTIM INTEGER ID, IFLAG, INDG, INDL, IOUT, IWT, N, NBAD, NDCV, * NFCN, NFCN1, NRMTYP, NSTART, NSTL, NSTP, NTRU, * OPT, XTRAP C .. Arrays in Common .. DOUBLE PRECISION CG(24), WG(51,9), YOLD(51), YOLDG(51) C .. Local Scalars .. DOUBLE PRECISION HLUMP, HMIN, YNORM REAL ESTSC, LEERSC, LESC, TRUT0 INTEGER I, NDIM, NNFCN C .. Local Arrays .. DOUBLE PRECISION CL(24), WL(51,9), YSTAR(51), ZERO(51) C .. External Functions .. REAL CLOCK, CONST, DIFNRM EXTERNAL CLOCK, CONST, DIFNRM C .. External Subroutines .. EXTERNAL FCN2, PLOT, TRUE C .. Intrinsic Functions .. INTRINSIC AMAX1, DABS, DMAX1 C .. Common blocks .. COMMON /NSCOM1/ERRTOL, OPT, NRMTYP, XTRAP, ID, IWT, IOUT COMMON /NSCOM2/XEND, HSTART, N, IFLAG, INDL, INDG COMMON /NSCOM3/XFIN, XTRUE, TIME, OVHD, TRUTIM, GEND, * GEMX, LEMXSC, NFCN, NSTP, NSTL, NDCV, NBAD, NTRU, * NSTART COMMON /NSCOM4/XOLD1, XOLD, YOLD, XOLDG, YOLDG, CG, WG, * XT, PRECIS, ERLUMP COMMON /NSCOM6/NFCN1 C .. Data statements .. CE C DATA NDIM/51/, ZERO/51*0.D0/ C .. Executable Statements .. C C--------+---------+---------+---------+---------+---------+---------+-- C IF IFLAG = 0 METHOD IS BEING TIMED. C--------+---------+---------+---------+---------+---------+---------+-- IF (IFLAG.EQ.0) RETURN C C--------+---------+---------+---------+---------+---------+---------+-- C IF IFLAG = 1 INITIALIZE VARIABLES TO DO WITH FINDING FIRST STEP- C SIZE, ASSESSING LUMPED STEPS AND COMPUTING TRUE GLOBAL SOLUTION. C RESET INDL, OTHERWISE A LOCAL FAILURE (INDL<0) ON A PREVIOUS C INTEGRATION WILL BE DEEMED A FAILURE ON THIS ONE. C 1ST 9 ELEMENTS OF CG MUST BE INITIALIZED; WE INITIALIZE C MORE TO AID DIAGNOSTICS. C--------+---------+---------+---------+---------+---------+---------+-- IF (IFLAG.NE.1) GO TO 60 C C FOR EVALUATING PERFORMANCE OF 'TRUE': C CALL TRUCHK(1,IDUM) PRECIS = 1000.D0*CONST(1) ERLUMP = 0.D0 XOLD1 = X XOLD = X XOLDG = X XT = X DO 20 I = 1, N YOLD(I) = Y(I) YOLDG(I) = Y(I) 20 CONTINUE DO 40 I = 1, 24 CG(I) = 0.D0 40 CONTINUE CG(1) = 1.D0 CG(7) = 200.D0 INDG = 2 INDL = 2 RETURN C--------+---------+---------+---------+---------+---------+---------+-- C IF IFLAG = 2 DETERMINE THE INITIAL STEPSIZE FOR C THE INTEGRATION PROPER. WE CHOOSE THE SECOND STEP C TAKEN AND TERMINATE THE INTEGRATION BY SETTING X C EQUAL TO XEND. HSTART THEN HOLDS THE CURRENT STEPSIZE. C--------+---------+---------+---------+---------+---------+---------+-- 60 IF (IFLAG.NE.2) GO TO 80 NSTP = NSTP + 1 HSTART = X - XOLD1 XOLD1 = X IF (NSTP.GE.2) X = XEND RETURN C C C--------+---------+---------+---------+---------+---------+---------+-- C IF IFLAG = 3 COMPILE STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- C C IF THE STEPSIZE AND, HENCE, THE ERROR REQUIREMENT WAS C TOO SMALL TO PERMIT AN EFFECTIVE ASSESSMENT AT THIS C PRECISION, CONTINUE THE INTEGRATION. A LUMPED ERROR C ESTIMATE IS FORMED IN ERLUMP AND SEVERAL SMALL STEPS C ASSESSED AS ONE. C THE TEST FOR THE SIZE OF A LUMPED STEP IS MATCHED TO THE C MINIMUM STEPSIZE TEST IN 'TRUE' AND IS INTENDED TO ENSURE C (VERY CONSERVATIVELY) THAT ROUNDOFF EFFECTS ARE NEGLIGIBLE. C MAX-NORM IS USED IRRESPECTIVE OF THE VALUE OF NRMTYP IN /NSCOM1/. C THE LUMPED LOCAL ERROR IS TAKEN SIMPLY AS THE SUM OF THE C INDIVIDUAL LOCAL ERRORS. C--------+---------+---------+---------+---------+---------+---------+-- 80 CONTINUE NSTP = NSTP + 1 HLUMP = X - XOLD ERLUMP = ERLUMP + ERRBND XT = X YNORM = 0.D0 DO 100 I = 1, N YNORM = DMAX1(YNORM,DABS(YOLDG(I)),DABS(Y(I))) 100 CONTINUE IF (HLUMP*ERRTOL.GE.YNORM*PRECIS) GO TO 120 C WRITE(6,998)XOLD,X,HLUMP,ERREST,ERRBND,NSTL,NSTP C998 FORMAT(1H0,'XOLD X HLUMP ERREST ERRBND NSTL NSTP=', C * 1P5D12.4,2I4) RETURN C C--------+---------+---------+---------+---------+---------+---------+-- C A SUFFICIENTLY LARGE LUMPED STEP HAS BEEN FORMED. C INCREMENT THE LUMPED STEP COUNT. C--------+---------+---------+---------+---------+---------+---------+-- 120 CONTINUE NSTL = NSTL + 1 C--------+---------+---------+---------+---------+---------+---------+-- C GLOBAL ASSESSMENT C SAVE COUNTERS THAT WILL BE AFFECTED BY 'TRUE' CALLS. SET MAX C STEPSIZE FOR GLOBAL SOLUTION TO X-XOLDG (DEFAULT VALUE IN TRUE IS C SIMPLY 2.) C CONTINUE TRUE GLOBAL SOLUTION TO CURRENT MESHPOINT AND C UPDATE MAX GLOBAL ERROR GEMX. C IF FAILURE OCCURS, RECORD POSITION IN XTRUE AND SKIP LOCAL C ASSESSMENT ALSO. C--------+---------+---------+---------+---------+---------+---------+-- IF (OPT.LT.2 .OR. INDG.LT.0) GO TO 240 NNFCN = NFCN1 HMIN = 10.D0*DMAX1(1.D-30,CONST(1)*DABS(X)) CG(3) = HMIN CG(6) = 1.1D0*(X-XOLDG) TRUT0 = CLOCK(0.) C CALL TRUE(N,FCN2,XOLDG,YOLDG,X,1.D-2*ERRTOL,INDG,CG,NDIM,WG) C TRUTIM = TRUTIM + CLOCK(TRUT0) CG(7) = CG(24) + 200.D0 IF (INDG.GE.0) GO TO 140 XTRUE = XOLDG C WRITE(6,999)CG C999 FORMAT(1H0,'TRUE FAILURE, C ='/ C * (1H0,1P10D12.4)) GO TO 220 140 GEMX = AMAX1(GEMX,DIFNRM(Y,YOLDG,N)) C--------+---------+---------+---------+---------+---------+---------+-- C LOCAL ASSESSMENT C OBTAIN THE LOCAL SOLUTION THROUGH THE PREVIOUS COMPUTED C MESH VALUE TO HIGHER ACCURACY THAN METHOD, PROVIDED NO C FAILURES HAVE OCCURRED IN PREVIOUS CALLS TO TRUE (INDL.GE.0). C THE STARTING STEP FOR TRUE IS TAKEN AS .8 * THE LAST RECOMM- C ENDED STEPSIZE OF THE GLOBAL SOLUTION. C CHECK FOR A FAILURE THIS TIME AFTER THE C CALL TO TRUE. COMPILE THE RELIABILITY STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- IF (OPT.LT.3 .OR. INDL.LT.0) GO TO 220 DO 160 I = 1, 9 CL(I) = 0.D0 160 CONTINUE INDL = 2 CL(1) = 1.D0 CL(3) = HMIN CL(4) = 0.8D0*CG(14) CL(6) = 1.1D0*(X-XOLD) CL(7) = 200.D0 TRUT0 = CLOCK(0.) C CALL TRUE(N,FCN2,XOLD,YOLD,X,1.D-2*ERLUMP,INDL,CL,NDIM,WL) C TRUTIM = TRUTIM + CLOCK(TRUT0) XTRUE = XOLD C IF(INDL.LT.0)WRITE(6,999)CL IF (INDL.LT.0) GO TO 220 C--------+---------+---------+---------+---------+---------+---------+-- C UPDATE STATISTICS C LESC RECORDS THE RATIO OF THE MAGNITUDE OF THE TRUE C LOCAL ERROR TO THE ASSUMED LOCAL ERROR BOUND. C LEMXSC RECORDS ITS MAXIMUM OVER THE RANGE. C NTRU COUNTS THE NO. OF LUMPED STEPS OF METHOD ON WHICH C LOCAL ASSESSMENT SUCCEEDED, SO AS TO ALLOW SUMMARY OF PARTIAL C RESULTS IF TRUE FAILS AT SOME POINT. C C IF OPT=4, DO THE ANALYSIS OF THE LOCAL ERROR ESTIMATE VECTOR, C ERREST, BY FORMING THE SCALED ||ERROR|| IN ERREST. IF LOCAL C EXTRAPOLATION IS DONE THIS IS LESC=||ERREST||/ERLUMP. IF NOT, C FORM YSTAR=LOCALLY EXTRAPOLATED SOLUTION AND IT IS THEN C ||YSTAR-YOLD||/ERLUMP. FORM A POINT ON THE SCATTER DIAGRAM C OF ERROR IN ERREST (VERT AXIS) VS. ERREST (HORIZ AXIS) C AND ENTER IT BY A CALL TO 'PLOT'. C--------+---------+---------+---------+---------+---------+---------+-- C C FOR EVALUATING PERFORMANCE OF 'TRUE': C CALL TRUCHK(3,INFL) LESC = DIFNRM(Y,YOLD,N)/ERLUMP LEMXSC = AMAX1(LEMXSC,LESC) IF (LESC.GT.1.0) NDCV = NDCV + 1 IF (LESC.GT.5.0) NBAD = NBAD + 1 IF (OPT.EQ.4) THEN C XTRAP=1 OR 0 ACCORDING AS THE USER HAS TOLD THE PACKAGE THAT C LOCAL EXTRAPOLATION IS OR IS NOT BEING DONE BY SOLVER: IF (XTRAP.EQ.0) THEN DO 180 I = 1, N YSTAR(I) = Y(I) - ERREST(I) 180 CONTINUE LEERSC = DIFNRM(YSTAR,YOLD,N)/ERLUMP ELSE LEERSC = LESC END IF ESTSC = DIFNRM(ERREST,ZERO,N)/ERLUMP CALL PLOT(ESTSC,LEERSC,1) C WRITE(IOUT,'('' STEP NO'',I4,'', X = '',F14.10, C 1 '', BOUND IE. ERLUMP = '',1PE10.3)') NSTP,X,ERLUMP C WRITE(IOUT,'('' I TRUE LE EST LE '', C 1 ''LE IN UNEXTRAP'')') C DO 95 I=1,N C95 WRITE(IOUT,'(1X,I3,3F14.10)') I,Y(I)-YOLD(I),ERREST(I) C * ,LERR(I) END IF C NTRU = NTRU + 1 C--------+---------+---------+---------+---------+---------+---------+-- C UPDATE MEMORY OF LAST COMPUTED VALUES. C--------+---------+---------+---------+---------+---------+---------+-- DO 200 I = 1, N YOLD(I) = Y(I) 200 CONTINUE C--------+---------+---------+---------+---------+---------+---------+-- C RESTORE THE COUNTS AFFECTED BY 'TRUE' CALLS. C--------+---------+---------+---------+---------+---------+---------+-- 220 NFCN1 = NNFCN C--------+---------+---------+---------+---------+---------+---------+-- C RE-INITIALIZE THE DATA PERTAINING TO A LUMPED STEP. C--------+---------+---------+---------+---------+---------+---------+-- 240 ERLUMP = 0.D0 XOLD = X C--------+---------+---------+---------+---------+---------+---------+-- C RETURN TO METHOD TO CONTINUE THE INTEGRATION. C--------+---------+---------+---------+---------+---------+---------+-- RETURN END SUBROUTINE PLOT(X,Y,IFLAG) C ROUTINE TO FORM PLOTS OF LOCAL ERROR INFORMATION FOR DETEST, USING C AN ARRAY K WHICH IS IN 'SAVE' STORAGE. C C IF IFLAG<=0, IT RESETS ARRAY K TO ZERO. C C IF IFLAG=1, THE ROUTINE ENTERS (X,Y) ON THE SCATTER-DIAGRAM C REPRESENTED BY K. HERE X,Y ARE >= 0, AND THE RANGE 0 TO INFINITY IS C SPLIT INTO CLASS-INTERVALS NUMBERED I = NLO .. NHI, THE I-TH INTERVAL C BEING 2**(I-1) <= X < 2**I EXCEPT THAT THE NLO-TH ONE INCLUDES ALL C X BELOW 2**NLO AND THE NHI-TH INCLUDES ALL X >=2**(NHI-1). C C IF IFLAG=2, THE SCATTER DIAGRAM IS PRINTED OUT. C C NOTE: IF IMPLEMENTER WISHES TO ALTER NLO, NHI THEN THE DATA C STATEMENTS MUST BE ALTERED CORRESPONDINGLY. C CERR CHARACTER STR3*3, LINE*LINLEN, LINE1*LINLEN, LINE2*LINLEN, CERR * LINE3*LINLEN, LINE4*LINLEN C .. Parameters .. INTEGER NLO, NHI REAL ALOG2 INTEGER NMIN, LINLEN REAL XYMIN PARAMETER (NLO=-7,NHI=4,ALOG2=.69314718,NMIN=NLO-1, * LINLEN=3*(NHI-NLO+1)+1,XYMIN=2.**NMIN) C .. Scalar Arguments .. REAL X, Y INTEGER IFLAG C .. Local Scalars .. REAL C, P, T INTEGER I, IOUT, J, JL, KMAX, KTOT CHARACTER*(LINLEN) LINE CHARACTER*(LINLEN) LINE1 CHARACTER*(LINLEN) LINE2 CHARACTER*(LINLEN) LINE3 CHARACTER*(LINLEN) LINE4 C .. Local Arrays .. INTEGER K(NLO:NHI,NLO:NHI) C .. External Functions .. REAL CONST CHARACTER*3 STR3 EXTERNAL CONST, STR3 C .. Intrinsic Functions .. INTRINSIC ALOG, MAX, MIN, NINT C .. Statement Functions .. INTEGER ICLAS, ICLAS0 C .. Save statement .. SAVE K, KTOT, KMAX, IOUT C .. Data statements .. DATA LINE1/'+--+--+--+--+--+--+--+--+--+--+--+--+'/, * LINE2/'+ +'/, * LINE3/'| |'/, * LINE4/' 2 2 2 2 2 2 2 2 2 2 2 '/ C .. Executable Statements .. C C C .. Statement Function definitions .. ICLAS0(T) = NMIN + NINT(ALOG(MAX(1.,T/XYMIN))/ALOG2) ICLAS(T) = MIN(MAX(ICLAS0(T),NLO),NHI) IF (IFLAG.LE.0) THEN IOUT = CONST(3) KTOT = 0 KMAX = 0 DO 40 I = NLO, NHI DO 20 J = NLO, NHI K(I,J) = 0 20 CONTINUE 40 CONTINUE ELSE IF (IFLAG.EQ.1) THEN IF (X.LT.0. .OR. Y.LT.0.) THEN WRITE (IOUT,FMT=*) * ' ERROR IN ARGUMENTS TO DETEST PLOT ROUTINE', X, Y STOP END IF I = ICLAS(X) J = ICLAS(Y) K(I,J) = K(I,J) + 1 KTOT = KTOT + 1 KMAX = MAX(KMAX,K(I,J)) ELSE C = KTOT DO 80 I = NHI, NLO, -1 LINE = LINE3 DO 60 J = NLO, NHI JL = J - NLO CERR8 LINE(3*JL+1:3*JL+3) = STR3(K(J,I)/C) P = K(J,I)/C LINE(3*JL+1:3*JL+3) = STR3(P) 60 CONTINUE IF (LINE(1:1).EQ.' ') LINE(1:1) = '|' IF (I.EQ.NHI) THEN WRITE (IOUT,FMT='(1X,15X,''INFINITY '',A)') LINE1 WRITE (IOUT,FMT='(1X,20X,'' '',A)') LINE ELSE WRITE (IOUT,FMT='(1X,15X,I8,1X,A)') I, LINE2 WRITE (IOUT,FMT='(1X,20X,''2 '',A)') LINE END IF 80 CONTINUE WRITE (IOUT,FMT='(1X,24X,A)') LINE1 WRITE (IOUT,FMT='(/1X,25X,30I3)') (J,J=NLO,NHI-1) WRITE (IOUT,FMT='(1X,24X,A)') LINE4 END IF RETURN END CHARACTER*3 FUNCTION STR3(P) C CONVERTS P (MEANT TO BE IN RANGE 0 TO 1) TO A 3 CHARACTER C INTEGER PERCENTAGE. P=0 BECOMES ' ', 0-+ C | +------+ | BEING | | C | | | TESTED)| | C | | +--------+ |---FCN C | | | C | STATS---TRUE--->--+ C | C +----EVALU C C WE ACKNOWLEDGE VALUABLE RECOMMENDATIONS IN SHAMPINE'S PAPER [5]. IN C PARTICULAR THE PACKAGE WILL, BY DEFAULT, INTEGRATE EACH SYSTEM IN C SCALED FORM, SCALING EACH SOLUTION COMPONENT BY ITS MAXIMUM OBSERVED C VALUE OVER THE RANGE OF INTEGRATION. THAT IS, THE CHANGE OF VARIABLE C -1 C Z = D Y IS DONE WHERE C D = DIAG(W(1), .., W(N)) C C AND W(I) =MAX |I-TH COMPONENT OF Y| OVER THE RANGE. THE PROBLEM C -1 C SOLVED IS THEN Z' = D F(X,DZ). THE WEIGHTS W(I) WERE FOUND BY AN C ACCURATE INTEGRATION OF EACH PROBLEM AND ARE EMBEDDED IN IVALU. C NOTE THAT THIS SCALING AFFECTS THE NORMS WHICH ARE USED IN C MEASURING ALL ERRORS, AND THUS CAN HAVE A CONSIDERABLE EFFECT ON THE C ACCURACY IN SOME OF THE PROBLEMS. C C IF THE PROBLEM CODE IN IDLIST (SEE BELOW) IS GIVEN A NEGATIVE SIGN THE C SYSTEM IS SOLVED IN ITS 'NATURAL' SCALING, AS WAS DONE IN THE 1975 C VERSION OF DETEST. C C C REFERENCES C ----------- C C [1] W H ENRIGHT, 'USING A TESTING PACKAGE FOR THE AUTOMATIC C ASSESSMENT OF NUMERICAL METHODS FOR ODES', IN PERFORMANCE C EVALUATION OF NUMERICAL SOFTWARE, (FOSDICK, ED), IFIP, NORTH C HOLLAND PUBL CO (1979) 199-213. C C [2] T E HULL, W H ENRIGHT, B M FELLEN AND A E SEDGWICK, 'COMPARING C NUMERICAL METHODS FOR ORDINARY DIFFERENTIAL EQUATIONS', SIAM J. C NUMER. ANAL. 9(1972)603-637. C C [3] W H ENRIGHT AND J D PRYCE, 'A PAIR OF PACKAGES FOR ASSESSING C INITIAL VALUE METHODS', UNIVERSITY OF TORONTO TECHNICAL REPORT C NO. 167/83. C C [4] W H ENRIGHT AND T E HULL, 'TEST RESULTS ON INITIAL VALUE METHODS C FOR NONSTIFF ORDINARY DIFFERENTIAL EQUATIONS', SIAM J. NUMER. C ANAL. 13(1976)944-961. C C [5] L F SHAMPINE 'EVALUATION OF A TEST SET FOR STIFF ODE SOLVERS', C TOMS 7(1981)409-420. C C C C C C C C C 2. ARGUMENTS TO NSDTST: C --------- -- ------- C C TITLE (INPUT) CHARACTER OF LENGTH 80, HOLDS NAME OF METHOD BEING C TESTED. C C OPTION (INPUT) INTEGER ARRAY OF LENGTH 10, ONLY ELEMENTS 1 TO 3 ARE C USED AND ARE REFERRED TO HENCEFORTH AS OPT, NORMEF AND NRMTYP. C (OPTION(4) IS ALSO USED WHEN OPT=4) C C OPT ONE OF 1, 2, 3 OR 4. OPT SELECTS LEVEL OF ANALYSIS REQUIRED: C 1 GIVES A REPORT OF THE FOLLOWING AT EACH TOLERANCE USED: C - TOTAL TIME PER INTEGRATION C - OVERHEAD TIME EXCLUDING FUNCTION CALLS. C - NUMBER OF FUNCTION CALLS AND SUCCESSFUL STEPS OVER RANGE. C - GLOBAL ERROR AT ENDPOINT XEND, DIVIDED BY TOL, IE. C ||(COMPUTED Y) - (TRUE Y)||/TOL AT X=XEND C THE NORM USED THROUGHOUT THE PACKAGE IS THAT CHOSEN BY NRMTYP. C C 2 REPORTS (IN ADDITION TO THE ABOVE STATISTICS): C - MAXIMUM GLOBAL ERROR OVER RANGE. THE 'TRUE' SOLUTION OVER C THE RANGE IS OBTAINED BY A RELIABLE INTEGRATOR AT A MORE C STRINGENT TOLERANCE. C C 3 REPORTS (IN ADDITION TO THE ABOVE): C - MAXIMUM LOCAL ERROR OVER RANGE, IE. MAX OVER ALL MESHPOINTS C OF C LENRM = ||(COMPUTED Y) - YLOC||/ERRBND C WHERE YLOC IS THE TRUE LOCAL SOLUTION THROUGH THE PREVIOUS C MESHPOINT, AND ERRBND, THE ASSUMED ERROR BOUND, IS EXPLAINED C BELOW. C - FRACTION OF STEPS WHERE LENRM EXCEEDED 1. C - FRACTION OF STEPS WHERE LENRM EXCEEDED 5. C C 4 REPORTS (IN ADDITION TO THE ABOVE): C - AN ANALYSIS OF THE LOCAL ERROR ESTIMATES USED BY SOLVER AS THE C BASIS FOR ITS ERROR CONTROL. AT THIS LEVEL THREE ASSUMPTIONS C ARE MADE. FIRST, THAT AT EACH STEP SOLVER FORMS TWO C APPROXIMATIONS, Y AND Y*, TO THE LOCAL SOLUTION YLOC AT THE C NEW MESHPOINT, SUCH THAT ASYMPTOTICALLY AS TOL->0, Y* IS 'MORE C ACCURATE' THAN Y. SECOND, THAT THE APPROXIMATION WHICH IS C TAKEN AS THE COMPUTED SOLUTION AT THE NEW MESHPOINT IS EITHER C ALWAYS Y* (IN WHICH CASE ONE SAYS LOCAL EXTRAPOLATION IS USED) C OR ALWAYS Y (IN WHICH CASE IT IS NOT USED). THE VECTOR C LE = Y - YLOC C IS THE TRUE LOCAL ERROR IN THE 'LESS ACCURATE' SOLUTION Y, C AND C ERREST = Y - Y* C IS AN ESTIMATE OF LE. IT IS ASSUMED FINALLY THAT THE ERROR C CONTROL CONSISTS IN KEEPING ||ERREST||, IN AN APPROPRIATE C NORM, BELOW ERRBND AT EACH STEP. C C NOTE THAT SOME METHODS, SUCH AS MERSON'S METHOD, CANNOT BE C REGARDED IN THIS WAY. C C AT THIS LEVEL DETEST ANALYSES HOW ACCURATELY ERREST C APPROXIMATES TO LE, BY FORMING A SCATTER PLOT OF THE VALUES OF C R1 = ||ERREST - LE||/ERRBND (VERTICAL AXIS) AGAINST R2 = C ||ERREST||/ERRBND (HORIZONTAL) AT EACH STEP. NOTE ERREST - C LE = -(Y* - YLOC) = -LE*, SAY, SO THAT LENRM DEFINED ABOVE IS C R1 IF LOCAL EXTRAPOLATION IS BEING DONE. FOR AN 'IDEAL' ERROR C CONTROL STRATEGY, WE EXPECT THE PLOTTED POINTS TO CLUSTER NEAR C (1,0) ON THE GRAPH, WHETHER OR NOT LOCAL EXTRAPOLATION IS C USED. C C TO USE THIS LEVEL OF ANALYSIS THE USER MUST: C A) ENSURE THAT THE STATS CALL IN METHOD DELIVERS ERREST AS C DEFINED ABOVE (WITH THE CORRECT SIGN!). C B) SET OPTION(4) AS FOLLOWS. C =0 ARGUMENT Y TO STATS IS Y ABOVE (NO LOCAL EXTRAPOLATION). C =1 Y IS Y* ABOVE (LOCAL EXTRAPOLATION). C C FOR EACH INTEGRATION, A SCATTER PLOT IS PRODUCED. EACH OF THE C RATIOS R1, R2 IS PUT INTO ONE OF 12 CLASS-INTERVALS C -7 -7 -6 2 3 3 C 0<=R<2 , 2 <=R<2 , ..., 2 <=R<2 , 2 <=R= 2, AND HAVE A POSSIBLY MORE EFFICIENT C CODE TO PUT IN ITS PLACE. NSTL IS RELEVANT IF YOU ARE C INTERESTED IN THE ALGORITHMS USED BY THE PACKAGE, SPECIFICALLY THE C STEP-LUMPING PROCESS WHICH TAKES PLACE IN STATS AT STRINGENT C TOLERANCES. C C C C C 8. SUBROUTINES IN THE PACKAGE C ----------- -- --- ------- C C IN ORDER OF APPEARANCE IN THE FILES. THE LIST ALSO SHOWS, FOR EACH C ROUTINE, THE OTHER PACKAGE ROUTINES AND COMMON AREAS WHICH IT USES. A C NAME IN PARENTHESES, LIKE (FCN) DENOTES A ROUTINE WHICH IS CALLED AT C ONE REMOVE (EG. METHOD CALLS SOLVER WHICH MUST CALL FCN) OR WHICH IS C PASSED AS AN ARGUMENT RATHER THAN BEING AN EXTERNAL REFERENCE (EG. C FCN IN TRUE). C C IN CONCLK FILE C CONST CALLS: NONE C CLOCK CALLS: NONE C C IN NSDTST FILE C NSDTST CALLS: PARCHK LSQFIT RATIO EFSTAT CNTROL CONST ; NSCOM1 C NSCOM3 C PARCHK CALLS: NONE C LSQFIT CALLS: NONE C RATIO CALLS: NONE C EFSTAT CALLS: NONE C CNTROL CALLS: DIFNRM STATS CONST CLOCK IVALU EVALU METHOD PLOT ; C NSCOM1 NSCOM2 NSCOM3 NSCOM5 NSCOM6 C DIFNRM CALLS: NONE C STATS CALLS: DIFNRM CONST TRUE FCN PLOT ; NSCOM1 NSCOM2 NSCOM3 C NSCOM4 NSCOM6 C PLOT CALLS: NONE C C IN NSTRUE FILE C TRUE CALLS: CONST (FCN2 ) C FCN2 CALLS: FCN C C IN NSPROB FILE C IVALU CALLS: NONE C EVALU CALLS: NONE C FCN CALLS: ; NSCOM5 NSCOM6 C C USER-SUPPLIED C METHOD CALLS: STATS (FCN ) C C C 9. DEFINITION OF COMMON AREAS AND DICTIONARY OF DATA-FLOW C ---------- -- ------ ----- --- ---------- -- --------- C C THE FLOW OF INFORMATION BETWEEN THOSE ROUTINES WHICH USE COMMON IS C INDICATED FOR EACH VARIABLE BY THE CODES C S: THE VARIABLE IS ASSIGNED A VALUE (SET) IN THIS ROUTINE, POSSIBLY C BY A CALL TO ANOTHER ROUTINE TO WHICH THE VARIABLE IS PASSED AS C AN ARGUMENT. C A: THE VALUE IS USED (ACCESSED) IN THIS ROUTINE. C C FOR COUNTERS AND SIMILAR VARIABLES, THESE CODES ARE USED INSTEAD OF C CODE S: C I: THE VARIABLE IS INITIALIZED IN THIS ROUTINE. C U: THE VARIABLE IS UPDATED IN THIS ROUTINE. C C C COMMON /NSCOM1/ PASSES INFORMATION FROM NSDTST TO CNTROL AND STATS. C C NSDTST C | CNTROL C | | STATS C | | | DIFNRM C | | | | C S A A - ERRTOL DOUBLE. COPY OF CURRENT ERROR TOLERANCE. C S A A - OPT INTEGER. COPY OF OPTION(1) ARGUMENT OF NSDTST. C S - - A NRMTYP INTEGER. COPY OF OPTION(3) ARGUMENT OF NSDTST. C S - A - XTRAP INTEGER. COPY OF OPTION(4) ARGUMENT OF NSDTST. C S A - - ID INTEGER. INTERNAL CODE OF CURRENT PROBLEM, 1 FOR A1, C ..., 13 FOR B3, ETC. C S A - - IWT INTEGER. FLAG FOR SCALING (+1: SCALED. -1: C UNSCALED) C S - - - IOUT INTEGER. STANDARD OUTPUT UNIT NUMBER. C C C C C COMMON /NSCOM2/ COMMUNICATES BETWEEN CNTROL AND STATS. C C CNTROL C | STATS C | | C S A XEND DOUBLE. END OF INTEGRATION RANGE OF CURRENT PROBLEM. C A S HSTART DOUBLE. INITIAL STEPSIZE PASSED TO METHOD FOR C INTEGRATION PROPER. C S A N INTEGER. NO. OF EQUATIONS IN CURRENT PROBLEM. C S A IFLAG INTEGER. SET BY CNTROL TO INFORM STATS WHAT IT IS TO C DO: C =0 METHOD IS BEING TIMED. C =1 INITIALIZING CALL OF STATS FROM CNTROL TO SET UP C NSCOM4. C =2 PRELIMINARY INTEGRATION TO DETERMINE HSTART, ABORTED C AFTER 2 STEPS. C =3 INTEGRATION PROPER, COMPILING STATISTICS. C C C A SA INDL,INDG C ERROR FLAGS FOR THE LOCAL AND GLOBAL 'TRUE SOLUTIONS' C OBTAINED BY CALLS TO ROUTINE TRUE. C C C C C C COMMON /NSCOM3/ OUTPUTS STATISTICS FROM CNTROL AND STATS. C C NSDTST C | CNTROL C | | STATS C | | | C A S - XFIN DOUBLE. POINT OF FAILURE OF METHOD IF IT DOESN'T REACH C XEND. C A - S XTRUE DOUBLE. POINT OF FAILURE OF TRUE IF ANY. IF BOTH C LOCAL AND GLOBAL FAIL, POINT OF GLOBAL FAILURE IS C RETURNED. C A S - TIME REAL. CPU TIME FOR ONE INTEGRATION AS MEASURED BY C CLOCK FUNCTION. C A S - OVHD REAL. EQUALS TIME LESS ESTIMATED COST OF FCN CALLS. C A I U TRUTIM REAL. THE TIME SPENT IN CALLS TO TRUE. NOT RELEVANT C TO PERFORMANCE OF METHOD BUT MEASURES THE OVERHEAD C INCURRED BY THE TESTING PACKAGE WHEN OPT = 2, 3 OR 4. C NOT PRINTED BUT AVAILABLE. C A S - GEND REAL. NORM OF GLOBAL ERROR OF METHOD AT XEND. C C C A I U GEMX REAL. MAXIMUM OF GLOBAL ERROR OVER ALL LUMPED STEP C MESHPOINTS, IE. USUALLY OVER ALL MESHPOINTS OF METHOD, C EXCEPT WHEN ERRTOL IS VERY SMALL. C A I U LEMXSC REAL. MAXIMUM LOCAL ERROR IN UNITS OF ERRBND, OVER ALL C LUMPED STEP MESHPOINTS. C A S - NFCN INTEGER. COPY OF NFCN1, SEE /NSCOM6/. C /NSCOM6/ C A I U NSTP INTEGER. COUNTS (UNLUMPED) STEPS TAKEN BY METHOD IN C CURRENT INTEGRATION. C - I U NSTL INTEGER. COUNTS LUMPED STEPS FORMED IN CURRENT C INTEGRATION (SEE STATS). NOT PRINTED BUT AVAILABLE. C A I U NDCV,NBAD C INTEGER. COUNT LUMPED STEPS ON WHICH SOLVER'S LOCAL C ERROR CONTROL WAS DECEIVED, RESP. BADLY DECEIVED. C A I U NTRU INTEGER. COUNTS LUMPED STEPS ON WHICH TRUE LOCAL C SOLUTION WAS SUCCESSFULLY COMPUTED, HENCE VALID LOCAL C ERROR STATISTICS OBTAINED. USED IN COMPUTING 'FRACTION C DECEIVED' INFORMATION. REPORTED IF DIFFERENT FROM C NSTP. NOTE NTRU <= NSTL <= NSTP. C - S - NSTART INTEGER. NO. OF FCN CALLS NEEDED BY METHOD TO START, C IE. TO DO PRELIMINARY INTEGRATION (2 STEPS). NOT C PRINTED OUT BUT AVAILABLE. C C C COMMON /NSCOM4/ IS USED ONLY BY STATS, TO PRESERVE INFORMATION FROM C ONE CALL OF STATS TO ANOTHER. ALL VARIABLES ARE SET AND/OR UPDATED IN C STATS. C C XOLD1 DOUBLE. SIMILAR TO XOLD BUT USED IN PRELIMINARY C INTEGRATION. C XOLD,YOLD C DOUBLE AND DOUBLE ARRAY. COPY OF METHOD'S COMPUTED C SOLUTION AT END OF PREVIOUS LUMPED STEP. USED AS C ACTUAL ARGUMENTS OF TRUE LOCAL SOLUTION CALL. C XOLDG,YOLDG C DOUBLE AND DOUBLE ARRAY. HOLD 'TRUE' GLOBAL SOLUTION C UPDATED TO END OF PREVIOUS LUMPED STEP. USED AS ACTUAL C ARGUMENTS OF TRUE GLOBAL SOLUTION CALL. C CG,PDG,WKG,WG,YPG,INFG C WORKSPACE FOR 'TRUE' GLOBAL SOLUTION. C XT DOUBLE. HOLDS LAST METHOD MESHPOINT BETWEEN CALLS TO C STATS. C PRECIS DOUBLE. HOLDS 1000 * (UNIT ROUNDOFF) APPROX. C ERLUMP DOUBLE. ACCUMULATES METHOD'S LOCAL ERROR ESTIMATES TO C FORM AN ESTIMATE OVER A LUMPED STEP. C C C COMMON /NSCOM5/ PASSES INFORMATION BETWEEN CNTROL AND FCN, (OR ANY C REPLACEMENT A USER MAY PROVIDE FOR FCN). C C CNTROL C | FCN C | | C C S A WT DOUBLE. ARRAY OF WEIGHTS USED TO IMPLEMENT THE C 'SCALED' INTEGRATION OPTION. C S A IWT1,N1,ID1 C INTEGER. COPIES OF IWT,N,ID IN /NSCOM1/ OR /NSCOM2/. C C C COMMON /NSCOM6/ HOLDS A COUNTER. IT IS INITIALIZED IN CNTROL, C SAVED-AND-RESTORED IN STATS, AND EVENTUALLY COPIED BY CNTROL TO THE C CORRESPONDING VARIABLE IN /NSCOM3/. C C CNTROL C | STATS C | | FCN C | | | C C IA AS U - - NFCN1 INTEGER. COUNTS CALLS TO FCN. C C C THERE IS ALSO A COMMON/NSCOM7/ USED BY THE DUMMY (DEBUGGING) VERSIONS C OF NSDTST AND STATS FOR COMMUNICATION. C C--------+---------+---------+---------+---------+---------+---------+-- C E N D O F G E N E R A L D O C U M E N T A T I O N C********+*********+*********+*********+*********+*********+*********+** C C DESCRIPTION OF NSDTST C ----------- -- ------ C C ROUTINE NSDTST INTERPRETS THE LIST OF TOLERANCES AND LIST OF C GROUPS OF PROBLEMS SPECIFIED IN THE ARGUMENTS. USING CNTROL C TO GATHER INDIVIDUAL STATISTICS FOR ONE PROBLEM AT ONE C TOLERANCE, IT ORGANIZES THE FORMATION AND OUTPUT OF SUMMARY C STATISTICS. C INDIVIDUAL STATISTICS ARE INDEXED OVER TOLERANCES, PROBLEMS C AND GROUPS. C 'PROBLEMS-SUMMARY' MEANS SUM OF THESE OVER PROBLEMS IN A GROUP. C 'GROUPS-SUMMARY' MEANS SUM OF PROBLEMS-SUMMARY OVER ALL GROUPS. C 'OVERALL-SUMMARY' MEANS SUM OF GROUPS-SUMMARIES OVER ALL C TOLERANCES. C (READ 'MAX' FOR 'SUM' IN CASE OF SOME OF THE STATISTICS.) C C LOCAL VARIABLES C PSNFCN,PSNSTP,... HOLD THE SUMMARY OVER PROBLEMS IN A GROUP C OF NFCN,NSTP,... (SEE DESCRIPTION OF /NSCOM3/) AT ALL THE C TOLERANCES USED. C GSNFCN,... HOLD SUMMARY OVER GROUPS OF PSNFCN,... C OSNFCN,... HOLD OVERALL SUMMARY (OVER TOLERANCES) OF GSNFCN,... C C LGTOL HOLDS LOGARITHMS TO BASE 10 OF ELEMENTS OF ARRAY TOL, C AND LGGEMX,LGGEND HOLD LOGARITHMS OF CORRESPONDING GEMX C AND GEND VALUES, USED IN SMOOTHNESS CALCULATIONS. C NSNFCN,... STORE NFCN,... FOR ONE PROBLEM AT ALL TOLERANCES C USED, FOR USE IN NORMALIZED EFFICIENCY CALCULATIONS. C ERFLGE,ERFLG1 FLAG 'MISSING VALUES' IN SMOOTHNESS AND NORMALIZED C EFFICIENCY CALCULATIONS. C C C--------+---------+---------+---------+---------+---------+---------+-- C COMMON AREAS C--------+---------+---------+---------+---------+---------+---------+-- C1 C3 C .. Scalar Arguments .. REAL FLAG CHARACTER*80 TITLE C .. Array Arguments .. REAL TOL(11) INTEGER IDLIST(60), OPTION(10) C .. Scalars in Common .. REAL ERRTOL, XFIN, XTRUE REAL GEMX, GEND, LEMXSC, OVHD, TIME, TRUTIM INTEGER ID, IOUT, IWT, NBAD, NDCV, NFCN, NRMTYP, NSTART, * NSTL, NSTP, NTRU, OPT, XTRAP C .. Local Scalars .. REAL BIG, C, C1, CTEN, CTEN1, DUM, E, E1, FBADEC, * FDECEV, GEMXSC, GENDSC, OSLEMX, OSOVHD, OSTIME, * RES, RES1, TOLK INTEGER CMPLET, I, ICH, IDSUB, IID, INDG1, INDL1, * KCLASS, KGRP, KSYST, KTOL, NGRP, NOK, NOK1, * NORMEF, NSYST, NTOL, OSNBAD, OSNDCV, OSNFCN, * OSNSTP, OSNTRU CHARACTER BL CHARACTER*10 IDCLAS CHARACTER*32 MCNAME C .. Local Arrays .. REAL GSLEMX(10), GSOVHD(10), GSTIME(10), LGGEMX(10), * LGGEND(10), LGTOL(10), NSOVHD(10), NSTIME(10), * PSGEMX(10), PSGEND(10), PSLEMX(10), PSOVHD(10), * PSTIME(10) INTEGER GRPLST(2,6), GSNBAD(10), GSNDCV(10), GSNFCN(10), * GSNSTP(10), GSNTRU(10), NSNFCN(10), NSNSTP(10), * PSNBAD(10), PSNDCV(10), PSNFCN(10), PSNSTP(10), * PSNTRU(10) LOGICAL ERFLG1(10), ERFLGE(10) C .. External Functions .. REAL CONST, RATIO EXTERNAL CONST, RATIO C .. External Subroutines .. EXTERNAL CNTROL, EFSTAT, LSQFIT, PARCHK, PLOT C .. Intrinsic Functions .. INTRINSIC ALOG10, AMAX1, CHAR, REAL, IABS, ISIGN C .. Common blocks .. COMMON /NSCOM1/ERRTOL, OPT, NRMTYP, XTRAP, ID, IWT, * IOUT COMMON /NSCOM3/XFIN, XTRUE, TIME, OVHD, TRUTIM, GEND, * GEMX, LEMXSC, NFCN, NSTP, NSTL, NDCV, NBAD, * NTRU, NSTART C .. Data statements .. CE C DATA IDCLAS/'ABCDEFGHIJ'/, BL/' '/, BIG/1.E20/ C .. Executable Statements .. C C--------+---------+---------+---------+---------+---------+---------+-- C COPY THE ENTRIES IN ARRAY 'OPTION'. C DO DUMMY CALL TO CONST TO INVOKE MACHINE-DEPENDENT INITIALIZ- C ATIONS. SET MACHINE NAME. SET OUTPUT UNIT NUMBER. C WRITE OUTPUT-HEADING. CALL ARGUMENT-CHECKING ROUTINE. C--------+---------+---------+---------+---------+---------+---------+-- OPT = OPTION(1) NORMEF = OPTION(2) NRMTYP = OPTION(3) XTRAP = OPTION(4) DUM = CONST(0) DO 20 I = 1, 32 ICH = CONST(-I) MCNAME(I:I) = CHAR(ICH) 20 CONTINUE IOUT = CONST(3) C WRITE (IOUT,FMT=99999) OPT, NORMEF, NRMTYP, MCNAME C CALL PARCHK(OPT,NORMEF,NRMTYP,TOL,IDLIST,NTOL,NGRP,GRPLST,LGTOL, * FLAG) IF (FLAG.EQ.0.) GO TO 40 WRITE (IOUT,FMT=99998) FLAG RETURN C C--------+---------+---------+---------+---------+---------+---------+-- C INITIALIZE OVERALL- AND GROUPS-SUMMARY STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- 40 OSTIME = 0. OSOVHD = 0. OSNFCN = 0 OSNSTP = 0 OSNTRU = 0 OSLEMX = 0. OSNDCV = 0 OSNBAD = 0 DO 60 I = 1, NTOL GSTIME(I) = 0. GSOVHD(I) = 0. GSNFCN(I) = 0 GSNSTP(I) = 0 GSNTRU(I) = 0 GSLEMX(I) = 0. GSNDCV(I) = 0 GSNBAD(I) = 0 60 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C LOOP OVER GROUPS OF PROBLEMS C--------+---------+---------+---------+---------+---------+---------+-- C DO 300 KGRP = 1, NGRP C C--------+---------+---------+---------+---------+---------+---------+-- C OUTPUT HEADING, ON NEW PAGE FOR GROUPS AFTER FIRST. C SELECT GROUP OF DIFFERENTIAL EQUATIONS. C GET NO. OF SYSTEMS IN THIS GROUP, & OFFSET FOR C POSITION OF ITEM IN GROUP WITHIN IDLIST. C INITIALIZE PROBLEM SUMMARY STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- IF (KGRP.GT.1) WRITE (IOUT,FMT=99997) WRITE (IOUT,FMT=99996) KGRP, TITLE C NSYST = GRPLST(1,KGRP) IDSUB = GRPLST(2,KGRP) C DO 80 I = 1, NTOL PSTIME(I) = 0. PSOVHD(I) = 0. PSNFCN(I) = 0 PSNSTP(I) = 0 PSNTRU(I) = 0 PSLEMX(I) = 0. PSNDCV(I) = 0 PSNBAD(I) = 0 PSGEMX(I) = 0. PSGEND(I) = 0. 80 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C LOOP OVER PROBLEMS WITHIN A GROUP C--------+---------+---------+---------+---------+---------+---------+-- DO 260 KSYST = 1, NSYST C--------+---------+---------+---------+---------+---------+---------+-- C GET NEXT PROBLEM-ID: C EXTRACT THE WEIGHTING OPTION (IWT=1 OR -1). C UNPACK ID INTO CLASSNAME + INDEX WITHIN CLASS AND TRANSLATE C INTO NSDTST INTERNAL ID BY SUBTRACTING 10: C--------+---------+---------+---------+---------+---------+---------+-- IDSUB = IDSUB + 1 ID = IDLIST(IDSUB) IWT = ISIGN(1,ID) ID = IABS(ID) KCLASS = (ID-1)/10 IID = ID - 10*KCLASS ID = ID - 10 IF (IWT.GT.0) WRITE (IOUT,FMT=99995) IDCLAS(KCLASS:KCLASS), * IID IF (IWT.LE.0) WRITE (IOUT,FMT=99994) IDCLAS(KCLASS:KCLASS), * IID WRITE (IOUT,FMT=99993) (BL,I=1,OPT) WRITE (IOUT,FMT=99992) (BL,I=1,OPT) C C--------+---------+---------+---------+---------+---------+---------+-- C LOOP OVER TOLERANCES FOR ONE PROBLEM C--------+---------+---------+---------+---------+---------+---------+-- DO 220 KTOL = 1, NTOL C--------+---------+---------+---------+---------+---------+---------+-- C CALL PLOT TO INITIALIZE LOCAL-ERROR SCATTER DIAGRAM C IF OPT=4. C CALL CNTROL TO ORGANIZE THE COLLECTION OF C STATISTICS. C ON EXIT FROM CNTROL THE VALUE OF CMPLET WILL C INDICATE WHETHER A FAILURE OCCURRED. C C CMPLET = 1 NO FAILURES. C CMPLET = 0 DETEST FAILED TO OBTAIN TRUE C LOCAL OR GLOBAL SOLUTION. C CMPLET = -1 METHOD FAILED TO REACH THE END C OF RANGE. C CMPLET = -2 DETEST FAILED AND SUBSEQUENTLY C METHOD FAILED. C CMPLET = -3 METHOD COULD NOT START THE C INTEGRATION. C CMPLET = -4 METHOD COMPLETED THE STATISTICS C GATHERING BUT FAILED IN TIMING LOOP. C C ON EXIT INDG1,INDL1 HOLD EXIT-FLAGS OF 'TRUE' C GLOBAL AND LOCAL SOLUTIONS RESPECTIVELY. C C ERFLGE(KTOL) IS TRUE IF METHOD FAILED TO REACH XEND. C ERFLG1(KTOL) IS TRUE IF EITHER METHOD OR C TRUE-SOLUTION FAILED TO REACH XEND (THUS INVALIDATING C GEMX AS DATA FOR SMOOTHNESS CALC WHEN NORMEF=2 ). C C IF CMPLET IS -4,-2,-1,0 OR 1 PRINT A LINE OF STATISTICS: C IF CMPLET ISNT 1, PRINT AN ERROR MESSAGE. C CALL PLOT TO PRINT LOCAL-ERROR SCATTER DIAGRAM C IF OPT=4 C NOTE IF METHOD FAILED TO REACH XEND, ANY STATISTICS FOR C THIS PROBLEM ARE PRINTED BUT DO NOT CONTRIBUTE TO THE C SUMMARY STATISTICS. CONVERSELY IF METHOD REACHED XEND, C ALL STATISTICS CONTRIBUTE TO THE SUMMARIES THOUGH GEMX, C LEMXSC,NDCV,NBAD,NTRU ONLY APPLY TO PART OF THE RANGE C IF 'TRUE' FAILED. C--------+---------+---------+---------+---------+---------+---------+-- C TOLK = TOL(KTOL) ERRTOL = REAL(TOLK) IF (OPT.EQ.4) CALL PLOT(0.,0.,0) C CALL CNTROL(CMPLET,INDG1,INDL1) C ERFLGE(KTOL) = CMPLET .LT. 0 .AND. CMPLET .GT. -4 ERFLG1(KTOL) = CMPLET .LT. 1 .AND. CMPLET .GT. -4 GENDSC = BIG IF (ERFLGE(KTOL)) GO TO 100 GENDSC = GEND/TOLK LGGEND(KTOL) = ALOG10(AMAX1(GEND,.01*TOLK)) 100 CONTINUE GEMXSC = GEMX/TOLK FDECEV = RATIO(NDCV,NTRU) FBADEC = RATIO(NBAD,NTRU) C IF (CMPLET.EQ.-3) GO TO 120 IF (OPT.EQ.1) WRITE (IOUT,FMT=99991) LGTOL(KTOL), TIME, * OVHD, NFCN, NSTP, GENDSC IF (OPT.EQ.2) WRITE (IOUT,FMT=99991) LGTOL(KTOL), TIME, * OVHD, NFCN, NSTP, GENDSC, GEMXSC IF (OPT.GE.3) WRITE (IOUT,FMT=99991) LGTOL(KTOL), TIME, * OVHD, NFCN, NSTP, GENDSC, GEMXSC, LEMXSC, FDECEV, * FBADEC IF (OPT.GE.3 .AND. NSTP.NE.NTRU) WRITE (IOUT,FMT=99990) * NTRU 120 CONTINUE C C IF (CMPLET.EQ.-4) WRITE (IOUT,FMT=99989) IF (CMPLET.EQ.-3) WRITE (IOUT,FMT=99988) LGTOL(KTOL) C IF (CMPLET.EQ.-2) WRITE (IOUT,FMT=99987) XTRUE, INDG1, * INDL1, XFIN C IF (CMPLET.EQ.-1) WRITE (IOUT,FMT=99986) XFIN C IF (CMPLET.EQ.0) WRITE (IOUT,FMT=99985) XTRUE, INDG1, * INDL1 C IF (OPT.EQ.4) THEN C WRITE (IOUT,FMT=99984) XTRAP C CALL PLOT(0.,0.,2) END IF C FOR EVALUATING PERFORMANCE OF 'TRUE': C CALL TRUCHK(4,IDUM) C C--------+---------+---------+---------+---------+---------+---------+-- C UPDATE PROBLEMS-SUMMARY STATS IF METHOD REACHED XEND. C (IF IT DIDN'T, DON'T UPDATE THE LOCAL-ASSESSMENT INFO: C NTRU,LEMXSC,NDCV,NBAD. THIS IS AN ARBITRARY CHOICE, IT C MAKES IT SIMPLER TO EXPLAIN TO THE USER. C STORE NORMEF STATISTICS: C--------+---------+---------+---------+---------+---------+---------+-- C IF (ERFLGE(KTOL)) GO TO 180 PSTIME(KTOL) = PSTIME(KTOL) + TIME PSOVHD(KTOL) = PSOVHD(KTOL) + OVHD PSNFCN(KTOL) = PSNFCN(KTOL) + NFCN PSNSTP(KTOL) = PSNSTP(KTOL) + NSTP PSGEND(KTOL) = AMAX1(PSGEND(KTOL),GENDSC) C IF (OPT.LT.2) GO TO 140 PSGEMX(KTOL) = AMAX1(PSGEMX(KTOL),GEMXSC) LGGEMX(KTOL) = ALOG10(AMAX1(GEMX,.01*TOLK)) C 140 IF (OPT.LT.3) GO TO 160 PSNTRU(KTOL) = PSNTRU(KTOL) + NTRU PSLEMX(KTOL) = AMAX1(PSLEMX(KTOL),LEMXSC) PSNDCV(KTOL) = PSNDCV(KTOL) + NDCV PSNBAD(KTOL) = PSNBAD(KTOL) + NBAD 160 CONTINUE 180 CONTINUE C IF (NORMEF.EQ.0) GO TO 200 NSTIME(KTOL) = TIME NSOVHD(KTOL) = OVHD NSNFCN(KTOL) = NFCN NSNSTP(KTOL) = NSTP 200 CONTINUE C--------+---------+---------+---------+---------+---------+---------+-- C END OF LOOP OVER TOLERANCES FOR ONE PROBLEM C--------+---------+---------+---------+---------+---------+---------+-- 220 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C SMOOTHNESS AND NORMALIZED EFFICIENCY CALCULATIONS BEGIN C--------+---------+---------+---------+---------+---------+---------+-- WRITE (IOUT,FMT=99983) C WRITE (IOUT,FMT=99982) C CALL LSQFIT(LGTOL,LGGEND,ERFLGE,NTOL,NOK,C,E,RES) C CTEN = 10.**C IF (NOK.LE.2) WRITE (IOUT,FMT=99981) NOK C IF (NOK.GT.2) WRITE (IOUT,FMT=99980) CTEN, E, RES, NOK C IF (OPT.LT.2) GO TO 240 WRITE (IOUT,FMT=99979) C CALL LSQFIT(LGTOL,LGGEMX,ERFLG1,NTOL,NOK1,C1,E1,RES1) C CTEN1 = 10.**C1 IF (NOK1.LE.2) WRITE (IOUT,FMT=99981) NOK1 IF (NOK1.GT.2) WRITE (IOUT,FMT=99980) CTEN1, E1, RES1, NOK1 240 CONTINUE C IF (NORMEF.EQ.1) CALL EFSTAT(C,E,LGTOL,NTOL,NOK,ERFLGE, * 'ENDPOINT',IOUT,NSTIME,NSOVHD, * NSNFCN,NSNSTP) C IF (NORMEF.EQ.2) CALL EFSTAT(C1,E1,LGTOL,NTOL,NOK1,ERFLG1, * 'MAXIMUM ',IOUT,NSTIME,NSOVHD, * NSNFCN,NSNSTP) C C--------+---------+---------+---------+---------+---------+---------+-- C SMOOTHNESS AND NORMALIZED EFFICIENCY CALCULATIONS END C--------+---------+---------+---------+---------+---------+---------+-- C C--------+---------+---------+---------+---------+---------+---------+-- C END OF LOOP OVER PROBLEMS IN A GROUP. C--------+---------+---------+---------+---------+---------+---------+-- 260 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C OUTPUT PROBLEMS-SUMMARY STATISTICS C--------+---------+---------+---------+---------+---------+---------+-- C WRITE (IOUT,FMT=99978) KGRP WRITE (IOUT,FMT=99993) (BL,I=1,OPT) WRITE (IOUT,FMT=99992) (BL,I=1,OPT) DO 280 KTOL = 1, NTOL FDECEV = RATIO(PSNDCV(KTOL),PSNTRU(KTOL)) FBADEC = RATIO(PSNBAD(KTOL),PSNTRU(KTOL)) C IF (OPT.EQ.1) WRITE (IOUT,FMT=99991) LGTOL(KTOL), * PSTIME(KTOL), PSOVHD(KTOL), PSNFCN(KTOL), PSNSTP(KTOL), * PSGEND(KTOL) C IF (OPT.EQ.2) WRITE (IOUT,FMT=99991) LGTOL(KTOL), * PSTIME(KTOL), PSOVHD(KTOL), PSNFCN(KTOL), PSNSTP(KTOL), * PSGEND(KTOL), PSGEMX(KTOL) C IF (OPT.GE.3) WRITE (IOUT,FMT=99991) LGTOL(KTOL), * PSTIME(KTOL), PSOVHD(KTOL), PSNFCN(KTOL), PSNSTP(KTOL), * PSGEND(KTOL), PSGEMX(KTOL), PSLEMX(KTOL), FDECEV, FBADEC C IF (OPT.GE.3 .AND. PSNSTP(KTOL).NE.PSNTRU(KTOL)) * WRITE (IOUT,FMT=99990) PSNTRU(KTOL) C C--------+---------+---------+---------+---------+---------+---------+-- C UPDATE GROUPS-SUMMARY STATISTICS C--------+---------+---------+---------+---------+---------+---------+-- GSTIME(KTOL) = GSTIME(KTOL) + PSTIME(KTOL) GSOVHD(KTOL) = GSOVHD(KTOL) + PSOVHD(KTOL) GSNFCN(KTOL) = GSNFCN(KTOL) + PSNFCN(KTOL) GSNSTP(KTOL) = GSNSTP(KTOL) + PSNSTP(KTOL) C IF (OPT.LT.3) GO TO 280 GSNTRU(KTOL) = GSNTRU(KTOL) + PSNTRU(KTOL) GSLEMX(KTOL) = AMAX1(GSLEMX(KTOL),PSLEMX(KTOL)) GSNDCV(KTOL) = GSNDCV(KTOL) + PSNDCV(KTOL) GSNBAD(KTOL) = GSNBAD(KTOL) + PSNBAD(KTOL) 280 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C END OF LOOP OVER GROUPS C--------+---------+---------+---------+---------+---------+---------+-- 300 CONTINUE C C C--------+---------+---------+---------+---------+---------+---------+-- C OUTPUT HEADINGS FOR GROUPS- AND OVERALL-SUMMARY STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- WRITE (IOUT,FMT=99977) TITLE, (BL,I=1,OPT) WRITE (IOUT,FMT=99976) (BL,I=1,OPT) C--------+---------+---------+---------+---------+---------+---------+-- C OUTPUT GROUPS-SUMMARY STATISTICS C--------+---------+---------+---------+---------+---------+---------+-- IF (OPT.GE.3) GO TO 340 DO 320 I = 1, NTOL WRITE (IOUT,FMT=99975) LGTOL(I), GSTIME(I), GSOVHD(I), * GSNFCN(I), GSNSTP(I) 320 CONTINUE GO TO 380 340 DO 360 I = 1, NTOL FDECEV = RATIO(GSNDCV(I),GSNTRU(I)) FBADEC = RATIO(GSNBAD(I),GSNTRU(I)) WRITE (IOUT,FMT=99975) LGTOL(I), GSTIME(I), GSOVHD(I), * GSNFCN(I), GSNSTP(I), GSLEMX(I), FDECEV, FBADEC C IF (GSNSTP(I).NE.GSNTRU(I)) WRITE (IOUT,FMT=99990) GSNTRU(I) 360 CONTINUE 380 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C COMPUTE OVERALL-SUMMARY STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- DO 400 I = 1, NTOL OSTIME = OSTIME + GSTIME(I) OSOVHD = OSOVHD + GSOVHD(I) OSNFCN = OSNFCN + GSNFCN(I) OSNSTP = OSNSTP + GSNSTP(I) C IF (OPT.LT.3) GO TO 400 OSNTRU = OSNTRU + GSNTRU(I) OSNDCV = OSNDCV + GSNDCV(I) OSNBAD = OSNBAD + GSNBAD(I) OSLEMX = AMAX1(OSLEMX,GSLEMX(I)) 400 CONTINUE FDECEV = RATIO(OSNDCV,OSNTRU) FBADEC = RATIO(OSNBAD,OSNTRU) C--------+---------+---------+---------+---------+---------+---------+-- C OUTPUT OVERALL-SUMMARY STATISTICS C--------+---------+---------+---------+---------+---------+---------+-- IF (OPT.LT.3) WRITE (IOUT,FMT=99974) OSTIME, OSOVHD, OSNFCN, * OSNSTP C IF (OPT.GE.3) WRITE (IOUT,FMT=99974) OSTIME, OSOVHD, OSNFCN, * OSNSTP, OSLEMX, FDECEV, FBADEC C C RETURN C 99999 FORMAT ('0NONSTIFF DETEST PACKAGE OPTION=',I2,', NORMEF=',I2, * ', NRMTYP=',I2,19X,'ON ',A,//) 99998 FORMAT ('0PARAMETER ERRORS AS SHOWN BY FLAG=',E15.8,/' ',49('*') * ,//) 99997 FORMAT ('1') 99996 FORMAT ('0GROUP',I3,18X,A) 99995 FORMAT (/'0',A3,I1,' (SCALED)',/) 99994 FORMAT (/'0',A3,I1,' (UNSCALED)',/) 99993 FORMAT (' ',A1,6X,'LOG10',5X,'TIME',3X,'OVHD',5X,'FCN',4X,'NO OF', * 3X,'END PNT',A1,2X,'MAXIMUM',A1,2X,'MAXIMUM',3X,'FRACTION', * 3X,'FRACTION',A1) 99992 FORMAT (' ',A1,7X,'TOL',21X,'CALLS',3X,'STEPS',3X,'GLB ERR',A1,2X, * 'GLB ERR',A1,2X,'LOC ERR',3X,'DECEIVED',3X,'BAD DECV',A1) 99991 FORMAT ('0',6X,F6.2,2X,2F7.3,1X,2I8,2X,F8.2,1X,F9.2,1X,F9.3,1X, * F9.3,1X,F10.3,1X,F10.3) 99990 FORMAT (114X,'(LOC ASSESS ON',I4,')') 99989 FORMAT ('0',20X, * '***** UNEXPECTED FAILURE OF METHOD WHILE BEING TIMED *****' * ,/) 99988 FORMAT ('0',6X,F6.2,' *** METHOD FAILED TO START ***') 99987 FORMAT (15X,'TRUE-SOLUTION OF TEST PACKAGE FAILED AT X = ',1P, * E12.5,', ERROR FLAG (GLOBAL) ',I3,', (LOCAL) ',I3,/21X, * 'AND SUBSEQUENTLY METHOD FAILED AT X = ',1P,E12.5) 99986 FORMAT (21X,'METHOD FAILED AT X = ',1P,E12.5) 99985 FORMAT (21X,'TRUE-SOLUTION OF TEST PACKAGE FAILED AT X = ',1P, * E12.5,', ERROR FLAG (GLOBAL) ',I3,', (LOCAL) ',I3) 99984 FORMAT (/6X,'ERROR ESTIMATE ANALYSIS',10X, * 'EXTRAPOLATION (0=NO 1=YES):',I2,/11X, * 'HORIZONTAL AXIS: R1=||ERREST|| / ERRBND',/11X, * 'VERTICAL AXIS: R2 = ||ERROR IN ERREST|| / ERRBND',/11X, * 'PLOT SHOWS % STEPS WHERE (R1,R2) LAY',1X, * 'IN INDICATED PIGEONHOLE, A DOT MEANS UNDER 1%',/) 99983 FORMAT (/'0',17X,'SMOOTHNESS FIT OF LOG10(ERROR) VS LOG10(TOL)') 99982 FORMAT ('0',17X,'ENDPOINT GLOBAL ERROR') 99981 FORMAT (39X,I2,' VALUES, TOO FEW TO GET STATISTICS') 99980 FORMAT (39X,'=',1P,G10.3,' *(TOL**',0P,F6.3,') APPROX,',6X, * 'R.M.S. RESIDUAL=',1P,E8.1,' OVER',I3,' VALUES') 99979 FORMAT ('0',17X,'MAXIMUM GLOBAL ERROR') 99978 FORMAT (/'0SUMMARY OVER GROUP',I3) 99977 FORMAT ('1SUMMARY OVER ALL GROUPS',6X,A,//' ',A1,6X,'LOG10',5X, * 'TIME',3X,'OVHD',5X,'FCN',4X,'NO OF',2A1,'MAXIMUM',3X, * 'FRACTION',3X,'FRACTION',A1) 99976 FORMAT (' ',A1,7X,'TOL',21X,'CALLS',3X,'STEPS',2A1,'LOC ERR',3X, * 'DECEIVED',3X,'BAD DECV',A1) 99975 FORMAT ('0',6X,F6.2,2X,2F7.3,1X,2I8,1X,3F11.3) 99974 FORMAT ('0',5X,'OVERALL',/6X,'SUMMARY',2X,2F7.3,1X,2I8,1X,3F11.3) END C C C********+*********+*********+*********+*********+*********+*********+** C SUBROUTINE PARCHK(OPT,NORMEF,NRMTYP,TOL,IDLIST,NTOL,NGRP,GRPLST, * LGTOL,FLAG) C C********+*********+*********+*********+*********+*********+*********+** C ROUTINE TO DO PARAMETER CHECKS FOR REVISED NSDTST INTERFACE. C C INPUT: OPT,NORMEF,NRMTYP,TOL,IDLIST C VALID INPUT IS: C OPTION = 1 2 3 OR 4 C NORMEF = 0 1 OR 2 C NRMTYP = 1 2 OR 3 C TOL = LIST OF UP TO 10 POSITIVE REAL'S FOLLOWED BY A 0., C IN STRICTLY DECREASING ORDER C IDLIST = LIST OF GROUPS OF PROBLEM-IDS SEPARATED BY ZEROS C WITH 2 ZEROS AFTER LAST GROUP, AT MOST 60 ITEMS TOTAL. C EACH ID MAY HAVE A MINUS SIGN TO SELECT THE 'UNSCALED' C ERROR CONTROL OPTION. C VALID PROBLEM-IDS ARE IN RANGES C 11-15 21-25 31-35 41-45 51-55 61-65 C FOR PROBLEM CLASSES A1-A5 B1-B5 ETC. C OUTPUT: NTOL = NO. OF TOLERANCES IN TOL LIST C NGRP = NO. OF GROUPS IN IDLIST LIST C GRPLST(1,I) = SIZE OF I-TH GROUP OF PROBLEMS CC ... (2,I) = POINTER TO (START OF I-TH GROUP)-1 IN IDLIST C LGTOL(I) = LOG10(TOL(I)) C FLAG IS ERROR FLAG, 0.0 IF ALL OK, ELSE ITS DECIMAL DIGITS C INDICATE WHICH PARAMETER ERRORS WERE FOUND: C 1: OPT INVALID C 2: NORMEF INVALID C 3: NORMEF = 2 REQUESTED WITH OPT = 1 C 4: TOL(I) < 0, OR LIST NOT IN DECREASING ORDER C 5: TOL LIST EMPTY OR NOT TERMINATED BY ZERO C 6: INVALID PROBLEM-ID FOUND C 7: LIST OF GROUPS IN IDLIST EMPTY,NOT TERMINATED BY C 2 ZEROS OR HAS MORE THAN MAXGRP GROUPS C 8: NRMTYP INVALID C--------+---------+---------+---------+---------+---------+---------+-- C C .. Scalar Arguments .. REAL FLAG INTEGER NGRP, NORMEF, NRMTYP, NTOL, OPT C .. Array Arguments .. REAL LGTOL(10), TOL(11) INTEGER GRPLST(2,6), IDLIST(60) C .. Local Scalars .. REAL BIG, TOLPRV INTEGER ENDLST, I, ID, IID, ISAV, KCLASS, LENIDS, * LENTOL, MAXGRP, NCLASS C .. Local Arrays .. INTEGER NSYSTM(6) C .. Intrinsic Functions .. INTRINSIC ALOG10, IABS C .. Data statements .. DATA ENDLST/-1/, BIG/1E20/ DATA NCLASS/6/, NSYSTM/5, 5, 5, 5, 5, 5/, MAXGRP/6/, * LENTOL/11/, LENIDS/60/ C .. Executable Statements .. C FLAG = 0. IF (OPT.LT.1 .OR. OPT.GT.4) FLAG = 1. IF (NORMEF.LT.0 .OR. NORMEF.GT.2) FLAG = 10.*FLAG + 2. IF (OPT.EQ.1 .AND. NORMEF.EQ.2) FLAG = 10.*FLAG + 3. IF (NRMTYP.LT.1 .OR. NRMTYP.GT.3) FLAG = 10.*FLAG + 8. C C TOLERANCES: NTOL = 0 TOLPRV = BIG DO 20 I = 1, LENTOL IF (TOL(I).LT.0. .OR. TOL(I).GE.TOLPRV) FLAG = 10.*FLAG + 4. IF (TOL(I).EQ.0.) GO TO 40 NTOL = NTOL + 1 TOLPRV = TOL(I) 20 CONTINUE C C NO TERMINATING 0 IN TOLERANCE LIST: FLAG = 10.*FLAG + 5. C C CHECK FOR EMPTY TOLERANCE LIST: 40 IF (NTOL.EQ.0) FLAG = 10.*FLAG + 5. C C LIST OF GROUPS OF PROBLEMS: NGRP = 0 I = 0 C C WHILE NEXT ID IN LIST ISNT 0 OR END OF LIST: 60 I = I + 1 ID = ENDLST IF (I.LE.LENIDS) ID = IDLIST(I) C IF (ID.EQ.0) GO TO 160 IF (NGRP.GE.MAXGRP) GO TO 180 ISAV = I - 1 C C WHILE ID ISNT 0, GET ONE GROUP: 80 IF (ID.EQ.0) GO TO 140 IF (ID.EQ.ENDLST) GO TO 180 C TRANSLATE ID INTO CLASS & NUMBER WITHIN CLASS, C IGNORING SIGN (WHICH SELECTS SCALED/UNSCALED OPTION): ID = IABS(ID) KCLASS = (ID-1)/10 IID = ID - 10*KCLASS IF ( .NOT. (KCLASS.GE.1 .AND. KCLASS.LE.NCLASS)) GO TO 100 IF (IID.LE.NSYSTM(KCLASS)) GO TO 120 100 FLAG = 10.*FLAG + 6. 120 CONTINUE C GET NEXT ID AS ABOVE: I = I + 1 ID = ENDLST IF (I.LE.LENIDS) ID = IDLIST(I) GO TO 80 C C NEW GROUP FORMED: 140 NGRP = NGRP + 1 GRPLST(1,NGRP) = I - ISAV - 1 GRPLST(2,NGRP) = ISAV GO TO 60 C C CHECK IF NO GROUPS WERE SPECIFIED: 160 IF (NGRP.LE.0) GO TO 180 GO TO 200 C 180 FLAG = 10.*FLAG + 7. C C IF ALL OK, COMPUTE LOGS OF TOLERANCES: C 200 IF (FLAG.NE.0.) GO TO 240 DO 220 I = 1, NTOL LGTOL(I) = ALOG10(TOL(I)) 220 CONTINUE 240 RETURN END C C********+*********+*********+*********+*********+*********+*********+** C SUBROUTINE LSQFIT(X,Y,MISS,N,NN,C0,C1,RES) C .. Scalar Arguments .. REAL C0, C1, RES INTEGER N, NN C .. Array Arguments .. REAL X(N), Y(N) LOGICAL MISS(N) C .. Local Scalars .. REAL SX, SXX, SXY, SY, XNN INTEGER I C .. Intrinsic Functions .. INTRINSIC SQRT C .. Executable Statements .. C C********+*********+*********+*********+*********+*********+*********+** C FITS MODEL Y = C0 + C1*X TO DATA X(I),Y(I),I = 1..N WHERE DATA C FOR WHICH MISS(I) IS .TRUE. IS REGARDED AS MISSING. C C ON EXIT C X,Y,MISS,N ARE UNCHANGED. C NN = NO. OF NONMISSING VALUES C C0,C1 = FITTED COEFFICIENTS C RES = ROOT MEAN SQUARE RESIDUAL C C EXCEPT THAT IF NN.LE.1 NO COMPUTATION OF THE COEFFICIENTS IS DONE. C--------+---------+---------+---------+---------+---------+---------+-- C NN = 0 SX = 0. SY = 0. DO 20 I = 1, N IF (MISS(I)) GO TO 20 NN = NN + 1 SX = SX + X(I) SY = SY + Y(I) 20 CONTINUE IF (NN.LE.1) GO TO 80 XNN = NN SX = SX/XNN SY = SY/XNN SXX = 0. SXY = 0. DO 40 I = 1, N IF (MISS(I)) GO TO 40 SXX = SXX + (X(I)-SX)**2 SXY = SXY + (X(I)-SX)*(Y(I)-SY) 40 CONTINUE C1 = SXY/SXX C0 = SY - C1*SX RES = 0. DO 60 I = 1, N IF ( .NOT. MISS(I)) RES = RES + (Y(I)-SY-C1*(X(I)-SX))**2 60 CONTINUE C RES = SQRT(RES/XNN) C 80 RETURN END C C********+*********+*********+*********+*********+*********+*********+** C REAL FUNCTION RATIO(M,N) C C********+*********+*********+*********+*********+*********+*********+** C .. Scalar Arguments .. INTEGER M, N C .. Intrinsic Functions .. INTRINSIC FLOAT C .. Executable Statements .. RATIO = 1E20 IF (N.NE.0) RATIO = FLOAT(M)/FLOAT(N) RETURN END C C********+*********+*********+*********+*********+*********+*********+** C SUBROUTINE EFSTAT(C,E,LGTOL,NTOL,NOK,ERFLG,TITLE,IOUT,W1,W2,W3,W4) C C********+*********+*********+*********+*********+*********+*********+** C ROUTINE TO COMPUTE AND PRINT NORMALIZED EFFICIENCY STATISTICS. C C PARAMETERS (ALL INPUT): C C,E - COEFFICIENTS IN LEAST-SQUARES FIT OF ACHIEVED ACCURACY C (EITHER AT ENDPOINT OR MAX-OVER-RANGE) TO TOLERANCE. C LGTOL - LIST OF LOGS TO BASE 10 OF TOLERANCES C NTOL - NO. OF TOLERANCES. C NOK - NO. OF .FALSE. ENTRIES IN ERFLG (FROM LSQFIT CALL) C ERFLG - LOGICAL VECTOR INDICATING FOR WHICH TOLERANCES DATA C IS TO BE REGARDED AS MISSING. C TITLE C - IDENTIFYING CHARACTER STRING. C IOUT - OUTPUT UNIT NUMBER. C W1,...,W6 C - VECTORS OF STATISTICS, INDEXED OVER TOLERANCES, FOR C WHICH NORMALIZED STATISTICS ARE TO BE PRODUCED. C (NOTE SOME ARE REAL, SOME INTEGER: REFER TO ACTUAL CALL C IN NSDTST.) C IT IS ASSUMED THAT NTOL.LE.10, OTHERWISE ARRAY S MUST BE LONGER. C--------+---------+---------+---------+---------+---------+---------+-- C C LOCAL VARIABLES C .. Scalar Arguments .. REAL C, E INTEGER IOUT, NOK, NTOL CHARACTER*8 TITLE C .. Array Arguments .. REAL LGTOL(NTOL), W1(NTOL), W2(NTOL) INTEGER W3(NTOL), W4(NTOL) LOGICAL ERFLG(NTOL) C .. Local Scalars .. REAL EQVTOL, S0, THETA, W1INT, W2INT, X INTEGER I, MSINT, NHI, NLO, SHI, SINT, SLO, W3INT, W4INT C .. Local Arrays .. REAL S(10) C .. Intrinsic Functions .. INTRINSIC FLOAT, INT C .. Statement Functions .. INTEGER FLOOR C .. Statement Function definitions .. C C STATEMENT FUNCTION C FLOOR FUNCTION VALID IF ARGUMENT X.GE.-100 WHICH IS OK HERE. FLOOR(X) = INT(X+100.) - 100 C .. Executable Statements .. C IF (NOK.LE.2) GO TO 200 C C TRANSFORM THE LOG10(TOL)'S TO NORMALIZED-EFFICIENCY VARIABLE: DO 20 I = 1, NTOL S(I) = -(C+E*LGTOL(I)) 20 CONTINUE C C FIND SET OF CONSECUTIVE TOL'S FOR WHICH INTEGRATION SUCCEEDED: DO 40 NLO = 1, NTOL IF ( .NOT. ERFLG(NLO)) GO TO 60 40 CONTINUE C ELSE ALL INTEGRATIONS FOR THIS PROBLEM FAILED: GO TO 200 60 CONTINUE NHI = NLO - 1 DO 80 I = NLO, NTOL IF (ERFLG(I)) GO TO 100 NHI = I 80 CONTINUE 100 CONTINUE C IF (NHI.LE.NLO) GO TO 200 IF (E.LE.0.) GO TO 220 C C FORM RANGE OF INTEGER POWERS OF 10 FOR WHICH NORMALIZED STATISTICS C ARE TO BE PRINTED: SLO = -FLOOR(-S(NLO)+0.1) SHI = FLOOR(S(NHI)+0.1) IF (SHI.LT.SLO) GO TO 240 C WRITE (IOUT,FMT=99999) TITLE C C START OF LOOP TO PRINT A LINE OF STATISTICS FOR EACH POWER OF 10: I = NLO + 1 CC ... WHICH IS KNOWN TO BE .LE. NHI C DO 160 SINT = SLO, SHI S0 = FLOAT(SINT) C C MOVE INTERVAL S(I-1)..S(I) TO RIGHT WHILE S(I).LT.SINT: 120 IF (S(I).GE.S0 .OR. I.GE.NHI) GO TO 140 I = I + 1 GO TO 120 140 CONTINUE C NECESSARILY NOW NLO + 1 .LE. I .LE. NHI C C NOW DO INTERPOLATION (POSSIBLY EXTRAPOLATION A SHORT DISTANCE) C USING DATA FOR I AND I + 1: THETA = (S0-S(I-1))/(S(I)-S(I-1)) W1INT = W1(I-1) + THETA*(W1(I)-W1(I-1)) W2INT = W2(I-1) + THETA*(W2(I)-W2(I-1)) W3INT = W3(I-1) + THETA*(W3(I)-W3(I-1)) W4INT = W4(I-1) + THETA*(W4(I)-W4(I-1)) C MSINT = -SINT EQVTOL = -(C+S0)/E WRITE (IOUT,FMT=99998) MSINT, EQVTOL, W1INT, W2INT, W3INT, * W4INT C 160 CONTINUE C 180 RETURN C 200 WRITE (IOUT,FMT=99997) GO TO 180 C 220 WRITE (IOUT,FMT=99996) GO TO 180 C 240 WRITE (IOUT,FMT=99995) GO TO 180 C 99999 FORMAT (/'0',6X,'NORMALIZED EFFICIENCY - ',A8,' GLOBAL ERROR', * //7X,'EXPECTED',3X,'EQUIV',4X,'TIME',3X,'OVHD',5X,'FCN',4X, * 'NO OF',/7X,'ACCURACY',1X,'LOG10 TOL',17X,'CALLS',3X, * 'STEPS') 99998 FORMAT ('0',6X,'10**',I3,F8.2,F9.3,F7.3,1X,2I8) 99997 FORMAT ('0',10X,'NOT ENOUGH SUCCESSFUL INTEGRATIONS TO FORM',1X, * 'NORMALIZED STATISTICS') 99996 FORMAT ('0',10X,'DEPENDENCE OF ACCURACY ON TOLERANCE IS TOO',1X, * 'UNRELIABLE TO FORM NORMALIZED STATISTICS') 99995 FORMAT ('0',10X,'NO POWERS OF TEN WITHIN RANGE OF TOLERANCES',1X, * 'USED: NO NORMALIZED STATISTICS') END C C C********+*********+*********+*********+*********+*********+*********+** C SUBROUTINE CNTROL(CMPLET,INDG1,INDL1) C C********+*********+*********+*********+*********+*********+*********+** C CNTROL ORGANIZES THE CALLS TO METHOD NEEDED TO GATHER C STATISTICS FOR ONE PROBLEM AND ONE TOLERANCE AT THE LEVEL OF C DETAIL SPECIFIED BY OPT, WITH SCALING TURNED ON OR OFF BY IWT. C C ON EXIT FROM CNTROL C CMPLET INDICATES WHETHER A FAILURE OCCURRED: C CMPLET = 1 NO FAILURES. C CMPLET = 0 DETEST FAILED TO OBTAIN TRUE LOCAL OR GLOBAL C SOLUTION. C CMPLET = -1 METHOD FAILED TO REACH THE END OF RANGE. C CMPLET = -2 DETEST FAILED AND SUBSEQUENTLY METHOD FAILED C CMPLET = -3 METHOD COULD NOT START THE INTEGRATION. C CMPLET = -4 METHOD COMPLETED THE STATISTICS GATHERING CALL C BUT (UNEXPECTEDLY) FAILED IN THE TIMING LOOP. C C INDG1, INDL1 RETURN THE ERROR FLAGS OF THE 'TRUE' GLOBAL C AND LOCAL SOLUTIONS RESPECTIVELY. C C THE MAIN OUTPUT FROM CNTROL CONSISTS OF THE STATISTICS HELD C IN COMMON /NSCOM3/ C--------+---------+---------+---------+---------+---------+---------+-- C--------+---------+---------+---------+---------+---------+---------+-- C COMMON AREAS C--------+---------+---------+---------+---------+---------+---------+-- C1 C2 C3 C5 C6 C .. Scalar Arguments .. INTEGER CMPLET, INDG1, INDL1 C .. Scalars in Common .. REAL ERRTOL, HSTART, XEND, XFIN, XTRUE REAL GEMX, GEND, LEMXSC, OVHD, TIME, TRUTIM INTEGER ID, ID1, IFLAG, INDG, INDL, IOUT, IWT, IWT1, N, * N1, NBAD, NDCV, NFCN, NFCN1, NRMTYP, NSTART, * NSTL, NSTP, NTRU, OPT, XTRAP C .. Arrays in Common .. REAL WT(51) C .. Local Scalars .. REAL DUMMY, HINIT, HMAX, X, XSTART REAL FCNTIM, S, TIMCUM, TSTTIM INTEGER COUNT, I LOGICAL NOSTRT, OKMETH, TIMERR C .. Local Arrays .. REAL Y(51), YEND(51), YSTART(51) C .. External Functions .. REAL CLOCK, CONST, DIFNRM EXTERNAL CLOCK, CONST, DIFNRM C .. External Subroutines .. EXTERNAL EVALU, IVALU, METHOD, STATS C .. Intrinsic Functions .. INTRINSIC FLOAT C .. Common blocks .. COMMON /NSCOM1/ERRTOL, OPT, NRMTYP, XTRAP, ID, IWT, * IOUT COMMON /NSCOM2/XEND, HSTART, N, IFLAG, INDL, INDG COMMON /NSCOM3/XFIN, XTRUE, TIME, OVHD, TRUTIM, GEND, * GEMX, LEMXSC, NFCN, NSTP, NSTL, NDCV, NBAD, * NTRU, NSTART COMMON /NSCOM5/WT, IWT1, N1, ID1 COMMON /NSCOM6/NFCN1 C .. Executable Statements .. CE C C--------+---------+---------+---------+---------+---------+---------+-- C NOTE ON INDL, INDG IN /NSCOM2/: C THESE ARE ERROR INDICATORS FOR THE 'TRUE' LOCAL AND C GLOBAL SOLUTION RESPECTIVELY. THEY ARE SET INSIDE STATS C WHICH IS CALLED BY METHOD. C ON RETURN FROM METHOD, INDL IS: C 2 IF NO CALL TO TRUE TO COMPUTE LOCAL SOLUTION HAS C YET BEEN MADE (SET BY INITIALIZING CALL TO STATS). C .GT.0 IF ALL CALLS TO TRUE FOR CALCULATION OF LOCAL C SOLUTION WERE SUCCESSFUL. C .LT.0 IF AN UNSUCCESSFUL CALL TO TRUE FOR THE LOCAL C SOLUTION WAS MADE. C THE VALUE ON EXIT IF NOT 0 IS THE VALUE RETURNED IN THE C FLAG 'IND' OF SUBROUTINE TRUE. C INDG IS THE SAME, BUT FOR THE GLOBAL SOLUTION. C C INDL,INDG ARE USED ON RE-ENTRY TO STATS TO TEST IF A C FAILURE OF THE TRUE SOLUTIONS OCCURRED ON A PREVIOUS STEP C AND SHOULD THUS BE LEFT ALONE BETWEEN STEPS. C--------+---------+---------+---------+---------+---------+---------+-- C C ACTION OF THE ROUTINE: C CALL IVALU TO SET INTEGRATION PARAMETERS. C COPY N,ID,IWT INTO /NSCOM5/ FOR USE BY FCN. C SET IFLAG = 1 AND CALL STATS TO INITIALIZE ITS COMMON AREAS. C (THE ARGUMENTS FOR THIS CALL ARE DUMMIES.) C SET X,Y,NSTP,NFCN FOR USE IN STATS. SET IFLAG = 2 SO THAT C THE CALL TO METHOD WILL SET THE FIRST STEP SIZE (HSTART) C AND RETURN. C SET NSTART = NO. OF FCN CALLS NEEDED BY METHOD TO START. C--------+---------+---------+---------+---------+---------+---------+-- C CALL IVALU(N,XSTART,XEND,HINIT,HMAX,YSTART,FCNTIM,WT,IWT,ID) C N1 = N ID1 = ID IWT1 = IWT X = XSTART DO 20 I = 1, N Y(I) = YSTART(I) 20 CONTINUE C IFLAG = 1 CALL STATS(X,Y,DUMMY,Y) C NFCN1 = 0 NSTP = 0 IFLAG = 2 C CALL METHOD(N,X,Y,XEND,ERRTOL,HMAX,HINIT) C NOSTRT = X .LT. XEND NSTART = NFCN1 C--------+---------+---------+---------+---------+---------+---------+-- C INITIALIZE THE COUNTERS ETC. IN /NSCOM3/,/NSCOM6/. C IF METHOD FAILED TO START, SET FLAGS AND EXIT. C SET IFLAG = 3 SO THAT THE CALL TO METHOD WILL DO A COMPLETE C INTEGRATION, COMPILING STATISTICS ON EACH STEP. C START THE CLOCK. C--------+---------+---------+---------+---------+---------+---------+-- NFCN1 = 0 NSTP = 0 NSTL = 0 LEMXSC = 0. NDCV = 0 NBAD = 0 GEMX = 0. TRUTIM = 0. NTRU = 0 C IF (NOSTRT) GO TO 180 C X = XSTART DO 40 I = 1, N Y(I) = YSTART(I) 40 CONTINUE IFLAG = 3 S = CLOCK(0.0) C CALL METHOD(N,X,Y,XEND,ERRTOL,HMAX,HSTART) C TIME = CLOCK(S) OKMETH = X .GE. XEND XFIN = X NFCN = NFCN1 IF ( .NOT. OKMETH) GO TO 160 C--------+---------+---------+---------+---------+---------+---------+-- C IF OPT.GT.1, OR IF OPT = 1 BUT THE TIMING ESTIMATE ALREADY C OBTAINED WAS TOO SMALL TO BE RELIABLE, DO A TIMING COMPUTATION C PROVIDED THAT METHOD REACHED THE ENDPOINT IN THE PREVIOUS CALL. C SET IFLAG = 0, START THE CLOCK, AND CALL C METHOD SUFFICIENTLY MANY TIMES FOR THE SOLUTION TIME TO C BE OBTAINED ACCURATELY. COMPUTE THE OVERHEAD AS THE C TOTAL TIME EXCLUSIVE OF FUNCTION EVALUATIONS C--------+---------+---------+---------+---------+---------+---------+-- TSTTIM = CONST(4) TIMERR = .FALSE. IF (TSTTIM.LE.0) GO TO 120 IF (OPT.EQ.1 .AND. TIME.GE.0.5*TSTTIM) GO TO 120 COUNT = 0 IFLAG = 0 S = CLOCK(0.0) C--------+---------+---------+---------+---------+---------+---------+-- C LOOP TILL 'TSTTIM' TIME UNITS HAVE ELAPSED: C--------+---------+---------+---------+---------+---------+---------+-- 60 CONTINUE X = XSTART DO 80 I = 1, N Y(I) = YSTART(I) 80 CONTINUE CALL METHOD(N,X,Y,XEND,ERRTOL,HMAX,HSTART) TIMERR = X .LT. XEND IF (TIMERR) GO TO 100 TIMCUM = CLOCK(S) COUNT = COUNT + 1 IF (TIMCUM.LT.TSTTIM .AND. COUNT.LT.10) GO TO 60 C 100 IF (COUNT.GE.1) TIME = TIMCUM/FLOAT(COUNT) 120 CONTINUE C--------+---------+---------+---------+---------+---------+---------+-- C WE NOW HAVE A VALUE FOR TIME: THE ONE OBTAINED BEFORE THE C TIMING LOOP IF WE SKIPPED THE LATTER OR IN THE UNLIKELY C EVENT OF AN ERROR IN THE 1ST TIMING ITERATION; OTHERWISE C THE ONE FROM THE TIMING LOOP. C COMPUTE OVERHEAD AND ENDPOINT GLOBAL ERROR. C--------+---------+---------+---------+---------+---------+---------+-- OVHD = TIME - FLOAT(NFCN)*FCNTIM CALL EVALU(YEND,N,WT,IWT,ID) GEND = DIFNRM(YEND,Y,N) C IF (TIMERR) GO TO 200 C C--------+---------+---------+---------+---------+---------+---------+-- C SET THE OUTPUT VALUE OF CMPLET, INDG1 AND INDL1. C--------+---------+---------+---------+---------+---------+---------+-- CMPLET = 1 IF (INDL.LT.0 .OR. INDG.LT.0) CMPLET = 0 140 INDG1 = INDG INDL1 = INDL RETURN C C--------+---------+---------+---------+---------+---------+---------+-- C *********** ERROR EXITS *********** C--------+---------+---------+---------+---------+---------+---------+-- C METHOD FAILED TO REACH XEND C--------+---------+---------+---------+---------+---------+---------+-- 160 CMPLET = -1 IF (INDL.LT.0 .OR. INDG.LT.0) CMPLET = -2 TIME = 1E20 OVHD = 1E20 GEND = 1E20 GO TO 140 C C--------+---------+---------+---------+---------+---------+---------+-- C METHOD FAILED TO START C--------+---------+---------+---------+---------+---------+---------+-- 180 CMPLET = -3 NFCN = 0 TIME = 1E20 OVHD = 1E20 GEND = 1E20 GO TO 140 C--------+---------+---------+---------+---------+---------+---------+-- C INTEGRATION FAILED IN TIMING LOOP C--------+---------+---------+---------+---------+---------+---------+-- 200 CMPLET = -4 GO TO 140 END C C********+*********+*********+*********+*********+*********+*********+** C REAL FUNCTION DIFNRM(A,B,N) C1 C .. Scalar Arguments .. INTEGER N C .. Array Arguments .. REAL A(N), B(N) C .. Scalars in Common .. REAL ERRTOL INTEGER ID, IOUT, IWT, NRMTYP, OPT, XTRAP C .. Local Scalars .. INTEGER I C .. Intrinsic Functions .. INTRINSIC AMAX1, ABS, REAL, SQRT C .. Common blocks .. COMMON /NSCOM1/ERRTOL, OPT, NRMTYP, XTRAP, ID, IWT, * IOUT C .. Executable Statements .. C C********+*********+*********+*********+*********+*********+*********+** C NORM OF DIFFERENCE BETWEEN TWO DOUBLE PRECISION VECTORS, C SINGLE PRECISION RESULT. C NRMTYP=1,2,3 CHOOSES MAX-NORM, 2-NORM, R.M.S.-NORM. C--------+---------+---------+---------+---------+---------+---------+-- IF (NRMTYP.EQ.1) THEN DIFNRM = 0.0 DO 20 I = 1, N DIFNRM = AMAX1(DIFNRM,REAL(ABS(A(I)-B(I)))) 20 CONTINUE ELSE DIFNRM = 0.0 DO 40 I = 1, N DIFNRM = DIFNRM + REAL(ABS(A(I)-B(I)))**2 40 CONTINUE C IF (NRMTYP.EQ.2) DIFNRM = SQRT(DIFNRM) IF (NRMTYP.EQ.3) DIFNRM = SQRT(DIFNRM/N) END IF RETURN END C C********+*********+*********+*********+*********+*********+*********+** C SUBROUTINE STATS(X,Y,ERRBND,ERREST) C C********+*********+*********+*********+*********+*********+*********+** C STATS 'INSTRUMENTS' THE ODE-SOLVER BEING TESTED, BY COMPUTING C THE DEVIATION OF THE SOLUTION COMPUTED IN ROUTINE METHOD FROM C THE 'TRUE' GLOBAL AND LOCAL SOLUTIONS IF REQUESTED, AND BY C ACCUMULATING VARIOUS ASSOCIATED STATISTICS. IT ALSO PERFORMS C VARIOUS INITIALIZATION DUTIES, DEPENDING ON THE VALUE OF IFLAG C ON ENTRY. C C ON ENTRY C X,Y - MUST HOLD 'SOLVER' SOLUTION AT CURRENT STEP C ERREST- MUST HOLD ESTIMATED LOCAL ERROR VECTOR AT THIS STEP C DEFINED AS (COMPUTED Y) - (TRUE LOCAL SOLUTION AT NEW X). C SINCE ABSOLUTE ERROR-CONTROL IS SPECIFIED, THIS IS THE C VECTOR WHOSE NORM IS MAINTAINED BELOW ERRBND BY 'METHOD'. C IT IS ASSUMED THAT 'METHOD' USES ONE OF THE 3 NORMS C OFFERED BY THE PACKAGE, AND NRMTYP MUST BE SET SUITABLY. C ERRBND- MUST HOLD TOLERANCE BELOW WHICH THE NORM OF ERREST IS C BEING HELD AT THIS STEP. USUALLY SAME AS ERRTOL BUT WILL C BE DIFFERENT AND VARY WITH STEPSIZE IF (EG) A PER-UNIT- C STEP ERROR CRITERION IS USED. C C STORAGE FOR VARIOUS SOLUTIONS: C X,Y - CURRENT SOLUTION COMPUTED BY METHOD, PASSED IN C VIA ARGUMENT LIST. C XOLD,YOLD- VALUES OF X,Y AT AN OLD MESHPOINT OF METHOD, C USUALLY THE LAST ONE BUT OLDER IF A LUMPED C STEP IS BEING FORMED (SEE BELOW). C IF IFLAG = 0, NEITHER XOLD NOR YOLD IS USED. C YOLD IS NOT USED UNLESS STATISTICS ON LOCAL ERROR C ARE BEING COMPILED (IFLAG=3 AND OPT=3). C THE 'TRUE' LOCAL SOLUTION IS OBTAINED BY INTEG- C RATING FROM XOLD,YOLD TO THE CURRENT X. C XOLD,YOLD ARE USED AS THE ACTUAL ARGUMENTS IN THIS C INTEGRATION, AND ARE THEN UPDATED TO HOLD X,Y IN C PREPARATION FOR NEXT CALL TO STATS. C XT - LAST MESHPOINT OF METHOD. C XOLDG - INDEP VAR FOR 'TRUE' GLOBAL SOLUTION, IN COMMON. C YOLDG - 'TRUE' GLOBAL SOLUTION AT XOLDG, HELD IN COMMON. C UPDATED BY CALLING TRUE AT EACH CALL TO STATS IF C DETAILED STATISTICS ARE BEING COMPILED (IFLAG = 3) C YSTAR - ONLY USED IF OPT.EQ.4. IF SOLVER DOES NOT DO LOCAL C EXTRAPOLATION, WE FORM THE LOCALLY EXTRAPOLATED C SOLUTION IN YSTAR. C--------+---------+---------+---------+---------+---------+---------+-- C C--------+---------+---------+---------+---------+---------+---------+-- C COMMON AREAS C--------+---------+---------+---------+---------+---------+---------+-- C1 C2 C3 C4 C6 C .. Scalar Arguments .. REAL ERRBND, X C .. Array Arguments .. REAL ERREST(51), Y(51) C .. Scalars in Common .. REAL ERLUMP, ERRTOL, HSTART, PRECIS, XEND, XFIN, XOLD, * XOLD1, XOLDG, XT, XTRUE REAL GEMX, GEND, LEMXSC, OVHD, TIME, TRUTIM INTEGER ID, IFLAG, INDG, INDL, IOUT, IWT, N, NBAD, NDCV, * NFCN, NFCN1, NRMTYP, NSTART, NSTL, NSTP, NTRU, * OPT, XTRAP C .. Arrays in Common .. REAL CG(24), WG(51,9), YOLD(51), YOLDG(51) C .. Local Scalars .. REAL HLUMP, HMIN, YNORM REAL ESTSC, LEERSC, LESC, TRUT0 INTEGER I, NDIM, NNFCN C .. Local Arrays .. REAL CL(24), WL(51,9), YSTAR(51), ZERO(51) C .. External Functions .. REAL CLOCK, CONST, DIFNRM EXTERNAL CLOCK, CONST, DIFNRM C .. External Subroutines .. EXTERNAL FCN2, PLOT, TRUE C .. Intrinsic Functions .. INTRINSIC AMAX1, ABS C .. Common blocks .. COMMON /NSCOM1/ERRTOL, OPT, NRMTYP, XTRAP, ID, IWT, IOUT COMMON /NSCOM2/XEND, HSTART, N, IFLAG, INDL, INDG COMMON /NSCOM3/XFIN, XTRUE, TIME, OVHD, TRUTIM, GEND, * GEMX, LEMXSC, NFCN, NSTP, NSTL, NDCV, NBAD, NTRU, * NSTART COMMON /NSCOM4/XOLD1, XOLD, YOLD, XOLDG, YOLDG, CG, WG, * XT, PRECIS, ERLUMP COMMON /NSCOM6/NFCN1 C .. Data statements .. CE C DATA NDIM/51/, ZERO/51*0./ C .. Executable Statements .. C C--------+---------+---------+---------+---------+---------+---------+-- C IF IFLAG = 0 METHOD IS BEING TIMED. C--------+---------+---------+---------+---------+---------+---------+-- IF (IFLAG.EQ.0) RETURN C C--------+---------+---------+---------+---------+---------+---------+-- C IF IFLAG = 1 INITIALIZE VARIABLES TO DO WITH FINDING FIRST STEP- C SIZE, ASSESSING LUMPED STEPS AND COMPUTING TRUE GLOBAL SOLUTION. C RESET INDL, OTHERWISE A LOCAL FAILURE (INDL<0) ON A PREVIOUS C INTEGRATION WILL BE DEEMED A FAILURE ON THIS ONE. C 1ST 9 ELEMENTS OF CG MUST BE INITIALIZED; WE INITIALIZE C MORE TO AID DIAGNOSTICS. C--------+---------+---------+---------+---------+---------+---------+-- IF (IFLAG.NE.1) GO TO 60 C C FOR EVALUATING PERFORMANCE OF 'TRUE': C CALL TRUCHK(1,IDUM) PRECIS = 1000.*CONST(1) ERLUMP = 0. XOLD1 = X XOLD = X XOLDG = X XT = X DO 20 I = 1, N YOLD(I) = Y(I) YOLDG(I) = Y(I) 20 CONTINUE DO 40 I = 1, 24 CG(I) = 0. 40 CONTINUE CG(1) = 1. CG(7) = 200. INDG = 2 INDL = 2 RETURN C--------+---------+---------+---------+---------+---------+---------+-- C IF IFLAG = 2 DETERMINE THE INITIAL STEPSIZE FOR C THE INTEGRATION PROPER. WE CHOOSE THE SECOND STEP C TAKEN AND TERMINATE THE INTEGRATION BY SETTING X C EQUAL TO XEND. HSTART THEN HOLDS THE CURRENT STEPSIZE. C--------+---------+---------+---------+---------+---------+---------+-- 60 IF (IFLAG.NE.2) GO TO 80 NSTP = NSTP + 1 HSTART = X - XOLD1 XOLD1 = X IF (NSTP.GE.2) X = XEND RETURN C C C--------+---------+---------+---------+---------+---------+---------+-- C IF IFLAG = 3 COMPILE STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- C C IF THE STEPSIZE AND, HENCE, THE ERROR REQUIREMENT WAS C TOO SMALL TO PERMIT AN EFFECTIVE ASSESSMENT AT THIS C PRECISION, CONTINUE THE INTEGRATION. A LUMPED ERROR C ESTIMATE IS FORMED IN ERLUMP AND SEVERAL SMALL STEPS C ASSESSED AS ONE. C THE TEST FOR THE SIZE OF A LUMPED STEP IS MATCHED TO THE C MINIMUM STEPSIZE TEST IN 'TRUE' AND IS INTENDED TO ENSURE C (VERY CONSERVATIVELY) THAT ROUNDOFF EFFECTS ARE NEGLIGIBLE. C MAX-NORM IS USED IRRESPECTIVE OF THE VALUE OF NRMTYP IN /NSCOM1/. C THE LUMPED LOCAL ERROR IS TAKEN SIMPLY AS THE SUM OF THE C INDIVIDUAL LOCAL ERRORS. C--------+---------+---------+---------+---------+---------+---------+-- 80 CONTINUE NSTP = NSTP + 1 HLUMP = X - XOLD ERLUMP = ERLUMP + ERRBND XT = X YNORM = 0. DO 100 I = 1, N YNORM = AMAX1(YNORM,ABS(YOLDG(I)),ABS(Y(I))) 100 CONTINUE IF (HLUMP*ERRTOL.GE.YNORM*PRECIS) GO TO 120 C WRITE(6,998)XOLD,X,HLUMP,ERREST,ERRBND,NSTL,NSTP C998 FORMAT(1H0,'XOLD X HLUMP ERREST ERRBND NSTL NSTP=', C * 1P5D12.4,2I4) RETURN C C--------+---------+---------+---------+---------+---------+---------+-- C A SUFFICIENTLY LARGE LUMPED STEP HAS BEEN FORMED. C INCREMENT THE LUMPED STEP COUNT. C--------+---------+---------+---------+---------+---------+---------+-- 120 CONTINUE NSTL = NSTL + 1 C--------+---------+---------+---------+---------+---------+---------+-- C GLOBAL ASSESSMENT C SAVE COUNTERS THAT WILL BE AFFECTED BY 'TRUE' CALLS. SET MAX C STEPSIZE FOR GLOBAL SOLUTION TO X-XOLDG (DEFAULT VALUE IN TRUE IS C SIMPLY 2.) C CONTINUE TRUE GLOBAL SOLUTION TO CURRENT MESHPOINT AND C UPDATE MAX GLOBAL ERROR GEMX. C IF FAILURE OCCURS, RECORD POSITION IN XTRUE AND SKIP LOCAL C ASSESSMENT ALSO. C--------+---------+---------+---------+---------+---------+---------+-- IF (OPT.LT.2 .OR. INDG.LT.0) GO TO 240 NNFCN = NFCN1 HMIN = 10.*AMAX1(1.E-30,CONST(1)*ABS(X)) CG(3) = HMIN CG(6) = 1.1*(X-XOLDG) TRUT0 = CLOCK(0.) C CALL TRUE(N,FCN2,XOLDG,YOLDG,X,1.E-2*ERRTOL,INDG,CG,NDIM,WG) C TRUTIM = TRUTIM + CLOCK(TRUT0) CG(7) = CG(24) + 200. IF (INDG.GE.0) GO TO 140 XTRUE = XOLDG C WRITE(6,999)CG C999 FORMAT(1H0,'TRUE FAILURE, C ='/ C * (1H0,1P10D12.4)) GO TO 220 140 GEMX = AMAX1(GEMX,DIFNRM(Y,YOLDG,N)) C--------+---------+---------+---------+---------+---------+---------+-- C LOCAL ASSESSMENT C OBTAIN THE LOCAL SOLUTION THROUGH THE PREVIOUS COMPUTED C MESH VALUE TO HIGHER ACCURACY THAN METHOD, PROVIDED NO C FAILURES HAVE OCCURRED IN PREVIOUS CALLS TO TRUE (INDL.GE.0). C THE STARTING STEP FOR TRUE IS TAKEN AS .8 * THE LAST RECOMM- C ENDED STEPSIZE OF THE GLOBAL SOLUTION. C CHECK FOR A FAILURE THIS TIME AFTER THE C CALL TO TRUE. COMPILE THE RELIABILITY STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- IF (OPT.LT.3 .OR. INDL.LT.0) GO TO 220 DO 160 I = 1, 9 CL(I) = 0. 160 CONTINUE INDL = 2 CL(1) = 1. CL(3) = HMIN CL(4) = 0.8*CG(14) CL(6) = 1.1*(X-XOLD) CL(7) = 200. TRUT0 = CLOCK(0.) C CALL TRUE(N,FCN2,XOLD,YOLD,X,1.E-2*ERLUMP,INDL,CL,NDIM,WL) C TRUTIM = TRUTIM + CLOCK(TRUT0) XTRUE = XOLD C IF(INDL.LT.0)WRITE(6,999)CL IF (INDL.LT.0) GO TO 220 C--------+---------+---------+---------+---------+---------+---------+-- C UPDATE STATISTICS C LESC RECORDS THE RATIO OF THE MAGNITUDE OF THE TRUE C LOCAL ERROR TO THE ASSUMED LOCAL ERROR BOUND. C LEMXSC RECORDS ITS MAXIMUM OVER THE RANGE. C NTRU COUNTS THE NO. OF LUMPED STEPS OF METHOD ON WHICH C LOCAL ASSESSMENT SUCCEEDED, SO AS TO ALLOW SUMMARY OF PARTIAL C RESULTS IF TRUE FAILS AT SOME POINT. C C IF OPT=4, DO THE ANALYSIS OF THE LOCAL ERROR ESTIMATE VECTOR, C ERREST, BY FORMING THE SCALED ||ERROR|| IN ERREST. IF LOCAL C EXTRAPOLATION IS DONE THIS IS LESC=||ERREST||/ERLUMP. IF NOT, C FORM YSTAR=LOCALLY EXTRAPOLATED SOLUTION AND IT IS THEN C ||YSTAR-YOLD||/ERLUMP. FORM A POINT ON THE SCATTER DIAGRAM C OF ERROR IN ERREST (VERT AXIS) VS. ERREST (HORIZ AXIS) C AND ENTER IT BY A CALL TO 'PLOT'. C--------+---------+---------+---------+---------+---------+---------+-- C C FOR EVALUATING PERFORMANCE OF 'TRUE': C CALL TRUCHK(3,INFL) LESC = DIFNRM(Y,YOLD,N)/ERLUMP LEMXSC = AMAX1(LEMXSC,LESC) IF (LESC.GT.1.0) NDCV = NDCV + 1 IF (LESC.GT.5.0) NBAD = NBAD + 1 IF (OPT.EQ.4) THEN C XTRAP=1 OR 0 ACCORDING AS THE USER HAS TOLD THE PACKAGE THAT C LOCAL EXTRAPOLATION IS OR IS NOT BEING DONE BY SOLVER: IF (XTRAP.EQ.0) THEN DO 180 I = 1, N YSTAR(I) = Y(I) - ERREST(I) 180 CONTINUE LEERSC = DIFNRM(YSTAR,YOLD,N)/ERLUMP ELSE LEERSC = LESC END IF ESTSC = DIFNRM(ERREST,ZERO,N)/ERLUMP CALL PLOT(ESTSC,LEERSC,1) C WRITE(IOUT,'('' STEP NO'',I4,'', X = '',F14.10, C 1 '', BOUND IE. ERLUMP = '',1PE10.3)') NSTP,X,ERLUMP C WRITE(IOUT,'('' I TRUE LE EST LE '', C 1 ''LE IN UNEXTRAP'')') C DO 95 I=1,N C95 WRITE(IOUT,'(1X,I3,3F14.10)') I,Y(I)-YOLD(I),ERREST(I) C * ,LERR(I) END IF C NTRU = NTRU + 1 C--------+---------+---------+---------+---------+---------+---------+-- C UPDATE MEMORY OF LAST COMPUTED VALUES. C--------+---------+---------+---------+---------+---------+---------+-- DO 200 I = 1, N YOLD(I) = Y(I) 200 CONTINUE C--------+---------+---------+---------+---------+---------+---------+-- C RESTORE THE COUNTS AFFECTED BY 'TRUE' CALLS. C--------+---------+---------+---------+---------+---------+---------+-- 220 NFCN1 = NNFCN C--------+---------+---------+---------+---------+---------+---------+-- C RE-INITIALIZE THE DATA PERTAINING TO A LUMPED STEP. C--------+---------+---------+---------+---------+---------+---------+-- 240 ERLUMP = 0. XOLD = X C--------+---------+---------+---------+---------+---------+---------+-- C RETURN TO METHOD TO CONTINUE THE INTEGRATION. C--------+---------+---------+---------+---------+---------+---------+-- RETURN END SUBROUTINE PLOT(X,Y,IFLAG) C ROUTINE TO FORM PLOTS OF LOCAL ERROR INFORMATION FOR DETEST, USING C AN ARRAY K WHICH IS IN 'SAVE' STORAGE. C C IF IFLAG<=0, IT RESETS ARRAY K TO ZERO. C C IF IFLAG=1, THE ROUTINE ENTERS (X,Y) ON THE SCATTER-DIAGRAM C REPRESENTED BY K. HERE X,Y ARE >= 0, AND THE RANGE 0 TO INFINITY IS C SPLIT INTO CLASS-INTERVALS NUMBERED I = NLO .. NHI, THE I-TH INTERVAL C BEING 2**(I-1) <= X < 2**I EXCEPT THAT THE NLO-TH ONE INCLUDES ALL C X BELOW 2**NLO AND THE NHI-TH INCLUDES ALL X >=2**(NHI-1). C C IF IFLAG=2, THE SCATTER DIAGRAM IS PRINTED OUT. C C NOTE: IF IMPLEMENTER WISHES TO ALTER NLO, NHI THEN THE DATA C STATEMENTS MUST BE ALTERED CORRESPONDINGLY. C CERR CHARACTER STR3*3, LINE*LINLEN, LINE1*LINLEN, LINE2*LINLEN, CERR * LINE3*LINLEN, LINE4*LINLEN C .. Parameters .. INTEGER NLO, NHI REAL ALOG2 INTEGER NMIN, LINLEN REAL XYMIN PARAMETER (NLO=-7,NHI=4,ALOG2=.69314718,NMIN=NLO-1, * LINLEN=3*(NHI-NLO+1)+1,XYMIN=2.**NMIN) C .. Scalar Arguments .. REAL X, Y INTEGER IFLAG C .. Local Scalars .. REAL C, P, T INTEGER I, IOUT, J, JL, KMAX, KTOT CHARACTER*(LINLEN) LINE CHARACTER*(LINLEN) LINE1 CHARACTER*(LINLEN) LINE2 CHARACTER*(LINLEN) LINE3 CHARACTER*(LINLEN) LINE4 C .. Local Arrays .. INTEGER K(NLO:NHI,NLO:NHI) C .. External Functions .. REAL CONST CHARACTER*3 STR3 EXTERNAL CONST, STR3 C .. Intrinsic Functions .. INTRINSIC ALOG, MAX, MIN, NINT C .. Statement Functions .. INTEGER ICLAS, ICLAS0 C .. Save statement .. SAVE K, KTOT, KMAX, IOUT C .. Data statements .. DATA LINE1/'+--+--+--+--+--+--+--+--+--+--+--+--+'/, * LINE2/'+ +'/, * LINE3/'| |'/, * LINE4/' 2 2 2 2 2 2 2 2 2 2 2 '/ C .. Executable Statements .. C C C .. Statement Function definitions .. ICLAS0(T) = NMIN + NINT(ALOG(MAX(1.,T/XYMIN))/ALOG2) ICLAS(T) = MIN(MAX(ICLAS0(T),NLO),NHI) IF (IFLAG.LE.0) THEN IOUT = CONST(3) KTOT = 0 KMAX = 0 DO 40 I = NLO, NHI DO 20 J = NLO, NHI K(I,J) = 0 20 CONTINUE 40 CONTINUE ELSE IF (IFLAG.EQ.1) THEN IF (X.LT.0. .OR. Y.LT.0.) THEN WRITE (IOUT,FMT=*) * ' ERROR IN ARGUMENTS TO DETEST PLOT ROUTINE', X, Y STOP END IF I = ICLAS(X) J = ICLAS(Y) K(I,J) = K(I,J) + 1 KTOT = KTOT + 1 KMAX = MAX(KMAX,K(I,J)) ELSE C = KTOT DO 80 I = NHI, NLO, -1 LINE = LINE3 DO 60 J = NLO, NHI JL = J - NLO CERR8 LINE(3*JL+1:3*JL+3) = STR3(K(J,I)/C) P = K(J,I)/C LINE(3*JL+1:3*JL+3) = STR3(P) 60 CONTINUE IF (LINE(1:1).EQ.' ') LINE(1:1) = '|' IF (I.EQ.NHI) THEN WRITE (IOUT,FMT='(1X,15X,''INFINITY '',A)') LINE1 WRITE (IOUT,FMT='(1X,20X,'' '',A)') LINE ELSE WRITE (IOUT,FMT='(1X,15X,I8,1X,A)') I, LINE2 WRITE (IOUT,FMT='(1X,20X,''2 '',A)') LINE END IF 80 CONTINUE WRITE (IOUT,FMT='(1X,24X,A)') LINE1 WRITE (IOUT,FMT='(/1X,25X,30I3)') (J,J=NLO,NHI-1) WRITE (IOUT,FMT='(1X,24X,A)') LINE4 END IF RETURN END CHARACTER*3 FUNCTION STR3(P) C CONVERTS P (MEANT TO BE IN RANGE 0 TO 1) TO A 3 CHARACTER C INTEGER PERCENTAGE. P=0 BECOMES ' ', 0-+ | +------+ | being | | | | | tested)| | | | +--------+ |---FCN,PDERV | | | | STATS---TRUE--->--+ | +----EVALU * We acknowledge valuable recommendations in Shampine's paper [5]. In particular the package will, by default, integrate each system in scaled form, scaling each solution component by its maximum observed value over the range of integration. That is, the change of variable -1 z = D y is done where D = diag(w(1), .., w(n)) * and w(i) =max |i-th component of y| over the range. The problem -1 solved is then z' = D f(x,Dz). The weights w(i) were found by an accurate integration of each problem and are embedded in IVALU. Note that this scaling affects the norms which are used in measuring all errors, and thus can have a considerable effect on the accuracy in some of the problems. * If the problem code in IDLIST (see below) is given a negative sign the system is solved in its 'natural' scaling, as was done in the 1975 version of DETEST. * * References ----------- * [1] W H Enright, 'Using a testing package for the automatic assessment of numerical methods for ODEs', in Performance Evaluation of Numerical Software, (Fosdick, ed), IFIP, North Holland Publ Co (1979) 199-213. * * [2] W H Enright and T E Hull, 'Comparing numerical methods for the solution of stiff systems of ODEs arising in chemistry', in Numerical Methods for Differential Systems (Lapidus and Schiesser, eds), Academic Press, New York (1976) 45-65. * [3] W H Enright, T E Hull and B Lindberg, 'Comparing numerical methods for stiff systems of ordinary differential equations', BIT 15(1975) 10-48. * [4] W H Enright and J D Pryce, 'A pair of packages for assessing initial value methods', University of Toronto Technical Report no. 167/83. * [5] L F Shampine 'Evaluation of a test set for stiff ODE solvers', TOMS 7(1981)409-420. * * * * * * * * 2. Arguments to STDTST: --------- -- ------- * TITLE (input) Character of length 80, holds name of method being tested. * OPTION (input) Integer array of length 10, only elements 1 to 3 are used and are referred to henceforth as OPT, NORMEF and NRMTYP. (OPTION(4) is also used when OPT=4) * OPT one of 1, 2, 3 or 4. OPT selects level of analysis required: 1 gives a report of the following at each tolerance used: - Total time per integration - Overhead time excluding function and Jacobian calls and matrix factorizations. - Number of function calls, Jacobian calls, matrix factorizations and successful steps over range - Global error at endpoint XEND, divided by TOL, ie. ||(computed y) - (true y)||/TOL at x=XEND The norm used throughout the package is that chosen by NRMTYP. * 2 reports (in addition to the above statistics): - Maximum global error over range. The 'true' solution over the range is obtained by a reliable integrator at a more stringent tolerance. * 3 reports (in addition to the above): - Maximum local error over range, ie. max over all meshpoints of LENRM = ||(computed y) - yloc||/ERRBND where yloc is the true local solution through the previous meshpoint, and ERRBND, the assumed error bound, is explained below. - Fraction of steps where LENRM exceeded 1. - Fraction of steps where LENRM exceeded 5. * 4 reports (in addition to the above): - An analysis of the local error estimates used by SOLVER as the basis for its error control. At this level three assumptions are made. First, that at each step SOLVER forms two approximations, y and y*, to the local solution yloc at the new meshpoint, such that asymptotically as TOL->0, y* is 'more accurate' than y. Second, that the approximation which is taken as the computed solution at the new meshpoint is either always y* (in which case one says local extrapolation is used) or always y (in which case it is not used). The vector LE = y - yloc is the true local error in the 'less accurate' solution y, and ERREST = y - y* is an estimate of LE. It is assumed finally that the error control consists in keeping ||ERREST||, in an appropriate norm, below ERRBND at each step. * Note that some methods, such as (in the nonstiff case) Merson's method, cannot be regarded in this way. * At this level DETEST analyses how accurately ERREST approximates to LE, by forming a scatter plot of the values of r1 = ||ERREST - LE||/ERRBND (vertical axis) against r2 = ||ERREST||/ERRBND (horizontal) at each step. Note ERREST - LE = -(y* - yloc) = -LE*, say, so that LENRM defined above is r1 if local extrapolation is being done. For an 'ideal' error control strategy, we expect the plotted points to cluster near (1,0) on the graph, whether or not local extrapolation is used. * To use this level of analysis the user must: a) Ensure that the STATS call in METHOD delivers ERREST as defined above (with the correct sign!). b) Set OPTION(4) as follows. =0 Argument Y to STATS is y above (no local extrapolation). =1 Y is y* above (local extrapolation). * For each integration, a scatter plot is produced. Each of the ratios r1, r2 is put into one of 12 class-intervals -7 -7 -6 2 3 3 0<=r<2 , 2 <=r<2 , ..., 2 <=r<2 , 2 <=r= 2, and have a possibly more efficient code to put in its place. NSTL is relevant if you are interested in the algorithms used by the package, specifically the step-lumping process which takes place in STATS at stringent tolerances. * * * * 9. Subroutines in the Package ----------- -- --- ------- * In order of appearance in the files. The list also shows, for each routine, the other package routines and COMMON areas which it uses. A name in parentheses, like (FCN) denotes a routine which is called at one remove (eg. METHOD calls SOLVER which must call FCN) or which is passed as an argument rather than being an external reference (eg. FCN in TRUE). * In CONCLK file CONST calls: none CLOCK calls: none * In STDTST file STDTST calls: PARCHK LSQFIT RATIO EFSTAT CNTROL CONST ; STCOM1 STCOM3 PARCHK calls: none LSQFIT calls: none RATIO calls: none EFSTAT calls: none CNTROL calls: DIFNRM STATS CONST CLOCK IVALU EVALU METHOD PLOT ; STCOM1 STCOM2 STCOM3 STCOM5 STCOM6 DIFNRM calls: none STATS calls: DIFNRM CONST TRUE FCN PDERV PLOT ; STCOM1 STCOM2 STCOM3 STCOM4 STCOM6 PLOT calls: none * In STTRUE file TRUE calls: CONST STEP NEWSTP COEFF DDCOMP DSOLVE (FCN PDERV ) STEP calls: none NEWSTP calls: none COEFF calls: none DDCOMP calls: ; STCOM6 DSOLVE calls: none * In STPROB file IVALU calls: none EVALU calls: none FCN calls: ; STCOM5 STCOM6 PDERV calls: ; STCOM5 STCOM6 * User-supplied METHOD calls: STATS (FCN PDERV ) * * 10. Definition of Common Areas and Dictionary of Data-flow ---------- -- ------ ----- --- ---------- -- --------- * The flow of information between those routines which use COMMON is indicated for each variable by the codes S: the variable is assigned a value (Set) in this routine, possibly by a call to another routine to which the variable is passed as an argument. A: the value is used (Accessed) in this routine. * For counters and similar variables, these codes are used instead of code S: I: the variable is Initialized in this routine. U: the variable is Updated in this routine. * * COMMON /STCOM1/ passes information from STDTST to CNTROL and STATS. * STDTST | CNTROL | | STATS | | | DIFNRM | | | | S A A - ERRTOL DOUBLE. Copy of current error tolerance. S A A - OPT INTEGER. Copy of OPTION(1) argument of STDTST. S - - A NRMTYP INTEGER. Copy of OPTION(3) argument of STDTST. S - A - XTRAP INTEGER. Copy of OPTION(4) argument of STDTST. S A - - ID INTEGER. Internal code of current problem, 1 for A1, ..., 13 for B3, etc. S A - - IWT INTEGER. Flag for scaling (+1: Scaled. -1: Unscaled) S - - - IOUT INTEGER. Standard output unit number. * * * * COMMON /STCOM2/ communicates between CNTROL and STATS. * CNTROL | STATS | | S A XEND DOUBLE. End of integration range of current problem. A S HSTART DOUBLE. Initial stepsize passed to METHOD for integration proper. S A N INTEGER. No. of equations in current problem. S A IFLAG INTEGER. Set by CNTROL to inform STATS what it is to do: =0 METHOD is being timed. =1 Initializing call of STATS from CNTROL to set up STCOM4. =2 Preliminary integration to determine HSTART, aborted after 2 steps. =3 Integration proper, compiling statistics. * * A SA INDL,INDG Error flags for the local and global 'true solutions' obtained by calls to routine TRUE. * * * * * COMMON /STCOM3/ outputs statistics from CNTROL and STATS. * STDTST | CNTROL | | STATS | | | A S - XFIN DOUBLE. Point of failure of METHOD if it doesn't reach XEND. A - S XTRUE DOUBLE. Point of failure of TRUE if any. If both local and global fail, point of global failure is returned. A S - TIME REAL. CPU time for one integration as measured by CLOCK function. A S - OVHD REAL. Equals TIME less estimated cost of FCN, PDERV and matrix factorization calls. A I U TRUTIM REAL. The time spent in calls to TRUE. Not relevant to performance of METHOD but measures the overhead incurred by the testing package when OPT = 2, 3 or 4. Not printed but available. A S - GEND REAL. Norm of global error of METHOD at XEND. * * A I U GEMX REAL. Maximum of global error over all lumped step meshpoints, ie. usually over all meshpoints of METHOD, except when ERRTOL is very small. A I U LEMXSC REAL. Maximum local error in units of ERRBND, over all lumped step meshpoints. A S - NFCN,NJAC,NLUD INTEGER. Copies of NFCN1,NJAC1,NLUD1, see /STCOM5/, /STCOM6/ A I U NSTP INTEGER. Counts (unlumped) steps taken by METHOD in current integration. - I U NSTL INTEGER. Counts lumped steps formed in current integration (see STATS). Not printed but available. A I U NDCV,NBAD INTEGER. Count lumped steps on which SOLVER's local error control was deceived, resp. badly deceived. A I U NTRU INTEGER. Counts lumped steps on which true local solution was successfully computed, hence valid local error statistics obtained. Used in computing 'fraction deceived' information. Reported if different from NSTP. Note NTRU <= NSTL <= NSTP. - S - NSTART INTEGER. No. of FCN calls needed by METHOD to start, ie. to do preliminary integration (2 steps). Not printed out but available. * * COMMON /STCOM4/ is used only by STATS, to preserve information from one call of STATS to another. All variables are set and/or updated in STATS. * XOLD1 DOUBLE. Similar to XOLD but used in preliminary integration. XOLD,YOLD DOUBLE and DOUBLE array. Copy of METHOD's computed solution at end of previous lumped step. Used as actual arguments of TRUE local solution call. XOLDG,YOLDG DOUBLE and DOUBLE array. Hold 'true' global solution updated to end of previous lumped step. Used as actual arguments of TRUE global solution call. CG,PDG,WKG,WG,YPG,INFG Workspace for 'true' global solution. XT DOUBLE. Holds last METHOD meshpoint between calls to STATS. PRECIS DOUBLE. Holds 1000 * (unit roundoff) approx. ERLUMP DOUBLE. Accumulates METHOD's local error estimates to form an estimate over a lumped step. * * COMMON /STCOM5/ passes information between CNTROL and FCN, PDERV, (or any replacements a user may provide for FCN, PDERV). * CNTROL | FCN | | PDERV | | | * S A A WT DOUBLE. Array of weights used to implement the 'scaled' integration option. S A A IWT1,N1,ID1 INTEGER. Copies of IWT,N,ID in /STCOM1/ or /STCOM2/. * * COMMON /STCOM6/ holds counters. They are initialized in CNTROL, saved-and-restored in STATS, and eventually copied by CNTROL to the corresponding variables in /STCOM3/. * CNTROL | STATS | | FCN | | | PDERV | | | | DDCOMP,etc | | | | | * IA AS U - - NFCN1 INTEGER. Counts calls to FCN. IA AS - U - NJAC1 INTEGER. Counts calls to PDERV. IA AS - - U NLUD1 INTEGER. Counts calls to any "O(n cubed)" linear algebra routines which METHOD may employ. In particular it is incremented by the LU decomposition routine DDCOMP which is used by TRUE and is available to the user. * * There is also a COMMON/STCOM7/ used by the dummy (debugging) versions of STDTST and STATS for communication. * C********+*********+*********+*********+*********+*********+*********+** C SUBROUTINE STDTST(TITLE,OPTION,TOL,IDLIST,FLAG) C C********+*********+*********+*********+*********+*********+*********+** C G E N E R A L D O C U M E N T A T I O N C--------+---------+---------+---------+---------+---------+---------+-- C C STIFF DETEST 1986 VERSION C ----- ------ ---- ------- C BY W H ENRIGHT, AND J D PRYCE, C DEPT OF COMPUTER SCIENCE, SCHOOL OF MATHEMATICS C UNIVERSITY OF TORONTO, UNIVERSITY WALK C TORONTO M5S 1A4 BRISTOL BS8 1TW C CANADA ENGLAND C TEL (416) 978-6025 TEL (272) 303335 C C PLEASE INFORM THE AUTHORS OF ANY ERRORS IN CODE OR C DOCUMENTATION. C C 1. GENERAL NOTES C ------- ----- C C STIFF DETEST IS A PACKAGE TO TEST THE PERFORMANCE OF INITIAL-VALUE C CODES FOR STIFF DIFFERENTIAL SYSTEMS. THIS CODE IS A REVISION OF THE C 1975 VERSION, USED TO PRODUCE THE RESULTS REPORTED ON IN [3]. C C A SET OF TEST PROBLEMS, DESCRIBED IN DETAIL IN [2,3], IS INCORPORATED C IN THE STIFF PACKAGE. THE CODE BEING TESTED IS RUN ON A SELECTION OF C THESE PROBLEMS AT VARIOUS TOLERANCES. THE USER SELECTS THE PROBLEMS C AND THE TOLERANCES, AND ALSO ORGANIZES THE PROBLEMS INTO C GROUPS FOR STATISTICAL REPORTING PURPOSES, AT HIS DISCRETION. C C TO TEST A CODE A USER MUST WRITE AN INTERFACE ROUTINE CALLED METHOD, C DESCRIBED BELOW, AND THEN CALL STDTST WITH THE DESIRED OPTIONS. NOTE C THAT STDTST COMES IN A 'SINGLE' AND A 'DOUBLE' PRECISION VERSION FOR C USE ACCORDING AS THE SOFTWARE UNDER TEST IS WRITTEN IN SINGLE OR C DOUBLE PRECISION. THE ARGUMENTS OF STDTST ARE SINGLE PRECISION BUT C METHOD MUST BE IMPLEMENTED IN THE APPROPRIATE PRECISION. C C THE PACKAGE DIVIDES NATURALLY INTO FIVE PARTS: C C STDTST,CNTROL AND VARIOUS SERVICE ROUTINES C ORGANIZE THE ASSEMBLING, COMPUTATION AND REPORTING OF C STATISTICS. C C STATS C IS THE ROUTINE WHICH 'INSTRUMENTS' THE CODE BEING TESTED AND C PASSES STATISTICS VIA COMMON TO CNTROL AND STDTST. C C FCN, PDERV, IVALU, EVALU C DESCRIBE THE SET OF TEST PROBLEMS. FCN GIVES THE R.H.S. F(Y) C OF THE ODE SYSTEM AND PDERV GIVES THE JACOBIAN MATRIX DF/DY. C (AT PRESENT ALL THE PROBLEMS ARE POSED IN AUTONOMOUS FORM). C IVALU GIVES THE INITIAL CONDITIONS, SCALING WEIGHTS AND OTHER C DATA ABOUT EACH PROBLEM. EVALU GIVES ACCURATELY COMPUTED C VALUES AT THE ENDPOINT. C C DDCOMP AND DSOLVE C ARE STANDARD (DOUBLE PRECISION) LU DECOMPOSITION AND BACKSOLVE C ROUTINES FOR FULL MATRICES, COMPATIBLE WITH THE LAYOUT OF THE C JACOBIAN PRODUCED BY PDERV. THEY ARE USED BY TRUE BUT ARE C AVAILABLE FOR USE BY THE CODE BEING TESTED IF DESIRED. C C TRUE AND ITS SUBORDINATE ROUTINES C (ALIAS THE ADDISON-ENRIGHT CODE SECDER) FORM A RELIABLE STIFF C SOLVER FOR COMPUTING THE 'TRUE' GLOBAL AND LOCAL SOLUTIONS C WHEN REQUIRED. C C THERE IS ALSO A 'DUMMY' STDTST AND STATS TO HELP THE USER DEBUG HIS C METHOD ROUTINE (DESCRIBED BELOW); A UTILITY STGTIM WHICH MUST BE USED C ON EACH NEW MACHINE TO GENERATE TIMING DATA EMBEDDED IN THE CODE; AND C A UTILITY STGWT WHICH IS NEEDED IF EVER A USER WISHES TO ADD FURTHER C TEST PROBLEMS TO THE SET. C C MAIN LINES OF CALLING HIERARCHY (USER-SUPPLIED ROUTINES ARE IN BOXES) C C +--------+ C | USER'S |---STDTST---CNTROL-----IVALU C |PROGRAM | | +--------+ C +--------+ | +------+ |'SOLVER'| C |---|METHOD|----|(CODE |->-+ C | +------+ | BEING | | C | | | TESTED)| | C | | +--------+ |---FCN,PDERV C | | | C | STATS---TRUE--->--+ C | C +----EVALU C C WE ACKNOWLEDGE VALUABLE RECOMMENDATIONS IN SHAMPINE'S PAPER [5]. IN C PARTICULAR THE PACKAGE WILL, BY DEFAULT, INTEGRATE EACH SYSTEM IN C SCALED FORM, SCALING EACH SOLUTION COMPONENT BY ITS MAXIMUM OBSERVED C VALUE OVER THE RANGE OF INTEGRATION. THAT IS, THE CHANGE OF VARIABLE C -1 C Z = D Y IS DONE WHERE C D = DIAG(W(1), .., W(N)) C C AND W(I) =MAX |I-TH COMPONENT OF Y| OVER THE RANGE. THE PROBLEM C -1 C SOLVED IS THEN Z' = D F(X,DZ). THE WEIGHTS W(I) WERE FOUND BY AN C ACCURATE INTEGRATION OF EACH PROBLEM AND ARE EMBEDDED IN IVALU. C NOTE THAT THIS SCALING AFFECTS THE NORMS WHICH ARE USED IN C MEASURING ALL ERRORS, AND THUS CAN HAVE A CONSIDERABLE EFFECT ON THE C ACCURACY IN SOME OF THE PROBLEMS. C C IF THE PROBLEM CODE IN IDLIST (SEE BELOW) IS GIVEN A NEGATIVE SIGN THE C SYSTEM IS SOLVED IN ITS 'NATURAL' SCALING, AS WAS DONE IN THE 1975 C VERSION OF DETEST. C C C REFERENCES C ----------- C C [1] W H ENRIGHT, 'USING A TESTING PACKAGE FOR THE AUTOMATIC C ASSESSMENT OF NUMERICAL METHODS FOR ODES', IN PERFORMANCE C EVALUATION OF NUMERICAL SOFTWARE, (FOSDICK, ED), IFIP, NORTH C HOLLAND PUBL CO (1979) 199-213. C C C [2] W H ENRIGHT AND T E HULL, 'COMPARING NUMERICAL METHODS FOR THE C SOLUTION OF STIFF SYSTEMS OF ODES ARISING IN CHEMISTRY', IN C NUMERICAL METHODS FOR DIFFERENTIAL SYSTEMS (LAPIDUS AND C SCHIESSER, EDS), ACADEMIC PRESS, NEW YORK (1976) 45-65. C C [3] W H ENRIGHT, T E HULL AND B LINDBERG, 'COMPARING NUMERICAL C METHODS FOR STIFF SYSTEMS OF ORDINARY DIFFERENTIAL EQUATIONS', C BIT 15(1975) 10-48. C C [4] W H ENRIGHT AND J D PRYCE, 'A PAIR OF PACKAGES FOR ASSESSING C INITIAL VALUE METHODS', UNIVERSITY OF TORONTO TECHNICAL REPORT C NO. 167/83. C C [5] L F SHAMPINE 'EVALUATION OF A TEST SET FOR STIFF ODE SOLVERS', C TOMS 7(1981)409-420. C C C C C C C C C 2. ARGUMENTS TO STDTST: C --------- -- ------- C C TITLE (INPUT) CHARACTER OF LENGTH 80, HOLDS NAME OF METHOD BEING C TESTED. C C OPTION (INPUT) INTEGER ARRAY OF LENGTH 10, ONLY ELEMENTS 1 TO 3 ARE C USED AND ARE REFERRED TO HENCEFORTH AS OPT, NORMEF AND NRMTYP. C (OPTION(4) IS ALSO USED WHEN OPT=4) C C OPT ONE OF 1, 2, 3 OR 4. OPT SELECTS LEVEL OF ANALYSIS REQUIRED: C 1 GIVES A REPORT OF THE FOLLOWING AT EACH TOLERANCE USED: C - TOTAL TIME PER INTEGRATION C - OVERHEAD TIME EXCLUDING FUNCTION AND JACOBIAN CALLS AND MATRIX C FACTORIZATIONS. C - NUMBER OF FUNCTION CALLS, JACOBIAN CALLS, MATRIX C FACTORIZATIONS AND SUCCESSFUL STEPS OVER RANGE C - GLOBAL ERROR AT ENDPOINT XEND, DIVIDED BY TOL, IE. C ||(COMPUTED Y) - (TRUE Y)||/TOL AT X=XEND C THE NORM USED THROUGHOUT THE PACKAGE IS THAT CHOSEN BY NRMTYP. C C 2 REPORTS (IN ADDITION TO THE ABOVE STATISTICS): C - MAXIMUM GLOBAL ERROR OVER RANGE. THE 'TRUE' SOLUTION OVER C THE RANGE IS OBTAINED BY A RELIABLE INTEGRATOR AT A MORE C STRINGENT TOLERANCE. C C 3 REPORTS (IN ADDITION TO THE ABOVE): C - MAXIMUM LOCAL ERROR OVER RANGE, IE. MAX OVER ALL MESHPOINTS C OF C LENRM = ||(COMPUTED Y) - YLOC||/ERRBND C WHERE YLOC IS THE TRUE LOCAL SOLUTION THROUGH THE PREVIOUS C MESHPOINT, AND ERRBND, THE ASSUMED ERROR BOUND, IS EXPLAINED C BELOW. C - FRACTION OF STEPS WHERE LENRM EXCEEDED 1. C - FRACTION OF STEPS WHERE LENRM EXCEEDED 5. C C 4 REPORTS (IN ADDITION TO THE ABOVE): C - AN ANALYSIS OF THE LOCAL ERROR ESTIMATES USED BY SOLVER AS THE C BASIS FOR ITS ERROR CONTROL. AT THIS LEVEL THREE ASSUMPTIONS C ARE MADE. FIRST, THAT AT EACH STEP SOLVER FORMS TWO C APPROXIMATIONS, Y AND Y*, TO THE LOCAL SOLUTION YLOC AT THE C NEW MESHPOINT, SUCH THAT ASYMPTOTICALLY AS TOL->0, Y* IS 'MORE C ACCURATE' THAN Y. SECOND, THAT THE APPROXIMATION WHICH IS C TAKEN AS THE COMPUTED SOLUTION AT THE NEW MESHPOINT IS EITHER C ALWAYS Y* (IN WHICH CASE ONE SAYS LOCAL EXTRAPOLATION IS USED) C OR ALWAYS Y (IN WHICH CASE IT IS NOT USED). THE VECTOR C LE = Y - YLOC C IS THE TRUE LOCAL ERROR IN THE 'LESS ACCURATE' SOLUTION Y, C AND C ERREST = Y - Y* C IS AN ESTIMATE OF LE. IT IS ASSUMED FINALLY THAT THE ERROR C CONTROL CONSISTS IN KEEPING ||ERREST||, IN AN APPROPRIATE C NORM, BELOW ERRBND AT EACH STEP. C C NOTE THAT SOME METHODS, SUCH AS (IN THE NONSTIFF CASE) C MERSON'S METHOD, CANNOT BE REGARDED IN THIS WAY. C C AT THIS LEVEL DETEST ANALYSES HOW ACCURATELY ERREST C APPROXIMATES TO LE, BY FORMING A SCATTER PLOT OF THE VALUES OF C R1 = ||ERREST - LE||/ERRBND (VERTICAL AXIS) AGAINST R2 = C ||ERREST||/ERRBND (HORIZONTAL) AT EACH STEP. NOTE ERREST - C LE = -(Y* - YLOC) = -LE*, SAY, SO THAT LENRM DEFINED ABOVE IS C R1 IF LOCAL EXTRAPOLATION IS BEING DONE. FOR AN 'IDEAL' ERROR C CONTROL STRATEGY, WE EXPECT THE PLOTTED POINTS TO CLUSTER NEAR C (1,0) ON THE GRAPH, WHETHER OR NOT LOCAL EXTRAPOLATION IS C USED. C C TO USE THIS LEVEL OF ANALYSIS THE USER MUST: C A) ENSURE THAT THE STATS CALL IN METHOD DELIVERS ERREST AS C DEFINED ABOVE (WITH THE CORRECT SIGN!). C B) SET OPTION(4) AS FOLLOWS. C =0 ARGUMENT Y TO STATS IS Y ABOVE (NO LOCAL EXTRAPOLATION). C =1 Y IS Y* ABOVE (LOCAL EXTRAPOLATION). C C FOR EACH INTEGRATION, A SCATTER PLOT IS PRODUCED. EACH OF THE C RATIOS R1, R2 IS PUT INTO ONE OF 12 CLASS-INTERVALS C -7 -7 -6 2 3 3 C 0<=R<2 , 2 <=R<2 , ..., 2 <=R<2 , 2 <=R= 2, AND HAVE A POSSIBLY MORE EFFICIENT C CODE TO PUT IN ITS PLACE. NSTL IS RELEVANT IF YOU ARE C INTERESTED IN THE ALGORITHMS USED BY THE PACKAGE, SPECIFICALLY THE C STEP-LUMPING PROCESS WHICH TAKES PLACE IN STATS AT STRINGENT C TOLERANCES. C C C C C 9. SUBROUTINES IN THE PACKAGE C ----------- -- --- ------- C C IN ORDER OF APPEARANCE IN THE FILES. THE LIST ALSO SHOWS, FOR EACH C ROUTINE, THE OTHER PACKAGE ROUTINES AND COMMON AREAS WHICH IT USES. A C NAME IN PARENTHESES, LIKE (FCN) DENOTES A ROUTINE WHICH IS CALLED AT C ONE REMOVE (EG. METHOD CALLS SOLVER WHICH MUST CALL FCN) OR WHICH IS C PASSED AS AN ARGUMENT RATHER THAN BEING AN EXTERNAL REFERENCE (EG. C FCN IN TRUE). C C IN CONCLK FILE C CONST CALLS: NONE C CLOCK CALLS: NONE C C IN STDTST FILE C STDTST CALLS: PARCHK LSQFIT RATIO EFSTAT CNTROL CONST ; STCOM1 C STCOM3 C PARCHK CALLS: NONE C LSQFIT CALLS: NONE C RATIO CALLS: NONE C EFSTAT CALLS: NONE C CNTROL CALLS: DIFNRM STATS CONST CLOCK IVALU EVALU METHOD PLOT ; C STCOM1 STCOM2 STCOM3 STCOM5 STCOM6 C DIFNRM CALLS: NONE C STATS CALLS: DIFNRM CONST TRUE FCN PDERV PLOT ; STCOM1 STCOM2 C STCOM3 STCOM4 STCOM6 C PLOT CALLS: NONE C C IN STTRUE FILE C TRUE CALLS: CONST STEP NEWSTP COEFF DDCOMP DSOLVE (FCN C PDERV ) C STEP CALLS: NONE C NEWSTP CALLS: NONE C COEFF CALLS: NONE C DDCOMP CALLS: ; STCOM6 C DSOLVE CALLS: NONE C C IN STPROB FILE C IVALU CALLS: NONE C EVALU CALLS: NONE C FCN CALLS: ; STCOM5 STCOM6 C PDERV CALLS: ; STCOM5 STCOM6 C C USER-SUPPLIED C METHOD CALLS: STATS (FCN PDERV ) C C C 10. DEFINITION OF COMMON AREAS AND DICTIONARY OF DATA-FLOW C ---------- -- ------ ----- --- ---------- -- --------- C C THE FLOW OF INFORMATION BETWEEN THOSE ROUTINES WHICH USE COMMON IS C INDICATED FOR EACH VARIABLE BY THE CODES C S: THE VARIABLE IS ASSIGNED A VALUE (SET) IN THIS ROUTINE, POSSIBLY C BY A CALL TO ANOTHER ROUTINE TO WHICH THE VARIABLE IS PASSED AS C AN ARGUMENT. C A: THE VALUE IS USED (ACCESSED) IN THIS ROUTINE. C C FOR COUNTERS AND SIMILAR VARIABLES, THESE CODES ARE USED INSTEAD OF C CODE S: C I: THE VARIABLE IS INITIALIZED IN THIS ROUTINE. C U: THE VARIABLE IS UPDATED IN THIS ROUTINE. C C C COMMON /STCOM1/ PASSES INFORMATION FROM STDTST TO CNTROL AND STATS. C C STDTST C | CNTROL C | | STATS C | | | DIFNRM C | | | | C S A A - ERRTOL DOUBLE. COPY OF CURRENT ERROR TOLERANCE. C S A A - OPT INTEGER. COPY OF OPTION(1) ARGUMENT OF STDTST. C S - - A NRMTYP INTEGER. COPY OF OPTION(3) ARGUMENT OF STDTST. C S - A - XTRAP INTEGER. COPY OF OPTION(4) ARGUMENT OF STDTST. C S A - - ID INTEGER. INTERNAL CODE OF CURRENT PROBLEM, 1 FOR A1, C ..., 13 FOR B3, ETC. C S A - - IWT INTEGER. FLAG FOR SCALING (+1: SCALED. -1: C UNSCALED) C S - - - IOUT INTEGER. STANDARD OUTPUT UNIT NUMBER. C C C C C COMMON /STCOM2/ COMMUNICATES BETWEEN CNTROL AND STATS. C C CNTROL C | STATS C | | C S A XEND DOUBLE. END OF INTEGRATION RANGE OF CURRENT PROBLEM. C A S HSTART DOUBLE. INITIAL STEPSIZE PASSED TO METHOD FOR C INTEGRATION PROPER. C S A N INTEGER. NO. OF EQUATIONS IN CURRENT PROBLEM. C S A IFLAG INTEGER. SET BY CNTROL TO INFORM STATS WHAT IT IS TO C DO: C =0 METHOD IS BEING TIMED. C =1 INITIALIZING CALL OF STATS FROM CNTROL TO SET UP C STCOM4. C =2 PRELIMINARY INTEGRATION TO DETERMINE HSTART, ABORTED C AFTER 2 STEPS. C =3 INTEGRATION PROPER, COMPILING STATISTICS. C C C A SA INDL,INDG C ERROR FLAGS FOR THE LOCAL AND GLOBAL 'TRUE SOLUTIONS' C OBTAINED BY CALLS TO ROUTINE TRUE. C C C C C C COMMON /STCOM3/ OUTPUTS STATISTICS FROM CNTROL AND STATS. C C STDTST C | CNTROL C | | STATS C | | | C A S - XFIN DOUBLE. POINT OF FAILURE OF METHOD IF IT DOESN'T REACH C XEND. C A - S XTRUE DOUBLE. POINT OF FAILURE OF TRUE IF ANY. IF BOTH C LOCAL AND GLOBAL FAIL, POINT OF GLOBAL FAILURE IS C RETURNED. C A S - TIME REAL. CPU TIME FOR ONE INTEGRATION AS MEASURED BY C CLOCK FUNCTION. C A S - OVHD REAL. EQUALS TIME LESS ESTIMATED COST OF FCN, PDERV C AND MATRIX FACTORIZATION CALLS. C A I U TRUTIM REAL. THE TIME SPENT IN CALLS TO TRUE. NOT RELEVANT C TO PERFORMANCE OF METHOD BUT MEASURES THE OVERHEAD C INCURRED BY THE TESTING PACKAGE WHEN OPT = 2, 3 OR 4. C NOT PRINTED BUT AVAILABLE. C A S - GEND REAL. NORM OF GLOBAL ERROR OF METHOD AT XEND. C C C A I U GEMX REAL. MAXIMUM OF GLOBAL ERROR OVER ALL LUMPED STEP C MESHPOINTS, IE. USUALLY OVER ALL MESHPOINTS OF METHOD, C EXCEPT WHEN ERRTOL IS VERY SMALL. C A I U LEMXSC REAL. MAXIMUM LOCAL ERROR IN UNITS OF ERRBND, OVER ALL C LUMPED STEP MESHPOINTS. C A S - NFCN,NJAC,NLUD C INTEGER. COPIES OF NFCN1,NJAC1,NLUD1, SEE /STCOM5/, C /STCOM6/ C A I U NSTP INTEGER. COUNTS (UNLUMPED) STEPS TAKEN BY METHOD IN C CURRENT INTEGRATION. C - I U NSTL INTEGER. COUNTS LUMPED STEPS FORMED IN CURRENT C INTEGRATION (SEE STATS). NOT PRINTED BUT AVAILABLE. C A I U NDCV,NBAD C INTEGER. COUNT LUMPED STEPS ON WHICH SOLVER'S LOCAL C ERROR CONTROL WAS DECEIVED, RESP. BADLY DECEIVED. C A I U NTRU INTEGER. COUNTS LUMPED STEPS ON WHICH TRUE LOCAL C SOLUTION WAS SUCCESSFULLY COMPUTED, HENCE VALID LOCAL C ERROR STATISTICS OBTAINED. USED IN COMPUTING 'FRACTION C DECEIVED' INFORMATION. REPORTED IF DIFFERENT FROM C NSTP. NOTE NTRU <= NSTL <= NSTP. C - S - NSTART INTEGER. NO. OF FCN CALLS NEEDED BY METHOD TO START, C IE. TO DO PRELIMINARY INTEGRATION (2 STEPS). NOT C PRINTED OUT BUT AVAILABLE. C C C COMMON /STCOM4/ IS USED ONLY BY STATS, TO PRESERVE INFORMATION FROM C ONE CALL OF STATS TO ANOTHER. ALL VARIABLES ARE SET AND/OR UPDATED IN C STATS. C C XOLD1 DOUBLE. SIMILAR TO XOLD BUT USED IN PRELIMINARY C INTEGRATION. C XOLD,YOLD C DOUBLE AND DOUBLE ARRAY. COPY OF METHOD'S COMPUTED C SOLUTION AT END OF PREVIOUS LUMPED STEP. USED AS C ACTUAL ARGUMENTS OF TRUE LOCAL SOLUTION CALL. C XOLDG,YOLDG C DOUBLE AND DOUBLE ARRAY. HOLD 'TRUE' GLOBAL SOLUTION C UPDATED TO END OF PREVIOUS LUMPED STEP. USED AS ACTUAL C ARGUMENTS OF TRUE GLOBAL SOLUTION CALL. C CG,PDG,WKG,WG,YPG,INFG C WORKSPACE FOR 'TRUE' GLOBAL SOLUTION. C XT DOUBLE. HOLDS LAST METHOD MESHPOINT BETWEEN CALLS TO C STATS. C PRECIS DOUBLE. HOLDS 1000 * (UNIT ROUNDOFF) APPROX. C ERLUMP DOUBLE. ACCUMULATES METHOD'S LOCAL ERROR ESTIMATES TO C FORM AN ESTIMATE OVER A LUMPED STEP. C C C COMMON /STCOM5/ PASSES INFORMATION BETWEEN CNTROL AND FCN, PDERV, (OR C ANY REPLACEMENTS A USER MAY PROVIDE FOR FCN, PDERV). C C CNTROL C | FCN C | | PDERV C | | | C C S A A WT DOUBLE. ARRAY OF WEIGHTS USED TO IMPLEMENT THE C 'SCALED' INTEGRATION OPTION. C S A A IWT1,N1,ID1 C INTEGER. COPIES OF IWT,N,ID IN /STCOM1/ OR /STCOM2/. C C C COMMON /STCOM6/ HOLDS COUNTERS. THEY ARE INITIALIZED IN CNTROL, C SAVED-AND-RESTORED IN STATS, AND EVENTUALLY COPIED BY CNTROL TO THE C CORRESPONDING VARIABLES IN /STCOM3/. C C CNTROL C | STATS C | | FCN C | | | PDERV C | | | | DDCOMP,ETC C | | | | | C C IA AS U - - NFCN1 INTEGER. COUNTS CALLS TO FCN. C IA AS - U - NJAC1 INTEGER. COUNTS CALLS TO PDERV. C IA AS - - U NLUD1 INTEGER. COUNTS CALLS TO ANY "O(N CUBED)" C LINEAR ALGEBRA ROUTINES WHICH METHOD MAY EMPLOY. IN C PARTICULAR IT IS INCREMENTED BY THE LU DECOMPOSITION C ROUTINE DDCOMP WHICH IS USED BY TRUE AND IS AVAILABLE C TO THE USER. C C C THERE IS ALSO A COMMON/STCOM7/ USED BY THE DUMMY (DEBUGGING) VERSIONS C OF STDTST AND STATS FOR COMMUNICATION. C C--------+---------+---------+---------+---------+---------+---------+-- C E N D O F G E N E R A L D O C U M E N T A T I O N C********+*********+*********+*********+*********+*********+*********+** C C DESCRIPTION OF STDTST C ----------- -- ------ C C ROUTINE STDTST INTERPRETS THE LIST OF TOLERANCES AND LIST OF C GROUPS OF PROBLEMS SPECIFIED IN THE ARGUMENTS. USING CNTROL C TO GATHER INDIVIDUAL STATISTICS FOR ONE PROBLEM AT ONE C TOLERANCE, IT ORGANIZES THE FORMATION AND OUTPUT OF SUMMARY C STATISTICS. C INDIVIDUAL STATISTICS ARE INDEXED OVER TOLERANCES, PROBLEMS C AND GROUPS. C 'PROBLEMS-SUMMARY' MEANS SUM OF THESE OVER PROBLEMS IN A GROUP. C 'GROUPS-SUMMARY' MEANS SUM OF PROBLEMS-SUMMARY OVER ALL GROUPS. C 'OVERALL-SUMMARY' MEANS SUM OF GROUPS-SUMMARIES OVER ALL C TOLERANCES. C (READ 'MAX' FOR 'SUM' IN CASE OF SOME OF THE STATISTICS.) C C LOCAL VARIABLES: C PSNFCN,PSNJAC,... HOLD THE SUMMARY OVER PROBLEMS IN A GROUP C OF NFCN,NJAC,... (SEE DESCRIPTION OF /STCOM3/) AT ALL THE C TOLERANCES USED. C GSNFCN,... HOLD SUMMARY OVER GROUPS OF PSNFCN,... C OSNFCN,... HOLD OVERALL SUMMARY (OVER TOLERANCES) OF GSNFCN,... C C LGTOL HOLDS LOGARITHMS TO BASE 10 OF ELEMENTS OF ARRAY TOL, C AND LGGEMX,LGGEND HOLD LOGARITHMS OF CORRESPONDING GEMX C AND GEND VALUES, USED IN SMOOTHNESS CALCULATIONS. C NSNFCN,... STORE NFCN,... FOR ONE PROBLEM AT ALL TOLERANCES C USED, FOR USE IN NORMALIZED EFFICIENCY CALCULATIONS. C ERFLGE,ERFLG1 FLAG 'MISSING VALUES' IN SMOOTHNESS AND NORMALIZED C EFFICIENCY CALCULATIONS. C C C--------+---------+---------+---------+---------+---------+---------+-- C COMMON AREAS C--------+---------+---------+---------+---------+---------+---------+-- C1 C3 C .. Scalar Arguments .. REAL FLAG CHARACTER*80 TITLE C .. Array Arguments .. REAL TOL(11) INTEGER IDLIST(60), OPTION(10) C .. Scalars in Common .. DOUBLE PRECISION ERRTOL, XFIN, XTRUE REAL GEMX, GEND, LEMXSC, OVHD, TIME, TRUTIM INTEGER ID, IOUT, IWT, NBAD, NDCV, NFCN, NJAC, NLUD, * NRMTYP, NSTART, NSTL, NSTP, NTRU, OPT, XTRAP C .. Local Scalars .. REAL BIG, C, C1, CTEN, CTEN1, DUM, E, E1, FBADEC, * FDECEV, GEMXSC, GENDSC, OSLEMX, OSOVHD, OSTIME, * RES, RES1, TOLK INTEGER CMPLET, I, ICH, IDSUB, IID, INDG1, INDL1, * KCLASS, KGRP, KSYST, KTOL, NGRP, NOK, NOK1, * NORMEF, NSYST, NTOL, OSNBAD, OSNDCV, OSNFCN, * OSNJAC, OSNLUD, OSNSTP, OSNTRU CHARACTER BL CHARACTER*10 IDCLAS CHARACTER*32 MCNAME C .. Local Arrays .. REAL GSLEMX(10), GSOVHD(10), GSTIME(10), LGGEMX(10), * LGGEND(10), LGTOL(10), NSOVHD(10), NSTIME(10), * PSGEMX(10), PSGEND(10), PSLEMX(10), PSOVHD(10), * PSTIME(10) INTEGER GRPLST(2,6), GSNBAD(10), GSNDCV(10), GSNFCN(10), * GSNJAC(10), GSNLUD(10), GSNSTP(10), GSNTRU(10), * NSNFCN(10), NSNJAC(10), NSNLUD(10), NSNSTP(10), * PSNBAD(10), PSNDCV(10), PSNFCN(10), PSNJAC(10), * PSNLUD(10), PSNSTP(10), PSNTRU(10) LOGICAL ERFLG1(10), ERFLGE(10) C .. External Functions .. REAL CONST, RATIO EXTERNAL CONST, RATIO C .. External Subroutines .. EXTERNAL CNTROL, EFSTAT, LSQFIT, PARCHK, PLOT C .. Intrinsic Functions .. INTRINSIC ALOG10, AMAX1, CHAR, DBLE, IABS, ISIGN C .. Common blocks .. COMMON /STCOM1/ERRTOL, OPT, NRMTYP, XTRAP, ID, IWT, * IOUT COMMON /STCOM3/XFIN, XTRUE, TIME, OVHD, TRUTIM, GEND, * GEMX, LEMXSC, NFCN, NJAC, NLUD, NSTP, NSTL, * NDCV, NBAD, NTRU, NSTART C .. Data statements .. CE C DATA IDCLAS/'ABCDEFGHIJ'/, BL/' '/, BIG/1.E20/ C .. Executable Statements .. C C--------+---------+---------+---------+---------+---------+---------+-- C COPY THE ENTRIES IN ARRAY 'OPTION'. C DO DUMMY CALL TO CONST TO INVOKE MACHINE-DEPENDENT INITIALIZ- C ATIONS. SET MACHINE NAME. SET OUTPUT UNIT NUMBER. C WRITE OUTPUT-HEADING. CALL ARGUMENT-CHECKING ROUTINE. C--------+---------+---------+---------+---------+---------+---------+-- OPT = OPTION(1) NORMEF = OPTION(2) NRMTYP = OPTION(3) XTRAP = OPTION(4) DUM = CONST(0) DO 20 I = 1, 32 ICH = CONST(-I) MCNAME(I:I) = CHAR(ICH) 20 CONTINUE IOUT = CONST(3) C WRITE (IOUT,FMT=99999) OPT, NORMEF, NRMTYP, MCNAME C CALL PARCHK(OPT,NORMEF,NRMTYP,TOL,IDLIST,NTOL,NGRP,GRPLST,LGTOL, * FLAG) IF (FLAG.EQ.0.) GO TO 40 WRITE (IOUT,FMT=99998) FLAG RETURN C C--------+---------+---------+---------+---------+---------+---------+-- C INITIALIZE OVERALL- AND GROUPS-SUMMARY STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- 40 OSTIME = 0. OSOVHD = 0. OSNFCN = 0 OSNJAC = 0 OSNLUD = 0 OSNSTP = 0 OSNTRU = 0 OSLEMX = 0. OSNDCV = 0 OSNBAD = 0 DO 60 I = 1, NTOL GSTIME(I) = 0. GSOVHD(I) = 0. GSNFCN(I) = 0 GSNJAC(I) = 0 GSNLUD(I) = 0 GSNSTP(I) = 0 GSNTRU(I) = 0 GSLEMX(I) = 0. GSNDCV(I) = 0 GSNBAD(I) = 0 60 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C LOOP OVER GROUPS OF PROBLEMS C--------+---------+---------+---------+---------+---------+---------+-- C DO 300 KGRP = 1, NGRP C C--------+---------+---------+---------+---------+---------+---------+-- C OUTPUT HEADING, ON NEW PAGE FOR GROUPS AFTER FIRST. C SELECT GROUP OF DIFFERENTIAL EQUATIONS. C GET NO. OF SYSTEMS IN THIS GROUP, & OFFSET FOR C POSITION OF ITEM IN GROUP WITHIN IDLIST. C INITIALIZE PROBLEM SUMMARY STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- IF (KGRP.GT.1) WRITE (IOUT,FMT=99997) WRITE (IOUT,FMT=99996) KGRP, TITLE C NSYST = GRPLST(1,KGRP) IDSUB = GRPLST(2,KGRP) C DO 80 I = 1, NTOL PSTIME(I) = 0. PSOVHD(I) = 0. PSNFCN(I) = 0 PSNJAC(I) = 0 PSNLUD(I) = 0 PSNSTP(I) = 0 PSNTRU(I) = 0 PSLEMX(I) = 0. PSNDCV(I) = 0 PSNBAD(I) = 0 PSGEMX(I) = 0. PSGEND(I) = 0. 80 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C LOOP OVER PROBLEMS WITHIN A GROUP C--------+---------+---------+---------+---------+---------+---------+-- DO 260 KSYST = 1, NSYST C--------+---------+---------+---------+---------+---------+---------+-- C GET NEXT PROBLEM-ID: C EXTRACT THE WEIGHTING OPTION (IWT=1 OR -1). C UNPACK ID INTO CLASSNAME + INDEX WITHIN CLASS AND TRANSLATE C INTO STDTST INTERNAL ID BY SUBTRACTING 10: C--------+---------+---------+---------+---------+---------+---------+-- IDSUB = IDSUB + 1 ID = IDLIST(IDSUB) IWT = ISIGN(1,ID) ID = IABS(ID) KCLASS = (ID-1)/10 IID = ID - 10*KCLASS ID = ID - 10 IF (IWT.GT.0) WRITE (IOUT,FMT=99995) IDCLAS(KCLASS:KCLASS), * IID IF (IWT.LE.0) WRITE (IOUT,FMT=99994) IDCLAS(KCLASS:KCLASS), * IID WRITE (IOUT,FMT=99993) (BL,I=1,OPT) WRITE (IOUT,FMT=99992) (BL,I=1,OPT) C C--------+---------+---------+---------+---------+---------+---------+-- C LOOP OVER TOLERANCES FOR ONE PROBLEM C--------+---------+---------+---------+---------+---------+---------+-- DO 220 KTOL = 1, NTOL C--------+---------+---------+---------+---------+---------+---------+-- C CALL PLOT TO INITIALIZE LOCAL-ERROR SCATTER DIAGRAM C IF OPT=4. C CALL CNTROL TO ORGANIZE THE COLLECTION OF C STATISTICS. C ON EXIT FROM CNTROL THE VALUE OF CMPLET WILL C INDICATE WHETHER A FAILURE OCCURRED. C C CMPLET = 1 NO FAILURES. C CMPLET = 0 DETEST FAILED TO OBTAIN TRUE C LOCAL OR GLOBAL SOLUTION. C CMPLET = -1 METHOD FAILED TO REACH THE END C OF RANGE. C CMPLET = -2 DETEST FAILED AND SUBSEQUENTLY C METHOD FAILED. C CMPLET = -3 METHOD COULD NOT START THE C INTEGRATION. C CMPLET = -4 METHOD COMPLETED THE STATISTICS C GATHERING BUT FAILED IN TIMING LOOP. C C ON EXIT INDG1,INDL1 HOLD EXIT-FLAGS OF 'TRUE' C GLOBAL AND LOCAL SOLUTIONS RESPECTIVELY. C C ERFLGE(KTOL) IS TRUE IF METHOD FAILED TO REACH XEND. C ERFLG1(KTOL) IS TRUE IF EITHER METHOD OR C TRUE-SOLUTION FAILED TO REACH XEND (THUS INVALIDATING C GEMX AS DATA FOR SMOOTHNESS CALC WHEN NORMEF=2 ). C C IF CMPLET IS -4,-2,-1,0 OR 1 PRINT A LINE OF STATISTICS: C IF CMPLET ISNT 1, PRINT AN ERROR MESSAGE. C CALL PLOT TO PRINT LOCAL-ERROR SCATTER DIAGRAM C IF OPT=4 C NOTE IF METHOD FAILED TO REACH XEND, ANY STATISTICS FOR C THIS PROBLEM ARE PRINTED BUT DO NOT CONTRIBUTE TO THE C SUMMARY STATISTICS. CONVERSELY IF METHOD REACHED XEND, C ALL STATISTICS CONTRIBUTE TO THE SUMMARIES THOUGH GEMX, C LEMXSC,NDCV,NBAD,NTRU ONLY APPLY TO PART OF THE RANGE C IF 'TRUE' FAILED. C--------+---------+---------+---------+---------+---------+---------+-- C TOLK = TOL(KTOL) ERRTOL = DBLE(TOLK) IF (OPT.EQ.4) CALL PLOT(0.,0.,0) C CALL CNTROL(CMPLET,INDG1,INDL1) C ERFLGE(KTOL) = CMPLET .LT. 0 .AND. CMPLET .GT. -4 ERFLG1(KTOL) = CMPLET .LT. 1 .AND. CMPLET .GT. -4 GENDSC = BIG IF (ERFLGE(KTOL)) GO TO 100 GENDSC = GEND/TOLK LGGEND(KTOL) = ALOG10(AMAX1(GEND,.01*TOLK)) 100 CONTINUE GEMXSC = GEMX/TOLK FDECEV = RATIO(NDCV,NTRU) FBADEC = RATIO(NBAD,NTRU) C IF (CMPLET.EQ.-3) GO TO 120 IF (OPT.EQ.1) WRITE (IOUT,FMT=99991) LGTOL(KTOL), TIME, * OVHD, NFCN, NJAC, NLUD, NSTP, GENDSC IF (OPT.EQ.2) WRITE (IOUT,FMT=99991) LGTOL(KTOL), TIME, * OVHD, NFCN, NJAC, NLUD, NSTP, GENDSC, GEMXSC IF (OPT.GE.3) WRITE (IOUT,FMT=99991) LGTOL(KTOL), TIME, * OVHD, NFCN, NJAC, NLUD, NSTP, GENDSC, GEMXSC, LEMXSC, * FDECEV, FBADEC IF (OPT.GE.3 .AND. NSTP.NE.NTRU) WRITE (IOUT,FMT=99990) * NTRU 120 CONTINUE C C IF (CMPLET.EQ.-4) WRITE (IOUT,FMT=99989) IF (CMPLET.EQ.-3) WRITE (IOUT,FMT=99988) LGTOL(KTOL) C IF (CMPLET.EQ.-2) WRITE (IOUT,FMT=99987) XTRUE, INDG1, * INDL1, XFIN C IF (CMPLET.EQ.-1) WRITE (IOUT,FMT=99986) XFIN C IF (CMPLET.EQ.0) WRITE (IOUT,FMT=99985) XTRUE, INDG1, * INDL1 C IF (OPT.EQ.4) THEN C WRITE (IOUT,FMT=99984) XTRAP C CALL PLOT(0.,0.,2) END IF C FOR EVALUATING PERFORMANCE OF 'TRUE': C CALL TRUCHK(4,IDUM) C C--------+---------+---------+---------+---------+---------+---------+-- C UPDATE PROBLEMS-SUMMARY STATS IF METHOD REACHED XEND. C (IF IT DIDN'T, DON'T UPDATE THE LOCAL-ASSESSMENT INFO: C NTRU,LEMXSC,NDCV,NBAD. THIS IS AN ARBITRARY CHOICE, IT C MAKES IT SIMPLER TO EXPLAIN TO THE USER. C STORE NORMEF STATISTICS: C--------+---------+---------+---------+---------+---------+---------+-- C IF (ERFLGE(KTOL)) GO TO 180 PSTIME(KTOL) = PSTIME(KTOL) + TIME PSOVHD(KTOL) = PSOVHD(KTOL) + OVHD PSNFCN(KTOL) = PSNFCN(KTOL) + NFCN PSNSTP(KTOL) = PSNSTP(KTOL) + NSTP PSNJAC(KTOL) = PSNJAC(KTOL) + NJAC PSNLUD(KTOL) = PSNLUD(KTOL) + NLUD PSGEND(KTOL) = AMAX1(PSGEND(KTOL),GENDSC) C IF (OPT.LT.2) GO TO 140 PSGEMX(KTOL) = AMAX1(PSGEMX(KTOL),GEMXSC) LGGEMX(KTOL) = ALOG10(AMAX1(GEMX,.01*TOLK)) C 140 IF (OPT.LT.3) GO TO 160 PSNTRU(KTOL) = PSNTRU(KTOL) + NTRU PSLEMX(KTOL) = AMAX1(PSLEMX(KTOL),LEMXSC) PSNDCV(KTOL) = PSNDCV(KTOL) + NDCV PSNBAD(KTOL) = PSNBAD(KTOL) + NBAD 160 CONTINUE 180 CONTINUE C IF (NORMEF.EQ.0) GO TO 200 NSTIME(KTOL) = TIME NSOVHD(KTOL) = OVHD NSNFCN(KTOL) = NFCN NSNSTP(KTOL) = NSTP NSNJAC(KTOL) = NJAC NSNLUD(KTOL) = NLUD 200 CONTINUE C--------+---------+---------+---------+---------+---------+---------+-- C END OF LOOP OVER TOLERANCES FOR ONE PROBLEM C--------+---------+---------+---------+---------+---------+---------+-- 220 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C SMOOTHNESS AND NORMALIZED EFFICIENCY CALCULATIONS BEGIN C--------+---------+---------+---------+---------+---------+---------+-- WRITE (IOUT,FMT=99983) C WRITE (IOUT,FMT=99982) C CALL LSQFIT(LGTOL,LGGEND,ERFLGE,NTOL,NOK,C,E,RES) C CTEN = 10.**C IF (NOK.LE.2) WRITE (IOUT,FMT=99981) NOK C IF (NOK.GT.2) WRITE (IOUT,FMT=99980) CTEN, E, RES, NOK C IF (OPT.LT.2) GO TO 240 WRITE (IOUT,FMT=99979) C CALL LSQFIT(LGTOL,LGGEMX,ERFLG1,NTOL,NOK1,C1,E1,RES1) C CTEN1 = 10.**C1 IF (NOK1.LE.2) WRITE (IOUT,FMT=99981) NOK1 IF (NOK1.GT.2) WRITE (IOUT,FMT=99980) CTEN1, E1, RES1, NOK1 240 CONTINUE C IF (NORMEF.EQ.1) CALL EFSTAT(C,E,LGTOL,NTOL,NOK,ERFLGE, * 'ENDPOINT',IOUT,NSTIME,NSOVHD, * NSNFCN,NSNJAC,NSNLUD,NSNSTP) C IF (NORMEF.EQ.2) CALL EFSTAT(C1,E1,LGTOL,NTOL,NOK1,ERFLG1, * 'MAXIMUM ',IOUT,NSTIME,NSOVHD, * NSNFCN,NSNJAC,NSNLUD,NSNSTP) C C--------+---------+---------+---------+---------+---------+---------+-- C SMOOTHNESS AND NORMALIZED EFFICIENCY CALCULATIONS END C--------+---------+---------+---------+---------+---------+---------+-- C C--------+---------+---------+---------+---------+---------+---------+-- C END OF LOOP OVER PROBLEMS IN A GROUP. C--------+---------+---------+---------+---------+---------+---------+-- 260 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C OUTPUT PROBLEMS-SUMMARY STATISTICS C--------+---------+---------+---------+---------+---------+---------+-- C WRITE (IOUT,FMT=99978) KGRP WRITE (IOUT,FMT=99993) (BL,I=1,OPT) WRITE (IOUT,FMT=99992) (BL,I=1,OPT) DO 280 KTOL = 1, NTOL FDECEV = RATIO(PSNDCV(KTOL),PSNTRU(KTOL)) FBADEC = RATIO(PSNBAD(KTOL),PSNTRU(KTOL)) C IF (OPT.EQ.1) WRITE (IOUT,FMT=99991) LGTOL(KTOL), * PSTIME(KTOL), PSOVHD(KTOL), PSNFCN(KTOL), PSNJAC(KTOL), * PSNLUD(KTOL), PSNSTP(KTOL), PSGEND(KTOL) C IF (OPT.EQ.2) WRITE (IOUT,FMT=99991) LGTOL(KTOL), * PSTIME(KTOL), PSOVHD(KTOL), PSNFCN(KTOL), PSNJAC(KTOL), * PSNLUD(KTOL), PSNSTP(KTOL), PSGEND(KTOL), PSGEMX(KTOL) C IF (OPT.GE.3) WRITE (IOUT,FMT=99991) LGTOL(KTOL), * PSTIME(KTOL), PSOVHD(KTOL), PSNFCN(KTOL), PSNJAC(KTOL), * PSNLUD(KTOL), PSNSTP(KTOL), PSGEND(KTOL), PSGEMX(KTOL), * PSLEMX(KTOL), FDECEV, FBADEC C IF (OPT.GE.3 .AND. PSNSTP(KTOL).NE.PSNTRU(KTOL)) * WRITE (IOUT,FMT=99990) PSNTRU(KTOL) C C--------+---------+---------+---------+---------+---------+---------+-- C UPDATE GROUPS-SUMMARY STATISTICS C--------+---------+---------+---------+---------+---------+---------+-- GSTIME(KTOL) = GSTIME(KTOL) + PSTIME(KTOL) GSOVHD(KTOL) = GSOVHD(KTOL) + PSOVHD(KTOL) GSNFCN(KTOL) = GSNFCN(KTOL) + PSNFCN(KTOL) GSNJAC(KTOL) = GSNJAC(KTOL) + PSNJAC(KTOL) GSNLUD(KTOL) = GSNLUD(KTOL) + PSNLUD(KTOL) GSNSTP(KTOL) = GSNSTP(KTOL) + PSNSTP(KTOL) C IF (OPT.LT.3) GO TO 280 GSNTRU(KTOL) = GSNTRU(KTOL) + PSNTRU(KTOL) GSLEMX(KTOL) = AMAX1(GSLEMX(KTOL),PSLEMX(KTOL)) GSNDCV(KTOL) = GSNDCV(KTOL) + PSNDCV(KTOL) GSNBAD(KTOL) = GSNBAD(KTOL) + PSNBAD(KTOL) 280 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C END OF LOOP OVER GROUPS C--------+---------+---------+---------+---------+---------+---------+-- 300 CONTINUE C C C--------+---------+---------+---------+---------+---------+---------+-- C OUTPUT HEADINGS FOR GROUPS- AND OVERALL-SUMMARY STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- WRITE (IOUT,FMT=99977) TITLE, (BL,I=1,OPT) WRITE (IOUT,FMT=99976) (BL,I=1,OPT) C--------+---------+---------+---------+---------+---------+---------+-- C OUTPUT GROUPS-SUMMARY STATISTICS C--------+---------+---------+---------+---------+---------+---------+-- IF (OPT.GE.3) GO TO 340 DO 320 I = 1, NTOL WRITE (IOUT,FMT=99975) LGTOL(I), GSTIME(I), GSOVHD(I), * GSNFCN(I), GSNJAC(I), GSNLUD(I), GSNSTP(I) 320 CONTINUE GO TO 380 340 DO 360 I = 1, NTOL FDECEV = RATIO(GSNDCV(I),GSNTRU(I)) FBADEC = RATIO(GSNBAD(I),GSNTRU(I)) WRITE (IOUT,FMT=99975) LGTOL(I), GSTIME(I), GSOVHD(I), * GSNFCN(I), GSNJAC(I), GSNLUD(I), GSNSTP(I), GSLEMX(I), * FDECEV, FBADEC C IF (GSNSTP(I).NE.GSNTRU(I)) WRITE (IOUT,FMT=99990) GSNTRU(I) 360 CONTINUE 380 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C COMPUTE OVERALL-SUMMARY STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- DO 400 I = 1, NTOL OSTIME = OSTIME + GSTIME(I) OSOVHD = OSOVHD + GSOVHD(I) OSNFCN = OSNFCN + GSNFCN(I) OSNJAC = OSNJAC + GSNJAC(I) OSNLUD = OSNLUD + GSNLUD(I) OSNSTP = OSNSTP + GSNSTP(I) C IF (OPT.LT.3) GO TO 400 OSNTRU = OSNTRU + GSNTRU(I) OSNDCV = OSNDCV + GSNDCV(I) OSNBAD = OSNBAD + GSNBAD(I) OSLEMX = AMAX1(OSLEMX,GSLEMX(I)) 400 CONTINUE FDECEV = RATIO(OSNDCV,OSNTRU) FBADEC = RATIO(OSNBAD,OSNTRU) C--------+---------+---------+---------+---------+---------+---------+-- C OUTPUT OVERALL-SUMMARY STATISTICS C--------+---------+---------+---------+---------+---------+---------+-- IF (OPT.LT.3) WRITE (IOUT,FMT=99974) OSTIME, OSOVHD, OSNFCN, * OSNJAC, OSNLUD, OSNSTP C IF (OPT.GE.3) WRITE (IOUT,FMT=99974) OSTIME, OSOVHD, OSNFCN, * OSNJAC, OSNLUD, OSNSTP, OSLEMX, FDECEV, FBADEC C C RETURN C 99999 FORMAT ('0STIFF DETEST PACKAGE OPT=',I2,', NORMEF=',I2, * ', NRMTYP=',I2,19X,'ON ',A,//) 99998 FORMAT ('0PARAMETER ERRORS AS SHOWN BY FLAG=',E15.8,/' ',49('*') * ,//) 99997 FORMAT ('1') 99996 FORMAT ('0GROUP',I3,18X,A) 99995 FORMAT (/'0',A3,I1,' (SCALED)',/) 99994 FORMAT (/'0',A3,I1,' (UNSCALED)',/) 99993 FORMAT (' ',A1,6X,'LOG10',5X,'TIME',3X,'OVHD',5X,'FCN',5X,'JAC', * 5X,'MAT',4X,'NO OF',3X,'END PNT',A1,2X,'MAXIMUM',A1,2X, * 'MAXIMUM',3X,'FRACTION',3X,'FRACTION',A1) 99992 FORMAT (' ',A1,7X,'TOL',21X,'CALLS',3X,'CALLS',4X,'FACT',3X, * 'STEPS',3X,'GLB ERR',A1,2X,'GLB ERR',A1,2X,'LOC ERR',3X, * 'DECEIVED',3X,'BAD DECV',A1) 99991 FORMAT ('0',6X,F6.2,2X,2F7.3,1X,4I8,2X,F8.2,1X,F9.2,1X,F9.3,1X, * F9.3,1X,F10.3,1X,F10.3) 99990 FORMAT (114X,'(LOC ASSESS ON',I4,')') 99989 FORMAT ('0',20X, * '***** UNEXPECTED FAILURE OF METHOD WHILE BEING TIMED *****' * ,/) 99988 FORMAT ('0',6X,F6.2,' *** METHOD FAILED TO START ***') 99987 FORMAT (15X,'TRUE-SOLUTION OF TEST PACKAGE FAILED AT X = ',1P, * E12.5,', ERROR FLAG (GLOBAL) ',I3,', (LOCAL) ',I3,/21X, * 'AND SUBSEQUENTLY METHOD FAILED AT X = ',1P,E12.5) 99986 FORMAT (21X,'METHOD FAILED AT X = ',1P,E12.5) 99985 FORMAT (21X,'TRUE-SOLUTION OF TEST PACKAGE FAILED AT X = ',1P, * E12.5,', ERROR FLAG (GLOBAL) ',I3,', (LOCAL) ',I3) 99984 FORMAT (/6X,'ERROR ESTIMATE ANALYSIS',10X, * 'EXTRAPOLATION (0=NO 1=YES):',I2,/11X, * 'HORIZONTAL AXIS: R1=||ERREST|| / ERRBND',/11X, * 'VERTICAL AXIS: R2 = ||ERROR IN ERREST|| / ERRBND',/11X, *'PLOT SHOWS % STEPS WHERE (R1,R2) LAY IN INDICATED PIGEONHOLE, A', *1X,'DOT MEANS UNDER 1%',/) 99983 FORMAT (/'0',17X,'SMOOTHNESS FIT OF LOG10(ERROR) VS LOG10(TOL)') 99982 FORMAT ('0',17X,'ENDPOINT GLOBAL ERROR') 99981 FORMAT (39X,I2,' VALUES, TOO FEW TO GET STATISTICS') 99980 FORMAT (39X,'=',1P,G10.3,' *(TOL**',0P,F6.3,') APPROX,',6X, * 'R.M.S. RESIDUAL=',1P,E8.1,' OVER',I3,' VALUES') 99979 FORMAT ('0',17X,'MAXIMUM GLOBAL ERROR') 99978 FORMAT (/'0SUMMARY OVER GROUP',I3) 99977 FORMAT ('1SUMMARY OVER ALL GROUPS',6X,A,//' ',A1,6X,'LOG10',5X, * 'TIME',3X,'OVHD',5X,'FCN',5X,'JAC',5X,'MAT',4X,'NO OF',2A1, * 2X,'MAXIMUM',3X,'FRACTION',3X,'FRACTION',A1) 99976 FORMAT (' ',A1,7X,'TOL',21X,'CALLS',3X,'CALLS',4X,'FACT',3X, * 'STEPS',2A1,2X,'LOC ERR',3X,'DECEIVED',3X,'BAD DECV',A1) 99975 FORMAT ('0',6X,F6.2,2X,2F7.3,1X,4I8,1X,3F11.3) 99974 FORMAT ('0',5X,'OVERALL',/6X,'SUMMARY',2X,2F7.3,1X,4I8,1X,3F11.3) END C C C********+*********+*********+*********+*********+*********+*********+** C SUBROUTINE PARCHK(OPT,NORMEF,NRMTYP,TOL,IDLIST,NTOL,NGRP,GRPLST, * LGTOL,FLAG) C C********+*********+*********+*********+*********+*********+*********+** C ROUTINE TO DO PARAMETER CHECKS FOR REVISED STDTST INTERFACE. C C INPUT: OPT,NORMEF,NRMTYP,TOL,IDLIST C VALID INPUT IS: C OPTION = 1 2 3 OR 4 C NORMEF = 0 1 OR 2 C NRMTYP = 1 2 OR 3 C TOL = LIST OF UP TO 10 POSITIVE REAL'S FOLLOWED BY A 0., C IN STRICTLY DECREASING ORDER C IDLIST = LIST OF GROUPS OF PROBLEM-IDS SEPARATED BY ZEROS C WITH 2 ZEROS AFTER LAST GROUP, AT MOST 60 ITEMS TOTAL. C EACH ID MAY HAVE A MINUS SIGN TO SELECT THE 'UNSCALED' C ERROR CONTROL OPTION. C VALID PROBLEM-IDS ARE IN RANGES C 11-14 21-25 31-35 41-46 51-55 61-65 C FOR PROBLEM CLASSES A1-A4 B1-B5 ETC. C OUTPUT: NTOL = NO. OF TOLERANCES IN TOL LIST C NGRP = NO. OF GROUPS IN IDLIST LIST C GRPLST(1,I) = SIZE OF I-TH GROUP OF PROBLEMS CC ... (2,I) = POINTER TO (START OF I-TH GROUP)-1 IN IDLIST C LGTOL(I) = LOG10(TOL(I)) C FLAG IS ERROR FLAG, 0.0 IF ALL OK, ELSE ITS DECIMAL DIGITS C INDICATE WHICH PARAMETER ERRORS WERE FOUND: C 1: OPT INVALID C 2: NORMEF INVALID C 3: NORMEF = 2 REQUESTED WITH OPT = 1 C 4: TOL(I) < 0, OR LIST NOT IN DECREASING ORDER C 5: TOL LIST EMPTY OR NOT TERMINATED BY ZERO C 6: INVALID PROBLEM-ID FOUND C 7: LIST OF GROUPS IN IDLIST EMPTY,NOT TERMINATED BY C 2 ZEROS OR HAS MORE THAN MAXGRP GROUPS C 8: NRMTYP INVALID C--------+---------+---------+---------+---------+---------+---------+-- C C .. Scalar Arguments .. REAL FLAG INTEGER NGRP, NORMEF, NRMTYP, NTOL, OPT C .. Array Arguments .. REAL LGTOL(10), TOL(11) INTEGER GRPLST(2,6), IDLIST(60) C .. Local Scalars .. REAL BIG, TOLPRV INTEGER ENDLST, I, ID, IID, ISAV, KCLASS, LENIDS, * LENTOL, MAXGRP, NCLASS C .. Local Arrays .. INTEGER NSYSTM(6) C .. Intrinsic Functions .. INTRINSIC ALOG10, IABS C .. Data statements .. DATA ENDLST/-1/, BIG/1E20/ DATA NCLASS/6/, NSYSTM/4, 5, 5, 6, 5, 5/, MAXGRP/6/, * LENTOL/11/, LENIDS/60/ C .. Executable Statements .. C FLAG = 0. IF (OPT.LT.1 .OR. OPT.GT.4) FLAG = 1. IF (NORMEF.LT.0 .OR. NORMEF.GT.2) FLAG = 10.*FLAG + 2. IF (OPT.EQ.1 .AND. NORMEF.EQ.2) FLAG = 10.*FLAG + 3. IF (NRMTYP.LT.1 .OR. NRMTYP.GT.3) FLAG = 10.*FLAG + 8. C C TOLERANCES: NTOL = 0 TOLPRV = BIG DO 20 I = 1, LENTOL IF (TOL(I).LT.0. .OR. TOL(I).GE.TOLPRV) FLAG = 10.*FLAG + 4. IF (TOL(I).EQ.0.) GO TO 40 NTOL = NTOL + 1 TOLPRV = TOL(I) 20 CONTINUE C C NO TERMINATING 0 IN TOLERANCE LIST: FLAG = 10.*FLAG + 5. C C CHECK FOR EMPTY TOLERANCE LIST: 40 IF (NTOL.EQ.0) FLAG = 10.*FLAG + 5. C C LIST OF GROUPS OF PROBLEMS: NGRP = 0 I = 0 C C WHILE NEXT ID IN LIST ISNT 0 OR END OF LIST: 60 I = I + 1 ID = ENDLST IF (I.LE.LENIDS) ID = IDLIST(I) C IF (ID.EQ.0) GO TO 160 IF (NGRP.GE.MAXGRP) GO TO 180 ISAV = I - 1 C C WHILE ID ISNT 0, GET ONE GROUP: 80 IF (ID.EQ.0) GO TO 140 IF (ID.EQ.ENDLST) GO TO 180 C TRANSLATE ID INTO CLASS & NUMBER WITHIN CLASS, C IGNORING SIGN (WHICH SELECTS SCALED/UNSCALED OPTION): ID = IABS(ID) KCLASS = (ID-1)/10 IID = ID - 10*KCLASS IF ( .NOT. (KCLASS.GE.1 .AND. KCLASS.LE.NCLASS)) GO TO 100 IF (IID.LE.NSYSTM(KCLASS)) GO TO 120 100 FLAG = 10.*FLAG + 6. 120 CONTINUE C GET NEXT ID AS ABOVE: I = I + 1 ID = ENDLST IF (I.LE.LENIDS) ID = IDLIST(I) GO TO 80 C C NEW GROUP FORMED: 140 NGRP = NGRP + 1 GRPLST(1,NGRP) = I - ISAV - 1 GRPLST(2,NGRP) = ISAV GO TO 60 C C CHECK IF NO GROUPS WERE SPECIFIED: 160 IF (NGRP.LE.0) GO TO 180 GO TO 200 C 180 FLAG = 10.*FLAG + 7. C C IF ALL OK, COMPUTE LOGS OF TOLERANCES: C 200 IF (FLAG.NE.0.) GO TO 240 DO 220 I = 1, NTOL LGTOL(I) = ALOG10(TOL(I)) 220 CONTINUE 240 RETURN END C C********+*********+*********+*********+*********+*********+*********+** C SUBROUTINE LSQFIT(X,Y,MISS,N,NN,C0,C1,RES) C .. Scalar Arguments .. REAL C0, C1, RES INTEGER N, NN C .. Array Arguments .. REAL X(N), Y(N) LOGICAL MISS(N) C .. Local Scalars .. REAL SX, SXX, SXY, SY, XNN INTEGER I C .. Intrinsic Functions .. INTRINSIC SQRT C .. Executable Statements .. C C********+*********+*********+*********+*********+*********+*********+** C FITS MODEL Y = C0 + C1*X TO DATA X(I),Y(I),I = 1..N WHERE DATA C FOR WHICH MISS(I) IS .TRUE. IS REGARDED AS MISSING. C C ON EXIT C X,Y,MISS,N ARE UNCHANGED. C NN = NO. OF NONMISSING VALUES C C0,C1 = FITTED COEFFICIENTS C RES = ROOT MEAN SQUARE RESIDUAL C C EXCEPT THAT IF NN.LE.1 NO COMPUTATION OF THE COEFFICIENTS IS DONE. C--------+---------+---------+---------+---------+---------+---------+-- C NN = 0 SX = 0. SY = 0. DO 20 I = 1, N IF (MISS(I)) GO TO 20 NN = NN + 1 SX = SX + X(I) SY = SY + Y(I) 20 CONTINUE IF (NN.LE.1) GO TO 80 XNN = NN SX = SX/XNN SY = SY/XNN SXX = 0. SXY = 0. DO 40 I = 1, N IF (MISS(I)) GO TO 40 SXX = SXX + (X(I)-SX)**2 SXY = SXY + (X(I)-SX)*(Y(I)-SY) 40 CONTINUE C1 = SXY/SXX C0 = SY - C1*SX RES = 0. DO 60 I = 1, N IF ( .NOT. MISS(I)) RES = RES + (Y(I)-SY-C1*(X(I)-SX))**2 60 CONTINUE C RES = SQRT(RES/XNN) C 80 RETURN END C C********+*********+*********+*********+*********+*********+*********+** C REAL FUNCTION RATIO(M,N) C C********+*********+*********+*********+*********+*********+*********+** C .. Scalar Arguments .. INTEGER M, N C .. Intrinsic Functions .. INTRINSIC FLOAT C .. Executable Statements .. RATIO = 1E20 IF (N.NE.0) RATIO = FLOAT(M)/FLOAT(N) RETURN END C C********+*********+*********+*********+*********+*********+*********+** C SUBROUTINE EFSTAT(C,E,LGTOL,NTOL,NOK,ERFLG,TITLE,IOUT,W1,W2,W3,W4, * W5,W6) C C********+*********+*********+*********+*********+*********+*********+** C ROUTINE TO COMPUTE AND PRINT NORMALIZED EFFICIENCY STATISTICS. C C PARAMETERS (ALL INPUT): C C,E - COEFFICIENTS IN LEAST-SQUARES FIT OF ACHIEVED ACCURACY C (EITHER AT ENDPOINT OR MAX-OVER-RANGE) TO TOLERANCE. C LGTOL - LIST OF LOGS TO BASE 10 OF TOLERANCES C NTOL - NO. OF TOLERANCES. C NOK - NO. OF .FALSE. ENTRIES IN ERFLG (FROM LSQFIT CALL) C ERFLG - LOGICAL VECTOR INDICATING FOR WHICH TOLERANCES DATA C IS TO BE REGARDED AS MISSING. C TITLE C - IDENTIFYING CHARACTER STRING. C IOUT - OUTPUT UNIT NUMBER. C W1,...,W6 C - VECTORS OF STATISTICS, INDEXED OVER TOLERANCES, FOR C WHICH NORMALIZED STATISTICS ARE TO BE PRODUCED. C (NOTE SOME ARE REAL, SOME INTEGER: REFER TO ACTUAL CALL C IN STDTST.) C IT IS ASSUMED THAT NTOL.LE.10, OTHERWISE ARRAY S MUST BE LONGER. C--------+---------+---------+---------+---------+---------+---------+-- C C LOCAL VARIABLES C .. Scalar Arguments .. REAL C, E INTEGER IOUT, NOK, NTOL CHARACTER*8 TITLE C .. Array Arguments .. REAL LGTOL(NTOL), W1(NTOL), W2(NTOL) INTEGER W3(NTOL), W4(NTOL), W5(NTOL), W6(NTOL) LOGICAL ERFLG(NTOL) C .. Local Scalars .. REAL EQVTOL, S0, THETA, W1INT, W2INT, X INTEGER I, MSINT, NHI, NLO, SHI, SINT, SLO, W3INT, * W4INT, W5INT, W6INT C .. Local Arrays .. REAL S(10) C .. Intrinsic Functions .. INTRINSIC FLOAT, INT C .. Statement Functions .. INTEGER FLOOR C .. Statement Function definitions .. C C STATEMENT FUNCTION C FLOOR FUNCTION VALID IF ARGUMENT X.GE.-100 WHICH IS OK HERE. FLOOR(X) = INT(X+100.) - 100 C .. Executable Statements .. C IF (NOK.LE.2) GO TO 200 C C TRANSFORM THE LOG10(TOL)'S TO NORMALIZED-EFFICIENCY VARIABLE: DO 20 I = 1, NTOL S(I) = -(C+E*LGTOL(I)) 20 CONTINUE C C FIND SET OF CONSECUTIVE TOL'S FOR WHICH INTEGRATION SUCCEEDED: DO 40 NLO = 1, NTOL IF ( .NOT. ERFLG(NLO)) GO TO 60 40 CONTINUE C ELSE ALL INTEGRATIONS FOR THIS PROBLEM FAILED: GO TO 200 60 CONTINUE NHI = NLO - 1 DO 80 I = NLO, NTOL IF (ERFLG(I)) GO TO 100 NHI = I 80 CONTINUE 100 CONTINUE C IF (NHI.LE.NLO) GO TO 200 IF (E.LE.0.) GO TO 220 C C FORM RANGE OF INTEGER POWERS OF 10 FOR WHICH NORMALIZED STATISTICS C ARE TO BE PRINTED: SLO = -FLOOR(-S(NLO)+0.1) SHI = FLOOR(S(NHI)+0.1) IF (SHI.LT.SLO) GO TO 240 C WRITE (IOUT,FMT=99999) TITLE C C START OF LOOP TO PRINT A LINE OF STATISTICS FOR EACH POWER OF 10: I = NLO + 1 CC ... WHICH IS KNOWN TO BE .LE. NHI C DO 160 SINT = SLO, SHI S0 = FLOAT(SINT) C C MOVE INTERVAL S(I-1)..S(I) TO RIGHT WHILE S(I).LT.SINT: 120 IF (S(I).GE.S0 .OR. I.GE.NHI) GO TO 140 I = I + 1 GO TO 120 140 CONTINUE C NECESSARILY NOW NLO + 1 .LE. I .LE. NHI C C NOW DO INTERPOLATION (POSSIBLY EXTRAPOLATION A SHORT DISTANCE) C USING DATA FOR I AND I + 1: THETA = (S0-S(I-1))/(S(I)-S(I-1)) W1INT = W1(I-1) + THETA*(W1(I)-W1(I-1)) W2INT = W2(I-1) + THETA*(W2(I)-W2(I-1)) W3INT = W3(I-1) + THETA*(W3(I)-W3(I-1)) W4INT = W4(I-1) + THETA*(W4(I)-W4(I-1)) W5INT = W5(I-1) + THETA*(W5(I)-W5(I-1)) W6INT = W6(I-1) + THETA*(W6(I)-W6(I-1)) C MSINT = -SINT EQVTOL = -(C+S0)/E WRITE (IOUT,FMT=99998) MSINT, EQVTOL, W1INT, W2INT, W3INT, * W4INT, W5INT, W6INT C 160 CONTINUE C 180 RETURN C 200 WRITE (IOUT,FMT=99997) GO TO 180 C 220 WRITE (IOUT,FMT=99996) GO TO 180 C 240 WRITE (IOUT,FMT=99995) GO TO 180 C 99999 FORMAT (/'0',6X,'NORMALIZED EFFICIENCY - ',A8,' GLOBAL ERROR', * //7X,'EXPECTED',3X,'EQUIV',4X,'TIME',3X,'OVHD',5X,'FCN',5X, * 'JAC',5X,'MAT',4X,'NO OF',/7X,'ACCURACY',1X,'LOG10 TOL', * 17X,'CALLS',3X,'CALLS',4X,'FACT',3X,'STEPS') 99998 FORMAT ('0',6X,'10**',I3,F8.2,F9.3,F7.3,1X,4I8) 99997 FORMAT ('0',10X,'NOT ENOUGH SUCCESSFUL INTEGRATIONS TO FORM',1X, * 'NORMALIZED STATISTICS') 99996 FORMAT ('0',10X,'DEPENDENCE OF ACCURACY ON TOLERANCE IS TOO',1X, * 'UNRELIABLE TO FORM NORMALIZED STATISTICS') 99995 FORMAT ('0',10X,'NO POWERS OF TEN WITHIN RANGE OF TOLERANCES',1X, * 'USED: NO NORMALIZED STATISTICS') END C C C********+*********+*********+*********+*********+*********+*********+** C SUBROUTINE CNTROL(CMPLET,INDG1,INDL1) C C********+*********+*********+*********+*********+*********+*********+** C CNTROL ORGANIZES THE CALLS TO METHOD NEEDED TO GATHER C STATISTICS FOR ONE PROBLEM AND ONE TOLERANCE AT THE LEVEL OF C DETAIL SPECIFIED BY OPT, WITH SCALING TURNED ON OR OFF BY IWT. C C ON EXIT FROM CNTROL C CMPLET INDICATES WHETHER A FAILURE OCCURRED: C CMPLET = 1 NO FAILURES. C CMPLET = 0 DETEST FAILED TO OBTAIN TRUE LOCAL OR GLOBAL C SOLUTION. C CMPLET = -1 METHOD FAILED TO REACH THE END OF RANGE. C CMPLET = -2 DETEST FAILED AND SUBSEQUENTLY METHOD FAILED C CMPLET = -3 METHOD COULD NOT START THE INTEGRATION. C CMPLET = -4 METHOD COMPLETED THE STATISTICS GATHERING CALL C BUT (UNEXPECTEDLY) FAILED IN THE TIMING LOOP. C C INDG1, INDL1 RETURN THE ERROR FLAGS OF THE 'TRUE' GLOBAL C AND LOCAL SOLUTIONS RESPECTIVELY. C C THE MAIN OUTPUT FROM CNTROL CONSISTS OF THE STATISTICS HELD C IN COMMON /STCOM3/ C--------+---------+---------+---------+---------+---------+---------+-- C--------+---------+---------+---------+---------+---------+---------+-- C COMMON AREAS C--------+---------+---------+---------+---------+---------+---------+-- C1 C2 C3 C5 C6 C .. Scalar Arguments .. INTEGER CMPLET, INDG1, INDL1 C .. Scalars in Common .. DOUBLE PRECISION ERRTOL, HSTART, XEND, XFIN, XTRUE REAL GEMX, GEND, LEMXSC, OVHD, TIME, TRUTIM INTEGER ID, ID1, IFLAG, INDG, INDL, IOUT, IWT, IWT1, N, * N1, NBAD, NDCV, NFCN, NFCN1, NJAC, NJAC1, NLUD, * NLUD1, NRMTYP, NSTART, NSTL, NSTP, NTRU, OPT, * XTRAP C .. Arrays in Common .. DOUBLE PRECISION WT(20) C .. Local Scalars .. DOUBLE PRECISION DUMMY, HINIT, HMAX, X, XSTART REAL FCNTIM, JACTIM, LUDTIM, S, TIMCUM, TSTTIM INTEGER COUNT, I LOGICAL NOSTRT, OKMETH, TIMERR C .. Local Arrays .. DOUBLE PRECISION Y(20), YEND(20), YSTART(20) C .. External Functions .. REAL CLOCK, CONST, DIFNRM EXTERNAL CLOCK, CONST, DIFNRM C .. External Subroutines .. EXTERNAL EVALU, IVALU, METHOD, STATS C .. Intrinsic Functions .. INTRINSIC FLOAT C .. Common blocks .. COMMON /STCOM1/ERRTOL, OPT, NRMTYP, XTRAP, ID, IWT, * IOUT COMMON /STCOM2/XEND, HSTART, N, IFLAG, INDL, INDG COMMON /STCOM3/XFIN, XTRUE, TIME, OVHD, TRUTIM, GEND, * GEMX, LEMXSC, NFCN, NJAC, NLUD, NSTP, NSTL, * NDCV, NBAD, NTRU, NSTART COMMON /STCOM5/WT, IWT1, N1, ID1 COMMON /STCOM6/NFCN1, NJAC1, NLUD1 C .. Executable Statements .. CE C C--------+---------+---------+---------+---------+---------+---------+-- C NOTE ON INDL, INDG IN /STCOM2/: C THESE ARE ERROR INDICATORS FOR THE 'TRUE' LOCAL AND C GLOBAL SOLUTION RESPECTIVELY. THEY ARE SET INSIDE STATS C WHICH IS CALLED BY METHOD. C ON RETURN FROM METHOD, INDL IS: C 2 IF NO CALL TO TRUE TO COMPUTE LOCAL SOLUTION HAS C YET BEEN MADE (SET BY INITIALIZING CALL TO STATS). C .GT.0 IF ALL CALLS TO TRUE FOR CALCULATION OF LOCAL C SOLUTION WERE SUCCESSFUL. C .LT.0 IF AN UNSUCCESSFUL CALL TO TRUE FOR THE LOCAL C SOLUTION WAS MADE. C THE VALUE ON EXIT IF NOT 0 IS THE VALUE RETURNED IN THE C FLAG 'IND' OF SUBROUTINE TRUE. C INDG IS THE SAME, BUT FOR THE GLOBAL SOLUTION. C C INDL,INDG ARE USED ON RE-ENTRY TO STATS TO TEST IF A C FAILURE OF THE TRUE SOLUTIONS OCCURRED ON A PREVIOUS STEP C AND SHOULD THUS BE LEFT ALONE BETWEEN STEPS. C--------+---------+---------+---------+---------+---------+---------+-- C C ACTION OF THE ROUTINE: C CALL IVALU TO SET INTEGRATION PARAMETERS. C COPY N,ID,IWT INTO /STCOM5/ FOR USE BY FCN,PDERV. C SET IFLAG = 1 AND CALL STATS TO INITIALIZE ITS COMMON AREAS. C (THE ARGUMENTS FOR THIS CALL ARE DUMMIES.) C SET X,Y,NSTP,NFCN FOR USE IN STATS. SET IFLAG = 2 SO THAT C THE CALL TO METHOD WILL SET THE FIRST STEP SIZE (HSTART) C AND RETURN. C SET NSTART = NO. OF FCN CALLS NEEDED BY METHOD TO START. C--------+---------+---------+---------+---------+---------+---------+-- C CALL IVALU(N,XSTART,XEND,HINIT,HMAX,YSTART,FCNTIM,JACTIM,LUDTIM, * WT,IWT,ID) C N1 = N ID1 = ID IWT1 = IWT X = XSTART DO 20 I = 1, N Y(I) = YSTART(I) 20 CONTINUE C IFLAG = 1 CALL STATS(X,Y,DUMMY,Y) C NFCN1 = 0 NSTP = 0 IFLAG = 2 C CALL METHOD(N,X,Y,XEND,ERRTOL,HMAX,HINIT) C NOSTRT = X .LT. XEND NSTART = NFCN1 C--------+---------+---------+---------+---------+---------+---------+-- C INITIALIZE THE COUNTERS ETC. IN /STCOM3/,/STCOM6/. C IF METHOD FAILED TO START, SET FLAGS AND EXIT. C SET IFLAG = 3 SO THAT THE CALL TO METHOD WILL DO A COMPLETE C INTEGRATION, COMPILING STATISTICS ON EACH STEP. C START THE CLOCK. C--------+---------+---------+---------+---------+---------+---------+-- NFCN1 = 0 NJAC1 = 0 NLUD1 = 0 NSTP = 0 NSTL = 0 LEMXSC = 0. NDCV = 0 NBAD = 0 GEMX = 0. TRUTIM = 0. NTRU = 0 C IF (NOSTRT) GO TO 180 C X = XSTART DO 40 I = 1, N Y(I) = YSTART(I) 40 CONTINUE IFLAG = 3 S = CLOCK(0.0) C CALL METHOD(N,X,Y,XEND,ERRTOL,HMAX,HSTART) C TIME = CLOCK(S) OKMETH = X .GE. XEND XFIN = X NFCN = NFCN1 NJAC = NJAC1 NLUD = NLUD1 IF ( .NOT. OKMETH) GO TO 160 C--------+---------+---------+---------+---------+---------+---------+-- C IF OPT.GT.1, OR IF OPT = 1 BUT THE TIMING ESTIMATE ALREADY C OBTAINED WAS TOO SMALL TO BE RELIABLE, DO A TIMING COMPUTATION C PROVIDED THAT METHOD REACHED THE ENDPOINT IN THE PREVIOUS CALL. C SET IFLAG = 0, START THE CLOCK, AND CALL C METHOD SUFFICIENTLY MANY TIMES FOR THE SOLUTION TIME TO C BE OBTAINED ACCURATELY. COMPUTE THE OVERHEAD AS THE C TOTAL TIME EXCLUSIVE OF FUNCTION AND JACOBIAN EVALUATIONS C AND MATRIX INVERSIONS. C--------+---------+---------+---------+---------+---------+---------+-- TSTTIM = CONST(4) TIMERR = .FALSE. IF (TSTTIM.LE.0) GO TO 120 IF (OPT.EQ.1 .AND. TIME.GE.0.5*TSTTIM) GO TO 120 COUNT = 0 IFLAG = 0 S = CLOCK(0.0) C--------+---------+---------+---------+---------+---------+---------+-- C LOOP TILL 'TSTTIM' TIME UNITS HAVE ELAPSED: C--------+---------+---------+---------+---------+---------+---------+-- 60 CONTINUE X = XSTART DO 80 I = 1, N Y(I) = YSTART(I) 80 CONTINUE CALL METHOD(N,X,Y,XEND,ERRTOL,HMAX,HSTART) TIMERR = X .LT. XEND IF (TIMERR) GO TO 100 TIMCUM = CLOCK(S) COUNT = COUNT + 1 IF (TIMCUM.LT.TSTTIM .AND. COUNT.LT.10) GO TO 60 C 100 IF (COUNT.GE.1) TIME = TIMCUM/FLOAT(COUNT) 120 CONTINUE C--------+---------+---------+---------+---------+---------+---------+-- C WE NOW HAVE A VALUE FOR TIME: THE ONE OBTAINED BEFORE THE C TIMING LOOP IF WE SKIPPED THE LATTER OR IN THE UNLIKELY C EVENT OF AN ERROR IN THE 1ST TIMING ITERATION; OTHERWISE C THE ONE FROM THE TIMING LOOP. C COMPUTE OVERHEAD AND ENDPOINT GLOBAL ERROR. C--------+---------+---------+---------+---------+---------+---------+-- OVHD = TIME - FLOAT(NFCN)*FCNTIM - FLOAT(NJAC)*JACTIM - * FLOAT(NLUD)*LUDTIM CALL EVALU(YEND,N,WT,IWT,ID) GEND = DIFNRM(YEND,Y,N) C IF (TIMERR) GO TO 200 C C--------+---------+---------+---------+---------+---------+---------+-- C SET THE OUTPUT VALUE OF CMPLET, INDG1 AND INDL1. C--------+---------+---------+---------+---------+---------+---------+-- CMPLET = 1 IF (INDL.LT.0 .OR. INDG.LT.0) CMPLET = 0 140 INDG1 = INDG INDL1 = INDL RETURN C C--------+---------+---------+---------+---------+---------+---------+-- C *********** ERROR EXITS *********** C--------+---------+---------+---------+---------+---------+---------+-- C METHOD FAILED TO REACH XEND C--------+---------+---------+---------+---------+---------+---------+-- 160 CMPLET = -1 IF (INDL.LT.0 .OR. INDG.LT.0) CMPLET = -2 TIME = 1E20 OVHD = 1E20 GEND = 1E20 GO TO 140 C C--------+---------+---------+---------+---------+---------+---------+-- C METHOD FAILED TO START C--------+---------+---------+---------+---------+---------+---------+-- 180 CMPLET = -3 NFCN = 0 NJAC = 0 NLUD = 0 TIME = 1E20 OVHD = 1E20 GEND = 1E20 GO TO 140 C--------+---------+---------+---------+---------+---------+---------+-- C INTEGRATION FAILED IN TIMING LOOP C--------+---------+---------+---------+---------+---------+---------+-- 200 CMPLET = -4 GO TO 140 END C C********+*********+*********+*********+*********+*********+*********+** C REAL FUNCTION DIFNRM(A,B,N) C1 C .. Scalar Arguments .. INTEGER N C .. Array Arguments .. DOUBLE PRECISION A(N), B(N) C .. Scalars in Common .. DOUBLE PRECISION ERRTOL INTEGER ID, IOUT, IWT, NRMTYP, OPT, XTRAP C .. Local Scalars .. INTEGER I C .. Intrinsic Functions .. INTRINSIC AMAX1, DABS, REAL, SQRT C .. Common blocks .. COMMON /STCOM1/ERRTOL, OPT, NRMTYP, XTRAP, ID, IWT, * IOUT C .. Executable Statements .. C C********+*********+*********+*********+*********+*********+*********+** C NORM OF DIFFERENCE BETWEEN TWO DOUBLE PRECISION VECTORS, C SINGLE PRECISION RESULT. C NRMTYP=1,2,3 CHOOSES MAX-NORM, 2-NORM, R.M.S.-NORM. C--------+---------+---------+---------+---------+---------+---------+-- IF (NRMTYP.EQ.1) THEN DIFNRM = 0.0 DO 20 I = 1, N DIFNRM = AMAX1(DIFNRM,REAL(DABS(A(I)-B(I)))) 20 CONTINUE ELSE DIFNRM = 0.0 DO 40 I = 1, N DIFNRM = DIFNRM + REAL(DABS(A(I)-B(I)))**2 40 CONTINUE C IF (NRMTYP.EQ.2) DIFNRM = SQRT(DIFNRM) IF (NRMTYP.EQ.3) DIFNRM = SQRT(DIFNRM/N) END IF RETURN END C C********+*********+*********+*********+*********+*********+*********+** C SUBROUTINE STATS(X,Y,ERRBND,ERREST) C C********+*********+*********+*********+*********+*********+*********+** C STATS 'INSTRUMENTS' THE ODE-SOLVER BEING TESTED, BY COMPUTING C THE DEVIATION OF THE SOLUTION COMPUTED IN ROUTINE METHOD FROM C THE 'TRUE' GLOBAL AND LOCAL SOLUTIONS IF REQUESTED, AND BY C ACCUMULATING VARIOUS ASSOCIATED STATISTICS. IT ALSO PERFORMS C VARIOUS INITIALIZATION DUTIES, DEPENDING ON THE VALUE OF IFLAG C ON ENTRY. C C ON ENTRY C X,Y - MUST HOLD 'SOLVER' SOLUTION AT CURRENT STEP C ERREST- MUST HOLD ESTIMATED LOCAL ERROR VECTOR AT THIS STEP C DEFINED AS (COMPUTED Y) - (TRUE LOCAL SOLUTION AT NEW X). C SINCE ABSOLUTE ERROR-CONTROL IS SPECIFIED, THIS IS THE C VECTOR WHOSE NORM IS MAINTAINED BELOW ERRBND BY 'METHOD'. C IT IS ASSUMED THAT 'METHOD' USES ONE OF THE 3 NORMS C OFFERED BY THE PACKAGE, AND NRMTYP MUST BE SET SUITABLY. C ERRBND- MUST HOLD TOLERANCE BELOW WHICH THE NORM OF ERREST IS C BEING HELD AT THIS STEP. USUALLY SAME AS ERRTOL BUT WILL C BE DIFFERENT AND VARY WITH STEPSIZE IF (EG) A PER-UNIT- C STEP ERROR CRITERION IS USED. C C STORAGE FOR VARIOUS SOLUTIONS: C X,Y - CURRENT SOLUTION COMPUTED BY METHOD, PASSED IN C VIA ARGUMENT LIST. C XOLD,YOLD- VALUES OF X,Y AT AN OLD MESHPOINT OF METHOD, C USUALLY THE LAST ONE BUT OLDER IF A LUMPED C STEP IS BEING FORMED (SEE BELOW). C IF IFLAG = 0, NEITHER XOLD NOR YOLD IS USED. C YOLD IS NOT USED UNLESS STATISTICS ON LOCAL ERROR C ARE BEING COMPILED (IFLAG=3 AND OPT=3). C THE 'TRUE' LOCAL SOLUTION IS OBTAINED BY INTEG- C RATING FROM XOLD,YOLD TO THE CURRENT X. C XOLD,YOLD ARE USED AS THE ACTUAL ARGUMENTS IN THIS C INTEGRATION, AND ARE THEN UPDATED TO HOLD X,Y IN C PREPARATION FOR NEXT CALL TO STATS. C XT - LAST MESHPOINT OF METHOD. C XOLDG - INDEP VAR FOR 'TRUE' GLOBAL SOLUTION, IN COMMON. C YOLDG - 'TRUE' GLOBAL SOLUTION AT XOLDG, HELD IN COMMON. C UPDATED BY CALLING TRUE AT EACH CALL TO STATS IF C DETAILED STATISTICS ARE BEING COMPILED (IFLAG = 3) C AND IF OPT.GE.2 C YSTAR - ONLY USED IF OPT.EQ.4. IF SOLVER DOES NOT DO LOCAL C EXTRAPOLATION, WE FORM THE LOCALLY EXTRAPOLATED C SOLUTION IN YSTAR. C--------+---------+---------+---------+---------+---------+---------+-- C C--------+---------+---------+---------+---------+---------+---------+-- C COMMON AREAS C--------+---------+---------+---------+---------+---------+---------+-- C1 C2 C3 C4 C6 C .. Scalar Arguments .. DOUBLE PRECISION ERRBND, X C .. Array Arguments .. DOUBLE PRECISION ERREST(20), Y(20) C .. Scalars in Common .. DOUBLE PRECISION ERLUMP, ERRTOL, HSTART, PRECIS, XEND, XFIN, XOLD, * XOLD1, XOLDG, XT, XTRUE REAL GEMX, GEND, LEMXSC, OVHD, TIME, TRUTIM INTEGER ID, IFLAG, INDG, INDL, IOUT, IWT, N, NBAD, NDCV, * NFCN, NFCN1, NJAC, NJAC1, NLUD, NLUD1, NRMTYP, * NSTART, NSTL, NSTP, NTRU, OPT, XTRAP C .. Arrays in Common .. DOUBLE PRECISION CG(20), PDG(400), WG(400), WKG(20,12), YOLD(20), * YOLDG(20), YPG(20,11) INTEGER INFG(40) C .. Local Scalars .. DOUBLE PRECISION HLUMP, YNORM REAL ESTSC, LEERSC, LESC, THETA, TRUT0 INTEGER I, NDIM, NNFCN, NNJAC, NNLUD C .. Local Arrays .. DOUBLE PRECISION CL(20), PDL(400), WKL(20,12), WL(400), * YPL(20,11), YSTAR(20), ZERO(20) INTEGER INFL(40) C .. External Functions .. REAL CLOCK, CONST, DIFNRM EXTERNAL CLOCK, CONST, DIFNRM C .. External Subroutines .. EXTERNAL FCN, PDERV, PLOT, TRUE C .. Intrinsic Functions .. INTRINSIC AMAX1, DABS, DMAX1 C .. Common blocks .. COMMON /STCOM1/ERRTOL, OPT, NRMTYP, XTRAP, ID, IWT, IOUT COMMON /STCOM2/XEND, HSTART, N, IFLAG, INDL, INDG COMMON /STCOM3/XFIN, XTRUE, TIME, OVHD, TRUTIM, GEND, * GEMX, LEMXSC, NFCN, NJAC, NLUD, NSTP, NSTL, NDCV, * NBAD, NTRU, NSTART COMMON /STCOM4/XOLD1, XOLD, YOLD, XOLDG, YOLDG, CG, PDG, * WKG, WG, YPG, XT, PRECIS, ERLUMP, INFG COMMON /STCOM6/NFCN1, NJAC1, NLUD1 C .. Data statements .. CE C DATA NDIM/20/ C .. Executable Statements .. C C--------+---------+---------+---------+---------+---------+---------+-- C IF IFLAG = 0 METHOD IS BEING TIMED. C--------+---------+---------+---------+---------+---------+---------+-- IF (IFLAG.EQ.0) RETURN C C--------+---------+---------+---------+---------+---------+---------+-- C IF IFLAG = 1 INITIALIZE VARIABLES TO DO WITH FINDING FIRST STEP- C SIZE, ASSESSING LUMPED STEPS AND COMPUTING TRUE GLOBAL SOLUTION. C RESET INDL, OTHERWISE A LOCAL FAILURE (INDL<0) ON A PREVIOUS C INTEGRATION WILL BE DEEMED A FAILURE ON THIS ONE. C 1ST 5 ELEMENTS OF INFG,CG MUST BE INITIALIZED; WE INITIALIZE C MORE TO AID DIAGNOSTICS. C--------+---------+---------+---------+---------+---------+---------+-- IF (IFLAG.NE.1) GO TO 60 C C FOR EVALUATING PERFORMANCE OF 'TRUE': C CALL TRUCHK(1,IDUM) PRECIS = 1000.D0*CONST(1) ERLUMP = 0.D0 XOLD1 = X XOLD = X XOLDG = X XT = X DO 20 I = 1, N YOLD(I) = Y(I) YOLDG(I) = Y(I) 20 CONTINUE DO 40 I = 1, 20 INFG(I) = 0 CG(I) = 0.D0 40 CONTINUE INFG(1) = 1 INFG(3) = 1000 INDG = 2 INDL = 2 RETURN C--------+---------+---------+---------+---------+---------+---------+-- C IF IFLAG = 2 DETERMINE THE INITIAL STEPSIZE FOR C THE INTEGRATION PROPER. WE CHOOSE THE SECOND STEP C TAKEN AND TERMINATE THE INTEGRATION BY SETTING X C EQUAL TO XEND. HSTART THEN HOLDS THE CURRENT STEPSIZE. C--------+---------+---------+---------+---------+---------+---------+-- 60 IF (IFLAG.NE.2) GO TO 80 NSTP = NSTP + 1 HSTART = X - XOLD1 XOLD1 = X IF (NSTP.GE.2) X = XEND RETURN C C C--------+---------+---------+---------+---------+---------+---------+-- C IF IFLAG = 3 COMPILE STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- C C IF THE STEPSIZE AND, HENCE, THE ERROR REQUIREMENT WAS C TOO SMALL TO PERMIT AN EFFECTIVE ASSESSMENT AT THIS C PRECISION, CONTINUE THE INTEGRATION. A LUMPED ERROR C ESTIMATE IS FORMED IN ERLUMP AND SEVERAL SMALL STEPS C ASSESSED AS ONE. C THE TEST FOR THE SIZE OF A LUMPED STEP IS MATCHED TO THE C MINIMUM STEPSIZE TEST IN 'TRUE' AND IS INTENDED TO ENSURE C (VERY CONSERVATIVELY) THAT ROUNDOFF EFFECTS ARE NEGLIGIBLE. C MAX-NORM IS USED IRRESPECTIVE OF THE VALUE OF NRMTYP IN /STCOM1/. C IT IS ASSUMED THAT LUMPING OCCURS ONLY WHEN FAST TRANSIENTS ARE C BEING DAMPED OUT AND CONSEQUENTLY THE STEPSIZE WILL BE RAPIDLY C INCREASING. IN THIS SITUATION EARLIER LOCAL ERRORS HAVE LESS C EFFECT ON THE LUMPED ERROR THAN RECENT ONES AND THE C FORMULA FOR ERLUMP IS A CRUDE WAY TO ENSURE THIS. C--------+---------+---------+---------+---------+---------+---------+-- 80 CONTINUE NSTP = NSTP + 1 HLUMP = X - XOLD THETA = (X-XT)/HLUMP ERLUMP = ERLUMP + THETA*(ERRBND-ERLUMP) XT = X YNORM = 0.D0 DO 100 I = 1, N YNORM = DMAX1(YNORM,DABS(YOLDG(I)),DABS(Y(I))) 100 CONTINUE IF (HLUMP*ERRTOL.GE.YNORM*PRECIS) GO TO 120 C WRITE(6,998)XOLD,X,THETA,HLUMP,ERREST,ERRBND,NSTL,NSTP C998 FORMAT(1H0,'XOLD X THETA HLUMP ERREST ERRBND NSTL NSTP=', C * 1P6D12.4,2I4) RETURN C C--------+---------+---------+---------+---------+---------+---------+-- C A SUFFICIENTLY LARGE LUMPED STEP HAS BEEN FORMED. C INCREMENT THE LUMPED STEP COUNT. C--------+---------+---------+---------+---------+---------+---------+-- 120 CONTINUE NSTL = NSTL + 1 C--------+---------+---------+---------+---------+---------+---------+-- C GLOBAL ASSESSMENT C SAVE COUNTERS THAT WILL BE AFFECTED BY 'TRUE' CALLS. SET MAX C STEPSIZE FOR GLOBAL SOLUTION TO X-XOLDG (DEFAULT VALUE IN TRUE IS C 1/5TH OF THIS.) C CONTINUE TRUE GLOBAL SOLUTION TO CURRENT MESHPOINT AND C UPDATE MAX GLOBAL ERROR GEMX. C IF FAILURE OCCURS, RECORD POSITION IN XTRUE AND SKIP LOCAL C ASSESSMENT ALSO. C--------+---------+---------+---------+---------+---------+---------+-- IF (OPT.LT.2 .OR. INDG.LT.0) GO TO 240 NNFCN = NFCN1 NNJAC = NJAC1 NNLUD = NLUD1 CG(4) = 1.1D0*(X-XOLDG) TRUT0 = CLOCK(0.) C CALL TRUE(FCN,PDERV,NDIM,N,XOLDG,YOLDG,X,1.D-2*ERRTOL,INDG,CG, * INFG,YPG,WG,PDG,WKG) C TRUTIM = TRUTIM + CLOCK(TRUT0) INFG(3) = INFG(13) + 100 IF (INDG.GE.0) GO TO 140 XTRUE = XOLDG C WRITE(6,999)(INFG(I),I=1,20),CG C999 FORMAT(1H0,'TRUE FAILURE, INF & C ='/1H0,20I6/ C * (1H0,1P10D12.4)) GO TO 220 140 GEMX = AMAX1(GEMX,DIFNRM(Y,YOLDG,N)) C--------+---------+---------+---------+---------+---------+---------+-- C LOCAL ASSESSMENT C OBTAIN THE LOCAL SOLUTION THROUGH THE PREVIOUS COMPUTED C MESH VALUE TO HIGHER ACCURACY THAN METHOD, PROVIDED NO C FAILURES HAVE OCCURRED IN PREVIOUS CALLS TO TRUE C (INDL.GE.0). CHECK FOR A FAILURE THIS TIME AFTER THE C CALL TO TRUE. COMPILE THE RELIABILITY STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- IF (OPT.LT.3 .OR. INDL.LT.0) GO TO 220 DO 160 I = 1, 5 INFL(I) = 0 CL(I) = 0.D0 160 CONTINUE INFL(1) = 1 INFL(3) = 500 INDL = 2 CL(4) = 1.1D0*(X-XOLD) TRUT0 = CLOCK(0.) C CALL TRUE(FCN,PDERV,NDIM,N,XOLD,YOLD,X,1.D-2*ERLUMP,INDL,CL,INFL, * YPL,WL,PDL,WKL) C TRUTIM = TRUTIM + CLOCK(TRUT0) XTRUE = XOLD C IF(INDL.LT.0)WRITE(6,999)(INFL(I),I=1,20),CL IF (INDL.LT.0) GO TO 220 C--------+---------+---------+---------+---------+---------+---------+-- C UPDATE STATISTICS C LESC RECORDS THE RATIO OF THE MAGNITUDE OF THE TRUE C LOCAL ERROR TO THE ASSUMED LOCAL ERROR BOUND. C LEMXSC RECORDS ITS MAXIMUM OVER THE RANGE. C NTRU COUNTS THE NO. OF LUMPED STEPS OF METHOD ON WHICH C LOCAL ASSESSMENT SUCCEEDED, SO AS TO ALLOW SUMMARY OF PARTIAL C RESULTS IF TRUE FAILS AT SOME POINT. C C IF OPT=4, DO THE ANALYSIS OF THE LOCAL ERROR ESTIMATE VECTOR, C ERREST, BY FORMING THE SCALED ||ERROR|| IN ERREST. IF LOCAL C EXTRAPOLATION IS DONE THIS IS LESC=||ERREST||/ERLUMP. IF NOT, C FORM YSTAR=LOCALLY EXTRAPOLATED SOLUTION AND IT IS THEN C ||YSTAR-YOLD||/ERLUMP. FORM A POINT ON THE SCATTER DIAGRAM C OF ERROR IN ERREST (VERT AXIS) VS. ERREST (HORIZ AXIS) C AND ENTER IT BY A CALL TO 'PLOT'. C--------+---------+---------+---------+---------+---------+---------+-- C C FOR EVALUATING PERFORMANCE OF 'TRUE': C CALL TRUCHK(3,INFL) LESC = DIFNRM(Y,YOLD,N)/ERLUMP LEMXSC = AMAX1(LEMXSC,LESC) IF (LESC.GT.1.0) NDCV = NDCV + 1 IF (LESC.GT.5.0) NBAD = NBAD + 1 IF (OPT.EQ.4) THEN C XTRAP=1 OR 0 ACCORDING AS THE USER HAS TOLD THE PACKAGE THAT C LOCAL EXTRAPOLATION IS OR IS NOT BEING DONE BY SOLVER: IF (XTRAP.EQ.0) THEN DO 180 I = 1, N YSTAR(I) = Y(I) - ERREST(I) 180 CONTINUE LEERSC = DIFNRM(YSTAR,YOLD,N)/ERLUMP ELSE LEERSC = LESC END IF ESTSC = DIFNRM(ERREST,ZERO,N)/ERLUMP CALL PLOT(ESTSC,LEERSC,1) C WRITE(IOUT,'('' I TRUE LE EST LE'')') C DO 95 I=1,N C95 WRITE(IOUT,''(' ',I3,2F14.10)'') I,LERR(I),ERREST(I) END IF C NTRU = NTRU + 1 C--------+---------+---------+---------+---------+---------+---------+-- C UPDATE MEMORY OF LAST COMPUTED VALUES. C--------+---------+---------+---------+---------+---------+---------+-- DO 200 I = 1, N YOLD(I) = Y(I) 200 CONTINUE C--------+---------+---------+---------+---------+---------+---------+-- C RESTORE THE COUNTS AFFECTED BY 'TRUE' CALLS. C--------+---------+---------+---------+---------+---------+---------+-- 220 NFCN1 = NNFCN NJAC1 = NNJAC NLUD1 = NNLUD C--------+---------+---------+---------+---------+---------+---------+-- C RE-INITIALIZE THE DATA PERTAINING TO A LUMPED STEP. C--------+---------+---------+---------+---------+---------+---------+-- 240 ERLUMP = 0.D0 XOLD = X C--------+---------+---------+---------+---------+---------+---------+-- C RETURN TO METHOD TO CONTINUE THE INTEGRATION. C--------+---------+---------+---------+---------+---------+---------+-- RETURN END * SUBROUTINE PLOT(X,Y,IFLAG) C ROUTINE TO FORM PLOTS OF LOCAL ERROR INFORMATION FOR DETEST, USING C AN ARRAY K WHICH IS IN 'SAVE' STORAGE. C C IF IFLAG<=0, IT RESETS ARRAY K TO ZERO. C C IF IFLAG=1, THE ROUTINE ENTERS (X,Y) ON THE SCATTER-DIAGRAM C REPRESENTED BY K. HERE X,Y ARE >= 0, AND THE RANGE 0 TO INFINITY IS C SPLIT INTO CLASS-INTERVALS NUMBERED I = NLO .. NHI, THE I-TH INTERVAL C BEING 2**(I-1) <= X < 2**I EXCEPT THAT THE NLO-TH ONE INCLUDES ALL C X BELOW 2**NLO AND THE NHI-TH INCLUDES ALL X >=2**(NHI-1). C C IF IFLAG=2, THE SCATTER DIAGRAM IS PRINTED OUT. C C NOTE: IF IMPLEMENTER WISHES TO ALTER NLO, NHI THEN THE DATA C STATEMENTS MUST BE ALTERED CORRESPONDINGLY. C CERR CHARACTER STR3*3, LINE*LINLEN, LINE1*LINLEN, LINE2*LINLEN, CERR * LINE3*LINLEN, LINE4*LINLEN C .. Parameters .. INTEGER NLO, NHI REAL ALOG2 INTEGER NMIN, LINLEN REAL XYMIN PARAMETER (NLO=-7,NHI=4,ALOG2=.69314718,NMIN=NLO-1, * LINLEN=3*(NHI-NLO+1)+1,XYMIN=2.**NMIN) C .. Scalar Arguments .. REAL X, Y INTEGER IFLAG C .. Local Scalars .. REAL C, P, T INTEGER I, IOUT, J, JL, KMAX, KTOT CHARACTER*(LINLEN) LINE CHARACTER*(LINLEN) LINE1 CHARACTER*(LINLEN) LINE2 CHARACTER*(LINLEN) LINE3 CHARACTER*(LINLEN) LINE4 C .. Local Arrays .. INTEGER K(NLO:NHI,NLO:NHI) C .. External Functions .. REAL CONST CHARACTER*3 STR3 EXTERNAL CONST, STR3 C .. Intrinsic Functions .. INTRINSIC ALOG, MAX, MIN, NINT C .. Statement Functions .. INTEGER ICLAS, ICLAS0 C .. Save statement .. SAVE K, KTOT, KMAX, IOUT C .. Data statements .. DATA LINE1/'+--+--+--+--+--+--+--+--+--+--+--+--+'/, * LINE2/'+ +'/, * LINE3/'| |'/, * LINE4/' 2 2 2 2 2 2 2 2 2 2 2 '/ C .. Executable Statements .. C C C .. Statement Function definitions .. ICLAS0(T) = NMIN + NINT(ALOG(MAX(1.,T/XYMIN))/ALOG2) ICLAS(T) = MIN(MAX(ICLAS0(T),NLO),NHI) IF (IFLAG.LE.0) THEN IOUT = CONST(3) KTOT = 0 KMAX = 0 DO 40 I = NLO, NHI DO 20 J = NLO, NHI K(I,J) = 0 20 CONTINUE 40 CONTINUE ELSE IF (IFLAG.EQ.1) THEN IF (X.LT.0. .OR. Y.LT.0.) THEN WRITE (IOUT,FMT=*) * ' ERROR IN ARGUMENTS TO DETEST PLOT ROUTINE', X, Y STOP END IF I = ICLAS(X) J = ICLAS(Y) K(I,J) = K(I,J) + 1 KTOT = KTOT + 1 KMAX = MAX(KMAX,K(I,J)) ELSE C = KTOT DO 80 I = NHI, NLO, -1 LINE = LINE3 DO 60 J = NLO, NHI JL = J - NLO P = K(J,I)/C LINE(3*JL+1:3*JL+3) = STR3(P) 60 CONTINUE CERR8 LINE(3*JL+1:3*JL+3) = STR3(K(J,I)/C) IF (LINE(1:1).EQ.' ') LINE(1:1) = '|' IF (I.EQ.NHI) THEN WRITE (IOUT,FMT='(1X,15X,''INFINITY '',A)') LINE1 WRITE (IOUT,FMT='(1X,20X,'' '',A)') LINE ELSE WRITE (IOUT,FMT='(1X,15X,I8,1X,A)') I, LINE2 WRITE (IOUT,FMT='(1X,20X,''2 '',A)') LINE END IF 80 CONTINUE WRITE (IOUT,FMT='(1X,24X,A)') LINE1 WRITE (IOUT,FMT='(/1X,25X,30I3)') (J,J=NLO,NHI-1) WRITE (IOUT,FMT='(1X,24X,A)') LINE4 END IF RETURN END CHARACTER*3 FUNCTION STR3(P) C CONVERTS P (MEANT TO BE IN RANGE 0 TO 1) TO A 3 CHARACTER C INTEGER PERCENTAGE. P=0 BECOMES ' ', 0-+ C | +------+ | BEING | | C | | | TESTED)| | C | | +--------+ |---FCN,PDERV C | | | C | STATS---TRUE--->--+ C | C +----EVALU C C WE ACKNOWLEDGE VALUABLE RECOMMENDATIONS IN SHAMPINE'S PAPER [5]. IN C PARTICULAR THE PACKAGE WILL, BY DEFAULT, INTEGRATE EACH SYSTEM IN C SCALED FORM, SCALING EACH SOLUTION COMPONENT BY ITS MAXIMUM OBSERVED C VALUE OVER THE RANGE OF INTEGRATION. THAT IS, THE CHANGE OF VARIABLE C -1 C Z = D Y IS DONE WHERE C D = DIAG(W(1), .., W(N)) C C AND W(I) =MAX |I-TH COMPONENT OF Y| OVER THE RANGE. THE PROBLEM C -1 C SOLVED IS THEN Z' = D F(X,DZ). THE WEIGHTS W(I) WERE FOUND BY AN C ACCURATE INTEGRATION OF EACH PROBLEM AND ARE EMBEDDED IN IVALU. C NOTE THAT THIS SCALING AFFECTS THE NORMS WHICH ARE USED IN C MEASURING ALL ERRORS, AND THUS CAN HAVE A CONSIDERABLE EFFECT ON THE C ACCURACY IN SOME OF THE PROBLEMS. C C IF THE PROBLEM CODE IN IDLIST (SEE BELOW) IS GIVEN A NEGATIVE SIGN THE C SYSTEM IS SOLVED IN ITS 'NATURAL' SCALING, AS WAS DONE IN THE 1975 C VERSION OF DETEST. C C C REFERENCES C ----------- C C [1] W H ENRIGHT, 'USING A TESTING PACKAGE FOR THE AUTOMATIC C ASSESSMENT OF NUMERICAL METHODS FOR ODES', IN PERFORMANCE C EVALUATION OF NUMERICAL SOFTWARE, (FOSDICK, ED), IFIP, NORTH C HOLLAND PUBL CO (1979) 199-213. C C C [2] W H ENRIGHT AND T E HULL, 'COMPARING NUMERICAL METHODS FOR THE C SOLUTION OF STIFF SYSTEMS OF ODES ARISING IN CHEMISTRY', IN C NUMERICAL METHODS FOR DIFFERENTIAL SYSTEMS (LAPIDUS AND C SCHIESSER, EDS), ACADEMIC PRESS, NEW YORK (1976) 45-65. C C [3] W H ENRIGHT, T E HULL AND B LINDBERG, 'COMPARING NUMERICAL C METHODS FOR STIFF SYSTEMS OF ORDINARY DIFFERENTIAL EQUATIONS', C BIT 15(1975) 10-48. C C [4] W H ENRIGHT AND J D PRYCE, 'A PAIR OF PACKAGES FOR ASSESSING C INITIAL VALUE METHODS', UNIVERSITY OF TORONTO TECHNICAL REPORT C NO. 167/83. C C [5] L F SHAMPINE 'EVALUATION OF A TEST SET FOR STIFF ODE SOLVERS', C TOMS 7(1981)409-420. C C C C C C C C C 2. ARGUMENTS TO STDTST: C --------- -- ------- C C TITLE (INPUT) CHARACTER OF LENGTH 80, HOLDS NAME OF METHOD BEING C TESTED. C C OPTION (INPUT) INTEGER ARRAY OF LENGTH 10, ONLY ELEMENTS 1 TO 3 ARE C USED AND ARE REFERRED TO HENCEFORTH AS OPT, NORMEF AND NRMTYP. C (OPTION(4) IS ALSO USED WHEN OPT=4) C C OPT ONE OF 1, 2, 3 OR 4. OPT SELECTS LEVEL OF ANALYSIS REQUIRED: C 1 GIVES A REPORT OF THE FOLLOWING AT EACH TOLERANCE USED: C - TOTAL TIME PER INTEGRATION C - OVERHEAD TIME EXCLUDING FUNCTION AND JACOBIAN CALLS AND MATRIX C FACTORIZATIONS. C - NUMBER OF FUNCTION CALLS, JACOBIAN CALLS, MATRIX C FACTORIZATIONS AND SUCCESSFUL STEPS OVER RANGE C - GLOBAL ERROR AT ENDPOINT XEND, DIVIDED BY TOL, IE. C ||(COMPUTED Y) - (TRUE Y)||/TOL AT X=XEND C THE NORM USED THROUGHOUT THE PACKAGE IS THAT CHOSEN BY NRMTYP. C C 2 REPORTS (IN ADDITION TO THE ABOVE STATISTICS): C - MAXIMUM GLOBAL ERROR OVER RANGE. THE 'TRUE' SOLUTION OVER C THE RANGE IS OBTAINED BY A RELIABLE INTEGRATOR AT A MORE C STRINGENT TOLERANCE. C C 3 REPORTS (IN ADDITION TO THE ABOVE): C - MAXIMUM LOCAL ERROR OVER RANGE, IE. MAX OVER ALL MESHPOINTS C OF C LENRM = ||(COMPUTED Y) - YLOC||/ERRBND C WHERE YLOC IS THE TRUE LOCAL SOLUTION THROUGH THE PREVIOUS C MESHPOINT, AND ERRBND, THE ASSUMED ERROR BOUND, IS EXPLAINED C BELOW. C - FRACTION OF STEPS WHERE LENRM EXCEEDED 1. C - FRACTION OF STEPS WHERE LENRM EXCEEDED 5. C C 4 REPORTS (IN ADDITION TO THE ABOVE): C - AN ANALYSIS OF THE LOCAL ERROR ESTIMATES USED BY SOLVER AS THE C BASIS FOR ITS ERROR CONTROL. AT THIS LEVEL THREE ASSUMPTIONS C ARE MADE. FIRST, THAT AT EACH STEP SOLVER FORMS TWO C APPROXIMATIONS, Y AND Y*, TO THE LOCAL SOLUTION YLOC AT THE C NEW MESHPOINT, SUCH THAT ASYMPTOTICALLY AS TOL->0, Y* IS 'MORE C ACCURATE' THAN Y. SECOND, THAT THE APPROXIMATION WHICH IS C TAKEN AS THE COMPUTED SOLUTION AT THE NEW MESHPOINT IS EITHER C ALWAYS Y* (IN WHICH CASE ONE SAYS LOCAL EXTRAPOLATION IS USED) C OR ALWAYS Y (IN WHICH CASE IT IS NOT USED). THE VECTOR C LE = Y - YLOC C IS THE TRUE LOCAL ERROR IN THE 'LESS ACCURATE' SOLUTION Y, C AND C ERREST = Y - Y* C IS AN ESTIMATE OF LE. IT IS ASSUMED FINALLY THAT THE ERROR C CONTROL CONSISTS IN KEEPING ||ERREST||, IN AN APPROPRIATE C NORM, BELOW ERRBND AT EACH STEP. C C NOTE THAT SOME METHODS, SUCH AS (IN THE NONSTIFF CASE) C MERSON'S METHOD, CANNOT BE REGARDED IN THIS WAY. C C AT THIS LEVEL DETEST ANALYSES HOW ACCURATELY ERREST C APPROXIMATES TO LE, BY FORMING A SCATTER PLOT OF THE VALUES OF C R1 = ||ERREST - LE||/ERRBND (VERTICAL AXIS) AGAINST R2 = C ||ERREST||/ERRBND (HORIZONTAL) AT EACH STEP. NOTE ERREST - C LE = -(Y* - YLOC) = -LE*, SAY, SO THAT LENRM DEFINED ABOVE IS C R1 IF LOCAL EXTRAPOLATION IS BEING DONE. FOR AN 'IDEAL' ERROR C CONTROL STRATEGY, WE EXPECT THE PLOTTED POINTS TO CLUSTER NEAR C (1,0) ON THE GRAPH, WHETHER OR NOT LOCAL EXTRAPOLATION IS C USED. C C TO USE THIS LEVEL OF ANALYSIS THE USER MUST: C A) ENSURE THAT THE STATS CALL IN METHOD DELIVERS ERREST AS C DEFINED ABOVE (WITH THE CORRECT SIGN!). C B) SET OPTION(4) AS FOLLOWS. C =0 ARGUMENT Y TO STATS IS Y ABOVE (NO LOCAL EXTRAPOLATION). C =1 Y IS Y* ABOVE (LOCAL EXTRAPOLATION). C C FOR EACH INTEGRATION, A SCATTER PLOT IS PRODUCED. EACH OF THE C RATIOS R1, R2 IS PUT INTO ONE OF 12 CLASS-INTERVALS C -7 -7 -6 2 3 3 C 0<=R<2 , 2 <=R<2 , ..., 2 <=R<2 , 2 <=R= 2, AND HAVE A POSSIBLY MORE EFFICIENT C CODE TO PUT IN ITS PLACE. NSTL IS RELEVANT IF YOU ARE C INTERESTED IN THE ALGORITHMS USED BY THE PACKAGE, SPECIFICALLY THE C STEP-LUMPING PROCESS WHICH TAKES PLACE IN STATS AT STRINGENT C TOLERANCES. C C C C C 9. SUBROUTINES IN THE PACKAGE C ----------- -- --- ------- C C IN ORDER OF APPEARANCE IN THE FILES. THE LIST ALSO SHOWS, FOR EACH C ROUTINE, THE OTHER PACKAGE ROUTINES AND COMMON AREAS WHICH IT USES. A C NAME IN PARENTHESES, LIKE (FCN) DENOTES A ROUTINE WHICH IS CALLED AT C ONE REMOVE (EG. METHOD CALLS SOLVER WHICH MUST CALL FCN) OR WHICH IS C PASSED AS AN ARGUMENT RATHER THAN BEING AN EXTERNAL REFERENCE (EG. C FCN IN TRUE). C C IN CONCLK FILE C CONST CALLS: NONE C CLOCK CALLS: NONE C C IN STDTST FILE C STDTST CALLS: PARCHK LSQFIT RATIO EFSTAT CNTROL CONST ; STCOM1 C STCOM3 C PARCHK CALLS: NONE C LSQFIT CALLS: NONE C RATIO CALLS: NONE C EFSTAT CALLS: NONE C CNTROL CALLS: DIFNRM STATS CONST CLOCK IVALU EVALU METHOD PLOT ; C STCOM1 STCOM2 STCOM3 STCOM5 STCOM6 C DIFNRM CALLS: NONE C STATS CALLS: DIFNRM CONST TRUE FCN PDERV PLOT ; STCOM1 STCOM2 C STCOM3 STCOM4 STCOM6 C PLOT CALLS: NONE C C IN STTRUE FILE C TRUE CALLS: CONST STEP NEWSTP COEFF DDCOMP DSOLVE (FCN C PDERV ) C STEP CALLS: NONE C NEWSTP CALLS: NONE C COEFF CALLS: NONE C DDCOMP CALLS: ; STCOM6 C DSOLVE CALLS: NONE C C IN STPROB FILE C IVALU CALLS: NONE C EVALU CALLS: NONE C FCN CALLS: ; STCOM5 STCOM6 C PDERV CALLS: ; STCOM5 STCOM6 C C USER-SUPPLIED C METHOD CALLS: STATS (FCN PDERV ) C C C 10. DEFINITION OF COMMON AREAS AND DICTIONARY OF DATA-FLOW C ---------- -- ------ ----- --- ---------- -- --------- C C THE FLOW OF INFORMATION BETWEEN THOSE ROUTINES WHICH USE COMMON IS C INDICATED FOR EACH VARIABLE BY THE CODES C S: THE VARIABLE IS ASSIGNED A VALUE (SET) IN THIS ROUTINE, POSSIBLY C BY A CALL TO ANOTHER ROUTINE TO WHICH THE VARIABLE IS PASSED AS C AN ARGUMENT. C A: THE VALUE IS USED (ACCESSED) IN THIS ROUTINE. C C FOR COUNTERS AND SIMILAR VARIABLES, THESE CODES ARE USED INSTEAD OF C CODE S: C I: THE VARIABLE IS INITIALIZED IN THIS ROUTINE. C U: THE VARIABLE IS UPDATED IN THIS ROUTINE. C C C COMMON /STCOM1/ PASSES INFORMATION FROM STDTST TO CNTROL AND STATS. C C STDTST C | CNTROL C | | STATS C | | | DIFNRM C | | | | C S A A - ERRTOL DOUBLE. COPY OF CURRENT ERROR TOLERANCE. C S A A - OPT INTEGER. COPY OF OPTION(1) ARGUMENT OF STDTST. C S - - A NRMTYP INTEGER. COPY OF OPTION(3) ARGUMENT OF STDTST. C S - A - XTRAP INTEGER. COPY OF OPTION(4) ARGUMENT OF STDTST. C S A - - ID INTEGER. INTERNAL CODE OF CURRENT PROBLEM, 1 FOR A1, C ..., 13 FOR B3, ETC. C S A - - IWT INTEGER. FLAG FOR SCALING (+1: SCALED. -1: C UNSCALED) C S - - - IOUT INTEGER. STANDARD OUTPUT UNIT NUMBER. C C C C C COMMON /STCOM2/ COMMUNICATES BETWEEN CNTROL AND STATS. C C CNTROL C | STATS C | | C S A XEND DOUBLE. END OF INTEGRATION RANGE OF CURRENT PROBLEM. C A S HSTART DOUBLE. INITIAL STEPSIZE PASSED TO METHOD FOR C INTEGRATION PROPER. C S A N INTEGER. NO. OF EQUATIONS IN CURRENT PROBLEM. C S A IFLAG INTEGER. SET BY CNTROL TO INFORM STATS WHAT IT IS TO C DO: C =0 METHOD IS BEING TIMED. C =1 INITIALIZING CALL OF STATS FROM CNTROL TO SET UP C STCOM4. C =2 PRELIMINARY INTEGRATION TO DETERMINE HSTART, ABORTED C AFTER 2 STEPS. C =3 INTEGRATION PROPER, COMPILING STATISTICS. C C C A SA INDL,INDG C ERROR FLAGS FOR THE LOCAL AND GLOBAL 'TRUE SOLUTIONS' C OBTAINED BY CALLS TO ROUTINE TRUE. C C C C C C COMMON /STCOM3/ OUTPUTS STATISTICS FROM CNTROL AND STATS. C C STDTST C | CNTROL C | | STATS C | | | C A S - XFIN DOUBLE. POINT OF FAILURE OF METHOD IF IT DOESN'T REACH C XEND. C A - S XTRUE DOUBLE. POINT OF FAILURE OF TRUE IF ANY. IF BOTH C LOCAL AND GLOBAL FAIL, POINT OF GLOBAL FAILURE IS C RETURNED. C A S - TIME REAL. CPU TIME FOR ONE INTEGRATION AS MEASURED BY C CLOCK FUNCTION. C A S - OVHD REAL. EQUALS TIME LESS ESTIMATED COST OF FCN, PDERV C AND MATRIX FACTORIZATION CALLS. C A I U TRUTIM REAL. THE TIME SPENT IN CALLS TO TRUE. NOT RELEVANT C TO PERFORMANCE OF METHOD BUT MEASURES THE OVERHEAD C INCURRED BY THE TESTING PACKAGE WHEN OPT = 2, 3 OR 4. C NOT PRINTED BUT AVAILABLE. C A S - GEND REAL. NORM OF GLOBAL ERROR OF METHOD AT XEND. C C C A I U GEMX REAL. MAXIMUM OF GLOBAL ERROR OVER ALL LUMPED STEP C MESHPOINTS, IE. USUALLY OVER ALL MESHPOINTS OF METHOD, C EXCEPT WHEN ERRTOL IS VERY SMALL. C A I U LEMXSC REAL. MAXIMUM LOCAL ERROR IN UNITS OF ERRBND, OVER ALL C LUMPED STEP MESHPOINTS. C A S - NFCN,NJAC,NLUD C INTEGER. COPIES OF NFCN1,NJAC1,NLUD1, SEE /STCOM5/, C /STCOM6/ C A I U NSTP INTEGER. COUNTS (UNLUMPED) STEPS TAKEN BY METHOD IN C CURRENT INTEGRATION. C - I U NSTL INTEGER. COUNTS LUMPED STEPS FORMED IN CURRENT C INTEGRATION (SEE STATS). NOT PRINTED BUT AVAILABLE. C A I U NDCV,NBAD C INTEGER. COUNT LUMPED STEPS ON WHICH SOLVER'S LOCAL C ERROR CONTROL WAS DECEIVED, RESP. BADLY DECEIVED. C A I U NTRU INTEGER. COUNTS LUMPED STEPS ON WHICH TRUE LOCAL C SOLUTION WAS SUCCESSFULLY COMPUTED, HENCE VALID LOCAL C ERROR STATISTICS OBTAINED. USED IN COMPUTING 'FRACTION C DECEIVED' INFORMATION. REPORTED IF DIFFERENT FROM C NSTP. NOTE NTRU <= NSTL <= NSTP. C - S - NSTART INTEGER. NO. OF FCN CALLS NEEDED BY METHOD TO START, C IE. TO DO PRELIMINARY INTEGRATION (2 STEPS). NOT C PRINTED OUT BUT AVAILABLE. C C C COMMON /STCOM4/ IS USED ONLY BY STATS, TO PRESERVE INFORMATION FROM C ONE CALL OF STATS TO ANOTHER. ALL VARIABLES ARE SET AND/OR UPDATED IN C STATS. C C XOLD1 DOUBLE. SIMILAR TO XOLD BUT USED IN PRELIMINARY C INTEGRATION. C XOLD,YOLD C DOUBLE AND DOUBLE ARRAY. COPY OF METHOD'S COMPUTED C SOLUTION AT END OF PREVIOUS LUMPED STEP. USED AS C ACTUAL ARGUMENTS OF TRUE LOCAL SOLUTION CALL. C XOLDG,YOLDG C DOUBLE AND DOUBLE ARRAY. HOLD 'TRUE' GLOBAL SOLUTION C UPDATED TO END OF PREVIOUS LUMPED STEP. USED AS ACTUAL C ARGUMENTS OF TRUE GLOBAL SOLUTION CALL. C CG,PDG,WKG,WG,YPG,INFG C WORKSPACE FOR 'TRUE' GLOBAL SOLUTION. C XT DOUBLE. HOLDS LAST METHOD MESHPOINT BETWEEN CALLS TO C STATS. C PRECIS DOUBLE. HOLDS 1000 * (UNIT ROUNDOFF) APPROX. C ERLUMP DOUBLE. ACCUMULATES METHOD'S LOCAL ERROR ESTIMATES TO C FORM AN ESTIMATE OVER A LUMPED STEP. C C C COMMON /STCOM5/ PASSES INFORMATION BETWEEN CNTROL AND FCN, PDERV, (OR C ANY REPLACEMENTS A USER MAY PROVIDE FOR FCN, PDERV). C C CNTROL C | FCN C | | PDERV C | | | C C S A A WT DOUBLE. ARRAY OF WEIGHTS USED TO IMPLEMENT THE C 'SCALED' INTEGRATION OPTION. C S A A IWT1,N1,ID1 C INTEGER. COPIES OF IWT,N,ID IN /STCOM1/ OR /STCOM2/. C C C COMMON /STCOM6/ HOLDS COUNTERS. THEY ARE INITIALIZED IN CNTROL, C SAVED-AND-RESTORED IN STATS, AND EVENTUALLY COPIED BY CNTROL TO THE C CORRESPONDING VARIABLES IN /STCOM3/. C C CNTROL C | STATS C | | FCN C | | | PDERV C | | | | DDCOMP,ETC C | | | | | C C IA AS U - - NFCN1 INTEGER. COUNTS CALLS TO FCN. C IA AS - U - NJAC1 INTEGER. COUNTS CALLS TO PDERV. C IA AS - - U NLUD1 INTEGER. COUNTS CALLS TO ANY "O(N CUBED)" C LINEAR ALGEBRA ROUTINES WHICH METHOD MAY EMPLOY. IN C PARTICULAR IT IS INCREMENTED BY THE LU DECOMPOSITION C ROUTINE DDCOMP WHICH IS USED BY TRUE AND IS AVAILABLE C TO THE USER. C C C THERE IS ALSO A COMMON/STCOM7/ USED BY THE DUMMY (DEBUGGING) VERSIONS C OF STDTST AND STATS FOR COMMUNICATION. C C--------+---------+---------+---------+---------+---------+---------+-- C E N D O F G E N E R A L D O C U M E N T A T I O N C********+*********+*********+*********+*********+*********+*********+** C C DESCRIPTION OF STDTST C ----------- -- ------ C C ROUTINE STDTST INTERPRETS THE LIST OF TOLERANCES AND LIST OF C GROUPS OF PROBLEMS SPECIFIED IN THE ARGUMENTS. USING CNTROL C TO GATHER INDIVIDUAL STATISTICS FOR ONE PROBLEM AT ONE C TOLERANCE, IT ORGANIZES THE FORMATION AND OUTPUT OF SUMMARY C STATISTICS. C INDIVIDUAL STATISTICS ARE INDEXED OVER TOLERANCES, PROBLEMS C AND GROUPS. C 'PROBLEMS-SUMMARY' MEANS SUM OF THESE OVER PROBLEMS IN A GROUP. C 'GROUPS-SUMMARY' MEANS SUM OF PROBLEMS-SUMMARY OVER ALL GROUPS. C 'OVERALL-SUMMARY' MEANS SUM OF GROUPS-SUMMARIES OVER ALL C TOLERANCES. C (READ 'MAX' FOR 'SUM' IN CASE OF SOME OF THE STATISTICS.) C C LOCAL VARIABLES: C PSNFCN,PSNJAC,... HOLD THE SUMMARY OVER PROBLEMS IN A GROUP C OF NFCN,NJAC,... (SEE DESCRIPTION OF /STCOM3/) AT ALL THE C TOLERANCES USED. C GSNFCN,... HOLD SUMMARY OVER GROUPS OF PSNFCN,... C OSNFCN,... HOLD OVERALL SUMMARY (OVER TOLERANCES) OF GSNFCN,... C C LGTOL HOLDS LOGARITHMS TO BASE 10 OF ELEMENTS OF ARRAY TOL, C AND LGGEMX,LGGEND HOLD LOGARITHMS OF CORRESPONDING GEMX C AND GEND VALUES, USED IN SMOOTHNESS CALCULATIONS. C NSNFCN,... STORE NFCN,... FOR ONE PROBLEM AT ALL TOLERANCES C USED, FOR USE IN NORMALIZED EFFICIENCY CALCULATIONS. C ERFLGE,ERFLG1 FLAG 'MISSING VALUES' IN SMOOTHNESS AND NORMALIZED C EFFICIENCY CALCULATIONS. C C C--------+---------+---------+---------+---------+---------+---------+-- C COMMON AREAS C--------+---------+---------+---------+---------+---------+---------+-- C1 C3 C .. Scalar Arguments .. REAL FLAG CHARACTER*80 TITLE C .. Array Arguments .. REAL TOL(11) INTEGER IDLIST(60), OPTION(10) C .. Scalars in Common .. REAL ERRTOL, XFIN, XTRUE REAL GEMX, GEND, LEMXSC, OVHD, TIME, TRUTIM INTEGER ID, IOUT, IWT, NBAD, NDCV, NFCN, NJAC, NLUD, * NRMTYP, NSTART, NSTL, NSTP, NTRU, OPT, XTRAP C .. Local Scalars .. REAL BIG, C, C1, CTEN, CTEN1, DUM, E, E1, FBADEC, * FDECEV, GEMXSC, GENDSC, OSLEMX, OSOVHD, OSTIME, * RES, RES1, TOLK INTEGER CMPLET, I, ICH, IDSUB, IID, INDG1, INDL1, * KCLASS, KGRP, KSYST, KTOL, NGRP, NOK, NOK1, * NORMEF, NSYST, NTOL, OSNBAD, OSNDCV, OSNFCN, * OSNJAC, OSNLUD, OSNSTP, OSNTRU CHARACTER BL CHARACTER*10 IDCLAS CHARACTER*32 MCNAME C .. Local Arrays .. REAL GSLEMX(10), GSOVHD(10), GSTIME(10), LGGEMX(10), * LGGEND(10), LGTOL(10), NSOVHD(10), NSTIME(10), * PSGEMX(10), PSGEND(10), PSLEMX(10), PSOVHD(10), * PSTIME(10) INTEGER GRPLST(2,6), GSNBAD(10), GSNDCV(10), GSNFCN(10), * GSNJAC(10), GSNLUD(10), GSNSTP(10), GSNTRU(10), * NSNFCN(10), NSNJAC(10), NSNLUD(10), NSNSTP(10), * PSNBAD(10), PSNDCV(10), PSNFCN(10), PSNJAC(10), * PSNLUD(10), PSNSTP(10), PSNTRU(10) LOGICAL ERFLG1(10), ERFLGE(10) C .. External Functions .. REAL CONST, RATIO EXTERNAL CONST, RATIO C .. External Subroutines .. EXTERNAL CNTROL, EFSTAT, LSQFIT, PARCHK, PLOT C .. Intrinsic Functions .. INTRINSIC ALOG10, AMAX1, CHAR, REAL, IABS, ISIGN C .. Common blocks .. COMMON /STCOM1/ERRTOL, OPT, NRMTYP, XTRAP, ID, IWT, * IOUT COMMON /STCOM3/XFIN, XTRUE, TIME, OVHD, TRUTIM, GEND, * GEMX, LEMXSC, NFCN, NJAC, NLUD, NSTP, NSTL, * NDCV, NBAD, NTRU, NSTART C .. Data statements .. CE C DATA IDCLAS/'ABCDEFGHIJ'/, BL/' '/, BIG/1.E20/ C .. Executable Statements .. C C--------+---------+---------+---------+---------+---------+---------+-- C COPY THE ENTRIES IN ARRAY 'OPTION'. C DO DUMMY CALL TO CONST TO INVOKE MACHINE-DEPENDENT INITIALIZ- C ATIONS. SET MACHINE NAME. SET OUTPUT UNIT NUMBER. C WRITE OUTPUT-HEADING. CALL ARGUMENT-CHECKING ROUTINE. C--------+---------+---------+---------+---------+---------+---------+-- OPT = OPTION(1) NORMEF = OPTION(2) NRMTYP = OPTION(3) XTRAP = OPTION(4) DUM = CONST(0) DO 20 I = 1, 32 ICH = CONST(-I) MCNAME(I:I) = CHAR(ICH) 20 CONTINUE IOUT = CONST(3) C WRITE (IOUT,FMT=99999) OPT, NORMEF, NRMTYP, MCNAME C CALL PARCHK(OPT,NORMEF,NRMTYP,TOL,IDLIST,NTOL,NGRP,GRPLST,LGTOL, * FLAG) IF (FLAG.EQ.0.) GO TO 40 WRITE (IOUT,FMT=99998) FLAG RETURN C C--------+---------+---------+---------+---------+---------+---------+-- C INITIALIZE OVERALL- AND GROUPS-SUMMARY STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- 40 OSTIME = 0. OSOVHD = 0. OSNFCN = 0 OSNJAC = 0 OSNLUD = 0 OSNSTP = 0 OSNTRU = 0 OSLEMX = 0. OSNDCV = 0 OSNBAD = 0 DO 60 I = 1, NTOL GSTIME(I) = 0. GSOVHD(I) = 0. GSNFCN(I) = 0 GSNJAC(I) = 0 GSNLUD(I) = 0 GSNSTP(I) = 0 GSNTRU(I) = 0 GSLEMX(I) = 0. GSNDCV(I) = 0 GSNBAD(I) = 0 60 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C LOOP OVER GROUPS OF PROBLEMS C--------+---------+---------+---------+---------+---------+---------+-- C DO 300 KGRP = 1, NGRP C C--------+---------+---------+---------+---------+---------+---------+-- C OUTPUT HEADING, ON NEW PAGE FOR GROUPS AFTER FIRST. C SELECT GROUP OF DIFFERENTIAL EQUATIONS. C GET NO. OF SYSTEMS IN THIS GROUP, & OFFSET FOR C POSITION OF ITEM IN GROUP WITHIN IDLIST. C INITIALIZE PROBLEM SUMMARY STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- IF (KGRP.GT.1) WRITE (IOUT,FMT=99997) WRITE (IOUT,FMT=99996) KGRP, TITLE C NSYST = GRPLST(1,KGRP) IDSUB = GRPLST(2,KGRP) C DO 80 I = 1, NTOL PSTIME(I) = 0. PSOVHD(I) = 0. PSNFCN(I) = 0 PSNJAC(I) = 0 PSNLUD(I) = 0 PSNSTP(I) = 0 PSNTRU(I) = 0 PSLEMX(I) = 0. PSNDCV(I) = 0 PSNBAD(I) = 0 PSGEMX(I) = 0. PSGEND(I) = 0. 80 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C LOOP OVER PROBLEMS WITHIN A GROUP C--------+---------+---------+---------+---------+---------+---------+-- DO 260 KSYST = 1, NSYST C--------+---------+---------+---------+---------+---------+---------+-- C GET NEXT PROBLEM-ID: C EXTRACT THE WEIGHTING OPTION (IWT=1 OR -1). C UNPACK ID INTO CLASSNAME + INDEX WITHIN CLASS AND TRANSLATE C INTO STDTST INTERNAL ID BY SUBTRACTING 10: C--------+---------+---------+---------+---------+---------+---------+-- IDSUB = IDSUB + 1 ID = IDLIST(IDSUB) IWT = ISIGN(1,ID) ID = IABS(ID) KCLASS = (ID-1)/10 IID = ID - 10*KCLASS ID = ID - 10 IF (IWT.GT.0) WRITE (IOUT,FMT=99995) IDCLAS(KCLASS:KCLASS), * IID IF (IWT.LE.0) WRITE (IOUT,FMT=99994) IDCLAS(KCLASS:KCLASS), * IID WRITE (IOUT,FMT=99993) (BL,I=1,OPT) WRITE (IOUT,FMT=99992) (BL,I=1,OPT) C C--------+---------+---------+---------+---------+---------+---------+-- C LOOP OVER TOLERANCES FOR ONE PROBLEM C--------+---------+---------+---------+---------+---------+---------+-- DO 220 KTOL = 1, NTOL C--------+---------+---------+---------+---------+---------+---------+-- C CALL PLOT TO INITIALIZE LOCAL-ERROR SCATTER DIAGRAM C IF OPT=4. C CALL CNTROL TO ORGANIZE THE COLLECTION OF C STATISTICS. C ON EXIT FROM CNTROL THE VALUE OF CMPLET WILL C INDICATE WHETHER A FAILURE OCCURRED. C C CMPLET = 1 NO FAILURES. C CMPLET = 0 DETEST FAILED TO OBTAIN TRUE C LOCAL OR GLOBAL SOLUTION. C CMPLET = -1 METHOD FAILED TO REACH THE END C OF RANGE. C CMPLET = -2 DETEST FAILED AND SUBSEQUENTLY C METHOD FAILED. C CMPLET = -3 METHOD COULD NOT START THE C INTEGRATION. C CMPLET = -4 METHOD COMPLETED THE STATISTICS C GATHERING BUT FAILED IN TIMING LOOP. C C ON EXIT INDG1,INDL1 HOLD EXIT-FLAGS OF 'TRUE' C GLOBAL AND LOCAL SOLUTIONS RESPECTIVELY. C C ERFLGE(KTOL) IS TRUE IF METHOD FAILED TO REACH XEND. C ERFLG1(KTOL) IS TRUE IF EITHER METHOD OR C TRUE-SOLUTION FAILED TO REACH XEND (THUS INVALIDATING C GEMX AS DATA FOR SMOOTHNESS CALC WHEN NORMEF=2 ). C C IF CMPLET IS -4,-2,-1,0 OR 1 PRINT A LINE OF STATISTICS: C IF CMPLET ISNT 1, PRINT AN ERROR MESSAGE. C CALL PLOT TO PRINT LOCAL-ERROR SCATTER DIAGRAM C IF OPT=4 C NOTE IF METHOD FAILED TO REACH XEND, ANY STATISTICS FOR C THIS PROBLEM ARE PRINTED BUT DO NOT CONTRIBUTE TO THE C SUMMARY STATISTICS. CONVERSELY IF METHOD REACHED XEND, C ALL STATISTICS CONTRIBUTE TO THE SUMMARIES THOUGH GEMX, C LEMXSC,NDCV,NBAD,NTRU ONLY APPLY TO PART OF THE RANGE C IF 'TRUE' FAILED. C--------+---------+---------+---------+---------+---------+---------+-- C TOLK = TOL(KTOL) ERRTOL = REAL(TOLK) IF (OPT.EQ.4) CALL PLOT(0.,0.,0) C CALL CNTROL(CMPLET,INDG1,INDL1) C ERFLGE(KTOL) = CMPLET .LT. 0 .AND. CMPLET .GT. -4 ERFLG1(KTOL) = CMPLET .LT. 1 .AND. CMPLET .GT. -4 GENDSC = BIG IF (ERFLGE(KTOL)) GO TO 100 GENDSC = GEND/TOLK LGGEND(KTOL) = ALOG10(AMAX1(GEND,.01*TOLK)) 100 CONTINUE GEMXSC = GEMX/TOLK FDECEV = RATIO(NDCV,NTRU) FBADEC = RATIO(NBAD,NTRU) C IF (CMPLET.EQ.-3) GO TO 120 IF (OPT.EQ.1) WRITE (IOUT,FMT=99991) LGTOL(KTOL), TIME, * OVHD, NFCN, NJAC, NLUD, NSTP, GENDSC IF (OPT.EQ.2) WRITE (IOUT,FMT=99991) LGTOL(KTOL), TIME, * OVHD, NFCN, NJAC, NLUD, NSTP, GENDSC, GEMXSC IF (OPT.GE.3) WRITE (IOUT,FMT=99991) LGTOL(KTOL), TIME, * OVHD, NFCN, NJAC, NLUD, NSTP, GENDSC, GEMXSC, LEMXSC, * FDECEV, FBADEC IF (OPT.GE.3 .AND. NSTP.NE.NTRU) WRITE (IOUT,FMT=99990) * NTRU 120 CONTINUE C C IF (CMPLET.EQ.-4) WRITE (IOUT,FMT=99989) IF (CMPLET.EQ.-3) WRITE (IOUT,FMT=99988) LGTOL(KTOL) C IF (CMPLET.EQ.-2) WRITE (IOUT,FMT=99987) XTRUE, INDG1, * INDL1, XFIN C IF (CMPLET.EQ.-1) WRITE (IOUT,FMT=99986) XFIN C IF (CMPLET.EQ.0) WRITE (IOUT,FMT=99985) XTRUE, INDG1, * INDL1 C IF (OPT.EQ.4) THEN C WRITE (IOUT,FMT=99984) XTRAP C CALL PLOT(0.,0.,2) END IF C FOR EVALUATING PERFORMANCE OF 'TRUE': C CALL TRUCHK(4,IDUM) C C--------+---------+---------+---------+---------+---------+---------+-- C UPDATE PROBLEMS-SUMMARY STATS IF METHOD REACHED XEND. C (IF IT DIDN'T, DON'T UPDATE THE LOCAL-ASSESSMENT INFO: C NTRU,LEMXSC,NDCV,NBAD. THIS IS AN ARBITRARY CHOICE, IT C MAKES IT SIMPLER TO EXPLAIN TO THE USER. C STORE NORMEF STATISTICS: C--------+---------+---------+---------+---------+---------+---------+-- C IF (ERFLGE(KTOL)) GO TO 180 PSTIME(KTOL) = PSTIME(KTOL) + TIME PSOVHD(KTOL) = PSOVHD(KTOL) + OVHD PSNFCN(KTOL) = PSNFCN(KTOL) + NFCN PSNSTP(KTOL) = PSNSTP(KTOL) + NSTP PSNJAC(KTOL) = PSNJAC(KTOL) + NJAC PSNLUD(KTOL) = PSNLUD(KTOL) + NLUD PSGEND(KTOL) = AMAX1(PSGEND(KTOL),GENDSC) C IF (OPT.LT.2) GO TO 140 PSGEMX(KTOL) = AMAX1(PSGEMX(KTOL),GEMXSC) LGGEMX(KTOL) = ALOG10(AMAX1(GEMX,.01*TOLK)) C 140 IF (OPT.LT.3) GO TO 160 PSNTRU(KTOL) = PSNTRU(KTOL) + NTRU PSLEMX(KTOL) = AMAX1(PSLEMX(KTOL),LEMXSC) PSNDCV(KTOL) = PSNDCV(KTOL) + NDCV PSNBAD(KTOL) = PSNBAD(KTOL) + NBAD 160 CONTINUE 180 CONTINUE C IF (NORMEF.EQ.0) GO TO 200 NSTIME(KTOL) = TIME NSOVHD(KTOL) = OVHD NSNFCN(KTOL) = NFCN NSNSTP(KTOL) = NSTP NSNJAC(KTOL) = NJAC NSNLUD(KTOL) = NLUD 200 CONTINUE C--------+---------+---------+---------+---------+---------+---------+-- C END OF LOOP OVER TOLERANCES FOR ONE PROBLEM C--------+---------+---------+---------+---------+---------+---------+-- 220 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C SMOOTHNESS AND NORMALIZED EFFICIENCY CALCULATIONS BEGIN C--------+---------+---------+---------+---------+---------+---------+-- WRITE (IOUT,FMT=99983) C WRITE (IOUT,FMT=99982) C CALL LSQFIT(LGTOL,LGGEND,ERFLGE,NTOL,NOK,C,E,RES) C CTEN = 10.**C IF (NOK.LE.2) WRITE (IOUT,FMT=99981) NOK C IF (NOK.GT.2) WRITE (IOUT,FMT=99980) CTEN, E, RES, NOK C IF (OPT.LT.2) GO TO 240 WRITE (IOUT,FMT=99979) C CALL LSQFIT(LGTOL,LGGEMX,ERFLG1,NTOL,NOK1,C1,E1,RES1) C CTEN1 = 10.**C1 IF (NOK1.LE.2) WRITE (IOUT,FMT=99981) NOK1 IF (NOK1.GT.2) WRITE (IOUT,FMT=99980) CTEN1, E1, RES1, NOK1 240 CONTINUE C IF (NORMEF.EQ.1) CALL EFSTAT(C,E,LGTOL,NTOL,NOK,ERFLGE, * 'ENDPOINT',IOUT,NSTIME,NSOVHD, * NSNFCN,NSNJAC,NSNLUD,NSNSTP) C IF (NORMEF.EQ.2) CALL EFSTAT(C1,E1,LGTOL,NTOL,NOK1,ERFLG1, * 'MAXIMUM ',IOUT,NSTIME,NSOVHD, * NSNFCN,NSNJAC,NSNLUD,NSNSTP) C C--------+---------+---------+---------+---------+---------+---------+-- C SMOOTHNESS AND NORMALIZED EFFICIENCY CALCULATIONS END C--------+---------+---------+---------+---------+---------+---------+-- C C--------+---------+---------+---------+---------+---------+---------+-- C END OF LOOP OVER PROBLEMS IN A GROUP. C--------+---------+---------+---------+---------+---------+---------+-- 260 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C OUTPUT PROBLEMS-SUMMARY STATISTICS C--------+---------+---------+---------+---------+---------+---------+-- C WRITE (IOUT,FMT=99978) KGRP WRITE (IOUT,FMT=99993) (BL,I=1,OPT) WRITE (IOUT,FMT=99992) (BL,I=1,OPT) DO 280 KTOL = 1, NTOL FDECEV = RATIO(PSNDCV(KTOL),PSNTRU(KTOL)) FBADEC = RATIO(PSNBAD(KTOL),PSNTRU(KTOL)) C IF (OPT.EQ.1) WRITE (IOUT,FMT=99991) LGTOL(KTOL), * PSTIME(KTOL), PSOVHD(KTOL), PSNFCN(KTOL), PSNJAC(KTOL), * PSNLUD(KTOL), PSNSTP(KTOL), PSGEND(KTOL) C IF (OPT.EQ.2) WRITE (IOUT,FMT=99991) LGTOL(KTOL), * PSTIME(KTOL), PSOVHD(KTOL), PSNFCN(KTOL), PSNJAC(KTOL), * PSNLUD(KTOL), PSNSTP(KTOL), PSGEND(KTOL), PSGEMX(KTOL) C IF (OPT.GE.3) WRITE (IOUT,FMT=99991) LGTOL(KTOL), * PSTIME(KTOL), PSOVHD(KTOL), PSNFCN(KTOL), PSNJAC(KTOL), * PSNLUD(KTOL), PSNSTP(KTOL), PSGEND(KTOL), PSGEMX(KTOL), * PSLEMX(KTOL), FDECEV, FBADEC C IF (OPT.GE.3 .AND. PSNSTP(KTOL).NE.PSNTRU(KTOL)) * WRITE (IOUT,FMT=99990) PSNTRU(KTOL) C C--------+---------+---------+---------+---------+---------+---------+-- C UPDATE GROUPS-SUMMARY STATISTICS C--------+---------+---------+---------+---------+---------+---------+-- GSTIME(KTOL) = GSTIME(KTOL) + PSTIME(KTOL) GSOVHD(KTOL) = GSOVHD(KTOL) + PSOVHD(KTOL) GSNFCN(KTOL) = GSNFCN(KTOL) + PSNFCN(KTOL) GSNJAC(KTOL) = GSNJAC(KTOL) + PSNJAC(KTOL) GSNLUD(KTOL) = GSNLUD(KTOL) + PSNLUD(KTOL) GSNSTP(KTOL) = GSNSTP(KTOL) + PSNSTP(KTOL) C IF (OPT.LT.3) GO TO 280 GSNTRU(KTOL) = GSNTRU(KTOL) + PSNTRU(KTOL) GSLEMX(KTOL) = AMAX1(GSLEMX(KTOL),PSLEMX(KTOL)) GSNDCV(KTOL) = GSNDCV(KTOL) + PSNDCV(KTOL) GSNBAD(KTOL) = GSNBAD(KTOL) + PSNBAD(KTOL) 280 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C END OF LOOP OVER GROUPS C--------+---------+---------+---------+---------+---------+---------+-- 300 CONTINUE C C C--------+---------+---------+---------+---------+---------+---------+-- C OUTPUT HEADINGS FOR GROUPS- AND OVERALL-SUMMARY STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- WRITE (IOUT,FMT=99977) TITLE, (BL,I=1,OPT) WRITE (IOUT,FMT=99976) (BL,I=1,OPT) C--------+---------+---------+---------+---------+---------+---------+-- C OUTPUT GROUPS-SUMMARY STATISTICS C--------+---------+---------+---------+---------+---------+---------+-- IF (OPT.GE.3) GO TO 340 DO 320 I = 1, NTOL WRITE (IOUT,FMT=99975) LGTOL(I), GSTIME(I), GSOVHD(I), * GSNFCN(I), GSNJAC(I), GSNLUD(I), GSNSTP(I) 320 CONTINUE GO TO 380 340 DO 360 I = 1, NTOL FDECEV = RATIO(GSNDCV(I),GSNTRU(I)) FBADEC = RATIO(GSNBAD(I),GSNTRU(I)) WRITE (IOUT,FMT=99975) LGTOL(I), GSTIME(I), GSOVHD(I), * GSNFCN(I), GSNJAC(I), GSNLUD(I), GSNSTP(I), GSLEMX(I), * FDECEV, FBADEC C IF (GSNSTP(I).NE.GSNTRU(I)) WRITE (IOUT,FMT=99990) GSNTRU(I) 360 CONTINUE 380 CONTINUE C C--------+---------+---------+---------+---------+---------+---------+-- C COMPUTE OVERALL-SUMMARY STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- DO 400 I = 1, NTOL OSTIME = OSTIME + GSTIME(I) OSOVHD = OSOVHD + GSOVHD(I) OSNFCN = OSNFCN + GSNFCN(I) OSNJAC = OSNJAC + GSNJAC(I) OSNLUD = OSNLUD + GSNLUD(I) OSNSTP = OSNSTP + GSNSTP(I) C IF (OPT.LT.3) GO TO 400 OSNTRU = OSNTRU + GSNTRU(I) OSNDCV = OSNDCV + GSNDCV(I) OSNBAD = OSNBAD + GSNBAD(I) OSLEMX = AMAX1(OSLEMX,GSLEMX(I)) 400 CONTINUE FDECEV = RATIO(OSNDCV,OSNTRU) FBADEC = RATIO(OSNBAD,OSNTRU) C--------+---------+---------+---------+---------+---------+---------+-- C OUTPUT OVERALL-SUMMARY STATISTICS C--------+---------+---------+---------+---------+---------+---------+-- IF (OPT.LT.3) WRITE (IOUT,FMT=99974) OSTIME, OSOVHD, OSNFCN, * OSNJAC, OSNLUD, OSNSTP C IF (OPT.GE.3) WRITE (IOUT,FMT=99974) OSTIME, OSOVHD, OSNFCN, * OSNJAC, OSNLUD, OSNSTP, OSLEMX, FDECEV, FBADEC C C RETURN C 99999 FORMAT ('0STIFF DETEST PACKAGE OPT=',I2,', NORMEF=',I2, * ', NRMTYP=',I2,19X,'ON ',A,//) 99998 FORMAT ('0PARAMETER ERRORS AS SHOWN BY FLAG=',E15.8,/' ',49('*') * ,//) 99997 FORMAT ('1') 99996 FORMAT ('0GROUP',I3,18X,A) 99995 FORMAT (/'0',A3,I1,' (SCALED)',/) 99994 FORMAT (/'0',A3,I1,' (UNSCALED)',/) 99993 FORMAT (' ',A1,6X,'LOG10',5X,'TIME',3X,'OVHD',5X,'FCN',5X,'JAC', * 5X,'MAT',4X,'NO OF',3X,'END PNT',A1,2X,'MAXIMUM',A1,2X, * 'MAXIMUM',3X,'FRACTION',3X,'FRACTION',A1) 99992 FORMAT (' ',A1,7X,'TOL',21X,'CALLS',3X,'CALLS',4X,'FACT',3X, * 'STEPS',3X,'GLB ERR',A1,2X,'GLB ERR',A1,2X,'LOC ERR',3X, * 'DECEIVED',3X,'BAD DECV',A1) 99991 FORMAT ('0',6X,F6.2,2X,2F7.3,1X,4I8,2X,F8.2,1X,F9.2,1X,F9.3,1X, * F9.3,1X,F10.3,1X,F10.3) 99990 FORMAT (114X,'(LOC ASSESS ON',I4,')') 99989 FORMAT ('0',20X, * '***** UNEXPECTED FAILURE OF METHOD WHILE BEING TIMED *****' * ,/) 99988 FORMAT ('0',6X,F6.2,' *** METHOD FAILED TO START ***') 99987 FORMAT (15X,'TRUE-SOLUTION OF TEST PACKAGE FAILED AT X = ',1P, * E12.5,', ERROR FLAG (GLOBAL) ',I3,', (LOCAL) ',I3,/21X, * 'AND SUBSEQUENTLY METHOD FAILED AT X = ',1P,E12.5) 99986 FORMAT (21X,'METHOD FAILED AT X = ',1P,E12.5) 99985 FORMAT (21X,'TRUE-SOLUTION OF TEST PACKAGE FAILED AT X = ',1P, * E12.5,', ERROR FLAG (GLOBAL) ',I3,', (LOCAL) ',I3) 99984 FORMAT (/6X,'ERROR ESTIMATE ANALYSIS',10X, * 'EXTRAPOLATION (0=NO 1=YES):',I2,/11X, * 'HORIZONTAL AXIS: R1=||ERREST|| / ERRBND',/11X, * 'VERTICAL AXIS: R2 = ||ERROR IN ERREST|| / ERRBND',/11X, *'PLOT SHOWS % STEPS WHERE (R1,R2) LAY IN INDICATED PIGEONHOLE, A', *1X,'DOT MEANS UNDER 1%',/) 99983 FORMAT (/'0',17X,'SMOOTHNESS FIT OF LOG10(ERROR) VS LOG10(TOL)') 99982 FORMAT ('0',17X,'ENDPOINT GLOBAL ERROR') 99981 FORMAT (39X,I2,' VALUES, TOO FEW TO GET STATISTICS') 99980 FORMAT (39X,'=',1P,G10.3,' *(TOL**',0P,F6.3,') APPROX,',6X, * 'R.M.S. RESIDUAL=',1P,E8.1,' OVER',I3,' VALUES') 99979 FORMAT ('0',17X,'MAXIMUM GLOBAL ERROR') 99978 FORMAT (/'0SUMMARY OVER GROUP',I3) 99977 FORMAT ('1SUMMARY OVER ALL GROUPS',6X,A,//' ',A1,6X,'LOG10',5X, * 'TIME',3X,'OVHD',5X,'FCN',5X,'JAC',5X,'MAT',4X,'NO OF',2A1, * 2X,'MAXIMUM',3X,'FRACTION',3X,'FRACTION',A1) 99976 FORMAT (' ',A1,7X,'TOL',21X,'CALLS',3X,'CALLS',4X,'FACT',3X, * 'STEPS',2A1,2X,'LOC ERR',3X,'DECEIVED',3X,'BAD DECV',A1) 99975 FORMAT ('0',6X,F6.2,2X,2F7.3,1X,4I8,1X,3F11.3) 99974 FORMAT ('0',5X,'OVERALL',/6X,'SUMMARY',2X,2F7.3,1X,4I8,1X,3F11.3) END C C C********+*********+*********+*********+*********+*********+*********+** C SUBROUTINE PARCHK(OPT,NORMEF,NRMTYP,TOL,IDLIST,NTOL,NGRP,GRPLST, * LGTOL,FLAG) C C********+*********+*********+*********+*********+*********+*********+** C ROUTINE TO DO PARAMETER CHECKS FOR REVISED STDTST INTERFACE. C C INPUT: OPT,NORMEF,NRMTYP,TOL,IDLIST C VALID INPUT IS: C OPTION = 1 2 3 OR 4 C NORMEF = 0 1 OR 2 C NRMTYP = 1 2 OR 3 C TOL = LIST OF UP TO 10 POSITIVE REAL'S FOLLOWED BY A 0., C IN STRICTLY DECREASING ORDER C IDLIST = LIST OF GROUPS OF PROBLEM-IDS SEPARATED BY ZEROS C WITH 2 ZEROS AFTER LAST GROUP, AT MOST 60 ITEMS TOTAL. C EACH ID MAY HAVE A MINUS SIGN TO SELECT THE 'UNSCALED' C ERROR CONTROL OPTION. C VALID PROBLEM-IDS ARE IN RANGES C 11-14 21-25 31-35 41-46 51-55 61-65 C FOR PROBLEM CLASSES A1-A4 B1-B5 ETC. C OUTPUT: NTOL = NO. OF TOLERANCES IN TOL LIST C NGRP = NO. OF GROUPS IN IDLIST LIST C GRPLST(1,I) = SIZE OF I-TH GROUP OF PROBLEMS CC ... (2,I) = POINTER TO (START OF I-TH GROUP)-1 IN IDLIST C LGTOL(I) = LOG10(TOL(I)) C FLAG IS ERROR FLAG, 0.0 IF ALL OK, ELSE ITS DECIMAL DIGITS C INDICATE WHICH PARAMETER ERRORS WERE FOUND: C 1: OPT INVALID C 2: NORMEF INVALID C 3: NORMEF = 2 REQUESTED WITH OPT = 1 C 4: TOL(I) < 0, OR LIST NOT IN DECREASING ORDER C 5: TOL LIST EMPTY OR NOT TERMINATED BY ZERO C 6: INVALID PROBLEM-ID FOUND C 7: LIST OF GROUPS IN IDLIST EMPTY,NOT TERMINATED BY C 2 ZEROS OR HAS MORE THAN MAXGRP GROUPS C 8: NRMTYP INVALID C--------+---------+---------+---------+---------+---------+---------+-- C C .. Scalar Arguments .. REAL FLAG INTEGER NGRP, NORMEF, NRMTYP, NTOL, OPT C .. Array Arguments .. REAL LGTOL(10), TOL(11) INTEGER GRPLST(2,6), IDLIST(60) C .. Local Scalars .. REAL BIG, TOLPRV INTEGER ENDLST, I, ID, IID, ISAV, KCLASS, LENIDS, * LENTOL, MAXGRP, NCLASS C .. Local Arrays .. INTEGER NSYSTM(6) C .. Intrinsic Functions .. INTRINSIC ALOG10, IABS C .. Data statements .. DATA ENDLST/-1/, BIG/1E20/ DATA NCLASS/6/, NSYSTM/4, 5, 5, 6, 5, 5/, MAXGRP/6/, * LENTOL/11/, LENIDS/60/ C .. Executable Statements .. C FLAG = 0. IF (OPT.LT.1 .OR. OPT.GT.4) FLAG = 1. IF (NORMEF.LT.0 .OR. NORMEF.GT.2) FLAG = 10.*FLAG + 2. IF (OPT.EQ.1 .AND. NORMEF.EQ.2) FLAG = 10.*FLAG + 3. IF (NRMTYP.LT.1 .OR. NRMTYP.GT.3) FLAG = 10.*FLAG + 8. C C TOLERANCES: NTOL = 0 TOLPRV = BIG DO 20 I = 1, LENTOL IF (TOL(I).LT.0. .OR. TOL(I).GE.TOLPRV) FLAG = 10.*FLAG + 4. IF (TOL(I).EQ.0.) GO TO 40 NTOL = NTOL + 1 TOLPRV = TOL(I) 20 CONTINUE C C NO TERMINATING 0 IN TOLERANCE LIST: FLAG = 10.*FLAG + 5. C C CHECK FOR EMPTY TOLERANCE LIST: 40 IF (NTOL.EQ.0) FLAG = 10.*FLAG + 5. C C LIST OF GROUPS OF PROBLEMS: NGRP = 0 I = 0 C C WHILE NEXT ID IN LIST ISNT 0 OR END OF LIST: 60 I = I + 1 ID = ENDLST IF (I.LE.LENIDS) ID = IDLIST(I) C IF (ID.EQ.0) GO TO 160 IF (NGRP.GE.MAXGRP) GO TO 180 ISAV = I - 1 C C WHILE ID ISNT 0, GET ONE GROUP: 80 IF (ID.EQ.0) GO TO 140 IF (ID.EQ.ENDLST) GO TO 180 C TRANSLATE ID INTO CLASS & NUMBER WITHIN CLASS, C IGNORING SIGN (WHICH SELECTS SCALED/UNSCALED OPTION): ID = IABS(ID) KCLASS = (ID-1)/10 IID = ID - 10*KCLASS IF ( .NOT. (KCLASS.GE.1 .AND. KCLASS.LE.NCLASS)) GO TO 100 IF (IID.LE.NSYSTM(KCLASS)) GO TO 120 100 FLAG = 10.*FLAG + 6. 120 CONTINUE C GET NEXT ID AS ABOVE: I = I + 1 ID = ENDLST IF (I.LE.LENIDS) ID = IDLIST(I) GO TO 80 C C NEW GROUP FORMED: 140 NGRP = NGRP + 1 GRPLST(1,NGRP) = I - ISAV - 1 GRPLST(2,NGRP) = ISAV GO TO 60 C C CHECK IF NO GROUPS WERE SPECIFIED: 160 IF (NGRP.LE.0) GO TO 180 GO TO 200 C 180 FLAG = 10.*FLAG + 7. C C IF ALL OK, COMPUTE LOGS OF TOLERANCES: C 200 IF (FLAG.NE.0.) GO TO 240 DO 220 I = 1, NTOL LGTOL(I) = ALOG10(TOL(I)) 220 CONTINUE 240 RETURN END C C********+*********+*********+*********+*********+*********+*********+** C SUBROUTINE LSQFIT(X,Y,MISS,N,NN,C0,C1,RES) C .. Scalar Arguments .. REAL C0, C1, RES INTEGER N, NN C .. Array Arguments .. REAL X(N), Y(N) LOGICAL MISS(N) C .. Local Scalars .. REAL SX, SXX, SXY, SY, XNN INTEGER I C .. Intrinsic Functions .. INTRINSIC SQRT C .. Executable Statements .. C C********+*********+*********+*********+*********+*********+*********+** C FITS MODEL Y = C0 + C1*X TO DATA X(I),Y(I),I = 1..N WHERE DATA C FOR WHICH MISS(I) IS .TRUE. IS REGARDED AS MISSING. C C ON EXIT C X,Y,MISS,N ARE UNCHANGED. C NN = NO. OF NONMISSING VALUES C C0,C1 = FITTED COEFFICIENTS C RES = ROOT MEAN SQUARE RESIDUAL C C EXCEPT THAT IF NN.LE.1 NO COMPUTATION OF THE COEFFICIENTS IS DONE. C--------+---------+---------+---------+---------+---------+---------+-- C NN = 0 SX = 0. SY = 0. DO 20 I = 1, N IF (MISS(I)) GO TO 20 NN = NN + 1 SX = SX + X(I) SY = SY + Y(I) 20 CONTINUE IF (NN.LE.1) GO TO 80 XNN = NN SX = SX/XNN SY = SY/XNN SXX = 0. SXY = 0. DO 40 I = 1, N IF (MISS(I)) GO TO 40 SXX = SXX + (X(I)-SX)**2 SXY = SXY + (X(I)-SX)*(Y(I)-SY) 40 CONTINUE C1 = SXY/SXX C0 = SY - C1*SX RES = 0. DO 60 I = 1, N IF ( .NOT. MISS(I)) RES = RES + (Y(I)-SY-C1*(X(I)-SX))**2 60 CONTINUE C RES = SQRT(RES/XNN) C 80 RETURN END C C********+*********+*********+*********+*********+*********+*********+** C REAL FUNCTION RATIO(M,N) C C********+*********+*********+*********+*********+*********+*********+** C .. Scalar Arguments .. INTEGER M, N C .. Intrinsic Functions .. INTRINSIC FLOAT C .. Executable Statements .. RATIO = 1E20 IF (N.NE.0) RATIO = FLOAT(M)/FLOAT(N) RETURN END C C********+*********+*********+*********+*********+*********+*********+** C SUBROUTINE EFSTAT(C,E,LGTOL,NTOL,NOK,ERFLG,TITLE,IOUT,W1,W2,W3,W4, * W5,W6) C C********+*********+*********+*********+*********+*********+*********+** C ROUTINE TO COMPUTE AND PRINT NORMALIZED EFFICIENCY STATISTICS. C C PARAMETERS (ALL INPUT): C C,E - COEFFICIENTS IN LEAST-SQUARES FIT OF ACHIEVED ACCURACY C (EITHER AT ENDPOINT OR MAX-OVER-RANGE) TO TOLERANCE. C LGTOL - LIST OF LOGS TO BASE 10 OF TOLERANCES C NTOL - NO. OF TOLERANCES. C NOK - NO. OF .FALSE. ENTRIES IN ERFLG (FROM LSQFIT CALL) C ERFLG - LOGICAL VECTOR INDICATING FOR WHICH TOLERANCES DATA C IS TO BE REGARDED AS MISSING. C TITLE C - IDENTIFYING CHARACTER STRING. C IOUT - OUTPUT UNIT NUMBER. C W1,...,W6 C - VECTORS OF STATISTICS, INDEXED OVER TOLERANCES, FOR C WHICH NORMALIZED STATISTICS ARE TO BE PRODUCED. C (NOTE SOME ARE REAL, SOME INTEGER: REFER TO ACTUAL CALL C IN STDTST.) C IT IS ASSUMED THAT NTOL.LE.10, OTHERWISE ARRAY S MUST BE LONGER. C--------+---------+---------+---------+---------+---------+---------+-- C C LOCAL VARIABLES C .. Scalar Arguments .. REAL C, E INTEGER IOUT, NOK, NTOL CHARACTER*8 TITLE C .. Array Arguments .. REAL LGTOL(NTOL), W1(NTOL), W2(NTOL) INTEGER W3(NTOL), W4(NTOL), W5(NTOL), W6(NTOL) LOGICAL ERFLG(NTOL) C .. Local Scalars .. REAL EQVTOL, S0, THETA, W1INT, W2INT, X INTEGER I, MSINT, NHI, NLO, SHI, SINT, SLO, W3INT, * W4INT, W5INT, W6INT C .. Local Arrays .. REAL S(10) C .. Intrinsic Functions .. INTRINSIC FLOAT, INT C .. Statement Functions .. INTEGER FLOOR C .. Statement Function definitions .. C C STATEMENT FUNCTION C FLOOR FUNCTION VALID IF ARGUMENT X.GE.-100 WHICH IS OK HERE. FLOOR(X) = INT(X+100.) - 100 C .. Executable Statements .. C IF (NOK.LE.2) GO TO 200 C C TRANSFORM THE LOG10(TOL)'S TO NORMALIZED-EFFICIENCY VARIABLE: DO 20 I = 1, NTOL S(I) = -(C+E*LGTOL(I)) 20 CONTINUE C C FIND SET OF CONSECUTIVE TOL'S FOR WHICH INTEGRATION SUCCEEDED: DO 40 NLO = 1, NTOL IF ( .NOT. ERFLG(NLO)) GO TO 60 40 CONTINUE C ELSE ALL INTEGRATIONS FOR THIS PROBLEM FAILED: GO TO 200 60 CONTINUE NHI = NLO - 1 DO 80 I = NLO, NTOL IF (ERFLG(I)) GO TO 100 NHI = I 80 CONTINUE 100 CONTINUE C IF (NHI.LE.NLO) GO TO 200 IF (E.LE.0.) GO TO 220 C C FORM RANGE OF INTEGER POWERS OF 10 FOR WHICH NORMALIZED STATISTICS C ARE TO BE PRINTED: SLO = -FLOOR(-S(NLO)+0.1) SHI = FLOOR(S(NHI)+0.1) IF (SHI.LT.SLO) GO TO 240 C WRITE (IOUT,FMT=99999) TITLE C C START OF LOOP TO PRINT A LINE OF STATISTICS FOR EACH POWER OF 10: I = NLO + 1 CC ... WHICH IS KNOWN TO BE .LE. NHI C DO 160 SINT = SLO, SHI S0 = FLOAT(SINT) C C MOVE INTERVAL S(I-1)..S(I) TO RIGHT WHILE S(I).LT.SINT: 120 IF (S(I).GE.S0 .OR. I.GE.NHI) GO TO 140 I = I + 1 GO TO 120 140 CONTINUE C NECESSARILY NOW NLO + 1 .LE. I .LE. NHI C C NOW DO INTERPOLATION (POSSIBLY EXTRAPOLATION A SHORT DISTANCE) C USING DATA FOR I AND I + 1: THETA = (S0-S(I-1))/(S(I)-S(I-1)) W1INT = W1(I-1) + THETA*(W1(I)-W1(I-1)) W2INT = W2(I-1) + THETA*(W2(I)-W2(I-1)) W3INT = W3(I-1) + THETA*(W3(I)-W3(I-1)) W4INT = W4(I-1) + THETA*(W4(I)-W4(I-1)) W5INT = W5(I-1) + THETA*(W5(I)-W5(I-1)) W6INT = W6(I-1) + THETA*(W6(I)-W6(I-1)) C MSINT = -SINT EQVTOL = -(C+S0)/E WRITE (IOUT,FMT=99998) MSINT, EQVTOL, W1INT, W2INT, W3INT, * W4INT, W5INT, W6INT C 160 CONTINUE C 180 RETURN C 200 WRITE (IOUT,FMT=99997) GO TO 180 C 220 WRITE (IOUT,FMT=99996) GO TO 180 C 240 WRITE (IOUT,FMT=99995) GO TO 180 C 99999 FORMAT (/'0',6X,'NORMALIZED EFFICIENCY - ',A8,' GLOBAL ERROR', * //7X,'EXPECTED',3X,'EQUIV',4X,'TIME',3X,'OVHD',5X,'FCN',5X, * 'JAC',5X,'MAT',4X,'NO OF',/7X,'ACCURACY',1X,'LOG10 TOL', * 17X,'CALLS',3X,'CALLS',4X,'FACT',3X,'STEPS') 99998 FORMAT ('0',6X,'10**',I3,F8.2,F9.3,F7.3,1X,4I8) 99997 FORMAT ('0',10X,'NOT ENOUGH SUCCESSFUL INTEGRATIONS TO FORM',1X, * 'NORMALIZED STATISTICS') 99996 FORMAT ('0',10X,'DEPENDENCE OF ACCURACY ON TOLERANCE IS TOO',1X, * 'UNRELIABLE TO FORM NORMALIZED STATISTICS') 99995 FORMAT ('0',10X,'NO POWERS OF TEN WITHIN RANGE OF TOLERANCES',1X, * 'USED: NO NORMALIZED STATISTICS') END C C C********+*********+*********+*********+*********+*********+*********+** C SUBROUTINE CNTROL(CMPLET,INDG1,INDL1) C C********+*********+*********+*********+*********+*********+*********+** C CNTROL ORGANIZES THE CALLS TO METHOD NEEDED TO GATHER C STATISTICS FOR ONE PROBLEM AND ONE TOLERANCE AT THE LEVEL OF C DETAIL SPECIFIED BY OPT, WITH SCALING TURNED ON OR OFF BY IWT. C C ON EXIT FROM CNTROL C CMPLET INDICATES WHETHER A FAILURE OCCURRED: C CMPLET = 1 NO FAILURES. C CMPLET = 0 DETEST FAILED TO OBTAIN TRUE LOCAL OR GLOBAL C SOLUTION. C CMPLET = -1 METHOD FAILED TO REACH THE END OF RANGE. C CMPLET = -2 DETEST FAILED AND SUBSEQUENTLY METHOD FAILED C CMPLET = -3 METHOD COULD NOT START THE INTEGRATION. C CMPLET = -4 METHOD COMPLETED THE STATISTICS GATHERING CALL C BUT (UNEXPECTEDLY) FAILED IN THE TIMING LOOP. C C INDG1, INDL1 RETURN THE ERROR FLAGS OF THE 'TRUE' GLOBAL C AND LOCAL SOLUTIONS RESPECTIVELY. C C THE MAIN OUTPUT FROM CNTROL CONSISTS OF THE STATISTICS HELD C IN COMMON /STCOM3/ C--------+---------+---------+---------+---------+---------+---------+-- C--------+---------+---------+---------+---------+---------+---------+-- C COMMON AREAS C--------+---------+---------+---------+---------+---------+---------+-- C1 C2 C3 C5 C6 C .. Scalar Arguments .. INTEGER CMPLET, INDG1, INDL1 C .. Scalars in Common .. REAL ERRTOL, HSTART, XEND, XFIN, XTRUE REAL GEMX, GEND, LEMXSC, OVHD, TIME, TRUTIM INTEGER ID, ID1, IFLAG, INDG, INDL, IOUT, IWT, IWT1, N, * N1, NBAD, NDCV, NFCN, NFCN1, NJAC, NJAC1, NLUD, * NLUD1, NRMTYP, NSTART, NSTL, NSTP, NTRU, OPT, * XTRAP C .. Arrays in Common .. REAL WT(20) C .. Local Scalars .. REAL DUMMY, HINIT, HMAX, X, XSTART REAL FCNTIM, JACTIM, LUDTIM, S, TIMCUM, TSTTIM INTEGER COUNT, I LOGICAL NOSTRT, OKMETH, TIMERR C .. Local Arrays .. REAL Y(20), YEND(20), YSTART(20) C .. External Functions .. REAL CLOCK, CONST, DIFNRM EXTERNAL CLOCK, CONST, DIFNRM C .. External Subroutines .. EXTERNAL EVALU, IVALU, METHOD, STATS C .. Intrinsic Functions .. INTRINSIC FLOAT C .. Common blocks .. COMMON /STCOM1/ERRTOL, OPT, NRMTYP, XTRAP, ID, IWT, * IOUT COMMON /STCOM2/XEND, HSTART, N, IFLAG, INDL, INDG COMMON /STCOM3/XFIN, XTRUE, TIME, OVHD, TRUTIM, GEND, * GEMX, LEMXSC, NFCN, NJAC, NLUD, NSTP, NSTL, * NDCV, NBAD, NTRU, NSTART COMMON /STCOM5/WT, IWT1, N1, ID1 COMMON /STCOM6/NFCN1, NJAC1, NLUD1 C .. Executable Statements .. CE C C--------+---------+---------+---------+---------+---------+---------+-- C NOTE ON INDL, INDG IN /STCOM2/: C THESE ARE ERROR INDICATORS FOR THE 'TRUE' LOCAL AND C GLOBAL SOLUTION RESPECTIVELY. THEY ARE SET INSIDE STATS C WHICH IS CALLED BY METHOD. C ON RETURN FROM METHOD, INDL IS: C 2 IF NO CALL TO TRUE TO COMPUTE LOCAL SOLUTION HAS C YET BEEN MADE (SET BY INITIALIZING CALL TO STATS). C .GT.0 IF ALL CALLS TO TRUE FOR CALCULATION OF LOCAL C SOLUTION WERE SUCCESSFUL. C .LT.0 IF AN UNSUCCESSFUL CALL TO TRUE FOR THE LOCAL C SOLUTION WAS MADE. C THE VALUE ON EXIT IF NOT 0 IS THE VALUE RETURNED IN THE C FLAG 'IND' OF SUBROUTINE TRUE. C INDG IS THE SAME, BUT FOR THE GLOBAL SOLUTION. C C INDL,INDG ARE USED ON RE-ENTRY TO STATS TO TEST IF A C FAILURE OF THE TRUE SOLUTIONS OCCURRED ON A PREVIOUS STEP C AND SHOULD THUS BE LEFT ALONE BETWEEN STEPS. C--------+---------+---------+---------+---------+---------+---------+-- C C ACTION OF THE ROUTINE: C CALL IVALU TO SET INTEGRATION PARAMETERS. C COPY N,ID,IWT INTO /STCOM5/ FOR USE BY FCN,PDERV. C SET IFLAG = 1 AND CALL STATS TO INITIALIZE ITS COMMON AREAS. C (THE ARGUMENTS FOR THIS CALL ARE DUMMIES.) C SET X,Y,NSTP,NFCN FOR USE IN STATS. SET IFLAG = 2 SO THAT C THE CALL TO METHOD WILL SET THE FIRST STEP SIZE (HSTART) C AND RETURN. C SET NSTART = NO. OF FCN CALLS NEEDED BY METHOD TO START. C--------+---------+---------+---------+---------+---------+---------+-- C CALL IVALU(N,XSTART,XEND,HINIT,HMAX,YSTART,FCNTIM,JACTIM,LUDTIM, * WT,IWT,ID) C N1 = N ID1 = ID IWT1 = IWT X = XSTART DO 20 I = 1, N Y(I) = YSTART(I) 20 CONTINUE C IFLAG = 1 CALL STATS(X,Y,DUMMY,Y) C NFCN1 = 0 NSTP = 0 IFLAG = 2 C CALL METHOD(N,X,Y,XEND,ERRTOL,HMAX,HINIT) C NOSTRT = X .LT. XEND NSTART = NFCN1 C--------+---------+---------+---------+---------+---------+---------+-- C INITIALIZE THE COUNTERS ETC. IN /STCOM3/,/STCOM6/. C IF METHOD FAILED TO START, SET FLAGS AND EXIT. C SET IFLAG = 3 SO THAT THE CALL TO METHOD WILL DO A COMPLETE C INTEGRATION, COMPILING STATISTICS ON EACH STEP. C START THE CLOCK. C--------+---------+---------+---------+---------+---------+---------+-- NFCN1 = 0 NJAC1 = 0 NLUD1 = 0 NSTP = 0 NSTL = 0 LEMXSC = 0. NDCV = 0 NBAD = 0 GEMX = 0. TRUTIM = 0. NTRU = 0 C IF (NOSTRT) GO TO 180 C X = XSTART DO 40 I = 1, N Y(I) = YSTART(I) 40 CONTINUE IFLAG = 3 S = CLOCK(0.0) C CALL METHOD(N,X,Y,XEND,ERRTOL,HMAX,HSTART) C TIME = CLOCK(S) OKMETH = X .GE. XEND XFIN = X NFCN = NFCN1 NJAC = NJAC1 NLUD = NLUD1 IF ( .NOT. OKMETH) GO TO 160 C--------+---------+---------+---------+---------+---------+---------+-- C IF OPT.GT.1, OR IF OPT = 1 BUT THE TIMING ESTIMATE ALREADY C OBTAINED WAS TOO SMALL TO BE RELIABLE, DO A TIMING COMPUTATION C PROVIDED THAT METHOD REACHED THE ENDPOINT IN THE PREVIOUS CALL. C SET IFLAG = 0, START THE CLOCK, AND CALL C METHOD SUFFICIENTLY MANY TIMES FOR THE SOLUTION TIME TO C BE OBTAINED ACCURATELY. COMPUTE THE OVERHEAD AS THE C TOTAL TIME EXCLUSIVE OF FUNCTION AND JACOBIAN EVALUATIONS C AND MATRIX INVERSIONS. C--------+---------+---------+---------+---------+---------+---------+-- TSTTIM = CONST(4) TIMERR = .FALSE. IF (TSTTIM.LE.0) GO TO 120 IF (OPT.EQ.1 .AND. TIME.GE.0.5*TSTTIM) GO TO 120 COUNT = 0 IFLAG = 0 S = CLOCK(0.0) C--------+---------+---------+---------+---------+---------+---------+-- C LOOP TILL 'TSTTIM' TIME UNITS HAVE ELAPSED: C--------+---------+---------+---------+---------+---------+---------+-- 60 CONTINUE X = XSTART DO 80 I = 1, N Y(I) = YSTART(I) 80 CONTINUE CALL METHOD(N,X,Y,XEND,ERRTOL,HMAX,HSTART) TIMERR = X .LT. XEND IF (TIMERR) GO TO 100 TIMCUM = CLOCK(S) COUNT = COUNT + 1 IF (TIMCUM.LT.TSTTIM .AND. COUNT.LT.10) GO TO 60 C 100 IF (COUNT.GE.1) TIME = TIMCUM/FLOAT(COUNT) 120 CONTINUE C--------+---------+---------+---------+---------+---------+---------+-- C WE NOW HAVE A VALUE FOR TIME: THE ONE OBTAINED BEFORE THE C TIMING LOOP IF WE SKIPPED THE LATTER OR IN THE UNLIKELY C EVENT OF AN ERROR IN THE 1ST TIMING ITERATION; OTHERWISE C THE ONE FROM THE TIMING LOOP. C COMPUTE OVERHEAD AND ENDPOINT GLOBAL ERROR. C--------+---------+---------+---------+---------+---------+---------+-- OVHD = TIME - FLOAT(NFCN)*FCNTIM - FLOAT(NJAC)*JACTIM - * FLOAT(NLUD)*LUDTIM CALL EVALU(YEND,N,WT,IWT,ID) GEND = DIFNRM(YEND,Y,N) C IF (TIMERR) GO TO 200 C C--------+---------+---------+---------+---------+---------+---------+-- C SET THE OUTPUT VALUE OF CMPLET, INDG1 AND INDL1. C--------+---------+---------+---------+---------+---------+---------+-- CMPLET = 1 IF (INDL.LT.0 .OR. INDG.LT.0) CMPLET = 0 140 INDG1 = INDG INDL1 = INDL RETURN C C--------+---------+---------+---------+---------+---------+---------+-- C *********** ERROR EXITS *********** C--------+---------+---------+---------+---------+---------+---------+-- C METHOD FAILED TO REACH XEND C--------+---------+---------+---------+---------+---------+---------+-- 160 CMPLET = -1 IF (INDL.LT.0 .OR. INDG.LT.0) CMPLET = -2 TIME = 1E20 OVHD = 1E20 GEND = 1E20 GO TO 140 C C--------+---------+---------+---------+---------+---------+---------+-- C METHOD FAILED TO START C--------+---------+---------+---------+---------+---------+---------+-- 180 CMPLET = -3 NFCN = 0 NJAC = 0 NLUD = 0 TIME = 1E20 OVHD = 1E20 GEND = 1E20 GO TO 140 C--------+---------+---------+---------+---------+---------+---------+-- C INTEGRATION FAILED IN TIMING LOOP C--------+---------+---------+---------+---------+---------+---------+-- 200 CMPLET = -4 GO TO 140 END C C********+*********+*********+*********+*********+*********+*********+** C REAL FUNCTION DIFNRM(A,B,N) C1 C .. Scalar Arguments .. INTEGER N C .. Array Arguments .. REAL A(N), B(N) C .. Scalars in Common .. REAL ERRTOL INTEGER ID, IOUT, IWT, NRMTYP, OPT, XTRAP C .. Local Scalars .. INTEGER I C .. Intrinsic Functions .. INTRINSIC AMAX1, ABS, REAL, SQRT C .. Common blocks .. COMMON /STCOM1/ERRTOL, OPT, NRMTYP, XTRAP, ID, IWT, * IOUT C .. Executable Statements .. C C********+*********+*********+*********+*********+*********+*********+** C NORM OF DIFFERENCE BETWEEN TWO DOUBLE PRECISION VECTORS, C SINGLE PRECISION RESULT. C NRMTYP=1,2,3 CHOOSES MAX-NORM, 2-NORM, R.M.S.-NORM. C--------+---------+---------+---------+---------+---------+---------+-- IF (NRMTYP.EQ.1) THEN DIFNRM = 0.0 DO 20 I = 1, N DIFNRM = AMAX1(DIFNRM,REAL(ABS(A(I)-B(I)))) 20 CONTINUE ELSE DIFNRM = 0.0 DO 40 I = 1, N DIFNRM = DIFNRM + REAL(ABS(A(I)-B(I)))**2 40 CONTINUE C IF (NRMTYP.EQ.2) DIFNRM = SQRT(DIFNRM) IF (NRMTYP.EQ.3) DIFNRM = SQRT(DIFNRM/N) END IF RETURN END C C********+*********+*********+*********+*********+*********+*********+** C SUBROUTINE STATS(X,Y,ERRBND,ERREST) C C********+*********+*********+*********+*********+*********+*********+** C STATS 'INSTRUMENTS' THE ODE-SOLVER BEING TESTED, BY COMPUTING C THE DEVIATION OF THE SOLUTION COMPUTED IN ROUTINE METHOD FROM C THE 'TRUE' GLOBAL AND LOCAL SOLUTIONS IF REQUESTED, AND BY C ACCUMULATING VARIOUS ASSOCIATED STATISTICS. IT ALSO PERFORMS C VARIOUS INITIALIZATION DUTIES, DEPENDING ON THE VALUE OF IFLAG C ON ENTRY. C C ON ENTRY C X,Y - MUST HOLD 'SOLVER' SOLUTION AT CURRENT STEP C ERREST- MUST HOLD ESTIMATED LOCAL ERROR VECTOR AT THIS STEP C DEFINED AS (COMPUTED Y) - (TRUE LOCAL SOLUTION AT NEW X). C SINCE ABSOLUTE ERROR-CONTROL IS SPECIFIED, THIS IS THE C VECTOR WHOSE NORM IS MAINTAINED BELOW ERRBND BY 'METHOD'. C IT IS ASSUMED THAT 'METHOD' USES ONE OF THE 3 NORMS C OFFERED BY THE PACKAGE, AND NRMTYP MUST BE SET SUITABLY. C ERRBND- MUST HOLD TOLERANCE BELOW WHICH THE NORM OF ERREST IS C BEING HELD AT THIS STEP. USUALLY SAME AS ERRTOL BUT WILL C BE DIFFERENT AND VARY WITH STEPSIZE IF (EG) A PER-UNIT- C STEP ERROR CRITERION IS USED. C C STORAGE FOR VARIOUS SOLUTIONS: C X,Y - CURRENT SOLUTION COMPUTED BY METHOD, PASSED IN C VIA ARGUMENT LIST. C XOLD,YOLD- VALUES OF X,Y AT AN OLD MESHPOINT OF METHOD, C USUALLY THE LAST ONE BUT OLDER IF A LUMPED C STEP IS BEING FORMED (SEE BELOW). C IF IFLAG = 0, NEITHER XOLD NOR YOLD IS USED. C YOLD IS NOT USED UNLESS STATISTICS ON LOCAL ERROR C ARE BEING COMPILED (IFLAG=3 AND OPT=3). C THE 'TRUE' LOCAL SOLUTION IS OBTAINED BY INTEG- C RATING FROM XOLD,YOLD TO THE CURRENT X. C XOLD,YOLD ARE USED AS THE ACTUAL ARGUMENTS IN THIS C INTEGRATION, AND ARE THEN UPDATED TO HOLD X,Y IN C PREPARATION FOR NEXT CALL TO STATS. C XT - LAST MESHPOINT OF METHOD. C XOLDG - INDEP VAR FOR 'TRUE' GLOBAL SOLUTION, IN COMMON. C YOLDG - 'TRUE' GLOBAL SOLUTION AT XOLDG, HELD IN COMMON. C UPDATED BY CALLING TRUE AT EACH CALL TO STATS IF C DETAILED STATISTICS ARE BEING COMPILED (IFLAG = 3) C AND IF OPT.GE.2 C YSTAR - ONLY USED IF OPT.EQ.4. IF SOLVER DOES NOT DO LOCAL C EXTRAPOLATION, WE FORM THE LOCALLY EXTRAPOLATED C SOLUTION IN YSTAR. C--------+---------+---------+---------+---------+---------+---------+-- C C--------+---------+---------+---------+---------+---------+---------+-- C COMMON AREAS C--------+---------+---------+---------+---------+---------+---------+-- C1 C2 C3 C4 C6 C .. Scalar Arguments .. REAL ERRBND, X C .. Array Arguments .. REAL ERREST(20), Y(20) C .. Scalars in Common .. REAL ERLUMP, ERRTOL, HSTART, PRECIS, XEND, XFIN, XOLD, * XOLD1, XOLDG, XT, XTRUE REAL GEMX, GEND, LEMXSC, OVHD, TIME, TRUTIM INTEGER ID, IFLAG, INDG, INDL, IOUT, IWT, N, NBAD, NDCV, * NFCN, NFCN1, NJAC, NJAC1, NLUD, NLUD1, NRMTYP, * NSTART, NSTL, NSTP, NTRU, OPT, XTRAP C .. Arrays in Common .. REAL CG(20), PDG(400), WG(400), WKG(20,12), YOLD(20), * YOLDG(20), YPG(20,11) INTEGER INFG(40) C .. Local Scalars .. REAL HLUMP, YNORM REAL ESTSC, LEERSC, LESC, THETA, TRUT0 INTEGER I, NDIM, NNFCN, NNJAC, NNLUD C .. Local Arrays .. REAL CL(20), PDL(400), WKL(20,12), WL(400), * YPL(20,11), YSTAR(20), ZERO(20) INTEGER INFL(40) C .. External Functions .. REAL CLOCK, CONST, DIFNRM EXTERNAL CLOCK, CONST, DIFNRM C .. External Subroutines .. EXTERNAL FCN, PDERV, PLOT, TRUE C .. Intrinsic Functions .. INTRINSIC AMAX1, ABS C .. Common blocks .. COMMON /STCOM1/ERRTOL, OPT, NRMTYP, XTRAP, ID, IWT, IOUT COMMON /STCOM2/XEND, HSTART, N, IFLAG, INDL, INDG COMMON /STCOM3/XFIN, XTRUE, TIME, OVHD, TRUTIM, GEND, * GEMX, LEMXSC, NFCN, NJAC, NLUD, NSTP, NSTL, NDCV, * NBAD, NTRU, NSTART COMMON /STCOM4/XOLD1, XOLD, YOLD, XOLDG, YOLDG, CG, PDG, * WKG, WG, YPG, XT, PRECIS, ERLUMP, INFG COMMON /STCOM6/NFCN1, NJAC1, NLUD1 C .. Data statements .. CE C DATA NDIM/20/ C .. Executable Statements .. C C--------+---------+---------+---------+---------+---------+---------+-- C IF IFLAG = 0 METHOD IS BEING TIMED. C--------+---------+---------+---------+---------+---------+---------+-- IF (IFLAG.EQ.0) RETURN C C--------+---------+---------+---------+---------+---------+---------+-- C IF IFLAG = 1 INITIALIZE VARIABLES TO DO WITH FINDING FIRST STEP- C SIZE, ASSESSING LUMPED STEPS AND COMPUTING TRUE GLOBAL SOLUTION. C RESET INDL, OTHERWISE A LOCAL FAILURE (INDL<0) ON A PREVIOUS C INTEGRATION WILL BE DEEMED A FAILURE ON THIS ONE. C 1ST 5 ELEMENTS OF INFG,CG MUST BE INITIALIZED; WE INITIALIZE C MORE TO AID DIAGNOSTICS. C--------+---------+---------+---------+---------+---------+---------+-- IF (IFLAG.NE.1) GO TO 60 C C FOR EVALUATING PERFORMANCE OF 'TRUE': C CALL TRUCHK(1,IDUM) PRECIS = 1000.*CONST(1) ERLUMP = 0. XOLD1 = X XOLD = X XOLDG = X XT = X DO 20 I = 1, N YOLD(I) = Y(I) YOLDG(I) = Y(I) 20 CONTINUE DO 40 I = 1, 20 INFG(I) = 0 CG(I) = 0. 40 CONTINUE INFG(1) = 1 INFG(3) = 1000 INDG = 2 INDL = 2 RETURN C--------+---------+---------+---------+---------+---------+---------+-- C IF IFLAG = 2 DETERMINE THE INITIAL STEPSIZE FOR C THE INTEGRATION PROPER. WE CHOOSE THE SECOND STEP C TAKEN AND TERMINATE THE INTEGRATION BY SETTING X C EQUAL TO XEND. HSTART THEN HOLDS THE CURRENT STEPSIZE. C--------+---------+---------+---------+---------+---------+---------+-- 60 IF (IFLAG.NE.2) GO TO 80 NSTP = NSTP + 1 HSTART = X - XOLD1 XOLD1 = X IF (NSTP.GE.2) X = XEND RETURN C C C--------+---------+---------+---------+---------+---------+---------+-- C IF IFLAG = 3 COMPILE STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- C C IF THE STEPSIZE AND, HENCE, THE ERROR REQUIREMENT WAS C TOO SMALL TO PERMIT AN EFFECTIVE ASSESSMENT AT THIS C PRECISION, CONTINUE THE INTEGRATION. A LUMPED ERROR C ESTIMATE IS FORMED IN ERLUMP AND SEVERAL SMALL STEPS C ASSESSED AS ONE. C THE TEST FOR THE SIZE OF A LUMPED STEP IS MATCHED TO THE C MINIMUM STEPSIZE TEST IN 'TRUE' AND IS INTENDED TO ENSURE C (VERY CONSERVATIVELY) THAT ROUNDOFF EFFECTS ARE NEGLIGIBLE. C MAX-NORM IS USED IRRESPECTIVE OF THE VALUE OF NRMTYP IN /STCOM1/. C IT IS ASSUMED THAT LUMPING OCCURS ONLY WHEN FAST TRANSIENTS ARE C BEING DAMPED OUT AND CONSEQUENTLY THE STEPSIZE WILL BE RAPIDLY C INCREASING. IN THIS SITUATION EARLIER LOCAL ERRORS HAVE LESS C EFFECT ON THE LUMPED ERROR THAN RECENT ONES AND THE C FORMULA FOR ERLUMP IS A CRUDE WAY TO ENSURE THIS. C--------+---------+---------+---------+---------+---------+---------+-- 80 CONTINUE NSTP = NSTP + 1 HLUMP = X - XOLD THETA = (X-XT)/HLUMP ERLUMP = ERLUMP + THETA*(ERRBND-ERLUMP) XT = X YNORM = 0. DO 100 I = 1, N YNORM = AMAX1(YNORM,ABS(YOLDG(I)),ABS(Y(I))) 100 CONTINUE IF (HLUMP*ERRTOL.GE.YNORM*PRECIS) GO TO 120 C WRITE(6,998)XOLD,X,THETA,HLUMP,ERREST,ERRBND,NSTL,NSTP C998 FORMAT(1H0,'XOLD X THETA HLUMP ERREST ERRBND NSTL NSTP=', C * 1P6D12.4,2I4) RETURN C C--------+---------+---------+---------+---------+---------+---------+-- C A SUFFICIENTLY LARGE LUMPED STEP HAS BEEN FORMED. C INCREMENT THE LUMPED STEP COUNT. C--------+---------+---------+---------+---------+---------+---------+-- 120 CONTINUE NSTL = NSTL + 1 C--------+---------+---------+---------+---------+---------+---------+-- C GLOBAL ASSESSMENT C SAVE COUNTERS THAT WILL BE AFFECTED BY 'TRUE' CALLS. SET MAX C STEPSIZE FOR GLOBAL SOLUTION TO X-XOLDG (DEFAULT VALUE IN TRUE IS C 1/5TH OF THIS.) C CONTINUE TRUE GLOBAL SOLUTION TO CURRENT MESHPOINT AND C UPDATE MAX GLOBAL ERROR GEMX. C IF FAILURE OCCURS, RECORD POSITION IN XTRUE AND SKIP LOCAL C ASSESSMENT ALSO. C--------+---------+---------+---------+---------+---------+---------+-- IF (OPT.LT.2 .OR. INDG.LT.0) GO TO 240 NNFCN = NFCN1 NNJAC = NJAC1 NNLUD = NLUD1 CG(4) = 1.1*(X-XOLDG) TRUT0 = CLOCK(0.) C CALL TRUE(FCN,PDERV,NDIM,N,XOLDG,YOLDG,X,1.E-2*ERRTOL,INDG,CG, * INFG,YPG,WG,PDG,WKG) C TRUTIM = TRUTIM + CLOCK(TRUT0) INFG(3) = INFG(13) + 100 IF (INDG.GE.0) GO TO 140 XTRUE = XOLDG C WRITE(6,999)(INFG(I),I=1,20),CG C999 FORMAT(1H0,'TRUE FAILURE, INF & C ='/1H0,20I6/ C * (1H0,1P10D12.4)) GO TO 220 140 GEMX = AMAX1(GEMX,DIFNRM(Y,YOLDG,N)) C--------+---------+---------+---------+---------+---------+---------+-- C LOCAL ASSESSMENT C OBTAIN THE LOCAL SOLUTION THROUGH THE PREVIOUS COMPUTED C MESH VALUE TO HIGHER ACCURACY THAN METHOD, PROVIDED NO C FAILURES HAVE OCCURRED IN PREVIOUS CALLS TO TRUE C (INDL.GE.0). CHECK FOR A FAILURE THIS TIME AFTER THE C CALL TO TRUE. COMPILE THE RELIABILITY STATISTICS. C--------+---------+---------+---------+---------+---------+---------+-- IF (OPT.LT.3 .OR. INDL.LT.0) GO TO 220 DO 160 I = 1, 5 INFL(I) = 0 CL(I) = 0. 160 CONTINUE INFL(1) = 1 INFL(3) = 500 INDL = 2 CL(4) = 1.1*(X-XOLD) TRUT0 = CLOCK(0.) C CALL TRUE(FCN,PDERV,NDIM,N,XOLD,YOLD,X,1.E-2*ERLUMP,INDL,CL,INFL, * YPL,WL,PDL,WKL) C TRUTIM = TRUTIM + CLOCK(TRUT0) XTRUE = XOLD C IF(INDL.LT.0)WRITE(6,999)(INFL(I),I=1,20),CL IF (INDL.LT.0) GO TO 220 C--------+---------+---------+---------+---------+---------+---------+-- C UPDATE STATISTICS C LESC RECORDS THE RATIO OF THE MAGNITUDE OF THE TRUE C LOCAL ERROR TO THE ASSUMED LOCAL ERROR BOUND. C LEMXSC RECORDS ITS MAXIMUM OVER THE RANGE. C NTRU COUNTS THE NO. OF LUMPED STEPS OF METHOD ON WHICH C LOCAL ASSESSMENT SUCCEEDED, SO AS TO ALLOW SUMMARY OF PARTIAL C RESULTS IF TRUE FAILS AT SOME POINT. C C IF OPT=4, DO THE ANALYSIS OF THE LOCAL ERROR ESTIMATE VECTOR, C ERREST, BY FORMING THE SCALED ||ERROR|| IN ERREST. IF LOCAL C EXTRAPOLATION IS DONE THIS IS LESC=||ERREST||/ERLUMP. IF NOT, C FORM YSTAR=LOCALLY EXTRAPOLATED SOLUTION AND IT IS THEN C ||YSTAR-YOLD||/ERLUMP. FORM A POINT ON THE SCATTER DIAGRAM C OF ERROR IN ERREST (VERT AXIS) VS. ERREST (HORIZ AXIS) C AND ENTER IT BY A CALL TO 'PLOT'. C--------+---------+---------+---------+---------+---------+---------+-- C C FOR EVALUATING PERFORMANCE OF 'TRUE': C CALL TRUCHK(3,INFL) LESC = DIFNRM(Y,YOLD,N)/ERLUMP LEMXSC = AMAX1(LEMXSC,LESC) IF (LESC.GT.1.0) NDCV = NDCV + 1 IF (LESC.GT.5.0) NBAD = NBAD + 1 IF (OPT.EQ.4) THEN C XTRAP=1 OR 0 ACCORDING AS THE USER HAS TOLD THE PACKAGE THAT C LOCAL EXTRAPOLATION IS OR IS NOT BEING DONE BY SOLVER: IF (XTRAP.EQ.0) THEN DO 180 I = 1, N YSTAR(I) = Y(I) - ERREST(I) 180 CONTINUE LEERSC = DIFNRM(YSTAR,YOLD,N)/ERLUMP ELSE LEERSC = LESC END IF ESTSC = DIFNRM(ERREST,ZERO,N)/ERLUMP CALL PLOT(ESTSC,LEERSC,1) C WRITE(IOUT,'('' I TRUE LE EST LE'')') C DO 95 I=1,N C95 WRITE(IOUT,''(' ',I3,2F14.10)'') I,LERR(I),ERREST(I) END IF C NTRU = NTRU + 1 C--------+---------+---------+---------+---------+---------+---------+-- C UPDATE MEMORY OF LAST COMPUTED VALUES. C--------+---------+---------+---------+---------+---------+---------+-- DO 200 I = 1, N YOLD(I) = Y(I) 200 CONTINUE C--------+---------+---------+---------+---------+---------+---------+-- C RESTORE THE COUNTS AFFECTED BY 'TRUE' CALLS. C--------+---------+---------+---------+---------+---------+---------+-- 220 NFCN1 = NNFCN NJAC1 = NNJAC NLUD1 = NNLUD C--------+---------+---------+---------+---------+---------+---------+-- C RE-INITIALIZE THE DATA PERTAINING TO A LUMPED STEP. C--------+---------+---------+---------+---------+---------+---------+-- 240 ERLUMP = 0. XOLD = X C--------+---------+---------+---------+---------+---------+---------+-- C RETURN TO METHOD TO CONTINUE THE INTEGRATION. C--------+---------+---------+---------+---------+---------+---------+-- RETURN END * SUBROUTINE PLOT(X,Y,IFLAG) C ROUTINE TO FORM PLOTS OF LOCAL ERROR INFORMATION FOR DETEST, USING C AN ARRAY K WHICH IS IN 'SAVE' STORAGE. C C IF IFLAG<=0, IT RESETS ARRAY K TO ZERO. C C IF IFLAG=1, THE ROUTINE ENTERS (X,Y) ON THE SCATTER-DIAGRAM C REPRESENTED BY K. HERE X,Y ARE >= 0, AND THE RANGE 0 TO INFINITY IS C SPLIT INTO CLASS-INTERVALS NUMBERED I = NLO .. NHI, THE I-TH INTERVAL C BEING 2**(I-1) <= X < 2**I EXCEPT THAT THE NLO-TH ONE INCLUDES ALL C X BELOW 2**NLO AND THE NHI-TH INCLUDES ALL X >=2**(NHI-1). C C IF IFLAG=2, THE SCATTER DIAGRAM IS PRINTED OUT. C C NOTE: IF IMPLEMENTER WISHES TO ALTER NLO, NHI THEN THE DATA C STATEMENTS MUST BE ALTERED CORRESPONDINGLY. C CERR CHARACTER STR3*3, LINE*LINLEN, LINE1*LINLEN, LINE2*LINLEN, CERR * LINE3*LINLEN, LINE4*LINLEN C .. Parameters .. INTEGER NLO, NHI REAL ALOG2 INTEGER NMIN, LINLEN REAL XYMIN PARAMETER (NLO=-7,NHI=4,ALOG2=.69314718,NMIN=NLO-1, * LINLEN=3*(NHI-NLO+1)+1,XYMIN=2.**NMIN) C .. Scalar Arguments .. REAL X, Y INTEGER IFLAG C .. Local Scalars .. REAL C, P, T INTEGER I, IOUT, J, JL, KMAX, KTOT CHARACTER*(LINLEN) LINE CHARACTER*(LINLEN) LINE1 CHARACTER*(LINLEN) LINE2 CHARACTER*(LINLEN) LINE3 CHARACTER*(LINLEN) LINE4 C .. Local Arrays .. INTEGER K(NLO:NHI,NLO:NHI) C .. External Functions .. REAL CONST CHARACTER*3 STR3 EXTERNAL CONST, STR3 C .. Intrinsic Functions .. INTRINSIC ALOG, MAX, MIN, NINT C .. Statement Functions .. INTEGER ICLAS, ICLAS0 C .. Save statement .. SAVE K, KTOT, KMAX, IOUT C .. Data statements .. DATA LINE1/'+--+--+--+--+--+--+--+--+--+--+--+--+'/, * LINE2/'+ +'/, * LINE3/'| |'/, * LINE4/' 2 2 2 2 2 2 2 2 2 2 2 '/ C .. Executable Statements .. C C C .. Statement Function definitions .. ICLAS0(T) = NMIN + NINT(ALOG(MAX(1.,T/XYMIN))/ALOG2) ICLAS(T) = MIN(MAX(ICLAS0(T),NLO),NHI) IF (IFLAG.LE.0) THEN IOUT = CONST(3) KTOT = 0 KMAX = 0 DO 40 I = NLO, NHI DO 20 J = NLO, NHI K(I,J) = 0 20 CONTINUE 40 CONTINUE ELSE IF (IFLAG.EQ.1) THEN IF (X.LT.0. .OR. Y.LT.0.) THEN WRITE (IOUT,FMT=*) * ' ERROR IN ARGUMENTS TO DETEST PLOT ROUTINE', X, Y STOP END IF I = ICLAS(X) J = ICLAS(Y) K(I,J) = K(I,J) + 1 KTOT = KTOT + 1 KMAX = MAX(KMAX,K(I,J)) ELSE C = KTOT DO 80 I = NHI, NLO, -1 LINE = LINE3 DO 60 J = NLO, NHI JL = J - NLO P = K(J,I)/C LINE(3*JL+1:3*JL+3) = STR3(P) 60 CONTINUE CERR8 LINE(3*JL+1:3*JL+3) = STR3(K(J,I)/C) IF (LINE(1:1).EQ.' ') LINE(1:1) = '|' IF (I.EQ.NHI) THEN WRITE (IOUT,FMT='(1X,15X,''INFINITY '',A)') LINE1 WRITE (IOUT,FMT='(1X,20X,'' '',A)') LINE ELSE WRITE (IOUT,FMT='(1X,15X,I8,1X,A)') I, LINE2 WRITE (IOUT,FMT='(1X,20X,''2 '',A)') LINE END IF 80 CONTINUE WRITE (IOUT,FMT='(1X,24X,A)') LINE1 WRITE (IOUT,FMT='(/1X,25X,30I3)') (J,J=NLO,NHI-1) WRITE (IOUT,FMT='(1X,24X,A)') LINE4 END IF RETURN END CHARACTER*3 FUNCTION STR3(P) C CONVERTS P (MEANT TO BE IN RANGE 0 TO 1) TO A 3 CHARACTER C INTEGER PERCENTAGE. P=0 BECOMES ' ', 0 HMAX. C IF (C(9).LE.C(11)) GO TO 560 IND = -2 RETURN 560 CONTINUE C C CASES - INITIAL STEP, LAST STEP ACCEPTED, LAST STEP REJECTED. C IER = INF(8) GO TO (580,720,980,980) IER C C CASE 1 - INITIAL STEP (INF(8) .EQ. 1) C 580 CONTINUE CALL FCN(X,Y,YP(1,8)) CALL PDERV(X,Y,PDERIV) INF(13) = INF(13) + 1 INF(14) = INF(14) + 1 INF(6) = 3 K = 1 INF(17) = 0 INF(16) = 0 INF(20) = 1 INF(18) = -1 INF(19) = 1 CALL COEFF(K,POEF,COEF,PIE,PII) DO 620 I = 1, N YDP = 0.D0 DO 600 J = 1, N YDP = YDP + PDERIV(I+(J-1)*N)*YP(J,8) 600 CONTINUE YP(I,9) = YDP 620 CONTINUE HSTART = C(5) IF (HSTART.EQ.0.D0) GO TO 640 C(12) = DMIN1(DABS(HSTART),C(11)) GO TO 700 640 CONTINUE HABS = DSQRT(C(6)) HTMP = DSIGN(HABS,XEND-X) DO 660 I = 1, N WORK(I,1) = Y(I) + HTMP*(YP(I,8)+.5D0*HTMP*YP(I,9)) 660 CONTINUE CALL FCN(X+HTMP,WORK(1,1),YP(1,10)) YP3NRM = C(7) DO 680 I = 1, N YDP = (WORK(I,1)-Y(I)-HTMP*(COEF(2)*YP(I,10)+COEF(1)*YP(I,8))) * /(HTMP*HTMP*COEF(3)) YP3NRM = DMAX1(YP3NRM,DABS(YP(I,9)-YDP)) 680 CONTINUE C(12) = DMIN1(C(11),.95D0*(6.D0*TOL*HABS/YP3NRM)**(1.D0/3.D0)) 700 CONTINUE C(14) = DSIGN(C(12),XEND-X) C(13) = X + C(14) GO TO 1220 720 CONTINUE IF (INF(16).LE.0 .OR. C(12).GE.C(11)) GO TO 920 HABS = DABS(C(14)) IF (INF(16).GE.K+1) GO TO 740 C(12) = STEP(C(15),C(12),TOL,INF(6)) HK = C(12) GO TO 900 740 CONTINUE HPAST = C(16) KM1 = K - 1 NQM1 = INF(6) - 1 KP1 = K + 1 NQP1 = INF(6) + 1 HKM1 = 0.D0 IF (K.EQ.1) GO TO 800 CALL COEFF(KM1,PTMP,CTMP,PEKM1,PIKM1) ESTKM1 = 0.D0 JSHFT = 8 - K DO 780 I = 1, N SUM = C(14)*PTMP(NQM1)*YP(I,9) DO 760 J = 1, K SUM = SUM + PTMP(J)*YP(I,J+JSHFT) 760 CONTINUE YKM1 = C(14)*SUM + WORK(I,4) ESTKM1 = DMAX1(ESTKM1,DABS(YKM1-Y(I))*WORK(I,9)) 780 CONTINUE ESTKM1 = PIKM1*ESTKM1/PEKM1 HKM1 = STEP(ESTKM1,C(12),TOL,NQM1) 800 CONTINUE HKP1 = 0.D0 IF (INF(6).EQ.INF(7)) GO TO 840 CALL COEFF(KP1,PTMP,CTMP,PEKP1,PIKP1) HP = (C(14)/HPAST)**NQP1 ESTKP1 = 0.D0 DO 820 I = 1, N ESTKP1 = DMAX1(ESTKP1,DABS(WORK(I,7)-WORK(I,8)*HP)*WORK(I,9)) 820 CONTINUE ESTKP1 = PIKP1*ESTKP1/(PIE-PII) HKP1 = STEP(ESTKP1,C(12),TOL,NQP1) 840 CONTINUE IF (HKP1.GT.HKM1) GO TO 860 HTMP = HKM1 KTMP = KM1 GO TO 880 860 CONTINUE HTMP = HKP1 KTMP = KP1 880 CONTINUE HK = STEP(C(15),C(12),TOL,INF(6)) C(12) = HK IF (HK.GE.DMIN1(HTMP,C(11)) .OR. HTMP.LT.1.3D0*HABS .AND. .NOT. * (HK.LE.HABS .AND. HTMP.GT.1.1D0*HABS)) GO TO 900 C(12) = HTMP K = KTMP INF(6) = K + 2 CALL COEFF(K,POEF,COEF,PIE,PII) INF(16) = 0 INF(20) = 1 900 CONTINUE C(12) = DMIN1(C(12),C(11)) IF (C(12).EQ.HK .AND. C(12).LE.1.3D0*HABS) C(12) = HABS 920 CONTINUE JSHFT = 8 - K DO 960 I = 1, N DO 940 J = JSHFT, 7 YP(I,J) = YP(I,J+1) 940 CONTINUE YP(I,8) = YP(I,10) YP(I,9) = YP(I,11) 960 CONTINUE C(16) = C(14) GO TO 1100 980 CONTINUE IF (INF(8).EQ.4) GO TO 1000 INF(8) = 4 INF(16) = -1 C(12) = C(12)*.5D0 IF (INF(6).EQ.3) GO TO 1060 IF (INF(12).GE.4) GO TO 1040 GO TO 1020 1000 CONTINUE C(12) = STEP(C(15),C(12),TOL,INF(6)-1) IF (INF(6).EQ.3) GO TO 1060 IF (INF(12).GE.4) GO TO 1040 INF(18) = -1*INF(18) IF (INF(18).EQ.-1) GO TO 1080 1020 CONTINUE INF(16) = MIN0(INF(16),0) INF(6) = INF(6) - 1 K = K - 1 CALL COEFF(K,POEF,COEF,PIE,PII) GO TO 1080 1040 CONTINUE INF(6) = 3 K = 1 CALL COEFF(K,POEF,COEF,PIE,PII) 1060 CONTINUE INF(17) = INF(17) + 1 IF (INF(17).GE.2) INF(19) = 1 1080 CONTINUE 1100 CONTINUE C>>>>>>>>INTERRUPT NO. 1 (IND .EQ. 4) IF REQUESTED IF (INF(4).EQ.0) GO TO 1120 IND = 4 RETURN C C RESUME HERE ON RE-ENTRY WITH IND .EQ. 4 - ...RE-ENTRY........... C 1120 CONTINUE C C OBTAIN FINAL HMAG, XTRIAL AND HTRIAL C DIFF = XEND - X K = INF(6) - 2 IF (IND.EQ.4) CALL COEFF(K,POEF,COEF,PIE,PII) IF (C(12).GE.DABS(DIFF)) GO TO 1140 C DO NOT STEP MORE THAN HALF WAY TO XEND C(12) = DMIN1(C(12),.5D0*DABS(DIFF)) IF (C(4).EQ.0.D0) C(11) = C(12) GO TO 1160 1140 CONTINUE C HIT XEND EXACTLY C(12) = DABS(DIFF) 1160 CONTINUE C CALCULATE HTRIAL HTMP = C(14) C(14) = DSIGN(C(12),DIFF) C(13) = X + C(14) IF (HTMP.NE.C(14)) GO TO 1180 GO TO 1200 1180 CONTINUE C C IF HTRIAL IS BEING CHANGED RESET UPDATE, INF(20), AND C CALL NEWSTP TO OBTAIN THE APPROXIMATION TO F AT C K EQUALLY SPACED POINTS C INF(20) = 1 IF (INF(19).EQ.0) CALL NEWSTP(NDIM,N,K,X,HTMP,C(14),YP) 1200 CONTINUE 1220 CONTINUE 1240 CONTINUE NQ = INF(6) RREB = C(6) HMAG = C(12) XTRIAL = C(13) HTRIAL = C(14) HPAST = C(16) IF (INF(19).EQ.1) GO TO 1260 GO TO 1300 1260 CONTINUE DO 1280 I = 1, N WORK(I,2) = Y(I) + HTRIAL*(YP(I,8)+HTRIAL*YP(I,9)*.5D0) WORK(I,1) = WORK(I,2) IF (INF(10).EQ.0) GO TO 1280 WORK(I,1) = Y(I) + (Y(I)-WORK(I,4))*HTRIAL/HPAST YP(I,1) = WORK(I,1) 1280 CONTINUE GO TO 1400 1300 CONTINUE RATIO = HTRIAL/HPAST JSHFT = 7 - K KP1 = K + 1 DO 1340 I = 1, N SUM = HTRIAL*POEF(NQ)*YP(I,9) DO 1320 J = 1, KP1 SUM = SUM + POEF(J)*YP(I,JSHFT+J) 1320 CONTINUE WORK(I,2) = HTRIAL*SUM + Y(I) WORK(I,1) = WORK(I,2) IF (NQ.GT.3) GO TO 1340 WORK(I,1) = Y(I) + (Y(I)-WORK(I,4))*RATIO YP(I,1) = WORK(I,1) 1340 CONTINUE IF (INF(8).NE.2) GO TO 1380 DO 1360 I = 1, N WORK(I,8) = WORK(I,7) 1360 CONTINUE 1380 CONTINUE 1400 CONTINUE NN = N*N NP1 = N + 1 CALL FCN(XTRIAL,WORK(1,1),YP(1,10)) INF(13) = INF(13) + 1 CALL PDERV(XTRIAL,WORK(1,1),PDERIV) INF(14) = INF(14) + 1 ERRCO = PII/(PIE-PII) DMAX = 1.D0 DPRED = 1.D-16 JSHFT = 8 - K DO 1440 I = 1, N DPRED = DMAX1(DPRED,DABS(YP(I,10)-YP(I,8)) * /DMAX1(1.D0,DABS(YP(I,8)))) WORK(I,6) = YP(I,10) CNST = 0.D0 DO 1420 J = 1, K CNST = CNST + COEF(J)*YP(I,JSHFT+J) 1420 CONTINUE WORK(I,5) = HTRIAL*CNST + Y(I) 1440 CONTINUE DPRED = HMAG*DPRED DPAST = DPRED DSTRT = DPRED ICONV = 1 IF (INF(8).EQ.2 .AND. INF(20).EQ.0) ICONV = 2 RESTRT = .FALSE. ERRLIM = .25D0*(1.9D0**NQ)*TOL KOUNT = 1 C C ITERATE UNTIL CONVERGENCE, DIVERGENCE DETECTED, OR KOUNT .GE. 5 C 1460 IF (ICONV.EQ.1) GO TO 1480 GO TO 1600 C C IF ICONV = 1 THEN RE-EVALUATE W, THE ITERATION MATRIX. C OTHERWISE, PROCEED TO THE NEXT STAGE C 1480 CONTINUE IF (KOUNT.EQ.1) GO TO 1500 CALL PDERV(XTRIAL,WORK(1,1),PDERIV) INF(14) = INF(14) + 1 1500 CONTINUE RESTRT = .TRUE. R = -HTRIAL*HTRIAL*COEF(NQ) HTMP = -HTRIAL*COEF(K+1) DO 1560 I = 1, N DO 1540 J = 1, N JM1TN = (J-1)*N IJ = I + JM1TN W(IJ) = PDERIV(IJ)*HTMP IF (I.EQ.J) W(IJ) = W(IJ) + 1.D0 SUM = 0.D0 DO 1520 M = 1, N SUM = SUM + PDERIV(I+(M-1)*N)*PDERIV(M+JM1TN) 1520 CONTINUE SUM = R*SUM IF (I.EQ.J .AND. SUM.EQ.SUM+1.D0) * SUM = SUM*(1.D0-10.D0*RREB) W(IJ) = W(IJ) + SUM 1540 CONTINUE 1560 CONTINUE INF(15) = INF(15) + 1 CALL DDCOMP(N,N,W,INF(21),ISING) IF (ISING.EQ.0) GO TO 1580 C MATRIX APPEARS SINGULAR, SET INF(8) TO 3 AND BRANCH TO C THE END OF YCALC. INF(8) = 3 GO TO 1980 1580 CONTINUE 1600 CONTINUE C C CALCULATE THE RIGHT HAND SIDE OF THE SYSTEM, WORK(*,10) C THEN BACK-SUBSTITUTE TO SOLVE FOR THE CORRECTION C VECTOR, WORK(*,11). C DO 1640 I = 1, N R = 0.D0 DO 1620 J = 1, N R = R + PDERIV(I+(J-1)*N)*YP(J,10) 1620 CONTINUE YP(I,11) = R WORK(I,10) = -WORK(I,1) + HTRIAL*COEF(K+1)*YP(I,10) + * HTRIAL*HTRIAL*COEF(NQ)*R + WORK(I,5) 1640 CONTINUE CALL DSOLVE(N,N,W,INF(21),WORK(1,10),WORK(1,11)) DELMAX = 0.D0 CMAX = 0.D0 DO 1660 I = 1, N DELTA = WORK(I,11) WEIGHT = WORK(I,3) WORK(I,1) = WORK(I,1) + DELTA WORK(I,7) = WORK(I,2) - WORK(I,1) WORK(I,12) = ERRCO*WORK(I,7) DELMAX = DMAX1(DELMAX,DABS(DELTA)*WEIGHT) CMAX = DMAX1(CMAX,DABS(WORK(I,7))*WEIGHT) WORK(I,10) = YP(I,10) 1660 CONTINUE C(15) = ERRCO*CMAX CONVGD = .FALSE. DIFF = DMAX1(1.D-2*TOL,RREB*C(8)) IF (DELMAX.LE.DMAX1(DIFF,RREB)) CONVGD = .TRUE. DBND = DMIN1(RREB,.1D0*TOL) IF ((DMAX.LE.DBND .AND. CONVGD) .OR. * (KOUNT.EQ.2 .AND. DELMAX.LE.DBND)) GO TO 1700 C C IF IT APPEARS THAT THE SYSTEM IS LINEAR, DON'T DO THE C LAST FUNCTION EVALUATION. C INF(13) = INF(13) + 1 CALL FCN(XTRIAL,WORK(1,1),YP(1,10)) FMAX = 0.D0 DO 1680 I = 1, N FMAX = DMAX1(FMAX,DABS(WORK(I,10)-YP(I,10)) * /DMAX1(DABS(WORK(I,10)),1.D0)) 1680 CONTINUE DMAX = DMAX1(HMAG*FMAX,DBND) 1700 CONTINUE C C CHECK FOR CONVERGENCE (DMAX <=MIN(1.D-3,TOL) AND C DELMAX <= 1.D-2*TOL) C IF ((DMAX.LE.DMIN1(TOL,1.D-3) .AND. CONVGD) * .OR. (KOUNT.EQ.2 .AND. DELMAX.LE.DBND)) GO TO 1720 GO TO 1760 1720 CONTINUE DO 1740 I = 1, N YP(I,11) = (WORK(I,1)-WORK(I,5)-COEF(K+1)*HTRIAL*YP(I,10)) * /(HTRIAL*HTRIAL*COEF(NQ)) 1740 CONTINUE GO TO 1980 1760 CONTINUE C C IF CONVERGENCE CRITERIA HAVE NOT BEEN SATISFIED, PREPARE FOR C THE NEXT ITERATION. C CHECK TO SEE THAT ANOTHER ITERATION IS ALLOWED (KOUNT < 5) C IF (KOUNT.GE.5) GO TO 1780 GO TO 1800 1780 INF(8) = 3 GO TO 1980 1800 CONTINUE KOUNT = KOUNT + 1 IF (C(15).GT.TOL) GO TO 1820 GO TO 1900 1820 CONTINUE IF (RESTRT) GO TO 1840 GO TO 1860 1840 CONTINUE IF (C(15).GT.ERRLIM) INF(8) = 3 GO TO 1980 1860 CONTINUE ICONV = 1 DO 1880 I = 1, N WORK(I,1) = WORK(I,2) IF (NQ.EQ.3) WORK(I,1) = YP(I,1) YP(I,10) = WORK(I,6) 1880 CONTINUE DPRED = DSTRT DPAST = DSTRT GO TO 1460 1900 CONTINUE C C ANOTHER ITERATION WILL BE DONE, CHECK TO SEE IF AN UPDATE OF C W IS NECESSARY. C IF ((DMAX.LE.DPRED .OR. (KOUNT.EQ.2 .AND. RESTRT)) .OR. CONVGD) * GO TO 1920 GO TO 1940 1920 ICONV = 2 GO TO 1960 1940 IF (DMAX.GT.(N/6)*DPRED) ICONV = 1 1960 CONTINUE C ALLOW AT MOST 2 UPDATES PER TRIAL STEP. IF (ICONV.EQ.1) INF(20) = INF(20) + 1 IF (INF(20).GT.2) ICONV = 2 RATE = DMAX1(.2D0,DMIN1(.5D0,DMAX/DPAST)) DPAST = DMAX IF (KOUNT.EQ.2 .OR. DPRED.GT.RATE*DMAX) * DPRED = DMAX1(TOL,RATE*DMAX) GO TO 1460 1980 CONTINUE C C SET INF(8) AND IND TO THEIR CORRECT VALUES. C IF (INF(8).EQ.3) GO TO 2000 INF(8) = 2 IF (C(15).GT.TOL) INF(8) = 4 2000 CONTINUE IND = 5 + INF(8)/3 C>>>>>>>>INTERRUPT NO. 2 (IND .EQ. 5) IF REQUESTED IF (INF(5).EQ.0) GO TO 2020 RETURN C C RESUME HERE ON RE-ENTRY WITH IND .EQ. 5 - ...RE-ENTRY........... C 2020 CONTINUE K = INF(6) - 2 IF (INF(5).NE.0) CALL COEFF(K,POEF,COEF,PIE,PII) IF (INF(8).NE.2 .OR. IND.EQ.6) GO TO 2080 C C LAST STEP IS ACCEPTED, RESET STATUS VARIABLES TO INDICATE C THIS, UPDATE X AND Y AND FINALLY SEE IF X = XEND. C INF(8) = 2 X = C(13) DO 2040 I = 1, N WORK(I,9) = WORK(I,3) WORK(I,4) = Y(I) Y(I) = WORK(I,1) 2040 CONTINUE INF(10) = INF(10) + 1 INF(12) = 0 INF(16) = INF(16) + 1 INF(17) = 0 INF(18) = 1 INF(19) = 0 INF(20) = 0 IF (XEND+DABS(XEND-X)*.1D0.NE.XEND) GO TO 2060 IND = 3 C(17) = XEND X = XEND INF(9) = 1 RETURN 2060 CONTINUE GO TO 2120 C C ELSE STEP IS REJECTED C ADD 1 TO COUNTER FOR NUMBER OF FAILURES C ADD 1 TO NUMBER OF SUCCESSIVE FAILURES C 2080 CONTINUE INF(11) = INF(11) + 1 INF(12) = INF(12) + 1 IF (DABS(C(14)).GT.C(9)) GO TO 2100 C C*************** ERROR RETURN IF |HTRIAL| <= HMIN C IND = -3 RETURN 2100 CONTINUE 2120 CONTINUE GO TO 240 C C*********************************************************************** C*********************************************************************** C C BEGIN ABORT ACTION: 2140 CONTINUE IOUT = CONST(3) WRITE (IOUT,FMT=99999) IND, TOL, X, N, C(9), XEND, NDIM, C(11), * C(17), INF(10), INF(12), INF(13), (Y(J),J=1,N) STOP C 99999 FORMAT (/// * '0COMPUTATION STOPPED IN SECDER WITH THE FOLLOWING VALUES', * /'0IND =',I4,5X,'TOL =',1P,D13.6,5X,'X =',1P, * D22.15,/' N =',I4,5X,'HMIN =',1P,D13.6,5X,'XEND =', * 1P,D22.15,/' NDIM=',I4,5X,'HMAX =',1P,D13.6,5X, * 'PREV XEND =',1P,D22.15,/'0',14X, * 'NO OF SUCCESSFUL STEPS =',I8,/15X, * 'NO OF SUCCESSIVE FAILURES =',I8,/15X, * 'NO OF FUNCTION EVALS =',I8, * /'0THE COMPONENTS OF Y ARE',//(' ',1P,D24.15)) END DOUBLE PRECISION FUNCTION STEP(ERR,HMAG,TOL,NQ) C .. Scalar Arguments .. DOUBLE PRECISION ERR, HMAG, TOL INTEGER NQ C .. Local Scalars .. DOUBLE PRECISION STPMAX C .. Executable Statements .. STPMAX = 1.D1 IF (NQ.GE.5) STPMAX = 2.D0 IF (TOL.GE.(STPMAX/.95D0)**(NQ+1)*4.D0*ERR) GO TO 20 GO TO 40 20 STEP = STPMAX*HMAG RETURN 40 STEP = .95*HMAG*(TOL/(4.D0*ERR))**(1.D0/(NQ+1)) RETURN END SUBROUTINE NEWSTP(NDIM,N,K,X,H,HNEW,YP) C .. Scalar Arguments .. DOUBLE PRECISION H, HNEW, X INTEGER K, N, NDIM C .. Array Arguments .. DOUBLE PRECISION YP(NDIM,11) C .. Local Scalars .. DOUBLE PRECISION FCT, RATIO, SP1, TMP, VALUE INTEGER I, IMAX, J, KOUNT, KP1, L, LIM, LM1, M, NQ C .. Local Arrays .. DOUBLE PRECISION C(9), DIV(8), FACT(7,7), FKP1(7), S(7) C .. Intrinsic Functions .. INTRINSIC DBLE C .. Executable Statements .. KP1 = K + 1 NQ = K + 2 DIV(1) = 1.D0 DO 20 I = 2, KP1 DIV(I) = 1.D0/DBLE(I) 20 CONTINUE RATIO = HNEW/H C CALCULATE THE COEFFICIENTS FOR THE BACKWARD DIFFERENCES C DO 60 M = 1, K S(M) = M*RATIO SP1 = S(M) + 1.D0 FCT = 1.D0 DO 40 J = 1, K FCT = -FCT*(SP1-J)*DIV(J) FACT(M,J) = FCT 40 CONTINUE FKP1(M) = -FCT*(S(M)-K) 60 CONTINUE DO 200 KOUNT = 1, N C C CALCULATE THE BACKWARD DIFFERENCE FORM OF THE OLD POINT C SET, STORING THE RESULTS IN C. C LIM = 8 - K LM1 = LIM - 1 DO 80 I = LIM, 9 C(I-LM1) = YP(KOUNT,I) 80 CONTINUE DO 120 L = 1, K IMAX = KP1 - L DO 100 I = 1, IMAX C(I) = C(I+1) - C(I) 100 CONTINUE 120 CONTINUE TMP = H*C(NQ) DO 140 I = 1, K TMP = TMP - DIV(I)*C(KP1-I) 140 CONTINUE C C EVALUATE THE INTERPOLATING POLYNOMIAL AT THE NEW POINT SET C DO 180 M = 1, K VALUE = C(KP1) + FKP1(M)*TMP DO 160 J = 1, K VALUE = VALUE + FACT(M,J)*C(KP1-J) 160 CONTINUE YP(KOUNT,8-M) = VALUE 180 CONTINUE 200 CONTINUE RETURN END SUBROUTINE COEFF(K,POEF,COEF,PIE,PII) C .. Scalar Arguments .. DOUBLE PRECISION PIE, PII INTEGER K C .. Array Arguments .. DOUBLE PRECISION COEF(9), POEF(9) C .. Executable Statements .. GO TO (20,40,60,80,100,120,140) K C ****************************************************** C 1: ORDER = 3 C ****************************************************** 20 COEF(1) = 1.D0/3.D0 COEF(2) = 2.D0/3.D0 COEF(3) = -1.D0/6.D0 POEF(1) = COEF(1) POEF(2) = COEF(2) POEF(3) = 5.D0/6.D0 PII = 1.D0/72.D0 PIE = 7.D0/72.D0 GO TO 160 C ****************************************************** C 2: ORDER = 4 C ****************************************************** 40 COEF(1) = -1.0D0/48.0D0 COEF(2) = 5.0D0/12.0D0 COEF(3) = 29.0D0/48.0D0 COEF(4) = -1.0D0/8.0D0 POEF(1) = -7.D0/48.D0 POEF(2) = 11.D0/12.D0 POEF(3) = 11.D0/48.D0 POEF(4) = 9.D0/8.D0 PII = 7.D0/1440.D0 PIE = 97.D0/1440.D0 GO TO 160 C ****************************************************** C 3: ORDER = 5 C ****************************************************** 60 COEF(1) = 7.0D0/1080.0D0 COEF(2) = -1.0D0/20.0D0 COEF(3) = 19.0D0/40.0D0 COEF(4) = 307.0D0/540.0D0 COEF(5) = -19.0D0/180.0D0 POEF(1) = 97.D0/1080.D0 POEF(2) = -11.D0/20.D0 POEF(3) = 69.D0/40.D0 POEF(4) = -143.D0/540.D0 POEF(5) = 251.D0/180.D0 PII = 17.D0/7200.D0 PIE = 367.D0/7200.D0 GO TO 160 C ****************************************************** C 4: ORDER = 6 C ****************************************************** 80 COEF(1) = -17.0D0/5760.0D0 COEF(2) = 1.0D0/45.0D0 COEF(3) = -41.0D0/480.0D0 COEF(4) = 47.0D0/90.0D0 COEF(5) = 3133.0D0/5760.0D0 COEF(6) = -3.0D0/32.0D0 POEF(1) = -367.D0/5760.D0 POEF(2) = 58.D0/135.D0 POEF(3) = -631.D0/480.D0 POEF(4) = 247.D0/90.D0 POEF(5) = -13751.D0/17280.D0 POEF(6) = 475.D0/288.D0 PII = 41.D0/30240.D0 PIE = 1231.D0/30240.D0 GO TO 160 C ****************************************************** C 5: ORDER = 7 C ****************************************************** 100 COEF(1) = 41.0D0/25200.0D0 COEF(2) = -529.0D0/40320.0D0 COEF(3) = 373.0D0/7560.0D0 COEF(4) = -1271.0D0/10080.0D0 COEF(5) = 2837.0D0/5040.0D0 COEF(6) = 317731.0D0/604800.0D0 COEF(7) = -863.0D0/10080.0D0 POEF(1) = 1231.D0/25200.D0 POEF(2) = -14879.D0/40320.D0 POEF(3) = 9403.D0/7560.D0 POEF(4) = -25561.D0/10080.D0 POEF(5) = 19987.D0/5040.D0 POEF(6) = -818579.D0/604800.D0 POEF(7) = 19087.D0/10080.D0 PII = 731.D0/846720.D0 PIE = 28549.D0/846720.D0 GO TO 160 C ****************************************************** C 6: ORDER = 8 C ****************************************************** 120 COEF(1) = -731.0D0/725760.0D0 COEF(2) = 179.0D0/20160.0D0 COEF(3) = -5771.0D0/161280.0D0 COEF(4) = 8131.0D0/90720.0D0 COEF(5) = -13823.0D0/80640.0D0 COEF(6) = 12079.0D0/20160.0D0 COEF(7) = 247021.0D0/483840.0D0 COEF(8) = -275.0D0/3456.0D0 POEF(1) = -28549.D0/725760.D0 POEF(2) = 33473.D0/100800.D0 POEF(3) = -202261.D0/161280.D0 POEF(4) = 255581.D0/90720.D0 POEF(5) = -347233.D0/80640.D0 POEF(6) = 108497.D0/20160.D0 POEF(7) = -1557739.D0/806400.D0 POEF(8) = 36799.D0/17280.D0 PII = 8563.D0/14515200.D0 PIE = 416173.D0/14515200.D0 GO TO 160 C ****************************************************** C 7: ORDER = 9 C ****************************************************** 140 COEF(1) = 8563.0D0/12700800.0D0 COEF(2) = -35453.0D0/5443200.0D0 COEF(3) = 86791.0D0/3024000.0D0 COEF(4) = -2797.0D0/36288.0D0 COEF(5) = 157513.0D0/1088640.0D0 COEF(6) = -133643.0D0/604800.0D0 COEF(7) = 1147051.0D0/1814400.0D0 COEF(8) = 1758023.0D0/3528000.0D0 COEF(9) = -33953/453600.0D0 POEF(1) = 416173.D0/12700800.D0 POEF(2) = -1670723.D0/5443200.D0 POEF(3) = 3917401.D0/3024000.D0 POEF(4) = -118339.D0/36288.D0 POEF(5) = 5980183.D0/1088640.D0 POEF(6) = -4060853.D0/604800.D0 POEF(7) = 12677941.D0/1814400.D0 POEF(8) = -26739941.D0/10584000.D0 POEF(9) = 1070017.D0/453600.D0 PII = 27719.D0/65318400.D0 PIE = 324901.D0/13063680.D0 160 RETURN END SUBROUTINE DDCOMP(NDIM,N,A,NPIV,IND) C C--------+---------+---------+---------+---------+---------+---------+-- C COMMON AREA USED FOR STATISTICS GATHERING BY STDTST PACKAGE C .. Scalar Arguments .. INTEGER IND, N, NDIM C .. Array Arguments .. DOUBLE PRECISION A(NDIM,N) INTEGER NPIV(N) C .. Scalars in Common .. INTEGER NFCN, NJAC, NLUD C .. Local Scalars .. DOUBLE PRECISION AMULT, COLMAX, HOLD INTEGER I, IP1, IPIVOT, J, JPIVOT, K, NM1, NROW C .. Intrinsic Functions .. INTRINSIC DABS C .. Common blocks .. COMMON /STCOM6/NFCN, NJAC, NLUD C .. Executable Statements .. C--------+---------+---------+---------+---------+---------+---------+-- C NLUD = NLUD + 1 C IND = 0 C C *************** C * C * CHECK FOR A SYSTEM OF ONLY ONE UNKNOWN C * C *************** C IF (N.EQ.1) RETURN C C *************** C * C * INITIALIZE PIVOT VECTOR C * C *************** C DO 20 I = 1, N NPIV(I) = I 20 CONTINUE C C *************** C * C * MAIN LOOP FOR GAUSS ELIMINATION C * C *************** C NM1 = N - 1 DO 140 I = 1, NM1 C C *************** C * C * SEARCH COLUMN FOR LARGEST PIVOT,I.E., C * MAX |A(J,I)|, I <= J <= N. C * C *************** C COLMAX = 0.D0 DO 40 J = I, N HOLD = DABS(A(NPIV(J),I)) IF (HOLD.LE.COLMAX) GO TO 40 COLMAX = HOLD NROW = J 40 CONTINUE C C *************** C * C * TEST FOR SINGULARITY. THE MATRIX IS ASSUMED TO BE SINGULAR C * IF COLMAX (THE ABS. VALUE OF THE PIVOT) IS EQUIVALENT C * TO ZERO, I.E., C * 1.0 + COLMAX = 1.0 . C * IF THIS IS TRUE THEN THE ROUTINE PROCEEDS ON TO THE (I+1)-TH C * STAGE OF THE ELIMINATION. C * C *************** C IF (1.D0+COLMAX.NE.1.D0) GO TO 60 IND = -1 GO TO 140 C C *************** C * C * IF AN INTERCHANGE IS NECESSARY, ALTER THE PIVOT VECTOR NPIV. C * C *************** C 60 IPIVOT = NPIV(NROW) IF (NROW.EQ.I) GO TO 80 NPIV(NROW) = NPIV(I) NPIV(I) = IPIVOT C C *************** C * C * THE MULTIPLIERS FOR THE COMPUTATION OF THE REMAINING ROWS ARE C * DETERMINED AND ELIMINATION IS PERFORMED. THE VALUE OF EACH C * MULTIPLIER IS STORED IN THE POSITION OF THE ELIMINATED C * ELEMENT. C * C *************** C 80 IP1 = I + 1 DO 120 J = IP1, N JPIVOT = NPIV(J) AMULT = A(JPIVOT,I)/A(IPIVOT,I) A(JPIVOT,I) = AMULT DO 100 K = IP1, N A(JPIVOT,K) = A(JPIVOT,K) - AMULT*A(IPIVOT,K) 100 CONTINUE 120 CONTINUE 140 CONTINUE IF (1.D0+DABS(A(NPIV(N),N)).EQ.1.D0) IND = -1 RETURN END SUBROUTINE DSOLVE(NDIM,N,LU,NPIV,B,X) C .. Scalar Arguments .. INTEGER N, NDIM C .. Array Arguments .. DOUBLE PRECISION B(N), LU(NDIM,N), X(N) INTEGER NPIV(N) C .. Local Scalars .. DOUBLE PRECISION SUM INTEGER I, J, K, KM1, KP1, KPIVOT C .. Executable Statements .. C C *************** C * C * CHECK FOR SYSTEM OF ONLY ONE UNKNOWN C * C *************** C IF (N.GT.1) GO TO 20 X(1) = B(1)/LU(1,1) RETURN C C *************** C * C * FORWARD ELIMINATION ON B. THE RESULT IS PLACED IN X. C * C *************** C 20 KPIVOT = NPIV(1) X(1) = B(KPIVOT) DO 60 K = 2, N KPIVOT = NPIV(K) KM1 = K - 1 SUM = B(KPIVOT) DO 40 J = 1, KM1 SUM = SUM - LU(KPIVOT,J)*X(J) 40 CONTINUE X(K) = SUM 60 CONTINUE C C *************** C * C * BACK SUBSTITUTION BEGINS. C * C *************** C X(N) = X(N)/LU(KPIVOT,N) K = N DO 100 I = 2, N KP1 = K K = K - 1 KPIVOT = NPIV(K) SUM = X(K) DO 80 J = KP1, N SUM = SUM - LU(KPIVOT,J)*X(J) 80 CONTINUE X(K) = SUM/LU(KPIVOT,K) 100 CONTINUE RETURN END SUBROUTINE TRUE(FCN,PDERV,NDIM,N,X,Y,XEND,TOL,IND,C,INF,YP,W, * PDERIV,WORK) C C********+*********+*********+*********+*********+*********+*********+** C THIS IS THE ADDISON-ENRIGHT CODE 'SECDER', APART FROM: C AN EXTRA (12TH) COLUMN HAS BEEN ADDED TO THE 'WORK' ARRAY TO HOLD THE C LOCAL-ERROR-ESTIMATE VECTOR. C A MINOR ERROR TO DO WITH LANDING ON XEND HAS BEEN REMOVED. C THE SETTINGS OF MACHINE-DEPENDENT CONSTANTS IN C(6), C(7) HAVE BEEN C REPLACED BY CALLS TO THE 'CONST' ROUTINE. C********+*********+*********+*********+*********+*********+*********+** C .. Scalar Arguments .. REAL TOL, X, XEND INTEGER IND, N, NDIM C .. Array Arguments .. REAL C(20), PDERIV(400), W(400), WORK(NDIM,12), Y(N), * YP(NDIM,11) INTEGER INF(40) C .. Subroutine Arguments .. EXTERNAL FCN, PDERV C .. Local Scalars .. REAL CMAX, CNST, DBND, DELMAX, DELTA, DIFF, DMAX, * DPAST, DPRED, DSTRT, ERRCO, ERRLIM, ESTKM1, * ESTKP1, FMAX, HABS, HK, HKM1, HKP1, HMAG, HP, * HPAST, HSTART, HTMP, HTRIAL, PEKM1, PEKP1, PIE, * PII, PIKM1, PIKP1, R, RATE, RATIO, RREB, SUM, * TOLSTP, WEIGHT, XTRIAL, YDP, YKM1, YP3NRM INTEGER I, ICONV, IER, IJ, IOUT, ISING, J, JM1TN, JSHFT, * K, KM1, KOUNT, KP1, KTMP, M, NN, NP1, NQ, NQM1, * NQP1 LOGICAL CONVGD, RESTRT C .. Local Arrays .. REAL COEF(10), CTMP(10), POEF(10), PTMP(10) C .. External Functions .. REAL STEP REAL CONST EXTERNAL STEP, CONST C .. External Subroutines .. EXTERNAL COEFF, DDCOMP, DSOLVE, NEWSTP C .. Intrinsic Functions .. INTRINSIC ABS, ALOG10, AMAX1, AMIN1, SIGN, SQRT, IABS, MAX0, * MIN0 C .. Executable Statements .. IF (IND.LT.1 .OR. IND.GT.6) GO TO 2140 GO TO (20,20,200,1120,2020,2020) IND 20 IF (TOL.LE.0. .OR. N.GT.NDIM) GO TO 2140 IF (IND.EQ.2) GO TO 60 DO 40 I = 1, 5 INF(I) = 0 C(I) = 0. 40 CONTINUE GO TO 140 60 CONTINUE DO 80 I = 1, 5 INF(I) = IABS(INF(I)) C(I) = ABS(C(I)) 80 CONTINUE IF (INF(1).NE.4 .AND. INF(1).NE.5) GO TO 120 DO 100 I = 1, N C(I+20) = ABS(C(I+20)) 100 CONTINUE 120 CONTINUE 140 CONTINUE C(6) = CONST(1) C(7) = CONST(2) C(16) = 0. C(17) = X DO 160 I = 10, 15 INF(I) = 0 160 CONTINUE TOLSTP = TOL INF(7) = INF(2) IF (INF(2).GE.3 .AND. INF(2).LE.9) GO TO 180 INF(7) = 4 - .51*ALOG10(TOL) INF(7) = MAX0(INF(7),3) INF(7) = MIN0(INF(7),9) 180 CONTINUE INF(8) = 1 GO TO 220 200 IF (INF(9).NE.0 .AND. (X.NE.C(17) .OR. XEND.EQ.C(17))) GO TO 2140 INF(9) = 0 K = INF(6) - 2 CALL COEFF(K,POEF,COEF,PIE,PII) 220 CONTINUE 240 CONTINUE IF (INF(3).EQ.0 .OR. INF(13).LT.INF(3)) GO TO 260 IND = -1 RETURN 260 CONTINUE IF (IND.EQ.6) GO TO 560 IF (INF(1).NE.1) GO TO 300 C ABSOLUTE ERROR CONTROL - WEIGHTS ARE 1 DO 280 I = 1, N WORK(I,3) = 1. 280 CONTINUE GO TO 500 300 IF (INF(1).NE.2) GO TO 340 C RELATIVE ERROR CONTROL - WEIGHTS ARE 1/ABS(Y(I)) DO 320 I = 1, N WORK(I,3) = 1./ABS(Y(I)) 320 CONTINUE GO TO 500 340 IF (INF(1).NE.3) GO TO 380 C WEIGHTS ARE 1/MAX(C(1),ABS(Y(I))) DO 360 I = 1, N WORK(I,3) = 1./AMAX1(C(1),ABS(Y(I))) 360 CONTINUE GO TO 500 380 IF (INF(1).NE.4) GO TO 420 C WEIGHTS ARE 1/MAX(C(I+20),ABS(Y(I))) DO 400 I = 1, N WORK(I,3) = 1./AMAX1(C(I+20),ABS(Y(I))) 400 CONTINUE GO TO 500 420 IF (INF(1).NE.5) GO TO 460 C WEIGHTS ARE 1/C(I+20) DO 440 I = 1, N WORK(I,3) = 1./C(I+20) 440 CONTINUE GO TO 500 460 CONTINUE C DEFAULT CASE - WEIGHTS ARE 1/MAX(1,ABS(Y(I))) DO 480 I = 1, N WORK(I,3) = 1./AMAX1(1.,ABS(Y(I))) 480 CONTINUE 500 CONTINUE C C CALCULATE HMIN - USE DEFAULT UNLESS VALUE PRESCRIBED C C(9) = C(2) IF (C(2).NE.0.) GO TO 540 C FIRST - CALCULATE WEIGHTED Y NORM - C(8) C(8) = 0. DO 520 I = 1, N C(8) = AMAX1(C(8),Y(I)*WORK(I,3)) 520 CONTINUE C(9) = 10.*AMAX1(C(7),C(6)*AMAX1(C(8)/TOL,ABS(X))) 540 CONTINUE C CALCULATE SCALE - USE DEFAULT UNLESS VALUE PRESCRIBED C(10) = C(3) IF (C(3).EQ.0.) C(10) = 1. C C CALCULATE HMAX - CONSIDER 4 CASES (MAY MODIFY BECAUSE OF C SCALE WHAT IS A GOOD DEFAULT VALUE?) C IF (C(4).NE.0. .AND. C(3).NE.0.) C(11) = AMIN1(C(4),2./C(3)) IF (C(4).NE.0. .AND. C(3).EQ.0.) C(11) = C(4) IF (C(4).EQ.0. .AND. C(3).NE.0.) C(11) = 2./C(3) IF (C(4).EQ.0. .AND. C(3).EQ.0.) C(11) = ABS(XEND-C(17))/5. C C********ERROR RETURN (WITH IND .EQ. -2) IF HMIN > HMAX. C IF (C(9).LE.C(11)) GO TO 560 IND = -2 RETURN 560 CONTINUE C C CASES - INITIAL STEP, LAST STEP ACCEPTED, LAST STEP REJECTED. C IER = INF(8) GO TO (580,720,980,980) IER C C CASE 1 - INITIAL STEP (INF(8) .EQ. 1) C 580 CONTINUE CALL FCN(X,Y,YP(1,8)) CALL PDERV(X,Y,PDERIV) INF(13) = INF(13) + 1 INF(14) = INF(14) + 1 INF(6) = 3 K = 1 INF(17) = 0 INF(16) = 0 INF(20) = 1 INF(18) = -1 INF(19) = 1 CALL COEFF(K,POEF,COEF,PIE,PII) DO 620 I = 1, N YDP = 0. DO 600 J = 1, N YDP = YDP + PDERIV(I+(J-1)*N)*YP(J,8) 600 CONTINUE YP(I,9) = YDP 620 CONTINUE HSTART = C(5) IF (HSTART.EQ.0.) GO TO 640 C(12) = AMIN1(ABS(HSTART),C(11)) GO TO 700 640 CONTINUE HABS = SQRT(C(6)) HTMP = SIGN(HABS,XEND-X) DO 660 I = 1, N WORK(I,1) = Y(I) + HTMP*(YP(I,8)+.5*HTMP*YP(I,9)) 660 CONTINUE CALL FCN(X+HTMP,WORK(1,1),YP(1,10)) YP3NRM = C(7) DO 680 I = 1, N YDP = (WORK(I,1)-Y(I)-HTMP*(COEF(2)*YP(I,10)+COEF(1)*YP(I,8))) * /(HTMP*HTMP*COEF(3)) YP3NRM = AMAX1(YP3NRM,ABS(YP(I,9)-YDP)) 680 CONTINUE C(12) = AMIN1(C(11),.95*(6.*TOL*HABS/YP3NRM)**(1./3.)) 700 CONTINUE C(14) = SIGN(C(12),XEND-X) C(13) = X + C(14) GO TO 1220 720 CONTINUE IF (INF(16).LE.0 .OR. C(12).GE.C(11)) GO TO 920 HABS = ABS(C(14)) IF (INF(16).GE.K+1) GO TO 740 C(12) = STEP(C(15),C(12),TOL,INF(6)) HK = C(12) GO TO 900 740 CONTINUE HPAST = C(16) KM1 = K - 1 NQM1 = INF(6) - 1 KP1 = K + 1 NQP1 = INF(6) + 1 HKM1 = 0. IF (K.EQ.1) GO TO 800 CALL COEFF(KM1,PTMP,CTMP,PEKM1,PIKM1) ESTKM1 = 0. JSHFT = 8 - K DO 780 I = 1, N SUM = C(14)*PTMP(NQM1)*YP(I,9) DO 760 J = 1, K SUM = SUM + PTMP(J)*YP(I,J+JSHFT) 760 CONTINUE YKM1 = C(14)*SUM + WORK(I,4) ESTKM1 = AMAX1(ESTKM1,ABS(YKM1-Y(I))*WORK(I,9)) 780 CONTINUE ESTKM1 = PIKM1*ESTKM1/PEKM1 HKM1 = STEP(ESTKM1,C(12),TOL,NQM1) 800 CONTINUE HKP1 = 0. IF (INF(6).EQ.INF(7)) GO TO 840 CALL COEFF(KP1,PTMP,CTMP,PEKP1,PIKP1) HP = (C(14)/HPAST)**NQP1 ESTKP1 = 0. DO 820 I = 1, N ESTKP1 = AMAX1(ESTKP1,ABS(WORK(I,7)-WORK(I,8)*HP)*WORK(I,9)) 820 CONTINUE ESTKP1 = PIKP1*ESTKP1/(PIE-PII) HKP1 = STEP(ESTKP1,C(12),TOL,NQP1) 840 CONTINUE IF (HKP1.GT.HKM1) GO TO 860 HTMP = HKM1 KTMP = KM1 GO TO 880 860 CONTINUE HTMP = HKP1 KTMP = KP1 880 CONTINUE HK = STEP(C(15),C(12),TOL,INF(6)) C(12) = HK IF (HK.GE.AMIN1(HTMP,C(11)) .OR. HTMP.LT.1.3*HABS .AND. .NOT. * (HK.LE.HABS .AND. HTMP.GT.1.1*HABS)) GO TO 900 C(12) = HTMP K = KTMP INF(6) = K + 2 CALL COEFF(K,POEF,COEF,PIE,PII) INF(16) = 0 INF(20) = 1 900 CONTINUE C(12) = AMIN1(C(12),C(11)) IF (C(12).EQ.HK .AND. C(12).LE.1.3*HABS) C(12) = HABS 920 CONTINUE JSHFT = 8 - K DO 960 I = 1, N DO 940 J = JSHFT, 7 YP(I,J) = YP(I,J+1) 940 CONTINUE YP(I,8) = YP(I,10) YP(I,9) = YP(I,11) 960 CONTINUE C(16) = C(14) GO TO 1100 980 CONTINUE IF (INF(8).EQ.4) GO TO 1000 INF(8) = 4 INF(16) = -1 C(12) = C(12)*.5 IF (INF(6).EQ.3) GO TO 1060 IF (INF(12).GE.4) GO TO 1040 GO TO 1020 1000 CONTINUE C(12) = STEP(C(15),C(12),TOL,INF(6)-1) IF (INF(6).EQ.3) GO TO 1060 IF (INF(12).GE.4) GO TO 1040 INF(18) = -1*INF(18) IF (INF(18).EQ.-1) GO TO 1080 1020 CONTINUE INF(16) = MIN0(INF(16),0) INF(6) = INF(6) - 1 K = K - 1 CALL COEFF(K,POEF,COEF,PIE,PII) GO TO 1080 1040 CONTINUE INF(6) = 3 K = 1 CALL COEFF(K,POEF,COEF,PIE,PII) 1060 CONTINUE INF(17) = INF(17) + 1 IF (INF(17).GE.2) INF(19) = 1 1080 CONTINUE 1100 CONTINUE C>>>>>>>>INTERRUPT NO. 1 (IND .EQ. 4) IF REQUESTED IF (INF(4).EQ.0) GO TO 1120 IND = 4 RETURN C C RESUME HERE ON RE-ENTRY WITH IND .EQ. 4 - ...RE-ENTRY........... C 1120 CONTINUE C C OBTAIN FINAL HMAG, XTRIAL AND HTRIAL C DIFF = XEND - X K = INF(6) - 2 IF (IND.EQ.4) CALL COEFF(K,POEF,COEF,PIE,PII) IF (C(12).GE.ABS(DIFF)) GO TO 1140 C DO NOT STEP MORE THAN HALF WAY TO XEND C(12) = AMIN1(C(12),.5*ABS(DIFF)) IF (C(4).EQ.0.) C(11) = C(12) GO TO 1160 1140 CONTINUE C HIT XEND EXACTLY C(12) = ABS(DIFF) 1160 CONTINUE C CALCULATE HTRIAL HTMP = C(14) C(14) = SIGN(C(12),DIFF) C(13) = X + C(14) IF (HTMP.NE.C(14)) GO TO 1180 GO TO 1200 1180 CONTINUE C C IF HTRIAL IS BEING CHANGED RESET UPDATE, INF(20), AND C CALL NEWSTP TO OBTAIN THE APPROXIMATION TO F AT C K EQUALLY SPACED POINTS C INF(20) = 1 IF (INF(19).EQ.0) CALL NEWSTP(NDIM,N,K,X,HTMP,C(14),YP) 1200 CONTINUE 1220 CONTINUE 1240 CONTINUE NQ = INF(6) RREB = C(6) HMAG = C(12) XTRIAL = C(13) HTRIAL = C(14) HPAST = C(16) IF (INF(19).EQ.1) GO TO 1260 GO TO 1300 1260 CONTINUE DO 1280 I = 1, N WORK(I,2) = Y(I) + HTRIAL*(YP(I,8)+HTRIAL*YP(I,9)*.5) WORK(I,1) = WORK(I,2) IF (INF(10).EQ.0) GO TO 1280 WORK(I,1) = Y(I) + (Y(I)-WORK(I,4))*HTRIAL/HPAST YP(I,1) = WORK(I,1) 1280 CONTINUE GO TO 1400 1300 CONTINUE RATIO = HTRIAL/HPAST JSHFT = 7 - K KP1 = K + 1 DO 1340 I = 1, N SUM = HTRIAL*POEF(NQ)*YP(I,9) DO 1320 J = 1, KP1 SUM = SUM + POEF(J)*YP(I,JSHFT+J) 1320 CONTINUE WORK(I,2) = HTRIAL*SUM + Y(I) WORK(I,1) = WORK(I,2) IF (NQ.GT.3) GO TO 1340 WORK(I,1) = Y(I) + (Y(I)-WORK(I,4))*RATIO YP(I,1) = WORK(I,1) 1340 CONTINUE IF (INF(8).NE.2) GO TO 1380 DO 1360 I = 1, N WORK(I,8) = WORK(I,7) 1360 CONTINUE 1380 CONTINUE 1400 CONTINUE NN = N*N NP1 = N + 1 CALL FCN(XTRIAL,WORK(1,1),YP(1,10)) INF(13) = INF(13) + 1 CALL PDERV(XTRIAL,WORK(1,1),PDERIV) INF(14) = INF(14) + 1 ERRCO = PII/(PIE-PII) DMAX = 1. DPRED = 1.E-16 JSHFT = 8 - K DO 1440 I = 1, N DPRED = AMAX1(DPRED,ABS(YP(I,10)-YP(I,8))/AMAX1(1.,ABS(YP(I,8)) * )) WORK(I,6) = YP(I,10) CNST = 0. DO 1420 J = 1, K CNST = CNST + COEF(J)*YP(I,JSHFT+J) 1420 CONTINUE WORK(I,5) = HTRIAL*CNST + Y(I) 1440 CONTINUE DPRED = HMAG*DPRED DPAST = DPRED DSTRT = DPRED ICONV = 1 IF (INF(8).EQ.2 .AND. INF(20).EQ.0) ICONV = 2 RESTRT = .FALSE. ERRLIM = .25*(1.9**NQ)*TOL KOUNT = 1 C C ITERATE UNTIL CONVERGENCE, DIVERGENCE DETECTED, OR KOUNT .GE. 5 C 1460 IF (ICONV.EQ.1) GO TO 1480 GO TO 1600 C C IF ICONV = 1 THEN RE-EVALUATE W, THE ITERATION MATRIX. C OTHERWISE, PROCEED TO THE NEXT STAGE C 1480 CONTINUE IF (KOUNT.EQ.1) GO TO 1500 CALL PDERV(XTRIAL,WORK(1,1),PDERIV) INF(14) = INF(14) + 1 1500 CONTINUE RESTRT = .TRUE. R = -HTRIAL*HTRIAL*COEF(NQ) HTMP = -HTRIAL*COEF(K+1) DO 1560 I = 1, N DO 1540 J = 1, N JM1TN = (J-1)*N IJ = I + JM1TN W(IJ) = PDERIV(IJ)*HTMP IF (I.EQ.J) W(IJ) = W(IJ) + 1. SUM = 0. DO 1520 M = 1, N SUM = SUM + PDERIV(I+(M-1)*N)*PDERIV(M+JM1TN) 1520 CONTINUE SUM = R*SUM IF (I.EQ.J .AND. SUM.EQ.SUM+1.) SUM = SUM*(1.-10.*RREB) W(IJ) = W(IJ) + SUM 1540 CONTINUE 1560 CONTINUE INF(15) = INF(15) + 1 CALL DDCOMP(N,N,W,INF(21),ISING) IF (ISING.EQ.0) GO TO 1580 C MATRIX APPEARS SINGULAR, SET INF(8) TO 3 AND BRANCH TO C THE END OF YCALC. INF(8) = 3 GO TO 1980 1580 CONTINUE 1600 CONTINUE C C CALCULATE THE RIGHT HAND SIDE OF THE SYSTEM, WORK(*,10) C THEN BACK-SUBSTITUTE TO SOLVE FOR THE CORRECTION C VECTOR, WORK(*,11). C DO 1640 I = 1, N R = 0. DO 1620 J = 1, N R = R + PDERIV(I+(J-1)*N)*YP(J,10) 1620 CONTINUE YP(I,11) = R WORK(I,10) = -WORK(I,1) + HTRIAL*COEF(K+1)*YP(I,10) + * HTRIAL*HTRIAL*COEF(NQ)*R + WORK(I,5) 1640 CONTINUE CALL DSOLVE(N,N,W,INF(21),WORK(1,10),WORK(1,11)) DELMAX = 0. CMAX = 0. DO 1660 I = 1, N DELTA = WORK(I,11) WEIGHT = WORK(I,3) WORK(I,1) = WORK(I,1) + DELTA WORK(I,7) = WORK(I,2) - WORK(I,1) WORK(I,12) = ERRCO*WORK(I,7) DELMAX = AMAX1(DELMAX,ABS(DELTA)*WEIGHT) CMAX = AMAX1(CMAX,ABS(WORK(I,7))*WEIGHT) WORK(I,10) = YP(I,10) 1660 CONTINUE C(15) = ERRCO*CMAX CONVGD = .FALSE. DIFF = AMAX1(1.E-2*TOL,RREB*C(8)) IF (DELMAX.LE.AMAX1(DIFF,RREB)) CONVGD = .TRUE. DBND = AMIN1(RREB,.1*TOL) IF ((DMAX.LE.DBND .AND. CONVGD) .OR. * (KOUNT.EQ.2 .AND. DELMAX.LE.DBND)) GO TO 1700 C C IF IT APPEARS THAT THE SYSTEM IS LINEAR, DON'T DO THE C LAST FUNCTION EVALUATION. C INF(13) = INF(13) + 1 CALL FCN(XTRIAL,WORK(1,1),YP(1,10)) FMAX = 0. DO 1680 I = 1, N FMAX = AMAX1(FMAX,ABS(WORK(I,10)-YP(I,10))/AMAX1(ABS(WORK(I,10) * ),1.)) 1680 CONTINUE DMAX = AMAX1(HMAG*FMAX,DBND) 1700 CONTINUE C C CHECK FOR CONVERGENCE (DMAX <=MIN(1.D-3,TOL) AND C DELMAX <= 1.D-2*TOL) C IF ((DMAX.LE.AMIN1(TOL,1.E-3) .AND. CONVGD) * .OR. (KOUNT.EQ.2 .AND. DELMAX.LE.DBND)) GO TO 1720 GO TO 1760 1720 CONTINUE DO 1740 I = 1, N YP(I,11) = (WORK(I,1)-WORK(I,5)-COEF(K+1)*HTRIAL*YP(I,10)) * /(HTRIAL*HTRIAL*COEF(NQ)) 1740 CONTINUE GO TO 1980 1760 CONTINUE C C IF CONVERGENCE CRITERIA HAVE NOT BEEN SATISFIED, PREPARE FOR C THE NEXT ITERATION. C CHECK TO SEE THAT ANOTHER ITERATION IS ALLOWED (KOUNT < 5) C IF (KOUNT.GE.5) GO TO 1780 GO TO 1800 1780 INF(8) = 3 GO TO 1980 1800 CONTINUE KOUNT = KOUNT + 1 IF (C(15).GT.TOL) GO TO 1820 GO TO 1900 1820 CONTINUE IF (RESTRT) GO TO 1840 GO TO 1860 1840 CONTINUE IF (C(15).GT.ERRLIM) INF(8) = 3 GO TO 1980 1860 CONTINUE ICONV = 1 DO 1880 I = 1, N WORK(I,1) = WORK(I,2) IF (NQ.EQ.3) WORK(I,1) = YP(I,1) YP(I,10) = WORK(I,6) 1880 CONTINUE DPRED = DSTRT DPAST = DSTRT GO TO 1460 1900 CONTINUE C C ANOTHER ITERATION WILL BE DONE, CHECK TO SEE IF AN UPDATE OF C W IS NECESSARY. C IF ((DMAX.LE.DPRED .OR. (KOUNT.EQ.2 .AND. RESTRT)) .OR. CONVGD) * GO TO 1920 GO TO 1940 1920 ICONV = 2 GO TO 1960 1940 IF (DMAX.GT.(N/6)*DPRED) ICONV = 1 1960 CONTINUE C ALLOW AT MOST 2 UPDATES PER TRIAL STEP. IF (ICONV.EQ.1) INF(20) = INF(20) + 1 IF (INF(20).GT.2) ICONV = 2 RATE = AMAX1(.2,AMIN1(.5,DMAX/DPAST)) DPAST = DMAX IF (KOUNT.EQ.2 .OR. DPRED.GT.RATE*DMAX) * DPRED = AMAX1(TOL,RATE*DMAX) GO TO 1460 1980 CONTINUE C C SET INF(8) AND IND TO THEIR CORRECT VALUES. C IF (INF(8).EQ.3) GO TO 2000 INF(8) = 2 IF (C(15).GT.TOL) INF(8) = 4 2000 CONTINUE IND = 5 + INF(8)/3 C>>>>>>>>INTERRUPT NO. 2 (IND .EQ. 5) IF REQUESTED IF (INF(5).EQ.0) GO TO 2020 RETURN C C RESUME HERE ON RE-ENTRY WITH IND .EQ. 5 - ...RE-ENTRY........... C 2020 CONTINUE K = INF(6) - 2 IF (INF(5).NE.0) CALL COEFF(K,POEF,COEF,PIE,PII) IF (INF(8).NE.2 .OR. IND.EQ.6) GO TO 2080 C C LAST STEP IS ACCEPTED, RESET STATUS VARIABLES TO INDICATE C THIS, UPDATE X AND Y AND FINALLY SEE IF X = XEND. C INF(8) = 2 X = C(13) DO 2040 I = 1, N WORK(I,9) = WORK(I,3) WORK(I,4) = Y(I) Y(I) = WORK(I,1) 2040 CONTINUE INF(10) = INF(10) + 1 INF(12) = 0 INF(16) = INF(16) + 1 INF(17) = 0 INF(18) = 1 INF(19) = 0 INF(20) = 0 IF (XEND+ABS(XEND-X)*.1.NE.XEND) GO TO 2060 IND = 3 C(17) = XEND X = XEND INF(9) = 1 RETURN 2060 CONTINUE GO TO 2120 C C ELSE STEP IS REJECTED C ADD 1 TO COUNTER FOR NUMBER OF FAILURES C ADD 1 TO NUMBER OF SUCCESSIVE FAILURES C 2080 CONTINUE INF(11) = INF(11) + 1 INF(12) = INF(12) + 1 IF (ABS(C(14)).GT.C(9)) GO TO 2100 C C*************** ERROR RETURN IF |HTRIAL| <= HMIN C IND = -3 RETURN 2100 CONTINUE 2120 CONTINUE GO TO 240 C C*********************************************************************** C*********************************************************************** C C BEGIN ABORT ACTION: 2140 CONTINUE IOUT = CONST(3) WRITE (IOUT,FMT=99999) IND, TOL, X, N, C(9), XEND, NDIM, C(11), * C(17), INF(10), INF(12), INF(13), (Y(J),J=1,N) STOP C 99999 FORMAT (/// * '0COMPUTATION STOPPED IN SECDER WITH THE FOLLOWING VALUES', * /'0IND =',I4,5X,'TOL =',1P,E13.6,5X,'X =',1P, * E22.15,/' N =',I4,5X,'HMIN =',1P,E13.6,5X,'XEND =', * 1P,E22.15,/' NDIM=',I4,5X,'HMAX =',1P,E13.6,5X, * 'PREV XEND =',1P,E22.15,/'0',14X, * 'NO OF SUCCESSFUL STEPS =',I8,/15X, * 'NO OF SUCCESSIVE FAILURES =',I8,/15X, * 'NO OF FUNCTION EVALS =',I8, * /'0THE COMPONENTS OF Y ARE',//(' ',1P,E24.15)) END REAL FUNCTION STEP(ERR,HMAG,TOL,NQ) C .. Scalar Arguments .. REAL ERR, HMAG, TOL INTEGER NQ C .. Local Scalars .. REAL STPMAX C .. Executable Statements .. STPMAX = 1.E1 IF (NQ.GE.5) STPMAX = 2. IF (TOL.GE.(STPMAX/.95)**(NQ+1)*4.*ERR) GO TO 20 GO TO 40 20 STEP = STPMAX*HMAG RETURN 40 STEP = .95*HMAG*(TOL/(4.*ERR))**(1./(NQ+1)) RETURN END SUBROUTINE NEWSTP(NDIM,N,K,X,H,HNEW,YP) C .. Scalar Arguments .. REAL H, HNEW, X INTEGER K, N, NDIM C .. Array Arguments .. REAL YP(NDIM,11) C .. Local Scalars .. REAL FCT, RATIO, SP1, TMP, VALUE INTEGER I, IMAX, J, KOUNT, KP1, L, LIM, LM1, M, NQ C .. Local Arrays .. REAL C(9), DIV(8), FACT(7,7), FKP1(7), S(7) C .. Intrinsic Functions .. INTRINSIC REAL C .. Executable Statements .. KP1 = K + 1 NQ = K + 2 DIV(1) = 1. DO 20 I = 2, KP1 DIV(I) = 1./REAL(I) 20 CONTINUE RATIO = HNEW/H C CALCULATE THE COEFFICIENTS FOR THE BACKWARD DIFFERENCES C DO 60 M = 1, K S(M) = M*RATIO SP1 = S(M) + 1. FCT = 1. DO 40 J = 1, K FCT = -FCT*(SP1-J)*DIV(J) FACT(M,J) = FCT 40 CONTINUE FKP1(M) = -FCT*(S(M)-K) 60 CONTINUE DO 200 KOUNT = 1, N C C CALCULATE THE BACKWARD DIFFERENCE FORM OF THE OLD POINT C SET, STORING THE RESULTS IN C. C LIM = 8 - K LM1 = LIM - 1 DO 80 I = LIM, 9 C(I-LM1) = YP(KOUNT,I) 80 CONTINUE DO 120 L = 1, K IMAX = KP1 - L DO 100 I = 1, IMAX C(I) = C(I+1) - C(I) 100 CONTINUE 120 CONTINUE TMP = H*C(NQ) DO 140 I = 1, K TMP = TMP - DIV(I)*C(KP1-I) 140 CONTINUE C C EVALUATE THE INTERPOLATING POLYNOMIAL AT THE NEW POINT SET C DO 180 M = 1, K VALUE = C(KP1) + FKP1(M)*TMP DO 160 J = 1, K VALUE = VALUE + FACT(M,J)*C(KP1-J) 160 CONTINUE YP(KOUNT,8-M) = VALUE 180 CONTINUE 200 CONTINUE RETURN END SUBROUTINE COEFF(K,POEF,COEF,PIE,PII) C .. Scalar Arguments .. REAL PIE, PII INTEGER K C .. Array Arguments .. REAL COEF(9), POEF(9) C .. Executable Statements .. GO TO (20,40,60,80,100,120,140) K C ****************************************************** C 1: ORDER = 3 C ****************************************************** 20 COEF(1) = 1./3. COEF(2) = 2./3. COEF(3) = -1./6. POEF(1) = COEF(1) POEF(2) = COEF(2) POEF(3) = 5./6. PII = 1./72. PIE = 7./72. GO TO 160 C ****************************************************** C 2: ORDER = 4 C ****************************************************** 40 COEF(1) = -1.0/48.0 COEF(2) = 5.0/12.0 COEF(3) = 29.0/48.0 COEF(4) = -1.0/8.0 POEF(1) = -7./48. POEF(2) = 11./12. POEF(3) = 11./48. POEF(4) = 9./8. PII = 7./1440. PIE = 97./1440. GO TO 160 C ****************************************************** C 3: ORDER = 5 C ****************************************************** 60 COEF(1) = 7.0/1080.0 COEF(2) = -1.0/20.0 COEF(3) = 19.0/40.0 COEF(4) = 307.0/540.0 COEF(5) = -19.0/180.0 POEF(1) = 97./1080. POEF(2) = -11./20. POEF(3) = 69./40. POEF(4) = -143./540. POEF(5) = 251./180. PII = 17./7200. PIE = 367./7200. GO TO 160 C ****************************************************** C 4: ORDER = 6 C ****************************************************** 80 COEF(1) = -17.0/5760.0 COEF(2) = 1.0/45.0 COEF(3) = -41.0/480.0 COEF(4) = 47.0/90.0 COEF(5) = 3133.0/5760.0 COEF(6) = -3.0/32.0 POEF(1) = -367./5760. POEF(2) = 58./135. POEF(3) = -631./480. POEF(4) = 247./90. POEF(5) = -13751./17280. POEF(6) = 475./288. PII = 41./30240. PIE = 1231./30240. GO TO 160 C ****************************************************** C 5: ORDER = 7 C ****************************************************** 100 COEF(1) = 41.0/25200.0 COEF(2) = -529.0/40320.0 COEF(3) = 373.0/7560.0 COEF(4) = -1271.0/10080.0 COEF(5) = 2837.0/5040.0 COEF(6) = 317731.0/604800.0 COEF(7) = -863.0/10080.0 POEF(1) = 1231./25200. POEF(2) = -14879./40320. POEF(3) = 9403./7560. POEF(4) = -25561./10080. POEF(5) = 19987./5040. POEF(6) = -818579./604800. POEF(7) = 19087./10080. PII = 731./846720. PIE = 28549./846720. GO TO 160 C ****************************************************** C 6: ORDER = 8 C ****************************************************** 120 COEF(1) = -731.0/725760.0 COEF(2) = 179.0/20160.0 COEF(3) = -5771.0/161280.0 COEF(4) = 8131.0/90720.0 COEF(5) = -13823.0/80640.0 COEF(6) = 12079.0/20160.0 COEF(7) = 247021.0/483840.0 COEF(8) = -275.0/3456.0 POEF(1) = -28549./725760. POEF(2) = 33473./100800. POEF(3) = -202261./161280. POEF(4) = 255581./90720. POEF(5) = -347233./80640. POEF(6) = 108497./20160. POEF(7) = -1557739./806400. POEF(8) = 36799./17280. PII = 8563./14515200. PIE = 416173./14515200. GO TO 160 C ****************************************************** C 7: ORDER = 9 C ****************************************************** 140 COEF(1) = 8563.0/12700800.0 COEF(2) = -35453.0/5443200.0 COEF(3) = 86791.0/3024000.0 COEF(4) = -2797.0/36288.0 COEF(5) = 157513.0/1088640.0 COEF(6) = -133643.0/604800.0 COEF(7) = 1147051.0/1814400.0 COEF(8) = 1758023.0/3528000.0 COEF(9) = -33953/453600.0 POEF(1) = 416173./12700800. POEF(2) = -1670723./5443200. POEF(3) = 3917401./3024000. POEF(4) = -118339./36288. POEF(5) = 5980183./1088640. POEF(6) = -4060853./604800. POEF(7) = 12677941./1814400. POEF(8) = -26739941./10584000. POEF(9) = 1070017./453600. PII = 27719./65318400. PIE = 324901./13063680. 160 RETURN END SUBROUTINE DDCOMP(NDIM,N,A,NPIV,IND) C C--------+---------+---------+---------+---------+---------+---------+-- C COMMON AREA USED FOR STATISTICS GATHERING BY STDTST PACKAGE C .. Scalar Arguments .. INTEGER IND, N, NDIM C .. Array Arguments .. REAL A(NDIM,N) INTEGER NPIV(N) C .. Scalars in Common .. INTEGER NFCN, NJAC, NLUD C .. Local Scalars .. REAL AMULT, COLMAX, HOLD INTEGER I, IP1, IPIVOT, J, JPIVOT, K, NM1, NROW C .. Intrinsic Functions .. INTRINSIC ABS C .. Common blocks .. COMMON /STCOM6/NFCN, NJAC, NLUD C .. Executable Statements .. C--------+---------+---------+---------+---------+---------+---------+-- C NLUD = NLUD + 1 C IND = 0 C C *************** C * C * CHECK FOR A SYSTEM OF ONLY ONE UNKNOWN C * C *************** C IF (N.EQ.1) RETURN C C *************** C * C * INITIALIZE PIVOT VECTOR C * C *************** C DO 20 I = 1, N NPIV(I) = I 20 CONTINUE C C *************** C * C * MAIN LOOP FOR GAUSS ELIMINATION C * C *************** C NM1 = N - 1 DO 140 I = 1, NM1 C C *************** C * C * SEARCH COLUMN FOR LARGEST PIVOT,I.E., C * MAX |A(J,I)|, I <= J <= N. C * C *************** C COLMAX = 0. DO 40 J = I, N HOLD = ABS(A(NPIV(J),I)) IF (HOLD.LE.COLMAX) GO TO 40 COLMAX = HOLD NROW = J 40 CONTINUE C C *************** C * C * TEST FOR SINGULARITY. THE MATRIX IS ASSUMED TO BE SINGULAR C * IF COLMAX (THE ABS. VALUE OF THE PIVOT) IS EQUIVALENT C * TO ZERO, I.E., C * 1.0 + COLMAX = 1.0 . C * IF THIS IS TRUE THEN THE ROUTINE PROCEEDS ON TO THE (I+1)-TH C * STAGE OF THE ELIMINATION. C * C *************** C IF (1.+COLMAX.NE.1.) GO TO 60 IND = -1 GO TO 140 C C *************** C * C * IF AN INTERCHANGE IS NECESSARY, ALTER THE PIVOT VECTOR NPIV. C * C *************** C 60 IPIVOT = NPIV(NROW) IF (NROW.EQ.I) GO TO 80 NPIV(NROW) = NPIV(I) NPIV(I) = IPIVOT C C *************** C * C * THE MULTIPLIERS FOR THE COMPUTATION OF THE REMAINING ROWS ARE C * DETERMINED AND ELIMINATION IS PERFORMED. THE VALUE OF EACH C * MULTIPLIER IS STORED IN THE POSITION OF THE ELIMINATED C * ELEMENT. C * C *************** C 80 IP1 = I + 1 DO 120 J = IP1, N JPIVOT = NPIV(J) AMULT = A(JPIVOT,I)/A(IPIVOT,I) A(JPIVOT,I) = AMULT DO 100 K = IP1, N A(JPIVOT,K) = A(JPIVOT,K) - AMULT*A(IPIVOT,K) 100 CONTINUE 120 CONTINUE 140 CONTINUE IF (1.+ABS(A(NPIV(N),N)).EQ.1.) IND = -1 RETURN END SUBROUTINE DSOLVE(NDIM,N,LU,NPIV,B,X) C .. Scalar Arguments .. INTEGER N, NDIM C .. Array Arguments .. REAL B(N), LU(NDIM,N), X(N) INTEGER NPIV(N) C .. Local Scalars .. REAL SUM INTEGER I, J, K, KM1, KP1, KPIVOT C .. Executable Statements .. C C *************** C * C * CHECK FOR SYSTEM OF ONLY ONE UNKNOWN C * C *************** C IF (N.GT.1) GO TO 20 X(1) = B(1)/LU(1,1) RETURN C C *************** C * C * FORWARD ELIMINATION ON B. THE RESULT IS PLACED IN X. C * C *************** C 20 KPIVOT = NPIV(1) X(1) = B(KPIVOT) DO 60 K = 2, N KPIVOT = NPIV(K) KM1 = K - 1 SUM = B(KPIVOT) DO 40 J = 1, KM1 SUM = SUM - LU(KPIVOT,J)*X(J) 40 CONTINUE X(K) = SUM 60 CONTINUE C C *************** C * C * BACK SUBSTITUTION BEGINS. C * C *************** C X(N) = X(N)/LU(KPIVOT,N) K = N DO 100 I = 2, N KP1 = K K = K - 1 KPIVOT = NPIV(K) SUM = X(K) DO 80 J = KP1, N SUM = SUM - LU(KPIVOT,J)*X(J) 80 CONTINUE X(K) = SUM/LU(KPIVOT,K) 100 CONTINUE RETURN END SUBROUTINE IVALU(N,XSTART,XEND,HBEGIN,HMAX,Y,FCNTIM,JACTIM,LUDTIM, * W,IWT,ID) C C**************************************************************** C C ROUTINE TO PROVIDE THE INITIAL VALUES REQUIRED TO SPECIFY C THE MATHEMATICAL PROBLEM AS WELL AS VARIOUS PROBLEM C PARAMETERS REQUIRED BY THE TESTING PACKAGE. THE APPROPRIATE C SCALING VECTOR IS ALSO INITIALISED IN CASE THIS OPTION IS C SELECTED. C C PARAMETERS (OUTPUT) C N - DIMENSION OF THE PROBLEM C XSTART - INITIAL VALUE OF THE INDEPENDENT VARIABLE C XEND - FINAL VALUE OF THE INDEPENDENT VARIABLE C HBEGIN - APPROPRIATE STARTING STEPSIZE C Y - VECTOR OF INITIAL CONDITIONS FOR THE DEPENDENT C VARIABLES C FCNTIM - AVERAGE COMPUTER TIME REQUIRED FOR A DERIVATIVE C EVALUATION C JACTIM - AVERAGE COMPUTER TIME REQUIRED FOR A JACOBIAN C EVALUATION C LUDTIM - AVERAGE COMPUTER TIME REQUIRED FOR AN L/U C FACTORIZATION C WT - VECTOR OF WEIGHTS USED TO SCALE THE PROBLEM IF C THIS OPTION IS SELECTED. C C PARAMETER (INPUT) C IWT - FLAG TO INDICATE IF SCALED OPTION IS SELESTED C ID - FLAG IDENTIFYING WHICH EQUATION IS BEING SOLVED C C***************************************************************** C .. Scalar Arguments .. DOUBLE PRECISION HBEGIN, HMAX, XEND, XSTART REAL FCNTIM, JACTIM, LUDTIM INTEGER ID, IWT, N C .. Array Arguments .. DOUBLE PRECISION W(20), Y(20) C .. Local Scalars .. DOUBLE PRECISION XS INTEGER I, IID, IOUT, ITMP C .. External Functions .. REAL CONST EXTERNAL CONST C .. Intrinsic Functions .. INTRINSIC MOD C .. Data statements .. DATA XS/0.D0/ C .. Executable Statements .. XSTART = XS IID = MOD(ID,10) GO TO (40,80,120,160,20,20,20,20,20, * 20,200,220,220,220,220,20,20,20, * 20,20,360,400,400,400,400,20,20, * 20,20,20,540,580,600,640,660,680, * 20,20,20,20,700,740,760,780,800, * 20,20,20,20,20,840,860,880,900, * 920) ID 20 IOUT = CONST(3) WRITE (IOUT,FMT=99999) ID STOP C C C PROBLEM CLASS A - LINEAR WITH REAL EIGENVALUES C C 40 CONTINUE CP PROBLEM A1 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 4 W(1) = 0.100D+01 W(2) = 0.100D+01 W(3) = 0.100D+01 W(4) = 0.100D+01 XEND = 20.D0 HBEGIN = 1.D-2 HMAX = 20.D0 DO 60 I = 1, N Y(I) = 1.D0 60 CONTINUE GO TO 940 C 80 CONTINUE CP PROBLEM A2 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 9 W(1) = 0.100D+00 W(2) = 0.200D+00 W(3) = 0.300D+00 W(4) = 0.400D+00 W(5) = 0.500D+00 W(6) = 0.600D+00 W(7) = 0.700D+00 W(8) = 0.800D+00 W(9) = 0.900D+00 XEND = 120.D0 HBEGIN = 5.D-4 HMAX = 120.D0 DO 100 I = 1, N Y(I) = 0.D0 100 CONTINUE GO TO 940 C 120 CONTINUE CP PROBLEM A3 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 4 W(1) = 0.100D+01 W(2) = 0.100D+01 W(3) = 0.782D+01 W(4) = 0.100D+01 HBEGIN = 1.D-5 XEND = 20.D0 HMAX = 20.D0 DO 140 I = 1, N Y(I) = 1.D0 140 CONTINUE GO TO 940 C 160 CONTINUE CP PROBLEM A4 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 10 W(1) = 0.100D+01 W(2) = 0.100D+01 W(3) = 0.100D+01 W(4) = 0.100D+01 W(5) = 0.100D+01 W(6) = 0.100D+01 W(7) = 0.100D+01 W(8) = 0.100D+01 W(9) = 0.100D+01 W(10) = 0.100D+01 XEND = 1.D0 HBEGIN = 1.D-5 HMAX = 1.D0 DO 180 I = 1, N Y(I) = 1.D0 180 CONTINUE GO TO 940 C C PROBLEM CLASS B - LINEAR WITH NON-REAL EIGENVALUES C C 200 CONTINUE CP PROBLEM B1 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 4 W(1) = 0.100D+01 W(2) = 0.859D+01 W(3) = 0.100D+01 W(4) = 0.322D+02 XEND = 20.D0 HBEGIN = 7.D-3 HMAX = 20.D0 Y(1) = 1.D0 Y(2) = 0.D0 Y(3) = 1.D0 Y(4) = 0.D0 GO TO 940 C 220 CONTINUE CP PROBLEM B2, B3, B4, B5 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 6 ITMP = IID - 1 GO TO (240,260,280,300) ITMP 240 CONTINUE W(1) = 0.100D+01 W(2) = 0.100D+01 W(3) = 0.100D+01 W(4) = 0.100D+01 W(5) = 0.100D+01 W(6) = 0.100D+01 GO TO 320 260 CONTINUE W(1) = 0.100D+01 W(2) = 0.100D+01 W(3) = 0.100D+01 W(4) = 0.100D+01 W(5) = 0.100D+01 W(6) = 0.100D+01 GO TO 320 280 CONTINUE W(1) = 0.112D+01 W(2) = 0.100D+01 W(3) = 0.100D+01 W(4) = 0.100D+01 W(5) = 0.100D+01 W(6) = 0.100D+01 GO TO 320 300 CONTINUE W(1) = 0.131D+01 W(2) = 0.112D+01 W(3) = 0.100D+01 W(4) = 0.100D+01 W(5) = 0.100D+01 W(6) = 0.100D+01 320 CONTINUE XEND = 20.D0 HBEGIN = 1.D-2 HMAX = 20.D0 DO 340 I = 1, N Y(I) = 1.D0 340 CONTINUE GO TO 940 C C PROBLEM CLASS C - NON-LINEAR COUPLING FROM C STEADY STATE TO TRANSIENT C C 360 CONTINUE CP PROBLEM C1 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 4 W(1) = 0.102D+01 W(2) = 0.103D+01 W(3) = 0.100D+01 W(4) = 0.100D+01 XEND = 20.D0 HBEGIN = 1.D-2 HMAX = 20.D0 DO 380 I = 1, N Y(I) = 1.D0 380 CONTINUE GO TO 940 C 400 CONTINUE CP PROBLEM C2, C3, C4, C5 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 4 ITMP = IID - 1 GO TO (420,440,460,480) ITMP 420 CONTINUE W(1) = 0.200D+01 W(2) = 0.100D+01 W(3) = 0.100D+01 W(4) = 0.100D+01 GO TO 500 440 CONTINUE W(1) = 0.200D+01 W(2) = 0.100D+01 W(3) = 0.100D+01 W(4) = 0.100D+01 GO TO 500 460 CONTINUE W(1) = 0.200D+01 W(2) = 0.400D+01 W(3) = 0.200D+02 W(4) = 0.420D+03 GO TO 500 480 CONTINUE W(1) = 0.200D+01 W(2) = 0.800D+01 W(3) = 0.136D+03 W(4) = 0.371D+05 500 CONTINUE XEND = 20.D0 HBEGIN = 1.D-2 HMAX = 20.D0 DO 520 I = 1, N Y(I) = 1.D0 520 CONTINUE GO TO 940 C C PROBLEM CLASS D - NON-LINEAR WITH REAL EIGENVALUES C C 540 CONTINUE CP PROBLEM D1 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 3 W(1) = 0.223D+02 W(2) = 0.271D+02 W(3) = 0.400D+03 XEND = 400.D0 HBEGIN = 1.7D-2 HMAX = 400.D0 DO 560 I = 1, N Y(I) = 0.D0 560 CONTINUE GO TO 940 C 580 CONTINUE CP PROBLEM D2 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 3 W(1) = 0.100D+01 W(2) = 0.365D+00 W(3) = 0.285D+02 XEND = 40.D0 HBEGIN = 1.D-5 HMAX = 40.D0 Y(1) = 1.D0 Y(2) = 0.D0 Y(3) = 0.D0 GO TO 940 C 600 CONTINUE CP PROBLEM D3 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 4 W(1) = 0.100D+01 W(2) = 0.100D+01 W(3) = 0.360D+00 W(4) = 0.485D+00 XEND = 20.D0 HBEGIN = 2.5D-5 HMAX = 20.D0 DO 620 I = 1, 2 Y(I) = 1.D0 Y(I+2) = 0.D0 620 CONTINUE GO TO 940 C 640 CONTINUE CP PROBLEM D4 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 3 W(1) = 0.100D+01 W(2) = 0.142D+01 W(3) = 0.371D-05 XEND = 50.D0 HBEGIN = 2.9D-4 HMAX = 50.D0 Y(1) = 1.D0 Y(2) = 1.D0 Y(3) = 0.D0 GO TO 940 C 660 CONTINUE CP PROBLEM D5 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 2 W(1) = 0.992D+00 W(2) = 0.984D+00 XEND = 1.D2 HBEGIN = 1.D-4 HMAX = 1.D2 Y(1) = 0.D0 Y(2) = 0.D0 GO TO 940 C 680 CONTINUE CP PROBLEM D6 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 3 W(1) = 0.100D+01 W(2) = 0.148D+00 W(3) = 0.577D-07 XEND = 1.D0 HBEGIN = 3.3D-8 HMAX = 1.D0 Y(1) = 1.D0 Y(2) = 0.D0 Y(3) = 0.D0 GO TO 940 C C PROBLEM CLASS E - NON-LINEAR WITH NON-REAL EIGENVALUES C C 700 CONTINUE CP PROBLEM E1 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 4 W(1) = 0.100D-07 W(2) = 0.223D-06 W(3) = 0.132D-04 W(4) = 0.171D-02 XEND = 1.D0 HBEGIN = 6.8D-3 HMAX = 1.D0 DO 720 I = 1, N Y(I) = 0.D0 720 CONTINUE GO TO 940 C 740 CONTINUE CP PROBLEM E2 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 2 W(1) = 0.202D+01 W(2) = 0.764D+01 XEND = 1.D1 HBEGIN = 1.D-3 HMAX = 1.D1 Y(1) = 2.D0 Y(2) = 0.D0 GO TO 940 C 760 CONTINUE CP PROBLEM E3 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 3 W(1) = 0.163D+01 W(2) = 0.160D+01 W(3) = 0.263D+02 XEND = 5.D2 HBEGIN = .2D-1 HMAX = 5.D2 Y(1) = 1.D0 Y(2) = 1.D0 Y(3) = 0.D0 GO TO 940 C 780 CONTINUE CP PROBLEM E4 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 4 W(1) = 0.288D+02 W(2) = 0.295D+02 W(3) = 0.155D+02 W(4) = 0.163D+02 XEND = 1.D3 HBEGIN = 1.D-3 HMAX = 1.D3 Y(1) = 0.D0 Y(2) = -2.D0 Y(3) = -1.D0 Y(4) = -1.D0 GO TO 940 C 800 CONTINUE CP PROBLEM E5 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 4 W(1) = 0.176D-02 W(2) = 0.146D-09 W(3) = 0.827D-11 W(4) = 0.138D-09 XEND = 1.D3 HBEGIN = 5.D-5 HMAX = 1.D3 Y(1) = 1.76D-3 DO 820 I = 2, N Y(I) = 0.D0 820 CONTINUE GO TO 940 C C PROBLEM CLASS F - CHEMICAL KINETICS EQUATIONS C C 840 CONTINUE CP PROBLEM F1 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 4 W(1) = 0.121D+04 W(2) = 0.835D-01 W(3) = 0.121D+04 W(4) = 0.100D+00 HMAX = 1.D3 HBEGIN = 1.D-4 XEND = 1.D3 Y(1) = 761.D0 Y(2) = 0.D0 Y(3) = 600.D0 Y(4) = .1D0 GO TO 940 C 860 CONTINUE CP PROBLEM F2 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 2 W(1) = 0.100D+01 W(2) = 0.253D-02 HMAX = 240.D0 HBEGIN = 1.D-2 XEND = 240.D0 Y(1) = 1.0D0 Y(2) = 0.D0 GO TO 940 C 880 CONTINUE CP PROBLEM F3 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 5 W(1) = 0.400D-05 W(2) = 0.100D-05 W(3) = 0.374D-08 W(4) = 0.765D-06 W(5) = 0.324D-05 HBEGIN = 1.D-6 HMAX = 100.D0 XEND = 100.D0 Y(1) = 4.D-6 Y(2) = 1.D-6 Y(3) = 0.0D0 Y(4) = 0.0D0 Y(5) = 0.0D0 GO TO 940 C 900 CONTINUE CP PROBLEM F4 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 3 W(1) = 0.118D+06 W(2) = 0.177D+04 W(3) = 0.313D+05 HBEGIN = 1.D-3 HMAX = 50.D0 XEND = 300.D0 Y(1) = 4.D0 Y(2) = 1.1D0 Y(3) = 4.D0 GO TO 940 C 920 CONTINUE CP PROBLEM F5 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 4 W(1) = 0.336D-06 W(2) = 0.826D-02 W(3) = 0.619D-02 W(4) = 0.955D-05 HBEGIN = 1.D-7 HMAX = 100.D0 XEND = 100.D0 Y(1) = 3.365D-7 Y(2) = 8.261D-3 Y(3) = 1.642D-3 Y(4) = 9.380D-6 940 CONTINUE IF (IWT.LT.0) GO TO 980 DO 960 I = 1, N Y(I) = Y(I)/W(I) 960 CONTINUE 980 CONTINUE RETURN C 99999 FORMAT ('0AN INVALID INTERNAL PROBLEM ID OF ',I4, * ' WAS FOUND BY THE IVALU ROUTINE', * /' RUN TERMINATED. CHECK THE DATA AND THE PARCHK ROUTINE!') END SUBROUTINE EVALU(Y,N,W,IWT,ID) C C********************************************************************** C C ROUTINE TO PROVIDE THE 'TRUE' SOLUTION OF THE DIFFERENTIAL C EQUATION EVALUATED AT THE ENDPOINT OF THE INTEGRATION. C C 1986 REVISION: SOME VERY SMALL CONSTANTS HAVE BEEN RECAST IN THE C (NOT SO SMALL CONST)/(1.E38) TO AVOID COMPILE-TIME UNDERFLOW ERROR C IT IS ASSUMED 1E+38 WON'T OVERFLOW. C PARAMETER (OUTPUT) C Y - THE TRUE SOLUTION VECTOR EVALUATED AT THE ENDPOINT C C PARAMETERS (INPUT) C N - DIMENSION OF THE PROBLEM C W - VECTOR OF WEIGHTS USED TO SCALE THE PROBLEM C IF THIS OPTION IS SELECTED C IWT - FLAG USED TO SIGNAL WHEN THE SCALED PROBLEM IS C BEING SOLVED C ID - FLAG USED TO INDICATE WHICH EQUATION IS BEING C SOLVED C C********************************************************************** C .. Parameters .. REAL TENE38 PARAMETER (TENE38=1.D38) C .. Scalar Arguments .. INTEGER ID, IWT, N C .. Array Arguments .. DOUBLE PRECISION W(20), Y(20) C .. Local Scalars .. INTEGER I C .. Executable Statements .. GO TO (20,40,60,80,620,620,620,620,620, * 620,100,120,140,160,180,620,620,620, * 620,620,200,220,240,260,280,620,620, * 620,620,620,300,320,340,360,380,400, * 620,620,620,620,420,440,460,480,500, * 620,620,620,620,620,520,540,560,580, * 600,620,620,620,620,620) ID GO TO 620 C PROBLEM CLASS A C C PROBLEM A1 20 Y(1) = 4.539992969929191D-05 Y(2) = 2.061153036149920D-09 Y(3) = 2.823006338263857D-18/TENE38 Y(4) = 5.235792540515384D-14/TENE38 GO TO 620 C C PROBLEM A2 40 Y(1) = 9.999912552999704D-02 Y(2) = 1.999982511586291D-01 Y(3) = 2.999975543202422D-01 Y(4) = 3.999971057541257D-01 Y(5) = 4.999969509963023D-01 Y(6) = 5.999971057569546D-01 Y(7) = 6.999975543256127D-01 Y(8) = 7.999982511659962D-01 Y(9) = 8.999991255386128D-01 GO TO 620 C C PROBLEM A3 60 Y(1) = -1.353352661867235D-03 Y(2) = 1.368526917891521D-02 Y(3) = 1.503725348455117D+00 Y(4) = 1.353352832366099D-01 GO TO 620 C C PROBLEM A4 80 Y(1) = 3.678794411714325D-01 Y(2) = 1.265870722340194D-14 Y(3) = 1.911533219339204D-04/TENE38 Y(4) = 2.277441666729596D-17/TENE38 Y(5) = 0.0D0 Y(6) = 0.0D0 Y(7) = 0.0D0 Y(8) = 0.0D0 Y(9) = 0.0D0 Y(10) = 0.0D0 GO TO 620 C PROBLEM CLASS B C C PROBLEM B1 100 Y(1) = 1.004166730990124D-09 Y(2) = 1.800023280346500D-08 Y(3) = 0.0D0 Y(4) = -6.042962877027475D-03/TENE38/TENE38 GO TO 620 C C PROBLEM B2 120 Y(1) = 6.181330838820067D-31 Y(2) = 8.963657877626303D-31 Y(3) = 2.738406773453261D-27 Y(4) = 2.061153063164016D-09 Y(5) = 4.539992973654118D-05 Y(6) = 1.353352832365270D-01 GO TO 620 C C PROBLEM B3 140 Y(1) = -1.076790816984970D-28 Y(2) = 5.455007683862160D-28 Y(3) = 2.738539964946867D-27 Y(4) = 2.061153071123456D-09 Y(5) = 4.539992974611305D-05 Y(6) = 1.353352832365675D-01 GO TO 620 C C PROBLEM B4 160 Y(1) = 1.331242472678293D-22 Y(2) = -2.325916064237926D-22 Y(3) = 1.517853928534857D-35 Y(4) = 2.061152428936651D-09 Y(5) = 4.539992963392291D-05 Y(6) = 1.353352832363442D-01 GO TO 620 C C PROBLEM B5 180 Y(1) = -3.100634584292190D-14 Y(2) = 3.862788998076547D-14 Y(3) = 1.804851385304217D-35 Y(4) = 2.061153622425655D-09 Y(5) = 4.539992976246673D-05 Y(6) = 1.353352832366126D-01 GO TO 620 C PROBLEM CLASS C C C PROBLEM C1 200 Y(1) = 4.003223925456179D-04 Y(2) = 4.001600000000000D-04 Y(3) = 4.000000000000000D-04 Y(4) = 2.000000000000000D-02 GO TO 620 C C PROBLEM C2 220 Y(1) = 1.999999997938994D+00 Y(2) = 3.999999990839974D-02 Y(3) = 4.001599991537078D-02 Y(4) = 4.003201271914461D-02 GO TO 620 C C PROBLEM C3 240 Y(1) = 1.999999997939167D+00 Y(2) = 3.999999990840744D-01 Y(3) = 4.159999990793773D-01 Y(4) = 4.333055990159567D-01 GO TO 620 C C PROBLEM C4 260 Y(1) = 1.999999997938846D+00 Y(2) = 3.999999990839318D+00 Y(3) = 1.999999991637941D+01 Y(4) = 4.199999965390368D+02 GO TO 620 C C PROBLEM C5 280 Y(1) = 1.999999997938846D+00 Y(2) = 7.999999981678634D+00 Y(3) = 1.359999993817714D+02 Y(4) = 3.712799965967762D+04 GO TO 620 C PROBLEM CLASS D C C PROBLEM D1 300 Y(1) = 2.224222010616901D+01 Y(2) = 2.711071334484136D+01 Y(3) = 3.999999999999999D+02 GO TO 620 C C PROBLEM D2 320 Y(1) = 7.158270687193941D-01 Y(2) = 9.185534764557338D-02 Y(3) = 2.841637457458413D+01 GO TO 620 C C PROBLEM D3 340 Y(1) = 6.397604446889910D-01 Y(2) = 5.630850708287990D-03 Y(3) = 3.602395553110090D-01 Y(4) = 3.170647969903515D-01 GO TO 620 C C PROBLEM D4 360 Y(1) = 5.976546980673215D-01 Y(2) = 1.402343408546138D+00 Y(3) = -1.893386540441913D-06 GO TO 620 C C PROBLEM D5 380 Y(1) = -9.916420698713913D-01 Y(2) = 9.833363588544478D-01 GO TO 620 C C PROBLEM D6 400 Y(1) = 8.523995440749948D-01 Y(2) = 1.476003981941319D-01 Y(3) = 5.773087333950041D-08 GO TO 620 C PROBLEM CLASS E C C PROBLEM E1 420 Y(1) = 1.000000000000012D-08 Y(2) = -1.625323873316817D-19 Y(3) = 2.025953375595861D-17 Y(4) = -1.853149807630002D-15 GO TO 620 C C PROBLEM E2 440 Y(1) = -1.158701266031984D+00 Y(2) = 4.304698089780476D-01 GO TO 620 C C PROBLEM E3 460 Y(1) = 4.253052197643089D-03 Y(2) = 5.317019548450387D-03 Y(3) = 2.627647748753926D+01 GO TO 620 C C PROBLEM E4 480 Y(1) = 1.999999977523654D+01 Y(2) = -2.000000022476345D+01 Y(3) = -2.247634567084293D-07 Y(4) = 2.247634567084293D-07 GO TO 620 C C PROBLEM E5 500 Y(1) = 1.618076919919600D-03 Y(2) = 1.382236955418478D-10 Y(3) = 8.251573436034144D-12 Y(4) = 1.299721221058136D-10 GO TO 620 C PROBLEM CLASS F C C PROBLEM F1 520 Y(1) = 1.211129474696585D+03 Y(2) = 1.271123619113051D-05 Y(3) = 1.208637804660361D+03 Y(4) = 3.241981171933418D-04 GO TO 620 C C PROBLEM F2 540 Y(1) = 3.912699122292088D-01 Y(2) = 1.329964166084866D-03 GO TO 620 C C PROBLEM F3 560 Y(1) = 3.235910070806680D-13 Y(2) = 2.360679774997897D-07 Y(3) = 7.639319089351045D-14 Y(4) = 7.639319461070194D-07 Y(5) = 3.236067653908783D-06 GO TO 620 C C PROBLEM F4 580 Y(1) = 4.418303324022590D+00 Y(2) = 1.290244712916425D+00 Y(3) = 3.019282584050490D+00 GO TO 620 C C PROBLEM F5 600 Y(1) = 1.713564284690712D-07 Y(2) = 3.713563071160676D-03 Y(3) = 6.189271785267793D-03 Y(4) = 9.545143571530929D-06 620 CONTINUE IF (IWT.LT.0) GO TO 660 DO 640 I = 1, N Y(I) = Y(I)/W(I) 640 CONTINUE 660 CONTINUE RETURN END SUBROUTINE FCN(X,Y,YP) C C********************************************************************** C ROUTINE TO EVALUATE THE DERIVATIVE F(X,Y) CORRESPONDING TO THE C DIFFERENTIAL EQUATION: C DY/DX = F(X,Y) . C THE ROUTINE STORES THE VECTOR OF DERIVATIVES IN YP(*). THE C PARTICULAR EQUATION BEING INTEGRATED IS INDICATED BY THE C VALUE OF THE FLAG ID WHICH IS PASSED THROUGH COMMON. THE C DIFFERENTIAL EQUATION IS SCALED BY THE WEIGHT VECTOR W(*) C IF THIS OPTION HAS BEEN SELECTED (IF SO IT IS SIGNALLED C BY THE FLAG IWT). C C********************************************************************* C CC*******+*********+*********+*********+*********+*********+*********+** C COMMON AREAS C********+*********+*********+*********+*********+*********+*********+** C5 C6 C .. Scalar Arguments .. DOUBLE PRECISION X C .. Array Arguments .. DOUBLE PRECISION Y(20), YP(20) C .. Scalars in Common .. INTEGER ID, IWT, N, NFCN, NJAC, NLUD C .. Arrays in Common .. DOUBLE PRECISION W(20) C .. Local Scalars .. DOUBLE PRECISION F, Q, S, SUM, T, TEMP, XTEMP INTEGER I, IID C .. Local Arrays .. DOUBLE PRECISION BPARM(4), CPARM(4), VECT1(4), VECT2(4), YTEMP(20) C .. Intrinsic Functions .. INTRINSIC DBLE, DEXP, DSIN, MOD C .. Common blocks .. COMMON /STCOM5/W, IWT, N, ID COMMON /STCOM6/NFCN, NJAC, NLUD C .. Data statements .. CE DATA BPARM/3.D0, 8.D0, 25.D0, 1.D2/ DATA CPARM/1.D-1, 1.D0, 1.D1, 2.D1/ C .. Executable Statements .. NFCN = NFCN + 1 IF (IWT.LT.0) GO TO 40 DO 20 I = 1, N YTEMP(I) = Y(I) Y(I) = Y(I)*W(I) 20 CONTINUE 40 CONTINUE IID = MOD(ID,10) GO TO (60,80,120,140,640,640,640,640,640, * 640,180,200,200,200,200,640,640,640, * 640,640,220,240,240,240,240,640,640, * 640,640,640,260,280,300,320,340,360, * 640,640,640,640,380,400,420,440,520, * 640,640,640,640,640,540,560,580,600, * 620) ID GO TO 640 C C PROBLEM CLASS A - LINEAR WITH REAL EIGENVALUES C C C PROBLEM A1 60 YP(1) = -.5D0*Y(1) YP(2) = -1.D0*Y(2) YP(3) = -1.D2*Y(3) YP(4) = -9.D1*Y(4) GO TO 640 C C PROBLEM A2 80 YP(1) = -1.8D3*Y(1) + 9.D2*Y(2) DO 100 I = 2, 8 YP(I) = Y(I-1) - 2.D0*Y(I) + Y(I+1) 100 CONTINUE YP(9) = 1.D3*Y(8) - 2.D3*Y(9) + 1.D3 GO TO 640 C C PROBLEM A3 120 YP(1) = -1.D4*Y(1) + 1.D2*Y(2) - 1.D1*Y(3) + 1.D0*Y(4) YP(2) = -1.D3*Y(2) + 1.D1*Y(3) - 1.D1*Y(4) YP(3) = -1.D0*Y(3) + 1.D1*Y(4) YP(4) = -1.D-1*Y(4) GO TO 640 C C PROBLEM A4 140 DO 160 I = 1, 10 YP(I) = -DBLE(I)**5*Y(I) 160 CONTINUE GO TO 640 C C PROBLEM CLASS B - LINEAR WITH NON-REAL EIGENVALUES C C C PROBLEM B1 180 YP(1) = -Y(1) + Y(2) YP(2) = -1.D2*Y(1) - Y(2) YP(3) = -1.D2*Y(3) + Y(4) YP(4) = -1.D4*Y(3) - 1.D2*Y(4) GO TO 640 C C PROBLEMS B2, B3, B4, B5 200 YP(1) = -1.D1*Y(1) + BPARM(IID-1)*Y(2) YP(2) = -BPARM(IID-1)*Y(1) - 1.D1*Y(2) YP(3) = -4.D0*Y(3) YP(4) = -1.D0*Y(4) YP(5) = -.5D0*Y(5) YP(6) = -.1D0*Y(6) GO TO 640 C C PROBLEM CLASS C - NON-LINEAR COUPLING FROM C STEADY STATE TO TRANSIENT C C C PROBLEM C1 220 YP(1) = -Y(1) + (Y(2)*Y(2)+Y(3)*Y(3)+Y(4)*Y(4)) YP(2) = -1.D1*Y(2) + 1.D1*(Y(3)*Y(3)+Y(4)*Y(4)) YP(3) = -4.D1*Y(3) + 4.D1*Y(4)*Y(4) YP(4) = -1.D2*Y(4) + 2.D0 GO TO 640 C C PROBLEMS C2, C3, C4, C5 240 YP(1) = -Y(1) + 2.D0 YP(2) = -1.D1*Y(2) + CPARM(IID-1)*Y(1)*Y(1) YP(3) = -4.D1*Y(3) + (Y(1)*Y(1)+Y(2)*Y(2))*CPARM(IID-1)*4.D0 YP(4) = (Y(1)*Y(1)+Y(2)*Y(2)+Y(3)*Y(3))*CPARM(IID-1)*1.D1 - * 1.D2*Y(4) GO TO 640 C C PROBLEM CLASS D - NON-LINEAR WITH REAL EIGENVALUES C C C PROBLEM D1 260 YP(1) = .2D0*Y(2) - .2D0*Y(1) YP(2) = 1.D1*Y(1) - (6.D1-.125D0*Y(3))*Y(2) + .125D0*Y(3) YP(3) = 1.D0 GO TO 640 C C PROBLEM D2 280 YP(1) = -.04D0*Y(1) + .01D0*Y(2)*Y(3) YP(2) = 4.D2*Y(1) - 1.D2*Y(2)*Y(3) - 3.D3*Y(2)**2 YP(3) = 3.D1*Y(2)**2 GO TO 640 C C PROBLEM D3 300 YP(1) = Y(3) - 1.D2*Y(1)*Y(2) YP(3) = -YP(1) YP(4) = -Y(4) + 1.D4*Y(2)**2 YP(2) = YP(1) - YP(4) + Y(4) - 1.D4*Y(2)**2 GO TO 640 C C PROBLEM D4 320 YP(1) = -.013D0*Y(1) - 1.D3*Y(1)*Y(3) YP(2) = -2.5D3*Y(2)*Y(3) YP(3) = YP(1) + YP(2) GO TO 640 C C PROBLEM D5 340 XTEMP = .01D0 + Y(1) + Y(2) YP(1) = .01D0 - XTEMP*(1.D0+(Y(1)+1.D3)*(Y(1)+1.D0)) YP(2) = .01D0 - XTEMP*(1.D0+Y(2)**2) GO TO 640 C C PROBLEM D6 360 YP(1) = -Y(1) + 1.D8*Y(3)*(1.D0-Y(1)) YP(2) = -1.D1*Y(2) + 3.D7*Y(3)*(1.D0-Y(2)) YP(3) = -YP(1) - YP(2) GO TO 640 C C PROBLEM CLASS E - NON-LINEAR WITH NON-REAL EIGENVALUES C C C PROBLEM E1 380 YP(1) = Y(2) YP(2) = Y(3) YP(3) = Y(4) YP(4) = (Y(1)**2-DSIN(Y(1))-1.D8)*Y(1) + (Y(2)*Y(3)/(Y(1)**2+1.D0) * -4.D6)*Y(2) + (1.D0-6.D4)*Y(3) + (1.D1*DEXP(-Y(4)**2) * -4.D2)*Y(4) + 1.D0 GO TO 640 C C PROBLEM E2 400 YP(1) = Y(2) YP(2) = 5.D0*Y(2) - 5.D0*Y(1)*Y(1)*Y(2) - Y(1) GO TO 640 C C PROBLEM E3 420 YP(1) = -55.D0*Y(1) - Y(3)*Y(1) + 65.D0*Y(2) YP(2) = .785D-1*Y(1) - .785D-1*Y(2) YP(3) = .1D0*Y(1) GO TO 640 C C PROBLEM E4 440 SUM = Y(1) + Y(2) + Y(3) + Y(4) DO 460 I = 1, 4 VECT2(I) = -Y(I) + .5D0*SUM 460 CONTINUE VECT1(1) = .5D0*(VECT2(1)**2-VECT2(2)**2) VECT1(2) = VECT2(1)*VECT2(2) VECT1(3) = VECT2(3)**2 VECT1(4) = VECT2(4)**2 TEMP = -1.D1*VECT2(1) - 1.D1*VECT2(2) VECT2(2) = 1.D1*VECT2(1) - 1.D1*VECT2(2) VECT2(1) = TEMP VECT2(3) = 1.D3*VECT2(3) VECT2(4) = 1.D-2*VECT2(4) SUM = 0.D0 DO 480 I = 1, 4 SUM = SUM + VECT1(I) - VECT2(I) 480 CONTINUE DO 500 I = 1, 4 YP(I) = VECT2(I) - VECT1(I) + .5D0*SUM 500 CONTINUE GO TO 640 C C PROBLEM E5 520 XTEMP = -7.89D-10*Y(1) YP(1) = XTEMP - 1.1D7*Y(1)*Y(3) YP(2) = -XTEMP - 1.13D9*Y(2)*Y(3) YP(4) = 1.1D7*Y(1)*Y(3) - 1.13D3*Y(4) YP(3) = YP(2) - YP(4) GO TO 640 C C PROBLEM CLASS F - CHEMICAL KINETICS EQUATIONS C C C PROBLEM F1 540 TEMP = 6.D-3*DEXP(20.7D0-1.5D4/Y(1)) YP(1) = 1.3D0*(Y(3)-Y(1)) + 1.04D4*TEMP*Y(2) YP(2) = 1.88D3*(Y(4)-Y(2)*(1.D0+TEMP)) YP(3) = 1752.D0 - 269.D0*Y(3) + 267.D0*Y(1) YP(4) = .1D0 + 320.D0*Y(2) - 321.D0*Y(4) GO TO 640 C C PROBLEM F2 560 YP(1) = -Y(1) - Y(1)*Y(2) + 294.D0*Y(2) YP(2) = Y(1)*(1.D0-Y(2))/98.D0 - 3.D0*Y(2) GO TO 640 C C PROBLEM F3 580 YP(1) = -1.0D7*Y(2)*Y(1) + 1.D1*Y(3) YP(2) = -1.0D7*Y(2)*Y(1) - 1.D7*Y(2)*Y(5) + 1.D1*Y(3) + 1.D1*Y(4) YP(3) = 1.0D7*Y(2)*Y(1) - 1.001D4*Y(3) + 1.D-3*Y(4) YP(4) = 1.D4*Y(3) - 1.0001D1*Y(4) + 1.D7*Y(2)*Y(5) YP(5) = 1.D1*Y(4) - 1.D7*Y(2)*Y(5) GO TO 640 C C PROBLEM F4 600 S = 77.27D0 T = 0.161D0 Q = 8.375D-6 F = 1.D0 YP(1) = S*(Y(2)-Y(1)*Y(2)+Y(1)-Q*Y(1)*Y(1)) YP(2) = (-Y(2)-Y(1)*Y(2)+F*Y(3))/S YP(3) = T*(Y(1)-Y(3)) GO TO 640 C C PROBLEM F5 620 YP(1) = -3.D11*Y(1)*Y(2) + 1.2D8*Y(4) - 9.D11*Y(1)*Y(3) YP(2) = -3.D11*Y(1)*Y(2) + 2.D7*Y(4) YP(3) = -9.D11*Y(1)*Y(3) + 1.D8*Y(4) YP(4) = 3.D11*Y(1)*Y(2) - 1.2D8*Y(4) + 9.D11*Y(1)*Y(3) 640 CONTINUE IF (IWT.LT.0) GO TO 680 DO 660 I = 1, N YP(I) = YP(I)/W(I) Y(I) = YTEMP(I) 660 CONTINUE 680 CONTINUE RETURN END SUBROUTINE PDERV(X,Y,DY) C********************************************************************** C C ROUTINE TO EVALUATE THE JACOBIAN MATRIX OF PARTIAL DERIVATIVES C CORRESPONDING TO THE DIFFERENTIAL EQUATION: C DY/DX = F(X,Y). C THE N**2 ELEMENTS OF THE ARRAY DY(*) ARE ASSIGNED THE VALUE OF C THE JACOBIAN MATRIX WITH ELEMENT I+(J-1)*N BEING ASSIGNED THE C VALUE OF DF(I)/DY(J). THE PARTICULAR EQUATION BEING INTEGRATED C IS INDICATED BY THE VALUE OF THE FLAG ID WHICH IS PASSED THROUGH C COMMON. IF A SCALED DIFFERENTIAL EQUATION IS BEING SOLVED (AS C SIGNALLED IWT) THE ELEMENTS OF THE JACOBIAN ARE SCALED ACCORDING- C LY BY THE WEIGHT VECTOR W(*). C C********************************************************************** CC*******+*********+*********+*********+*********+*********+*********+** C COMMON AREAS C********+*********+*********+*********+*********+*********+*********+** C5 C6 C .. Scalar Arguments .. DOUBLE PRECISION X C .. Array Arguments .. DOUBLE PRECISION DY(400), Y(20) C .. Scalars in Common .. INTEGER ID, IWT, N, NFCN, NJAC, NLUD C .. Arrays in Common .. DOUBLE PRECISION W(20) C .. Local Scalars .. DOUBLE PRECISION F, Q, S, SUM, T, TEMP, XTEMP1, XTEMP2, XTEMP3 INTEGER I, IID, ITMP, J, L C .. Local Arrays .. DOUBLE PRECISION BPARM(4), CPARM(4), VECT2(4), YTEMP(20) C .. Intrinsic Functions .. INTRINSIC DBLE, DCOS, DEXP, DSIN, MOD C .. Common blocks .. COMMON /STCOM5/W, IWT, N, ID COMMON /STCOM6/NFCN, NJAC, NLUD C .. Data statements .. CE DATA BPARM/3.D0, 8.D0, 25.D0, 1.D2/ DATA CPARM/1.D-1, 1.D0, 1.D1, 2.D1/ C .. Executable Statements .. NJAC = NJAC + 1 IF (IWT.LT.0) GO TO 40 DO 20 I = 1, N YTEMP(I) = Y(I) Y(I) = Y(I)*W(I) 20 CONTINUE 40 CONTINUE IID = MOD(ID,10) GO TO (60,100,160,200,980,980,980,980,980, * 980,260,300,300,300,300,980,980,980, * 980,980,340,380,380,380,380,980,980, * 980,980,980,420,440,460,480,520,540, * 980,980,980,980,580,620,640,660,840, * 980,980,980,980,980,880,900,920,940, * 960) ID GO TO 980 C C PROBLEM CLASS A - LINEAR WITH REAL EIGENVALUES C C C PROBLEM A1 60 DO 80 I = 1, 16 DY(I) = 0.D0 80 CONTINUE DY(1) = -.5D0 DY(6) = -1.D0 DY(11) = -1.D2 DY(16) = -9.D1 GO TO 980 C C PROBLEM A2 100 DO 120 I = 1, 81 DY(I) = 0.D0 120 CONTINUE DO 140 I = 2, 62, 10 DY(I) = 1.D0 DY(I+9) = -2.D0 DY(I+18) = 1.D0 140 CONTINUE DY(1) = -1.8D3 DY(10) = 9.D2 DY(72) = 1.D3 DY(81) = -2.D3 GO TO 980 C C PROBLEM A3 160 DO 180 I = 1, 16 DY(I) = 0.D0 180 CONTINUE DY(1) = -1.D4 DY(5) = 1.D2 DY(6) = -1.D3 DY(9) = -1.D1 DY(10) = 1.D1 DY(11) = -1.D0 DY(13) = 1.D0 DY(14) = -1.D1 DY(15) = 1.D1 DY(16) = -1.D-1 GO TO 980 C C PROBLEM A4 200 DO 220 I = 1, 100 DY(I) = 0.D0 220 CONTINUE DO 240 I = 1, 10 DY((I-1)*10+I) = -DBLE(I)**5 240 CONTINUE GO TO 980 C C PROBLEM CLASS B - LINEAR WITH NON-REAL EIGENVALUES C C C PROBLEM B1 260 DO 280 I = 1, 16 DY(I) = 0.D0 280 CONTINUE DY(1) = -1.D0 DY(2) = -1.D2 DY(5) = 1.D0 DY(6) = -1.D0 DY(11) = -1.D2 DY(12) = -1.D4 DY(15) = 1.D0 DY(16) = -1.D2 GO TO 980 C C PROBLEMS B2, B3, B4, B5 300 DO 320 I = 1, 36 DY(I) = 0.D0 320 CONTINUE DY(1) = -1.D1 DY(2) = -BPARM(IID-1) DY(7) = BPARM(IID-1) DY(8) = -1.D1 DY(15) = -4.D0 DY(22) = -1.D0 DY(29) = -.5D0 DY(36) = -.1D0 GO TO 980 C C PROBLEM CLASS C - NON-LINEAR COUPLING FROM C STEADY STATE TO TRANSIENT C C C PROBLEM C1 340 DO 360 I = 1, 16 DY(I) = 0.D0 360 CONTINUE DY(1) = -1.D0 DY(5) = 2.D0*Y(2) DY(6) = -1.D1 DY(9) = 2.D0*Y(3) DY(10) = 2.D1*Y(3) DY(11) = -4.D1 DY(13) = 2.D0*Y(4) DY(14) = 2.D1*Y(4) DY(15) = 8.D1*Y(4) DY(16) = -1.D2 GO TO 980 C C PROBLEMS C2, C3, C4, C5 380 DO 400 I = 1, 16 DY(I) = 0.D0 400 CONTINUE DY(1) = -1.D0 DY(2) = 2.D0*Y(1)*CPARM(IID-1) DY(3) = 8.D0*Y(1)*CPARM(IID-1) DY(4) = 2.D1*Y(1)*CPARM(IID-1) DY(6) = -1.D1 DY(7) = 8.D0*Y(2)*CPARM(IID-1) DY(8) = 2.D1*Y(2)*CPARM(IID-1) DY(11) = -4.D1 DY(12) = 2.D1*Y(3)*CPARM(IID-1) DY(16) = -1.D2 GO TO 980 C C PROBLEM CLASS D - NON-LINEAR WITH REAL EIGENVALUES C C C PROBLEM D1 420 DY(1) = -.2D0 DY(2) = 1.D1 DY(3) = 0.D0 DY(4) = .2D0 DY(5) = -6.D1 + .125D0*Y(3) DY(6) = 0.D0 DY(7) = 0.D0 DY(8) = .125D0*Y(2) + .125D0 DY(9) = 0.D0 GO TO 980 C C PROBLEM D2 440 DY(1) = -4.D-2 DY(2) = 4.D2 DY(3) = 0.D0 DY(4) = 1.D-2*Y(3) DY(5) = -1.D2*Y(3) - 6.D3*Y(2) DY(6) = 6.D1*Y(2) DY(7) = .1D-1*Y(2) DY(8) = -1.D2*Y(2) DY(9) = 0.D0 GO TO 980 C C PROBLEM D3 460 DY(1) = -1.D2*Y(2) DY(2) = DY(1) DY(3) = -DY(1) DY(4) = 0.D0 DY(5) = -1.D2*Y(1) DY(7) = -DY(5) DY(8) = 2.D4*Y(2) DY(6) = DY(5) - DY(8) DY(6) = DY(6) - 2.D4*Y(2) DY(9) = 1.D0 DY(10) = 1.D0 DY(11) = -1.D0 DY(12) = 0.D0 DY(13) = 0.D0 DY(14) = 2.D0 DY(15) = 0.D0 DY(16) = -1.D0 GO TO 980 C C PROBLEM D4 480 DY(1) = -.013D0 - 1.D3*Y(3) DY(2) = 0.D0 DY(4) = 0.D0 DY(5) = -2.5D3*Y(3) DY(7) = -1.D3*Y(1) DY(8) = -2.5D3*Y(2) DO 500 I = 3, 9, 3 DY(I) = DY(I-1) + DY(I-2) 500 CONTINUE GO TO 980 C C PROBLEM D5 520 XTEMP1 = Y(1) + 1.D3 XTEMP2 = Y(1) + 1.D0 XTEMP3 = .01D0 + Y(1) + Y(2) DY(2) = -(1.D0+Y(2)**2) DY(3) = -(1.D0+XTEMP1*XTEMP2) DY(1) = -(-DY(3)+XTEMP3*(XTEMP1+XTEMP2)) DY(4) = -(2.D0*XTEMP3*Y(2)-DY(2)) GO TO 980 C C PROBLEM D6 540 DY(1) = -1.D0 - 1.D8*Y(3) DY(2) = 0.D0 DY(4) = 0.D0 DY(5) = -1.D1 - 3.D7*Y(3) DY(7) = 1.D8*(1.D0-Y(1)) DY(8) = 3.D7*(1.D0-Y(2)) DO 560 I = 3, 9, 3 DY(I) = -DY(I-2) - DY(I-1) 560 CONTINUE GO TO 980 C C PROBLEM CLASS E - NON-LINEAR WITH NON-REAL EIGENVALUES C C C PROBLEM E1 580 DO 600 I = 1, 16 DY(I) = 0.D0 600 CONTINUE DY(5) = 1.D0 DY(10) = 1.D0 DY(15) = 1.D0 XTEMP1 = Y(1) XTEMP2 = Y(2)/(XTEMP1**2+1.D0)**2 DY(4) = 3.D0*XTEMP1**2 - XTEMP1*DCOS(XTEMP1) - DSIN(XTEMP1) - * 1.D8 - 2.D0*XTEMP1*Y(2)*Y(3)*XTEMP2 DY(8) = 2.D0*Y(3)*Y(2)/(1.D0+Y(1)**2) - 4.D6 DY(12) = Y(2)*Y(2)/(1.D0+Y(1)**2) + 1.D0 - 6.D4 DY(16) = 1.D1*DEXP(-Y(4)**2)*(1.D0-2.D0*Y(4)**2) - 4.D2 GO TO 980 C C PROBLEM E2 620 DY(1) = 0.D0 DY(2) = -1.D1*Y(1)*Y(2) - 1.D0 DY(3) = 1.D0 DY(4) = 5.D0 - 5.D0*Y(1)*Y(1) GO TO 980 C C PROBLEM E3 640 DY(1) = -55.D0 - Y(3) DY(2) = .785D-1 DY(3) = 0.1D0 DY(4) = 65.D0 DY(5) = -.785D-1 DY(6) = 0.D0 DY(7) = -Y(1) DY(8) = 0.D0 DY(9) = 0.D0 GO TO 980 C C PROBLEM E4 660 SUM = Y(1) + Y(2) + Y(3) + Y(4) DO 680 I = 1, 4 VECT2(I) = -Y(I) + .5D0*SUM 680 CONTINUE DO 700 I = 1, 16 DY(I) = 0.D0 700 CONTINUE DY(1) = VECT2(1) + 1.D1 DY(2) = VECT2(2) - 1.D1 DY(5) = -DY(2) DY(6) = DY(1) DY(11) = 2.D0*VECT2(3) - 1.D3 DY(16) = 2.D0*VECT2(4) - 1.D-2 DO 760 I = 1, 4 SUM = 0.D0 DO 720 J = 1, 4 L = I + (J-1)*4 SUM = SUM + DY(L) 720 CONTINUE DO 740 J = 1, 4 L = I + (J-1)*4 DY(L) = -DY(L) + .5D0*SUM 740 CONTINUE 760 CONTINUE DO 820 J = 1, 4 SUM = 0.D0 DO 780 I = 1, 4 L = I + (J-1)*4 SUM = SUM + DY(L) 780 CONTINUE DO 800 I = 1, 4 L = I + (J-1)*4 DY(L) = -DY(L) + .5D0*SUM 800 CONTINUE 820 CONTINUE GO TO 980 C C PROBLEM E5 840 DY(1) = -7.89D-10 - 1.1D7*Y(3) DY(2) = 7.89D-10 DY(4) = 1.1D7*Y(3) DY(5) = 0.D0 DY(6) = -1.13D9*Y(3) DY(8) = 0.D0 DY(9) = -1.1D7*Y(1) DY(10) = -1.13D9*Y(2) DY(12) = -DY(9) DY(13) = 0.D0 DY(14) = 0.D0 DY(16) = -1.13D3 DO 860 I = 3, 15, 4 DY(I) = DY(I-1) - DY(I+1) 860 CONTINUE GO TO 980 C C PROBLEM CLASS F - CHEMICAL KINETICS EQUATIONS C C C PROBLEM F1 880 TEMP = 90.D0*DEXP(20.7D0-1.5D4/Y(1))/Y(1)**2 DY(1) = -1.3D0 + 1.04D4*TEMP*Y(2) DY(2) = -1.88D3*Y(2)*TEMP DY(3) = 267.D0 DY(4) = 0.D0 TEMP = 6.D-3*DEXP(20.7D0-1.5D4/Y(1)) DY(5) = 1.04D4*TEMP DY(6) = -1.88D3*(1.D0+TEMP) DY(7) = 0.D0 DY(8) = 320.D0 DY(9) = 1.3D0 DY(10) = 0.D0 DY(11) = -269.D0 DY(12) = 0.0D0 DY(13) = 0.0D0 DY(14) = 1.88D3 DY(15) = 0.0D0 DY(16) = -321.0D0 GO TO 980 C C PROBLEM F2 900 DY(1) = -1.D0 - Y(2) DY(2) = (1.D0-Y(2))/98.D0 DY(3) = -Y(1) + 294.D0 DY(4) = -Y(1)/98.D0 - 3.D0 GO TO 980 C C PROBLEM F3 920 DY(1) = -1.D7*Y(2) DY(2) = -1.D7*Y(2) DY(3) = 1.D7*Y(2) DY(4) = 0.0D0 DY(5) = 0.0D0 DY(6) = -1.D7*Y(1) DY(7) = -1.D7*Y(1) - 1.D7*Y(5) DY(8) = 1.D7*Y(1) DY(9) = 1.D7*Y(5) DY(10) = -1.D7*Y(5) DY(11) = 1.D1 DY(12) = 1.D1 DY(13) = -1.001D4 DY(14) = 1.D4 DY(15) = 0.0D0 DY(16) = 0.0D0 DY(17) = 1.D1 DY(18) = 1.D-3 DY(19) = -1.0001D1 DY(20) = 1.D1 DY(21) = 0.0D0 DY(22) = -1.D7*Y(2) DY(23) = 0.0D0 DY(24) = 1.D7*Y(2) DY(25) = -1.0D7*Y(2) GO TO 980 C C PROBLEM F4 940 S = 77.27D0 T = 0.161D0 Q = 8.375D-6 F = 1.D0 DY(1) = S*(-Y(2)+1.D0-2.D0*Q*Y(1)) DY(2) = -Y(2)/S DY(3) = T DY(4) = S*(1.D0-Y(1)) DY(5) = (-1.D0-Y(1))/S DY(6) = 0.D0 DY(7) = 0.D0 DY(8) = F/S DY(9) = -T GO TO 980 C C PROBLEM F5 960 DY(1) = -3.D11*Y(2) - 9.D11*Y(3) DY(2) = -3.D11*Y(2) DY(3) = -9.D11*Y(3) DY(4) = 3.D11*Y(2) + 9.D11*Y(3) DY(5) = -3.D11*Y(1) DY(6) = -3.D11*Y(1) DY(7) = 0.0D0 DY(8) = 3.D11*Y(1) DY(9) = -9.D11*Y(1) DY(10) = 0.0D0 DY(11) = -9.D11*Y(1) DY(12) = 9.D11*Y(1) DY(13) = 1.2D8 DY(14) = 2.D7 DY(15) = 1.D8 DY(16) = -1.2D8 980 CONTINUE IF (IWT.LT.0) GO TO 1040 DO 1020 I = 1, N Y(I) = YTEMP(I) DO 1000 J = 1, N ITMP = I + (J-1)*N DY(ITMP) = DY(ITMP)*W(J)/W(I) 1000 CONTINUE 1020 CONTINUE 1040 CONTINUE RETURN END SUBROUTINE IVALU(N,XSTART,XEND,HBEGIN,HMAX,Y,FCNTIM,JACTIM,LUDTIM, * W,IWT,ID) C C**************************************************************** C C ROUTINE TO PROVIDE THE INITIAL VALUES REQUIRED TO SPECIFY C THE MATHEMATICAL PROBLEM AS WELL AS VARIOUS PROBLEM C PARAMETERS REQUIRED BY THE TESTING PACKAGE. THE APPROPRIATE C SCALING VECTOR IS ALSO INITIALISED IN CASE THIS OPTION IS C SELECTED. C C PARAMETERS (OUTPUT) C N - DIMENSION OF THE PROBLEM C XSTART - INITIAL VALUE OF THE INDEPENDENT VARIABLE C XEND - FINAL VALUE OF THE INDEPENDENT VARIABLE C HBEGIN - APPROPRIATE STARTING STEPSIZE C Y - VECTOR OF INITIAL CONDITIONS FOR THE DEPENDENT C VARIABLES C FCNTIM - AVERAGE COMPUTER TIME REQUIRED FOR A DERIVATIVE C EVALUATION C JACTIM - AVERAGE COMPUTER TIME REQUIRED FOR A JACOBIAN C EVALUATION C LUDTIM - AVERAGE COMPUTER TIME REQUIRED FOR AN L/U C FACTORIZATION C WT - VECTOR OF WEIGHTS USED TO SCALE THE PROBLEM IF C THIS OPTION IS SELECTED. C C PARAMETER (INPUT) C IWT - FLAG TO INDICATE IF SCALED OPTION IS SELESTED C ID - FLAG IDENTIFYING WHICH EQUATION IS BEING SOLVED C C***************************************************************** C .. Scalar Arguments .. REAL HBEGIN, HMAX, XEND, XSTART REAL FCNTIM, JACTIM, LUDTIM INTEGER ID, IWT, N C .. Array Arguments .. REAL W(20), Y(20) C .. Local Scalars .. REAL XS INTEGER I, IID, IOUT, ITMP C .. External Functions .. REAL CONST EXTERNAL CONST C .. Intrinsic Functions .. INTRINSIC MOD C .. Data statements .. DATA XS/0./ C .. Executable Statements .. XSTART = XS IID = MOD(ID,10) GO TO (40,80,120,160,20,20,20,20,20, * 20,200,220,220,220,220,20,20,20, * 20,20,360,400,400,400,400,20,20, * 20,20,20,540,580,600,640,660,680, * 20,20,20,20,700,740,760,780,800, * 20,20,20,20,20,840,860,880,900, * 920) ID 20 IOUT = CONST(3) WRITE (IOUT,FMT=99999) ID STOP C C C PROBLEM CLASS A - LINEAR WITH REAL EIGENVALUES C C 40 CONTINUE CP PROBLEM A1 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 4 W(1) = 0.100E+01 W(2) = 0.100E+01 W(3) = 0.100E+01 W(4) = 0.100E+01 XEND = 20. HBEGIN = 1.E-2 HMAX = 20. DO 60 I = 1, N Y(I) = 1. 60 CONTINUE GO TO 940 C 80 CONTINUE CP PROBLEM A2 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 9 W(1) = 0.100E+00 W(2) = 0.200E+00 W(3) = 0.300E+00 W(4) = 0.400E+00 W(5) = 0.500E+00 W(6) = 0.600E+00 W(7) = 0.700E+00 W(8) = 0.800E+00 W(9) = 0.900E+00 XEND = 120. HBEGIN = 5.E-4 HMAX = 120. DO 100 I = 1, N Y(I) = 0. 100 CONTINUE GO TO 940 C 120 CONTINUE CP PROBLEM A3 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 4 W(1) = 0.100E+01 W(2) = 0.100E+01 W(3) = 0.782E+01 W(4) = 0.100E+01 HBEGIN = 1.E-5 XEND = 20. HMAX = 20. DO 140 I = 1, N Y(I) = 1. 140 CONTINUE GO TO 940 C 160 CONTINUE CP PROBLEM A4 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 10 W(1) = 0.100E+01 W(2) = 0.100E+01 W(3) = 0.100E+01 W(4) = 0.100E+01 W(5) = 0.100E+01 W(6) = 0.100E+01 W(7) = 0.100E+01 W(8) = 0.100E+01 W(9) = 0.100E+01 W(10) = 0.100E+01 XEND = 1. HBEGIN = 1.E-5 HMAX = 1. DO 180 I = 1, N Y(I) = 1. 180 CONTINUE GO TO 940 C C PROBLEM CLASS B - LINEAR WITH NON-REAL EIGENVALUES C C 200 CONTINUE CP PROBLEM B1 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 4 W(1) = 0.100E+01 W(2) = 0.859E+01 W(3) = 0.100E+01 W(4) = 0.322E+02 XEND = 20. HBEGIN = 7.E-3 HMAX = 20. Y(1) = 1. Y(2) = 0. Y(3) = 1. Y(4) = 0. GO TO 940 C 220 CONTINUE CP PROBLEM B2, B3, B4, B5 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 6 ITMP = IID - 1 GO TO (240,260,280,300) ITMP 240 CONTINUE W(1) = 0.100E+01 W(2) = 0.100E+01 W(3) = 0.100E+01 W(4) = 0.100E+01 W(5) = 0.100E+01 W(6) = 0.100E+01 GO TO 320 260 CONTINUE W(1) = 0.100E+01 W(2) = 0.100E+01 W(3) = 0.100E+01 W(4) = 0.100E+01 W(5) = 0.100E+01 W(6) = 0.100E+01 GO TO 320 280 CONTINUE W(1) = 0.112E+01 W(2) = 0.100E+01 W(3) = 0.100E+01 W(4) = 0.100E+01 W(5) = 0.100E+01 W(6) = 0.100E+01 GO TO 320 300 CONTINUE W(1) = 0.131E+01 W(2) = 0.112E+01 W(3) = 0.100E+01 W(4) = 0.100E+01 W(5) = 0.100E+01 W(6) = 0.100E+01 320 CONTINUE XEND = 20. HBEGIN = 1.E-2 HMAX = 20. DO 340 I = 1, N Y(I) = 1. 340 CONTINUE GO TO 940 C C PROBLEM CLASS C - NON-LINEAR COUPLING FROM C STEADY STATE TO TRANSIENT C C 360 CONTINUE CP PROBLEM C1 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 4 W(1) = 0.102E+01 W(2) = 0.103E+01 W(3) = 0.100E+01 W(4) = 0.100E+01 XEND = 20. HBEGIN = 1.E-2 HMAX = 20. DO 380 I = 1, N Y(I) = 1. 380 CONTINUE GO TO 940 C 400 CONTINUE CP PROBLEM C2, C3, C4, C5 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 4 ITMP = IID - 1 GO TO (420,440,460,480) ITMP 420 CONTINUE W(1) = 0.200E+01 W(2) = 0.100E+01 W(3) = 0.100E+01 W(4) = 0.100E+01 GO TO 500 440 CONTINUE W(1) = 0.200E+01 W(2) = 0.100E+01 W(3) = 0.100E+01 W(4) = 0.100E+01 GO TO 500 460 CONTINUE W(1) = 0.200E+01 W(2) = 0.400E+01 W(3) = 0.200E+02 W(4) = 0.420E+03 GO TO 500 480 CONTINUE W(1) = 0.200E+01 W(2) = 0.800E+01 W(3) = 0.136E+03 W(4) = 0.371E+05 500 CONTINUE XEND = 20. HBEGIN = 1.E-2 HMAX = 20. DO 520 I = 1, N Y(I) = 1. 520 CONTINUE GO TO 940 C C PROBLEM CLASS D - NON-LINEAR WITH REAL EIGENVALUES C C 540 CONTINUE CP PROBLEM D1 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 3 W(1) = 0.223E+02 W(2) = 0.271E+02 W(3) = 0.400E+03 XEND = 400. HBEGIN = 1.7E-2 HMAX = 400. DO 560 I = 1, N Y(I) = 0. 560 CONTINUE GO TO 940 C 580 CONTINUE CP PROBLEM D2 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 3 W(1) = 0.100E+01 W(2) = 0.365E+00 W(3) = 0.285E+02 XEND = 40. HBEGIN = 1.E-5 HMAX = 40. Y(1) = 1. Y(2) = 0. Y(3) = 0. GO TO 940 C 600 CONTINUE CP PROBLEM D3 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 4 W(1) = 0.100E+01 W(2) = 0.100E+01 W(3) = 0.360E+00 W(4) = 0.485E+00 XEND = 20. HBEGIN = 2.5E-5 HMAX = 20. DO 620 I = 1, 2 Y(I) = 1. Y(I+2) = 0. 620 CONTINUE GO TO 940 C 640 CONTINUE CP PROBLEM D4 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 3 W(1) = 0.100E+01 W(2) = 0.142E+01 W(3) = 0.371E-05 XEND = 50. HBEGIN = 2.9E-4 HMAX = 50. Y(1) = 1. Y(2) = 1. Y(3) = 0. GO TO 940 C 660 CONTINUE CP PROBLEM D5 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 2 W(1) = 0.992E+00 W(2) = 0.984E+00 XEND = 1.E2 HBEGIN = 1.E-4 HMAX = 1.E2 Y(1) = 0. Y(2) = 0. GO TO 940 C 680 CONTINUE CP PROBLEM D6 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 3 W(1) = 0.100E+01 W(2) = 0.148E+00 W(3) = 0.577E-07 XEND = 1. HBEGIN = 3.3E-8 HMAX = 1. Y(1) = 1. Y(2) = 0. Y(3) = 0. GO TO 940 C C PROBLEM CLASS E - NON-LINEAR WITH NON-REAL EIGENVALUES C C 700 CONTINUE CP PROBLEM E1 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 4 W(1) = 0.100E-07 W(2) = 0.223E-06 W(3) = 0.132E-04 W(4) = 0.171E-02 XEND = 1. HBEGIN = 6.8E-3 HMAX = 1. DO 720 I = 1, N Y(I) = 0. 720 CONTINUE GO TO 940 C 740 CONTINUE CP PROBLEM E2 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 2 W(1) = 0.202E+01 W(2) = 0.764E+01 XEND = 1.E1 HBEGIN = 1.E-3 HMAX = 1.E1 Y(1) = 2. Y(2) = 0. GO TO 940 C 760 CONTINUE CP PROBLEM E3 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 3 W(1) = 0.163E+01 W(2) = 0.160E+01 W(3) = 0.263E+02 XEND = 5.E2 HBEGIN = .2E-1 HMAX = 5.E2 Y(1) = 1. Y(2) = 1. Y(3) = 0. GO TO 940 C 780 CONTINUE CP PROBLEM E4 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 4 W(1) = 0.288E+02 W(2) = 0.295E+02 W(3) = 0.155E+02 W(4) = 0.163E+02 XEND = 1.E3 HBEGIN = 1.E-3 HMAX = 1.E3 Y(1) = 0. Y(2) = -2. Y(3) = -1. Y(4) = -1. GO TO 940 C 800 CONTINUE CP PROBLEM E5 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 4 W(1) = 0.176E-02 W(2) = 0.146E-09 W(3) = 0.827E-11 W(4) = 0.138E-09 XEND = 1.E3 HBEGIN = 5.E-5 HMAX = 1.E3 Y(1) = 1.76E-3 DO 820 I = 2, N Y(I) = 0. 820 CONTINUE GO TO 940 C C PROBLEM CLASS F - CHEMICAL KINETICS EQUATIONS C C 840 CONTINUE CP PROBLEM F1 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 4 W(1) = 0.121E+04 W(2) = 0.835E-01 W(3) = 0.121E+04 W(4) = 0.100E+00 HMAX = 1.E3 HBEGIN = 1.E-4 XEND = 1.E3 Y(1) = 761. Y(2) = 0. Y(3) = 600. Y(4) = .1 GO TO 940 C 860 CONTINUE CP PROBLEM F2 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 2 W(1) = 0.100E+01 W(2) = 0.253E-02 HMAX = 240. HBEGIN = 1.E-2 XEND = 240. Y(1) = 1.0 Y(2) = 0. GO TO 940 C 880 CONTINUE CP PROBLEM F3 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 5 W(1) = 0.400E-05 W(2) = 0.100E-05 W(3) = 0.374E-08 W(4) = 0.765E-06 W(5) = 0.324E-05 HBEGIN = 1.E-6 HMAX = 100. XEND = 100. Y(1) = 4.E-6 Y(2) = 1.E-6 Y(3) = 0.0 Y(4) = 0.0 Y(5) = 0.0 GO TO 940 C 900 CONTINUE CP PROBLEM F4 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 3 W(1) = 0.118E+06 W(2) = 0.177E+04 W(3) = 0.313E+05 HBEGIN = 1.E-3 HMAX = 50. XEND = 300. Y(1) = 4. Y(2) = 1.1 Y(3) = 4. GO TO 940 C 920 CONTINUE CP PROBLEM F5 FCNTIM = 0.0 JACTIM = 0.0 LUDTIM = 0.0 N = 4 W(1) = 0.336E-06 W(2) = 0.826E-02 W(3) = 0.619E-02 W(4) = 0.955E-05 HBEGIN = 1.E-7 HMAX = 100. XEND = 100. Y(1) = 3.365E-7 Y(2) = 8.261E-3 Y(3) = 1.642E-3 Y(4) = 9.380E-6 940 CONTINUE IF (IWT.LT.0) GO TO 980 DO 960 I = 1, N Y(I) = Y(I)/W(I) 960 CONTINUE 980 CONTINUE RETURN C 99999 FORMAT ('0AN INVALID INTERNAL PROBLEM ID OF ',I4, * ' WAS FOUND BY THE IVALU ROUTINE', * /' RUN TERMINATED. CHECK THE DATA AND THE PARCHK ROUTINE!') END SUBROUTINE EVALU(Y,N,W,IWT,ID) C C********************************************************************** C C ROUTINE TO PROVIDE THE 'TRUE' SOLUTION OF THE DIFFERENTIAL C EQUATION EVALUATED AT THE ENDPOINT OF THE INTEGRATION. C C 1986 REVISION: SOME VERY SMALL CONSTANTS HAVE BEEN RECAST IN THE C (NOT SO SMALL CONST)/(1.E38) TO AVOID COMPILE-TIME UNDERFLOW ERROR C IT IS ASSUMED 1E+38 WON'T OVERFLOW. C PARAMETER (OUTPUT) C Y - THE TRUE SOLUTION VECTOR EVALUATED AT THE ENDPOINT C C PARAMETERS (INPUT) C N - DIMENSION OF THE PROBLEM C W - VECTOR OF WEIGHTS USED TO SCALE THE PROBLEM C IF THIS OPTION IS SELECTED C IWT - FLAG USED TO SIGNAL WHEN THE SCALED PROBLEM IS C BEING SOLVED C ID - FLAG USED TO INDICATE WHICH EQUATION IS BEING C SOLVED C C********************************************************************** C .. Parameters .. REAL TENE38 PARAMETER (TENE38=1.E38) C .. Scalar Arguments .. INTEGER ID, IWT, N C .. Array Arguments .. REAL W(20), Y(20) C .. Local Scalars .. INTEGER I C .. Executable Statements .. GO TO (20,40,60,80,620,620,620,620,620, * 620,100,120,140,160,180,620,620,620, * 620,620,200,220,240,260,280,620,620, * 620,620,620,300,320,340,360,380,400, * 620,620,620,620,420,440,460,480,500, * 620,620,620,620,620,520,540,560,580, * 600,620,620,620,620,620) ID GO TO 620 C PROBLEM CLASS A C C PROBLEM A1 20 Y(1) = 4.539992969929191E-05 Y(2) = 2.061153036149920E-09 Y(3) = 2.823006338263857E-18/TENE38 Y(4) = 5.235792540515384E-14/TENE38 GO TO 620 C C PROBLEM A2 40 Y(1) = 9.999912552999704E-02 Y(2) = 1.999982511586291E-01 Y(3) = 2.999975543202422E-01 Y(4) = 3.999971057541257E-01 Y(5) = 4.999969509963023E-01 Y(6) = 5.999971057569546E-01 Y(7) = 6.999975543256127E-01 Y(8) = 7.999982511659962E-01 Y(9) = 8.999991255386128E-01 GO TO 620 C C PROBLEM A3 60 Y(1) = -1.353352661867235E-03 Y(2) = 1.368526917891521E-02 Y(3) = 1.503725348455117E+00 Y(4) = 1.353352832366099E-01 GO TO 620 C C PROBLEM A4 80 Y(1) = 3.678794411714325E-01 Y(2) = 1.265870722340194E-14 Y(3) = 1.911533219339204E-04/TENE38 Y(4) = 2.277441666729596E-17/TENE38 Y(5) = 0.0 Y(6) = 0.0 Y(7) = 0.0 Y(8) = 0.0 Y(9) = 0.0 Y(10) = 0.0 GO TO 620 C PROBLEM CLASS B C C PROBLEM B1 100 Y(1) = 1.004166730990124E-09 Y(2) = 1.800023280346500E-08 Y(3) = 0.0 Y(4) = -6.042962877027475E-03/TENE38/TENE38 GO TO 620 C C PROBLEM B2 120 Y(1) = 6.181330838820067E-31 Y(2) = 8.963657877626303E-31 Y(3) = 2.738406773453261E-27 Y(4) = 2.061153063164016E-09 Y(5) = 4.539992973654118E-05 Y(6) = 1.353352832365270E-01 GO TO 620 C C PROBLEM B3 140 Y(1) = -1.076790816984970E-28 Y(2) = 5.455007683862160E-28 Y(3) = 2.738539964946867E-27 Y(4) = 2.061153071123456E-09 Y(5) = 4.539992974611305E-05 Y(6) = 1.353352832365675E-01 GO TO 620 C C PROBLEM B4 160 Y(1) = 1.331242472678293E-22 Y(2) = -2.325916064237926E-22 Y(3) = 1.517853928534857E-35 Y(4) = 2.061152428936651E-09 Y(5) = 4.539992963392291E-05 Y(6) = 1.353352832363442E-01 GO TO 620 C C PROBLEM B5 180 Y(1) = -3.100634584292190E-14 Y(2) = 3.862788998076547E-14 Y(3) = 1.804851385304217E-35 Y(4) = 2.061153622425655E-09 Y(5) = 4.539992976246673E-05 Y(6) = 1.353352832366126E-01 GO TO 620 C PROBLEM CLASS C C C PROBLEM C1 200 Y(1) = 4.003223925456179E-04 Y(2) = 4.001600000000000E-04 Y(3) = 4.000000000000000E-04 Y(4) = 2.000000000000000E-02 GO TO 620 C C PROBLEM C2 220 Y(1) = 1.999999997938994E+00 Y(2) = 3.999999990839974E-02 Y(3) = 4.001599991537078E-02 Y(4) = 4.003201271914461E-02 GO TO 620 C C PROBLEM C3 240 Y(1) = 1.999999997939167E+00 Y(2) = 3.999999990840744E-01 Y(3) = 4.159999990793773E-01 Y(4) = 4.333055990159567E-01 GO TO 620 C C PROBLEM C4 260 Y(1) = 1.999999997938846E+00 Y(2) = 3.999999990839318E+00 Y(3) = 1.999999991637941E+01 Y(4) = 4.199999965390368E+02 GO TO 620 C C PROBLEM C5 280 Y(1) = 1.999999997938846E+00 Y(2) = 7.999999981678634E+00 Y(3) = 1.359999993817714E+02 Y(4) = 3.712799965967762E+04 GO TO 620 C PROBLEM CLASS D C C PROBLEM D1 300 Y(1) = 2.224222010616901E+01 Y(2) = 2.711071334484136E+01 Y(3) = 3.999999999999999E+02 GO TO 620 C C PROBLEM D2 320 Y(1) = 7.158270687193941E-01 Y(2) = 9.185534764557338E-02 Y(3) = 2.841637457458413E+01 GO TO 620 C C PROBLEM D3 340 Y(1) = 6.397604446889910E-01 Y(2) = 5.630850708287990E-03 Y(3) = 3.602395553110090E-01 Y(4) = 3.170647969903515E-01 GO TO 620 C C PROBLEM D4 360 Y(1) = 5.976546980673215E-01 Y(2) = 1.402343408546138E+00 Y(3) = -1.893386540441913E-06 GO TO 620 C C PROBLEM D5 380 Y(1) = -9.916420698713913E-01 Y(2) = 9.833363588544478E-01 GO TO 620 C C PROBLEM D6 400 Y(1) = 8.523995440749948E-01 Y(2) = 1.476003981941319E-01 Y(3) = 5.773087333950041E-08 GO TO 620 C PROBLEM CLASS E C C PROBLEM E1 420 Y(1) = 1.000000000000012E-08 Y(2) = -1.625323873316817E-19 Y(3) = 2.025953375595861E-17 Y(4) = -1.853149807630002E-15 GO TO 620 C C PROBLEM E2 440 Y(1) = -1.158701266031984E+00 Y(2) = 4.304698089780476E-01 GO TO 620 C C PROBLEM E3 460 Y(1) = 4.253052197643089E-03 Y(2) = 5.317019548450387E-03 Y(3) = 2.627647748753926E+01 GO TO 620 C C PROBLEM E4 480 Y(1) = 1.999999977523654E+01 Y(2) = -2.000000022476345E+01 Y(3) = -2.247634567084293E-07 Y(4) = 2.247634567084293E-07 GO TO 620 C C PROBLEM E5 500 Y(1) = 1.618076919919600E-03 Y(2) = 1.382236955418478E-10 Y(3) = 8.251573436034144E-12 Y(4) = 1.299721221058136E-10 GO TO 620 C PROBLEM CLASS F C C PROBLEM F1 520 Y(1) = 1.211129474696585E+03 Y(2) = 1.271123619113051E-05 Y(3) = 1.208637804660361E+03 Y(4) = 3.241981171933418E-04 GO TO 620 C C PROBLEM F2 540 Y(1) = 3.912699122292088E-01 Y(2) = 1.329964166084866E-03 GO TO 620 C C PROBLEM F3 560 Y(1) = 3.235910070806680E-13 Y(2) = 2.360679774997897E-07 Y(3) = 7.639319089351045E-14 Y(4) = 7.639319461070194E-07 Y(5) = 3.236067653908783E-06 GO TO 620 C C PROBLEM F4 580 Y(1) = 4.418303324022590E+00 Y(2) = 1.290244712916425E+00 Y(3) = 3.019282584050490E+00 GO TO 620 C C PROBLEM F5 600 Y(1) = 1.713564284690712E-07 Y(2) = 3.713563071160676E-03 Y(3) = 6.189271785267793E-03 Y(4) = 9.545143571530929E-06 620 CONTINUE IF (IWT.LT.0) GO TO 660 DO 640 I = 1, N Y(I) = Y(I)/W(I) 640 CONTINUE 660 CONTINUE RETURN END SUBROUTINE FCN(X,Y,YP) C C********************************************************************** C ROUTINE TO EVALUATE THE DERIVATIVE F(X,Y) CORRESPONDING TO THE C DIFFERENTIAL EQUATION: C DY/DX = F(X,Y) . C THE ROUTINE STORES THE VECTOR OF DERIVATIVES IN YP(*). THE C PARTICULAR EQUATION BEING INTEGRATED IS INDICATED BY THE C VALUE OF THE FLAG ID WHICH IS PASSED THROUGH COMMON. THE C DIFFERENTIAL EQUATION IS SCALED BY THE WEIGHT VECTOR W(*) C IF THIS OPTION HAS BEEN SELECTED (IF SO IT IS SIGNALLED C BY THE FLAG IWT). C C********************************************************************* C CC*******+*********+*********+*********+*********+*********+*********+** C COMMON AREAS C********+*********+*********+*********+*********+*********+*********+** C5 C6 C .. Scalar Arguments .. REAL X C .. Array Arguments .. REAL Y(20), YP(20) C .. Scalars in Common .. INTEGER ID, IWT, N, NFCN, NJAC, NLUD C .. Arrays in Common .. REAL W(20) C .. Local Scalars .. REAL F, Q, S, SUM, T, TEMP, XTEMP INTEGER I, IID C .. Local Arrays .. REAL BPARM(4), CPARM(4), VECT1(4), VECT2(4), YTEMP(20) C .. Intrinsic Functions .. INTRINSIC REAL, EXP, SIN, MOD C .. Common blocks .. COMMON /STCOM5/W, IWT, N, ID COMMON /STCOM6/NFCN, NJAC, NLUD C .. Data statements .. CE DATA BPARM/3., 8., 25., 1.E2/ DATA CPARM/1.E-1, 1., 1.E1, 2.E1/ C .. Executable Statements .. NFCN = NFCN + 1 IF (IWT.LT.0) GO TO 40 DO 20 I = 1, N YTEMP(I) = Y(I) Y(I) = Y(I)*W(I) 20 CONTINUE 40 CONTINUE IID = MOD(ID,10) GO TO (60,80,120,140,640,640,640,640,640, * 640,180,200,200,200,200,640,640,640, * 640,640,220,240,240,240,240,640,640, * 640,640,640,260,280,300,320,340,360, * 640,640,640,640,380,400,420,440,520, * 640,640,640,640,640,540,560,580,600, * 620) ID GO TO 640 C C PROBLEM CLASS A - LINEAR WITH REAL EIGENVALUES C C C PROBLEM A1 60 YP(1) = -.5*Y(1) YP(2) = -1.*Y(2) YP(3) = -1.E2*Y(3) YP(4) = -9.E1*Y(4) GO TO 640 C C PROBLEM A2 80 YP(1) = -1.8E3*Y(1) + 9.E2*Y(2) DO 100 I = 2, 8 YP(I) = Y(I-1) - 2.*Y(I) + Y(I+1) 100 CONTINUE YP(9) = 1.E3*Y(8) - 2.E3*Y(9) + 1.E3 GO TO 640 C C PROBLEM A3 120 YP(1) = -1.E4*Y(1) + 1.E2*Y(2) - 1.E1*Y(3) + 1.*Y(4) YP(2) = -1.E3*Y(2) + 1.E1*Y(3) - 1.E1*Y(4) YP(3) = -1.*Y(3) + 1.E1*Y(4) YP(4) = -1.E-1*Y(4) GO TO 640 C C PROBLEM A4 140 DO 160 I = 1, 10 YP(I) = -REAL(I)**5*Y(I) 160 CONTINUE GO TO 640 C C PROBLEM CLASS B - LINEAR WITH NON-REAL EIGENVALUES C C C PROBLEM B1 180 YP(1) = -Y(1) + Y(2) YP(2) = -1.E2*Y(1) - Y(2) YP(3) = -1.E2*Y(3) + Y(4) YP(4) = -1.E4*Y(3) - 1.E2*Y(4) GO TO 640 C C PROBLEMS B2, B3, B4, B5 200 YP(1) = -1.E1*Y(1) + BPARM(IID-1)*Y(2) YP(2) = -BPARM(IID-1)*Y(1) - 1.E1*Y(2) YP(3) = -4.*Y(3) YP(4) = -1.*Y(4) YP(5) = -.5*Y(5) YP(6) = -.1*Y(6) GO TO 640 C C PROBLEM CLASS C - NON-LINEAR COUPLING FROM C STEADY STATE TO TRANSIENT C C C PROBLEM C1 220 YP(1) = -Y(1) + (Y(2)*Y(2)+Y(3)*Y(3)+Y(4)*Y(4)) YP(2) = -1.E1*Y(2) + 1.E1*(Y(3)*Y(3)+Y(4)*Y(4)) YP(3) = -4.E1*Y(3) + 4.E1*Y(4)*Y(4) YP(4) = -1.E2*Y(4) + 2. GO TO 640 C C PROBLEMS C2, C3, C4, C5 240 YP(1) = -Y(1) + 2. YP(2) = -1.E1*Y(2) + CPARM(IID-1)*Y(1)*Y(1) YP(3) = -4.E1*Y(3) + (Y(1)*Y(1)+Y(2)*Y(2))*CPARM(IID-1)*4. YP(4) = (Y(1)*Y(1)+Y(2)*Y(2)+Y(3)*Y(3))*CPARM(IID-1)*1.E1 - * 1.E2*Y(4) GO TO 640 C C PROBLEM CLASS D - NON-LINEAR WITH REAL EIGENVALUES C C C PROBLEM D1 260 YP(1) = .2*Y(2) - .2*Y(1) YP(2) = 1.E1*Y(1) - (6.E1-.125*Y(3))*Y(2) + .125*Y(3) YP(3) = 1. GO TO 640 C C PROBLEM D2 280 YP(1) = -.04*Y(1) + .01*Y(2)*Y(3) YP(2) = 4.E2*Y(1) - 1.E2*Y(2)*Y(3) - 3.E3*Y(2)**2 YP(3) = 3.E1*Y(2)**2 GO TO 640 C C PROBLEM D3 300 YP(1) = Y(3) - 1.E2*Y(1)*Y(2) YP(3) = -YP(1) YP(4) = -Y(4) + 1.E4*Y(2)**2 YP(2) = YP(1) - YP(4) + Y(4) - 1.E4*Y(2)**2 GO TO 640 C C PROBLEM D4 320 YP(1) = -.013*Y(1) - 1.E3*Y(1)*Y(3) YP(2) = -2.5E3*Y(2)*Y(3) YP(3) = YP(1) + YP(2) GO TO 640 C C PROBLEM D5 340 XTEMP = .01 + Y(1) + Y(2) YP(1) = .01 - XTEMP*(1.+(Y(1)+1.E3)*(Y(1)+1.)) YP(2) = .01 - XTEMP*(1.+Y(2)**2) GO TO 640 C C PROBLEM D6 360 YP(1) = -Y(1) + 1.E8*Y(3)*(1.-Y(1)) YP(2) = -1.E1*Y(2) + 3.E7*Y(3)*(1.-Y(2)) YP(3) = -YP(1) - YP(2) GO TO 640 C C PROBLEM CLASS E - NON-LINEAR WITH NON-REAL EIGENVALUES C C C PROBLEM E1 380 YP(1) = Y(2) YP(2) = Y(3) YP(3) = Y(4) YP(4) = (Y(1)**2-SIN(Y(1))-1.E8)*Y(1) + (Y(2)*Y(3)/(Y(1)**2+1.) * -4.E6)*Y(2) + (1.-6.E4)*Y(3) + (1.E1*EXP(-Y(4)**2)-4.E2) * *Y(4) + 1. GO TO 640 C C PROBLEM E2 400 YP(1) = Y(2) YP(2) = 5.*Y(2) - 5.*Y(1)*Y(1)*Y(2) - Y(1) GO TO 640 C C PROBLEM E3 420 YP(1) = -55.*Y(1) - Y(3)*Y(1) + 65.*Y(2) YP(2) = .785E-1*Y(1) - .785E-1*Y(2) YP(3) = .1*Y(1) GO TO 640 C C PROBLEM E4 440 SUM = Y(1) + Y(2) + Y(3) + Y(4) DO 460 I = 1, 4 VECT2(I) = -Y(I) + .5*SUM 460 CONTINUE VECT1(1) = .5*(VECT2(1)**2-VECT2(2)**2) VECT1(2) = VECT2(1)*VECT2(2) VECT1(3) = VECT2(3)**2 VECT1(4) = VECT2(4)**2 TEMP = -1.E1*VECT2(1) - 1.E1*VECT2(2) VECT2(2) = 1.E1*VECT2(1) - 1.E1*VECT2(2) VECT2(1) = TEMP VECT2(3) = 1.E3*VECT2(3) VECT2(4) = 1.E-2*VECT2(4) SUM = 0. DO 480 I = 1, 4 SUM = SUM + VECT1(I) - VECT2(I) 480 CONTINUE DO 500 I = 1, 4 YP(I) = VECT2(I) - VECT1(I) + .5*SUM 500 CONTINUE GO TO 640 C C PROBLEM E5 520 XTEMP = -7.89E-10*Y(1) YP(1) = XTEMP - 1.1E7*Y(1)*Y(3) YP(2) = -XTEMP - 1.13E9*Y(2)*Y(3) YP(4) = 1.1E7*Y(1)*Y(3) - 1.13E3*Y(4) YP(3) = YP(2) - YP(4) GO TO 640 C C PROBLEM CLASS F - CHEMICAL KINETICS EQUATIONS C C C PROBLEM F1 540 TEMP = 6.E-3*EXP(20.7-1.5E4/Y(1)) YP(1) = 1.3*(Y(3)-Y(1)) + 1.04E4*TEMP*Y(2) YP(2) = 1.88E3*(Y(4)-Y(2)*(1.+TEMP)) YP(3) = 1752. - 269.*Y(3) + 267.*Y(1) YP(4) = .1 + 320.*Y(2) - 321.*Y(4) GO TO 640 C C PROBLEM F2 560 YP(1) = -Y(1) - Y(1)*Y(2) + 294.*Y(2) YP(2) = Y(1)*(1.-Y(2))/98. - 3.*Y(2) GO TO 640 C C PROBLEM F3 580 YP(1) = -1.0E7*Y(2)*Y(1) + 1.E1*Y(3) YP(2) = -1.0E7*Y(2)*Y(1) - 1.E7*Y(2)*Y(5) + 1.E1*Y(3) + 1.E1*Y(4) YP(3) = 1.0E7*Y(2)*Y(1) - 1.001E4*Y(3) + 1.E-3*Y(4) YP(4) = 1.E4*Y(3) - 1.0001E1*Y(4) + 1.E7*Y(2)*Y(5) YP(5) = 1.E1*Y(4) - 1.E7*Y(2)*Y(5) GO TO 640 C C PROBLEM F4 600 S = 77.27 T = 0.161 Q = 8.375E-6 F = 1. YP(1) = S*(Y(2)-Y(1)*Y(2)+Y(1)-Q*Y(1)*Y(1)) YP(2) = (-Y(2)-Y(1)*Y(2)+F*Y(3))/S YP(3) = T*(Y(1)-Y(3)) GO TO 640 C C PROBLEM F5 620 YP(1) = -3.E11*Y(1)*Y(2) + 1.2E8*Y(4) - 9.E11*Y(1)*Y(3) YP(2) = -3.E11*Y(1)*Y(2) + 2.E7*Y(4) YP(3) = -9.E11*Y(1)*Y(3) + 1.E8*Y(4) YP(4) = 3.E11*Y(1)*Y(2) - 1.2E8*Y(4) + 9.E11*Y(1)*Y(3) 640 CONTINUE IF (IWT.LT.0) GO TO 680 DO 660 I = 1, N YP(I) = YP(I)/W(I) Y(I) = YTEMP(I) 660 CONTINUE 680 CONTINUE RETURN END SUBROUTINE PDERV(X,Y,DY) C********************************************************************** C C ROUTINE TO EVALUATE THE JACOBIAN MATRIX OF PARTIAL DERIVATIVES C CORRESPONDING TO THE DIFFERENTIAL EQUATION: C DY/DX = F(X,Y). C THE N**2 ELEMENTS OF THE ARRAY DY(*) ARE ASSIGNED THE VALUE OF C THE JACOBIAN MATRIX WITH ELEMENT I+(J-1)*N BEING ASSIGNED THE C VALUE OF DF(I)/DY(J). THE PARTICULAR EQUATION BEING INTEGRATED C IS INDICATED BY THE VALUE OF THE FLAG ID WHICH IS PASSED THROUGH C COMMON. IF A SCALED DIFFERENTIAL EQUATION IS BEING SOLVED (AS C SIGNALLED IWT) THE ELEMENTS OF THE JACOBIAN ARE SCALED ACCORDING- C LY BY THE WEIGHT VECTOR W(*). C C********************************************************************** CC*******+*********+*********+*********+*********+*********+*********+** C COMMON AREAS C********+*********+*********+*********+*********+*********+*********+** C5 C6 C .. Scalar Arguments .. REAL X C .. Array Arguments .. REAL DY(400), Y(20) C .. Scalars in Common .. INTEGER ID, IWT, N, NFCN, NJAC, NLUD C .. Arrays in Common .. REAL W(20) C .. Local Scalars .. REAL F, Q, S, SUM, T, TEMP, XTEMP1, XTEMP2, XTEMP3 INTEGER I, IID, ITMP, J, L C .. Local Arrays .. REAL BPARM(4), CPARM(4), VECT2(4), YTEMP(20) C .. Intrinsic Functions .. INTRINSIC REAL, COS, EXP, SIN, MOD C .. Common blocks .. COMMON /STCOM5/W, IWT, N, ID COMMON /STCOM6/NFCN, NJAC, NLUD C .. Data statements .. CE DATA BPARM/3., 8., 25., 1.E2/ DATA CPARM/1.E-1, 1., 1.E1, 2.E1/ C .. Executable Statements .. NJAC = NJAC + 1 IF (IWT.LT.0) GO TO 40 DO 20 I = 1, N YTEMP(I) = Y(I) Y(I) = Y(I)*W(I) 20 CONTINUE 40 CONTINUE IID = MOD(ID,10) GO TO (60,100,160,200,980,980,980,980,980, * 980,260,300,300,300,300,980,980,980, * 980,980,340,380,380,380,380,980,980, * 980,980,980,420,440,460,480,520,540, * 980,980,980,980,580,620,640,660,840, * 980,980,980,980,980,880,900,920,940, * 960) ID GO TO 980 C C PROBLEM CLASS A - LINEAR WITH REAL EIGENVALUES C C C PROBLEM A1 60 DO 80 I = 1, 16 DY(I) = 0. 80 CONTINUE DY(1) = -.5 DY(6) = -1. DY(11) = -1.E2 DY(16) = -9.E1 GO TO 980 C C PROBLEM A2 100 DO 120 I = 1, 81 DY(I) = 0. 120 CONTINUE DO 140 I = 2, 62, 10 DY(I) = 1. DY(I+9) = -2. DY(I+18) = 1. 140 CONTINUE DY(1) = -1.8E3 DY(10) = 9.E2 DY(72) = 1.E3 DY(81) = -2.E3 GO TO 980 C C PROBLEM A3 160 DO 180 I = 1, 16 DY(I) = 0. 180 CONTINUE DY(1) = -1.E4 DY(5) = 1.E2 DY(6) = -1.E3 DY(9) = -1.E1 DY(10) = 1.E1 DY(11) = -1. DY(13) = 1. DY(14) = -1.E1 DY(15) = 1.E1 DY(16) = -1.E-1 GO TO 980 C C PROBLEM A4 200 DO 220 I = 1, 100 DY(I) = 0. 220 CONTINUE DO 240 I = 1, 10 DY((I-1)*10+I) = -REAL(I)**5 240 CONTINUE GO TO 980 C C PROBLEM CLASS B - LINEAR WITH NON-REAL EIGENVALUES C C C PROBLEM B1 260 DO 280 I = 1, 16 DY(I) = 0. 280 CONTINUE DY(1) = -1. DY(2) = -1.E2 DY(5) = 1. DY(6) = -1. DY(11) = -1.E2 DY(12) = -1.E4 DY(15) = 1. DY(16) = -1.E2 GO TO 980 C C PROBLEMS B2, B3, B4, B5 300 DO 320 I = 1, 36 DY(I) = 0. 320 CONTINUE DY(1) = -1.E1 DY(2) = -BPARM(IID-1) DY(7) = BPARM(IID-1) DY(8) = -1.E1 DY(15) = -4. DY(22) = -1. DY(29) = -.5 DY(36) = -.1 GO TO 980 C C PROBLEM CLASS C - NON-LINEAR COUPLING FROM C STEADY STATE TO TRANSIENT C C C PROBLEM C1 340 DO 360 I = 1, 16 DY(I) = 0. 360 CONTINUE DY(1) = -1. DY(5) = 2.*Y(2) DY(6) = -1.E1 DY(9) = 2.*Y(3) DY(10) = 2.E1*Y(3) DY(11) = -4.E1 DY(13) = 2.*Y(4) DY(14) = 2.E1*Y(4) DY(15) = 8.E1*Y(4) DY(16) = -1.E2 GO TO 980 C C PROBLEMS C2, C3, C4, C5 380 DO 400 I = 1, 16 DY(I) = 0. 400 CONTINUE DY(1) = -1. DY(2) = 2.*Y(1)*CPARM(IID-1) DY(3) = 8.*Y(1)*CPARM(IID-1) DY(4) = 2.E1*Y(1)*CPARM(IID-1) DY(6) = -1.E1 DY(7) = 8.*Y(2)*CPARM(IID-1) DY(8) = 2.E1*Y(2)*CPARM(IID-1) DY(11) = -4.E1 DY(12) = 2.E1*Y(3)*CPARM(IID-1) DY(16) = -1.E2 GO TO 980 C C PROBLEM CLASS D - NON-LINEAR WITH REAL EIGENVALUES C C C PROBLEM D1 420 DY(1) = -.2 DY(2) = 1.E1 DY(3) = 0. DY(4) = .2 DY(5) = -6.E1 + .125*Y(3) DY(6) = 0. DY(7) = 0. DY(8) = .125*Y(2) + .125 DY(9) = 0. GO TO 980 C C PROBLEM D2 440 DY(1) = -4.E-2 DY(2) = 4.E2 DY(3) = 0. DY(4) = 1.E-2*Y(3) DY(5) = -1.E2*Y(3) - 6.E3*Y(2) DY(6) = 6.E1*Y(2) DY(7) = .1E-1*Y(2) DY(8) = -1.E2*Y(2) DY(9) = 0. GO TO 980 C C PROBLEM D3 460 DY(1) = -1.E2*Y(2) DY(2) = DY(1) DY(3) = -DY(1) DY(4) = 0. DY(5) = -1.E2*Y(1) DY(7) = -DY(5) DY(8) = 2.E4*Y(2) DY(6) = DY(5) - DY(8) DY(6) = DY(6) - 2.E4*Y(2) DY(9) = 1. DY(10) = 1. DY(11) = -1. DY(12) = 0. DY(13) = 0. DY(14) = 2. DY(15) = 0. DY(16) = -1. GO TO 980 C C PROBLEM D4 480 DY(1) = -.013 - 1.E3*Y(3) DY(2) = 0. DY(4) = 0. DY(5) = -2.5E3*Y(3) DY(7) = -1.E3*Y(1) DY(8) = -2.5E3*Y(2) DO 500 I = 3, 9, 3 DY(I) = DY(I-1) + DY(I-2) 500 CONTINUE GO TO 980 C C PROBLEM D5 520 XTEMP1 = Y(1) + 1.E3 XTEMP2 = Y(1) + 1. XTEMP3 = .01 + Y(1) + Y(2) DY(2) = -(1.+Y(2)**2) DY(3) = -(1.+XTEMP1*XTEMP2) DY(1) = -(-DY(3)+XTEMP3*(XTEMP1+XTEMP2)) DY(4) = -(2.*XTEMP3*Y(2)-DY(2)) GO TO 980 C C PROBLEM D6 540 DY(1) = -1. - 1.E8*Y(3) DY(2) = 0. DY(4) = 0. DY(5) = -1.E1 - 3.E7*Y(3) DY(7) = 1.E8*(1.-Y(1)) DY(8) = 3.E7*(1.-Y(2)) DO 560 I = 3, 9, 3 DY(I) = -DY(I-2) - DY(I-1) 560 CONTINUE GO TO 980 C C PROBLEM CLASS E - NON-LINEAR WITH NON-REAL EIGENVALUES C C C PROBLEM E1 580 DO 600 I = 1, 16 DY(I) = 0. 600 CONTINUE DY(5) = 1. DY(10) = 1. DY(15) = 1. XTEMP1 = Y(1) XTEMP2 = Y(2)/(XTEMP1**2+1.)**2 DY(4) = 3.*XTEMP1**2 - XTEMP1*COS(XTEMP1) - SIN(XTEMP1) - 1.E8 - * 2.*XTEMP1*Y(2)*Y(3)*XTEMP2 DY(8) = 2.*Y(3)*Y(2)/(1.+Y(1)**2) - 4.E6 DY(12) = Y(2)*Y(2)/(1.+Y(1)**2) + 1. - 6.E4 DY(16) = 1.E1*EXP(-Y(4)**2)*(1.-2.*Y(4)**2) - 4.E2 GO TO 980 C C PROBLEM E2 620 DY(1) = 0. DY(2) = -1.E1*Y(1)*Y(2) - 1. DY(3) = 1. DY(4) = 5. - 5.*Y(1)*Y(1) GO TO 980 C C PROBLEM E3 640 DY(1) = -55. - Y(3) DY(2) = .785E-1 DY(3) = 0.1 DY(4) = 65. DY(5) = -.785E-1 DY(6) = 0. DY(7) = -Y(1) DY(8) = 0. DY(9) = 0. GO TO 980 C C PROBLEM E4 660 SUM = Y(1) + Y(2) + Y(3) + Y(4) DO 680 I = 1, 4 VECT2(I) = -Y(I) + .5*SUM 680 CONTINUE DO 700 I = 1, 16 DY(I) = 0. 700 CONTINUE DY(1) = VECT2(1) + 1.E1 DY(2) = VECT2(2) - 1.E1 DY(5) = -DY(2) DY(6) = DY(1) DY(11) = 2.*VECT2(3) - 1.E3 DY(16) = 2.*VECT2(4) - 1.E-2 DO 760 I = 1, 4 SUM = 0. DO 720 J = 1, 4 L = I + (J-1)*4 SUM = SUM + DY(L) 720 CONTINUE DO 740 J = 1, 4 L = I + (J-1)*4 DY(L) = -DY(L) + .5*SUM 740 CONTINUE 760 CONTINUE DO 820 J = 1, 4 SUM = 0. DO 780 I = 1, 4 L = I + (J-1)*4 SUM = SUM + DY(L) 780 CONTINUE DO 800 I = 1, 4 L = I + (J-1)*4 DY(L) = -DY(L) + .5*SUM 800 CONTINUE 820 CONTINUE GO TO 980 C C PROBLEM E5 840 DY(1) = -7.89E-10 - 1.1E7*Y(3) DY(2) = 7.89E-10 DY(4) = 1.1E7*Y(3) DY(5) = 0. DY(6) = -1.13E9*Y(3) DY(8) = 0. DY(9) = -1.1E7*Y(1) DY(10) = -1.13E9*Y(2) DY(12) = -DY(9) DY(13) = 0. DY(14) = 0. DY(16) = -1.13E3 DO 860 I = 3, 15, 4 DY(I) = DY(I-1) - DY(I+1) 860 CONTINUE GO TO 980 C C PROBLEM CLASS F - CHEMICAL KINETICS EQUATIONS C C C PROBLEM F1 880 TEMP = 90.*EXP(20.7-1.5E4/Y(1))/Y(1)**2 DY(1) = -1.3 + 1.04E4*TEMP*Y(2) DY(2) = -1.88E3*Y(2)*TEMP DY(3) = 267. DY(4) = 0. TEMP = 6.E-3*EXP(20.7-1.5E4/Y(1)) DY(5) = 1.04E4*TEMP DY(6) = -1.88E3*(1.+TEMP) DY(7) = 0. DY(8) = 320. DY(9) = 1.3 DY(10) = 0. DY(11) = -269. DY(12) = 0.0 DY(13) = 0.0 DY(14) = 1.88E3 DY(15) = 0.0 DY(16) = -321.0 GO TO 980 C C PROBLEM F2 900 DY(1) = -1. - Y(2) DY(2) = (1.-Y(2))/98. DY(3) = -Y(1) + 294. DY(4) = -Y(1)/98. - 3. GO TO 980 C C PROBLEM F3 920 DY(1) = -1.E7*Y(2) DY(2) = -1.E7*Y(2) DY(3) = 1.E7*Y(2) DY(4) = 0.0 DY(5) = 0.0 DY(6) = -1.E7*Y(1) DY(7) = -1.E7*Y(1) - 1.E7*Y(5) DY(8) = 1.E7*Y(1) DY(9) = 1.E7*Y(5) DY(10) = -1.E7*Y(5) DY(11) = 1.E1 DY(12) = 1.E1 DY(13) = -1.001E4 DY(14) = 1.E4 DY(15) = 0.0 DY(16) = 0.0 DY(17) = 1.E1 DY(18) = 1.E-3 DY(19) = -1.0001E1 DY(20) = 1.E1 DY(21) = 0.0 DY(22) = -1.E7*Y(2) DY(23) = 0.0 DY(24) = 1.E7*Y(2) DY(25) = -1.0E7*Y(2) GO TO 980 C C PROBLEM F4 940 S = 77.27 T = 0.161 Q = 8.375E-6 F = 1. DY(1) = S*(-Y(2)+1.-2.*Q*Y(1)) DY(2) = -Y(2)/S DY(3) = T DY(4) = S*(1.-Y(1)) DY(5) = (-1.-Y(1))/S DY(6) = 0. DY(7) = 0. DY(8) = F/S DY(9) = -T GO TO 980 C C PROBLEM F5 960 DY(1) = -3.E11*Y(2) - 9.E11*Y(3) DY(2) = -3.E11*Y(2) DY(3) = -9.E11*Y(3) DY(4) = 3.E11*Y(2) + 9.E11*Y(3) DY(5) = -3.E11*Y(1) DY(6) = -3.E11*Y(1) DY(7) = 0.0 DY(8) = 3.E11*Y(1) DY(9) = -9.E11*Y(1) DY(10) = 0.0 DY(11) = -9.E11*Y(1) DY(12) = 9.E11*Y(1) DY(13) = 1.2E8 DY(14) = 2.E7 DY(15) = 1.E8 DY(16) = -1.2E8 980 CONTINUE IF (IWT.LT.0) GO TO 1040 DO 1020 I = 1, N Y(I) = YTEMP(I) DO 1000 J = 1, N ITMP = I + (J-1)*N DY(ITMP) = DY(ITMP)*W(J)/W(I) 1000 CONTINUE 1020 CONTINUE 1040 CONTINUE RETURN END C .. Local Scalars .. REAL FLAG INTEGER IOUT CHARACTER*80 TITLE C .. Local Arrays .. REAL TOL(11) INTEGER IDLIST(60), OPTION(10) C .. External Functions .. REAL CONST EXTERNAL CONST C .. External Subroutines .. EXTERNAL STDTST C .. Data statements .. DATA OPTION/2, 0, 1, 1, 6*0/, TOL/1E-2, 1E-4, 1E-6, * 1E-8, 7*0E0/, IDLIST/51, 53, 0, -51, -53, 0, 54*0/ C .. Executable Statements .. C SAMPLE DRIVER FOR STDTST, WITH TWO GROUPS CONSISTING OF C PROBLEMS E1, E3 SOLVED FIRST IN SCALED AND THEN IN UNSCALED C FORM, AT FOUR TOLERANCES, FIRST WITH OPT=2 AND NORMEF=0, C THEN OPT=3, NORMEF=0, THEN OPT=2, NORMEF=2. C NOTE THE ARRAYS IDLIST, TOL ARE LONGER THEN NECESSARY. TITLE = 'SECDER, ADDISON-ENRIGHT SECOND DERIVATIVE METHOD' IOUT = CONST(3) CALL STDTST(TITLE,OPTION,TOL,IDLIST,FLAG) WRITE (IOUT,FMT=99999) OPTION(1) = 3 CALL STDTST(TITLE,OPTION,TOL,IDLIST,FLAG) WRITE (IOUT,FMT=99999) OPTION(1) = 2 OPTION(2) = 2 CALL STDTST(TITLE,OPTION,TOL,IDLIST,FLAG) STOP C 99999 FORMAT ('1') END C C SUBROUTINE METHOD(N,X,Y,XEND,TOL,HMAX,HSTART) C C DRIVER FOR THE SECDER CODE WHICH IS PART OF THE PACKAGE. C IT IS SOMEWHAT LENGTHY BECAUSE ITS INTERRUPT MECHANISM DOES C NOT ALLOW INTERRUPT IMMEDIATELY AFTER ACCEPTING A STEP. C C C .. Scalar Arguments .. DOUBLE PRECISION HMAX, HSTART, TOL, X, XEND INTEGER N C .. Array Arguments .. DOUBLE PRECISION Y(N) C .. Scalars in Common .. INTEGER NFCN, NJAC, NLUD C .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, IND, NDIM C .. Local Arrays .. DOUBLE PRECISION C(20), PD(400), W(400), WK(20,12), YP(20,11) INTEGER INF(40) C .. External Subroutines .. EXTERNAL FCN, PDERV, STATS, TRUE C .. Common blocks .. COMMON /STCOM6/NFCN, NJAC, NLUD C .. Data statements .. C DATA NDIM/20/ C .. Executable Statements .. C IND = 2 DO 20 I = 1, 5 INF(I) = 0 C(I) = 0.D0 20 CONTINUE C C SET ABS ERROR CONTROL: INF(1); INTERRUPT NO. 2: INF(5); C MIN,MAX & STARTING STEPSIZE: C(2),C(4),C(5). INF(1) = 1 INF(5) = 1 C(2) = 1D-12 C(4) = HMAX C(5) = HSTART C 40 CALL TRUE(FCN,PDERV,NDIM,N,X,Y,XEND,TOL,IND,C,INF,YP,W,PD,WK) IF (IND.EQ.6) GO TO 40 C WRITE(5,999)X,Y,C(13),(WK(I,1),I=1,N) C999 FORMAT(20X,10F10.6) IF (IND.NE.5) GO TO 60 TEMP = C(13) C C(13),WK(*,1) ARE THE ABOUT-TO-BE-ACCEPTED X,Y. C WK(*,12) IS THE ERROR-ESTIMATE VECTOR, DELIVERED C BY A SMALL CHANGE IN 'TRUE'. CALL STATS(C(13),WK(1,1),TOL,WK(1,12)) IF (C(13).NE.TEMP) GO TO 80 GO TO 40 C 60 IF (IND.NE.3) GO TO 80 X = XEND GO TO 100 C C FAILURE EXIT OF SOME KIND: 80 X = C(13) C WRITE(IOUT,110)IND,(INF(I),I=9,15) C110 FORMAT(1H ,'IND,INF(9)..INF(15)=',8I10) 100 CONTINUE NLUD = INF(15) RETURN END C .. Local Scalars .. C*PT*WARNING* Already single-precision REAL FLAG INTEGER IOUT CHARACTER*80 TITLE C .. Local Arrays .. C*PT*WARNING* Already single-precision REAL TOL(11) INTEGER IDLIST(60), OPTION(10) C .. External Functions .. C*PT*WARNING* Already single-precision REAL CONST EXTERNAL CONST C .. External Subroutines .. EXTERNAL STDTST C .. Data statements .. C*PT*WARNING* Constant already single-precision C*PT*WARNING* Constant already single-precision C*PT*WARNING* Constant already single-precision C*PT*WARNING* Constant already single-precision C*PT*WARNING* Constant already single-precision DATA OPTION/2, 0, 1, 1, 6*0/, TOL/1E-2, 1E-4, 1E-6, * 1E-8, 7*0E0/, IDLIST/51, 53, 0, -51, -53, 0, 54*0/ C .. Executable Statements .. C SAMPLE DRIVER FOR STDTST, WITH TWO GROUPS CONSISTING OF C PROBLEMS E1, E3 SOLVED FIRST IN SCALED AND THEN IN UNSCALED C FORM, AT FOUR TOLERANCES, FIRST WITH OPT=2 AND NORMEF=0, C THEN OPT=3, NORMEF=0, THEN OPT=2, NORMEF=2. C NOTE THE ARRAYS IDLIST, TOL ARE LONGER THEN NECESSARY. TITLE = 'SECDER, ADDISON-ENRIGHT SECOND DERIVATIVE METHOD' IOUT = CONST(3) CALL STDTST(TITLE,OPTION,TOL,IDLIST,FLAG) WRITE (IOUT,FMT=99999) OPTION(1) = 3 CALL STDTST(TITLE,OPTION,TOL,IDLIST,FLAG) WRITE (IOUT,FMT=99999) OPTION(1) = 2 OPTION(2) = 2 CALL STDTST(TITLE,OPTION,TOL,IDLIST,FLAG) STOP C 99999 FORMAT ('1') END C C SUBROUTINE METHOD(N,X,Y,XEND,TOL,HMAX,HSTART) C C DRIVER FOR THE SECDER CODE WHICH IS PART OF THE PACKAGE. C IT IS SOMEWHAT LENGTHY BECAUSE ITS INTERRUPT MECHANISM DOES C NOT ALLOW INTERRUPT IMMEDIATELY AFTER ACCEPTING A STEP. C C C .. Scalar Arguments .. REAL HMAX, HSTART, TOL, X, XEND INTEGER N C .. Array Arguments .. REAL Y(N) C .. Scalars in Common .. INTEGER NFCN, NJAC, NLUD C .. Local Scalars .. REAL TEMP INTEGER I, IND, NDIM C .. Local Arrays .. REAL C(20), PD(400), W(400), WK(20,12), YP(20,11) INTEGER INF(40) C .. External Subroutines .. EXTERNAL FCN, PDERV, STATS, TRUE C .. Common blocks .. COMMON /STCOM6/NFCN, NJAC, NLUD C .. Data statements .. C DATA NDIM/20/ C .. Executable Statements .. C IND = 2 DO 20 I = 1, 5 INF(I) = 0 C(I) = 0. 20 CONTINUE C C SET ABS ERROR CONTROL: INF(1); INTERRUPT NO. 2: INF(5); C MIN,MAX & STARTING STEPSIZE: C(2),C(4),C(5). INF(1) = 1 INF(5) = 1 C(2) = 1E-12 C(4) = HMAX C(5) = HSTART C 40 CALL TRUE(FCN,PDERV,NDIM,N,X,Y,XEND,TOL,IND,C,INF,YP,W,PD,WK) IF (IND.EQ.6) GO TO 40 C WRITE(5,999)X,Y,C(13),(WK(I,1),I=1,N) C999 FORMAT(20X,10F10.6) IF (IND.NE.5) GO TO 60 TEMP = C(13) C C(13),WK(*,1) ARE THE ABOUT-TO-BE-ACCEPTED X,Y. C WK(*,12) IS THE ERROR-ESTIMATE VECTOR, DELIVERED C BY A SMALL CHANGE IN 'TRUE'. CALL STATS(C(13),WK(1,1),TOL,WK(1,12)) IF (C(13).NE.TEMP) GO TO 80 GO TO 40 C 60 IF (IND.NE.3) GO TO 80 X = XEND GO TO 100 C C FAILURE EXIT OF SOME KIND: 80 X = C(13) C WRITE(IOUT,110)IND,(INF(I),I=9,15) C110 FORMAT(1H ,'IND,INF(9)..INF(15)=',8I10) 100 CONTINUE NLUD = INF(15) RETURN END C .. Scalars in Common .. INTEGER IDENT, IWT, NN C .. Arrays in Common .. DOUBLE PRECISION WT(20) C .. Local Scalars .. DOUBLE PRECISION ATOL, HMAX, HSTART, RTOL, T, XEND REAL DTIM, FTIM, MTIM INTEGER I, IID, IOPT, IP, ISTATE, ITASK, ITOL, IZ, K, LIW, * LRW, MF, N, NPROB C .. Local Arrays .. DOUBLE PRECISION W(20), WS(700), Y(20) INTEGER ID(30), IW(50) C .. External Subroutines .. EXTERNAL FN, IVALU, JAC, LSODE C .. Intrinsic Functions .. INTRINSIC DABS, DMAX1 C .. Common blocks .. COMMON /STCOM5/WT, IWT, NN, IDENT C .. Data statements .. C IN THIS EXAMPLE WE OBTAIN THE WEIGHTS FOR 3 PROBLEMS; A1,B2 AND C3. C DATA NPROB/3/ DATA ID/1, 12, 23, 27*0/ DATA IP/1/ C .. Executable Statements .. C THIS UTILITY ROUTINE GENERATES THE WEIGHTS REQUIRED FOR THE SCALED C FORM OF A PROBLEM. IT IS ASSUMED THAT IVALU, FCN, AND PDERV C ARE SET TO CORRESPOND TO THE NATURAL (UNSCALED) FORM OF THE PROBLEM. C AFTER THE EXECUTION OF THIS ROUTINE THE FILE CORRESPONDING TO UNIT C NUMBER IP (SET IN THE DATA STATEMENT) WILL CONTAIN THE SEQUENCE OF C ASSIGNMENT STATEMENTS REQUIRED BY IVALU TO SET UP THE SCALED FORM C OF THE PROBLEM. NOTE THAT THIS ROUTINE USES LSODE TO GENERATE THE C TRIAL SOLUTION. IF LSODE IS NOT AVAILABLE THEN TRUE COULD BE USED. C DO 160 K = 1, NPROB IID = ID(K) IZ = -1 CALL IVALU(N,T,XEND,HSTART,HMAX,Y,FTIM,DTIM,MTIM,W,IZ,IID) NN = N IDENT = IID DO 20 I = 1, N W(I) = DABS(Y(I)) 20 CONTINUE IWT = -1 MF = 21 LRW = 700 ITOL = 1 ATOL = 1.D-8 RTOL = 0.D0 ITASK = 2 ISTATE = 1 IOPT = 1 DO 40 I = 1, 5 WS(I) = 0.D0 IW(I) = 0 40 CONTINUE WS(5) = HSTART WS(6) = HMAX LIW = 50 C LOOP OVER EACH STEP MONITORING THE SIZE OF THE SOLUTION. 60 CALL LSODE(FN,N,Y,T,XEND,ITOL,RTOL,ATOL,ITASK,ISTATE,IOPT,WS, * LRW,IW,LIW,JAC,MF) DO 80 I = 1, N W(I) = DMAX1(DABS(Y(I)),W(I)) 80 CONTINUE IF (T.GE.XEND) GO TO 120 IF (ISTATE.LT.0) GO TO 100 GO TO 60 100 CONTINUE WRITE (IP,FMT=99999) 120 WRITE (IP,FMT=99998) IID WRITE (5,FMT=99998) IID DO 140 I = 1, N WRITE (IP,FMT=99997) I, W(I) 140 CONTINUE C C 160 CONTINUE STOP C 99999 FORMAT (1X,'ERROR IN THE INTEGRATION') 99998 FORMAT (1X,//1X,I10) 99997 FORMAT (6X,'W(',I2,') = ',D10.3) END SUBROUTINE FN(N,T,Y,YP) C .. Scalar Arguments .. DOUBLE PRECISION T INTEGER N C .. Array Arguments .. DOUBLE PRECISION Y(N), YP(N) C .. External Subroutines .. EXTERNAL FCN C .. Executable Statements .. CALL FCN(T,Y,YP) RETURN END SUBROUTINE JAC(N,T,Y,ML,MU,PD,NR) C .. Scalar Arguments .. DOUBLE PRECISION T INTEGER ML, MU, N, NR C .. Array Arguments .. DOUBLE PRECISION PD(1), Y(N) C .. External Subroutines .. EXTERNAL PDERV C .. Executable Statements .. CALL PDERV(T,Y,PD) RETURN END C .. Scalars in Common .. INTEGER IDENT, IWT, NN C .. Arrays in Common .. REAL WT(20) C .. Local Scalars .. REAL ATOL, HMAX, HSTART, RTOL, T, XEND REAL DTIM, FTIM, MTIM INTEGER I, IID, IOPT, IP, ISTATE, ITASK, ITOL, IZ, K, LIW, * LRW, MF, N, NPROB C .. Local Arrays .. REAL W(20), WS(700), Y(20) INTEGER ID(30), IW(50) C .. External Subroutines .. EXTERNAL FN, IVALU, JAC, LSODE C .. Intrinsic Functions .. INTRINSIC ABS, AMAX1 C .. Common blocks .. COMMON /STCOM5/WT, IWT, NN, IDENT C .. Data statements .. C IN THIS EXAMPLE WE OBTAIN THE WEIGHTS FOR 3 PROBLEMS; A1,B2 AND C3. C DATA NPROB/3/ DATA ID/1, 12, 23, 27*0/ DATA IP/1/ C .. Executable Statements .. C THIS UTILITY ROUTINE GENERATES THE WEIGHTS REQUIRED FOR THE SCALED C FORM OF A PROBLEM. IT IS ASSUMED THAT IVALU, FCN, AND PDERV C ARE SET TO CORRESPOND TO THE NATURAL (UNSCALED) FORM OF THE PROBLEM. C AFTER THE EXECUTION OF THIS ROUTINE THE FILE CORRESPONDING TO UNIT C NUMBER IP (SET IN THE DATA STATEMENT) WILL CONTAIN THE SEQUENCE OF C ASSIGNMENT STATEMENTS REQUIRED BY IVALU TO SET UP THE SCALED FORM C OF THE PROBLEM. NOTE THAT THIS ROUTINE USES LSODE TO GENERATE THE C TRIAL SOLUTION. IF LSODE IS NOT AVAILABLE THEN TRUE COULD BE USED. C DO 160 K = 1, NPROB IID = ID(K) IZ = -1 CALL IVALU(N,T,XEND,HSTART,HMAX,Y,FTIM,DTIM,MTIM,W,IZ,IID) NN = N IDENT = IID DO 20 I = 1, N W(I) = ABS(Y(I)) 20 CONTINUE IWT = -1 MF = 21 LRW = 700 ITOL = 1 ATOL = 1.E-8 RTOL = 0. ITASK = 2 ISTATE = 1 IOPT = 1 DO 40 I = 1, 5 WS(I) = 0. IW(I) = 0 40 CONTINUE WS(5) = HSTART WS(6) = HMAX LIW = 50 C LOOP OVER EACH STEP MONITORING THE SIZE OF THE SOLUTION. 60 CALL LSODE(FN,N,Y,T,XEND,ITOL,RTOL,ATOL,ITASK,ISTATE,IOPT,WS, * LRW,IW,LIW,JAC,MF) DO 80 I = 1, N W(I) = AMAX1(ABS(Y(I)),W(I)) 80 CONTINUE IF (T.GE.XEND) GO TO 120 IF (ISTATE.LT.0) GO TO 100 GO TO 60 100 CONTINUE WRITE (IP,FMT=99999) 120 WRITE (IP,FMT=99998) IID WRITE (5,FMT=99998) IID DO 140 I = 1, N WRITE (IP,FMT=99997) I, W(I) 140 CONTINUE C C 160 CONTINUE STOP C 99999 FORMAT (1X,'ERROR IN THE INTEGRATION') 99998 FORMAT (1X,//1X,I10) 99997 FORMAT (6X,'W(',I2,') = ',E10.3) END SUBROUTINE FN(N,T,Y,YP) C .. Scalar Arguments .. REAL T INTEGER N C .. Array Arguments .. REAL Y(N), YP(N) C .. External Subroutines .. EXTERNAL FCN C .. Executable Statements .. CALL FCN(T,Y,YP) RETURN END SUBROUTINE JAC(N,T,Y,ML,MU,PD,NR) C .. Scalar Arguments .. REAL T INTEGER ML, MU, N, NR C .. Array Arguments .. REAL PD(1), Y(N) C .. External Subroutines .. EXTERNAL PDERV C .. Executable Statements .. CALL PDERV(T,Y,PD) RETURN END C .. Local Scalars .. REAL FCNTIM, JACTIM, LUDTIM INTEGER ID, IDEXT, IIN, IOUT, IPROB, K, LEN, LNUM, LNUM0, * NFCN, NID, NJAC, NLUD, TTYIN, TTYOUT CHARACTER EOF CHARACTER*2 PROBID CHARACTER*40 INFIL, OUTFIL CHARACTER*72 LINE, TEMP C .. Local Arrays .. INTEGER IDLIST(30), PROB(24) C .. External Functions .. CHARACTER*2 PRBNAM CHARACTER*72 GETL EXTERNAL PRBNAM, GETL C .. External Subroutines .. EXTERNAL GETTIM C .. Intrinsic Functions .. INTRINSIC MIN, INDEX C .. Statement Functions .. CHARACTER FIRST1 C .. Data statements .. C PROB HOLDS THE INTERNAL ID'S OF THE PROBLEMS AS ENCOUNTERED C IN IVALU ROUTINE (NOTE B2-B5 ARE LUMPED, SO ARE C2-C5). DATA PROB/01, 02, 03, 04, 11, 12, 21, 22, 31, 32, 33, * 34, 35, 36, 41, 42, 43, 44, 45, 51, 52, 53, 54, * 55/ C .. Statement Function definitions .. C CDEC PARAMETER(EOF='.',IIN=1,IOUT=2,TTYIN=5,TTYOUT=5) CIBM PARAMETER(EOF='.',IIN=5,IOUT=6,TTYIN=5,TTYOUT=6) C CDEC PARAMETER( INFIL = 'IVALU.FOR', OUTFIL = 'IVALU.NEW' ) C C STATEMENT FUNCTION: FIRST1(TEMP) = TEMP(1:1) C .. Executable Statements .. C C********************************************************************* C GENTIM PROGRAM FOR THE STDTST PACKAGE: C THIS PROGRAM COMPUTES THE VALUES OF THE TIMING CONSTANTS FCNTIM, C JACTIM, LUDTIM FOR A PARTICULAR COMPUTER SYSTEM EITHER FOR C SELECTED PROBLEMS OR FOR THE WHOLE PROBLEM SET. C C ********* THIS IS A FORTRAN 77 PROGRAM ********** C C TO RUN, THIS PROGRAM MUST BE LINKED WITH THE 'STPROB' FILE AND WITH C THE REVISED 'CONST' AND 'CLOCK' ROUTINES YOU WILL HAVE WRITTEN. C YOU MAY ALSO NEED TO ALTER THE UNIT NUMBERS AND FILE NAMES IN THE C PARAMETER STATEMENTS, BOTH IN THE MAIN PROGRAM AND IN GETL. C C DATA IS INPUT ON UNIT NUMBER 'TTYIN', PRESUMABLY THE TERMINAL. C OUTPUT IS TO A FILE AND LOGGING INFORMATION TO 'TTYOUT'. C FOR PROCESSING SELECTED PROBLEMS, GIVE: C (1) THE NUMBER OF PROBLEMS, NID; C (2) A LIST OF NID PROBLEM-IDS IN FREE FORMAT SEPARATED BY SPACES. C THESE ARE THE 'EXTERNAL' IDS, IE. 11 FOR A1, 21 FOR B1 ETC., C WHICH ARE 10 MORE THAN THE 'INTERNAL' IDS USED BY THE PACKAGE C ROUTINES THEMSELVES. C C TO PROCESS THE WHOLE SET, THE PROGRAM READS THE 'IVALU' ROUTINE C AS A DATA FILE AND CREATES A REVISED VERSION AS AN OUTPUT FILE. C TO USE THIS OPTION: C (A) IF DESIRED, ALTER THE FILENAMES IN THE PARAMETER STATEMENTS. C AT PRESENT INPUT='IVALU.FOR', OUTPUT='IVALU.NEW' . C (B) EXTRACT THE IVALU ROUTINE FROM THE 'STPROB' FILE INTO THE C INPUT FILE USING AN EDITOR. C (C) RUN THE PROGRAM AND GIVE IT THE VALUE NID=0 WHEN IT ASKS FOR C DATA ON UNIT 'TTYIN'. C (D) INSPECT THE OUTPUT FILE WITH CARE, PREFERABLY COMPARE IT WITH C THE INPUT FILE USING A FILE-COMPARE PROGRAM. NOTE ANY SITE- C DEPENDENT RULES FOR USING 'CLOCK', EG. ON A DEC10 IT MUST BE C USED IN CONJUNCTION WITH THE MONITOR'S 'SET TIME' COMMAND. C (E) MERGE THE OUTPUT FILE BACK INTO 'STPROB'. C C NOTE THE TIMING LOOPS ARE SET UP SO THAT EACH PROBLEM TAKES ABOUT C TSTTIM (= CONST(4)) PROCESSOR SECONDS IN TOTAL. C C********************************************************************* C READ DATA: WRITE (TTYOUT,FMT=*) 'GIVE NID (0 TO PROCESS WHOLE FILE, ', * 'ELSE IN RANGE 1-30) ' READ (TTYIN,FMT=*) NID C IF (NID.GT.0) THEN C C PROCESS SELECTED PROBLEMS AS SPECIFIED BY THE DATA: NID = MIN(NID,30) WRITE (TTYOUT,FMT=*) * 'GIVE LIST OF NID PROBLEM-IDS SEPARATED BY BLANKS' READ (TTYIN,FMT=*) (IDLIST(K),K=1,NID) OPEN (IOUT,DEVICE='DSK',FILE=OUTFIL) C DO 20 K = 1, NID IDEXT = IDLIST(K) ID = IDEXT - 10 PROBID = PRBNAM(IDEXT) WRITE (IOUT,FMT=99999) PROBID, ID, IDEXT C CALL GETTIM(ID,FCNTIM,JACTIM,LUDTIM,NFCN,NJAC,NLUD) C WRITE (IOUT,FMT=99997) FCNTIM, JACTIM, LUDTIM WRITE (TTYOUT,FMT=99996) PROBID, IDEXT, NFCN, NJAC, NLUD 20 CONTINUE C CLOSE (IOUT) C ELSE C C PROCESS THE WHOLE PROBLEM SET & WRITE A NEW IVALU ROUTINE: OPEN (IIN,FILE=INFIL) OPEN (IOUT,DEVICE='DSK',FILE=OUTFIL) C LNUM = 0 IPROB = 0 C 40 IF (FIRST1(GETL(LINE,LNUM,LEN)).NE.EOF) THEN WRITE (IOUT,FMT='(1H ,A)') LINE(1:LEN) IF (LINE(1:2).EQ.'CP') THEN LNUM0 = LNUM IPROB = IPROB + 1 C GET THE EXPECTED NEXT INTERNAL PROBLEM-ID IN THE IVALU C ROUTINE AND FORM THE CORRESPONDING EXTERNAL ID AND C CHARACTER EQUIVALENT: ID = PROB(IPROB) IDEXT = ID + 10 PROBID = PRBNAM(IDEXT) C IF (LINE(15:16).NE.PROBID .OR. INDEX(GETL(TEMP,LNUM,LEN) * ,'FCNTIM').EQ.0 .OR. INDEX(GETL(TEMP,LNUM,LEN) * ,'JACTIM').EQ.0 .OR. INDEX(GETL(TEMP,LNUM,LEN) * ,'LUDTIM').EQ.0) THEN WRITE (TTYOUT,FMT=99998) LNUM0, LINE, PROBID STOP ELSE CALL GETTIM(ID,FCNTIM,JACTIM,LUDTIM,NFCN,NJAC,NLUD) WRITE (IOUT,FMT=99997) FCNTIM, JACTIM, LUDTIM WRITE (TTYOUT,FMT=99996) PROBID, IDEXT, NFCN, NJAC, * NLUD END IF END IF C GO TO 40 END IF C CLOSE (IIN) CLOSE (IOUT) END IF C STOP C 99999 FORMAT (//' CP PROBLEM ',A,' INTERNAL ID ',I5,', EXTERNAL ID', * I5) 99998 FORMAT (' LINE',I3,':',A,/ * ' OF INPUT FILE DOESN''T MATCH EXPECTED PROB',A, * /' OR NEXT 3 LINES NOT AS EXPECTED.',/) 99997 FORMAT (10X,'FCNTIM = ',1P,E11.4,/10X,'JACTIM = ',E11.4,/10X, * 'LUDTIM = ',E11.4) 99996 FORMAT (' PROBLEM ',A,'(',I3, * ') PROCESSED, TIMES ROUND TIMING LOOPS WERE NFCN NJAC NLUD' * ,/57X,3I7) END C C CHARACTER*72 FUNCTION GETL(LINE,LNUM,LEN) C FUNCTION TO RETURN NEXT LINE ON INPUT FILE. C LNUM IS LINE COUNT, INCREASED BY 1 EACH CALL C LEN SHOWS 'NONTRIVIAL' PART OF LINE, C IE. LINE(LEN+1: ) IS TRAILING BLANKS. C C .. Parameters .. CHARACTER EOF INTEGER IIN PARAMETER (EOF='.',IIN=1) C .. Scalar Arguments .. INTEGER LEN, LNUM CHARACTER*72 LINE C .. Executable Statements .. C READ (IIN,FMT='(A)',END=40) LINE LEN = 72 20 IF (LINE(LEN:LEN).EQ.' ') THEN LEN = LEN - 1 GO TO 20 END IF GO TO 60 40 LINE = EOF LEN = 1 60 GETL = LINE LNUM = LNUM + 1 RETURN END C C CHARACTER*2 FUNCTION PRBNAM(IDEXT) C C FORMS THE NAME OF A DETEST PROBLEM CORRESPONDING TO ITS C EXTERNAL ID C C .. Scalar Arguments .. INTEGER IDEXT C .. Local Scalars .. INTEGER IID, KCLASS CHARACTER*6 CLASS CHARACTER*10 DIGIT C .. Data statements .. DATA CLASS/'ABCDEF'/, DIGIT/'1234567890'/ C .. Executable Statements .. KCLASS = (IDEXT-1)/10 IID = IDEXT - 10*KCLASS PRBNAM = CLASS(KCLASS:KCLASS)//DIGIT(IID:IID) RETURN END C C SUBROUTINE GETTIM(IDENT,FCNTIM,JACTIM,LUDTIM,NFCN,NJAC,NLUD) C .. Scalar Arguments .. REAL FCNTIM, JACTIM, LUDTIM INTEGER IDENT, NFCN, NJAC, NLUD C .. Scalars in Common .. INTEGER ID, IWT, NN C .. Arrays in Common .. DOUBLE PRECISION WT(20) C .. Local Scalars .. DOUBLE PRECISION HB, HM, XEND, XS REAL S, TIM, TSTTIM INTEGER I, II, J, N C .. Local Arrays .. DOUBLE PRECISION A(400), B(400), DY(400), Y(20), Z(20) INTEGER NPIV(20) C .. External Functions .. REAL CLOCK, CONST EXTERNAL CLOCK, CONST C .. External Subroutines .. EXTERNAL DDCOMP, EVALU, FCN, IVALU, PDERV C .. Intrinsic Functions .. INTRINSIC FLOAT C .. Common blocks .. COMMON /STCOM5/WT, IWT, NN, ID C .. Executable Statements .. C C A TYPICAL SET OF SOLUTION VALUES FOR EACH PROBLEM IS C DETERMINED FOR TIMING PURPOSES USING THE ENDPOINT VALUES. C TSTTIM = CONST(4)/3.0 ID = IDENT IWT = -1 CALL IVALU(N,XS,XEND,HB,HM,Y,FCNTIM,LUDTIM,JACTIM,WT,IWT,IDENT) CALL EVALU(Y,N,WT,IWT,IDENT) CALL PDERV(XEND,Y,DY) C C SET A TO I-.1*J DO 40 I = 1, N DO 20 J = 1, N A(I+(J-1)*N) = -.1D0*DY(I+(J-1)*N) 20 CONTINUE A(I+(I-1)*N) = 1.D0 + A(I+(I-1)*N) 40 CONTINUE C C DETERMINE THE DERIVATIVE EVALUATION TIME C S = CLOCK(0.0) NFCN = 0 C LOOP UNTIL TIMING IS SIGNIFICANT 60 CONTINUE CALL FCN(XEND,Y,Z) NFCN = NFCN + 1 TIM = CLOCK(S) IF (TIM.LT.TSTTIM) GO TO 60 FCNTIM = TIM/FLOAT(NFCN) C C DETERMINE THE JACOBIAN EVALUATION TIME C S = CLOCK(0.0) NJAC = 0 C LOOP UNTIL TIMING IS SIGNIFICANT 80 CALL PDERV(XEND,Y,DY) NJAC = NJAC + 1 TIM = CLOCK(S) IF (TIM.LT.TSTTIM) GO TO 80 JACTIM = TIM/FLOAT(NJAC) C C C DETERMINE THE MATRIX FACTORIZATION TIME C S = CLOCK(0.0) NLUD = 0 C LOOP UNTIL TIMING IS SIGNIFICANT 100 CONTINUE DO 140 I = 1, N DO 120 J = 1, N B(I+(J-1)*N) = A(I+(J-1)*N) 120 CONTINUE 140 CONTINUE CALL DDCOMP(N,N,B,NPIV,II) NLUD = NLUD + 1 TIM = CLOCK(S) IF (TIM.LT.TSTTIM) GO TO 100 LUDTIM = TIM/FLOAT(NLUD) RETURN END SUBROUTINE DDCOMP(NDIM,N,A,NPIV,IND) C C--------+---------+---------+---------+---------+---------+---------+-- C COMMON AREA USED FOR STATISTICS GATHERING BY STDTST PACKAGE C .. Scalar Arguments .. INTEGER IND, N, NDIM C .. Array Arguments .. DOUBLE PRECISION A(NDIM,N) INTEGER NPIV(N) C .. Scalars in Common .. INTEGER NFCN, NJAC, NLUD C .. Local Scalars .. DOUBLE PRECISION AMULT, COLMAX, HOLD INTEGER I, IP1, IPIVOT, J, JPIVOT, K, NM1, NROW C .. Intrinsic Functions .. INTRINSIC DABS C .. Common blocks .. COMMON /STCOM6/NFCN, NJAC, NLUD C .. Executable Statements .. C--------+---------+---------+---------+---------+---------+---------+-- C NLUD = NLUD + 1 C IND = 0 C C *************** C * C * CHECK FOR A SYSTEM OF ONLY ONE UNKNOWN C * C *************** C IF (N.EQ.1) RETURN C C *************** C * C * INITIALIZE PIVOT VECTOR C * C *************** C DO 20 I = 1, N NPIV(I) = I 20 CONTINUE C C *************** C * C * MAIN LOOP FOR GAUSS ELIMINATION C * C *************** C NM1 = N - 1 DO 140 I = 1, NM1 C C *************** C * C * SEARCH COLUMN FOR LARGEST PIVOT,I.E., C * MAX |A(J,I)|, I <= J <= N. C * C *************** C COLMAX = 0.D0 DO 40 J = I, N HOLD = DABS(A(NPIV(J),I)) IF (HOLD.LE.COLMAX) GO TO 40 COLMAX = HOLD NROW = J 40 CONTINUE C C *************** C * C * TEST FOR SINGULARITY. THE MATRIX IS ASSUMED TO BE SINGULAR C * IF COLMAX (THE ABS. VALUE OF THE PIVOT) IS EQUIVALENT C * TO ZERO, I.E., C * 1.0 + COLMAX = 1.0 . C * IF THIS IS TRUE THEN THE ROUTINE PROCEEDS ON TO THE (I+1)-TH C * STAGE OF THE ELIMINATION. C * C *************** C IF (1.D0+COLMAX.NE.1.D0) GO TO 60 IND = -1 GO TO 140 C C *************** C * C * IF AN INTERCHANGE IS NECESSARY, ALTER THE PIVOT VECTOR NPIV. C * C *************** C 60 IPIVOT = NPIV(NROW) IF (NROW.EQ.I) GO TO 80 NPIV(NROW) = NPIV(I) NPIV(I) = IPIVOT C C *************** C * C * THE MULTIPLIERS FOR THE COMPUTATION OF THE REMAINING ROWS ARE C * DETERMINED AND ELIMINATION IS PERFORMED. THE VALUE OF EACH C * MULTIPLIER IS STORED IN THE POSITION OF THE ELIMINATED C * ELEMENT. C * C *************** C 80 IP1 = I + 1 DO 120 J = IP1, N JPIVOT = NPIV(J) AMULT = A(JPIVOT,I)/A(IPIVOT,I) A(JPIVOT,I) = AMULT DO 100 K = IP1, N A(JPIVOT,K) = A(JPIVOT,K) - AMULT*A(IPIVOT,K) 100 CONTINUE 120 CONTINUE 140 CONTINUE IF (1.D0+DABS(A(NPIV(N),N)).EQ.1.D0) IND = -1 RETURN END C .. Local Scalars .. REAL FCNTIM, JACTIM, LUDTIM INTEGER ID, IDEXT, IIN, IOUT, IPROB, K, LEN, LNUM, LNUM0, * NFCN, NID, NJAC, NLUD, TTYIN, TTYOUT CHARACTER EOF CHARACTER*2 PROBID CHARACTER*40 INFIL, OUTFIL CHARACTER*72 LINE, TEMP C .. Local Arrays .. INTEGER IDLIST(30), PROB(24) C .. External Functions .. CHARACTER*2 PRBNAM CHARACTER*72 GETL EXTERNAL PRBNAM, GETL C .. External Subroutines .. EXTERNAL GETTIM C .. Intrinsic Functions .. INTRINSIC MIN, INDEX C .. Statement Functions .. CHARACTER FIRST1 C .. Data statements .. C PROB HOLDS THE INTERNAL ID'S OF THE PROBLEMS AS ENCOUNTERED C IN IVALU ROUTINE (NOTE B2-B5 ARE LUMPED, SO ARE C2-C5). DATA PROB/01, 02, 03, 04, 11, 12, 21, 22, 31, 32, 33, * 34, 35, 36, 41, 42, 43, 44, 45, 51, 52, 53, 54, * 55/ C .. Statement Function definitions .. C CDEC PARAMETER(EOF='.',IIN=1,IOUT=2,TTYIN=5,TTYOUT=5) CIBM PARAMETER(EOF='.',IIN=5,IOUT=6,TTYIN=5,TTYOUT=6) C CDEC PARAMETER( INFIL = 'IVALU.FOR', OUTFIL = 'IVALU.NEW' ) C C STATEMENT FUNCTION: FIRST1(TEMP) = TEMP(1:1) C .. Executable Statements .. C C********************************************************************* C GENTIM PROGRAM FOR THE STDTST PACKAGE: C THIS PROGRAM COMPUTES THE VALUES OF THE TIMING CONSTANTS FCNTIM, C JACTIM, LUDTIM FOR A PARTICULAR COMPUTER SYSTEM EITHER FOR C SELECTED PROBLEMS OR FOR THE WHOLE PROBLEM SET. C C ********* THIS IS A FORTRAN 77 PROGRAM ********** C C TO RUN, THIS PROGRAM MUST BE LINKED WITH THE 'STPROB' FILE AND WITH C THE REVISED 'CONST' AND 'CLOCK' ROUTINES YOU WILL HAVE WRITTEN. C YOU MAY ALSO NEED TO ALTER THE UNIT NUMBERS AND FILE NAMES IN THE C PARAMETER STATEMENTS, BOTH IN THE MAIN PROGRAM AND IN GETL. C C DATA IS INPUT ON UNIT NUMBER 'TTYIN', PRESUMABLY THE TERMINAL. C OUTPUT IS TO A FILE AND LOGGING INFORMATION TO 'TTYOUT'. C FOR PROCESSING SELECTED PROBLEMS, GIVE: C (1) THE NUMBER OF PROBLEMS, NID; C (2) A LIST OF NID PROBLEM-IDS IN FREE FORMAT SEPARATED BY SPACES. C THESE ARE THE 'EXTERNAL' IDS, IE. 11 FOR A1, 21 FOR B1 ETC., C WHICH ARE 10 MORE THAN THE 'INTERNAL' IDS USED BY THE PACKAGE C ROUTINES THEMSELVES. C C TO PROCESS THE WHOLE SET, THE PROGRAM READS THE 'IVALU' ROUTINE C AS A DATA FILE AND CREATES A REVISED VERSION AS AN OUTPUT FILE. C TO USE THIS OPTION: C (A) IF DESIRED, ALTER THE FILENAMES IN THE PARAMETER STATEMENTS. C AT PRESENT INPUT='IVALU.FOR', OUTPUT='IVALU.NEW' . C (B) EXTRACT THE IVALU ROUTINE FROM THE 'STPROB' FILE INTO THE C INPUT FILE USING AN EDITOR. C (C) RUN THE PROGRAM AND GIVE IT THE VALUE NID=0 WHEN IT ASKS FOR C DATA ON UNIT 'TTYIN'. C (D) INSPECT THE OUTPUT FILE WITH CARE, PREFERABLY COMPARE IT WITH C THE INPUT FILE USING A FILE-COMPARE PROGRAM. NOTE ANY SITE- C DEPENDENT RULES FOR USING 'CLOCK', EG. ON A DEC10 IT MUST BE C USED IN CONJUNCTION WITH THE MONITOR'S 'SET TIME' COMMAND. C (E) MERGE THE OUTPUT FILE BACK INTO 'STPROB'. C C NOTE THE TIMING LOOPS ARE SET UP SO THAT EACH PROBLEM TAKES ABOUT C TSTTIM (= CONST(4)) PROCESSOR SECONDS IN TOTAL. C C********************************************************************* C READ DATA: WRITE (TTYOUT,FMT=*) 'GIVE NID (0 TO PROCESS WHOLE FILE, ', * 'ELSE IN RANGE 1-30) ' READ (TTYIN,FMT=*) NID C IF (NID.GT.0) THEN C C PROCESS SELECTED PROBLEMS AS SPECIFIED BY THE DATA: NID = MIN(NID,30) WRITE (TTYOUT,FMT=*) * 'GIVE LIST OF NID PROBLEM-IDS SEPARATED BY BLANKS' READ (TTYIN,FMT=*) (IDLIST(K),K=1,NID) OPEN (IOUT,DEVICE='DSK',FILE=OUTFIL) C DO 20 K = 1, NID IDEXT = IDLIST(K) ID = IDEXT - 10 PROBID = PRBNAM(IDEXT) WRITE (IOUT,FMT=99999) PROBID, ID, IDEXT C CALL GETTIM(ID,FCNTIM,JACTIM,LUDTIM,NFCN,NJAC,NLUD) C WRITE (IOUT,FMT=99997) FCNTIM, JACTIM, LUDTIM WRITE (TTYOUT,FMT=99996) PROBID, IDEXT, NFCN, NJAC, NLUD 20 CONTINUE C CLOSE (IOUT) C ELSE C C PROCESS THE WHOLE PROBLEM SET & WRITE A NEW IVALU ROUTINE: OPEN (IIN,FILE=INFIL) OPEN (IOUT,DEVICE='DSK',FILE=OUTFIL) C LNUM = 0 IPROB = 0 C 40 IF (FIRST1(GETL(LINE,LNUM,LEN)).NE.EOF) THEN WRITE (IOUT,FMT='(1H ,A)') LINE(1:LEN) IF (LINE(1:2).EQ.'CP') THEN LNUM0 = LNUM IPROB = IPROB + 1 C GET THE EXPECTED NEXT INTERNAL PROBLEM-ID IN THE IVALU C ROUTINE AND FORM THE CORRESPONDING EXTERNAL ID AND C CHARACTER EQUIVALENT: ID = PROB(IPROB) IDEXT = ID + 10 PROBID = PRBNAM(IDEXT) C IF (LINE(15:16).NE.PROBID .OR. INDEX(GETL(TEMP,LNUM,LEN) * ,'FCNTIM').EQ.0 .OR. INDEX(GETL(TEMP,LNUM,LEN) * ,'JACTIM').EQ.0 .OR. INDEX(GETL(TEMP,LNUM,LEN) * ,'LUDTIM').EQ.0) THEN WRITE (TTYOUT,FMT=99998) LNUM0, LINE, PROBID STOP ELSE CALL GETTIM(ID,FCNTIM,JACTIM,LUDTIM,NFCN,NJAC,NLUD) WRITE (IOUT,FMT=99997) FCNTIM, JACTIM, LUDTIM WRITE (TTYOUT,FMT=99996) PROBID, IDEXT, NFCN, NJAC, * NLUD END IF END IF C GO TO 40 END IF C CLOSE (IIN) CLOSE (IOUT) END IF C STOP C 99999 FORMAT (//' CP PROBLEM ',A,' INTERNAL ID ',I5,', EXTERNAL ID', * I5) 99998 FORMAT (' LINE',I3,':',A,/ * ' OF INPUT FILE DOESN''T MATCH EXPECTED PROB',A, * /' OR NEXT 3 LINES NOT AS EXPECTED.',/) 99997 FORMAT (10X,'FCNTIM = ',1P,E11.4,/10X,'JACTIM = ',E11.4,/10X, * 'LUDTIM = ',E11.4) 99996 FORMAT (' PROBLEM ',A,'(',I3, * ') PROCESSED, TIMES ROUND TIMING LOOPS WERE NFCN NJAC NLUD' * ,/57X,3I7) END C C CHARACTER*72 FUNCTION GETL(LINE,LNUM,LEN) C FUNCTION TO RETURN NEXT LINE ON INPUT FILE. C LNUM IS LINE COUNT, INCREASED BY 1 EACH CALL C LEN SHOWS 'NONTRIVIAL' PART OF LINE, C IE. LINE(LEN+1: ) IS TRAILING BLANKS. C C .. Parameters .. CHARACTER EOF INTEGER IIN PARAMETER (EOF='.',IIN=1) C .. Scalar Arguments .. INTEGER LEN, LNUM CHARACTER*72 LINE C .. Executable Statements .. C READ (IIN,FMT='(A)',END=40) LINE LEN = 72 20 IF (LINE(LEN:LEN).EQ.' ') THEN LEN = LEN - 1 GO TO 20 END IF GO TO 60 40 LINE = EOF LEN = 1 60 GETL = LINE LNUM = LNUM + 1 RETURN END C C CHARACTER*2 FUNCTION PRBNAM(IDEXT) C C FORMS THE NAME OF A DETEST PROBLEM CORRESPONDING TO ITS C EXTERNAL ID C C .. Scalar Arguments .. INTEGER IDEXT C .. Local Scalars .. INTEGER IID, KCLASS CHARACTER*6 CLASS CHARACTER*10 DIGIT C .. Data statements .. DATA CLASS/'ABCDEF'/, DIGIT/'1234567890'/ C .. Executable Statements .. KCLASS = (IDEXT-1)/10 IID = IDEXT - 10*KCLASS PRBNAM = CLASS(KCLASS:KCLASS)//DIGIT(IID:IID) RETURN END C C SUBROUTINE GETTIM(IDENT,FCNTIM,JACTIM,LUDTIM,NFCN,NJAC,NLUD) C .. Scalar Arguments .. REAL FCNTIM, JACTIM, LUDTIM INTEGER IDENT, NFCN, NJAC, NLUD C .. Scalars in Common .. INTEGER ID, IWT, NN C .. Arrays in Common .. REAL WT(20) C .. Local Scalars .. REAL HB, HM, XEND, XS REAL S, TIM, TSTTIM INTEGER I, II, J, N C .. Local Arrays .. REAL A(400), B(400), DY(400), Y(20), Z(20) INTEGER NPIV(20) C .. External Functions .. REAL CLOCK, CONST EXTERNAL CLOCK, CONST C .. External Subroutines .. EXTERNAL DDCOMP, EVALU, FCN, IVALU, PDERV C .. Intrinsic Functions .. INTRINSIC FLOAT C .. Common blocks .. COMMON /STCOM5/WT, IWT, NN, ID C .. Executable Statements .. C C A TYPICAL SET OF SOLUTION VALUES FOR EACH PROBLEM IS C DETERMINED FOR TIMING PURPOSES USING THE ENDPOINT VALUES. C TSTTIM = CONST(4)/3.0 ID = IDENT IWT = -1 CALL IVALU(N,XS,XEND,HB,HM,Y,FCNTIM,LUDTIM,JACTIM,WT,IWT,IDENT) CALL EVALU(Y,N,WT,IWT,IDENT) CALL PDERV(XEND,Y,DY) C C SET A TO I-.1*J DO 40 I = 1, N DO 20 J = 1, N A(I+(J-1)*N) = -.1*DY(I+(J-1)*N) 20 CONTINUE A(I+(I-1)*N) = 1. + A(I+(I-1)*N) 40 CONTINUE C C DETERMINE THE DERIVATIVE EVALUATION TIME C S = CLOCK(0.0) NFCN = 0 C LOOP UNTIL TIMING IS SIGNIFICANT 60 CONTINUE CALL FCN(XEND,Y,Z) NFCN = NFCN + 1 TIM = CLOCK(S) IF (TIM.LT.TSTTIM) GO TO 60 FCNTIM = TIM/FLOAT(NFCN) C C DETERMINE THE JACOBIAN EVALUATION TIME C S = CLOCK(0.0) NJAC = 0 C LOOP UNTIL TIMING IS SIGNIFICANT 80 CALL PDERV(XEND,Y,DY) NJAC = NJAC + 1 TIM = CLOCK(S) IF (TIM.LT.TSTTIM) GO TO 80 JACTIM = TIM/FLOAT(NJAC) C C C DETERMINE THE MATRIX FACTORIZATION TIME C S = CLOCK(0.0) NLUD = 0 C LOOP UNTIL TIMING IS SIGNIFICANT 100 CONTINUE DO 140 I = 1, N DO 120 J = 1, N B(I+(J-1)*N) = A(I+(J-1)*N) 120 CONTINUE 140 CONTINUE CALL DDCOMP(N,N,B,NPIV,II) NLUD = NLUD + 1 TIM = CLOCK(S) IF (TIM.LT.TSTTIM) GO TO 100 LUDTIM = TIM/FLOAT(NLUD) RETURN END SUBROUTINE DDCOMP(NDIM,N,A,NPIV,IND) C C--------+---------+---------+---------+---------+---------+---------+-- C COMMON AREA USED FOR STATISTICS GATHERING BY STDTST PACKAGE C .. Scalar Arguments .. INTEGER IND, N, NDIM C .. Array Arguments .. REAL A(NDIM,N) INTEGER NPIV(N) C .. Scalars in Common .. INTEGER NFCN, NJAC, NLUD C .. Local Scalars .. REAL AMULT, COLMAX, HOLD INTEGER I, IP1, IPIVOT, J, JPIVOT, K, NM1, NROW C .. Intrinsic Functions .. INTRINSIC ABS C .. Common blocks .. COMMON /STCOM6/NFCN, NJAC, NLUD C .. Executable Statements .. C--------+---------+---------+---------+---------+---------+---------+-- C NLUD = NLUD + 1 C IND = 0 C C *************** C * C * CHECK FOR A SYSTEM OF ONLY ONE UNKNOWN C * C *************** C IF (N.EQ.1) RETURN C C *************** C * C * INITIALIZE PIVOT VECTOR C * C *************** C DO 20 I = 1, N NPIV(I) = I 20 CONTINUE C C *************** C * C * MAIN LOOP FOR GAUSS ELIMINATION C * C *************** C NM1 = N - 1 DO 140 I = 1, NM1 C C *************** C * C * SEARCH COLUMN FOR LARGEST PIVOT,I.E., C * MAX |A(J,I)|, I <= J <= N. C * C *************** C COLMAX = 0. DO 40 J = I, N HOLD = ABS(A(NPIV(J),I)) IF (HOLD.LE.COLMAX) GO TO 40 COLMAX = HOLD NROW = J 40 CONTINUE C C *************** C * C * TEST FOR SINGULARITY. THE MATRIX IS ASSUMED TO BE SINGULAR C * IF COLMAX (THE ABS. VALUE OF THE PIVOT) IS EQUIVALENT C * TO ZERO, I.E., C * 1.0 + COLMAX = 1.0 . C * IF THIS IS TRUE THEN THE ROUTINE PROCEEDS ON TO THE (I+1)-TH C * STAGE OF THE ELIMINATION. C * C *************** C IF (1.+COLMAX.NE.1.) GO TO 60 IND = -1 GO TO 140 C C *************** C * C * IF AN INTERCHANGE IS NECESSARY, ALTER THE PIVOT VECTOR NPIV. C * C *************** C 60 IPIVOT = NPIV(NROW) IF (NROW.EQ.I) GO TO 80 NPIV(NROW) = NPIV(I) NPIV(I) = IPIVOT C C *************** C * C * THE MULTIPLIERS FOR THE COMPUTATION OF THE REMAINING ROWS ARE C * DETERMINED AND ELIMINATION IS PERFORMED. THE VALUE OF EACH C * MULTIPLIER IS STORED IN THE POSITION OF THE ELIMINATED C * ELEMENT. C * C *************** C 80 IP1 = I + 1 DO 120 J = IP1, N JPIVOT = NPIV(J) AMULT = A(JPIVOT,I)/A(IPIVOT,I) A(JPIVOT,I) = AMULT DO 100 K = IP1, N A(JPIVOT,K) = A(JPIVOT,K) - AMULT*A(IPIVOT,K) 100 CONTINUE 120 CONTINUE 140 CONTINUE IF (1.+ABS(A(NPIV(N),N)).EQ.1.) IND = -1 RETURN END