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<infinity
        thus   forming  12x12  pigeonholes.  Each   integration   step
        contributes  a data point (r1,r2)  which  is  entered  in  one
        pigeonhole. The  counts  of  the  number  of  entries  in each
        pigeonhole are expressed as integer percentages of  the  total
        number  of integration steps and printed out in a 12x12 array,
        zero entries being left blank,  and  positive  values  below 1
        being shown by a dot '.'.
*
        Step-lumping (see [4]) is deemed to make this analysis useless
        so  statistics are only gathered on unlumped steps. It  is  at
        present also  not  considered useful to produce summary tables
        over several problems (and would be costly in array space).
*
*
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
        NSDTST  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 NSDTST anyway, but FLAG is meant to be inspected if
        further  action  of  the  main program depends on a successful
        call to NSDTST.
*
*
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
*
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 of the problem are  computed  by  package routine FCN.
Thus FCN will be an argument to  SOLVER, and 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, ...  )
     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 y-y*  defined
     above
*
     (See   [3]   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 routine FCN
   --- ------- ---
*
The specification of FCN is
        SUBROUTINE FCN(X,Y,YP)
        DOUBLE PRECISION X,Y(51),YP(51)
*
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).
*
*
6. The Dummy NSDTST for Debugging
   --- ----- ------ --- ---------
*
To the user:
*
This will probably be implemented  at  your  site  as  a  source  file
containing  cut-down  versions  of NSDTST and STATS (and other package
routines of no concern to the  user).   This  file  makes  a  complete
program when combined with the NSPROB file and the user's Main Program
and METHOD (and of course SOLVER).  The  cut-down  routines  have  the
same calling sequence as the proper ones.
*
The resulting program uses METHOD to solve the first problem specified
in IDLIST, at the first tolerance specified in TOL.  It will print out
the values of the arguments passed by METHOD to STATS and also the  LU
Decomp  counter  NLUD,  for  5 steps, and then set X = XEND.  The user
should check that the values of X, Y, ERREST, ERRBND look right;  that
X = XEND  forces  termination  as  it  should;  and that NLUD is being
counted up correctly.
*
Feel free to modify these routines to work interactively.
*
To the person implementing the package:
*
Please modify these routines to match the user environment.
*
*
*
7. Implementation Notes
   -------------- -----
*
 7.1.  Machine-dependent constants
*
    These  are   isolated  in  the  routine   CONST   which   has  the
    specification   REAL  FUNCTION CONST(I).  You must set the array C
    and the string MCNAME in the DATA statement:
*
    C(1)   Approximately  the  double  precision  unit  roundoff, used
           in STATS and TRUE.
    C(2)   A number near the underflow threshold, used in TRUE.
    C(3)   The  standard  output  unit number IOUT, used in NSDTST and
           TRUE.   We suggest output be to the terminal by default.
    C(4)   TSTTIM, used in CNTROL (see Clock Routine).
    MCNAME Titling  information  for printout, giving the  name of the
           computer and operating system.
*
    In addition, a call of CONST(0) (executed near the top of  NSDTST)
    is  intended  to  invoke  calls  to  system  routines  to suppress
    underflow  reporting  (which  may  spoil  the  appearance  of  the
    output), etc.
*
    It may be convenient  to  allow  IOUT  (C(3)  above)  to be set by
    interaction with the user at this point.
*
 7.2.  Clock Routine
*
    If   it  is  decided  to  implement  the  timing  facilities,  the
    implementer  should  provide  a  timing routine  which  calls  the
    system clock and has the specification
         REAL FUNCTION CLOCK(S)
         REAL(S)
    It should be such that it is 'reset to zero' by the statement
         S = CLOCK(0.0)
    and (as long as S is left alone) can then be 'read'  as  often  as
    desired by statements like
         TIME = CLOCK(S)
    which sets TIME to the number of seconds of processor  time  since
    CLOCK was 'reset'.
*
    The larger is  the  value  of  TSTTIM  (ie.   CONST(4))  the  more
    accurate,  and expensive, is the timing process.  It should be set
    to a value reflecting the speed of the hardware and the resolution
    of  the  system clock.  We cannot give much guidance here, and our
    experience is that timings inevitably vary significantly from  run
    to run on a time-shared computing system.
*
    If timing is left unimplemented, give  TSTTIM  the  value zero and
    leave the timing data in IVALU as all zero  to cause all values of
    timing statistics to be printed out as zero.
*
 7.3.  The Timing Data in IVALU
*
    Routine IVALU contains values of the  quantity  FCNTIM  for   each
    problem:  these are the cost of one call to  FCN  as  measured  by
    CLOCK, and are used in computing the "overhead"   statistics. They
    should be  recomputed  for  another  machine.  The utility program
    NSGTIM  provided  with  the package, when supplied  with  a  CLOCK
    routine, can either produce  a complete revised IVALU file, or for
    selected problems will produce blocks of output of the form
*
    C PROBLEM xx
          FCNTIM = ...
*
    suitable for inclusion in the text of IVALU.
*
*
 7.4.  Adding extra problems
*
    Say you wish to add three extra problems to class B  of  the  set.
    They  will  then  be  called  B6,  B7  and B8 (for the sake of the
    checking routine PARCHK they  must  follow  consecutively  on  the
    existing  problem-ids).   Their numeric codes which you specify in
    the IDLIST argument of NSDTST will then be 26, 27, 27.   You  need
    to be aware that the internal code, put in variable ID and used in
    FCN, IVALU and EVALU to select the correct section  of  subroutine
    to execute, is 10 less than this, ie.  16, 17 or 17.
*
    The  steps  involved  are:
    a)  Code the  definition  of   the   differential   equations   at
        the appropriate place in FCN.  Change the computed GOTO at the
        head  of  FCN so that the value ID = 16, 17 or 18 gives a jump
        to  the correct place.
    b)  Code the  initial  values,  "true"  final   values  and  other
        data into  the  appropriate  places  in IVALU  and  EVALU in a
        similar  way.   The  true  final  values  should  probably  be
        computed   by   an  integrator   using   higher   than  double
        precision, but the only consequence of slight  inaccuracies is
        to  affect  the  END  PT   GLB ERR  statistic   at   stringent
        tolerances.  At this stage ignore the  weights  W(i)  and  the
        timing data FCNTIM.
    c)  In the argument-checking  routine   PARCHK  change  the   DATA
        statement  which defines array NSYSTM,  to indicate that class
        B now has 8 members.  (Ie.   change its second element from  5
        to 7.)
    d)  Run  the utility  program  NSGWT.F on the tape to compute  the
        values  of  the  weights  W(i).   Similarly  run  NSGTIM.F  to
        determine FCNTIM for your problems.
*
Adding  an  entire  new  problem class is  no  more  difficult.   Note
that  it  involves  increasing  the   value   of   NCLASS  in the DATA
statement and the length of NSYSTM in the  dimensioning   statement in
PARCHK; also check the string IDCLAS  in  NSDTST has enough letters in
it.
*
 7.5.  Other statistics to print
*
Statistics  which are gathered but do  not  appear   in   the   output
tables  include   NSTART,  NSTL  and  TRUTIM.  They are defined in the
description   of   COMMON  /NSCOM3/  below.   NSTART   assesses    the
efficiency  of  the  starting  phase  of  a code and may be of general
interest.  TRUTIM is of use  if  you  are  troubled  by  the overheads
of calls to TRUE with OPT  >=  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<INFINITY
C         THUS   FORMING  12X12  PIGEONHOLES.  EACH   INTEGRATION   STEP
C         CONTRIBUTES  A DATA POINT (R1,R2)  WHICH  IS  ENTERED  IN  ONE
C         PIGEONHOLE. THE  COUNTS  OF  THE  NUMBER  OF  ENTRIES  IN EACH
C         PIGEONHOLE ARE EXPRESSED AS INTEGER PERCENTAGES OF  THE  TOTAL
C         NUMBER  OF INTEGRATION STEPS AND PRINTED OUT IN A 12X12 ARRAY,
C         ZERO ENTRIES BEING LEFT BLANK,  AND  POSITIVE  VALUES  BELOW 1
C         BEING SHOWN BY A DOT '.'.
C
C         STEP-LUMPING (SEE [4]) IS DEEMED TO MAKE THIS ANALYSIS USELESS
C         SO  STATISTICS ARE ONLY GATHERED ON UNLUMPED STEPS. IT  IS  AT
C         PRESENT ALSO  NOT  CONSIDERED USEFUL TO PRODUCE SUMMARY TABLES
C         OVER SEVERAL PROBLEMS (AND WOULD BE COSTLY IN ARRAY SPACE).
C
C
C NORMEF  ONE  OF  0   1   OR   2   ,   SELECTS   NORMALIZED  EFFICIENCY
C         STATISTICS.    THESE  TRY  TO  COMPENSATE  FOR  THE  FACT THAT
C         ACHIEVED  ACCURACY  MAY  BE MUCH HIGHER OR LOWER   THAN   THAT
C         REQUESTED  BY  TOL, AND THIS RELATIONSHIP IS VERY PROBLEM- AND
C         METHOD- DEPENDENT.  FOR EACH PROBLEM, A LEAST-SQUARES  FIT  IS
C         MADE OF LOG10(ACTUAL ERROR) VS LOG10(TOL) AND USED TO ESTIMATE
C         WHAT THE VARIOUS COST STATISTICS WOULD BE FOR AN ACTUAL  ERROR
C         OF 10**N.  THIS IS ACHIEVED BY INTERPOLATION, FOR THOSE N SUCH
C         THAT 10**N LIES WITHIN THE RANGE OF ACCURACIES  ACHIEVED  WITH
C         THE USER-SPECIFIED TOLERANCES.
C     0   NO NORMALIZED STATISTICS
C     1   NORMALIZED STATISTICS ARE PRODUCED TAKING THE  'ACTUAL  ERROR'
C         USED IN THE LEAST SQUARES FIT TO BE THE ENDPOINT GLOBAL ERROR.
C     2   NORMALIZED STATISTICS ARE PRODUCED TAKING  'ACTUAL  ERROR'  AS
C         THE  MAXIMUM  GLOBAL ERROR OVER THE RANGE.  N.B.  IN THIS CASE
C         OPT MUST BE AT LEAST 2.
C
C NRMTYP  ONE OF 1, 2  OR 3, SELECTS THE NORM USED IN ASSESSING THE SIZE
C         OF LOCAL AND GLOBAL ERRORS. IT SHOULD BE CHOSEN BY THE USER TO
C         AGREE WITH THE NORM USED IN SOLVER. WE OFFER:
C     1   MAX-NORM.
C     2   2-NORM (EUCLIDEAN NORM).
C     3   R.M.S. NORM, THAT IS (2-NORM OF X)/SQRT(N) FOR AN N-VECTOR X.
C
C TOL     (INPUT) REAL ARRAY, HOLDS LIST OF UP TO 10  TOLERANCES  TO  BE
C         USED,  IN  STRICTLY  DECREASING  ORDER,  WITH 0 AS TERMINATOR.
C         EACH PROBLEM IS INTEGRATED AT EACH TOLERANCE IN TURN.
C         EXAMPLE:  IN CALLING PROGRAM
C                   REAL TOL(11)
C                   DATA TOL/1E-1,1E-3,1E-5,1E-7,7*0E0/
C         REQUESTS THE FOUR TOLERANCES .1, .001, .00001, .0000001.
C
C IDLIST  (INPUT) INTEGER ARRAY, HOLDS LIST OF GROUPS OF  PROBLEMS,  AND
C         SPECIFIES  FOR  EACH  ONE  WHETHER  IT  IS TO BE INTEGRATED IN
C         SCALED OR UNSCALED  FORM  (SEE  GENERAL  NOTES  ABOVE).   EACH
C         PROBLEM  IS SPECIFIED BY A NUMERIC CODE, 11 TO 14 FOR PROBLEMS
C         A1 TO A4, 21 TO 25 FOR B1 TO B5  ETC.   A  ZERO  TERMINATES  A
C         GROUP AND TWO ZEROS TERMINATE THE LIST OF GROUPS.
C         IF THE PROBLEM CODE IS GIVEN A NEGATIVE SIGN,  THE  SYSTEM  IS
C         INTEGRATED  IN  UNSCALED  FORM;  IF A POSITIVE SIGN, IN SCALED
C         FORM.
C         EXAMPLE:  IN CALLING PROGRAM
C                   INTEGER IDLIST(7)
C                   DATA IDLIST/11,22,0,-31,-51,0,0/
C         SPECIFIES GROUP 1 CONSISTING OF PROBLEMS A1,B2 AND GROUP 2  OF
C         PROBLEMS  C1,E1.  THE FIRST TWO ARE TO BE SOLVED IN THE SCALED
C         FORM AND THE LAST TWO  IN  UNSCALED  FORM.
C
C         THE TOTAL LENGTH OF THE LIST INCLUDING ZEROS MUST BE  AT  MOST
C         60 ITEMS.
C
C FLAG
C         (OUTPUT) REAL.  A NONZERO VALUE INDICATES  THAT  THE  CALL  TO
C         NSDTST  WAS  ABORTED BECAUSE OF ARGUMENT ERRORS, IN WHICH CASE
C         THE VALUES OF THE DECIMAL DIGITS OF FLAG INDICATE THE ERROR(S)
C         THAT HAVE OCCURRED, AS FOLLOWS:
C           1:  OPT INVALID.
C           2:  NORMEF INVALID.
C           3:  NORMEF = 2 WAS REQUESTED WITH OPT = 1.
C           4:  A NEGATIVE  TOLERANCE  WAS  SUPPLIED,  OR THE  LIST  OF
C               TOLERANCES WAS NOT IN DECREASING ORDER.
C           5:  THE LIST OF TOLERANCES WAS EMPTY OR NOT TERMINATED BY A
C               ZERO.
C           6:  AN INVALID PROBLEM-ID WAS FOUND IN IDLIST.
C           7:  THE LIST  OF  GROUPS  IN  IDLIST  IS  EMPTY  OR  IS NOT
C               TERMINATED  BY  TWO  ZEROS OR HAS MORE THAN THE MAXIMUM
C               ALLOWED NUMBER (6) OF GROUPS.
C           8:  NRMTYP INVALID.
C         EG.  A VALUE FLAG = 0.245E 03 INDICATES THAT ERRORS 2, 4 AND 5
C         IN  THE  ABOVE  LIST  HAVE  OCCURRED.  ITS VALUE IF NONZERO IS
C         PRINTED BY NSDTST ANYWAY, BUT FLAG IS MEANT TO BE INSPECTED IF
C         FURTHER  ACTION  OF  THE  MAIN PROGRAM DEPENDS ON A SUCCESSFUL
C         CALL TO NSDTST.
C
C
C 3. INTERFACE ROUTINE METHOD
C    --------- ------- ------
C
C THIS INVOKES THE CODE BEING TESTED, CALL IT SOLVER.  THE SPECIFICATION
C IS
C         SUBROUTINE METHOD(N,X,Y,XEND,TOL,HMAX,HSTART)
C         INTEGER N
C         DOUBLE PRECISION X,Y(N),XEND,TOL,HMAX,HSTART
C         EXTERNAL FCN
C
C METHOD IS TO BE WRITTEN BY THE USER AS A SIMPLE INTEGRATOR TO  ADVANCE
C THE  SOLUTION OF N DIFFERENTIAL EQUATIONS FROM THE INITIAL VALUES HELD
C IN X,Y UP TO XEND, WITH AN UNWEIGHTED ABSOLUTE ERROR CONTROL  OF  TOL.
C HMAX  IS  A  RECOMMENDED  MAXIMUM STEPSIZE AND HSTART IS A RECOMMENDED
C INITIAL STEPSIZE.  IF SOLVER CAN MAKE USE OF THESE TWO PARAMETERS, THE
C STATISTICS WILL PROBABLY BE MORE FAVORABLE AND RELIABLE, BUT THEIR USE
C IS NOT CRUCIAL.
C
C THE DERIVATIVES OF THE PROBLEM ARE  COMPUTED  BY  PACKAGE ROUTINE FCN.
C THUS FCN WILL BE AN ARGUMENT TO  SOLVER, AND MUST BE DECLARED EXTERNAL
C IN METHOD.
C
C METHOD SHOULD CALL SOLVER IN ONE-STEP MODE  SO  THAT  A  CALL  TO  THE
C PACKAGE  ROUTINE  STATS  CAN  BE  MADE AFTER EACH SUCCESSFUL STEP.  IF
C SOLVER DOES NOT HAVE THIS FACILITY, SOLVER MUST HAVE A CALL  TO  STATS
C INSERTED AT THE APPROPRIATE POINT IN THE CODE.
C
C SOME  CALLS  TO  METHOD  ARE  INTENDED  TO  BE  ABORTED  AFTER  A  FEW
C INTEGRATION  STEPS  BY  THE  STATS CALL SETTING X = XEND.  THUS A TEST
C SHOULD BE MADE AFTER EACH CALL TO STATS, OF THE FORM
C         IF STATS HAS SET X = XEND THEN EXIT.
C
C NB:  IF THE ACTUAL X  ARGUMENT  TO  STATS  IS  DIFFERENT  FROM  THE  X
C ARGUMENT  OF METHOD (WHICH MAY BE NECESSARY WITH SOME SOLVERS), ENSURE
C THAT THE X ARGUMENT OF METHOD IS SET TO XEND  BEFORE  EXIT,  ELSE  THE
C PACKAGE WILL REPORT 'METHOD FAILED TO START'.
C
C THE ALGORITHM FOR METHOD SHOULD THUS BE OF THE FORM:
C - DECLARE ALL ARGUMENTS AND WORKSPACE EXPECTED BY SOLVER
C - SET APPROPRIATE OPTIONS  INCLUDING  ABSOLUTE  ERROR  CONTROL  AND
C    ONE-STEP MODE
C - INITIALIZE EXTRA ARGUMENTS IF REQUIRED
C - FOR EACH SUCCESSFUL STEP DO
C    - CALL SOLVER( ...  ,FCN, ...  )
C      EXIT IF SOLVER IS IN TROUBLE.
C    - SET X,Y TO THE JUST COMPUTED MESHPOINT X AND SOLUTION VECTOR Y
C    - SET ERRBND TO THE BOUND THAT IS  SATISFIED  BY ||ERREST||, AND
C      HENCE IS INTENDED TO BE SATISFIED BY ||LE||, AT THIS STEP.
C    - SET ERREST  TO THE  LOCAL ERROR ESTIMATE  VECTOR Y-Y*  DEFINED
C      ABOVE
C
C      (SEE   [3]   FOR   DISCUSSION  AND  NOTE  THAT X,Y ARE IGNORED
C      UNLESS  OPT.GE.2,  ERRBND   IS  IGNORED  UNLESS  OPT.GE.3, AND
C      ERREST IS IGNORED UNLESS OPT.GE.4.)
C
C    - CALL STATS(X,Y,ERRBND,ERREST)
C    - EXIT IF X .GE.  XEND.
C - ENDLOOP
C
C
C ON NORMAL EXIT X,Y MUST HOLD XEND AND THE SOLUTION AT XEND.   ON  EXIT
C BECAUSE  SOLVER  WAS  IN TROUBLE, X MUST HOLD THE FINAL POINT REACHED.
C ON AN EXIT FORCED BY STATS, X MUST HOLD XEND.
C
C
C
C
C
C
C 4. CONTROLLING THE DESTINATION OF OUTPUT
C    ----------- --- ----------- -- ------
C
C THE UNIT NUMBER ON WHICH THE PACKAGE WRITES ITS OUTPUT  IS  SET  BY  A
C CALL  TO ONE OF THE PACKAGE ROUTINES, AND YOU CAN FIND OUT WHAT IT IS,
C BY PUTTING THE STATEMENT
C
C       IOUT = CONST(3)
C
C IN YOUR MAIN PROGRAM.  PROBABLY OUTPUT WILL DEFAULT TO YOUR  TERMINAL,
C WHICH  IS  GOOD  FOR DEBUGGING.  FOR MORE SERIOUS WORK YOU MAY WANT TO
C SEND OUTPUT TO A FILE.  THE STATEMENTS
C
C       IOUT = CONST(3)
C       OPEN(IOUT, FILE=FILENAME, OTHER OPTIONS..  )
C
C WILL DO THIS FOR YOU, ASSUMING YOUR  FORTRAN   I/O  IS CONSISTENT WITH
C THE  1977 STANDARD.
C
C
C
C 5. THE ROUTINE FCN
C    --- ------- ---
C
C THE SPECIFICATION OF FCN IS
C         SUBROUTINE FCN(X,Y,YP)
C         DOUBLE PRECISION X,Y(51),YP(51)
C
C ON ENTRY X HOLDS THE INDEPENDENT VARIABLE AND Y HOLDS  THE  VECTOR  OF
C DEPENDENT  VARIABLES.   ON EXIT YP HOLDS THE VECTOR OF DERIVATIVES FOR
C THE PROBLEM BEING SOLVED (SELECTED BY A SWITCH IN COMMON).
C
C
C 6. THE DUMMY NSDTST FOR DEBUGGING
C    --- ----- ------ --- ---------
C
C TO THE USER:
C
C THIS WILL PROBABLY BE IMPLEMENTED  AT  YOUR  SITE  AS  A  SOURCE  FILE
C CONTAINING  CUT-DOWN  VERSIONS  OF NSDTST AND STATS (AND OTHER PACKAGE
C ROUTINES OF NO CONCERN TO THE  USER).   THIS  FILE  MAKES  A  COMPLETE
C PROGRAM WHEN COMBINED WITH THE NSPROB FILE AND THE USER'S MAIN PROGRAM
C AND METHOD (AND OF COURSE SOLVER).  THE  CUT-DOWN  ROUTINES  HAVE  THE
C SAME CALLING SEQUENCE AS THE PROPER ONES.
C
C THE RESULTING PROGRAM USES METHOD TO SOLVE THE FIRST PROBLEM SPECIFIED
C IN IDLIST, AT THE FIRST TOLERANCE SPECIFIED IN TOL.  IT WILL PRINT OUT
C THE VALUES OF THE ARGUMENTS PASSED BY METHOD TO STATS AND ALSO THE  LU
C DECOMP  COUNTER  NLUD,  FOR  5 STEPS, AND THEN SET X = XEND.  THE USER
C SHOULD CHECK THAT THE VALUES OF X, Y, ERREST, ERRBND LOOK RIGHT;  THAT
C X = XEND  FORCES  TERMINATION  AS  IT  SHOULD;  AND THAT NLUD IS BEING
C COUNTED UP CORRECTLY.
C
C FEEL FREE TO MODIFY THESE ROUTINES TO WORK INTERACTIVELY.
C
C TO THE PERSON IMPLEMENTING THE PACKAGE:
C
C PLEASE MODIFY THESE ROUTINES TO MATCH THE USER ENVIRONMENT.
C
C
C
C 7. IMPLEMENTATION NOTES
C    -------------- -----
C
C  7.1.  MACHINE-DEPENDENT CONSTANTS
C
C     THESE  ARE   ISOLATED  IN  THE  ROUTINE   CONST   WHICH   HAS  THE
C     SPECIFICATION   REAL  FUNCTION CONST(I).  YOU MUST SET THE ARRAY C
C     AND THE STRING MCNAME IN THE DATA STATEMENT:
C
C     C(1)   APPROXIMATELY  THE  DOUBLE  PRECISION  UNIT  ROUNDOFF, USED
C            IN STATS AND TRUE.
C     C(2)   A NUMBER NEAR THE UNDERFLOW THRESHOLD, USED IN TRUE.
C     C(3)   THE  STANDARD  OUTPUT  UNIT NUMBER IOUT, USED IN NSDTST AND
C            TRUE.   WE SUGGEST OUTPUT BE TO THE TERMINAL BY DEFAULT.
C     C(4)   TSTTIM, USED IN CNTROL (SEE CLOCK ROUTINE).
C     MCNAME TITLING  INFORMATION  FOR PRINTOUT, GIVING THE  NAME OF THE
C            COMPUTER AND OPERATING SYSTEM.
C
C     IN ADDITION, A CALL OF CONST(0) (EXECUTED NEAR THE TOP OF  NSDTST)
C     IS  INTENDED  TO  INVOKE  CALLS  TO  SYSTEM  ROUTINES  TO SUPPRESS
C     UNDERFLOW  REPORTING  (WHICH  MAY  SPOIL  THE  APPEARANCE  OF  THE
C     OUTPUT), ETC.
C
C     IT MAY BE CONVENIENT  TO  ALLOW  IOUT  (C(3)  ABOVE)  TO BE SET BY
C     INTERACTION WITH THE USER AT THIS POINT.
C
C  7.2.  CLOCK ROUTINE
C
C     IF   IT  IS  DECIDED  TO  IMPLEMENT  THE  TIMING  FACILITIES,  THE
C     IMPLEMENTER  SHOULD  PROVIDE  A  TIMING ROUTINE  WHICH  CALLS  THE
C     SYSTEM CLOCK AND HAS THE SPECIFICATION
C          REAL FUNCTION CLOCK(S)
C          REAL(S)
C     IT SHOULD BE SUCH THAT IT IS 'RESET TO ZERO' BY THE STATEMENT
C          S = CLOCK(0.0)
C     AND (AS LONG AS S IS LEFT ALONE) CAN THEN BE 'READ'  AS  OFTEN  AS
C     DESIRED BY STATEMENTS LIKE
C          TIME = CLOCK(S)
C     WHICH SETS TIME TO THE NUMBER OF SECONDS OF PROCESSOR  TIME  SINCE
C     CLOCK WAS 'RESET'.
C
C     THE LARGER IS  THE  VALUE  OF  TSTTIM  (IE.   CONST(4))  THE  MORE
C     ACCURATE,  AND EXPENSIVE, IS THE TIMING PROCESS.  IT SHOULD BE SET
C     TO A VALUE REFLECTING THE SPEED OF THE HARDWARE AND THE RESOLUTION
C     OF  THE  SYSTEM CLOCK.  WE CANNOT GIVE MUCH GUIDANCE HERE, AND OUR
C     EXPERIENCE IS THAT TIMINGS INEVITABLY VARY SIGNIFICANTLY FROM  RUN
C     TO RUN ON A TIME-SHARED COMPUTING SYSTEM.
C
C     IF TIMING IS LEFT UNIMPLEMENTED, GIVE  TSTTIM  THE  VALUE ZERO AND
C     LEAVE THE TIMING DATA IN IVALU AS ALL ZERO  TO CAUSE ALL VALUES OF
C     TIMING STATISTICS TO BE PRINTED OUT AS ZERO.
C
C  7.3.  THE TIMING DATA IN IVALU
C
C     ROUTINE IVALU CONTAINS VALUES OF THE  QUANTITY  FCNTIM  FOR   EACH
C     PROBLEM:  THESE ARE THE COST OF ONE CALL TO  FCN  AS  MEASURED  BY
C     CLOCK, AND ARE USED IN COMPUTING THE "OVERHEAD"   STATISTICS. THEY
C     SHOULD BE  RECOMPUTED  FOR  ANOTHER  MACHINE.  THE UTILITY PROGRAM
C     NSGTIM  PROVIDED  WITH  THE PACKAGE, WHEN SUPPLIED  WITH  A  CLOCK
C     ROUTINE, CAN EITHER PRODUCE  A COMPLETE REVISED IVALU FILE, OR FOR
C     SELECTED PROBLEMS WILL PRODUCE BLOCKS OF OUTPUT OF THE FORM
C
C     C PROBLEM XX
C           FCNTIM = ...
C
C     SUITABLE FOR INCLUSION IN THE TEXT OF IVALU.
C
C
C  7.4.  ADDING EXTRA PROBLEMS
C
C     SAY YOU WISH TO ADD THREE EXTRA PROBLEMS TO CLASS B  OF  THE  SET.
C     THEY  WILL  THEN  BE  CALLED  B6,  B7  AND B8 (FOR THE SAKE OF THE
C     CHECKING ROUTINE PARCHK THEY  MUST  FOLLOW  CONSECUTIVELY  ON  THE
C     EXISTING  PROBLEM-IDS).   THEIR NUMERIC CODES WHICH YOU SPECIFY IN
C     THE IDLIST ARGUMENT OF NSDTST WILL THEN BE 26, 27, 27.   YOU  NEED
C     TO BE AWARE THAT THE INTERNAL CODE, PUT IN VARIABLE ID AND USED IN
C     FCN, IVALU AND EVALU TO SELECT THE CORRECT SECTION  OF  SUBROUTINE
C     TO EXECUTE, IS 10 LESS THAN THIS, IE.  16, 17 OR 17.
C
C     THE  STEPS  INVOLVED  ARE:
C     A)  CODE THE  DEFINITION  OF   THE   DIFFERENTIAL   EQUATIONS   AT
C         THE APPROPRIATE PLACE IN FCN.  CHANGE THE COMPUTED GOTO AT THE
C         HEAD  OF  FCN SO THAT THE VALUE ID = 16, 17 OR 18 GIVES A JUMP
C         TO  THE CORRECT PLACE.
C     B)  CODE THE  INITIAL  VALUES,  "TRUE"  FINAL   VALUES  AND  OTHER
C         DATA INTO  THE  APPROPRIATE  PLACES  IN IVALU  AND  EVALU IN A
C         SIMILAR  WAY.   THE  TRUE  FINAL  VALUES  SHOULD  PROBABLY  BE
C         COMPUTED   BY   AN  INTEGRATOR   USING   HIGHER   THAN  DOUBLE
C         PRECISION, BUT THE ONLY CONSEQUENCE OF SLIGHT  INACCURACIES IS
C         TO  AFFECT  THE  END  PT   GLB ERR  STATISTIC   AT   STRINGENT
C         TOLERANCES.  AT THIS STAGE IGNORE THE  WEIGHTS  W(I)  AND  THE
C         TIMING DATA FCNTIM.
C     C)  IN THE ARGUMENT-CHECKING  ROUTINE   PARCHK  CHANGE  THE   DATA
C         STATEMENT  WHICH DEFINES ARRAY NSYSTM,  TO INDICATE THAT CLASS
C         B NOW HAS 8 MEMBERS.  (IE.   CHANGE ITS SECOND ELEMENT FROM  5
C         TO 7.)
C     D)  RUN  THE UTILITY  PROGRAM  NSGWT.F ON THE TAPE TO COMPUTE  THE
C         VALUES  OF  THE  WEIGHTS  W(I).   SIMILARLY  RUN  NSGTIM.F  TO
C         DETERMINE FCNTIM FOR YOUR PROBLEMS.
C
C ADDING  AN  ENTIRE  NEW  PROBLEM CLASS IS  NO  MORE  DIFFICULT.   NOTE
C THAT  IT  INVOLVES  INCREASING  THE   VALUE   OF   NCLASS  IN THE DATA
C STATEMENT AND THE LENGTH OF NSYSTM IN THE  DIMENSIONING   STATEMENT IN
C PARCHK; ALSO CHECK THE STRING IDCLAS  IN  NSDTST HAS ENOUGH LETTERS IN
C IT.
C
C  7.5.  OTHER STATISTICS TO PRINT
C
C STATISTICS  WHICH ARE GATHERED BUT DO  NOT  APPEAR   IN   THE   OUTPUT
C TABLES  INCLUDE   NSTART,  NSTL  AND  TRUTIM.  THEY ARE DEFINED IN THE
C DESCRIPTION   OF   COMMON  /NSCOM3/  BELOW.   NSTART   ASSESSES    THE
C EFFICIENCY  OF  THE  STARTING  PHASE  OF  A CODE AND MAY BE OF GENERAL
C INTEREST.  TRUTIM IS OF USE  IF  YOU  ARE  TROUBLED  BY  THE OVERHEADS
C OF CALLS TO TRUE WITH OPT  >=  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<P<1 BECOMES '  .',
C  P OUTSIDE RANGE BECOMES '***'
CERR  CHARACTER*1 DIG(0:9)/'0','1','2','3','4','5','6','7','8','9'/
C     .. Scalar Arguments ..
      REAL                      P
C     .. Local Scalars ..
      INTEGER                   I, J
C     .. Local Arrays ..
      CHARACTER                 DIG(0:9)
C     .. Data statements ..
      DATA                      DIG/'0', '1', '2', '3', '4', '5', '6',
     *                          '7', '8', '9'/
C     .. Executable Statements ..
      DIG(0) = ' '
      IF (P.LT.0 .OR. P.GT.1) THEN
         STR3 = '***'
      ELSE IF (P.EQ.0.) THEN
         STR3 = '   '
      ELSE IF (P.LT..01) THEN
         STR3 = '  .'
      ELSE
         DO 20 J = 1, 3
            I = P
            P = P - I
            STR3(J:J) = DIG(I)
            IF (I.GT.0) DIG(0) = '0'
            P = 10.*P
   20    CONTINUE
      END IF
      RETURN
      END
      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<INFINITY
C         THUS   FORMING  12X12  PIGEONHOLES.  EACH   INTEGRATION   STEP
C         CONTRIBUTES  A DATA POINT (R1,R2)  WHICH  IS  ENTERED  IN  ONE
C         PIGEONHOLE. THE  COUNTS  OF  THE  NUMBER  OF  ENTRIES  IN EACH
C         PIGEONHOLE ARE EXPRESSED AS INTEGER PERCENTAGES OF  THE  TOTAL
C         NUMBER  OF INTEGRATION STEPS AND PRINTED OUT IN A 12X12 ARRAY,
C         ZERO ENTRIES BEING LEFT BLANK,  AND  POSITIVE  VALUES  BELOW 1
C         BEING SHOWN BY A DOT '.'.
C
C         STEP-LUMPING (SEE [4]) IS DEEMED TO MAKE THIS ANALYSIS USELESS
C         SO  STATISTICS ARE ONLY GATHERED ON UNLUMPED STEPS. IT  IS  AT
C         PRESENT ALSO  NOT  CONSIDERED USEFUL TO PRODUCE SUMMARY TABLES
C         OVER SEVERAL PROBLEMS (AND WOULD BE COSTLY IN ARRAY SPACE).
C
C
C NORMEF  ONE  OF  0   1   OR   2   ,   SELECTS   NORMALIZED  EFFICIENCY
C         STATISTICS.    THESE  TRY  TO  COMPENSATE  FOR  THE  FACT THAT
C         ACHIEVED  ACCURACY  MAY  BE MUCH HIGHER OR LOWER   THAN   THAT
C         REQUESTED  BY  TOL, AND THIS RELATIONSHIP IS VERY PROBLEM- AND
C         METHOD- DEPENDENT.  FOR EACH PROBLEM, A LEAST-SQUARES  FIT  IS
C         MADE OF LOG10(ACTUAL ERROR) VS LOG10(TOL) AND USED TO ESTIMATE
C         WHAT THE VARIOUS COST STATISTICS WOULD BE FOR AN ACTUAL  ERROR
C         OF 10**N.  THIS IS ACHIEVED BY INTERPOLATION, FOR THOSE N SUCH
C         THAT 10**N LIES WITHIN THE RANGE OF ACCURACIES  ACHIEVED  WITH
C         THE USER-SPECIFIED TOLERANCES.
C     0   NO NORMALIZED STATISTICS
C     1   NORMALIZED STATISTICS ARE PRODUCED TAKING THE  'ACTUAL  ERROR'
C         USED IN THE LEAST SQUARES FIT TO BE THE ENDPOINT GLOBAL ERROR.
C     2   NORMALIZED STATISTICS ARE PRODUCED TAKING  'ACTUAL  ERROR'  AS
C         THE  MAXIMUM  GLOBAL ERROR OVER THE RANGE.  N.B.  IN THIS CASE
C         OPT MUST BE AT LEAST 2.
C
C NRMTYP  ONE OF 1, 2  OR 3, SELECTS THE NORM USED IN ASSESSING THE SIZE
C         OF LOCAL AND GLOBAL ERRORS. IT SHOULD BE CHOSEN BY THE USER TO
C         AGREE WITH THE NORM USED IN SOLVER. WE OFFER:
C     1   MAX-NORM.
C     2   2-NORM (EUCLIDEAN NORM).
C     3   R.M.S. NORM, THAT IS (2-NORM OF X)/SQRT(N) FOR AN N-VECTOR X.
C
C TOL     (INPUT) REAL ARRAY, HOLDS LIST OF UP TO 10  TOLERANCES  TO  BE
C         USED,  IN  STRICTLY  DECREASING  ORDER,  WITH 0 AS TERMINATOR.
C         EACH PROBLEM IS INTEGRATED AT EACH TOLERANCE IN TURN.
C         EXAMPLE:  IN CALLING PROGRAM
C                   REAL TOL(11)
C                   DATA TOL/1E-1,1E-3,1E-5,1E-7,7*0E0/
C         REQUESTS THE FOUR TOLERANCES .1, .001, .00001, .0000001.
C
C IDLIST  (INPUT) INTEGER ARRAY, HOLDS LIST OF GROUPS OF  PROBLEMS,  AND
C         SPECIFIES  FOR  EACH  ONE  WHETHER  IT  IS TO BE INTEGRATED IN
C         SCALED OR UNSCALED  FORM  (SEE  GENERAL  NOTES  ABOVE).   EACH
C         PROBLEM  IS SPECIFIED BY A NUMERIC CODE, 11 TO 14 FOR PROBLEMS
C         A1 TO A4, 21 TO 25 FOR B1 TO B5  ETC.   A  ZERO  TERMINATES  A
C         GROUP AND TWO ZEROS TERMINATE THE LIST OF GROUPS.
C         IF THE PROBLEM CODE IS GIVEN A NEGATIVE SIGN,  THE  SYSTEM  IS
C         INTEGRATED  IN  UNSCALED  FORM;  IF A POSITIVE SIGN, IN SCALED
C         FORM.
C         EXAMPLE:  IN CALLING PROGRAM
C                   INTEGER IDLIST(7)
C                   DATA IDLIST/11,22,0,-31,-51,0,0/
C         SPECIFIES GROUP 1 CONSISTING OF PROBLEMS A1,B2 AND GROUP 2  OF
C         PROBLEMS  C1,E1.  THE FIRST TWO ARE TO BE SOLVED IN THE SCALED
C         FORM AND THE LAST TWO  IN  UNSCALED  FORM.
C
C         THE TOTAL LENGTH OF THE LIST INCLUDING ZEROS MUST BE  AT  MOST
C         60 ITEMS.
C
C FLAG
C         (OUTPUT) REAL.  A NONZERO VALUE INDICATES  THAT  THE  CALL  TO
C         NSDTST  WAS  ABORTED BECAUSE OF ARGUMENT ERRORS, IN WHICH CASE
C         THE VALUES OF THE DECIMAL DIGITS OF FLAG INDICATE THE ERROR(S)
C         THAT HAVE OCCURRED, AS FOLLOWS:
C           1:  OPT INVALID.
C           2:  NORMEF INVALID.
C           3:  NORMEF = 2 WAS REQUESTED WITH OPT = 1.
C           4:  A NEGATIVE  TOLERANCE  WAS  SUPPLIED,  OR THE  LIST  OF
C               TOLERANCES WAS NOT IN DECREASING ORDER.
C           5:  THE LIST OF TOLERANCES WAS EMPTY OR NOT TERMINATED BY A
C               ZERO.
C           6:  AN INVALID PROBLEM-ID WAS FOUND IN IDLIST.
C           7:  THE LIST  OF  GROUPS  IN  IDLIST  IS  EMPTY  OR  IS NOT
C               TERMINATED  BY  TWO  ZEROS OR HAS MORE THAN THE MAXIMUM
C               ALLOWED NUMBER (6) OF GROUPS.
C           8:  NRMTYP INVALID.
C         EG.  A VALUE FLAG = 0.245E 03 INDICATES THAT ERRORS 2, 4 AND 5
C         IN  THE  ABOVE  LIST  HAVE  OCCURRED.  ITS VALUE IF NONZERO IS
C         PRINTED BY NSDTST ANYWAY, BUT FLAG IS MEANT TO BE INSPECTED IF
C         FURTHER  ACTION  OF  THE  MAIN PROGRAM DEPENDS ON A SUCCESSFUL
C         CALL TO NSDTST.
C
C
C 3. INTERFACE ROUTINE METHOD
C    --------- ------- ------
C
C THIS INVOKES THE CODE BEING TESTED, CALL IT SOLVER.  THE SPECIFICATION
C IS
C         SUBROUTINE METHOD(N,X,Y,XEND,TOL,HMAX,HSTART)
C         INTEGER N
C         DOUBLE PRECISION X,Y(N),XEND,TOL,HMAX,HSTART
C         EXTERNAL FCN
C
C METHOD IS TO BE WRITTEN BY THE USER AS A SIMPLE INTEGRATOR TO  ADVANCE
C THE  SOLUTION OF N DIFFERENTIAL EQUATIONS FROM THE INITIAL VALUES HELD
C IN X,Y UP TO XEND, WITH AN UNWEIGHTED ABSOLUTE ERROR CONTROL  OF  TOL.
C HMAX  IS  A  RECOMMENDED  MAXIMUM STEPSIZE AND HSTART IS A RECOMMENDED
C INITIAL STEPSIZE.  IF SOLVER CAN MAKE USE OF THESE TWO PARAMETERS, THE
C STATISTICS WILL PROBABLY BE MORE FAVORABLE AND RELIABLE, BUT THEIR USE
C IS NOT CRUCIAL.
C
C THE DERIVATIVES OF THE PROBLEM ARE  COMPUTED  BY  PACKAGE ROUTINE FCN.
C THUS FCN WILL BE AN ARGUMENT TO  SOLVER, AND MUST BE DECLARED EXTERNAL
C IN METHOD.
C
C METHOD SHOULD CALL SOLVER IN ONE-STEP MODE  SO  THAT  A  CALL  TO  THE
C PACKAGE  ROUTINE  STATS  CAN  BE  MADE AFTER EACH SUCCESSFUL STEP.  IF
C SOLVER DOES NOT HAVE THIS FACILITY, SOLVER MUST HAVE A CALL  TO  STATS
C INSERTED AT THE APPROPRIATE POINT IN THE CODE.
C
C SOME  CALLS  TO  METHOD  ARE  INTENDED  TO  BE  ABORTED  AFTER  A  FEW
C INTEGRATION  STEPS  BY  THE  STATS CALL SETTING X = XEND.  THUS A TEST
C SHOULD BE MADE AFTER EACH CALL TO STATS, OF THE FORM
C         IF STATS HAS SET X = XEND THEN EXIT.
C
C NB:  IF THE ACTUAL X  ARGUMENT  TO  STATS  IS  DIFFERENT  FROM  THE  X
C ARGUMENT  OF METHOD (WHICH MAY BE NECESSARY WITH SOME SOLVERS), ENSURE
C THAT THE X ARGUMENT OF METHOD IS SET TO XEND  BEFORE  EXIT,  ELSE  THE
C PACKAGE WILL REPORT 'METHOD FAILED TO START'.
C
C THE ALGORITHM FOR METHOD SHOULD THUS BE OF THE FORM:
C - DECLARE ALL ARGUMENTS AND WORKSPACE EXPECTED BY SOLVER
C - SET APPROPRIATE OPTIONS  INCLUDING  ABSOLUTE  ERROR  CONTROL  AND
C    ONE-STEP MODE
C - INITIALIZE EXTRA ARGUMENTS IF REQUIRED
C - FOR EACH SUCCESSFUL STEP DO
C    - CALL SOLVER( ...  ,FCN, ...  )
C      EXIT IF SOLVER IS IN TROUBLE.
C    - SET X,Y TO THE JUST COMPUTED MESHPOINT X AND SOLUTION VECTOR Y
C    - SET ERRBND TO THE BOUND THAT IS  SATISFIED  BY ||ERREST||, AND
C      HENCE IS INTENDED TO BE SATISFIED BY ||LE||, AT THIS STEP.
C    - SET ERREST  TO THE  LOCAL ERROR ESTIMATE  VECTOR Y-Y*  DEFINED
C      ABOVE
C
C      (SEE   [3]   FOR   DISCUSSION  AND  NOTE  THAT X,Y ARE IGNORED
C      UNLESS  OPT.GE.2,  ERRBND   IS  IGNORED  UNLESS  OPT.GE.3, AND
C      ERREST IS IGNORED UNLESS OPT.GE.4.)
C
C    - CALL STATS(X,Y,ERRBND,ERREST)
C    - EXIT IF X .GE.  XEND.
C - ENDLOOP
C
C
C ON NORMAL EXIT X,Y MUST HOLD XEND AND THE SOLUTION AT XEND.   ON  EXIT
C BECAUSE  SOLVER  WAS  IN TROUBLE, X MUST HOLD THE FINAL POINT REACHED.
C ON AN EXIT FORCED BY STATS, X MUST HOLD XEND.
C
C
C
C
C
C
C 4. CONTROLLING THE DESTINATION OF OUTPUT
C    ----------- --- ----------- -- ------
C
C THE UNIT NUMBER ON WHICH THE PACKAGE WRITES ITS OUTPUT  IS  SET  BY  A
C CALL  TO ONE OF THE PACKAGE ROUTINES, AND YOU CAN FIND OUT WHAT IT IS,
C BY PUTTING THE STATEMENT
C
C       IOUT = CONST(3)
C
C IN YOUR MAIN PROGRAM.  PROBABLY OUTPUT WILL DEFAULT TO YOUR  TERMINAL,
C WHICH  IS  GOOD  FOR DEBUGGING.  FOR MORE SERIOUS WORK YOU MAY WANT TO
C SEND OUTPUT TO A FILE.  THE STATEMENTS
C
C       IOUT = CONST(3)
C       OPEN(IOUT, FILE=FILENAME, OTHER OPTIONS..  )
C
C WILL DO THIS FOR YOU, ASSUMING YOUR  FORTRAN   I/O  IS CONSISTENT WITH
C THE  1977 STANDARD.
C
C
C
C 5. THE ROUTINE FCN
C    --- ------- ---
C
C THE SPECIFICATION OF FCN IS
C         SUBROUTINE FCN(X,Y,YP)
C         DOUBLE PRECISION X,Y(51),YP(51)
C
C ON ENTRY X HOLDS THE INDEPENDENT VARIABLE AND Y HOLDS  THE  VECTOR  OF
C DEPENDENT  VARIABLES.   ON EXIT YP HOLDS THE VECTOR OF DERIVATIVES FOR
C THE PROBLEM BEING SOLVED (SELECTED BY A SWITCH IN COMMON).
C
C
C 6. THE DUMMY NSDTST FOR DEBUGGING
C    --- ----- ------ --- ---------
C
C TO THE USER:
C
C THIS WILL PROBABLY BE IMPLEMENTED  AT  YOUR  SITE  AS  A  SOURCE  FILE
C CONTAINING  CUT-DOWN  VERSIONS  OF NSDTST AND STATS (AND OTHER PACKAGE
C ROUTINES OF NO CONCERN TO THE  USER).   THIS  FILE  MAKES  A  COMPLETE
C PROGRAM WHEN COMBINED WITH THE NSPROB FILE AND THE USER'S MAIN PROGRAM
C AND METHOD (AND OF COURSE SOLVER).  THE  CUT-DOWN  ROUTINES  HAVE  THE
C SAME CALLING SEQUENCE AS THE PROPER ONES.
C
C THE RESULTING PROGRAM USES METHOD TO SOLVE THE FIRST PROBLEM SPECIFIED
C IN IDLIST, AT THE FIRST TOLERANCE SPECIFIED IN TOL.  IT WILL PRINT OUT
C THE VALUES OF THE ARGUMENTS PASSED BY METHOD TO STATS AND ALSO THE  LU
C DECOMP  COUNTER  NLUD,  FOR  5 STEPS, AND THEN SET X = XEND.  THE USER
C SHOULD CHECK THAT THE VALUES OF X, Y, ERREST, ERRBND LOOK RIGHT;  THAT
C X = XEND  FORCES  TERMINATION  AS  IT  SHOULD;  AND THAT NLUD IS BEING
C COUNTED UP CORRECTLY.
C
C FEEL FREE TO MODIFY THESE ROUTINES TO WORK INTERACTIVELY.
C
C TO THE PERSON IMPLEMENTING THE PACKAGE:
C
C PLEASE MODIFY THESE ROUTINES TO MATCH THE USER ENVIRONMENT.
C
C
C
C 7. IMPLEMENTATION NOTES
C    -------------- -----
C
C  7.1.  MACHINE-DEPENDENT CONSTANTS
C
C     THESE  ARE   ISOLATED  IN  THE  ROUTINE   CONST   WHICH   HAS  THE
C     SPECIFICATION   REAL  FUNCTION CONST(I).  YOU MUST SET THE ARRAY C
C     AND THE STRING MCNAME IN THE DATA STATEMENT:
C
C     C(1)   APPROXIMATELY  THE  DOUBLE  PRECISION  UNIT  ROUNDOFF, USED
C            IN STATS AND TRUE.
C     C(2)   A NUMBER NEAR THE UNDERFLOW THRESHOLD, USED IN TRUE.
C     C(3)   THE  STANDARD  OUTPUT  UNIT NUMBER IOUT, USED IN NSDTST AND
C            TRUE.   WE SUGGEST OUTPUT BE TO THE TERMINAL BY DEFAULT.
C     C(4)   TSTTIM, USED IN CNTROL (SEE CLOCK ROUTINE).
C     MCNAME TITLING  INFORMATION  FOR PRINTOUT, GIVING THE  NAME OF THE
C            COMPUTER AND OPERATING SYSTEM.
C
C     IN ADDITION, A CALL OF CONST(0) (EXECUTED NEAR THE TOP OF  NSDTST)
C     IS  INTENDED  TO  INVOKE  CALLS  TO  SYSTEM  ROUTINES  TO SUPPRESS
C     UNDERFLOW  REPORTING  (WHICH  MAY  SPOIL  THE  APPEARANCE  OF  THE
C     OUTPUT), ETC.
C
C     IT MAY BE CONVENIENT  TO  ALLOW  IOUT  (C(3)  ABOVE)  TO BE SET BY
C     INTERACTION WITH THE USER AT THIS POINT.
C
C  7.2.  CLOCK ROUTINE
C
C     IF   IT  IS  DECIDED  TO  IMPLEMENT  THE  TIMING  FACILITIES,  THE
C     IMPLEMENTER  SHOULD  PROVIDE  A  TIMING ROUTINE  WHICH  CALLS  THE
C     SYSTEM CLOCK AND HAS THE SPECIFICATION
C          REAL FUNCTION CLOCK(S)
C          REAL(S)
C     IT SHOULD BE SUCH THAT IT IS 'RESET TO ZERO' BY THE STATEMENT
C          S = CLOCK(0.0)
C     AND (AS LONG AS S IS LEFT ALONE) CAN THEN BE 'READ'  AS  OFTEN  AS
C     DESIRED BY STATEMENTS LIKE
C          TIME = CLOCK(S)
C     WHICH SETS TIME TO THE NUMBER OF SECONDS OF PROCESSOR  TIME  SINCE
C     CLOCK WAS 'RESET'.
C
C     THE LARGER IS  THE  VALUE  OF  TSTTIM  (IE.   CONST(4))  THE  MORE
C     ACCURATE,  AND EXPENSIVE, IS THE TIMING PROCESS.  IT SHOULD BE SET
C     TO A VALUE REFLECTING THE SPEED OF THE HARDWARE AND THE RESOLUTION
C     OF  THE  SYSTEM CLOCK.  WE CANNOT GIVE MUCH GUIDANCE HERE, AND OUR
C     EXPERIENCE IS THAT TIMINGS INEVITABLY VARY SIGNIFICANTLY FROM  RUN
C     TO RUN ON A TIME-SHARED COMPUTING SYSTEM.
C
C     IF TIMING IS LEFT UNIMPLEMENTED, GIVE  TSTTIM  THE  VALUE ZERO AND
C     LEAVE THE TIMING DATA IN IVALU AS ALL ZERO  TO CAUSE ALL VALUES OF
C     TIMING STATISTICS TO BE PRINTED OUT AS ZERO.
C
C  7.3.  THE TIMING DATA IN IVALU
C
C     ROUTINE IVALU CONTAINS VALUES OF THE  QUANTITY  FCNTIM  FOR   EACH
C     PROBLEM:  THESE ARE THE COST OF ONE CALL TO  FCN  AS  MEASURED  BY
C     CLOCK, AND ARE USED IN COMPUTING THE "OVERHEAD"   STATISTICS. THEY
C     SHOULD BE  RECOMPUTED  FOR  ANOTHER  MACHINE.  THE UTILITY PROGRAM
C     NSGTIM  PROVIDED  WITH  THE PACKAGE, WHEN SUPPLIED  WITH  A  CLOCK
C     ROUTINE, CAN EITHER PRODUCE  A COMPLETE REVISED IVALU FILE, OR FOR
C     SELECTED PROBLEMS WILL PRODUCE BLOCKS OF OUTPUT OF THE FORM
C
C     C PROBLEM XX
C           FCNTIM = ...
C
C     SUITABLE FOR INCLUSION IN THE TEXT OF IVALU.
C
C
C  7.4.  ADDING EXTRA PROBLEMS
C
C     SAY YOU WISH TO ADD THREE EXTRA PROBLEMS TO CLASS B  OF  THE  SET.
C     THEY  WILL  THEN  BE  CALLED  B6,  B7  AND B8 (FOR THE SAKE OF THE
C     CHECKING ROUTINE PARCHK THEY  MUST  FOLLOW  CONSECUTIVELY  ON  THE
C     EXISTING  PROBLEM-IDS).   THEIR NUMERIC CODES WHICH YOU SPECIFY IN
C     THE IDLIST ARGUMENT OF NSDTST WILL THEN BE 26, 27, 27.   YOU  NEED
C     TO BE AWARE THAT THE INTERNAL CODE, PUT IN VARIABLE ID AND USED IN
C     FCN, IVALU AND EVALU TO SELECT THE CORRECT SECTION  OF  SUBROUTINE
C     TO EXECUTE, IS 10 LESS THAN THIS, IE.  16, 17 OR 17.
C
C     THE  STEPS  INVOLVED  ARE:
C     A)  CODE THE  DEFINITION  OF   THE   DIFFERENTIAL   EQUATIONS   AT
C         THE APPROPRIATE PLACE IN FCN.  CHANGE THE COMPUTED GOTO AT THE
C         HEAD  OF  FCN SO THAT THE VALUE ID = 16, 17 OR 18 GIVES A JUMP
C         TO  THE CORRECT PLACE.
C     B)  CODE THE  INITIAL  VALUES,  "TRUE"  FINAL   VALUES  AND  OTHER
C         DATA INTO  THE  APPROPRIATE  PLACES  IN IVALU  AND  EVALU IN A
C         SIMILAR  WAY.   THE  TRUE  FINAL  VALUES  SHOULD  PROBABLY  BE
C         COMPUTED   BY   AN  INTEGRATOR   USING   HIGHER   THAN  DOUBLE
C         PRECISION, BUT THE ONLY CONSEQUENCE OF SLIGHT  INACCURACIES IS
C         TO  AFFECT  THE  END  PT   GLB ERR  STATISTIC   AT   STRINGENT
C         TOLERANCES.  AT THIS STAGE IGNORE THE  WEIGHTS  W(I)  AND  THE
C         TIMING DATA FCNTIM.
C     C)  IN THE ARGUMENT-CHECKING  ROUTINE   PARCHK  CHANGE  THE   DATA
C         STATEMENT  WHICH DEFINES ARRAY NSYSTM,  TO INDICATE THAT CLASS
C         B NOW HAS 8 MEMBERS.  (IE.   CHANGE ITS SECOND ELEMENT FROM  5
C         TO 7.)
C     D)  RUN  THE UTILITY  PROGRAM  NSGWT.F ON THE TAPE TO COMPUTE  THE
C         VALUES  OF  THE  WEIGHTS  W(I).   SIMILARLY  RUN  NSGTIM.F  TO
C         DETERMINE FCNTIM FOR YOUR PROBLEMS.
C
C ADDING  AN  ENTIRE  NEW  PROBLEM CLASS IS  NO  MORE  DIFFICULT.   NOTE
C THAT  IT  INVOLVES  INCREASING  THE   VALUE   OF   NCLASS  IN THE DATA
C STATEMENT AND THE LENGTH OF NSYSTM IN THE  DIMENSIONING   STATEMENT IN
C PARCHK; ALSO CHECK THE STRING IDCLAS  IN  NSDTST HAS ENOUGH LETTERS IN
C IT.
C
C  7.5.  OTHER STATISTICS TO PRINT
C
C STATISTICS  WHICH ARE GATHERED BUT DO  NOT  APPEAR   IN   THE   OUTPUT
C TABLES  INCLUDE   NSTART,  NSTL  AND  TRUTIM.  THEY ARE DEFINED IN THE
C DESCRIPTION   OF   COMMON  /NSCOM3/  BELOW.   NSTART   ASSESSES    THE
C EFFICIENCY  OF  THE  STARTING  PHASE  OF  A CODE AND MAY BE OF GENERAL
C INTEREST.  TRUTIM IS OF USE  IF  YOU  ARE  TROUBLED  BY  THE OVERHEADS
C OF CALLS TO TRUE WITH OPT  >=  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<P<1 BECOMES '  .',
C  P OUTSIDE RANGE BECOMES '***'
CERR  CHARACTER*1 DIG(0:9)/'0','1','2','3','4','5','6','7','8','9'/
C     .. Scalar Arguments ..
      REAL                      P
C     .. Local Scalars ..
      INTEGER                   I, J
C     .. Local Arrays ..
      CHARACTER                 DIG(0:9)
C     .. Data statements ..
      DATA                      DIG/'0', '1', '2', '3', '4', '5', '6',
     *                          '7', '8', '9'/
C     .. Executable Statements ..
      DIG(0) = ' '
      IF (P.LT.0 .OR. P.GT.1) THEN
         STR3 = '***'
      ELSE IF (P.EQ.0.) THEN
         STR3 = '   '
      ELSE IF (P.LT..01) THEN
         STR3 = '  .'
      ELSE
         DO 20 J = 1, 3
            I = P
            P = P - I
            STR3(J:J) = DIG(I)
            IF (I.GT.0) DIG(0) = '0'
            P = 10.*P
   20    CONTINUE
      END IF
      RETURN
      END
      SUBROUTINE TRUE(N,FCN,X,Y,XEND,TOL,IND,C,NW,W)
C     .. Scalar Arguments ..
      DOUBLE PRECISION TOL, X, XEND
      INTEGER         IND, N, NW
C     .. Array Arguments ..
      DOUBLE PRECISION C(24), W(NW,9), Y(N)
C     .. Subroutine Arguments ..
      EXTERNAL        FCN
C     .. Local Scalars ..
      DOUBLE PRECISION TEMP
      INTEGER         IOUT, K
C     .. External Functions ..
      REAL            CONST
      EXTERNAL        CONST
C     .. Intrinsic Functions ..
      INTRINSIC       DABS, DMAX1, DMIN1, DSIGN
C     .. Executable Statements ..
C
C***********************************************************************
C THIS IS THE SAME AS THE DVERK CODE (DOCUMENTED BELOW) EXCEPT THAT
C THE SETTING OF THE MACHINE-DEPENDENT PARAMETERS C(10),C(11) HAS BEEN
C DONE BY CALLS TO THE 'CONST' FUNCTION OF THE DETEST PACKAGE.
C                             J D PRYCE AUG 1983
C
C***********************************************************************
C                                                                      *
C     PURPOSE - THIS IS A RUNGE-KUTTA  SUBROUTINE  BASED  ON  VERNER'S *
C FIFTH AND SIXTH ORDER PAIR OF FORMULAS FOR FINDING APPROXIMATIONS TO *
C THE SOLUTION OF  A  SYSTEM  OF  FIRST  ORDER  ORDINARY  DIFFERENTIAL *
C EQUATIONS  WITH  INITIAL  CONDITIONS. IT ATTEMPTS TO KEEP THE GLOBAL *
C ERROR PROPORTIONAL TO  A  TOLERANCE  SPECIFIED  BY  THE  USER.  (THE *
C PROPORTIONALITY  DEPENDS  ON THE KIND OF ERROR CONTROL THAT IS USED, *
C AS WELL AS THE DIFFERENTIAL EQUATION AND THE RANGE OF INTEGRATION.)  *
C                                                                      *
C     VARIOUS OPTIONS ARE AVAILABLE TO THE USER,  INCLUDING  DIFFERENT *
C KINDS  OF  ERROR CONTROL, RESTRICTIONS ON STEP SIZES, AND INTERRUPTS *
C WHICH PERMIT THE USER TO EXAMINE THE STATE OF THE  CALCULATION  (AND *
C PERHAPS MAKE MODIFICATIONS) DURING INTERMEDIATE STAGES.              *
C                                                                      *
C     THE PROGRAM IS EFFICIENT FOR NON-STIFF SYSTEMS.  HOWEVER, A GOOD *
C VARIABLE-ORDER-ADAMS  METHOD  WILL PROBABLY BE MORE EFFICIENT IF THE *
C FUNCTION EVALUATIONS ARE VERY COSTLY.  SUCH A METHOD WOULD  ALSO  BE *
C MORE SUITABLE IF ONE WANTED TO OBTAIN A LARGE NUMBER OF INTERMEDIATE *
C SOLUTION VALUES BY INTERPOLATION, AS MIGHT BE THE CASE  FOR  EXAMPLE *
C WITH GRAPHICAL OUTPUT.                                               *
C                                                                      *
C                                    HULL-ENRIGHT-JACKSON   1/10/76    *
C                                                                      *
C***********************************************************************
C                                                                      *
C     USE - THE USER MUST SPECIFY EACH OF THE FOLLOWING                *
C                                                                      *
C     N  NUMBER OF EQUATIONS                                           *
C                                                                      *
C   FCN  NAME OF SUBROUTINE FOR EVALUATING FUNCTIONS - THE  SUBROUTINE *
C           ITSELF MUST ALSO BE PROVIDED BY THE USER - IT SHOULD BE OF *
C           THE FOLLOWING FORM                                         *
C              SUBROUTINE FCN(N, X, Y, YPRIME)                         *
C              INTEGER N                                               *
C              DOUBLE PRECISION X, Y(N), YPRIME(N)                     *
C                      *** ETC ***                                     *
C           AND IT SHOULD EVALUATE YPRIME, GIVEN N, X AND Y            *
C                                                                      *
C     X  INDEPENDENT VARIABLE - INITIAL VALUE SUPPLIED BY USER         *
C                                                                      *
C     Y  DEPENDENT VARIABLE - INITIAL VALUES OF COMPONENTS Y(1), Y(2), *
CC          ..., Y(N) SUPPLIED BY USER                                 *
C                                                                      *
C  XEND  VALUE OF X TO WHICH INTEGRATION IS TO BE CARRIED OUT - IT MAY *
C           BE LESS THAN THE INITIAL VALUE OF X                        *
C                                                                      *
C   TOL  TOLERANCE - THE SUBROUTINE ATTEMPTS TO CONTROL A NORM OF  THE *
C           LOCAL  ERROR  IN  SUCH  A  WAY  THAT  THE  GLOBAL ERROR IS *
C           PROPORTIONAL TO TOL. IN SOME PROBLEMS THERE WILL BE ENOUGH *
C           DAMPING  OF  ERRORS, AS WELL AS SOME CANCELLATION, SO THAT *
C           THE GLOBAL ERROR WILL BE LESS THAN TOL. ALTERNATIVELY, THE *
C           CONTROL   CAN   BE  VIEWED  AS  ATTEMPTING  TO  PROVIDE  A *
C           CALCULATED VALUE OF Y AT XEND WHICH IS THE EXACT  SOLUTION *
C           TO  THE  PROBLEM Y' = F(X,Y) + E(X) WHERE THE NORM OF E(X) *
C           IS PROPORTIONAL TO TOL.  (THE NORM  IS  A  MAX  NORM  WITH *
C           WEIGHTS  THAT  DEPEND ON THE ERROR CONTROL STRATEGY CHOSEN *
C           BY THE USER.  THE DEFAULT WEIGHT FOR THE K-TH COMPONENT IS *
C           1/MAX(1,ABS(Y(K))),  WHICH THEREFORE PROVIDES A MIXTURE OF *
C           ABSOLUTE AND RELATIVE ERROR CONTROL.)                      *
C                                                                      *
C   IND  INDICATOR - ON INITIAL ENTRY IND MUST BE SET EQUAL TO  EITHER *
C           1  OR  2. IF THE USER DOES NOT WISH TO USE ANY OPTIONS, HE *
C           SHOULD SET IND TO 1 - ALL THAT REMAINS FOR THE USER TO  DO *
C           THEN  IS  TO  DECLARE C AND W, AND TO SPECIFY NW. THE USER *
C           MAY ALSO  SELECT  VARIOUS  OPTIONS  ON  INITIAL  ENTRY  BY *
C           SETTING IND = 2 AND INITIALIZING THE FIRST 9 COMPONENTS OF *
C           C AS DESCRIBED IN THE NEXT SECTION.  HE MAY ALSO  RE-ENTER *
C           THE  SUBROUTINE  WITH IND = 3 AS MENTIONED AGAIN BELOW. IN *
C           ANY EVENT, THE SUBROUTINE RETURNS WITH IND EQUAL TO        *
C              3 AFTER A NORMAL RETURN                                 *
C              4, 5, OR 6 AFTER AN INTERRUPT (SEE OPTIONS C(8), C(9))  *
C              -1, -2, OR -3 AFTER AN ERROR CONDITION (SEE BELOW)      *
C                                                                      *
C     C  COMMUNICATIONS VECTOR - THE DIMENSION MUST BE GREATER THAN OR *
C           EQUAL TO 24, UNLESS OPTION C(1) = 4 OR 5 IS USED, IN WHICH *
C           CASE THE DIMENSION MUST BE GREATER THAN OR EQUAL TO N+30   *
C                                                                      *
C    NW  FIRST DIMENSION OF WORKSPACE W -  MUST  BE  GREATER  THAN  OR *
C           EQUAL TO N                                                 *
C                                                                      *
C     W  WORKSPACE MATRIX - FIRST DIMENSION MUST BE NW AND SECOND MUST *
C           BE GREATER THAN OR EQUAL TO 9                              *
C                                                                      *
C     THE SUBROUTINE  WILL  NORMALLY  RETURN  WITH  IND  =  3,  HAVING *
C REPLACED THE INITIAL VALUES OF X AND Y WITH, RESPECTIVELY, THE VALUE *
C OF XEND AND AN APPROXIMATION TO Y AT XEND.  THE  SUBROUTINE  CAN  BE *
C CALLED  REPEATEDLY  WITH NEW VALUES OF XEND WITHOUT HAVING TO CHANGE *
C ANY OTHER ARGUMENT.  HOWEVER, CHANGES IN TOL, OR ANY OF THE  OPTIONS *
C DESCRIBED BELOW, MAY ALSO BE MADE ON SUCH A RE-ENTRY IF DESIRED.     *
C                                                                      *
C     THREE ERROR RETURNS ARE ALSO POSSIBLE, IN WHICH  CASE  X  AND  Y *
C WILL BE THE MOST RECENTLY ACCEPTED VALUES -                          *
C     WITH IND = -3 THE SUBROUTINE WAS UNABLE  TO  SATISFY  THE  ERROR *
C        REQUIREMENT  WITH A PARTICULAR STEP-SIZE THAT IS LESS THAN OR *
C        EQUAL TO HMIN, WHICH MAY MEAN THAT TOL IS TOO SMALL           *
C     WITH IND = -2 THE VALUE OF HMIN  IS  GREATER  THAN  HMAX,  WHICH *
C        PROBABLY  MEANS  THAT THE REQUESTED TOL (WHICH IS USED IN THE *
C        CALCULATION OF HMIN) IS TOO SMALL                             *
C     WITH IND = -1 THE ALLOWED MAXIMUM NUMBER OF FCN EVALUATIONS  HAS *
C        BEEN  EXCEEDED,  BUT  THIS  CAN ONLY OCCUR IF OPTION C(7), AS *
C        DESCRIBED IN THE NEXT SECTION, HAS BEEN USED                  *
C                                                                      *
C     THERE ARE SEVERAL CIRCUMSTANCES THAT WILL CAUSE THE CALCULATIONS *
C TO  BE  TERMINATED,  ALONG WITH OUTPUT OF INFORMATION THAT WILL HELP *
C THE USER DETERMINE THE CAUSE OF  THE  TROUBLE.  THESE  CIRCUMSTANCES *
C INVOLVE  ENTRY WITH ILLEGAL OR INCONSISTENT VALUES OF THE ARGUMENTS, *
C SUCH AS ATTEMPTING A NORMAL  RE-ENTRY  WITHOUT  FIRST  CHANGING  THE *
C VALUE OF XEND, OR ATTEMPTING TO RE-ENTER WITH IND LESS THAN ZERO.    *
C                                                                      *
C***********************************************************************
C                                                                      *
C     OPTIONS - IF THE SUBROUTINE IS ENTERED WITH IND = 1, THE FIRST 9 *
C COMPONENTS OF THE COMMUNICATIONS VECTOR ARE INITIALIZED TO ZERO, AND *
C THE SUBROUTINE USES ONLY DEFAULT VALUES  FOR  EACH  OPTION.  IF  THE *
C SUBROUTINE  IS  ENTERED  WITH IND = 2, THE USER MUST SPECIFY EACH OF *
C THESE 9 COMPONENTS - NORMALLY HE WOULD FIRST SET THEM ALL  TO  ZERO, *
C AND  THEN  MAKE  NON-ZERO  THOSE  THAT  CORRESPOND TO THE PARTICULAR *
C OPTIONS HE WISHES TO SELECT. IN ANY EVENT, OPTIONS MAY BE CHANGED ON *
C RE-ENTRY  TO  THE  SUBROUTINE  -  BUT IF THE USER CHANGES ANY OF THE *
C OPTIONS, OR TOL, IN THE COURSE OF A CALCULATION HE SHOULD BE CAREFUL *
C ABOUT  HOW  SUCH CHANGES AFFECT THE SUBROUTINE - IT MAY BE BETTER TO *
C RESTART WITH IND = 1 OR 2. (COMPONENTS 10 TO 24 OF C ARE USED BY THE *
C PROGRAM  -  THE INFORMATION IS AVAILABLE TO THE USER, BUT SHOULD NOT *
C NORMALLY BE CHANGED BY HIM.)                                         *
C                                                                      *
C  C(1)  ERROR CONTROL INDICATOR - THE NORM OF THE LOCAL ERROR IS  THE *
C           MAX  NORM  OF  THE  WEIGHTED  ERROR  ESTIMATE  VECTOR, THE *
C           WEIGHTS BEING DETERMINED ACCORDING TO THE VALUE OF C(1) -  *
C              IF C(1)=1 THE WEIGHTS ARE 1 (ABSOLUTE ERROR CONTROL)    *
C              IF C(1)=2 THE WEIGHTS ARE 1/ABS(Y(K))  (RELATIVE  ERROR *
C                 CONTROL)                                             *
C              IF C(1)=3 THE  WEIGHTS  ARE  1/MAX(ABS(C(2)),ABS(Y(K))) *
C                 (RELATIVE  ERROR  CONTROL,  UNLESS ABS(Y(K)) IS LESS *
C                 THAN THE FLOOR VALUE, ABS(C(2)) )                    *
C              IF C(1)=4 THE WEIGHTS ARE 1/MAX(ABS(C(K+30)),ABS(Y(K))) *
C                 (HERE INDIVIDUAL FLOOR VALUES ARE USED)              *
C              IF C(1)=5 THE WEIGHTS ARE 1/ABS(C(K+30))                *
C              FOR ALL OTHER VALUES OF C(1), INCLUDING  C(1) = 0,  THE *
C                 DEFAULT  VALUES  OF  THE  WEIGHTS  ARE  TAKEN  TO BE *
C                 1/MAX(1,ABS(Y(K))), AS MENTIONED EARLIER             *
C           (IN THE TWO CASES C(1) = 4 OR 5 THE USER MUST DECLARE  THE *
C           DIMENSION OF C TO BE AT LEAST N+30 AND MUST INITIALIZE THE *
C           COMPONENTS C(31), C(32), ..., C(N+30).)                    *
C                                                                      *
C  C(2)  FLOOR VALUE - USED WHEN THE INDICATOR C(1) HAS THE VALUE 3    *
C                                                                      *
C  C(3)  HMIN SPECIFICATION - IF NOT ZERO, THE SUBROUTINE CHOOSES HMIN *
C           TO BE ABS(C(3)) - OTHERWISE IT USES THE DEFAULT VALUE      *
C              10*MAX(DWARF,RREB*MAX(WEIGHTED NORM Y/TOL,ABS(X))),     *
C           WHERE DWARF IS A VERY SMALL POSITIVE  MACHINE  NUMBER  AND *
C           RREB IS THE RELATIVE ROUNDOFF ERROR BOUND                  *
C                                                                      *
C  C(4)  HSTART SPECIFICATION - IF NOT ZERO, THE SUBROUTINE  WILL  USE *
C           AN  INITIAL  HMAG EQUAL TO ABS(C(4)), EXCEPT OF COURSE FOR *
C           THE RESTRICTIONS IMPOSED BY HMIN AND HMAX  -  OTHERWISE IT *
C           USES THE DEFAULT VALUE OF HMAX*(TOL)**(1/6)                *
C                                                                      *
C  C(5)  SCALE SPECIFICATION - THIS IS INTENDED TO BE A MEASURE OF THE *
C           SCALE OF THE PROBLEM - LARGER VALUES OF SCALE TEND TO MAKE *
C           THE METHOD MORE RELIABLE, FIRST  BY  POSSIBLY  RESTRICTING *
C           HMAX  (AS  DESCRIBED  BELOW) AND SECOND, BY TIGHTENING THE *
C           ACCEPTANCE REQUIREMENT - IF C(5) IS ZERO, A DEFAULT  VALUE *
C           OF  1  IS  USED.  FOR  LINEAR  HOMOGENEOUS  PROBLEMS  WITH *
C           CONSTANT COEFFICIENTS, AN APPROPRIATE VALUE FOR SCALE IS A *
C           NORM  OF  THE  ASSOCIATED  MATRIX.  FOR OTHER PROBLEMS, AN *
C           APPROXIMATION TO  AN  AVERAGE  VALUE  OF  A  NORM  OF  THE *
C           JACOBIAN ALONG THE TRAJECTORY MAY BE APPROPRIATE           *
C                                                                      *
C  C(6)  HMAX SPECIFICATION - FOUR CASES ARE POSSIBLE                  *
C           IF C(6).NE.0 AND C(5).NE.0, HMAX IS TAKEN TO BE            *
C              MIN(ABS(C(6)),2/ABS(C(5)))                              *
C           IF C(6).NE.0 AND C(5).EQ.0, HMAX IS TAKEN TO BE  ABS(C(6)) *
C           IF C(6).EQ.0 AND C(5).NE.0, HMAX IS TAKEN TO BE            *
C              2/ABS(C(5))                                             *
C           IF C(6).EQ.0 AND C(5).EQ.0, HMAX IS GIVEN A DEFAULT  VALUE *
C              OF 2                                                    *
C                                                                      *
C  C(7)  MAXIMUM NUMBER OF FUNCTION EVALUATIONS  -  IF  NOT  ZERO,  AN *
C           ERROR  RETURN WITH IND = -1 WILL BE CAUSED WHEN THE NUMBER *
C           OF FUNCTION EVALUATIONS EXCEEDS ABS(C(7))                  *
C                                                                      *
C  C(8)  INTERRUPT NUMBER  1  -  IF  NOT  ZERO,  THE  SUBROUTINE  WILL *
C           INTERRUPT   THE  CALCULATIONS  AFTER  IT  HAS  CHOSEN  ITS *
C           PRELIMINARY VALUE OF HMAG, AND JUST BEFORE CHOOSING HTRIAL *
C           AND  XTRIAL  IN  PREPARATION FOR TAKING A STEP (HTRIAL MAY *
C           DIFFER FROM HMAG IN SIGN, AND MAY  REQUIRE  ADJUSTMENT  IF *
C           XEND  IS  NEAR) - THE SUBROUTINE RETURNS WITH IND = 4, AND *
C           WILL RESUME CALCULATION AT THE POINT  OF  INTERRUPTION  IF *
C           RE-ENTERED WITH IND = 4                                    *
C                                                                      *
C  C(9)  INTERRUPT NUMBER  2  -  IF  NOT  ZERO,  THE  SUBROUTINE  WILL *
C           INTERRUPT   THE  CALCULATIONS  IMMEDIATELY  AFTER  IT  HAS *
C           DECIDED WHETHER OR NOT TO ACCEPT THE RESULT  OF  THE  MOST *
C           RECENT  TRIAL STEP, WITH IND = 5 IF IT PLANS TO ACCEPT, OR *
C           IND = 6 IF IT PLANS TO REJECT -  Y(*)  IS  THE  PREVIOUSLY *
C           ACCEPTED  RESULT, WHILE W(*,9) IS THE NEWLY COMPUTED TRIAL *
C           VALUE, AND W(*,2) IS THE UNWEIGHTED ERROR ESTIMATE VECTOR. *
C           THE  SUBROUTINE  WILL  RESUME CALCULATIONS AT THE POINT OF *
C           INTERRUPTION ON RE-ENTRY WITH IND = 5 OR 6. (THE USER  MAY *
C           CHANGE IND IN THIS CASE IF HE WISHES, FOR EXAMPLE TO FORCE *
C           ACCEPTANCE OF A STEP THAT WOULD OTHERWISE BE REJECTED,  OR *
C           VICE VERSA. HE CAN ALSO RESTART WITH IND = 1 OR 2.)        *
C                                                                      *
C***********************************************************************
C                                                                      *
C  SUMMARY OF THE COMPONENTS OF THE COMMUNICATIONS VECTOR              *
C                                                                      *
C     PRESCRIBED AT THE OPTION       DETERMINED BY THE PROGRAM         *
C           OF THE USER                                                *
C                                                                      *
C                                    C(10) RREB(REL ROUNDOFF ERR BND)  *
C     C(1) ERROR CONTROL INDICATOR   C(11) DWARF (VERY SMALL MACH NO)  *
C     C(2) FLOOR VALUE               C(12) WEIGHTED NORM Y             *
C     C(3) HMIN SPECIFICATION        C(13) HMIN                        *
C     C(4) HSTART SPECIFICATION      C(14) HMAG                        *
C     C(5) SCALE SPECIFICATION       C(15) SCALE                       *
C     C(6) HMAX SPECIFICATION        C(16) HMAX                        *
C     C(7) MAX NO OF FCN EVALS       C(17) XTRIAL                      *
C     C(8) INTERRUPT NO 1            C(18) HTRIAL                      *
C     C(9) INTERRUPT NO 2            C(19) EST                         *
C                                    C(20) PREVIOUS XEND               *
C                                    C(21) FLAG FOR XEND               *
C                                    C(22) NO OF SUCCESSFUL STEPS      *
C                                    C(23) NO OF SUCCESSIVE FAILURES   *
C                                    C(24) NO OF FCN EVALS             *
C                                                                      *
C  IF C(1) = 4 OR 5, C(31), C(32), ... C(N+30) ARE FLOOR VALUES        *
C                                                                      *
C***********************************************************************
C                                                                      *
C  AN OVERVIEW OF THE PROGRAM                                          *
C                                                                      *
C     BEGIN INITIALIZATION, PARAMETER CHECKING, INTERRUPT RE-ENTRIES   *
CC ......ABORT IF IND OUT OF RANGE 1 TO 6                              *
C  .     CASES - INITIAL ENTRY, NORMAL RE-ENTRY, INTERRUPT RE-ENTRIES  *
C  .     CASE 1 - INITIAL ENTRY (IND .EQ. 1 OR 2)                      *
C  V........ABORT IF N.GT.NW OR TOL.LE.0                               *
C  .        IF INITIAL ENTRY WITHOUT OPTIONS (IND .EQ. 1)              *
C  .           SET C(1) TO C(9) EQUAL TO ZERO                          *
C  .        ELSE INITIAL ENTRY WITH OPTIONS (IND .EQ. 2)               *
C  .           MAKE C(1) TO C(9) NON-NEGATIVE                          *
C  .           MAKE FLOOR VALUES NON-NEGATIVE IF THEY ARE TO BE USED   *
C  .        END IF                                                     *
C  .        INITIALIZE RREB, DWARF, PREV XEND, FLAG, COUNTS            *
C  .     CASE 2 - NORMAL RE-ENTRY (IND .EQ. 3)                         *
CC .........ABORT IF XEND REACHED, AND EITHER X CHANGED OR XEND NOT    *
C  .        RE-INITIALIZE FLAG                                         *
C  .     CASE 3 - RE-ENTRY FOLLOWING AN INTERRUPT (IND .EQ. 4 TO 6)    *
C  V        TRANSFER CONTROL TO THE APPROPRIATE RE-ENTRY POINT.......  *
C  .     END CASES                                                  .  *
C  .  END INITIALIZATION, ETC.                                      .  *
C  .                                                                V  *
C  .  LOOP THROUGH THE FOLLOWING 4 STAGES, ONCE FOR EACH TRIAL STEP .  *
C  .     STAGE 1 - PREPARE                                          .  *
C***********ERROR RETURN (WITH IND=-1) IF NO OF FCN EVALS TOO GREAT .  *
C  .        CALC SLOPE (ADDING 1 TO NO OF FCN EVALS) IF IND .NE. 6  .  *
C  .        CALC HMIN, SCALE, HMAX                                  .  *
C***********ERROR RETURN (WITH IND=-2) IF HMIN .GT. HMAX            .  *
C  .        CALC PRELIMINARY HMAG                                   .  *
C***********INTERRUPT NO 1 (WITH IND=4) IF REQUESTED.......RE-ENTRY.V  *
C  .        CALC HMAG, XTRIAL AND HTRIAL                            .  *
C  .     END STAGE 1                                                .  *
C  V     STAGE 2 - CALC YTRIAL (ADDING 7 TO NO OF FCN EVALS)        .  *
C  .     STAGE 3 - CALC THE ERROR ESTIMATE                          .  *
C  .     STAGE 4 - MAKE DECISIONS                                   .  *
C  .        SET IND=5 IF STEP ACCEPTABLE, ELSE SET IND=6            .  *
C***********INTERRUPT NO 2 IF REQUESTED....................RE-ENTRY.V  *
C  .        IF STEP ACCEPTED (IND .EQ. 5)                              *
C  .           UPDATE X, Y FROM XTRIAL, YTRIAL                         *
C  .           ADD 1 TO NO OF SUCCESSFUL STEPS                         *
C  .           SET NO OF SUCCESSIVE FAILURES TO ZERO                   *
C**************RETURN(WITH IND=3, XEND SAVED, FLAG SET) IF X .EQ. XEND *
C  .        ELSE STEP NOT ACCEPTED (IND .EQ. 6)                        *
C  .           ADD 1 TO NO OF SUCCESSIVE FAILURES                      *
C**************ERROR RETURN (WITH IND=-3) IF HMAG .LE. HMIN            *
C  .        END IF                                                     *
C  .     END STAGE 4                                                   *
C  .  END LOOP                                                         *
C  .                                                                   *
C  BEGIN ABORT ACTION                                                  *
C     OUTPUT APPROPRIATE  MESSAGE  ABOUT  STOPPING  THE  CALCULATIONS, *
C        ALONG WITH VALUES OF IND, N, NW, TOL, HMIN,  HMAX,  X,  XEND, *
C        PREVIOUS XEND,  NO OF  SUCCESSFUL  STEPS,  NO  OF  SUCCESSIVE *
C        FAILURES, NO OF FCN EVALS, AND THE COMPONENTS OF Y            *
C     STOP                                                             *
C  END ABORT ACTION                                                    *
C                                                                      *
C***********************************************************************
C
C     ******************************************************************
C     * BEGIN INITIALIZATION, PARAMETER CHECKING, INTERRUPT RE-ENTRIES *
C     ******************************************************************
C
CC ......ABORT IF IND OUT OF RANGE 1 TO 6
      IF (IND.LT.1 .OR. IND.GT.6) GO TO 1200
C
C        CASES - INITIAL ENTRY, NORMAL RE-ENTRY, INTERRUPT RE-ENTRIES
      GO TO (20,20,180,600,1080,1080) IND
C        CASE 1 - INITIAL ENTRY (IND .EQ. 1 OR 2)
CC .........ABORT IF N.GT.NW OR TOL.LE.0
   20 IF (N.GT.NW .OR. TOL.LE.0.D0) GO TO 1200
      IF (IND.EQ.2) GO TO 60
C              INITIAL ENTRY WITHOUT OPTIONS (IND .EQ. 1)
C              SET C(1) TO C(9) EQUAL TO 0
      DO 40 K = 1, 9
         C(K) = 0.D0
   40 CONTINUE
      GO TO 140
   60 CONTINUE
C              INITIAL ENTRY WITH OPTIONS (IND .EQ. 2)
C              MAKE C(1) TO C(9) NON-NEGATIVE
      DO 80 K = 1, 9
         C(K) = DABS(C(K))
   80 CONTINUE
C              MAKE FLOOR VALUES NON-NEGATIVE IF THEY ARE TO BE USED
      IF (C(1).NE.4.D0 .AND. C(1).NE.5.D0) GO TO 120
      DO 100 K = 1, N
         C(K+30) = DABS(C(K+30))
  100 CONTINUE
  120 CONTINUE
  140 CONTINUE
C           INITIALIZE RREB, DWARF, PREV XEND, FLAG, COUNTS
      C(10) = CONST(1)
      C(11) = CONST(2)
C           SET PREVIOUS XEND INITIALLY TO INITIAL VALUE OF X
      C(20) = X
      DO 160 K = 21, 24
         C(K) = 0.D0
  160 CONTINUE
      GO TO 200
C        CASE 2 - NORMAL RE-ENTRY (IND .EQ. 3)
CC .........ABORT IF XEND REACHED, AND EITHER X CHANGED OR XEND NOT
  180 IF (C(21).NE.0.D0 .AND. (X.NE.C(20) .OR. XEND.EQ.C(20)))
     *    GO TO 1200
C           RE-INITIALIZE FLAG
      C(21) = 0.D0
      GO TO 200
C        CASE 3 - RE-ENTRY FOLLOWING AN INTERRUPT (IND .EQ. 4 TO 6)
C           TRANSFER CONTROL TO THE APPROPRIATE RE-ENTRY POINT..........
C           THIS HAS ALREADY BEEN HANDLED BY THE COMPUTED GO TO        .
C        END CASES                                                     V
  200 CONTINUE
C
C     END INITIALIZATION, ETC.
C
C     ******************************************************************
C     * LOOP THROUGH THE FOLLOWING 4 STAGES, ONCE FOR EACH TRIAL  STEP *
C     * UNTIL THE OCCURRENCE OF ONE OF THE FOLLOWING                   *
C     *    (A) THE NORMAL RETURN (WITH IND .EQ. 3) ON REACHING XEND IN *
C     *        STAGE 4                                                 *
C     *    (B) AN ERROR RETURN (WITH IND .LT. 0) IN STAGE 1 OR STAGE 4 *
C     *    (C) AN INTERRUPT RETURN (WITH IND  .EQ.  4,  5  OR  6),  IF *
C     *        REQUESTED, IN STAGE 1 OR STAGE 4                        *
C     ******************************************************************
C
  220 CONTINUE
C
C        ***************************************************************
C        * STAGE 1 - PREPARE - DO CALCULATIONS OF  HMIN,  HMAX,  ETC., *
C        * AND SOME PARAMETER  CHECKING,  AND  END  UP  WITH  SUITABLE *
C        * VALUES OF HMAG, XTRIAL AND HTRIAL IN PREPARATION FOR TAKING *
C        * AN INTEGRATION STEP.                                        *
C        ***************************************************************
C
C***********ERROR RETURN (WITH IND=-1) IF NO OF FCN EVALS TOO GREAT
      IF (C(7).EQ.0.D0 .OR. C(24).LT.C(7)) GO TO 240
      IND = -1
      RETURN
  240 CONTINUE
C
C           CALCULATE SLOPE (ADDING 1 TO NO OF FCN EVALS) IF IND .NE. 6
      IF (IND.EQ.6) GO TO 260
      CALL FCN(N,X,Y,W(1,1))
      C(24) = C(24) + 1.D0
  260 CONTINUE
C
C           CALCULATE HMIN - USE DEFAULT UNLESS VALUE PRESCRIBED
      C(13) = C(3)
      IF (C(3).NE.0.D0) GO TO 500
C              CALCULATE DEFAULT VALUE OF HMIN
C              FIRST CALCULATE WEIGHTED NORM Y - C(12) - AS SPECIFIED
C              BY THE ERROR CONTROL INDICATOR C(1)
      TEMP = 0.D0
      IF (C(1).NE.1.D0) GO TO 300
C                 ABSOLUTE ERROR CONTROL - WEIGHTS ARE 1
      DO 280 K = 1, N
         TEMP = DMAX1(TEMP,DABS(Y(K)))
  280 CONTINUE
      C(12) = TEMP
      GO TO 480
  300 IF (C(1).NE.2.D0) GO TO 320
C                 RELATIVE ERROR CONTROL - WEIGHTS ARE 1/DABS(Y(K)) SO
C                 WEIGHTED NORM Y IS 1
      C(12) = 1.D0
      GO TO 480
  320 IF (C(1).NE.3.D0) GO TO 360
C                 WEIGHTS ARE 1/MAX(C(2),ABS(Y(K)))
      DO 340 K = 1, N
         TEMP = DMAX1(TEMP,DABS(Y(K))/C(2))
  340 CONTINUE
      C(12) = DMIN1(TEMP,1.D0)
      GO TO 480
  360 IF (C(1).NE.4.D0) GO TO 400
C                 WEIGHTS ARE 1/MAX(C(K+30),ABS(Y(K)))
      DO 380 K = 1, N
         TEMP = DMAX1(TEMP,DABS(Y(K))/C(K+30))
  380 CONTINUE
      C(12) = DMIN1(TEMP,1.D0)
      GO TO 480
  400 IF (C(1).NE.5.D0) GO TO 440
C                 WEIGHTS ARE 1/C(K+30)
      DO 420 K = 1, N
         TEMP = DMAX1(TEMP,DABS(Y(K))/C(K+30))
  420 CONTINUE
      C(12) = TEMP
      GO TO 480
  440 CONTINUE
C                 DEFAULT CASE - WEIGHTS ARE 1/MAX(1,ABS(Y(K)))
      DO 460 K = 1, N
         TEMP = DMAX1(TEMP,DABS(Y(K)))
  460 CONTINUE
      C(12) = DMIN1(TEMP,1.D0)
  480 CONTINUE
      C(13) = 10.D0*DMAX1(C(11),C(10)*DMAX1(C(12)/TOL,DABS(X)))
  500 CONTINUE
C
C           CALCULATE SCALE - USE DEFAULT UNLESS VALUE PRESCRIBED
      C(15) = C(5)
      IF (C(5).EQ.0.D0) C(15) = 1.D0
C
C           CALCULATE HMAX - CONSIDER 4 CASES
C           CASE 1 BOTH HMAX AND SCALE PRESCRIBED
      IF (C(6).NE.0.D0 .AND. C(5).NE.0.D0) C(16) = DMIN1(C(6),2.D0/C(5))
C           CASE 2 - HMAX PRESCRIBED, BUT SCALE NOT
      IF (C(6).NE.0.D0 .AND. C(5).EQ.0.D0) C(16) = C(6)
C           CASE 3 - HMAX NOT PRESCRIBED, BUT SCALE IS
      IF (C(6).EQ.0.D0 .AND. C(5).NE.0.D0) C(16) = 2.D0/C(5)
C           CASE 4 - NEITHER HMAX NOR SCALE IS PROVIDED
      IF (C(6).EQ.0.D0 .AND. C(5).EQ.0.D0) C(16) = 2.D0
C
C***********ERROR RETURN (WITH IND=-2) IF HMIN .GT. HMAX
      IF (C(13).LE.C(16)) GO TO 520
      IND = -2
      RETURN
  520 CONTINUE
C
C           CALCULATE PRELIMINARY HMAG - CONSIDER 3 CASES
      IF (IND.GT.2) GO TO 540
C           CASE 1 - INITIAL ENTRY - USE PRESCRIBED VALUE OF HSTART, IF
C              ANY, ELSE DEFAULT
      C(14) = C(4)
      IF (C(4).EQ.0.D0) C(14) = C(16)*TOL**(1./6.)
      GO TO 580
  540 IF (C(23).GT.1.D0) GO TO 560
C           CASE 2 - AFTER A SUCCESSFUL STEP, OR AT MOST  ONE  FAILURE,
C              USE MIN(2, .9*(TOL/EST)**(1/6))*HMAG, BUT AVOID POSSIBLE
C              OVERFLOW. THEN AVOID REDUCTION BY MORE THAN HALF.
      TEMP = 2.D0*C(14)
      IF (TOL.LT.(2.D0/.9D0)**6*C(19)) TEMP = .9D0*(TOL/C(19))**(1./6.)
     *    *C(14)
      C(14) = DMAX1(TEMP,.5D0*C(14))
      GO TO 580
  560 CONTINUE
C           CASE 3 - AFTER TWO OR MORE SUCCESSIVE FAILURES
      C(14) = .5D0*C(14)
  580 CONTINUE
C
C           CHECK AGAINST HMAX
      C(14) = DMIN1(C(14),C(16))
C
C           CHECK AGAINST HMIN
      C(14) = DMAX1(C(14),C(13))
C
C***********INTERRUPT NO 1 (WITH IND=4) IF REQUESTED
      IF (C(8).EQ.0.D0) GO TO 600
      IND = 4
      RETURN
C           RESUME HERE ON RE-ENTRY WITH IND .EQ. 4   ........RE-ENTRY..
  600 CONTINUE
C
C           CALCULATE HMAG, XTRIAL - DEPENDING ON PRELIMINARY HMAG, XEND
      IF (C(14).GE.DABS(XEND-X)) GO TO 620
C              DO NOT STEP MORE THAN HALF WAY TO XEND
      C(14) = DMIN1(C(14),.5D0*DABS(XEND-X))
      C(17) = X + DSIGN(C(14),XEND-X)
      GO TO 640
  620 CONTINUE
C              HIT XEND EXACTLY
      C(14) = DABS(XEND-X)
      C(17) = XEND
  640 CONTINUE
C
C           CALCULATE HTRIAL
      C(18) = C(17) - X
C
C        END STAGE 1
C
C        ***************************************************************
C        * STAGE 2 - CALCULATE YTRIAL (ADDING 7 TO NO OF  FCN  EVALS). *
C        * W(*,2), ... W(*,8)  HOLD  INTERMEDIATE  RESULTS  NEEDED  IN *
C        * STAGE 3. W(*,9) IS TEMPORARY STORAGE UNTIL FINALLY IT HOLDS *
C        * YTRIAL.                                                     *
C        ***************************************************************
C
      TEMP = C(18)/1398169080000.D0
C
      DO 660 K = 1, N
         W(K,9) = Y(K) + TEMP*W(K,1)*233028180000.D0
  660 CONTINUE
      CALL FCN(N,X+C(18)/6.D0,W(1,9),W(1,2))
C
      DO 680 K = 1, N
         W(K,9) = Y(K) + TEMP*(W(K,1)*74569017600.D0+W(K,2)
     *            *298276070400.D0)
  680 CONTINUE
      CALL FCN(N,X+C(18)*(4.D0/15.D0),W(1,9),W(1,3))
C
      DO 700 K = 1, N
         W(K,9) = Y(K) + TEMP*(W(K,1)*1165140900000.D0-W(K,2)
     *            *3728450880000.D0+W(K,3)*3495422700000.D0)
  700 CONTINUE
      CALL FCN(N,X+C(18)*(2.D0/3.D0),W(1,9),W(1,4))
C
      DO 720 K = 1, N
         W(K,9) = Y(K) + TEMP*(-W(K,1)*3604654659375.D0+W(K,2)
     *            *12816549900000.D0-W(K,3)*9284716546875.D0+W(K,4)
     *            *1237962206250.D0)
  720 CONTINUE
      CALL FCN(N,X+C(18)*(5.D0/6.D0),W(1,9),W(1,5))
C
      DO 740 K = 1, N
         W(K,9) = Y(K) + TEMP*(W(K,1)*3355605792000.D0-W(K,2)
     *            *11185352640000.D0+W(K,3)*9172628850000.D0-W(K,4)
     *            *427218330000.D0+W(K,5)*482505408000.D0)
  740 CONTINUE
      CALL FCN(N,X+C(18),W(1,9),W(1,6))
C
      DO 760 K = 1, N
         W(K,9) = Y(K) + TEMP*(-W(K,1)*770204740536.D0+W(K,2)
     *            *2311639545600.D0-W(K,3)*1322092233000.D0-W(K,4)
     *            *453006781920.D0+W(K,5)*326875481856.D0)
  760 CONTINUE
      CALL FCN(N,X+C(18)/15.D0,W(1,9),W(1,7))
C
      DO 780 K = 1, N
         W(K,9) = Y(K) + TEMP*(W(K,1)*2845924389000.D0-W(K,2)
     *            *9754668000000.D0+W(K,3)*7897110375000.D0-W(K,4)
     *            *192082660000.D0+W(K,5)*400298976000.D0+W(K,7)
     *            *201586000000.D0)
  780 CONTINUE
      CALL FCN(N,X+C(18),W(1,9),W(1,8))
C
C           CALCULATE YTRIAL, THE EXTRAPOLATED APPROXIMATION AND STORE
C              IN W(*,9)
      DO 800 K = 1, N
         W(K,9) = Y(K) + TEMP*(W(K,1)*104862681000.D0+W(K,3)
     *            *545186250000.D0+W(K,4)*446637345000.D0+W(K,5)
     *            *188806464000.D0+W(K,7)*15076875000.D0+W(K,8)
     *            *97599465000.D0)
  800 CONTINUE
C
C           ADD 7 TO THE NO OF FCN EVALS
      C(24) = C(24) + 7.D0
C
C        END STAGE 2
C
C        ***************************************************************
C        * STAGE 3 - CALCULATE THE ERROR ESTIMATE EST. FIRST CALCULATE *
C        * THE  UNWEIGHTED  ABSOLUTE  ERROR  ESTIMATE VECTOR (PER UNIT *
C        * STEP) FOR THE UNEXTRAPOLATED APPROXIMATION AND STORE IT  IN *
C        * W(*,2).  THEN  CALCULATE THE WEIGHTED MAX NORM OF W(*,2) AS *
C        * SPECIFIED BY THE ERROR  CONTROL  INDICATOR  C(1).  FINALLY, *
C        * MODIFY  THIS RESULT TO PRODUCE EST, THE ERROR ESTIMATE (PER *
C        * UNIT STEP) FOR THE EXTRAPOLATED APPROXIMATION YTRIAL.       *
C        ***************************************************************
C
C           CALCULATE THE UNWEIGHTED ABSOLUTE ERROR ESTIMATE VECTOR
      DO 820 K = 1, N
         W(K,2) = (W(K,1)*8738556750.D0+W(K,3)*9735468750.D0-W(K,4)
     *            *9709507500.D0+W(K,5)*8582112000.D0+W(K,6)
     *            *95329710000.D0-W(K,7)*15076875000.D0-W(K,8)
     *            *97599465000.D0)/1398169080000.D0
  820 CONTINUE
C
C           CALCULATE THE WEIGHTED MAX NORM OF W(*,2) AS SPECIFIED BY
C           THE ERROR CONTROL INDICATOR C(1)
      TEMP = 0.D0
      IF (C(1).NE.1.D0) GO TO 860
C              ABSOLUTE ERROR CONTROL
      DO 840 K = 1, N
         TEMP = DMAX1(TEMP,DABS(W(K,2)))
  840 CONTINUE
      GO TO 1060
  860 IF (C(1).NE.2.D0) GO TO 900
C              RELATIVE ERROR CONTROL
      DO 880 K = 1, N
         TEMP = DMAX1(TEMP,DABS(W(K,2)/Y(K)))
  880 CONTINUE
      GO TO 1060
  900 IF (C(1).NE.3.D0) GO TO 940
C              WEIGHTS ARE 1/MAX(C(2),ABS(Y(K)))
      DO 920 K = 1, N
         TEMP = DMAX1(TEMP,DABS(W(K,2))/DMAX1(C(2),DABS(Y(K))))
  920 CONTINUE
      GO TO 1060
  940 IF (C(1).NE.4.D0) GO TO 980
C              WEIGHTS ARE 1/MAX(C(K+30),ABS(Y(K)))
      DO 960 K = 1, N
         TEMP = DMAX1(TEMP,DABS(W(K,2))/DMAX1(C(K+30),DABS(Y(K))))
  960 CONTINUE
      GO TO 1060
  980 IF (C(1).NE.5.D0) GO TO 1020
C              WEIGHTS ARE 1/C(K+30)
      DO 1000 K = 1, N
         TEMP = DMAX1(TEMP,DABS(W(K,2)/C(K+30)))
 1000 CONTINUE
      GO TO 1060
 1020 CONTINUE
C              DEFAULT CASE - WEIGHTS ARE 1/MAX(1,ABS(Y(K)))
      DO 1040 K = 1, N
         TEMP = DMAX1(TEMP,DABS(W(K,2))/DMAX1(1.D0,DABS(Y(K))))
 1040 CONTINUE
 1060 CONTINUE
C
C           CALCULATE EST - (THE WEIGHTED MAX NORM OF W(*,2))*HMAG*SCALE
C              - EST IS INTENDED TO BE A MEASURE OF THE ERROR  PER  UNIT
C              STEP IN YTRIAL
      C(19) = TEMP*C(14)*C(15)
C
C        END STAGE 3
C
C        ***************************************************************
C        * STAGE 4 - MAKE DECISIONS.                                   *
C        ***************************************************************
C
C           SET IND=5 IF STEP ACCEPTABLE, ELSE SET IND=6
      IND = 5
      IF (C(19).GT.TOL) IND = 6
C
C***********INTERRUPT NO 2 IF REQUESTED
      IF (C(9).EQ.0.D0) GO TO 1080
      RETURN
C           RESUME HERE ON RE-ENTRY WITH IND .EQ. 5 OR 6   ...RE-ENTRY..
 1080 CONTINUE
C
      IF (IND.EQ.6) GO TO 1140
C              STEP ACCEPTED (IND .EQ. 5), SO UPDATE X, Y FROM XTRIAL,
C                 YTRIAL, ADD 1 TO THE NO OF SUCCESSFUL STEPS, AND SET
C                 THE NO OF SUCCESSIVE FAILURES TO ZERO
      X = C(17)
      DO 1100 K = 1, N
         Y(K) = W(K,9)
 1100 CONTINUE
      C(22) = C(22) + 1.D0
      C(23) = 0.D0
C**************RETURN(WITH IND=3, XEND SAVED, FLAG SET) IF X .EQ. XEND
      IF (X.NE.XEND) GO TO 1120
      IND = 3
      C(20) = XEND
      C(21) = 1.D0
      RETURN
 1120 CONTINUE
      GO TO 1180
 1140 CONTINUE
C              STEP NOT ACCEPTED (IND .EQ. 6), SO ADD 1 TO THE NO OF
C                 SUCCESSIVE FAILURES
      C(23) = C(23) + 1.D0
C**************ERROR RETURN (WITH IND=-3) IF HMAG .LE. HMIN
      IF (C(14).GT.C(13)) GO TO 1160
      IND = -3
      RETURN
 1160 CONTINUE
 1180 CONTINUE
C
C        END STAGE 4
C
      GO TO 220
C     END LOOP
C
C  BEGIN ABORT ACTION
 1200 CONTINUE
C
      IOUT = CONST(3)
      WRITE (IOUT,FMT=99999) IND, TOL, X, N, C(13), XEND, NW, C(16),
     *  C(20), C(22), C(23), C(24), (Y(K),K=1,N)
C
      STOP
C
C  END ABORT ACTION
C
99999 FORMAT (///
     *      '0COMPUTATION STOPPED IN TRUE WITH THE FOLLOWIN G 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,/' NW  =',I4,5X,'HMAX =',1P,D13.6,5X,
     *       'PREV XEND =',1P,D22.15,/'0',14X,
     *       'NO OF SUCCESSFUL STEPS    =',0P,F8.0,/15X,
     *       'NO OF SUCCESSIVE FAILURES =',0P,F8.0,/15X,
     *       'NO OF FUNCTION EVALS      =',0P,F8.0,
     *       /'0THE COMPONENTS OF Y ARE',//(' ',1P,5D24.15))
      END
C
C*******************************************************************
C
      SUBROUTINE FCN2(N,X,Y,YP)
C     .. Scalar Arguments ..
      DOUBLE PRECISION X
      INTEGER         N
C     .. Array Arguments ..
      DOUBLE PRECISION Y(N), YP(N)
C     .. External Subroutines ..
      EXTERNAL        FCN
C     .. Executable Statements ..
      CALL FCN(X,Y,YP)
      RETURN
      END
      SUBROUTINE TRUE(N,FCN,X,Y,XEND,TOL,IND,C,NW,W)
C     .. Scalar Arguments ..
      REAL            TOL, X, XEND
      INTEGER         IND, N, NW
C     .. Array Arguments ..
      REAL            C(24), W(NW,9), Y(N)
C     .. Subroutine Arguments ..
      EXTERNAL        FCN
C     .. Local Scalars ..
      REAL            TEMP
      INTEGER         IOUT, K
C     .. External Functions ..
      REAL            CONST
      EXTERNAL        CONST
C     .. Intrinsic Functions ..
      INTRINSIC       ABS, AMAX1, AMIN1, SIGN
C     .. Executable Statements ..
C
C***********************************************************************
C THIS IS THE SAME AS THE DVERK CODE (DOCUMENTED BELOW) EXCEPT THAT
C THE SETTING OF THE MACHINE-DEPENDENT PARAMETERS C(10),C(11) HAS BEEN
C DONE BY CALLS TO THE 'CONST' FUNCTION OF THE DETEST PACKAGE.
C                             J D PRYCE AUG 1983
C
C***********************************************************************
C                                                                      *
C     PURPOSE - THIS IS A RUNGE-KUTTA  SUBROUTINE  BASED  ON  VERNER'S *
C FIFTH AND SIXTH ORDER PAIR OF FORMULAS FOR FINDING APPROXIMATIONS TO *
C THE SOLUTION OF  A  SYSTEM  OF  FIRST  ORDER  ORDINARY  DIFFERENTIAL *
C EQUATIONS  WITH  INITIAL  CONDITIONS. IT ATTEMPTS TO KEEP THE GLOBAL *
C ERROR PROPORTIONAL TO  A  TOLERANCE  SPECIFIED  BY  THE  USER.  (THE *
C PROPORTIONALITY  DEPENDS  ON THE KIND OF ERROR CONTROL THAT IS USED, *
C AS WELL AS THE DIFFERENTIAL EQUATION AND THE RANGE OF INTEGRATION.)  *
C                                                                      *
C     VARIOUS OPTIONS ARE AVAILABLE TO THE USER,  INCLUDING  DIFFERENT *
C KINDS  OF  ERROR CONTROL, RESTRICTIONS ON STEP SIZES, AND INTERRUPTS *
C WHICH PERMIT THE USER TO EXAMINE THE STATE OF THE  CALCULATION  (AND *
C PERHAPS MAKE MODIFICATIONS) DURING INTERMEDIATE STAGES.              *
C                                                                      *
C     THE PROGRAM IS EFFICIENT FOR NON-STIFF SYSTEMS.  HOWEVER, A GOOD *
C VARIABLE-ORDER-ADAMS  METHOD  WILL PROBABLY BE MORE EFFICIENT IF THE *
C FUNCTION EVALUATIONS ARE VERY COSTLY.  SUCH A METHOD WOULD  ALSO  BE *
C MORE SUITABLE IF ONE WANTED TO OBTAIN A LARGE NUMBER OF INTERMEDIATE *
C SOLUTION VALUES BY INTERPOLATION, AS MIGHT BE THE CASE  FOR  EXAMPLE *
C WITH GRAPHICAL OUTPUT.                                               *
C                                                                      *
C                                    HULL-ENRIGHT-JACKSON   1/10/76    *
C                                                                      *
C***********************************************************************
C                                                                      *
C     USE - THE USER MUST SPECIFY EACH OF THE FOLLOWING                *
C                                                                      *
C     N  NUMBER OF EQUATIONS                                           *
C                                                                      *
C   FCN  NAME OF SUBROUTINE FOR EVALUATING FUNCTIONS - THE  SUBROUTINE *
C           ITSELF MUST ALSO BE PROVIDED BY THE USER - IT SHOULD BE OF *
C           THE FOLLOWING FORM                                         *
C              SUBROUTINE FCN(N, X, Y, YPRIME)                         *
C              INTEGER N                                               *
C              DOUBLE PRECISION X, Y(N), YPRIME(N)                     *
C                      *** ETC ***                                     *
C           AND IT SHOULD EVALUATE YPRIME, GIVEN N, X AND Y            *
C                                                                      *
C     X  INDEPENDENT VARIABLE - INITIAL VALUE SUPPLIED BY USER         *
C                                                                      *
C     Y  DEPENDENT VARIABLE - INITIAL VALUES OF COMPONENTS Y(1), Y(2), *
CC          ..., Y(N) SUPPLIED BY USER                                 *
C                                                                      *
C  XEND  VALUE OF X TO WHICH INTEGRATION IS TO BE CARRIED OUT - IT MAY *
C           BE LESS THAN THE INITIAL VALUE OF X                        *
C                                                                      *
C   TOL  TOLERANCE - THE SUBROUTINE ATTEMPTS TO CONTROL A NORM OF  THE *
C           LOCAL  ERROR  IN  SUCH  A  WAY  THAT  THE  GLOBAL ERROR IS *
C           PROPORTIONAL TO TOL. IN SOME PROBLEMS THERE WILL BE ENOUGH *
C           DAMPING  OF  ERRORS, AS WELL AS SOME CANCELLATION, SO THAT *
C           THE GLOBAL ERROR WILL BE LESS THAN TOL. ALTERNATIVELY, THE *
C           CONTROL   CAN   BE  VIEWED  AS  ATTEMPTING  TO  PROVIDE  A *
C           CALCULATED VALUE OF Y AT XEND WHICH IS THE EXACT  SOLUTION *
C           TO  THE  PROBLEM Y' = F(X,Y) + E(X) WHERE THE NORM OF E(X) *
C           IS PROPORTIONAL TO TOL.  (THE NORM  IS  A  MAX  NORM  WITH *
C           WEIGHTS  THAT  DEPEND ON THE ERROR CONTROL STRATEGY CHOSEN *
C           BY THE USER.  THE DEFAULT WEIGHT FOR THE K-TH COMPONENT IS *
C           1/MAX(1,ABS(Y(K))),  WHICH THEREFORE PROVIDES A MIXTURE OF *
C           ABSOLUTE AND RELATIVE ERROR CONTROL.)                      *
C                                                                      *
C   IND  INDICATOR - ON INITIAL ENTRY IND MUST BE SET EQUAL TO  EITHER *
C           1  OR  2. IF THE USER DOES NOT WISH TO USE ANY OPTIONS, HE *
C           SHOULD SET IND TO 1 - ALL THAT REMAINS FOR THE USER TO  DO *
C           THEN  IS  TO  DECLARE C AND W, AND TO SPECIFY NW. THE USER *
C           MAY ALSO  SELECT  VARIOUS  OPTIONS  ON  INITIAL  ENTRY  BY *
C           SETTING IND = 2 AND INITIALIZING THE FIRST 9 COMPONENTS OF *
C           C AS DESCRIBED IN THE NEXT SECTION.  HE MAY ALSO  RE-ENTER *
C           THE  SUBROUTINE  WITH IND = 3 AS MENTIONED AGAIN BELOW. IN *
C           ANY EVENT, THE SUBROUTINE RETURNS WITH IND EQUAL TO        *
C              3 AFTER A NORMAL RETURN                                 *
C              4, 5, OR 6 AFTER AN INTERRUPT (SEE OPTIONS C(8), C(9))  *
C              -1, -2, OR -3 AFTER AN ERROR CONDITION (SEE BELOW)      *
C                                                                      *
C     C  COMMUNICATIONS VECTOR - THE DIMENSION MUST BE GREATER THAN OR *
C           EQUAL TO 24, UNLESS OPTION C(1) = 4 OR 5 IS USED, IN WHICH *
C           CASE THE DIMENSION MUST BE GREATER THAN OR EQUAL TO N+30   *
C                                                                      *
C    NW  FIRST DIMENSION OF WORKSPACE W -  MUST  BE  GREATER  THAN  OR *
C           EQUAL TO N                                                 *
C                                                                      *
C     W  WORKSPACE MATRIX - FIRST DIMENSION MUST BE NW AND SECOND MUST *
C           BE GREATER THAN OR EQUAL TO 9                              *
C                                                                      *
C     THE SUBROUTINE  WILL  NORMALLY  RETURN  WITH  IND  =  3,  HAVING *
C REPLACED THE INITIAL VALUES OF X AND Y WITH, RESPECTIVELY, THE VALUE *
C OF XEND AND AN APPROXIMATION TO Y AT XEND.  THE  SUBROUTINE  CAN  BE *
C CALLED  REPEATEDLY  WITH NEW VALUES OF XEND WITHOUT HAVING TO CHANGE *
C ANY OTHER ARGUMENT.  HOWEVER, CHANGES IN TOL, OR ANY OF THE  OPTIONS *
C DESCRIBED BELOW, MAY ALSO BE MADE ON SUCH A RE-ENTRY IF DESIRED.     *
C                                                                      *
C     THREE ERROR RETURNS ARE ALSO POSSIBLE, IN WHICH  CASE  X  AND  Y *
C WILL BE THE MOST RECENTLY ACCEPTED VALUES -                          *
C     WITH IND = -3 THE SUBROUTINE WAS UNABLE  TO  SATISFY  THE  ERROR *
C        REQUIREMENT  WITH A PARTICULAR STEP-SIZE THAT IS LESS THAN OR *
C        EQUAL TO HMIN, WHICH MAY MEAN THAT TOL IS TOO SMALL           *
C     WITH IND = -2 THE VALUE OF HMIN  IS  GREATER  THAN  HMAX,  WHICH *
C        PROBABLY  MEANS  THAT THE REQUESTED TOL (WHICH IS USED IN THE *
C        CALCULATION OF HMIN) IS TOO SMALL                             *
C     WITH IND = -1 THE ALLOWED MAXIMUM NUMBER OF FCN EVALUATIONS  HAS *
C        BEEN  EXCEEDED,  BUT  THIS  CAN ONLY OCCUR IF OPTION C(7), AS *
C        DESCRIBED IN THE NEXT SECTION, HAS BEEN USED                  *
C                                                                      *
C     THERE ARE SEVERAL CIRCUMSTANCES THAT WILL CAUSE THE CALCULATIONS *
C TO  BE  TERMINATED,  ALONG WITH OUTPUT OF INFORMATION THAT WILL HELP *
C THE USER DETERMINE THE CAUSE OF  THE  TROUBLE.  THESE  CIRCUMSTANCES *
C INVOLVE  ENTRY WITH ILLEGAL OR INCONSISTENT VALUES OF THE ARGUMENTS, *
C SUCH AS ATTEMPTING A NORMAL  RE-ENTRY  WITHOUT  FIRST  CHANGING  THE *
C VALUE OF XEND, OR ATTEMPTING TO RE-ENTER WITH IND LESS THAN ZERO.    *
C                                                                      *
C***********************************************************************
C                                                                      *
C     OPTIONS - IF THE SUBROUTINE IS ENTERED WITH IND = 1, THE FIRST 9 *
C COMPONENTS OF THE COMMUNICATIONS VECTOR ARE INITIALIZED TO ZERO, AND *
C THE SUBROUTINE USES ONLY DEFAULT VALUES  FOR  EACH  OPTION.  IF  THE *
C SUBROUTINE  IS  ENTERED  WITH IND = 2, THE USER MUST SPECIFY EACH OF *
C THESE 9 COMPONENTS - NORMALLY HE WOULD FIRST SET THEM ALL  TO  ZERO, *
C AND  THEN  MAKE  NON-ZERO  THOSE  THAT  CORRESPOND TO THE PARTICULAR *
C OPTIONS HE WISHES TO SELECT. IN ANY EVENT, OPTIONS MAY BE CHANGED ON *
C RE-ENTRY  TO  THE  SUBROUTINE  -  BUT IF THE USER CHANGES ANY OF THE *
C OPTIONS, OR TOL, IN THE COURSE OF A CALCULATION HE SHOULD BE CAREFUL *
C ABOUT  HOW  SUCH CHANGES AFFECT THE SUBROUTINE - IT MAY BE BETTER TO *
C RESTART WITH IND = 1 OR 2. (COMPONENTS 10 TO 24 OF C ARE USED BY THE *
C PROGRAM  -  THE INFORMATION IS AVAILABLE TO THE USER, BUT SHOULD NOT *
C NORMALLY BE CHANGED BY HIM.)                                         *
C                                                                      *
C  C(1)  ERROR CONTROL INDICATOR - THE NORM OF THE LOCAL ERROR IS  THE *
C           MAX  NORM  OF  THE  WEIGHTED  ERROR  ESTIMATE  VECTOR, THE *
C           WEIGHTS BEING DETERMINED ACCORDING TO THE VALUE OF C(1) -  *
C              IF C(1)=1 THE WEIGHTS ARE 1 (ABSOLUTE ERROR CONTROL)    *
C              IF C(1)=2 THE WEIGHTS ARE 1/ABS(Y(K))  (RELATIVE  ERROR *
C                 CONTROL)                                             *
C              IF C(1)=3 THE  WEIGHTS  ARE  1/MAX(ABS(C(2)),ABS(Y(K))) *
C                 (RELATIVE  ERROR  CONTROL,  UNLESS ABS(Y(K)) IS LESS *
C                 THAN THE FLOOR VALUE, ABS(C(2)) )                    *
C              IF C(1)=4 THE WEIGHTS ARE 1/MAX(ABS(C(K+30)),ABS(Y(K))) *
C                 (HERE INDIVIDUAL FLOOR VALUES ARE USED)              *
C              IF C(1)=5 THE WEIGHTS ARE 1/ABS(C(K+30))                *
C              FOR ALL OTHER VALUES OF C(1), INCLUDING  C(1) = 0,  THE *
C                 DEFAULT  VALUES  OF  THE  WEIGHTS  ARE  TAKEN  TO BE *
C                 1/MAX(1,ABS(Y(K))), AS MENTIONED EARLIER             *
C           (IN THE TWO CASES C(1) = 4 OR 5 THE USER MUST DECLARE  THE *
C           DIMENSION OF C TO BE AT LEAST N+30 AND MUST INITIALIZE THE *
C           COMPONENTS C(31), C(32), ..., C(N+30).)                    *
C                                                                      *
C  C(2)  FLOOR VALUE - USED WHEN THE INDICATOR C(1) HAS THE VALUE 3    *
C                                                                      *
C  C(3)  HMIN SPECIFICATION - IF NOT ZERO, THE SUBROUTINE CHOOSES HMIN *
C           TO BE ABS(C(3)) - OTHERWISE IT USES THE DEFAULT VALUE      *
C              10*MAX(DWARF,RREB*MAX(WEIGHTED NORM Y/TOL,ABS(X))),     *
C           WHERE DWARF IS A VERY SMALL POSITIVE  MACHINE  NUMBER  AND *
C           RREB IS THE RELATIVE ROUNDOFF ERROR BOUND                  *
C                                                                      *
C  C(4)  HSTART SPECIFICATION - IF NOT ZERO, THE SUBROUTINE  WILL  USE *
C           AN  INITIAL  HMAG EQUAL TO ABS(C(4)), EXCEPT OF COURSE FOR *
C           THE RESTRICTIONS IMPOSED BY HMIN AND HMAX  -  OTHERWISE IT *
C           USES THE DEFAULT VALUE OF HMAX*(TOL)**(1/6)                *
C                                                                      *
C  C(5)  SCALE SPECIFICATION - THIS IS INTENDED TO BE A MEASURE OF THE *
C           SCALE OF THE PROBLEM - LARGER VALUES OF SCALE TEND TO MAKE *
C           THE METHOD MORE RELIABLE, FIRST  BY  POSSIBLY  RESTRICTING *
C           HMAX  (AS  DESCRIBED  BELOW) AND SECOND, BY TIGHTENING THE *
C           ACCEPTANCE REQUIREMENT - IF C(5) IS ZERO, A DEFAULT  VALUE *
C           OF  1  IS  USED.  FOR  LINEAR  HOMOGENEOUS  PROBLEMS  WITH *
C           CONSTANT COEFFICIENTS, AN APPROPRIATE VALUE FOR SCALE IS A *
C           NORM  OF  THE  ASSOCIATED  MATRIX.  FOR OTHER PROBLEMS, AN *
C           APPROXIMATION TO  AN  AVERAGE  VALUE  OF  A  NORM  OF  THE *
C           JACOBIAN ALONG THE TRAJECTORY MAY BE APPROPRIATE           *
C                                                                      *
C  C(6)  HMAX SPECIFICATION - FOUR CASES ARE POSSIBLE                  *
C           IF C(6).NE.0 AND C(5).NE.0, HMAX IS TAKEN TO BE            *
C              MIN(ABS(C(6)),2/ABS(C(5)))                              *
C           IF C(6).NE.0 AND C(5).EQ.0, HMAX IS TAKEN TO BE  ABS(C(6)) *
C           IF C(6).EQ.0 AND C(5).NE.0, HMAX IS TAKEN TO BE            *
C              2/ABS(C(5))                                             *
C           IF C(6).EQ.0 AND C(5).EQ.0, HMAX IS GIVEN A DEFAULT  VALUE *
C              OF 2                                                    *
C                                                                      *
C  C(7)  MAXIMUM NUMBER OF FUNCTION EVALUATIONS  -  IF  NOT  ZERO,  AN *
C           ERROR  RETURN WITH IND = -1 WILL BE CAUSED WHEN THE NUMBER *
C           OF FUNCTION EVALUATIONS EXCEEDS ABS(C(7))                  *
C                                                                      *
C  C(8)  INTERRUPT NUMBER  1  -  IF  NOT  ZERO,  THE  SUBROUTINE  WILL *
C           INTERRUPT   THE  CALCULATIONS  AFTER  IT  HAS  CHOSEN  ITS *
C           PRELIMINARY VALUE OF HMAG, AND JUST BEFORE CHOOSING HTRIAL *
C           AND  XTRIAL  IN  PREPARATION FOR TAKING A STEP (HTRIAL MAY *
C           DIFFER FROM HMAG IN SIGN, AND MAY  REQUIRE  ADJUSTMENT  IF *
C           XEND  IS  NEAR) - THE SUBROUTINE RETURNS WITH IND = 4, AND *
C           WILL RESUME CALCULATION AT THE POINT  OF  INTERRUPTION  IF *
C           RE-ENTERED WITH IND = 4                                    *
C                                                                      *
C  C(9)  INTERRUPT NUMBER  2  -  IF  NOT  ZERO,  THE  SUBROUTINE  WILL *
C           INTERRUPT   THE  CALCULATIONS  IMMEDIATELY  AFTER  IT  HAS *
C           DECIDED WHETHER OR NOT TO ACCEPT THE RESULT  OF  THE  MOST *
C           RECENT  TRIAL STEP, WITH IND = 5 IF IT PLANS TO ACCEPT, OR *
C           IND = 6 IF IT PLANS TO REJECT -  Y(*)  IS  THE  PREVIOUSLY *
C           ACCEPTED  RESULT, WHILE W(*,9) IS THE NEWLY COMPUTED TRIAL *
C           VALUE, AND W(*,2) IS THE UNWEIGHTED ERROR ESTIMATE VECTOR. *
C           THE  SUBROUTINE  WILL  RESUME CALCULATIONS AT THE POINT OF *
C           INTERRUPTION ON RE-ENTRY WITH IND = 5 OR 6. (THE USER  MAY *
C           CHANGE IND IN THIS CASE IF HE WISHES, FOR EXAMPLE TO FORCE *
C           ACCEPTANCE OF A STEP THAT WOULD OTHERWISE BE REJECTED,  OR *
C           VICE VERSA. HE CAN ALSO RESTART WITH IND = 1 OR 2.)        *
C                                                                      *
C***********************************************************************
C                                                                      *
C  SUMMARY OF THE COMPONENTS OF THE COMMUNICATIONS VECTOR              *
C                                                                      *
C     PRESCRIBED AT THE OPTION       DETERMINED BY THE PROGRAM         *
C           OF THE USER                                                *
C                                                                      *
C                                    C(10) RREB(REL ROUNDOFF ERR BND)  *
C     C(1) ERROR CONTROL INDICATOR   C(11) DWARF (VERY SMALL MACH NO)  *
C     C(2) FLOOR VALUE               C(12) WEIGHTED NORM Y             *
C     C(3) HMIN SPECIFICATION        C(13) HMIN                        *
C     C(4) HSTART SPECIFICATION      C(14) HMAG                        *
C     C(5) SCALE SPECIFICATION       C(15) SCALE                       *
C     C(6) HMAX SPECIFICATION        C(16) HMAX                        *
C     C(7) MAX NO OF FCN EVALS       C(17) XTRIAL                      *
C     C(8) INTERRUPT NO 1            C(18) HTRIAL                      *
C     C(9) INTERRUPT NO 2            C(19) EST                         *
C                                    C(20) PREVIOUS XEND               *
C                                    C(21) FLAG FOR XEND               *
C                                    C(22) NO OF SUCCESSFUL STEPS      *
C                                    C(23) NO OF SUCCESSIVE FAILURES   *
C                                    C(24) NO OF FCN EVALS             *
C                                                                      *
C  IF C(1) = 4 OR 5, C(31), C(32), ... C(N+30) ARE FLOOR VALUES        *
C                                                                      *
C***********************************************************************
C                                                                      *
C  AN OVERVIEW OF THE PROGRAM                                          *
C                                                                      *
C     BEGIN INITIALIZATION, PARAMETER CHECKING, INTERRUPT RE-ENTRIES   *
CC ......ABORT IF IND OUT OF RANGE 1 TO 6                              *
C  .     CASES - INITIAL ENTRY, NORMAL RE-ENTRY, INTERRUPT RE-ENTRIES  *
C  .     CASE 1 - INITIAL ENTRY (IND .EQ. 1 OR 2)                      *
C  V........ABORT IF N.GT.NW OR TOL.LE.0                               *
C  .        IF INITIAL ENTRY WITHOUT OPTIONS (IND .EQ. 1)              *
C  .           SET C(1) TO C(9) EQUAL TO ZERO                          *
C  .        ELSE INITIAL ENTRY WITH OPTIONS (IND .EQ. 2)               *
C  .           MAKE C(1) TO C(9) NON-NEGATIVE                          *
C  .           MAKE FLOOR VALUES NON-NEGATIVE IF THEY ARE TO BE USED   *
C  .        END IF                                                     *
C  .        INITIALIZE RREB, DWARF, PREV XEND, FLAG, COUNTS            *
C  .     CASE 2 - NORMAL RE-ENTRY (IND .EQ. 3)                         *
CC .........ABORT IF XEND REACHED, AND EITHER X CHANGED OR XEND NOT    *
C  .        RE-INITIALIZE FLAG                                         *
C  .     CASE 3 - RE-ENTRY FOLLOWING AN INTERRUPT (IND .EQ. 4 TO 6)    *
C  V        TRANSFER CONTROL TO THE APPROPRIATE RE-ENTRY POINT.......  *
C  .     END CASES                                                  .  *
C  .  END INITIALIZATION, ETC.                                      .  *
C  .                                                                V  *
C  .  LOOP THROUGH THE FOLLOWING 4 STAGES, ONCE FOR EACH TRIAL STEP .  *
C  .     STAGE 1 - PREPARE                                          .  *
C***********ERROR RETURN (WITH IND=-1) IF NO OF FCN EVALS TOO GREAT .  *
C  .        CALC SLOPE (ADDING 1 TO NO OF FCN EVALS) IF IND .NE. 6  .  *
C  .        CALC HMIN, SCALE, HMAX                                  .  *
C***********ERROR RETURN (WITH IND=-2) IF HMIN .GT. HMAX            .  *
C  .        CALC PRELIMINARY HMAG                                   .  *
C***********INTERRUPT NO 1 (WITH IND=4) IF REQUESTED.......RE-ENTRY.V  *
C  .        CALC HMAG, XTRIAL AND HTRIAL                            .  *
C  .     END STAGE 1                                                .  *
C  V     STAGE 2 - CALC YTRIAL (ADDING 7 TO NO OF FCN EVALS)        .  *
C  .     STAGE 3 - CALC THE ERROR ESTIMATE                          .  *
C  .     STAGE 4 - MAKE DECISIONS                                   .  *
C  .        SET IND=5 IF STEP ACCEPTABLE, ELSE SET IND=6            .  *
C***********INTERRUPT NO 2 IF REQUESTED....................RE-ENTRY.V  *
C  .        IF STEP ACCEPTED (IND .EQ. 5)                              *
C  .           UPDATE X, Y FROM XTRIAL, YTRIAL                         *
C  .           ADD 1 TO NO OF SUCCESSFUL STEPS                         *
C  .           SET NO OF SUCCESSIVE FAILURES TO ZERO                   *
C**************RETURN(WITH IND=3, XEND SAVED, FLAG SET) IF X .EQ. XEND *
C  .        ELSE STEP NOT ACCEPTED (IND .EQ. 6)                        *
C  .           ADD 1 TO NO OF SUCCESSIVE FAILURES                      *
C**************ERROR RETURN (WITH IND=-3) IF HMAG .LE. HMIN            *
C  .        END IF                                                     *
C  .     END STAGE 4                                                   *
C  .  END LOOP                                                         *
C  .                                                                   *
C  BEGIN ABORT ACTION                                                  *
C     OUTPUT APPROPRIATE  MESSAGE  ABOUT  STOPPING  THE  CALCULATIONS, *
C        ALONG WITH VALUES OF IND, N, NW, TOL, HMIN,  HMAX,  X,  XEND, *
C        PREVIOUS XEND,  NO OF  SUCCESSFUL  STEPS,  NO  OF  SUCCESSIVE *
C        FAILURES, NO OF FCN EVALS, AND THE COMPONENTS OF Y            *
C     STOP                                                             *
C  END ABORT ACTION                                                    *
C                                                                      *
C***********************************************************************
C
C     ******************************************************************
C     * BEGIN INITIALIZATION, PARAMETER CHECKING, INTERRUPT RE-ENTRIES *
C     ******************************************************************
C
CC ......ABORT IF IND OUT OF RANGE 1 TO 6
      IF (IND.LT.1 .OR. IND.GT.6) GO TO 1200
C
C        CASES - INITIAL ENTRY, NORMAL RE-ENTRY, INTERRUPT RE-ENTRIES
      GO TO (20,20,180,600,1080,1080) IND
C        CASE 1 - INITIAL ENTRY (IND .EQ. 1 OR 2)
CC .........ABORT IF N.GT.NW OR TOL.LE.0
   20 IF (N.GT.NW .OR. TOL.LE.0.) GO TO 1200
      IF (IND.EQ.2) GO TO 60
C              INITIAL ENTRY WITHOUT OPTIONS (IND .EQ. 1)
C              SET C(1) TO C(9) EQUAL TO 0
      DO 40 K = 1, 9
         C(K) = 0.
   40 CONTINUE
      GO TO 140
   60 CONTINUE
C              INITIAL ENTRY WITH OPTIONS (IND .EQ. 2)
C              MAKE C(1) TO C(9) NON-NEGATIVE
      DO 80 K = 1, 9
         C(K) = ABS(C(K))
   80 CONTINUE
C              MAKE FLOOR VALUES NON-NEGATIVE IF THEY ARE TO BE USED
      IF (C(1).NE.4. .AND. C(1).NE.5.) GO TO 120
      DO 100 K = 1, N
         C(K+30) = ABS(C(K+30))
  100 CONTINUE
  120 CONTINUE
  140 CONTINUE
C           INITIALIZE RREB, DWARF, PREV XEND, FLAG, COUNTS
      C(10) = CONST(1)
      C(11) = CONST(2)
C           SET PREVIOUS XEND INITIALLY TO INITIAL VALUE OF X
      C(20) = X
      DO 160 K = 21, 24
         C(K) = 0.
  160 CONTINUE
      GO TO 200
C        CASE 2 - NORMAL RE-ENTRY (IND .EQ. 3)
CC .........ABORT IF XEND REACHED, AND EITHER X CHANGED OR XEND NOT
  180 IF (C(21).NE.0. .AND. (X.NE.C(20) .OR. XEND.EQ.C(20))) GO TO 1200
C           RE-INITIALIZE FLAG
      C(21) = 0.
      GO TO 200
C        CASE 3 - RE-ENTRY FOLLOWING AN INTERRUPT (IND .EQ. 4 TO 6)
C           TRANSFER CONTROL TO THE APPROPRIATE RE-ENTRY POINT..........
C           THIS HAS ALREADY BEEN HANDLED BY THE COMPUTED GO TO        .
C        END CASES                                                     V
  200 CONTINUE
C
C     END INITIALIZATION, ETC.
C
C     ******************************************************************
C     * LOOP THROUGH THE FOLLOWING 4 STAGES, ONCE FOR EACH TRIAL  STEP *
C     * UNTIL THE OCCURRENCE OF ONE OF THE FOLLOWING                   *
C     *    (A) THE NORMAL RETURN (WITH IND .EQ. 3) ON REACHING XEND IN *
C     *        STAGE 4                                                 *
C     *    (B) AN ERROR RETURN (WITH IND .LT. 0) IN STAGE 1 OR STAGE 4 *
C     *    (C) AN INTERRUPT RETURN (WITH IND  .EQ.  4,  5  OR  6),  IF *
C     *        REQUESTED, IN STAGE 1 OR STAGE 4                        *
C     ******************************************************************
C
  220 CONTINUE
C
C        ***************************************************************
C        * STAGE 1 - PREPARE - DO CALCULATIONS OF  HMIN,  HMAX,  ETC., *
C        * AND SOME PARAMETER  CHECKING,  AND  END  UP  WITH  SUITABLE *
C        * VALUES OF HMAG, XTRIAL AND HTRIAL IN PREPARATION FOR TAKING *
C        * AN INTEGRATION STEP.                                        *
C        ***************************************************************
C
C***********ERROR RETURN (WITH IND=-1) IF NO OF FCN EVALS TOO GREAT
      IF (C(7).EQ.0. .OR. C(24).LT.C(7)) GO TO 240
      IND = -1
      RETURN
  240 CONTINUE
C
C           CALCULATE SLOPE (ADDING 1 TO NO OF FCN EVALS) IF IND .NE. 6
      IF (IND.EQ.6) GO TO 260
      CALL FCN(N,X,Y,W(1,1))
      C(24) = C(24) + 1.
  260 CONTINUE
C
C           CALCULATE HMIN - USE DEFAULT UNLESS VALUE PRESCRIBED
      C(13) = C(3)
      IF (C(3).NE.0.) GO TO 500
C              CALCULATE DEFAULT VALUE OF HMIN
C              FIRST CALCULATE WEIGHTED NORM Y - C(12) - AS SPECIFIED
C              BY THE ERROR CONTROL INDICATOR C(1)
      TEMP = 0.
      IF (C(1).NE.1.) GO TO 300
C                 ABSOLUTE ERROR CONTROL - WEIGHTS ARE 1
      DO 280 K = 1, N
         TEMP = AMAX1(TEMP,ABS(Y(K)))
  280 CONTINUE
      C(12) = TEMP
      GO TO 480
  300 IF (C(1).NE.2.) GO TO 320
C                 RELATIVE ERROR CONTROL - WEIGHTS ARE 1/DABS(Y(K)) SO
C                 WEIGHTED NORM Y IS 1
      C(12) = 1.
      GO TO 480
  320 IF (C(1).NE.3.) GO TO 360
C                 WEIGHTS ARE 1/MAX(C(2),ABS(Y(K)))
      DO 340 K = 1, N
         TEMP = AMAX1(TEMP,ABS(Y(K))/C(2))
  340 CONTINUE
      C(12) = AMIN1(TEMP,1.)
      GO TO 480
  360 IF (C(1).NE.4.) GO TO 400
C                 WEIGHTS ARE 1/MAX(C(K+30),ABS(Y(K)))
      DO 380 K = 1, N
         TEMP = AMAX1(TEMP,ABS(Y(K))/C(K+30))
  380 CONTINUE
      C(12) = AMIN1(TEMP,1.)
      GO TO 480
  400 IF (C(1).NE.5.) GO TO 440
C                 WEIGHTS ARE 1/C(K+30)
      DO 420 K = 1, N
         TEMP = AMAX1(TEMP,ABS(Y(K))/C(K+30))
  420 CONTINUE
      C(12) = TEMP
      GO TO 480
  440 CONTINUE
C                 DEFAULT CASE - WEIGHTS ARE 1/MAX(1,ABS(Y(K)))
      DO 460 K = 1, N
         TEMP = AMAX1(TEMP,ABS(Y(K)))
  460 CONTINUE
      C(12) = AMIN1(TEMP,1.)
  480 CONTINUE
      C(13) = 10.*AMAX1(C(11),C(10)*AMAX1(C(12)/TOL,ABS(X)))
  500 CONTINUE
C
C           CALCULATE SCALE - USE DEFAULT UNLESS VALUE PRESCRIBED
      C(15) = C(5)
      IF (C(5).EQ.0.) C(15) = 1.
C
C           CALCULATE HMAX - CONSIDER 4 CASES
C           CASE 1 BOTH HMAX AND SCALE PRESCRIBED
      IF (C(6).NE.0. .AND. C(5).NE.0.) C(16) = AMIN1(C(6),2./C(5))
C           CASE 2 - HMAX PRESCRIBED, BUT SCALE NOT
      IF (C(6).NE.0. .AND. C(5).EQ.0.) C(16) = C(6)
C           CASE 3 - HMAX NOT PRESCRIBED, BUT SCALE IS
      IF (C(6).EQ.0. .AND. C(5).NE.0.) C(16) = 2./C(5)
C           CASE 4 - NEITHER HMAX NOR SCALE IS PROVIDED
      IF (C(6).EQ.0. .AND. C(5).EQ.0.) C(16) = 2.
C
C***********ERROR RETURN (WITH IND=-2) IF HMIN .GT. HMAX
      IF (C(13).LE.C(16)) GO TO 520
      IND = -2
      RETURN
  520 CONTINUE
C
C           CALCULATE PRELIMINARY HMAG - CONSIDER 3 CASES
      IF (IND.GT.2) GO TO 540
C           CASE 1 - INITIAL ENTRY - USE PRESCRIBED VALUE OF HSTART, IF
C              ANY, ELSE DEFAULT
      C(14) = C(4)
      IF (C(4).EQ.0.) C(14) = C(16)*TOL**(1./6.)
      GO TO 580
  540 IF (C(23).GT.1.) GO TO 560
C           CASE 2 - AFTER A SUCCESSFUL STEP, OR AT MOST  ONE  FAILURE,
C              USE MIN(2, .9*(TOL/EST)**(1/6))*HMAG, BUT AVOID POSSIBLE
C              OVERFLOW. THEN AVOID REDUCTION BY MORE THAN HALF.
      TEMP = 2.*C(14)
      IF (TOL.LT.(2./.9)**6*C(19)) TEMP = .9*(TOL/C(19))**(1./6.)*C(14)
      C(14) = AMAX1(TEMP,.5*C(14))
      GO TO 580
  560 CONTINUE
C           CASE 3 - AFTER TWO OR MORE SUCCESSIVE FAILURES
      C(14) = .5*C(14)
  580 CONTINUE
C
C           CHECK AGAINST HMAX
      C(14) = AMIN1(C(14),C(16))
C
C           CHECK AGAINST HMIN
      C(14) = AMAX1(C(14),C(13))
C
C***********INTERRUPT NO 1 (WITH IND=4) IF REQUESTED
      IF (C(8).EQ.0.) GO TO 600
      IND = 4
      RETURN
C           RESUME HERE ON RE-ENTRY WITH IND .EQ. 4   ........RE-ENTRY..
  600 CONTINUE
C
C           CALCULATE HMAG, XTRIAL - DEPENDING ON PRELIMINARY HMAG, XEND
      IF (C(14).GE.ABS(XEND-X)) GO TO 620
C              DO NOT STEP MORE THAN HALF WAY TO XEND
      C(14) = AMIN1(C(14),.5*ABS(XEND-X))
      C(17) = X + SIGN(C(14),XEND-X)
      GO TO 640
  620 CONTINUE
C              HIT XEND EXACTLY
      C(14) = ABS(XEND-X)
      C(17) = XEND
  640 CONTINUE
C
C           CALCULATE HTRIAL
      C(18) = C(17) - X
C
C        END STAGE 1
C
C        ***************************************************************
C        * STAGE 2 - CALCULATE YTRIAL (ADDING 7 TO NO OF  FCN  EVALS). *
C        * W(*,2), ... W(*,8)  HOLD  INTERMEDIATE  RESULTS  NEEDED  IN *
C        * STAGE 3. W(*,9) IS TEMPORARY STORAGE UNTIL FINALLY IT HOLDS *
C        * YTRIAL.                                                     *
C        ***************************************************************
C
      TEMP = C(18)/1398169080000.
C
      DO 660 K = 1, N
         W(K,9) = Y(K) + TEMP*W(K,1)*233028180000.
  660 CONTINUE
      CALL FCN(N,X+C(18)/6.,W(1,9),W(1,2))
C
      DO 680 K = 1, N
         W(K,9) = Y(K) + TEMP*(W(K,1)*74569017600.+W(K,2)*298276070400.)
  680 CONTINUE
      CALL FCN(N,X+C(18)*(4./15.),W(1,9),W(1,3))
C
      DO 700 K = 1, N
         W(K,9) = Y(K) + TEMP*(W(K,1)*1165140900000.-W(K,2)
     *            *3728450880000.+W(K,3)*3495422700000.)
  700 CONTINUE
      CALL FCN(N,X+C(18)*(2./3.),W(1,9),W(1,4))
C
      DO 720 K = 1, N
         W(K,9) = Y(K) + TEMP*(-W(K,1)*3604654659375.+W(K,2)
     *            *12816549900000.-W(K,3)*9284716546875.+W(K,4)
     *            *1237962206250.)
  720 CONTINUE
      CALL FCN(N,X+C(18)*(5./6.),W(1,9),W(1,5))
C
      DO 740 K = 1, N
         W(K,9) = Y(K) + TEMP*(W(K,1)*3355605792000.-W(K,2)
     *            *11185352640000.+W(K,3)*9172628850000.-W(K,4)
     *            *427218330000.+W(K,5)*482505408000.)
  740 CONTINUE
      CALL FCN(N,X+C(18),W(1,9),W(1,6))
C
      DO 760 K = 1, N
         W(K,9) = Y(K) + TEMP*(-W(K,1)*770204740536.+W(K,2)
     *            *2311639545600.-W(K,3)*1322092233000.-W(K,4)
     *            *453006781920.+W(K,5)*326875481856.)
  760 CONTINUE
      CALL FCN(N,X+C(18)/15.,W(1,9),W(1,7))
C
      DO 780 K = 1, N
         W(K,9) = Y(K) + TEMP*(W(K,1)*2845924389000.-W(K,2)
     *            *9754668000000.+W(K,3)*7897110375000.-W(K,4)
     *            *192082660000.+W(K,5)*400298976000.+W(K,7)
     *            *201586000000.)
  780 CONTINUE
      CALL FCN(N,X+C(18),W(1,9),W(1,8))
C
C           CALCULATE YTRIAL, THE EXTRAPOLATED APPROXIMATION AND STORE
C              IN W(*,9)
      DO 800 K = 1, N
         W(K,9) = Y(K) + TEMP*(W(K,1)*104862681000.+W(K,3)
     *            *545186250000.+W(K,4)*446637345000.+W(K,5)
     *            *188806464000.+W(K,7)*15076875000.+W(K,8)
     *            *97599465000.)
  800 CONTINUE
C
C           ADD 7 TO THE NO OF FCN EVALS
      C(24) = C(24) + 7.
C
C        END STAGE 2
C
C        ***************************************************************
C        * STAGE 3 - CALCULATE THE ERROR ESTIMATE EST. FIRST CALCULATE *
C        * THE  UNWEIGHTED  ABSOLUTE  ERROR  ESTIMATE VECTOR (PER UNIT *
C        * STEP) FOR THE UNEXTRAPOLATED APPROXIMATION AND STORE IT  IN *
C        * W(*,2).  THEN  CALCULATE THE WEIGHTED MAX NORM OF W(*,2) AS *
C        * SPECIFIED BY THE ERROR  CONTROL  INDICATOR  C(1).  FINALLY, *
C        * MODIFY  THIS RESULT TO PRODUCE EST, THE ERROR ESTIMATE (PER *
C        * UNIT STEP) FOR THE EXTRAPOLATED APPROXIMATION YTRIAL.       *
C        ***************************************************************
C
C           CALCULATE THE UNWEIGHTED ABSOLUTE ERROR ESTIMATE VECTOR
      DO 820 K = 1, N
         W(K,2) = (W(K,1)*8738556750.+W(K,3)*9735468750.-W(K,4)
     *            *9709507500.+W(K,5)*8582112000.+W(K,6)
     *            *95329710000.-W(K,7)*15076875000.-W(K,8)*97599465000.)
     *            /1398169080000.
  820 CONTINUE
C
C           CALCULATE THE WEIGHTED MAX NORM OF W(*,2) AS SPECIFIED BY
C           THE ERROR CONTROL INDICATOR C(1)
      TEMP = 0.
      IF (C(1).NE.1.) GO TO 860
C              ABSOLUTE ERROR CONTROL
      DO 840 K = 1, N
         TEMP = AMAX1(TEMP,ABS(W(K,2)))
  840 CONTINUE
      GO TO 1060
  860 IF (C(1).NE.2.) GO TO 900
C              RELATIVE ERROR CONTROL
      DO 880 K = 1, N
         TEMP = AMAX1(TEMP,ABS(W(K,2)/Y(K)))
  880 CONTINUE
      GO TO 1060
  900 IF (C(1).NE.3.) GO TO 940
C              WEIGHTS ARE 1/MAX(C(2),ABS(Y(K)))
      DO 920 K = 1, N
         TEMP = AMAX1(TEMP,ABS(W(K,2))/AMAX1(C(2),ABS(Y(K))))
  920 CONTINUE
      GO TO 1060
  940 IF (C(1).NE.4.) GO TO 980
C              WEIGHTS ARE 1/MAX(C(K+30),ABS(Y(K)))
      DO 960 K = 1, N
         TEMP = AMAX1(TEMP,ABS(W(K,2))/AMAX1(C(K+30),ABS(Y(K))))
  960 CONTINUE
      GO TO 1060
  980 IF (C(1).NE.5.) GO TO 1020
C              WEIGHTS ARE 1/C(K+30)
      DO 1000 K = 1, N
         TEMP = AMAX1(TEMP,ABS(W(K,2)/C(K+30)))
 1000 CONTINUE
      GO TO 1060
 1020 CONTINUE
C              DEFAULT CASE - WEIGHTS ARE 1/MAX(1,ABS(Y(K)))
      DO 1040 K = 1, N
         TEMP = AMAX1(TEMP,ABS(W(K,2))/AMAX1(1.,ABS(Y(K))))
 1040 CONTINUE
 1060 CONTINUE
C
C           CALCULATE EST - (THE WEIGHTED MAX NORM OF W(*,2))*HMAG*SCALE
C              - EST IS INTENDED TO BE A MEASURE OF THE ERROR  PER  UNIT
C              STEP IN YTRIAL
      C(19) = TEMP*C(14)*C(15)
C
C        END STAGE 3
C
C        ***************************************************************
C        * STAGE 4 - MAKE DECISIONS.                                   *
C        ***************************************************************
C
C           SET IND=5 IF STEP ACCEPTABLE, ELSE SET IND=6
      IND = 5
      IF (C(19).GT.TOL) IND = 6
C
C***********INTERRUPT NO 2 IF REQUESTED
      IF (C(9).EQ.0.) GO TO 1080
      RETURN
C           RESUME HERE ON RE-ENTRY WITH IND .EQ. 5 OR 6   ...RE-ENTRY..
 1080 CONTINUE
C
      IF (IND.EQ.6) GO TO 1140
C              STEP ACCEPTED (IND .EQ. 5), SO UPDATE X, Y FROM XTRIAL,
C                 YTRIAL, ADD 1 TO THE NO OF SUCCESSFUL STEPS, AND SET
C                 THE NO OF SUCCESSIVE FAILURES TO ZERO
      X = C(17)
      DO 1100 K = 1, N
         Y(K) = W(K,9)
 1100 CONTINUE
      C(22) = C(22) + 1.
      C(23) = 0.
C**************RETURN(WITH IND=3, XEND SAVED, FLAG SET) IF X .EQ. XEND
      IF (X.NE.XEND) GO TO 1120
      IND = 3
      C(20) = XEND
      C(21) = 1.
      RETURN
 1120 CONTINUE
      GO TO 1180
 1140 CONTINUE
C              STEP NOT ACCEPTED (IND .EQ. 6), SO ADD 1 TO THE NO OF
C                 SUCCESSIVE FAILURES
      C(23) = C(23) + 1.
C**************ERROR RETURN (WITH IND=-3) IF HMAG .LE. HMIN
      IF (C(14).GT.C(13)) GO TO 1160
      IND = -3
      RETURN
 1160 CONTINUE
 1180 CONTINUE
C
C        END STAGE 4
C
      GO TO 220
C     END LOOP
C
C  BEGIN ABORT ACTION
 1200 CONTINUE
C
      IOUT = CONST(3)
      WRITE (IOUT,FMT=99999) IND, TOL, X, N, C(13), XEND, NW, C(16),
     *  C(20), C(22), C(23), C(24), (Y(K),K=1,N)
C
      STOP
C
C  END ABORT ACTION
C
99999 FORMAT (///
     *      '0COMPUTATION STOPPED IN TRUE WITH THE FOLLOWIN G 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,/' NW  =',I4,5X,'HMAX =',1P,E13.6,5X,
     *       'PREV XEND =',1P,E22.15,/'0',14X,
     *       'NO OF SUCCESSFUL STEPS    =',0P,F8.0,/15X,
     *       'NO OF SUCCESSIVE FAILURES =',0P,F8.0,/15X,
     *       'NO OF FUNCTION EVALS      =',0P,F8.0,
     *       /'0THE COMPONENTS OF Y ARE',//(' ',1P,5E24.15))
      END
C
C*******************************************************************
C
      SUBROUTINE FCN2(N,X,Y,YP)
C     .. Scalar Arguments ..
      REAL            X
      INTEGER         N
C     .. Array Arguments ..
      REAL            Y(N), YP(N)
C     .. External Subroutines ..
      EXTERNAL        FCN
C     .. Executable Statements ..
      CALL FCN(X,Y,YP)
      RETURN
      END
      SUBROUTINE IVALU(N,XSTART,XEND,HBEGIN,HMAX,Y,FCNTIM,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      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
      INTEGER          ID, IWT, N
C     .. Array Arguments ..
      DOUBLE PRECISION W(51), Y(51)
C     .. Local Scalars ..
      DOUBLE PRECISION E, HB, HM, XE, XS
      INTEGER          I, IOUT
C     .. External Functions ..
      REAL             CONST
      EXTERNAL         CONST
C     .. Intrinsic Functions ..
      INTRINSIC        DBLE, DSQRT
C     .. Data statements ..
      DATA             HM, HB, XS, XE/20.D0, 1.D0, 0.D0, 20.D0/
C     .. Executable Statements ..
      HMAX = HM
      HBEGIN = HB
      XSTART = XS
      XEND = XE
      GO TO (40,60,80,100,120,20,20,20,20,
     *       20,140,160,180,200,220,20,20,20,
     *       20,20,240,280,320,360,400,20,20,
     *       20,20,20,420,420,420,420,420,20,
     *       20,20,20,20,540,560,580,600,620,
     *       20,20,20,20,20,640,660,680,700,
     *       720) ID
   20 IOUT = CONST(3)
      WRITE (IOUT,FMT=99999) ID
      STOP
C
C     PROBLEM CLASS A
C     1:
   40 CONTINUE
CP    PROBLEM A1
      FCNTIM = 0.0
      N = 1
      W(1) = 0.100D+01
      Y(1) = 1.D0
      GO TO 740
C     2:
   60 CONTINUE
CP    PROBLEM A2
      FCNTIM = 0.0
      N = 1
      W(1) = 0.100D+01
      Y(1) = 1.D0
      GO TO 740
C     3:
   80 CONTINUE
CP    PROBLEM A3
      FCNTIM = 0.0
      N = 1
      W(1) = 0.271D+01
      Y(1) = 1.D0
      GO TO 740
C     4:
  100 CONTINUE
CP    PROBLEM A4
      FCNTIM = 0.0
      N = 1
      W(1) = 0.177D+02
      Y(1) = 1.D0
      GO TO 740
C     5:
  120 CONTINUE
CP    PROBLEM A5
      FCNTIM = 0.0
      N = 1
      W(1) = 0.620D+01
      Y(1) = 4.D0
      GO TO 740
C     PROBLEM CLASS B
C     11:
  140 CONTINUE
CP    PROBLEM B1
      FCNTIM = 0.0
      N = 2
      W(1) = 0.425D+01
      W(2) = 0.300D+01
      Y(1) = 1.D0
      Y(2) = 3.D0
      GO TO 740
C     12:
  160 CONTINUE
CP    PROBLEM B2
      FCNTIM = 0.0
      N = 3
      W(1) = 0.200D+01
      W(2) = 0.100D+01
      W(3) = 0.100D+01
      Y(1) = 2.D0
      Y(2) = 0.D0
      Y(3) = 1.D0
      GO TO 740
C     13:
  180 CONTINUE
CP    PROBLEM B3
      FCNTIM = 0.0
      N = 3
      W(1) = 0.100D+01
      W(2) = 0.519D+00
      W(3) = 0.947D+00
      Y(1) = 1.D0
      Y(2) = 0.D0
      Y(3) = 0.D0
      GO TO 740
C     14:
  200 CONTINUE
CP    PROBLEM B4
      FCNTIM = 0.0
      N = 3
      W(1) = 0.300D+01
      W(2) = 0.220D+01
      W(3) = 0.100D+01
      Y(1) = 3.D0
      Y(2) = 0.D0
      Y(3) = 0.D0
      GO TO 740
C     15:
  220 CONTINUE
CP    PROBLEM B5
      FCNTIM = 0.0
      N = 3
      W(1) = 0.100D+01
      W(2) = 0.100D+01
      W(3) = 0.100D+01
      Y(1) = 0.D0
      Y(2) = 1.D0
      Y(3) = 1.D0
      GO TO 740
C     PROBLEM CLASS C
C     21:
  240 CONTINUE
CP    PROBLEM C1
      FCNTIM = 0.0
      N = 10
      W(1) = 0.100D+01
      W(2) = 0.368D+00
      W(3) = 0.271D+00
      W(4) = 0.224D+00
      W(5) = 0.195D+00
      W(6) = 0.175D+00
      W(7) = 0.161D+00
      W(8) = 0.149D+00
      W(9) = 0.139D+00
      W(10) = 0.998D+00
      Y(1) = 1.D0
      DO 260 I = 2, N
         Y(I) = 0.D0
  260 CONTINUE
      GO TO 740
C     22:
  280 CONTINUE
CP    PROBLEM C2
      FCNTIM = 0.0
      N = 10
      W(1) = 0.100D+01
      W(2) = 0.250D+00
      W(3) = 0.148D+00
      W(4) = 0.105D+00
      W(5) = 0.818D-01
      W(6) = 0.669D-01
      W(7) = 0.566D-01
      W(8) = 0.491D-01
      W(9) = 0.433D-01
      W(10) = 0.100D+01
      Y(1) = 1.D0
      DO 300 I = 2, N
         Y(I) = 0.D0
  300 CONTINUE
      GO TO 740
C     23:
  320 CONTINUE
CP    PROBLEM C3
      FCNTIM = 0.0
      N = 10
      W(1) = 0.100D+01
      W(2) = 0.204D+00
      W(3) = 0.955D-01
      W(4) = 0.553D-01
      W(5) = 0.359D-01
      W(6) = 0.252D-01
      W(7) = 0.184D-01
      W(8) = 0.133D-01
      W(9) = 0.874D-02
      W(10) = 0.435D-02
      Y(1) = 1.D0
      DO 340 I = 2, N
         Y(I) = 0.D0
  340 CONTINUE
      GO TO 740
C     24:
  360 CONTINUE
CP    PROBLEM C4
      FCNTIM = 0.0
      N = 51
      W(1) = 0.100D+01
      W(2) = 0.204D+00
      W(3) = 0.955D-01
      W(4) = 0.553D-01
      W(5) = 0.359D-01
      W(6) = 0.252D-01
      W(7) = 0.186D-01
      W(8) = 0.143D-01
      W(9) = 0.113D-01
      W(10) = 0.918D-02
      W(11) = 0.760D-02
      W(12) = 0.622D-02
      W(13) = 0.494D-02
      W(14) = 0.380D-02
      W(15) = 0.284D-02
      W(16) = 0.207D-02
      W(17) = 0.146D-02
      W(18) = 0.101D-02
      W(19) = 0.678D-03
      W(20) = 0.444D-03
      W(21) = 0.283D-03
      W(22) = 0.177D-03
      W(23) = 0.107D-03
      W(24) = 0.637D-04
      W(25) = 0.370D-04
      W(26) = 0.210D-04
      W(27) = 0.116D-04
      W(28) = 0.631D-05
      W(29) = 0.335D-05
      W(30) = 0.174D-05
      W(31) = 0.884D-06
      W(32) = 0.440D-06
      W(33) = 0.215D-06
      W(34) = 0.103D-06
      W(35) = 0.481D-07
      W(36) = 0.221D-07
      W(37) = 0.996D-08
      W(38) = 0.440D-08
      W(39) = 0.191D-08
      W(40) = 0.814D-09
      W(41) = 0.340D-09
      W(42) = 0.140D-09
      W(43) = 0.564D-10
      W(44) = 0.224D-10
      W(45) = 0.871D-11
      W(46) = 0.334D-11
      W(47) = 0.126D-11
      W(48) = 0.465D-12
      W(49) = 0.169D-12
      W(50) = 0.600D-13
      W(51) = 0.189D-13
      Y(1) = 1.D0
      DO 380 I = 2, N
         Y(I) = 0.D0
  380 CONTINUE
      GO TO 740
C     25:
  400 CONTINUE
CP    PROBLEM C5
      FCNTIM = 0.0
      N = 30
      W(1) = 0.545D+01
      W(2) = 0.471D+01
      W(3) = 0.203D+01
      W(4) = 0.664D+01
      W(5) = 0.834D+01
      W(6) = 0.346D+01
      W(7) = 0.113D+02
      W(8) = 0.172D+02
      W(9) = 0.748D+01
      W(10) = 0.302D+02
      W(11) = 0.411D+01
      W(12) = 0.144D+01
      W(13) = 0.244D+02
      W(14) = 0.284D+02
      W(15) = 0.154D+02
      W(16) = 0.764D+00
      W(17) = 0.661D+00
      W(18) = 0.284D+00
      W(19) = 0.588D+00
      W(20) = 0.366D+00
      W(21) = 0.169D+00
      W(22) = 0.388D+00
      W(23) = 0.190D+00
      W(24) = 0.877D-01
      W(25) = 0.413D-01
      W(26) = 0.289D+00
      W(27) = 0.119D+00
      W(28) = 0.177D+00
      W(29) = 0.246D+00
      W(30) = 0.319D-01
      Y(1) = 3.42947415189D0
      Y(2) = 3.35386959711D0
      Y(3) = 1.35494901715D0
      Y(4) = 6.64145542550D0
      Y(5) = 5.97156957878D0
      Y(6) = 2.18231499728D0
      Y(7) = 11.2630437207D0
      Y(8) = 14.6952576794D0
      Y(9) = 6.27960525067D0
      Y(10) = -30.1552268759D0
      Y(11) = 1.65699966404D0
      Y(12) = 1.43785752721D0
      Y(13) = -21.1238353380D0
      Y(14) = 28.4465098142D0
      Y(15) = 15.3882659679D0
      Y(16) = -.557160570446D0
      Y(17) = .505696783289D0
      Y(18) = .230578543901D0
      Y(19) = -.415570776342D0
      Y(20) = .365682722812D0
      Y(21) = .169143213293D0
      Y(22) = -.325325669158D0
      Y(23) = .189706021964D0
      Y(24) = .0877265322780D0
      Y(25) = -.0240476254170D0
      Y(26) = -.287659532608D0
      Y(27) = -.117219543175D0
      Y(28) = -.176860753121D0
      Y(29) = -.216393453025D0
      Y(30) = -.0148647893090D0
      GO TO 740
C     PROBLEM CLASS D
C     31:32:33:34:35:
  420 CONTINUE
CP    PROBLEM D1, D2, D3, D4, D5
      FCNTIM = 0.0
      E = .2D0*(DBLE(ID)-3.D1) - .1D0
      N = 4
      IF (ID.NE.31) GO TO 440
      W(1) = 0.110D+01
      W(2) = 0.995D+00
      W(3) = 0.101D+01
      W(4) = 0.111D+01
  440 IF (ID.NE.32) GO TO 460
      W(1) = 0.130D+01
      W(2) = 0.954D+00
      W(3) = 0.105D+01
      W(4) = 0.136D+01
  460 IF (ID.NE.33) GO TO 480
      W(1) = 0.150D+01
      W(2) = 0.866D+00
      W(3) = 0.115D+01
      W(4) = 0.173D+01
  480 IF (ID.NE.34) GO TO 500
      W(1) = 0.170D+01
      W(2) = 0.714D+00
      W(3) = 0.140D+01
      W(4) = 0.238D+01
  500 IF (ID.NE.35) GO TO 520
      W(1) = 0.190D+01
      W(2) = 0.436D+00
      W(3) = 0.229D+01
      W(4) = 0.436D+01
  520 CONTINUE
      Y(1) = 1.D0 - E
      Y(2) = 0.D0
      Y(3) = 0.D0
      Y(4) = DSQRT((1.D0+E)/(1.D0-E))
      GO TO 740
C     PROBLEM CLASS E
C     41:
  540 CONTINUE
CP    PROBLEM E1
      FCNTIM = 0.0
      N = 2
      W(1) = 0.679D+00
      W(2) = 0.478D+00
      E = .79788456080286536D0
      Y(1) = E*.84147098480789651D0
      Y(2) = E*.11956681346419146D0
      GO TO 740
C     42:
  560 CONTINUE
CP    PROBLEM E2
      FCNTIM = 0.0
      N = 2
      W(1) = 0.201D+01
      W(2) = 0.268D+01
      Y(1) = 2.D0
      Y(2) = 0.D0
      GO TO 740
C     43:
  580 CONTINUE
CP    PROBLEM E3
      FCNTIM = 0.0
      N = 2
      W(1) = 0.116D+01
      W(2) = 0.128D+01
      Y(1) = 0.D0
      Y(2) = 0.D0
      GO TO 740
C     44:
  600 CONTINUE
CP    PROBLEM E4
      FCNTIM = 0.0
      N = 2
      W(1) = 0.340D+02
      W(2) = 0.277D+00
      Y(1) = 3.D1
      Y(2) = 0.D0
      GO TO 740
C     45:
  620 CONTINUE
CP    PROBLEM E5
      FCNTIM = 0.0
      N = 2
      W(1) = 0.141D+02
      W(2) = 0.240D+01
      Y(1) = 0.D0
      Y(2) = 0.D0
      GO TO 740
C     PROBLEM CLASS F
C     51:
  640 CONTINUE
CP    PROBLEM F1
      FCNTIM = 0.0
      N = 2
      W(1) = 0.129D+02
      W(2) = 0.384D+02
      Y(1) = 0.D0
      Y(2) = 0.D0
      HMAX = 1.D0
      GO TO 740
C     52:
  660 CONTINUE
CP    PROBLEM F2
      FCNTIM = 0.0
      N = 1
      W(1) = 0.110D+03
      Y(1) = 110.D0
      HMAX = 1.D0
      GO TO 740
C     53:
  680 CONTINUE
CP    PROBLEM F3
      FCNTIM = 0.0
      N = 2
      W(1) = 0.131D+01
      W(2) = 0.737D+00
      Y(1) = 0.D0
      Y(2) = 0.D0
      HMAX = 1.D0
      HBEGIN = 0.9D0
      GO TO 740
C     54:
  700 CONTINUE
CP    PROBLEM F4
      FCNTIM = 0.0
      N = 1
      W(1) = 0.152D+01
      Y(1) = 1.D0
      HMAX = 10.D0
      GO TO 740
C     55:
  720 CONTINUE
CP    PROBLEM F5
      FCNTIM = 0.0
      N = 1
      W(1) = 0.100D+01
      Y(1) = 1.D0
      HMAX = 20.D0
  740 CONTINUE
      IF (IWT.LT.0.) GO TO 780
      DO 760 I = 1, N
         Y(I) = Y(I)/W(I)
  760 CONTINUE
  780 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     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     .. Scalar Arguments ..
      INTEGER          ID, IWT, N
C     .. Array Arguments ..
      DOUBLE PRECISION W(51), Y(51)
C     .. Local Scalars ..
      INTEGER          I
C     .. Executable Statements ..
      GO TO (20,40,60,80,100,620,620,620,620,
     *       620,120,140,160,180,200,620,620,620,
     *       620,620,220,240,260,280,300,620,620,
     *       620,620,620,320,340,360,380,400,620,
     *       620,620,620,620,420,440,460,480,500,
     *       620,620,620,620,620,520,540,560,580,
     *       600) ID
      GO TO 620
C     PROBLEM CLASS A
C     1:
C        PROBLEM A1
   20 Y(1) = 2.061153353012535D-09
      GO TO 620
C     2:
C        PROBLEM A2
   40 Y(1) = 2.182178902359887D-01
      GO TO 620
C     3:
C        PROBLEM A3
   60 Y(1) = 2.491650271850414D+00
      GO TO 620
C     4:
C        PROBLEM A4
   80 Y(1) = 1.773016648131483D+01
      GO TO 620
C     5:
C        PROBLEM A5
  100 Y(1) = -7.887826688964196D-01
      GO TO 620
C     PROBLEM CLASS B
C     11:
C        PROBLEM B1
  120 Y(1) = 6.761876008576667D-01
      Y(2) = 1.860816099640036D-01
      GO TO 620
C     12:
C        PROBLEM B2
  140 Y(1) = 1.000000001030576D+00
      Y(2) = 1.000000000000000D+00
      Y(3) = 9.999999989694235D-01
      GO TO 620
C     13:
C        PROBLEM B3
  160 Y(1) = 2.061153488557776D-09
      Y(2) = 5.257228022048349D-02
      Y(3) = 9.474277177183630D-01
      GO TO 620
C     14:
C        PROBLEM B4
  180 Y(1) = 9.826950928005993D-01
      Y(2) = 2.198447081694832D+00
      Y(3) = 9.129452507276399D-01
      GO TO 620
C     15:
C        PROBLEM B5
  200 Y(1) = -9.396570798729192D-01
      Y(2) = -3.421177754000779D-01
      Y(3) = 7.414126596199957D-01
      GO TO 620
C     PROBLEM CLASS C
C     21:
C        PROBLEM C1
  220 Y(1) = 2.061153622240064D-09
      Y(2) = 4.122307244619555D-08
      Y(3) = 4.122307244716968D-07
      Y(4) = 2.748204829855288D-06
      Y(5) = 1.374102414941961D-05
      Y(6) = 5.496409659803266D-05
      Y(7) = 1.832136553274552D-04
      Y(8) = 5.234675866508716D-04
      Y(9) = 1.308668966628220D-03
      Y(10) = 9.979127409508656D-01
      GO TO 620
C     22:
C        PROBLEM C2
  240 Y(1) = 2.061153577984930D-09
      Y(2) = 2.061153573736588D-09
      Y(3) = 2.061153569488245D-09
      Y(4) = 2.061153565239902D-09
      Y(5) = 2.061153560991560D-09
      Y(6) = 2.061153556743217D-09
      Y(7) = 2.061153552494874D-09
      Y(8) = 2.061153548246532D-09
      Y(9) = 2.061153543998189D-09
      Y(10) = 9.999999814496180D-01
      GO TO 620
C     23:
C        PROBLEM C3
  260 Y(1) = 2.948119211022058D-03
      Y(2) = 5.635380154844266D-03
      Y(3) = 7.829072515926013D-03
      Y(4) = 9.348257908594937D-03
      Y(5) = 1.007943610301970D-02
      Y(6) = 9.982674171429909D-03
      Y(7) = 9.088693332766085D-03
      Y(8) = 7.489115195185912D-03
      Y(9) = 5.322964130953349D-03
      Y(10) = 2.762434379029886D-03
      GO TO 620
C     24:
C        PROBLEM C4
  280 Y(1) = 3.124111453721466D-03
      Y(2) = 6.015416842150318D-03
      Y(3) = 8.470021834842650D-03
      Y(4) = 1.033682931733337D-02
      Y(5) = 1.153249572873923D-02
      Y(6) = 1.204549525737964D-02
      Y(7) = 1.192957068015293D-02
      Y(8) = 1.128883207111195D-02
      Y(9) = 1.025804501391024D-02
      Y(10) = 8.982017581934167D-03
      Y(11) = 7.597500902492453D-03
      Y(12) = 6.219920556824985D-03
      Y(13) = 4.935916341009131D-03
      Y(14) = 3.801432544256119D-03
      Y(15) = 2.844213677587894D-03
      Y(16) = 2.069123394222672D-03
      Y(17) = 1.464687282843915D-03
      Y(18) = 1.009545263941126D-03
      Y(19) = 6.779354330227017D-04
      Y(20) = 4.437815269118510D-04
      Y(21) = 2.833264542938954D-04
      Y(22) = 1.765005798796805D-04
      Y(23) = 1.073342592697238D-04
      Y(24) = 6.374497601777217D-05
      Y(25) = 3.698645309704183D-05
      Y(26) = 2.097466832643746D-05
      Y(27) = 1.162956710412555D-05
      Y(28) = 6.306710405783322D-06
      Y(29) = 3.346286430868515D-06
      Y(30) = 1.737760074184334D-06
      Y(31) = 8.835366904275847D-07
      Y(32) = 4.399520411127637D-07
      Y(33) = 2.146181897152360D-07
      Y(34) = 1.025981211654928D-07
      Y(35) = 4.807864068784215D-08
      Y(36) = 2.209175152474847D-08
      Y(37) = 9.956251263138180D-09
      Y(38) = 4.402193653748924D-09
      Y(39) = 1.910149382204028D-09
      Y(40) = 8.135892921473050D-10
      Y(41) = 3.402477118549235D-10
      Y(42) = 1.397485617545782D-10
      Y(43) = 5.638575303049199D-11
      Y(44) = 2.235459707956947D-11
      Y(45) = 8.710498036398032D-12
      Y(46) = 3.336554275346643D-12
      Y(47) = 1.256679567784939D-12
      Y(48) = 4.654359053128788D-13
      Y(49) = 1.693559145599857D-13
      Y(50) = 5.996593816663054D-14
      Y(51) = 1.891330702629865D-14
      GO TO 620
C     25:
C        PROBLEM C5
  300 Y(1) = -4.792730224323733D+00
      Y(2) = -2.420550725448973D+00
      Y(3) = -9.212509306014886D-01
      Y(4) = -4.217310404035213D+00
      Y(5) = 7.356202947498970D+00
      Y(6) = 3.223785985421212D+00
      Y(7) = 4.035559443262270D+00
      Y(8) = 1.719865528670555D+01
      Y(9) = 7.478910794233703D+00
      Y(10) = -2.998759326324844D+01
      Y(11) = -4.107310937550929D+00
      Y(12) = -9.277008321754407D-01
      Y(13) = -2.442125302518482D+01
      Y(14) = 2.381459045746554D+01
      Y(15) = 1.492096306951359D+01
      Y(16) = 3.499208963063806D-01
      Y(17) = -5.748487687912825D-01
      Y(18) = -2.551694020879149D-01
      Y(19) = -5.237040978903326D-01
      Y(20) = -2.493000463579661D-01
      Y(21) = -8.045341642044464D-02
      Y(22) = -3.875289237334110D-01
      Y(23) = 5.648603288767891D-02
      Y(24) = 3.023606472143342D-02
      Y(25) = 4.133856546712445D-02
      Y(26) = -2.862393029841379D-01
      Y(27) = -1.183032405136207D-01
      Y(28) = -1.511986457359206D-01
      Y(29) = -2.460068894318766D-01
      Y(30) = -3.189687411323877D-02
      GO TO 620
C     PROBLEM CLASS D
C     31:
C        PROBLEM D1
  320 Y(1) = 2.198835352008397D-01
      Y(2) = 9.427076846341813D-01
      Y(3) = -9.787659841058176D-01
      Y(4) = 3.287977990962036D-01
      GO TO 620
C     32:
C        PROBLEM D2
  340 Y(1) = -1.777027357140412D-01
      Y(2) = 9.467784719905892D-01
      Y(3) = -1.030294163192969D+00
      Y(4) = 1.211074890053952D-01
      GO TO 620
C     33:
C        PROBLEM D3
  360 Y(1) = -5.780432953035361D-01
      Y(2) = 8.633840009194193D-01
      Y(3) = -9.595083730380727D-01
      Y(4) = -6.504915126712089D-02
      GO TO 620
C     34:
C        PROBLEM D4
  380 Y(1) = -9.538990293416394D-01
      Y(2) = 6.907409024219432D-01
      Y(3) = -8.212674270877433D-01
      Y(4) = -1.539574259125825D-01
      GO TO 620
C     35:
C        PROBLEM D5
  400 Y(1) = -1.295266250987574D+00
      Y(2) = 4.003938963792321D-01
      Y(3) = -6.775390924707566D-01
      Y(4) = -1.270838154278686D-01
      GO TO 620
C     PROBLEM CLASS E
C     41:
C        PROBLEM E1
  420 Y(1) = 1.456723600728308D-01
      Y(2) = -9.883500195574063D-02
      GO TO 620
C     42:
C        PROBLEM E2
  440 Y(1) = 2.008149762174948D+00
      Y(2) = -4.250887527320057D-02
      GO TO 620
C     43:
C        PROBLEM E3
  460 Y(1) = -1.004178858647128D-01
      Y(2) = 2.411400132095954D-01
      GO TO 620
C     44:
C        PROBLEM E4
  480 Y(1) = 3.395091444646555D+01
      Y(2) = 2.767822659672869D-01
      GO TO 620
C     45:
C        PROBLEM E5
  500 Y(1) = 1.411797390542629D+01
      Y(2) = 2.400000000000002D+00
      GO TO 620
C     PROBLEM CLASS F
C     51:
C        PROBLEM F1
  520 Y(1) = -1.294460621213470D1
      Y(2) = -2.208575158908672D-15
      GO TO 620
C     52:
C        PROBLEM F2
  540 Y(1) = 70.03731057008607D0
      GO TO 620
C     53:
C        PROBLEM F3
  560 Y(1) = -3.726957553088175D-1
      Y(2) = -6.230137949234190D-1
      GO TO 620
C     54:
C        PROBLEM F4
  580 Y(1) = 9.815017249707434D-11
      GO TO 620
C     55:
C        PROBLEM F5
  600 Y(1) = 1.D0
  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
C     .. Scalar Arguments ..
      DOUBLE PRECISION X
C     .. Array Arguments ..
      DOUBLE PRECISION Y(51), YP(51)
C     .. Scalars in Common ..
      INTEGER        ID, IWT, N, NFCN
C     .. Arrays in Common ..
      DOUBLE PRECISION W(51)
C     .. Local Scalars ..
      DOUBLE PRECISION C1, C2, D, EX, K2, M0, P, TEMP
      INTEGER        I, I3, I3M2, ITEMP, J, L, LL, MM
C     .. Local Arrays ..
      DOUBLE PRECISION M(5), Q(5,5), R(5), YTEMP(51)
C     .. Intrinsic Functions ..
      INTRINSIC      DABS, DBLE, DCOS, DSIGN, DSIN, DSQRT, IDINT
C     .. Common blocks ..
      COMMON         /NSCOM5/W, IWT, N, ID
      COMMON         /NSCOM6/NFCN
C     .. Data statements ..
C     THE FOLLOWING DATA IS FOR PROBLEM C5 AND DEFINES THE MASSES
C     OF THE 5 OUTER PLANETS ETC. IN SOLAR UNITS.
C     K2 IS THE GRAVITATIONAL CONSTANT.
C     THE NEXT DATA IS FOR PROBLEMS F1 AND F5.
C     C1 IS PI**2 + 0.1**2 AND C2 IS SUM I**(4/3) FOR I=1 TO 19.
      DATA           M0/1.00000597682D0/, M/.954786104043D-3,
     *               .285583733151D-3, .437273164546D-4,
     *               .517759138449D-4, .277777777778D-5/
      DATA           K2/2.95912208286D0/
      DATA           EX, C1, C2/.33333333333333333D0,
     *               9.879604401089358D0, 438.4461015267790D0/
C     .. Executable Statements ..
C5
C6
CE
      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
      GO TO (60,80,100,120,140,860,860,860,860,
     *       860,160,180,200,220,240,860,860,860,
     *       860,860,260,300,340,380,420,860,860,
     *       860,860,860,580,580,580,580,580,860,
     *       860,860,860,860,600,620,640,660,680,
     *       860,860,860,860,860,700,740,780,800,
     *       840) ID
      GO TO 860
C     PROBLEM CLASS A
C     1:
C        PROBLEM A1
   60 YP(1) = -Y(1)
      GO TO 860
C     2:
C        PROBLEM A2
   80 YP(1) = -.5D0*Y(1)*Y(1)*Y(1)
      GO TO 860
C     3:
C        PROBLEM A3
  100 YP(1) = Y(1)*DCOS(X)
      GO TO 860
C     4:
C        PROBLEM A4
  120 YP(1) = (1.D0-Y(1)/20.D0)*Y(1)/4.D0
      GO TO 860
C     5:
C        PROBLEM A5
  140 YP(1) = (Y(1)-X)/(Y(1)+X)
      GO TO 860
C     PROBLEM CLASS B
C     11:
C        PROBLEM B1
  160 D = Y(1) - Y(1)*Y(2)
      YP(1) = D + D
      YP(2) = -(Y(2)-Y(1)*Y(2))
      GO TO 860
C     12:
C        PROBLEM B2
  180 YP(1) = -Y(1) + Y(2)
      YP(3) = Y(2) - Y(3)
      YP(2) = -YP(1) - YP(3)
      GO TO 860
C     13:
C        PROBLEM B3
  200 D = Y(2)*Y(2)
      YP(1) = -Y(1)
      YP(2) = Y(1) - D
      YP(3) = D
      GO TO 860
C     14:
C        PROBLEM B4
  220 D = DSQRT(Y(1)*Y(1)+Y(2)*Y(2))
      YP(1) = -Y(2) - Y(1)*Y(3)/D
      YP(2) = Y(1) - Y(2)*Y(3)/D
      YP(3) = Y(1)/D
      GO TO 860
C     15:
C        PROBLEM B5
  240 YP(1) = Y(2)*Y(3)
      YP(2) = -Y(1)*Y(3)
      YP(3) = -.51D0*Y(1)*Y(2)
      GO TO 860
C     PROBLEM CLASS C
C     21:
C        PROBLEM C1
  260 YP(1) = -Y(1)
      DO 280 I = 2, 9
         YP(I) = Y(I-1) - Y(I)
  280 CONTINUE
      YP(10) = Y(9)
      GO TO 860
C     22:
C        PROBLEM C2
  300 YP(1) = -Y(1)
      DO 320 I = 2, 9
         YP(I) = DBLE(I-1)*Y(I-1) - DBLE(I)*Y(I)
  320 CONTINUE
      YP(10) = 9.0D0*Y(9)
      GO TO 860
C     23:
C        PROBLEM C3
  340 YP(1) = -2.D0*Y(1) + Y(2)
      DO 360 I = 2, 9
         YP(I) = Y(I-1) - 2.D0*Y(I) + Y(I+1)
  360 CONTINUE
      YP(10) = Y(9) - 2.D0*Y(10)
      GO TO 860
C     24:
C        PROBLEM C4
  380 YP(1) = -2.D0*Y(1) + Y(2)
      DO 400 I = 2, 50
         YP(I) = Y(I-1) - 2.D0*Y(I) + Y(I+1)
  400 CONTINUE
      YP(51) = Y(50) - 2.D0*Y(51)
      GO TO 860
C     25:
C        PROBLEM C5
  420 I = 0
      DO 500 L = 3, 15, 3
         I = I + 1
         P = Y(L-2)**2 + Y(L-1)**2 + Y(L)**2
         R(I) = 1.D0/(P*DSQRT(P))
         J = 0
         DO 480 LL = 3, 15, 3
            J = J + 1
            IF (LL.NE.L) GO TO 440
            GO TO 460
C              THEN
  440       P = (Y(L-2)-Y(LL-2))**2 + (Y(L-1)-Y(LL-1))**2 + (Y(L)-Y(LL))
     *          **2
            Q(I,J) = 1.D0/(P*DSQRT(P))
            Q(J,I) = Q(I,J)
  460       CONTINUE
  480    CONTINUE
  500 CONTINUE
      I3 = 0
      DO 560 I = 1, 5
         I3 = I3 + 3
         I3M2 = I3 - 2
         DO 540 LL = I3M2, I3
            MM = LL - I3
            YP(LL) = Y(LL+15)
            P = 0.D0
            DO 520 J = 1, 5
               MM = MM + 3
               IF (J.NE.I) P = P + M(J)*(Y(MM)*(Q(I,J)-R(J))-Y(LL)
     *                         *Q(I,J))
  520       CONTINUE
            YP(LL+15) = K2*(-(M0+M(I))*Y(LL)*R(I)+P)
  540    CONTINUE
  560 CONTINUE
      GO TO 860
C     PROBLEM CLASS D
C     31:32:33:34:35:
C        PROBLEMS D1, D2, D3, D4, D5
  580 YP(1) = Y(3)
      YP(2) = Y(4)
      D = Y(1)*Y(1) + Y(2)*Y(2)
      D = DSQRT(D*D*D)
      YP(3) = -Y(1)/D
      YP(4) = -Y(2)/D
      GO TO 860
C     PROBLEM CLASS E
C     41:
C        PROBLEM E1
  600 YP(1) = Y(2)
      YP(2) = -(Y(2)/(X+1.D0)+(1.D0-.25D0/(X+1.D0)**2)*Y(1))
      GO TO 860
C     42:
C        PROBLEM E2
  620 YP(1) = Y(2)
      YP(2) = (1.D0-Y(1)*Y(1))*Y(2) - Y(1)
      GO TO 860
C     43:
C        PROBLEM E3
  640 YP(1) = Y(2)
      YP(2) = Y(1)**3/6.D0 - Y(1) + 2.D0*DSIN(2.78535D0*X)
      GO TO 860
C     44:
C        PROBLEM E4
  660 YP(1) = Y(2)
      YP(2) = .032D0 - .4D0*Y(2)*Y(2)
      GO TO 860
C     45:
C        PROBLEM E5
  680 YP(1) = Y(2)
      YP(2) = DSQRT(1.D0+Y(2)*Y(2))/(25.D0-X)
      GO TO 860
C     PROBLEM CLASS F
C     51:
C        PROBLEM F1
  700 YP(1) = Y(2)
      YP(2) = .2D0*Y(2) - C1*Y(1)
      ITEMP = IDINT(X)
      IF ((ITEMP/2)*2.EQ.ITEMP) GO TO 720
      YP(2) = YP(2) - 1.D0
      GO TO 860
  720 YP(2) = YP(2) + 1.D0
      GO TO 860
C     52:
C        PROBLEM F2
  740 ITEMP = IDINT(X)
      IF ((ITEMP/2)*2.EQ.ITEMP) GO TO 760
      YP(1) = 55.D0 - .5D0*Y(1)
      GO TO 860
  760 YP(1) = 55.D0 - 1.5D0*Y(1)
      GO TO 860
C     53:
C        PROBLEM F3
  780 YP(1) = Y(2)
      YP(2) = .01D0*Y(2)*(1.D0-Y(1)**2) - Y(1) -
     *        DABS(DSIN(3.1415926535897932D0*X))
      GO TO 860
C     54:
C        PROBLEM F4
  800 IF (X.GT.10.D0) GO TO 820
      TEMP = X - 5.D0
      YP(1) = -2.D0/21.D0 - 120.D0*TEMP/(1.D0+4.D0*TEMP**2)**16
      GO TO 860
  820 YP(1) = -2.D0*Y(1)
      GO TO 860
C     55:
C        PROBLEM F5
  840 YP(1) = Y(1)*(4.D0/(3.D0*C2))*(DSIGN(DABS(X-1.D0)**EX,X-1.D0)
     *        +DSIGN(DABS(X-2.D0)**EX,X-2.D0)+DSIGN(DABS(X-3.D0)
     *        **EX,X-3.D0)+DSIGN(DABS(X-4.D0)**EX,X-4.D0)
     *        +DSIGN(DABS(X-5.D0)**EX,X-5.D0)+DSIGN(DABS(X-6.D0)
     *        **EX,X-6.D0)+DSIGN(DABS(X-7.D0)**EX,X-7.D0)
     *        +DSIGN(DABS(X-8.D0)**EX,X-8.D0)+DSIGN(DABS(X-9.D0)
     *        **EX,X-9.D0)+DSIGN(DABS(X-10.D0)**EX,X-10.D0)
     *        +DSIGN(DABS(X-11.D0)**EX,X-11.D0)+DSIGN(DABS(X-12.D0)
     *        **EX,X-12.D0)+DSIGN(DABS(X-13.D0)**EX,X-13.D0)
     *        +DSIGN(DABS(X-14.D0)**EX,X-14.D0)+DSIGN(DABS(X-15.D0)
     *        **EX,X-15.D0)+DSIGN(DABS(X-16.D0)**EX,X-16.D0)
     *        +DSIGN(DABS(X-17.D0)**EX,X-17.D0)+DSIGN(DABS(X-18.D0)
     *        **EX,X-18.D0)+DSIGN(DABS(X-19.D0)**EX,X-19.D0))
  860 CONTINUE
      IF (IWT.LT.0) GO TO 900
      DO 880 I = 1, N
         YP(I) = YP(I)/W(I)
         Y(I) = YTEMP(I)
  880 CONTINUE
  900 CONTINUE
      RETURN
      END
      SUBROUTINE IVALU(N,XSTART,XEND,HBEGIN,HMAX,Y,FCNTIM,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      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
      INTEGER          ID, IWT, N
C     .. Array Arguments ..
      REAL             W(51), Y(51)
C     .. Local Scalars ..
      REAL             E, HB, HM, XE, XS
      INTEGER          I, IOUT
C     .. External Functions ..
      REAL             CONST
      EXTERNAL         CONST
C     .. Intrinsic Functions ..
      INTRINSIC        REAL, SQRT
C     .. Data statements ..
      DATA             HM, HB, XS, XE/20., 1., 0., 20./
C     .. Executable Statements ..
      HMAX = HM
      HBEGIN = HB
      XSTART = XS
      XEND = XE
      GO TO (40,60,80,100,120,20,20,20,20,
     *       20,140,160,180,200,220,20,20,20,
     *       20,20,240,280,320,360,400,20,20,
     *       20,20,20,420,420,420,420,420,20,
     *       20,20,20,20,540,560,580,600,620,
     *       20,20,20,20,20,640,660,680,700,
     *       720) ID
   20 IOUT = CONST(3)
      WRITE (IOUT,FMT=99999) ID
      STOP
C
C     PROBLEM CLASS A
C     1:
   40 CONTINUE
CP    PROBLEM A1
      FCNTIM = 0.0
      N = 1
      W(1) = 0.100E+01
      Y(1) = 1.
      GO TO 740
C     2:
   60 CONTINUE
CP    PROBLEM A2
      FCNTIM = 0.0
      N = 1
      W(1) = 0.100E+01
      Y(1) = 1.
      GO TO 740
C     3:
   80 CONTINUE
CP    PROBLEM A3
      FCNTIM = 0.0
      N = 1
      W(1) = 0.271E+01
      Y(1) = 1.
      GO TO 740
C     4:
  100 CONTINUE
CP    PROBLEM A4
      FCNTIM = 0.0
      N = 1
      W(1) = 0.177E+02
      Y(1) = 1.
      GO TO 740
C     5:
  120 CONTINUE
CP    PROBLEM A5
      FCNTIM = 0.0
      N = 1
      W(1) = 0.620E+01
      Y(1) = 4.
      GO TO 740
C     PROBLEM CLASS B
C     11:
  140 CONTINUE
CP    PROBLEM B1
      FCNTIM = 0.0
      N = 2
      W(1) = 0.425E+01
      W(2) = 0.300E+01
      Y(1) = 1.
      Y(2) = 3.
      GO TO 740
C     12:
  160 CONTINUE
CP    PROBLEM B2
      FCNTIM = 0.0
      N = 3
      W(1) = 0.200E+01
      W(2) = 0.100E+01
      W(3) = 0.100E+01
      Y(1) = 2.
      Y(2) = 0.
      Y(3) = 1.
      GO TO 740
C     13:
  180 CONTINUE
CP    PROBLEM B3
      FCNTIM = 0.0
      N = 3
      W(1) = 0.100E+01
      W(2) = 0.519E+00
      W(3) = 0.947E+00
      Y(1) = 1.
      Y(2) = 0.
      Y(3) = 0.
      GO TO 740
C     14:
  200 CONTINUE
CP    PROBLEM B4
      FCNTIM = 0.0
      N = 3
      W(1) = 0.300E+01
      W(2) = 0.220E+01
      W(3) = 0.100E+01
      Y(1) = 3.
      Y(2) = 0.
      Y(3) = 0.
      GO TO 740
C     15:
  220 CONTINUE
CP    PROBLEM B5
      FCNTIM = 0.0
      N = 3
      W(1) = 0.100E+01
      W(2) = 0.100E+01
      W(3) = 0.100E+01
      Y(1) = 0.
      Y(2) = 1.
      Y(3) = 1.
      GO TO 740
C     PROBLEM CLASS C
C     21:
  240 CONTINUE
CP    PROBLEM C1
      FCNTIM = 0.0
      N = 10
      W(1) = 0.100E+01
      W(2) = 0.368E+00
      W(3) = 0.271E+00
      W(4) = 0.224E+00
      W(5) = 0.195E+00
      W(6) = 0.175E+00
      W(7) = 0.161E+00
      W(8) = 0.149E+00
      W(9) = 0.139E+00
      W(10) = 0.998E+00
      Y(1) = 1.
      DO 260 I = 2, N
         Y(I) = 0.
  260 CONTINUE
      GO TO 740
C     22:
  280 CONTINUE
CP    PROBLEM C2
      FCNTIM = 0.0
      N = 10
      W(1) = 0.100E+01
      W(2) = 0.250E+00
      W(3) = 0.148E+00
      W(4) = 0.105E+00
      W(5) = 0.818E-01
      W(6) = 0.669E-01
      W(7) = 0.566E-01
      W(8) = 0.491E-01
      W(9) = 0.433E-01
      W(10) = 0.100E+01
      Y(1) = 1.
      DO 300 I = 2, N
         Y(I) = 0.
  300 CONTINUE
      GO TO 740
C     23:
  320 CONTINUE
CP    PROBLEM C3
      FCNTIM = 0.0
      N = 10
      W(1) = 0.100E+01
      W(2) = 0.204E+00
      W(3) = 0.955E-01
      W(4) = 0.553E-01
      W(5) = 0.359E-01
      W(6) = 0.252E-01
      W(7) = 0.184E-01
      W(8) = 0.133E-01
      W(9) = 0.874E-02
      W(10) = 0.435E-02
      Y(1) = 1.
      DO 340 I = 2, N
         Y(I) = 0.
  340 CONTINUE
      GO TO 740
C     24:
  360 CONTINUE
CP    PROBLEM C4
      FCNTIM = 0.0
      N = 51
      W(1) = 0.100E+01
      W(2) = 0.204E+00
      W(3) = 0.955E-01
      W(4) = 0.553E-01
      W(5) = 0.359E-01
      W(6) = 0.252E-01
      W(7) = 0.186E-01
      W(8) = 0.143E-01
      W(9) = 0.113E-01
      W(10) = 0.918E-02
      W(11) = 0.760E-02
      W(12) = 0.622E-02
      W(13) = 0.494E-02
      W(14) = 0.380E-02
      W(15) = 0.284E-02
      W(16) = 0.207E-02
      W(17) = 0.146E-02
      W(18) = 0.101E-02
      W(19) = 0.678E-03
      W(20) = 0.444E-03
      W(21) = 0.283E-03
      W(22) = 0.177E-03
      W(23) = 0.107E-03
      W(24) = 0.637E-04
      W(25) = 0.370E-04
      W(26) = 0.210E-04
      W(27) = 0.116E-04
      W(28) = 0.631E-05
      W(29) = 0.335E-05
      W(30) = 0.174E-05
      W(31) = 0.884E-06
      W(32) = 0.440E-06
      W(33) = 0.215E-06
      W(34) = 0.103E-06
      W(35) = 0.481E-07
      W(36) = 0.221E-07
      W(37) = 0.996E-08
      W(38) = 0.440E-08
      W(39) = 0.191E-08
      W(40) = 0.814E-09
      W(41) = 0.340E-09
      W(42) = 0.140E-09
      W(43) = 0.564E-10
      W(44) = 0.224E-10
      W(45) = 0.871E-11
      W(46) = 0.334E-11
      W(47) = 0.126E-11
      W(48) = 0.465E-12
      W(49) = 0.169E-12
      W(50) = 0.600E-13
      W(51) = 0.189E-13
      Y(1) = 1.
      DO 380 I = 2, N
         Y(I) = 0.
  380 CONTINUE
      GO TO 740
C     25:
  400 CONTINUE
CP    PROBLEM C5
      FCNTIM = 0.0
      N = 30
      W(1) = 0.545E+01
      W(2) = 0.471E+01
      W(3) = 0.203E+01
      W(4) = 0.664E+01
      W(5) = 0.834E+01
      W(6) = 0.346E+01
      W(7) = 0.113E+02
      W(8) = 0.172E+02
      W(9) = 0.748E+01
      W(10) = 0.302E+02
      W(11) = 0.411E+01
      W(12) = 0.144E+01
      W(13) = 0.244E+02
      W(14) = 0.284E+02
      W(15) = 0.154E+02
      W(16) = 0.764E+00
      W(17) = 0.661E+00
      W(18) = 0.284E+00
      W(19) = 0.588E+00
      W(20) = 0.366E+00
      W(21) = 0.169E+00
      W(22) = 0.388E+00
      W(23) = 0.190E+00
      W(24) = 0.877E-01
      W(25) = 0.413E-01
      W(26) = 0.289E+00
      W(27) = 0.119E+00
      W(28) = 0.177E+00
      W(29) = 0.246E+00
      W(30) = 0.319E-01
      Y(1) = 3.42947415189
      Y(2) = 3.35386959711
      Y(3) = 1.35494901715
      Y(4) = 6.64145542550
      Y(5) = 5.97156957878
      Y(6) = 2.18231499728
      Y(7) = 11.2630437207
      Y(8) = 14.6952576794
      Y(9) = 6.27960525067
      Y(10) = -30.1552268759
      Y(11) = 1.65699966404
      Y(12) = 1.43785752721
      Y(13) = -21.1238353380
      Y(14) = 28.4465098142
      Y(15) = 15.3882659679
      Y(16) = -.557160570446
      Y(17) = .505696783289
      Y(18) = .230578543901
      Y(19) = -.415570776342
      Y(20) = .365682722812
      Y(21) = .169143213293
      Y(22) = -.325325669158
      Y(23) = .189706021964
      Y(24) = .0877265322780
      Y(25) = -.0240476254170
      Y(26) = -.287659532608
      Y(27) = -.117219543175
      Y(28) = -.176860753121
      Y(29) = -.216393453025
      Y(30) = -.0148647893090
      GO TO 740
C     PROBLEM CLASS D
C     31:32:33:34:35:
  420 CONTINUE
CP    PROBLEM D1, D2, D3, D4, D5
      FCNTIM = 0.0
      E = .2*(REAL(ID)-3.E1) - .1
      N = 4
      IF (ID.NE.31) GO TO 440
      W(1) = 0.110E+01
      W(2) = 0.995E+00
      W(3) = 0.101E+01
      W(4) = 0.111E+01
  440 IF (ID.NE.32) GO TO 460
      W(1) = 0.130E+01
      W(2) = 0.954E+00
      W(3) = 0.105E+01
      W(4) = 0.136E+01
  460 IF (ID.NE.33) GO TO 480
      W(1) = 0.150E+01
      W(2) = 0.866E+00
      W(3) = 0.115E+01
      W(4) = 0.173E+01
  480 IF (ID.NE.34) GO TO 500
      W(1) = 0.170E+01
      W(2) = 0.714E+00
      W(3) = 0.140E+01
      W(4) = 0.238E+01
  500 IF (ID.NE.35) GO TO 520
      W(1) = 0.190E+01
      W(2) = 0.436E+00
      W(3) = 0.229E+01
      W(4) = 0.436E+01
  520 CONTINUE
      Y(1) = 1. - E
      Y(2) = 0.
      Y(3) = 0.
      Y(4) = SQRT((1.+E)/(1.-E))
      GO TO 740
C     PROBLEM CLASS E
C     41:
  540 CONTINUE
CP    PROBLEM E1
      FCNTIM = 0.0
      N = 2
      W(1) = 0.679E+00
      W(2) = 0.478E+00
      E = .79788456080286536
      Y(1) = E*.84147098480789651
      Y(2) = E*.11956681346419146
      GO TO 740
C     42:
  560 CONTINUE
CP    PROBLEM E2
      FCNTIM = 0.0
      N = 2
      W(1) = 0.201E+01
      W(2) = 0.268E+01
      Y(1) = 2.
      Y(2) = 0.
      GO TO 740
C     43:
  580 CONTINUE
CP    PROBLEM E3
      FCNTIM = 0.0
      N = 2
      W(1) = 0.116E+01
      W(2) = 0.128E+01
      Y(1) = 0.
      Y(2) = 0.
      GO TO 740
C     44:
  600 CONTINUE
CP    PROBLEM E4
      FCNTIM = 0.0
      N = 2
      W(1) = 0.340E+02
      W(2) = 0.277E+00
      Y(1) = 3.E1
      Y(2) = 0.
      GO TO 740
C     45:
  620 CONTINUE
CP    PROBLEM E5
      FCNTIM = 0.0
      N = 2
      W(1) = 0.141E+02
      W(2) = 0.240E+01
      Y(1) = 0.
      Y(2) = 0.
      GO TO 740
C     PROBLEM CLASS F
C     51:
  640 CONTINUE
CP    PROBLEM F1
      FCNTIM = 0.0
      N = 2
      W(1) = 0.129E+02
      W(2) = 0.384E+02
      Y(1) = 0.
      Y(2) = 0.
      HMAX = 1.
      GO TO 740
C     52:
  660 CONTINUE
CP    PROBLEM F2
      FCNTIM = 0.0
      N = 1
      W(1) = 0.110E+03
      Y(1) = 110.
      HMAX = 1.
      GO TO 740
C     53:
  680 CONTINUE
CP    PROBLEM F3
      FCNTIM = 0.0
      N = 2
      W(1) = 0.131E+01
      W(2) = 0.737E+00
      Y(1) = 0.
      Y(2) = 0.
      HMAX = 1.
      HBEGIN = 0.9
      GO TO 740
C     54:
  700 CONTINUE
CP    PROBLEM F4
      FCNTIM = 0.0
      N = 1
      W(1) = 0.152E+01
      Y(1) = 1.
      HMAX = 10.
      GO TO 740
C     55:
  720 CONTINUE
CP    PROBLEM F5
      FCNTIM = 0.0
      N = 1
      W(1) = 0.100E+01
      Y(1) = 1.
      HMAX = 20.
  740 CONTINUE
      IF (IWT.LT.0.) GO TO 780
      DO 760 I = 1, N
         Y(I) = Y(I)/W(I)
  760 CONTINUE
  780 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     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     .. Scalar Arguments ..
      INTEGER          ID, IWT, N
C     .. Array Arguments ..
      REAL             W(51), Y(51)
C     .. Local Scalars ..
      INTEGER          I
C     .. Executable Statements ..
      GO TO (20,40,60,80,100,620,620,620,620,
     *       620,120,140,160,180,200,620,620,620,
     *       620,620,220,240,260,280,300,620,620,
     *       620,620,620,320,340,360,380,400,620,
     *       620,620,620,620,420,440,460,480,500,
     *       620,620,620,620,620,520,540,560,580,
     *       600) ID
      GO TO 620
C     PROBLEM CLASS A
C     1:
C        PROBLEM A1
   20 Y(1) = 2.061153353012535E-09
      GO TO 620
C     2:
C        PROBLEM A2
   40 Y(1) = 2.182178902359887E-01
      GO TO 620
C     3:
C        PROBLEM A3
   60 Y(1) = 2.491650271850414E+00
      GO TO 620
C     4:
C        PROBLEM A4
   80 Y(1) = 1.773016648131483E+01
      GO TO 620
C     5:
C        PROBLEM A5
  100 Y(1) = -7.887826688964196E-01
      GO TO 620
C     PROBLEM CLASS B
C     11:
C        PROBLEM B1
  120 Y(1) = 6.761876008576667E-01
      Y(2) = 1.860816099640036E-01
      GO TO 620
C     12:
C        PROBLEM B2
  140 Y(1) = 1.000000001030576E+00
      Y(2) = 1.000000000000000E+00
      Y(3) = 9.999999989694235E-01
      GO TO 620
C     13:
C        PROBLEM B3
  160 Y(1) = 2.061153488557776E-09
      Y(2) = 5.257228022048349E-02
      Y(3) = 9.474277177183630E-01
      GO TO 620
C     14:
C        PROBLEM B4
  180 Y(1) = 9.826950928005993E-01
      Y(2) = 2.198447081694832E+00
      Y(3) = 9.129452507276399E-01
      GO TO 620
C     15:
C        PROBLEM B5
  200 Y(1) = -9.396570798729192E-01
      Y(2) = -3.421177754000779E-01
      Y(3) = 7.414126596199957E-01
      GO TO 620
C     PROBLEM CLASS C
C     21:
C        PROBLEM C1
  220 Y(1) = 2.061153622240064E-09
      Y(2) = 4.122307244619555E-08
      Y(3) = 4.122307244716968E-07
      Y(4) = 2.748204829855288E-06
      Y(5) = 1.374102414941961E-05
      Y(6) = 5.496409659803266E-05
      Y(7) = 1.832136553274552E-04
      Y(8) = 5.234675866508716E-04
      Y(9) = 1.308668966628220E-03
      Y(10) = 9.979127409508656E-01
      GO TO 620
C     22:
C        PROBLEM C2
  240 Y(1) = 2.061153577984930E-09
      Y(2) = 2.061153573736588E-09
      Y(3) = 2.061153569488245E-09
      Y(4) = 2.061153565239902E-09
      Y(5) = 2.061153560991560E-09
      Y(6) = 2.061153556743217E-09
      Y(7) = 2.061153552494874E-09
      Y(8) = 2.061153548246532E-09
      Y(9) = 2.061153543998189E-09
      Y(10) = 9.999999814496180E-01
      GO TO 620
C     23:
C        PROBLEM C3
  260 Y(1) = 2.948119211022058E-03
      Y(2) = 5.635380154844266E-03
      Y(3) = 7.829072515926013E-03
      Y(4) = 9.348257908594937E-03
      Y(5) = 1.007943610301970E-02
      Y(6) = 9.982674171429909E-03
      Y(7) = 9.088693332766085E-03
      Y(8) = 7.489115195185912E-03
      Y(9) = 5.322964130953349E-03
      Y(10) = 2.762434379029886E-03
      GO TO 620
C     24:
C        PROBLEM C4
  280 Y(1) = 3.124111453721466E-03
      Y(2) = 6.015416842150318E-03
      Y(3) = 8.470021834842650E-03
      Y(4) = 1.033682931733337E-02
      Y(5) = 1.153249572873923E-02
      Y(6) = 1.204549525737964E-02
      Y(7) = 1.192957068015293E-02
      Y(8) = 1.128883207111195E-02
      Y(9) = 1.025804501391024E-02
      Y(10) = 8.982017581934167E-03
      Y(11) = 7.597500902492453E-03
      Y(12) = 6.219920556824985E-03
      Y(13) = 4.935916341009131E-03
      Y(14) = 3.801432544256119E-03
      Y(15) = 2.844213677587894E-03
      Y(16) = 2.069123394222672E-03
      Y(17) = 1.464687282843915E-03
      Y(18) = 1.009545263941126E-03
      Y(19) = 6.779354330227017E-04
      Y(20) = 4.437815269118510E-04
      Y(21) = 2.833264542938954E-04
      Y(22) = 1.765005798796805E-04
      Y(23) = 1.073342592697238E-04
      Y(24) = 6.374497601777217E-05
      Y(25) = 3.698645309704183E-05
      Y(26) = 2.097466832643746E-05
      Y(27) = 1.162956710412555E-05
      Y(28) = 6.306710405783322E-06
      Y(29) = 3.346286430868515E-06
      Y(30) = 1.737760074184334E-06
      Y(31) = 8.835366904275847E-07
      Y(32) = 4.399520411127637E-07
      Y(33) = 2.146181897152360E-07
      Y(34) = 1.025981211654928E-07
      Y(35) = 4.807864068784215E-08
      Y(36) = 2.209175152474847E-08
      Y(37) = 9.956251263138180E-09
      Y(38) = 4.402193653748924E-09
      Y(39) = 1.910149382204028E-09
      Y(40) = 8.135892921473050E-10
      Y(41) = 3.402477118549235E-10
      Y(42) = 1.397485617545782E-10
      Y(43) = 5.638575303049199E-11
      Y(44) = 2.235459707956947E-11
      Y(45) = 8.710498036398032E-12
      Y(46) = 3.336554275346643E-12
      Y(47) = 1.256679567784939E-12
      Y(48) = 4.654359053128788E-13
      Y(49) = 1.693559145599857E-13
      Y(50) = 5.996593816663054E-14
      Y(51) = 1.891330702629865E-14
      GO TO 620
C     25:
C        PROBLEM C5
  300 Y(1) = -4.792730224323733E+00
      Y(2) = -2.420550725448973E+00
      Y(3) = -9.212509306014886E-01
      Y(4) = -4.217310404035213E+00
      Y(5) = 7.356202947498970E+00
      Y(6) = 3.223785985421212E+00
      Y(7) = 4.035559443262270E+00
      Y(8) = 1.719865528670555E+01
      Y(9) = 7.478910794233703E+00
      Y(10) = -2.998759326324844E+01
      Y(11) = -4.107310937550929E+00
      Y(12) = -9.277008321754407E-01
      Y(13) = -2.442125302518482E+01
      Y(14) = 2.381459045746554E+01
      Y(15) = 1.492096306951359E+01
      Y(16) = 3.499208963063806E-01
      Y(17) = -5.748487687912825E-01
      Y(18) = -2.551694020879149E-01
      Y(19) = -5.237040978903326E-01
      Y(20) = -2.493000463579661E-01
      Y(21) = -8.045341642044464E-02
      Y(22) = -3.875289237334110E-01
      Y(23) = 5.648603288767891E-02
      Y(24) = 3.023606472143342E-02
      Y(25) = 4.133856546712445E-02
      Y(26) = -2.862393029841379E-01
      Y(27) = -1.183032405136207E-01
      Y(28) = -1.511986457359206E-01
      Y(29) = -2.460068894318766E-01
      Y(30) = -3.189687411323877E-02
      GO TO 620
C     PROBLEM CLASS D
C     31:
C        PROBLEM D1
  320 Y(1) = 2.198835352008397E-01
      Y(2) = 9.427076846341813E-01
      Y(3) = -9.787659841058176E-01
      Y(4) = 3.287977990962036E-01
      GO TO 620
C     32:
C        PROBLEM D2
  340 Y(1) = -1.777027357140412E-01
      Y(2) = 9.467784719905892E-01
      Y(3) = -1.030294163192969E+00
      Y(4) = 1.211074890053952E-01
      GO TO 620
C     33:
C        PROBLEM D3
  360 Y(1) = -5.780432953035361E-01
      Y(2) = 8.633840009194193E-01
      Y(3) = -9.595083730380727E-01
      Y(4) = -6.504915126712089E-02
      GO TO 620
C     34:
C        PROBLEM D4
  380 Y(1) = -9.538990293416394E-01
      Y(2) = 6.907409024219432E-01
      Y(3) = -8.212674270877433E-01
      Y(4) = -1.539574259125825E-01
      GO TO 620
C     35:
C        PROBLEM D5
  400 Y(1) = -1.295266250987574E+00
      Y(2) = 4.003938963792321E-01
      Y(3) = -6.775390924707566E-01
      Y(4) = -1.270838154278686E-01
      GO TO 620
C     PROBLEM CLASS E
C     41:
C        PROBLEM E1
  420 Y(1) = 1.456723600728308E-01
      Y(2) = -9.883500195574063E-02
      GO TO 620
C     42:
C        PROBLEM E2
  440 Y(1) = 2.008149762174948E+00
      Y(2) = -4.250887527320057E-02
      GO TO 620
C     43:
C        PROBLEM E3
  460 Y(1) = -1.004178858647128E-01
      Y(2) = 2.411400132095954E-01
      GO TO 620
C     44:
C        PROBLEM E4
  480 Y(1) = 3.395091444646555E+01
      Y(2) = 2.767822659672869E-01
      GO TO 620
C     45:
C        PROBLEM E5
  500 Y(1) = 1.411797390542629E+01
      Y(2) = 2.400000000000002E+00
      GO TO 620
C     PROBLEM CLASS F
C     51:
C        PROBLEM F1
  520 Y(1) = -1.294460621213470E1
      Y(2) = -2.208575158908672E-15
      GO TO 620
C     52:
C        PROBLEM F2
  540 Y(1) = 70.03731057008607
      GO TO 620
C     53:
C        PROBLEM F3
  560 Y(1) = -3.726957553088175E-1
      Y(2) = -6.230137949234190E-1
      GO TO 620
C     54:
C        PROBLEM F4
  580 Y(1) = 9.815017249707434E-11
      GO TO 620
C     55:
C        PROBLEM F5
  600 Y(1) = 1.
  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
C     .. Scalar Arguments ..
      REAL           X
C     .. Array Arguments ..
      REAL           Y(51), YP(51)
C     .. Scalars in Common ..
      INTEGER        ID, IWT, N, NFCN
C     .. Arrays in Common ..
      REAL           W(51)
C     .. Local Scalars ..
      REAL           C1, C2, D, EX, K2, M0, P, TEMP
      INTEGER        I, I3, I3M2, ITEMP, J, L, LL, MM
C     .. Local Arrays ..
      REAL           M(5), Q(5,5), R(5), YTEMP(51)
C     .. Intrinsic Functions ..
      INTRINSIC      ABS, REAL, COS, SIGN, SIN, SQRT, INT
C     .. Common blocks ..
      COMMON         /NSCOM5/W, IWT, N, ID
      COMMON         /NSCOM6/NFCN
C     .. Data statements ..
C     THE FOLLOWING DATA IS FOR PROBLEM C5 AND DEFINES THE MASSES
C     OF THE 5 OUTER PLANETS ETC. IN SOLAR UNITS.
C     K2 IS THE GRAVITATIONAL CONSTANT.
C     THE NEXT DATA IS FOR PROBLEMS F1 AND F5.
C     C1 IS PI**2 + 0.1**2 AND C2 IS SUM I**(4/3) FOR I=1 TO 19.
      DATA           M0/1.00000597682/, M/.954786104043E-3,
     *               .285583733151E-3, .437273164546E-4,
     *               .517759138449E-4, .277777777778E-5/
      DATA           K2/2.95912208286/
      DATA           EX, C1, C2/.33333333333333333, 9.879604401089358,
     *               438.4461015267790/
C     .. Executable Statements ..
C5
C6
CE
      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
      GO TO (60,80,100,120,140,860,860,860,860,
     *       860,160,180,200,220,240,860,860,860,
     *       860,860,260,300,340,380,420,860,860,
     *       860,860,860,580,580,580,580,580,860,
     *       860,860,860,860,600,620,640,660,680,
     *       860,860,860,860,860,700,740,780,800,
     *       840) ID
      GO TO 860
C     PROBLEM CLASS A
C     1:
C        PROBLEM A1
   60 YP(1) = -Y(1)
      GO TO 860
C     2:
C        PROBLEM A2
   80 YP(1) = -.5*Y(1)*Y(1)*Y(1)
      GO TO 860
C     3:
C        PROBLEM A3
  100 YP(1) = Y(1)*COS(X)
      GO TO 860
C     4:
C        PROBLEM A4
  120 YP(1) = (1.-Y(1)/20.)*Y(1)/4.
      GO TO 860
C     5:
C        PROBLEM A5
  140 YP(1) = (Y(1)-X)/(Y(1)+X)
      GO TO 860
C     PROBLEM CLASS B
C     11:
C        PROBLEM B1
  160 D = Y(1) - Y(1)*Y(2)
      YP(1) = D + D
      YP(2) = -(Y(2)-Y(1)*Y(2))
      GO TO 860
C     12:
C        PROBLEM B2
  180 YP(1) = -Y(1) + Y(2)
      YP(3) = Y(2) - Y(3)
      YP(2) = -YP(1) - YP(3)
      GO TO 860
C     13:
C        PROBLEM B3
  200 D = Y(2)*Y(2)
      YP(1) = -Y(1)
      YP(2) = Y(1) - D
      YP(3) = D
      GO TO 860
C     14:
C        PROBLEM B4
  220 D = SQRT(Y(1)*Y(1)+Y(2)*Y(2))
      YP(1) = -Y(2) - Y(1)*Y(3)/D
      YP(2) = Y(1) - Y(2)*Y(3)/D
      YP(3) = Y(1)/D
      GO TO 860
C     15:
C        PROBLEM B5
  240 YP(1) = Y(2)*Y(3)
      YP(2) = -Y(1)*Y(3)
      YP(3) = -.51*Y(1)*Y(2)
      GO TO 860
C     PROBLEM CLASS C
C     21:
C        PROBLEM C1
  260 YP(1) = -Y(1)
      DO 280 I = 2, 9
         YP(I) = Y(I-1) - Y(I)
  280 CONTINUE
      YP(10) = Y(9)
      GO TO 860
C     22:
C        PROBLEM C2
  300 YP(1) = -Y(1)
      DO 320 I = 2, 9
         YP(I) = REAL(I-1)*Y(I-1) - REAL(I)*Y(I)
  320 CONTINUE
      YP(10) = 9.0*Y(9)
      GO TO 860
C     23:
C        PROBLEM C3
  340 YP(1) = -2.*Y(1) + Y(2)
      DO 360 I = 2, 9
         YP(I) = Y(I-1) - 2.*Y(I) + Y(I+1)
  360 CONTINUE
      YP(10) = Y(9) - 2.*Y(10)
      GO TO 860
C     24:
C        PROBLEM C4
  380 YP(1) = -2.*Y(1) + Y(2)
      DO 400 I = 2, 50
         YP(I) = Y(I-1) - 2.*Y(I) + Y(I+1)
  400 CONTINUE
      YP(51) = Y(50) - 2.*Y(51)
      GO TO 860
C     25:
C        PROBLEM C5
  420 I = 0
      DO 500 L = 3, 15, 3
         I = I + 1
         P = Y(L-2)**2 + Y(L-1)**2 + Y(L)**2
         R(I) = 1./(P*SQRT(P))
         J = 0
         DO 480 LL = 3, 15, 3
            J = J + 1
            IF (LL.NE.L) GO TO 440
            GO TO 460
C              THEN
  440       P = (Y(L-2)-Y(LL-2))**2 + (Y(L-1)-Y(LL-1))**2 + (Y(L)-Y(LL))
     *          **2
            Q(I,J) = 1./(P*SQRT(P))
            Q(J,I) = Q(I,J)
  460       CONTINUE
  480    CONTINUE
  500 CONTINUE
      I3 = 0
      DO 560 I = 1, 5
         I3 = I3 + 3
         I3M2 = I3 - 2
         DO 540 LL = I3M2, I3
            MM = LL - I3
            YP(LL) = Y(LL+15)
            P = 0.
            DO 520 J = 1, 5
               MM = MM + 3
               IF (J.NE.I) P = P + M(J)*(Y(MM)*(Q(I,J)-R(J))-Y(LL)
     *                         *Q(I,J))
  520       CONTINUE
            YP(LL+15) = K2*(-(M0+M(I))*Y(LL)*R(I)+P)
  540    CONTINUE
  560 CONTINUE
      GO TO 860
C     PROBLEM CLASS D
C     31:32:33:34:35:
C        PROBLEMS D1, D2, D3, D4, D5
  580 YP(1) = Y(3)
      YP(2) = Y(4)
      D = Y(1)*Y(1) + Y(2)*Y(2)
      D = SQRT(D*D*D)
      YP(3) = -Y(1)/D
      YP(4) = -Y(2)/D
      GO TO 860
C     PROBLEM CLASS E
C     41:
C        PROBLEM E1
  600 YP(1) = Y(2)
      YP(2) = -(Y(2)/(X+1.)+(1.-.25/(X+1.)**2)*Y(1))
      GO TO 860
C     42:
C        PROBLEM E2
  620 YP(1) = Y(2)
      YP(2) = (1.-Y(1)*Y(1))*Y(2) - Y(1)
      GO TO 860
C     43:
C        PROBLEM E3
  640 YP(1) = Y(2)
      YP(2) = Y(1)**3/6. - Y(1) + 2.*SIN(2.78535*X)
      GO TO 860
C     44:
C        PROBLEM E4
  660 YP(1) = Y(2)
      YP(2) = .032 - .4*Y(2)*Y(2)
      GO TO 860
C     45:
C        PROBLEM E5
  680 YP(1) = Y(2)
      YP(2) = SQRT(1.+Y(2)*Y(2))/(25.-X)
      GO TO 860
C     PROBLEM CLASS F
C     51:
C        PROBLEM F1
  700 YP(1) = Y(2)
      YP(2) = .2*Y(2) - C1*Y(1)
      ITEMP = INT(X)
      IF ((ITEMP/2)*2.EQ.ITEMP) GO TO 720
      YP(2) = YP(2) - 1.
      GO TO 860
  720 YP(2) = YP(2) + 1.
      GO TO 860
C     52:
C        PROBLEM F2
  740 ITEMP = INT(X)
      IF ((ITEMP/2)*2.EQ.ITEMP) GO TO 760
      YP(1) = 55. - .5*Y(1)
      GO TO 860
  760 YP(1) = 55. - 1.5*Y(1)
      GO TO 860
C     53:
C        PROBLEM F3
  780 YP(1) = Y(2)
      YP(2) = .01*Y(2)*(1.-Y(1)**2) - Y(1) -
     *        ABS(SIN(3.1415926535897932*X))
      GO TO 860
C     54:
C        PROBLEM F4
  800 IF (X.GT.10.) GO TO 820
      TEMP = X - 5.
      YP(1) = -2./21. - 120.*TEMP/(1.+4.*TEMP**2)**16
      GO TO 860
  820 YP(1) = -2.*Y(1)
      GO TO 860
C     55:
C        PROBLEM F5
  840 YP(1) = Y(1)*(4./(3.*C2))*(SIGN(ABS(X-1.)**EX,X-1.)+SIGN(ABS(X-2.)
     *        **EX,X-2.)+SIGN(ABS(X-3.)**EX,X-3.)+SIGN(ABS(X-4.)
     *        **EX,X-4.)+SIGN(ABS(X-5.)**EX,X-5.)+SIGN(ABS(X-6.)
     *        **EX,X-6.)+SIGN(ABS(X-7.)**EX,X-7.)+SIGN(ABS(X-8.)
     *        **EX,X-8.)+SIGN(ABS(X-9.)**EX,X-9.)+SIGN(ABS(X-10.)
     *        **EX,X-10.)+SIGN(ABS(X-11.)**EX,X-11.)+SIGN(ABS(X-12.)
     *        **EX,X-12.)+SIGN(ABS(X-13.)**EX,X-13.)+SIGN(ABS(X-14.)
     *        **EX,X-14.)+SIGN(ABS(X-15.)**EX,X-15.)+SIGN(ABS(X-16.)
     *        **EX,X-16.)+SIGN(ABS(X-17.)**EX,X-17.)+SIGN(ABS(X-18.)
     *        **EX,X-18.)+SIGN(ABS(X-19.)**EX,X-19.))
  860 CONTINUE
      IF (IWT.LT.0) GO TO 900
      DO 880 I = 1, N
         YP(I) = YP(I)/W(I)
         Y(I) = YTEMP(I)
  880 CONTINUE
  900 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        NSDTST
C     .. Data statements ..
      DATA            OPTION/2, 0, 1, 1, 6*0/, TOL/1E-2, 1E-4, 1E-6,
     *                1E-8, 7*0E0/, IDLIST/-11, -12, -13, -14, -15, 0,
     *                -21, -22, -23, -24, -25, 49*0/
C     .. Executable Statements ..
C   SAMPLE DRIVER FOR NSDTST, WITH TWO GROUPS CONSISTING OF
C   PROBLEM CLASSES A,B SOLVED IN UNSCALED FORM,
C   AT FOUR TOLERANCES, FIRST WITH OPT=1 AND NORMEF=O,
C   THEN OPT=3, NORMEF=0, THEN OPT=2, NORMEF=2.
C   NOTE THE ARRAYS IDLIST, TOL ARE LONGER THEN NECESSARY.
      TITLE = 'DVERK,  HULL-ENRIGHT-JACKSON CODE'//
     *        ' BASED ON VERNER RK FORMULAS'
      IOUT = CONST(3)
      CALL NSDTST(TITLE,OPTION,TOL,IDLIST,FLAG)
      WRITE (IOUT,FMT=99999)
      OPTION(1) = 3
      CALL NSDTST(TITLE,OPTION,TOL,IDLIST,FLAG)
      WRITE (IOUT,FMT=99999)
      OPTION(1) = 2
      OPTION(2) = 2
      CALL NSDTST(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 DVERK 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     .. Scalar Arguments ..
      DOUBLE PRECISION  HMAX, HSTART, TOL, X, XEND
      INTEGER           N
C     .. Array Arguments ..
      DOUBLE PRECISION  Y(N)
C     .. Local Scalars ..
      DOUBLE PRECISION  TEMP
      INTEGER           I, IND, NW
C     .. Local Arrays ..
      DOUBLE PRECISION  C(24), W(51,9)
C     .. External Subroutines ..
      EXTERNAL          FCN1, STATS, TRUE
C     .. Data statements ..
C
      DATA              NW/51/
C     .. Executable Statements ..
C
      IND = 2
      DO 20 I = 1, 9
         C(I) = 0.D0
   20 CONTINUE
C
C   SET ABS ERROR CONTROL..C(1); INTERRUPT NO. 2..C(9);
C   MAX STEPSIZE..C(6); STARTING STEPSIZE..C(4)
      C(1) = 1.D0
      C(4) = HSTART
      C(6) = HMAX
      C(9) = 1.D0
C
   40 CALL TRUE(N,FCN1,X,Y,XEND,TOL,IND,C,NW,W)
      IF (IND.EQ.6) GO TO 40
      IF (IND.NE.5) GO TO 60
      TEMP = C(17)
C
C     THE DOCUMENTATION AND COMMENTS IN DVERK (SEE END OF 'STAGE 3')
C     DESCRIBE IT AS AIMING AT AN ERROR-PER-UNIT-STEP CONTROL OF THE
C     LOCALLY EXTRAPOLATED SOLUTION, USING THE VARIABLE 'SCALE'=C(15)
C     AS A RATHER ARBITRARY SCALEFACTOR.  HOWEVER, THE STATS CALL BELOW
C     ANALYSES W(*,2) AS AN ESTIMATE OF THE ERROR-PER-STEP IN THE
C     UNEXTRAPOLATED SOLUTION, ACCORDINGLY MUST BE USED WITH OPTION(4)
C     SET TO 1 TO INDICATE THAT THIS IS A METHOD THAT DOES LOC. EXTRAP.
      CALL STATS(C(17),W(1,9),TOL,W(1,2))
C
      IF (C(17).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(17)
C      WRITE(IOUT,110)IND,(C(I),I=10,24)
C110   FORMAT(1H ,'IND,C(10)..C(24)=',1P10D12.4/
C     *       1H ,17X,1P5D12.4)
  100 CONTINUE
      RETURN
      END
      SUBROUTINE FCN1(N,X,Y,YP)
C     .. Scalar Arguments ..
      DOUBLE PRECISION X
      INTEGER         N
C     .. Array Arguments ..
      DOUBLE PRECISION Y(N), YP(N)
C     .. External Subroutines ..
      EXTERNAL        FCN
C     .. Executable Statements ..
      CALL FCN(X,Y,YP)
      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        NSDTST
C     .. Data statements ..
      DATA            OPTION/2, 0, 1, 1, 6*0/, TOL/1E-2, 1E-4, 1E-6,
     *                1E-8, 7*0E0/, IDLIST/-11, -12, -13, -14, -15, 0,
     *                -21, -22, -23, -24, -25, 49*0/
C     .. Executable Statements ..
C   SAMPLE DRIVER FOR NSDTST, WITH TWO GROUPS CONSISTING OF
C   PROBLEM CLASSES A,B SOLVED IN UNSCALED FORM,
C   AT FOUR TOLERANCES, FIRST WITH OPT=1 AND NORMEF=O,
C   THEN OPT=3, NORMEF=0, THEN OPT=2, NORMEF=2.
C   NOTE THE ARRAYS IDLIST, TOL ARE LONGER THEN NECESSARY.
      TITLE = 'DVERK,  HULL-ENRIGHT-JACKSON CODE'//
     *        ' BASED ON VERNER RK FORMULAS'
      IOUT = CONST(3)
      CALL NSDTST(TITLE,OPTION,TOL,IDLIST,FLAG)
      WRITE (IOUT,FMT=99999)
      OPTION(1) = 3
      CALL NSDTST(TITLE,OPTION,TOL,IDLIST,FLAG)
      WRITE (IOUT,FMT=99999)
      OPTION(1) = 2
      OPTION(2) = 2
      CALL NSDTST(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 DVERK 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     .. Scalar Arguments ..
      REAL              HMAX, HSTART, TOL, X, XEND
      INTEGER           N
C     .. Array Arguments ..
      REAL              Y(N)
C     .. Local Scalars ..
      REAL              TEMP
      INTEGER           I, IND, NW
C     .. Local Arrays ..
      REAL              C(24), W(51,9)
C     .. External Subroutines ..
      EXTERNAL          FCN1, STATS, TRUE
C     .. Data statements ..
C
      DATA              NW/51/
C     .. Executable Statements ..
C
      IND = 2
      DO 20 I = 1, 9
         C(I) = 0.
   20 CONTINUE
C
C   SET ABS ERROR CONTROL..C(1); INTERRUPT NO. 2..C(9);
C   MAX STEPSIZE..C(6); STARTING STEPSIZE..C(4)
      C(1) = 1.
      C(4) = HSTART
      C(6) = HMAX
      C(9) = 1.
C
   40 CALL TRUE(N,FCN1,X,Y,XEND,TOL,IND,C,NW,W)
      IF (IND.EQ.6) GO TO 40
      IF (IND.NE.5) GO TO 60
      TEMP = C(17)
C
C     THE DOCUMENTATION AND COMMENTS IN DVERK (SEE END OF 'STAGE 3')
C     DESCRIBE IT AS AIMING AT AN ERROR-PER-UNIT-STEP CONTROL OF THE
C     LOCALLY EXTRAPOLATED SOLUTION, USING THE VARIABLE 'SCALE'=C(15)
C     AS A RATHER ARBITRARY SCALEFACTOR.  HOWEVER, THE STATS CALL BELOW
C     ANALYSES W(*,2) AS AN ESTIMATE OF THE ERROR-PER-STEP IN THE
C     UNEXTRAPOLATED SOLUTION, ACCORDINGLY MUST BE USED WITH OPTION(4)
C     SET TO 1 TO INDICATE THAT THIS IS A METHOD THAT DOES LOC. EXTRAP.
      CALL STATS(C(17),W(1,9),TOL,W(1,2))
C
      IF (C(17).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(17)
C      WRITE(IOUT,110)IND,(C(I),I=10,24)
C110   FORMAT(1H ,'IND,C(10)..C(24)=',1P10D12.4/
C     *       1H ,17X,1P5D12.4)
  100 CONTINUE
      RETURN
      END
      SUBROUTINE FCN1(N,X,Y,YP)
C     .. Scalar Arguments ..
      REAL            X
      INTEGER         N
C     .. Array Arguments ..
      REAL            Y(N), YP(N)
C     .. External Subroutines ..
      EXTERNAL        FCN
C     .. Executable Statements ..
      CALL FCN(X,Y,YP)
      RETURN
      END
C     .. Scalars in Common ..
      INTEGER         IDENT, IWT, NN
C     .. Arrays in Common ..
      DOUBLE PRECISION WT(51)
C     .. Local Scalars ..
      DOUBLE PRECISION HMAX, HSTART, T, TOL, XEND
      REAL            FTIM
      INTEGER         I, IID, IND, IP, IZ, K, N, NPROB, NW
C     .. Local Arrays ..
      DOUBLE PRECISION C(24), W(51), WS(51,10), Y(51)
      INTEGER         ID(30)
C     .. External Subroutines ..
      EXTERNAL        FN, IVALU, TRUE
C     .. Intrinsic Functions ..
      INTRINSIC       DABS, DMAX1
C     .. Common blocks ..
      COMMON          /NSCOM5/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 BOTH IVALU AND FCN
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 NSTRUE TO GENERATE THE
C  TRIAL SOLUTION.
C
      DO 160 K = 1, NPROB
         IID = ID(K)
         IZ = -1
         CALL IVALU(N,T,XEND,HSTART,HMAX,Y,FTIM,W,IZ,IID)
         NN = N
         IDENT = IID
         DO 20 I = 1, N
            WT(I) = W(I)
            W(I) = DABS(Y(I))
   20    CONTINUE
         IWT = -1
         TOL = 1.D-8
         NW = 51
         IND = 2
         DO 40 I = 1, 9
            C(I) = 0.D0
   40    CONTINUE
         C(4) = HSTART
         C(9) = 1.D0
C        LOOP OVER EACH STEP MONITORING THE SIZE OF THE SOLUTION.
   60    CALL TRUE(N,FN,T,Y,XEND,TOL,IND,C,NW,WS)
         IF (IND.EQ.6) GO TO 60
         DO 80 I = 1, N
            W(I) = DMAX1(DABS(Y(I)),W(I))
   80    CONTINUE
         IF (T.GE.XEND) GO TO 120
         IF (IND.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
C     .. Scalars in Common ..
      INTEGER         IDENT, IWT, NN
C     .. Arrays in Common ..
      REAL            WT(51)
C     .. Local Scalars ..
      REAL            HMAX, HSTART, T, TOL, XEND
      REAL            FTIM
      INTEGER         I, IID, IND, IP, IZ, K, N, NPROB, NW
C     .. Local Arrays ..
      REAL            C(24), W(51), WS(51,10), Y(51)
      INTEGER         ID(30)
C     .. External Subroutines ..
      EXTERNAL        FN, IVALU, TRUE
C     .. Intrinsic Functions ..
      INTRINSIC       ABS, AMAX1
C     .. Common blocks ..
      COMMON          /NSCOM5/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 BOTH IVALU AND FCN
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 NSTRUE TO GENERATE THE
C  TRIAL SOLUTION.
C
      DO 160 K = 1, NPROB
         IID = ID(K)
         IZ = -1
         CALL IVALU(N,T,XEND,HSTART,HMAX,Y,FTIM,W,IZ,IID)
         NN = N
         IDENT = IID
         DO 20 I = 1, N
            WT(I) = W(I)
            W(I) = ABS(Y(I))
   20    CONTINUE
         IWT = -1
         TOL = 1.E-8
         NW = 51
         IND = 2
         DO 40 I = 1, 9
            C(I) = 0.
   40    CONTINUE
         C(4) = HSTART
         C(9) = 1.
C        LOOP OVER EACH STEP MONITORING THE SIZE OF THE SOLUTION.
   60    CALL TRUE(N,FN,T,Y,XEND,TOL,IND,C,NW,WS)
         IF (IND.EQ.6) GO TO 60
         DO 80 I = 1, N
            W(I) = AMAX1(ABS(Y(I)),W(I))
   80    CONTINUE
         IF (T.GE.XEND) GO TO 120
         IF (IND.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
C     .. Parameters ..
      CHARACTER       EOF
      INTEGER         IIN, IOUT, TTYIN, TTYOUT
      PARAMETER       (EOF='.',IIN=1,IOUT=2,TTYIN=5,TTYOUT=5)
      CHARACTER*40    INFIL, OUTFIL
      PARAMETER       (INFIL='IVALU.FOR',OUTFIL='IVALU.NEW')
C     .. Local Scalars ..
      REAL            FCNTIM
      INTEGER         ID, IDEXT, IPROB, K, LEN, LNUM, LNUM0, NFCN, NID
      CHARACTER*2     PROBID
      CHARACTER*72    LINE, TEMP
C     .. Local Arrays ..
      INTEGER         IDLIST(30), PROB(26)
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 D1-D5 ARE LUMPED TOGETHER).
      DATA            PROB/01, 02, 03, 04, 05, 11, 12, 13, 14, 15, 21,
     *                22, 23, 24, 25, 31, 41, 42, 43, 44, 45, 51, 52,
     *                53, 54, 55/
C     .. Executable Statements ..
C
CIBM      PARAMETER(EOF='.',IIN=5,IOUT=6,TTYIN=5,TTYOUT=6)
C
C
C     STATEMENT FUNCTION:
C*********************************************************************
C  GENTIM PROGRAM FOR THE NSDTST PACKAGE:
C  THIS PROGRAM COMPUTES THE VALUES OF THE TIMING CONSTANT FCNTIM
C  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 'NSPROB' 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 'NSPROB' 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 'NSPROB'.
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
C     READ DATA:
C     .. Statement Function definitions ..
      FIRST1(TEMP) = TEMP(1:1)
      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,NFCN)
C
            WRITE (IOUT,FMT=99997) FCNTIM
            WRITE (TTYOUT,FMT=99996) PROBID, IDEXT, NFCN
   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) THEN
                  WRITE (TTYOUT,FMT=99998) LNUM0, LINE, PROBID
                  STOP
               ELSE
                  CALL GETTIM(ID,FCNTIM,NFCN)
                  WRITE (IOUT,FMT=99997) FCNTIM
                  WRITE (TTYOUT,FMT=99996) PROBID, IDEXT, NFCN
               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 LINE NOT AS EXPECTED.',/)
99997 FORMAT (10X,'FCNTIM  =  ',1P,E11.4)
99996 FORMAT (' PROBLEM ',A,'(',I3,
     *       ') PROCESSED, TIMES ROUND TIMING LOOP WAS    NFCN',/57X,I7)
      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,NFCN)
C     .. Scalar Arguments ..
      REAL              FCNTIM
      INTEGER           IDENT, NFCN
C     .. Scalars in Common ..
      INTEGER           ID, IWT, NN
C     .. Arrays in Common ..
      DOUBLE PRECISION  WT(51)
C     .. Local Scalars ..
      DOUBLE PRECISION  HB, HM, XEND, XS
      REAL              S, TIM, TSTTIM
      INTEGER           N
C     .. Local Arrays ..
      DOUBLE PRECISION  Y(51), Z(51)
C     .. External Functions ..
      REAL              CLOCK, CONST
      EXTERNAL          CLOCK, CONST
C     .. External Subroutines ..
      EXTERNAL          EVALU, FCN, IVALU
C     .. Intrinsic Functions ..
      INTRINSIC         FLOAT
C     .. Common blocks ..
      COMMON            /NSCOM5/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)
      ID = IDENT
      IWT = -1
      CALL IVALU(N,XS,XEND,HB,HM,Y,FCNTIM,WT,IWT,IDENT)
      CALL EVALU(Y,N,WT,IWT,IDENT)
C
C        DETERMINE THE DERIVATIVE EVALUATION TIME
C
      S = CLOCK(0.0)
      NFCN = 0
C        LOOP UNTIL TIMING IS SIGNIFICANT
   20 CONTINUE
      CALL FCN(XEND,Y,Z)
      NFCN = NFCN + 1
      TIM = CLOCK(S)
      IF (TIM.LT.TSTTIM) GO TO 20
      FCNTIM = TIM/FLOAT(NFCN)
C
      RETURN
      END
C     .. Parameters ..
      CHARACTER       EOF
      INTEGER         IIN, IOUT, TTYIN, TTYOUT
      PARAMETER       (EOF='.',IIN=1,IOUT=2,TTYIN=5,TTYOUT=5)
      CHARACTER*40    INFIL, OUTFIL
      PARAMETER       (INFIL='IVALU.FOR',OUTFIL='IVALU.NEW')
C     .. Local Scalars ..
      REAL            FCNTIM
      INTEGER         ID, IDEXT, IPROB, K, LEN, LNUM, LNUM0, NFCN, NID
      CHARACTER*2     PROBID
      CHARACTER*72    LINE, TEMP
C     .. Local Arrays ..
      INTEGER         IDLIST(30), PROB(26)
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 D1-D5 ARE LUMPED TOGETHER).
      DATA            PROB/01, 02, 03, 04, 05, 11, 12, 13, 14, 15, 21,
     *                22, 23, 24, 25, 31, 41, 42, 43, 44, 45, 51, 52,
     *                53, 54, 55/
C     .. Executable Statements ..
C
CIBM      PARAMETER(EOF='.',IIN=5,IOUT=6,TTYIN=5,TTYOUT=6)
C
C
C     STATEMENT FUNCTION:
C*********************************************************************
C  GENTIM PROGRAM FOR THE NSDTST PACKAGE:
C  THIS PROGRAM COMPUTES THE VALUES OF THE TIMING CONSTANT FCNTIM
C  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 'NSPROB' 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 'NSPROB' 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 'NSPROB'.
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
C     READ DATA:
C     .. Statement Function definitions ..
      FIRST1(TEMP) = TEMP(1:1)
      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,NFCN)
C
            WRITE (IOUT,FMT=99997) FCNTIM
            WRITE (TTYOUT,FMT=99996) PROBID, IDEXT, NFCN
   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) THEN
                  WRITE (TTYOUT,FMT=99998) LNUM0, LINE, PROBID
                  STOP
               ELSE
                  CALL GETTIM(ID,FCNTIM,NFCN)
                  WRITE (IOUT,FMT=99997) FCNTIM
                  WRITE (TTYOUT,FMT=99996) PROBID, IDEXT, NFCN
               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 LINE NOT AS EXPECTED.',/)
99997 FORMAT (10X,'FCNTIM  =  ',1P,E11.4)
99996 FORMAT (' PROBLEM ',A,'(',I3,
     *       ') PROCESSED, TIMES ROUND TIMING LOOP WAS    NFCN',/57X,I7)
      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,NFCN)
C     .. Scalar Arguments ..
      REAL              FCNTIM
      INTEGER           IDENT, NFCN
C     .. Scalars in Common ..
      INTEGER           ID, IWT, NN
C     .. Arrays in Common ..
      REAL              WT(51)
C     .. Local Scalars ..
      REAL              HB, HM, XEND, XS
      REAL              S, TIM, TSTTIM
      INTEGER           N
C     .. Local Arrays ..
      REAL              Y(51), Z(51)
C     .. External Functions ..
      REAL              CLOCK, CONST
      EXTERNAL          CLOCK, CONST
C     .. External Subroutines ..
      EXTERNAL          EVALU, FCN, IVALU
C     .. Intrinsic Functions ..
      INTRINSIC         FLOAT
C     .. Common blocks ..
      COMMON            /NSCOM5/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)
      ID = IDENT
      IWT = -1
      CALL IVALU(N,XS,XEND,HB,HM,Y,FCNTIM,WT,IWT,IDENT)
      CALL EVALU(Y,N,WT,IWT,IDENT)
C
C        DETERMINE THE DERIVATIVE EVALUATION TIME
C
      S = CLOCK(0.0)
      NFCN = 0
C        LOOP UNTIL TIMING IS SIGNIFICANT
   20 CONTINUE
      CALL FCN(XEND,Y,Z)
      NFCN = NFCN + 1
      TIM = CLOCK(S)
      IF (TIM.LT.TSTTIM) GO TO 20
      FCNTIM = TIM/FLOAT(NFCN)
C
      RETURN
      END
*
Stiff 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
   ------- -----
*
Stiff DETEST is a package to test  the  performance  of  initial-value
codes  for stiff differential systems.  This code is a revision of the
1975 version, used to produce the results reported on in [3].
*
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 for
use according as the  software  under  test  is  written  in single or
double  precision.   The  arguments of STDTST are single precision but
METHOD must be implemented in the appropriate precision.
*
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 STGTIM which must be used
on each new machine to generate timing data embedded in the code;  and
a  utility  STGWT which is needed 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.
*
*
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<infinity
        thus   forming  12x12  pigeonholes.  Each   integration   step
        contributes  a data point (r1,r2)  which  is  entered  in  one
        pigeonhole. The  counts  of  the  number  of  entries  in each
        pigeonhole are expressed as integer percentages of  the  total
        number  of integration steps and printed out in a 12x12 array,
        zero entries being left blank,  and  positive  values  below 1
        being shown by a dot '.'.
*
        Step-lumping (see [4]) is deemed to make this analysis useless
        so  statistics are only gathered on unlumped steps. It  is  at
        present also  not  considered useful to produce summary tables
        over several problems (and would be costly in array space).
*
*
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 y-y*  defined
     above
*
     (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. The Dummy STDTST for Debugging
   --- ----- ------ --- ---------
*
To the user:
*
This will probably be implemented  at  your  site  as  a  source  file
containing  cut-down  versions  of STDTST and STATS (and other package
routines of no concern to the  user).   This  file  makes  a  complete
program when combined with the STPROB file and the user's Main Program
and METHOD (and of course SOLVER).  The  cut-down  routines  have  the
same calling sequence as the proper ones.
*
The resulting program uses METHOD to solve the first problem specified
in IDLIST, at the first tolerance specified in TOL.  It will print out
the values of the arguments passed by METHOD to STATS and also the  LU
Decomp  counter  NLUD,  for  5 steps, and then set X = XEND.  The user
should check that the values of X, Y, ERREST, ERRBND look right;  that
X = XEND  forces  termination  as  it  should;  and that NLUD is being
counted up correctly.
*
Feel free to modify these routines to work interactively.
*
To the person implementing the package:
*
Please modify these routines to match the user environment.
*
*
*
8. Implementation Notes
   -------------- -----
*
 8.1.  Machine-dependent constants
*
    These  are   isolated  in  the  routine   CONST   which   has  the
    specification   REAL  FUNCTION CONST(I).  You must set the array C
    and the string MCNAME in the DATA statement:
*
    C(1)   Approximately  the  double  precision  unit  roundoff, used
           in STATS and TRUE.
    C(2)   A number near the underflow threshold, used in TRUE.
    C(3)   The  standard  output  unit number IOUT, used in STDTST and
           TRUE.   We suggest output be to the terminal by default.
    C(4)   TSTTIM, used in CNTROL (see Clock Routine).
    MCNAME Titling  information  for printout, giving the  name of the
           computer and operating system.
*
    In addition, a call of CONST(0) (executed near the top of  STDTST)
    is  intended  to  invoke  calls  to  system  routines  to suppress
    underflow  reporting  (which  may  spoil  the  appearance  of  the
    output), etc.
*
    It may be convenient  to  allow  IOUT  (C(3)  above)  to be set by
    interaction with the user at this point.
*
 8.2.  Clock Routine
*
    If   it  is  decided  to  implement  the  timing  facilities,  the
    implementer  should  provide  a  timing routine  which  calls  the
    system clock and has the specification
         REAL FUNCTION CLOCK(S)
         REAL(S)
    It should be such that it is 'reset to zero' by the statement
         S = CLOCK(0.0)
    and (as long as S is left alone) can then be 'read'  as  often  as
    desired by statements like
         TIME = CLOCK(S)
    which sets TIME to the number of seconds of processor  time  since
    CLOCK was 'reset'.
*
    The larger is  the  value  of  TSTTIM  (ie.   CONST(4))  the  more
    accurate,  and expensive, is the timing process.  It should be set
    to a value reflecting the speed of the hardware and the resolution
    of  the  system clock.  We cannot give much guidance here, and our
    experience is that timings inevitably vary significantly from  run
    to run on a time-shared computing system.
*
    If timing is left unimplemented, give  TSTTIM  the  value zero and
    leave the timing data in IVALU as all zero  to cause all values of
    timing statistics to be printed out as zero.
*
 8.3.  The Timing Data in IVALU
*
    Routine IVALU  contains values of  the  quantities  FCNTIM, DRVTIM
    and LUDTIM  for   each  problem: these are the  cost  of  one call
    to  FCN as measured by  CLOCK,  and  are  used  in  computing  the
    "overhead"   statistics.     They   should   be   recomputed   for
    another machine.   The  utility  program  STGTIM provided with the
    package,   when   supplied  with  a  CLOCK  routine,   can  either
    produce a complete  revised  IVALU  file, or for selected problems
    will produce blocks of output of the form
*
    C PROBLEM xx
          FCNTIM = ...
          JACTIM = ...
          LUDTIM = ...
*
    suitable for inclusion in the text of IVALU.
*
*
 8.4.  Adding extra problems
*
    Say you wish to add three extra problems to class B  of  the  set.
    They  will  then  be  called  B6,  B7  and B8 (for the sake of the
    checking routine PARCHK they  must  follow  consecutively  on  the
    existing  problem-ids).   Their numeric codes which you specify in
    the IDLIST argument of STDTST will then be 26, 27, 28.   You  need
    to be aware that the internal code, put in variable ID and used in
    FCN, IVALU and EVALU to select the correct section  of  subroutine
    to execute, is 10 less than this, ie.  16, 17 or 18.
*
    The  steps  involved  are:
    a)  Code the  definition  of   the   differential   equations   at
        the appropriate place in FCN.  Change the computed GOTO at the
        head  of  FCN so that the value ID = 16, 17 or 18 gives a jump
        to  the correct place.
    b)  Code the  initial  values,  "true"  final   values  and  other
        data into  the  appropriate  places  in IVALU  and  EVALU in a
        similar  way.   The  true  final  values  should  probably  be
        computed   by   an  integrator   using   higher   than  double
        precision, but the only consequence of slight  inaccuracies is
        to  affect  the  END  PT   GLB ERR  statistic   at   stringent
        tolerances.  At this stage ignore the  weights  W(i)  and  the
        timing data FCNTIM.
    c)  In the argument-checking  routine   PARCHK  change  the   DATA
        statement  which defines array NSYSTM,  to indicate that class
        B now has 8 members.  (Ie.   change its second element from  5
        to 8.)
    d)  Run the  utility  program  STGWT.F on the tape to compute  the
        values   of  the  weights  W(i).    Similarly   run   STGTIM.F
        to determine FCNTIM etc. for your problems.
*
Adding  an  entire  new  problem class is  no  more  difficult.   Note
that  it  involves  increasing  the   value   of   NCLASS  in the DATA
statement and the length of NSYSTM in the  dimensioning   statement in
PARCHK; also check the string IDCLAS  in  STDTST has enough letters in
it.
*
 8.5.  Other statistics to print
*
Statistics  which are gathered but do  not  appear   in   the   output
tables  include   NSTART,  NSTL  and  TRUTIM.  They are defined in the
description   of   COMMON  /STCOM3/  below.   NSTART   assesses    the
efficiency  of  the  starting  phase  of  a code and may be of general
interest.  TRUTIM is of use  if  you  are  troubled  by  the overheads
of calls to TRUE with OPT  >=  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<INFINITY
C         THUS   FORMING  12X12  PIGEONHOLES.  EACH   INTEGRATION   STEP
C         CONTRIBUTES  A DATA POINT (R1,R2)  WHICH  IS  ENTERED  IN  ONE
C         PIGEONHOLE. THE  COUNTS  OF  THE  NUMBER  OF  ENTRIES  IN EACH
C         PIGEONHOLE ARE EXPRESSED AS INTEGER PERCENTAGES OF  THE  TOTAL
C         NUMBER  OF INTEGRATION STEPS AND PRINTED OUT IN A 12X12 ARRAY,
C         ZERO ENTRIES BEING LEFT BLANK,  AND  POSITIVE  VALUES  BELOW 1
C         BEING SHOWN BY A DOT '.'.
C
C         STEP-LUMPING (SEE [4]) IS DEEMED TO MAKE THIS ANALYSIS USELESS
C         SO  STATISTICS ARE ONLY GATHERED ON UNLUMPED STEPS. IT  IS  AT
C         PRESENT ALSO  NOT  CONSIDERED USEFUL TO PRODUCE SUMMARY TABLES
C         OVER SEVERAL PROBLEMS (AND WOULD BE COSTLY IN ARRAY SPACE).
C
C
C NORMEF  ONE  OF  0   1   OR   2   ,   SELECTS   NORMALIZED  EFFICIENCY
C         STATISTICS.    THESE  TRY  TO  COMPENSATE  FOR  THE  FACT THAT
C         ACHIEVED  ACCURACY  MAY  BE MUCH HIGHER OR LOWER   THAN   THAT
C         REQUESTED  BY  TOL, AND THIS RELATIONSHIP IS VERY PROBLEM- AND
C         METHOD- DEPENDENT.  FOR EACH PROBLEM, A LEAST-SQUARES  FIT  IS
C         MADE OF LOG10(ACTUAL ERROR) VS LOG10(TOL) AND USED TO ESTIMATE
C         WHAT THE VARIOUS COST STATISTICS WOULD BE FOR AN ACTUAL  ERROR
C         OF 10**N.  THIS IS ACHIEVED BY INTERPOLATION, FOR THOSE N SUCH
C         THAT 10**N LIES WITHIN THE RANGE OF ACCURACIES  ACHIEVED  WITH
C         THE USER-SPECIFIED TOLERANCES.
C     0   NO NORMALIZED STATISTICS
C     1   NORMALIZED STATISTICS ARE PRODUCED TAKING THE  'ACTUAL  ERROR'
C         USED IN THE LEAST SQUARES FIT TO BE THE ENDPOINT GLOBAL ERROR.
C     2   NORMALIZED STATISTICS ARE PRODUCED TAKING  'ACTUAL  ERROR'  AS
C         THE  MAXIMUM  GLOBAL ERROR OVER THE RANGE.  N.B.  IN THIS CASE
C         OPT MUST BE AT LEAST 2.
C
C NRMTYP  ONE OF 1, 2  OR 3, SELECTS THE NORM USED IN ASSESSING THE SIZE
C         OF LOCAL AND GLOBAL ERRORS. IT SHOULD BE CHOSEN BY THE USER TO
C         AGREE WITH THE NORM USED IN SOLVER. WE OFFER:
C     1   MAX-NORM.
C     2   2-NORM (EUCLIDEAN NORM).
C     3   R.M.S. NORM, THAT IS (2-NORM OF X)/SQRT(N) FOR AN N-VECTOR X.
C
C TOL     (INPUT) REAL ARRAY, HOLDS LIST OF UP TO 10  TOLERANCES  TO  BE
C         USED,  IN  STRICTLY  DECREASING  ORDER,  WITH 0 AS TERMINATOR.
C         EACH PROBLEM IS INTEGRATED AT EACH TOLERANCE IN TURN.
C         EXAMPLE:  IN CALLING PROGRAM
C                   REAL TOL(11)
C                   DATA TOL/1E-1,1E-3,1E-5,1E-7,7*0E0/
C         REQUESTS THE FOUR TOLERANCES .1, .001, .00001, .0000001.
C
C IDLIST  (INPUT) INTEGER ARRAY, HOLDS LIST OF GROUPS OF  PROBLEMS,  AND
C         SPECIFIES  FOR  EACH  ONE  WHETHER  IT  IS TO BE INTEGRATED IN
C         SCALED OR UNSCALED  FORM  (SEE  GENERAL  NOTES  ABOVE).   EACH
C         PROBLEM  IS SPECIFIED BY A NUMERIC CODE, 11 TO 14 FOR PROBLEMS
C         A1 TO A4, 21 TO 25 FOR B1 TO B5  ETC.   A  ZERO  TERMINATES  A
C         GROUP AND TWO ZEROS TERMINATE THE LIST OF GROUPS.
C         IF THE PROBLEM CODE IS GIVEN A NEGATIVE SIGN,  THE  SYSTEM  IS
C         INTEGRATED  IN  UNSCALED  FORM;  IF A POSITIVE SIGN, IN SCALED
C         FORM.
C         EXAMPLE:  IN CALLING PROGRAM
C                   INTEGER IDLIST(7)
C                   DATA IDLIST/11,22,0,-31,-51,0,0/
C         SPECIFIES GROUP 1 CONSISTING OF PROBLEMS A1,B2 AND GROUP 2  OF
C         PROBLEMS  C1,E1.  THE FIRST TWO ARE TO BE SOLVED IN THE SCALED
C         FORM AND THE LAST TWO  IN  UNSCALED  FORM.
C
C         THE TOTAL LENGTH OF THE LIST INCLUDING ZEROS MUST BE  AT  MOST
C         60 ITEMS.
C
C FLAG
C         (OUTPUT) REAL.  A NONZERO VALUE INDICATES  THAT  THE  CALL  TO
C         STDTST  WAS  ABORTED BECAUSE OF ARGUMENT ERRORS, IN WHICH CASE
C         THE VALUES OF THE DECIMAL DIGITS OF FLAG INDICATE THE ERROR(S)
C         THAT HAVE OCCURRED, AS FOLLOWS:
C           1:  OPT INVALID.
C           2:  NORMEF INVALID.
C           3:  NORMEF = 2 WAS REQUESTED WITH OPT = 1.
C           4:  A NEGATIVE  TOLERANCE  WAS  SUPPLIED,  OR THE  LIST  OF
C               TOLERANCES WAS NOT IN DECREASING ORDER.
C           5:  THE LIST OF TOLERANCES WAS EMPTY OR NOT TERMINATED BY A
C               ZERO.
C           6:  AN INVALID PROBLEM-ID WAS FOUND IN IDLIST.
C           7:  THE LIST  OF  GROUPS  IN  IDLIST  IS  EMPTY  OR  IS NOT
C               TERMINATED  BY  TWO  ZEROS OR HAS MORE THAN THE MAXIMUM
C               ALLOWED NUMBER (6) OF GROUPS.
C           8:  NRMTYP INVALID.
C         EG.  A VALUE FLAG = 0.245E 03 INDICATES THAT ERRORS 2, 4 AND 5
C         IN  THE  ABOVE  LIST  HAVE  OCCURRED.  ITS VALUE IF NONZERO IS
C         PRINTED BY STDTST ANYWAY, BUT FLAG IS MEANT TO BE INSPECTED IF
C         FURTHER  ACTION  OF  THE  MAIN PROGRAM DEPENDS ON A SUCCESSFUL
C         CALL TO STDTST.
C
C
C 3. INTERFACE ROUTINE METHOD
C    --------- ------- ------
C
C THIS INVOKES THE CODE BEING TESTED, CALL IT SOLVER.  THE SPECIFICATION
C IS
C         SUBROUTINE METHOD(N,X,Y,XEND,TOL,HMAX,HSTART)
C         INTEGER N
C         DOUBLE PRECISION X,Y(N),XEND,TOL,HMAX,HSTART
C         EXTERNAL FCN, PDERV
C
C METHOD IS TO BE WRITTEN BY THE USER AS A SIMPLE INTEGRATOR TO  ADVANCE
C THE  SOLUTION OF N DIFFERENTIAL EQUATIONS FROM THE INITIAL VALUES HELD
C IN X,Y UP TO XEND, WITH AN UNWEIGHTED ABSOLUTE ERROR CONTROL  OF  TOL.
C HMAX  IS  A  RECOMMENDED  MAXIMUM STEPSIZE AND HSTART IS A RECOMMENDED
C INITIAL STEPSIZE.  IF SOLVER CAN MAKE USE OF THESE TWO PARAMETERS, THE
C STATISTICS WILL PROBABLY BE MORE FAVORABLE AND RELIABLE, BUT THEIR USE
C IS NOT CRUCIAL.
C
C THE DERIVATIVES, AND THE ANALYTICAL JACOBIAN MATRIX,  OF  THE  PROBLEM
C ARE  COMPUTED  BY  PACKAGE  ROUTINES FCN AND PDERV RESPECTIVELY.  THUS
C CERTAINLY FCN, AND IN MOST CASES PDERV, MUST BE ARGUMENTS  TO  SOLVER,
C AND THEY MUST BE DECLARED EXTERNAL IN METHOD.
C
C METHOD SHOULD CALL SOLVER IN ONE-STEP MODE  SO  THAT  A  CALL  TO  THE
C PACKAGE  ROUTINE  STATS  CAN  BE  MADE AFTER EACH SUCCESSFUL STEP.  IF
C SOLVER DOES NOT HAVE THIS FACILITY, SOLVER MUST HAVE A CALL  TO  STATS
C INSERTED AT THE APPROPRIATE POINT IN THE CODE.
C
C SOME  CALLS  TO  METHOD  ARE  INTENDED  TO  BE  ABORTED  AFTER  A  FEW
C INTEGRATION  STEPS  BY  THE  STATS CALL SETTING X = XEND.  THUS A TEST
C SHOULD BE MADE AFTER EACH CALL TO STATS, OF THE FORM
C         IF STATS HAS SET X = XEND THEN EXIT.
C
C NB:  IF THE ACTUAL X  ARGUMENT  TO  STATS  IS  DIFFERENT  FROM  THE  X
C ARGUMENT  OF METHOD (WHICH MAY BE NECESSARY WITH SOME SOLVERS), ENSURE
C THAT THE X ARGUMENT OF METHOD IS SET TO XEND  BEFORE  EXIT,  ELSE  THE
C PACKAGE WILL REPORT 'METHOD FAILED TO START'.
C
C THE ALGORITHM FOR METHOD SHOULD THUS BE OF THE FORM:
C - DECLARE ALL ARGUMENTS AND WORKSPACE EXPECTED BY SOLVER
C - SET APPROPRIATE OPTIONS  INCLUDING  ABSOLUTE  ERROR  CONTROL  AND
C    ONE-STEP MODE
C - INITIALIZE EXTRA ARGUMENTS IF REQUIRED
C - FOR EACH SUCCESSFUL STEP DO
C    - CALL SOLVER( ...  ,FCN,PDERV, ...  )
C      EXIT IF SOLVER IS IN TROUBLE.
C    - SET X,Y TO THE JUST COMPUTED MESHPOINT X AND SOLUTION VECTOR Y
C    - SET ERRBND TO THE BOUND THAT IS  SATISFIED  BY ||ERREST||, AND
C      HENCE IS INTENDED TO BE SATISFIED BY ||LE||, AT THIS STEP.
C    - SET ERREST  TO THE  LOCAL ERROR ESTIMATE  VECTOR Y-Y*  DEFINED
C      ABOVE
C
C      (SEE   [4]   FOR   DISCUSSION  AND  NOTE  THAT X,Y ARE IGNORED
C      UNLESS  OPT.GE.2,  ERRBND   IS  IGNORED  UNLESS  OPT.GE.3, AND
C      ERREST IS IGNORED UNLESS OPT.GE.4.)
C
C    - CALL STATS(X,Y,ERRBND,ERREST)
C    - EXIT IF X .GE.  XEND.
C - ENDLOOP
C
C
C ON NORMAL EXIT X,Y MUST HOLD XEND AND THE SOLUTION AT XEND.   ON  EXIT
C BECAUSE  SOLVER  WAS  IN TROUBLE, X MUST HOLD THE FINAL POINT REACHED.
C ON AN EXIT FORCED BY STATS, X MUST HOLD XEND.
C
C
C
C
C
C
C 4. CONTROLLING THE DESTINATION OF OUTPUT
C    ----------- --- ----------- -- ------
C
C THE UNIT NUMBER ON WHICH THE PACKAGE WRITES ITS OUTPUT  IS  SET  BY  A
C CALL  TO ONE OF THE PACKAGE ROUTINES, AND YOU CAN FIND OUT WHAT IT IS,
C BY PUTTING THE STATEMENT
C
C       IOUT = CONST(3)
C
C IN YOUR MAIN PROGRAM.  PROBABLY OUTPUT WILL DEFAULT TO YOUR  TERMINAL,
C WHICH  IS  GOOD  FOR DEBUGGING.  FOR MORE SERIOUS WORK YOU MAY WANT TO
C SEND OUTPUT TO A FILE.  THE STATEMENTS
C
C       IOUT = CONST(3)
C       OPEN(IOUT, FILE=FILENAME, OTHER OPTIONS..  )
C
C WILL DO THIS FOR YOU, ASSUMING YOUR  FORTRAN   I/O  IS CONSISTENT WITH
C THE  1977 STANDARD.
C
C
C
C 5. THE ROUTINES FCN, PDERV
C    --- -------- ---- -----
C
C THE SPECIFICATION OF FCN IS
C         SUBROUTINE FCN(X,Y,YP)
C         DOUBLE PRECISION X,Y(20),YP(20)
C
C ON ENTRY X HOLDS THE INDEPENDENT VARIABLE AND Y HOLDS  THE  VECTOR  OF
C DEPENDENT  VARIABLES.   ON EXIT YP HOLDS THE VECTOR OF DERIVATIVES FOR
C THE PROBLEM BEING SOLVED (SELECTED BY A SWITCH IN COMMON).
C
C THE SPECIFICATION FOR PDERV IS
C         SUBROUTINE PDERV(X,Y,DY)
C         DOUBLE PRECISION X,Y(20),DY(400)
C
C WHERE X AND Y ARE AS FOR FCN.  THE ENTRIES OF THE JACOBIAN MATRIX  ARE
C STORED  IN THE FIRST N**2 ELEMENTS OF DY WITH DF(I)/DY(J) BEING STORED
C IN ELEMENT I+(J-1)*N.  THUS DY MAY BE TREATED AS IF IT WERE DECLARED
C         DIMENSION DY(N,N)
C
C 6. FUNCTION, JACOBIAN AND LU DECOMPOSITION COUNTS
C    --------- -------- --- -- ------------- ------
C
C THESE ARE MAINTAINED IN THREE COMMON VARIABLES:
C         COMMON/STCOM6/NFCN,NJAC,NLUD
C
C EACH CALL TO FCN, PDERV AND DDCOMP INCREMENTS NFCN, NJAC AND NLUD BY 1
C RESPECTIVELY.   IF  SOLVER  USES ITS OWN LINEAR ALGEBRA ROUTINES IT IS
C THE USER'S RESPONSIBILITY TO INSERT THE ABOVE COMMON AT AN APPROPRIATE
C PLACE  IN  HIS  CODE  AND  SET  NLUD  CORRECTLY.   THIS MAY BE DONE BY
C INCREMENTING IT AT EACH LU DECOMPOSITION CALL, OR BY SETTING IT  EQUAL
C TO AN INDEPENDENTLY MAINTAINED COUNT BEFORE EXIT FROM METHOD.  SIMILAR
C COMMENTS APPLY TO NJAC IF SOLVER DOES ITS OWN JACOBIAN EVALUATION (EG.
C BY  NUMERICAL DIFFERENCING).  IF A METHOD DOES NOT USE JACOBIANS, NJAC
C AND NLUD MAY BE USED FOR GATHERING SOME OTHER STATISTICS.
C
C 7. THE DUMMY STDTST FOR DEBUGGING
C    --- ----- ------ --- ---------
C
C TO THE USER:
C
C THIS WILL PROBABLY BE IMPLEMENTED  AT  YOUR  SITE  AS  A  SOURCE  FILE
C CONTAINING  CUT-DOWN  VERSIONS  OF STDTST AND STATS (AND OTHER PACKAGE
C ROUTINES OF NO CONCERN TO THE  USER).   THIS  FILE  MAKES  A  COMPLETE
C PROGRAM WHEN COMBINED WITH THE STPROB FILE AND THE USER'S MAIN PROGRAM
C AND METHOD (AND OF COURSE SOLVER).  THE  CUT-DOWN  ROUTINES  HAVE  THE
C SAME CALLING SEQUENCE AS THE PROPER ONES.
C
C THE RESULTING PROGRAM USES METHOD TO SOLVE THE FIRST PROBLEM SPECIFIED
C IN IDLIST, AT THE FIRST TOLERANCE SPECIFIED IN TOL.  IT WILL PRINT OUT
C THE VALUES OF THE ARGUMENTS PASSED BY METHOD TO STATS AND ALSO THE  LU
C DECOMP  COUNTER  NLUD,  FOR  5 STEPS, AND THEN SET X = XEND.  THE USER
C SHOULD CHECK THAT THE VALUES OF X, Y, ERREST, ERRBND LOOK RIGHT;  THAT
C X = XEND  FORCES  TERMINATION  AS  IT  SHOULD;  AND THAT NLUD IS BEING
C COUNTED UP CORRECTLY.
C
C FEEL FREE TO MODIFY THESE ROUTINES TO WORK INTERACTIVELY.
C
C TO THE PERSON IMPLEMENTING THE PACKAGE:
C
C PLEASE MODIFY THESE ROUTINES TO MATCH THE USER ENVIRONMENT.
C
C
C
C 8. IMPLEMENTATION NOTES
C    -------------- -----
C
C  8.1.  MACHINE-DEPENDENT CONSTANTS
C
C     THESE  ARE   ISOLATED  IN  THE  ROUTINE   CONST   WHICH   HAS  THE
C     SPECIFICATION   REAL  FUNCTION CONST(I).  YOU MUST SET THE ARRAY C
C     AND THE STRING MCNAME IN THE DATA STATEMENT:
C
C     C(1)   APPROXIMATELY  THE  DOUBLE  PRECISION  UNIT  ROUNDOFF, USED
C            IN STATS AND TRUE.
C     C(2)   A NUMBER NEAR THE UNDERFLOW THRESHOLD, USED IN TRUE.
C     C(3)   THE  STANDARD  OUTPUT  UNIT NUMBER IOUT, USED IN STDTST AND
C            TRUE.   WE SUGGEST OUTPUT BE TO THE TERMINAL BY DEFAULT.
C     C(4)   TSTTIM, USED IN CNTROL (SEE CLOCK ROUTINE).
C     MCNAME TITLING  INFORMATION  FOR PRINTOUT, GIVING THE  NAME OF THE
C            COMPUTER AND OPERATING SYSTEM.
C
C     IN ADDITION, A CALL OF CONST(0) (EXECUTED NEAR THE TOP OF  STDTST)
C     IS  INTENDED  TO  INVOKE  CALLS  TO  SYSTEM  ROUTINES  TO SUPPRESS
C     UNDERFLOW  REPORTING  (WHICH  MAY  SPOIL  THE  APPEARANCE  OF  THE
C     OUTPUT), ETC.
C
C     IT MAY BE CONVENIENT  TO  ALLOW  IOUT  (C(3)  ABOVE)  TO BE SET BY
C     INTERACTION WITH THE USER AT THIS POINT.
C
C  8.2.  CLOCK ROUTINE
C
C     IF   IT  IS  DECIDED  TO  IMPLEMENT  THE  TIMING  FACILITIES,  THE
C     IMPLEMENTER  SHOULD  PROVIDE  A  TIMING ROUTINE  WHICH  CALLS  THE
C     SYSTEM CLOCK AND HAS THE SPECIFICATION
C          REAL FUNCTION CLOCK(S)
C          REAL(S)
C     IT SHOULD BE SUCH THAT IT IS 'RESET TO ZERO' BY THE STATEMENT
C          S = CLOCK(0.0)
C     AND (AS LONG AS S IS LEFT ALONE) CAN THEN BE 'READ'  AS  OFTEN  AS
C     DESIRED BY STATEMENTS LIKE
C          TIME = CLOCK(S)
C     WHICH SETS TIME TO THE NUMBER OF SECONDS OF PROCESSOR  TIME  SINCE
C     CLOCK WAS 'RESET'.
C
C     THE LARGER IS  THE  VALUE  OF  TSTTIM  (IE.   CONST(4))  THE  MORE
C     ACCURATE,  AND EXPENSIVE, IS THE TIMING PROCESS.  IT SHOULD BE SET
C     TO A VALUE REFLECTING THE SPEED OF THE HARDWARE AND THE RESOLUTION
C     OF  THE  SYSTEM CLOCK.  WE CANNOT GIVE MUCH GUIDANCE HERE, AND OUR
C     EXPERIENCE IS THAT TIMINGS INEVITABLY VARY SIGNIFICANTLY FROM  RUN
C     TO RUN ON A TIME-SHARED COMPUTING SYSTEM.
C
C     IF TIMING IS LEFT UNIMPLEMENTED, GIVE  TSTTIM  THE  VALUE ZERO AND
C     LEAVE THE TIMING DATA IN IVALU AS ALL ZERO  TO CAUSE ALL VALUES OF
C     TIMING STATISTICS TO BE PRINTED OUT AS ZERO.
C
C  8.3.  THE TIMING DATA IN IVALU
C
C     ROUTINE IVALU  CONTAINS VALUES OF  THE  QUANTITIES  FCNTIM, DRVTIM
C     AND LUDTIM  FOR   EACH  PROBLEM: THESE ARE THE  COST  OF  ONE CALL
C     TO  FCN AS MEASURED BY  CLOCK,  AND  ARE  USED  IN  COMPUTING  THE
C     "OVERHEAD"   STATISTICS.     THEY   SHOULD   BE   RECOMPUTED   FOR
C     ANOTHER MACHINE.   THE  UTILITY  PROGRAM  STGTIM PROVIDED WITH THE
C     PACKAGE,   WHEN   SUPPLIED  WITH  A  CLOCK  ROUTINE,   CAN  EITHER
C     PRODUCE A COMPLETE  REVISED  IVALU  FILE, OR FOR SELECTED PROBLEMS
C     WILL PRODUCE BLOCKS OF OUTPUT OF THE FORM
C
C     C PROBLEM XX
C           FCNTIM = ...
C           JACTIM = ...
C           LUDTIM = ...
C
C     SUITABLE FOR INCLUSION IN THE TEXT OF IVALU.
C
C
C  8.4.  ADDING EXTRA PROBLEMS
C
C     SAY YOU WISH TO ADD THREE EXTRA PROBLEMS TO CLASS B  OF  THE  SET.
C     THEY  WILL  THEN  BE  CALLED  B6,  B7  AND B8 (FOR THE SAKE OF THE
C     CHECKING ROUTINE PARCHK THEY  MUST  FOLLOW  CONSECUTIVELY  ON  THE
C     EXISTING  PROBLEM-IDS).   THEIR NUMERIC CODES WHICH YOU SPECIFY IN
C     THE IDLIST ARGUMENT OF STDTST WILL THEN BE 26, 27, 28.   YOU  NEED
C     TO BE AWARE THAT THE INTERNAL CODE, PUT IN VARIABLE ID AND USED IN
C     FCN, IVALU AND EVALU TO SELECT THE CORRECT SECTION  OF  SUBROUTINE
C     TO EXECUTE, IS 10 LESS THAN THIS, IE.  16, 17 OR 18.
C
C     THE  STEPS  INVOLVED  ARE:
C     A)  CODE THE  DEFINITION  OF   THE   DIFFERENTIAL   EQUATIONS   AT
C         THE APPROPRIATE PLACE IN FCN.  CHANGE THE COMPUTED GOTO AT THE
C         HEAD  OF  FCN SO THAT THE VALUE ID = 16, 17 OR 18 GIVES A JUMP
C         TO  THE CORRECT PLACE.
C     B)  CODE THE  INITIAL  VALUES,  "TRUE"  FINAL   VALUES  AND  OTHER
C         DATA INTO  THE  APPROPRIATE  PLACES  IN IVALU  AND  EVALU IN A
C         SIMILAR  WAY.   THE  TRUE  FINAL  VALUES  SHOULD  PROBABLY  BE
C         COMPUTED   BY   AN  INTEGRATOR   USING   HIGHER   THAN  DOUBLE
C         PRECISION, BUT THE ONLY CONSEQUENCE OF SLIGHT  INACCURACIES IS
C         TO  AFFECT  THE  END  PT   GLB ERR  STATISTIC   AT   STRINGENT
C         TOLERANCES.  AT THIS STAGE IGNORE THE  WEIGHTS  W(I)  AND  THE
C         TIMING DATA FCNTIM.
C     C)  IN THE ARGUMENT-CHECKING  ROUTINE   PARCHK  CHANGE  THE   DATA
C         STATEMENT  WHICH DEFINES ARRAY NSYSTM,  TO INDICATE THAT CLASS
C         B NOW HAS 8 MEMBERS.  (IE.   CHANGE ITS SECOND ELEMENT FROM  5
C         TO 8.)
C     D)  RUN THE  UTILITY  PROGRAM  STGWT.F ON THE TAPE TO COMPUTE  THE
C         VALUES   OF  THE  WEIGHTS  W(I).    SIMILARLY   RUN   STGTIM.F
C         TO DETERMINE FCNTIM ETC. FOR YOUR PROBLEMS.
C
C ADDING  AN  ENTIRE  NEW  PROBLEM CLASS IS  NO  MORE  DIFFICULT.   NOTE
C THAT  IT  INVOLVES  INCREASING  THE   VALUE   OF   NCLASS  IN THE DATA
C STATEMENT AND THE LENGTH OF NSYSTM IN THE  DIMENSIONING   STATEMENT IN
C PARCHK; ALSO CHECK THE STRING IDCLAS  IN  STDTST HAS ENOUGH LETTERS IN
C IT.
C
C  8.5.  OTHER STATISTICS TO PRINT
C
C STATISTICS  WHICH ARE GATHERED BUT DO  NOT  APPEAR   IN   THE   OUTPUT
C TABLES  INCLUDE   NSTART,  NSTL  AND  TRUTIM.  THEY ARE DEFINED IN THE
C DESCRIPTION   OF   COMMON  /STCOM3/  BELOW.   NSTART   ASSESSES    THE
C EFFICIENCY  OF  THE  STARTING  PHASE  OF  A CODE AND MAY BE OF GENERAL
C INTEREST.  TRUTIM IS OF USE  IF  YOU  ARE  TROUBLED  BY  THE OVERHEADS
C OF CALLS TO TRUE WITH OPT  >=  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<P<1 BECOMES '  .',
C  P OUTSIDE RANGE BECOMES '***'
CERR  CHARACTER*1 DIG(0:9)/'0','1','2','3','4','5','6','7','8','9'/
C     .. Scalar Arguments ..
      REAL                      P
C     .. Local Scalars ..
      INTEGER                   I, J
C     .. Local Arrays ..
      CHARACTER                 DIG(0:9)
C     .. Data statements ..
      DATA                      DIG/'0', '1', '2', '3', '4', '5', '6',
     *                          '7', '8', '9'/
C     .. Executable Statements ..
      DIG(0) = ' '
      IF (P.LT.0 .OR. P.GT.1) THEN
         STR3 = '***'
      ELSE IF (P.EQ.0.) THEN
         STR3 = '   '
      ELSE IF (P.LT..01) THEN
         STR3 = '  .'
      ELSE
         DO 20 J = 1, 3
            I = P
            P = P - I
            STR3(J:J) = DIG(I)
            IF (I.GT.0) DIG(0) = '0'
            P = 10.*P
   20    CONTINUE
      END IF
      RETURN
      END
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<INFINITY
C         THUS   FORMING  12X12  PIGEONHOLES.  EACH   INTEGRATION   STEP
C         CONTRIBUTES  A DATA POINT (R1,R2)  WHICH  IS  ENTERED  IN  ONE
C         PIGEONHOLE. THE  COUNTS  OF  THE  NUMBER  OF  ENTRIES  IN EACH
C         PIGEONHOLE ARE EXPRESSED AS INTEGER PERCENTAGES OF  THE  TOTAL
C         NUMBER  OF INTEGRATION STEPS AND PRINTED OUT IN A 12X12 ARRAY,
C         ZERO ENTRIES BEING LEFT BLANK,  AND  POSITIVE  VALUES  BELOW 1
C         BEING SHOWN BY A DOT '.'.
C
C         STEP-LUMPING (SEE [4]) IS DEEMED TO MAKE THIS ANALYSIS USELESS
C         SO  STATISTICS ARE ONLY GATHERED ON UNLUMPED STEPS. IT  IS  AT
C         PRESENT ALSO  NOT  CONSIDERED USEFUL TO PRODUCE SUMMARY TABLES
C         OVER SEVERAL PROBLEMS (AND WOULD BE COSTLY IN ARRAY SPACE).
C
C
C NORMEF  ONE  OF  0   1   OR   2   ,   SELECTS   NORMALIZED  EFFICIENCY
C         STATISTICS.    THESE  TRY  TO  COMPENSATE  FOR  THE  FACT THAT
C         ACHIEVED  ACCURACY  MAY  BE MUCH HIGHER OR LOWER   THAN   THAT
C         REQUESTED  BY  TOL, AND THIS RELATIONSHIP IS VERY PROBLEM- AND
C         METHOD- DEPENDENT.  FOR EACH PROBLEM, A LEAST-SQUARES  FIT  IS
C         MADE OF LOG10(ACTUAL ERROR) VS LOG10(TOL) AND USED TO ESTIMATE
C         WHAT THE VARIOUS COST STATISTICS WOULD BE FOR AN ACTUAL  ERROR
C         OF 10**N.  THIS IS ACHIEVED BY INTERPOLATION, FOR THOSE N SUCH
C         THAT 10**N LIES WITHIN THE RANGE OF ACCURACIES  ACHIEVED  WITH
C         THE USER-SPECIFIED TOLERANCES.
C     0   NO NORMALIZED STATISTICS
C     1   NORMALIZED STATISTICS ARE PRODUCED TAKING THE  'ACTUAL  ERROR'
C         USED IN THE LEAST SQUARES FIT TO BE THE ENDPOINT GLOBAL ERROR.
C     2   NORMALIZED STATISTICS ARE PRODUCED TAKING  'ACTUAL  ERROR'  AS
C         THE  MAXIMUM  GLOBAL ERROR OVER THE RANGE.  N.B.  IN THIS CASE
C         OPT MUST BE AT LEAST 2.
C
C NRMTYP  ONE OF 1, 2  OR 3, SELECTS THE NORM USED IN ASSESSING THE SIZE
C         OF LOCAL AND GLOBAL ERRORS. IT SHOULD BE CHOSEN BY THE USER TO
C         AGREE WITH THE NORM USED IN SOLVER. WE OFFER:
C     1   MAX-NORM.
C     2   2-NORM (EUCLIDEAN NORM).
C     3   R.M.S. NORM, THAT IS (2-NORM OF X)/SQRT(N) FOR AN N-VECTOR X.
C
C TOL     (INPUT) REAL ARRAY, HOLDS LIST OF UP TO 10  TOLERANCES  TO  BE
C         USED,  IN  STRICTLY  DECREASING  ORDER,  WITH 0 AS TERMINATOR.
C         EACH PROBLEM IS INTEGRATED AT EACH TOLERANCE IN TURN.
C         EXAMPLE:  IN CALLING PROGRAM
C                   REAL TOL(11)
C                   DATA TOL/1E-1,1E-3,1E-5,1E-7,7*0E0/
C         REQUESTS THE FOUR TOLERANCES .1, .001, .00001, .0000001.
C
C IDLIST  (INPUT) INTEGER ARRAY, HOLDS LIST OF GROUPS OF  PROBLEMS,  AND
C         SPECIFIES  FOR  EACH  ONE  WHETHER  IT  IS TO BE INTEGRATED IN
C         SCALED OR UNSCALED  FORM  (SEE  GENERAL  NOTES  ABOVE).   EACH
C         PROBLEM  IS SPECIFIED BY A NUMERIC CODE, 11 TO 14 FOR PROBLEMS
C         A1 TO A4, 21 TO 25 FOR B1 TO B5  ETC.   A  ZERO  TERMINATES  A
C         GROUP AND TWO ZEROS TERMINATE THE LIST OF GROUPS.
C         IF THE PROBLEM CODE IS GIVEN A NEGATIVE SIGN,  THE  SYSTEM  IS
C         INTEGRATED  IN  UNSCALED  FORM;  IF A POSITIVE SIGN, IN SCALED
C         FORM.
C         EXAMPLE:  IN CALLING PROGRAM
C                   INTEGER IDLIST(7)
C                   DATA IDLIST/11,22,0,-31,-51,0,0/
C         SPECIFIES GROUP 1 CONSISTING OF PROBLEMS A1,B2 AND GROUP 2  OF
C         PROBLEMS  C1,E1.  THE FIRST TWO ARE TO BE SOLVED IN THE SCALED
C         FORM AND THE LAST TWO  IN  UNSCALED  FORM.
C
C         THE TOTAL LENGTH OF THE LIST INCLUDING ZEROS MUST BE  AT  MOST
C         60 ITEMS.
C
C FLAG
C         (OUTPUT) REAL.  A NONZERO VALUE INDICATES  THAT  THE  CALL  TO
C         STDTST  WAS  ABORTED BECAUSE OF ARGUMENT ERRORS, IN WHICH CASE
C         THE VALUES OF THE DECIMAL DIGITS OF FLAG INDICATE THE ERROR(S)
C         THAT HAVE OCCURRED, AS FOLLOWS:
C           1:  OPT INVALID.
C           2:  NORMEF INVALID.
C           3:  NORMEF = 2 WAS REQUESTED WITH OPT = 1.
C           4:  A NEGATIVE  TOLERANCE  WAS  SUPPLIED,  OR THE  LIST  OF
C               TOLERANCES WAS NOT IN DECREASING ORDER.
C           5:  THE LIST OF TOLERANCES WAS EMPTY OR NOT TERMINATED BY A
C               ZERO.
C           6:  AN INVALID PROBLEM-ID WAS FOUND IN IDLIST.
C           7:  THE LIST  OF  GROUPS  IN  IDLIST  IS  EMPTY  OR  IS NOT
C               TERMINATED  BY  TWO  ZEROS OR HAS MORE THAN THE MAXIMUM
C               ALLOWED NUMBER (6) OF GROUPS.
C           8:  NRMTYP INVALID.
C         EG.  A VALUE FLAG = 0.245E 03 INDICATES THAT ERRORS 2, 4 AND 5
C         IN  THE  ABOVE  LIST  HAVE  OCCURRED.  ITS VALUE IF NONZERO IS
C         PRINTED BY STDTST ANYWAY, BUT FLAG IS MEANT TO BE INSPECTED IF
C         FURTHER  ACTION  OF  THE  MAIN PROGRAM DEPENDS ON A SUCCESSFUL
C         CALL TO STDTST.
C
C
C 3. INTERFACE ROUTINE METHOD
C    --------- ------- ------
C
C THIS INVOKES THE CODE BEING TESTED, CALL IT SOLVER.  THE SPECIFICATION
C IS
C         SUBROUTINE METHOD(N,X,Y,XEND,TOL,HMAX,HSTART)
C         INTEGER N
C         DOUBLE PRECISION X,Y(N),XEND,TOL,HMAX,HSTART
C         EXTERNAL FCN, PDERV
C
C METHOD IS TO BE WRITTEN BY THE USER AS A SIMPLE INTEGRATOR TO  ADVANCE
C THE  SOLUTION OF N DIFFERENTIAL EQUATIONS FROM THE INITIAL VALUES HELD
C IN X,Y UP TO XEND, WITH AN UNWEIGHTED ABSOLUTE ERROR CONTROL  OF  TOL.
C HMAX  IS  A  RECOMMENDED  MAXIMUM STEPSIZE AND HSTART IS A RECOMMENDED
C INITIAL STEPSIZE.  IF SOLVER CAN MAKE USE OF THESE TWO PARAMETERS, THE
C STATISTICS WILL PROBABLY BE MORE FAVORABLE AND RELIABLE, BUT THEIR USE
C IS NOT CRUCIAL.
C
C THE DERIVATIVES, AND THE ANALYTICAL JACOBIAN MATRIX,  OF  THE  PROBLEM
C ARE  COMPUTED  BY  PACKAGE  ROUTINES FCN AND PDERV RESPECTIVELY.  THUS
C CERTAINLY FCN, AND IN MOST CASES PDERV, MUST BE ARGUMENTS  TO  SOLVER,
C AND THEY MUST BE DECLARED EXTERNAL IN METHOD.
C
C METHOD SHOULD CALL SOLVER IN ONE-STEP MODE  SO  THAT  A  CALL  TO  THE
C PACKAGE  ROUTINE  STATS  CAN  BE  MADE AFTER EACH SUCCESSFUL STEP.  IF
C SOLVER DOES NOT HAVE THIS FACILITY, SOLVER MUST HAVE A CALL  TO  STATS
C INSERTED AT THE APPROPRIATE POINT IN THE CODE.
C
C SOME  CALLS  TO  METHOD  ARE  INTENDED  TO  BE  ABORTED  AFTER  A  FEW
C INTEGRATION  STEPS  BY  THE  STATS CALL SETTING X = XEND.  THUS A TEST
C SHOULD BE MADE AFTER EACH CALL TO STATS, OF THE FORM
C         IF STATS HAS SET X = XEND THEN EXIT.
C
C NB:  IF THE ACTUAL X  ARGUMENT  TO  STATS  IS  DIFFERENT  FROM  THE  X
C ARGUMENT  OF METHOD (WHICH MAY BE NECESSARY WITH SOME SOLVERS), ENSURE
C THAT THE X ARGUMENT OF METHOD IS SET TO XEND  BEFORE  EXIT,  ELSE  THE
C PACKAGE WILL REPORT 'METHOD FAILED TO START'.
C
C THE ALGORITHM FOR METHOD SHOULD THUS BE OF THE FORM:
C - DECLARE ALL ARGUMENTS AND WORKSPACE EXPECTED BY SOLVER
C - SET APPROPRIATE OPTIONS  INCLUDING  ABSOLUTE  ERROR  CONTROL  AND
C    ONE-STEP MODE
C - INITIALIZE EXTRA ARGUMENTS IF REQUIRED
C - FOR EACH SUCCESSFUL STEP DO
C    - CALL SOLVER( ...  ,FCN,PDERV, ...  )
C      EXIT IF SOLVER IS IN TROUBLE.
C    - SET X,Y TO THE JUST COMPUTED MESHPOINT X AND SOLUTION VECTOR Y
C    - SET ERRBND TO THE BOUND THAT IS  SATISFIED  BY ||ERREST||, AND
C      HENCE IS INTENDED TO BE SATISFIED BY ||LE||, AT THIS STEP.
C    - SET ERREST  TO THE  LOCAL ERROR ESTIMATE  VECTOR Y-Y*  DEFINED
C      ABOVE
C
C      (SEE   [4]   FOR   DISCUSSION  AND  NOTE  THAT X,Y ARE IGNORED
C      UNLESS  OPT.GE.2,  ERRBND   IS  IGNORED  UNLESS  OPT.GE.3, AND
C      ERREST IS IGNORED UNLESS OPT.GE.4.)
C
C    - CALL STATS(X,Y,ERRBND,ERREST)
C    - EXIT IF X .GE.  XEND.
C - ENDLOOP
C
C
C ON NORMAL EXIT X,Y MUST HOLD XEND AND THE SOLUTION AT XEND.   ON  EXIT
C BECAUSE  SOLVER  WAS  IN TROUBLE, X MUST HOLD THE FINAL POINT REACHED.
C ON AN EXIT FORCED BY STATS, X MUST HOLD XEND.
C
C
C
C
C
C
C 4. CONTROLLING THE DESTINATION OF OUTPUT
C    ----------- --- ----------- -- ------
C
C THE UNIT NUMBER ON WHICH THE PACKAGE WRITES ITS OUTPUT  IS  SET  BY  A
C CALL  TO ONE OF THE PACKAGE ROUTINES, AND YOU CAN FIND OUT WHAT IT IS,
C BY PUTTING THE STATEMENT
C
C       IOUT = CONST(3)
C
C IN YOUR MAIN PROGRAM.  PROBABLY OUTPUT WILL DEFAULT TO YOUR  TERMINAL,
C WHICH  IS  GOOD  FOR DEBUGGING.  FOR MORE SERIOUS WORK YOU MAY WANT TO
C SEND OUTPUT TO A FILE.  THE STATEMENTS
C
C       IOUT = CONST(3)
C       OPEN(IOUT, FILE=FILENAME, OTHER OPTIONS..  )
C
C WILL DO THIS FOR YOU, ASSUMING YOUR  FORTRAN   I/O  IS CONSISTENT WITH
C THE  1977 STANDARD.
C
C
C
C 5. THE ROUTINES FCN, PDERV
C    --- -------- ---- -----
C
C THE SPECIFICATION OF FCN IS
C         SUBROUTINE FCN(X,Y,YP)
C         DOUBLE PRECISION X,Y(20),YP(20)
C
C ON ENTRY X HOLDS THE INDEPENDENT VARIABLE AND Y HOLDS  THE  VECTOR  OF
C DEPENDENT  VARIABLES.   ON EXIT YP HOLDS THE VECTOR OF DERIVATIVES FOR
C THE PROBLEM BEING SOLVED (SELECTED BY A SWITCH IN COMMON).
C
C THE SPECIFICATION FOR PDERV IS
C         SUBROUTINE PDERV(X,Y,DY)
C         DOUBLE PRECISION X,Y(20),DY(400)
C
C WHERE X AND Y ARE AS FOR FCN.  THE ENTRIES OF THE JACOBIAN MATRIX  ARE
C STORED  IN THE FIRST N**2 ELEMENTS OF DY WITH DF(I)/DY(J) BEING STORED
C IN ELEMENT I+(J-1)*N.  THUS DY MAY BE TREATED AS IF IT WERE DECLARED
C         DIMENSION DY(N,N)
C
C 6. FUNCTION, JACOBIAN AND LU DECOMPOSITION COUNTS
C    --------- -------- --- -- ------------- ------
C
C THESE ARE MAINTAINED IN THREE COMMON VARIABLES:
C         COMMON/STCOM6/NFCN,NJAC,NLUD
C
C EACH CALL TO FCN, PDERV AND DDCOMP INCREMENTS NFCN, NJAC AND NLUD BY 1
C RESPECTIVELY.   IF  SOLVER  USES ITS OWN LINEAR ALGEBRA ROUTINES IT IS
C THE USER'S RESPONSIBILITY TO INSERT THE ABOVE COMMON AT AN APPROPRIATE
C PLACE  IN  HIS  CODE  AND  SET  NLUD  CORRECTLY.   THIS MAY BE DONE BY
C INCREMENTING IT AT EACH LU DECOMPOSITION CALL, OR BY SETTING IT  EQUAL
C TO AN INDEPENDENTLY MAINTAINED COUNT BEFORE EXIT FROM METHOD.  SIMILAR
C COMMENTS APPLY TO NJAC IF SOLVER DOES ITS OWN JACOBIAN EVALUATION (EG.
C BY  NUMERICAL DIFFERENCING).  IF A METHOD DOES NOT USE JACOBIANS, NJAC
C AND NLUD MAY BE USED FOR GATHERING SOME OTHER STATISTICS.
C
C 7. THE DUMMY STDTST FOR DEBUGGING
C    --- ----- ------ --- ---------
C
C TO THE USER:
C
C THIS WILL PROBABLY BE IMPLEMENTED  AT  YOUR  SITE  AS  A  SOURCE  FILE
C CONTAINING  CUT-DOWN  VERSIONS  OF STDTST AND STATS (AND OTHER PACKAGE
C ROUTINES OF NO CONCERN TO THE  USER).   THIS  FILE  MAKES  A  COMPLETE
C PROGRAM WHEN COMBINED WITH THE STPROB FILE AND THE USER'S MAIN PROGRAM
C AND METHOD (AND OF COURSE SOLVER).  THE  CUT-DOWN  ROUTINES  HAVE  THE
C SAME CALLING SEQUENCE AS THE PROPER ONES.
C
C THE RESULTING PROGRAM USES METHOD TO SOLVE THE FIRST PROBLEM SPECIFIED
C IN IDLIST, AT THE FIRST TOLERANCE SPECIFIED IN TOL.  IT WILL PRINT OUT
C THE VALUES OF THE ARGUMENTS PASSED BY METHOD TO STATS AND ALSO THE  LU
C DECOMP  COUNTER  NLUD,  FOR  5 STEPS, AND THEN SET X = XEND.  THE USER
C SHOULD CHECK THAT THE VALUES OF X, Y, ERREST, ERRBND LOOK RIGHT;  THAT
C X = XEND  FORCES  TERMINATION  AS  IT  SHOULD;  AND THAT NLUD IS BEING
C COUNTED UP CORRECTLY.
C
C FEEL FREE TO MODIFY THESE ROUTINES TO WORK INTERACTIVELY.
C
C TO THE PERSON IMPLEMENTING THE PACKAGE:
C
C PLEASE MODIFY THESE ROUTINES TO MATCH THE USER ENVIRONMENT.
C
C
C
C 8. IMPLEMENTATION NOTES
C    -------------- -----
C
C  8.1.  MACHINE-DEPENDENT CONSTANTS
C
C     THESE  ARE   ISOLATED  IN  THE  ROUTINE   CONST   WHICH   HAS  THE
C     SPECIFICATION   REAL  FUNCTION CONST(I).  YOU MUST SET THE ARRAY C
C     AND THE STRING MCNAME IN THE DATA STATEMENT:
C
C     C(1)   APPROXIMATELY  THE  DOUBLE  PRECISION  UNIT  ROUNDOFF, USED
C            IN STATS AND TRUE.
C     C(2)   A NUMBER NEAR THE UNDERFLOW THRESHOLD, USED IN TRUE.
C     C(3)   THE  STANDARD  OUTPUT  UNIT NUMBER IOUT, USED IN STDTST AND
C            TRUE.   WE SUGGEST OUTPUT BE TO THE TERMINAL BY DEFAULT.
C     C(4)   TSTTIM, USED IN CNTROL (SEE CLOCK ROUTINE).
C     MCNAME TITLING  INFORMATION  FOR PRINTOUT, GIVING THE  NAME OF THE
C            COMPUTER AND OPERATING SYSTEM.
C
C     IN ADDITION, A CALL OF CONST(0) (EXECUTED NEAR THE TOP OF  STDTST)
C     IS  INTENDED  TO  INVOKE  CALLS  TO  SYSTEM  ROUTINES  TO SUPPRESS
C     UNDERFLOW  REPORTING  (WHICH  MAY  SPOIL  THE  APPEARANCE  OF  THE
C     OUTPUT), ETC.
C
C     IT MAY BE CONVENIENT  TO  ALLOW  IOUT  (C(3)  ABOVE)  TO BE SET BY
C     INTERACTION WITH THE USER AT THIS POINT.
C
C  8.2.  CLOCK ROUTINE
C
C     IF   IT  IS  DECIDED  TO  IMPLEMENT  THE  TIMING  FACILITIES,  THE
C     IMPLEMENTER  SHOULD  PROVIDE  A  TIMING ROUTINE  WHICH  CALLS  THE
C     SYSTEM CLOCK AND HAS THE SPECIFICATION
C          REAL FUNCTION CLOCK(S)
C          REAL(S)
C     IT SHOULD BE SUCH THAT IT IS 'RESET TO ZERO' BY THE STATEMENT
C          S = CLOCK(0.0)
C     AND (AS LONG AS S IS LEFT ALONE) CAN THEN BE 'READ'  AS  OFTEN  AS
C     DESIRED BY STATEMENTS LIKE
C          TIME = CLOCK(S)
C     WHICH SETS TIME TO THE NUMBER OF SECONDS OF PROCESSOR  TIME  SINCE
C     CLOCK WAS 'RESET'.
C
C     THE LARGER IS  THE  VALUE  OF  TSTTIM  (IE.   CONST(4))  THE  MORE
C     ACCURATE,  AND EXPENSIVE, IS THE TIMING PROCESS.  IT SHOULD BE SET
C     TO A VALUE REFLECTING THE SPEED OF THE HARDWARE AND THE RESOLUTION
C     OF  THE  SYSTEM CLOCK.  WE CANNOT GIVE MUCH GUIDANCE HERE, AND OUR
C     EXPERIENCE IS THAT TIMINGS INEVITABLY VARY SIGNIFICANTLY FROM  RUN
C     TO RUN ON A TIME-SHARED COMPUTING SYSTEM.
C
C     IF TIMING IS LEFT UNIMPLEMENTED, GIVE  TSTTIM  THE  VALUE ZERO AND
C     LEAVE THE TIMING DATA IN IVALU AS ALL ZERO  TO CAUSE ALL VALUES OF
C     TIMING STATISTICS TO BE PRINTED OUT AS ZERO.
C
C  8.3.  THE TIMING DATA IN IVALU
C
C     ROUTINE IVALU  CONTAINS VALUES OF  THE  QUANTITIES  FCNTIM, DRVTIM
C     AND LUDTIM  FOR   EACH  PROBLEM: THESE ARE THE  COST  OF  ONE CALL
C     TO  FCN AS MEASURED BY  CLOCK,  AND  ARE  USED  IN  COMPUTING  THE
C     "OVERHEAD"   STATISTICS.     THEY   SHOULD   BE   RECOMPUTED   FOR
C     ANOTHER MACHINE.   THE  UTILITY  PROGRAM  STGTIM PROVIDED WITH THE
C     PACKAGE,   WHEN   SUPPLIED  WITH  A  CLOCK  ROUTINE,   CAN  EITHER
C     PRODUCE A COMPLETE  REVISED  IVALU  FILE, OR FOR SELECTED PROBLEMS
C     WILL PRODUCE BLOCKS OF OUTPUT OF THE FORM
C
C     C PROBLEM XX
C           FCNTIM = ...
C           JACTIM = ...
C           LUDTIM = ...
C
C     SUITABLE FOR INCLUSION IN THE TEXT OF IVALU.
C
C
C  8.4.  ADDING EXTRA PROBLEMS
C
C     SAY YOU WISH TO ADD THREE EXTRA PROBLEMS TO CLASS B  OF  THE  SET.
C     THEY  WILL  THEN  BE  CALLED  B6,  B7  AND B8 (FOR THE SAKE OF THE
C     CHECKING ROUTINE PARCHK THEY  MUST  FOLLOW  CONSECUTIVELY  ON  THE
C     EXISTING  PROBLEM-IDS).   THEIR NUMERIC CODES WHICH YOU SPECIFY IN
C     THE IDLIST ARGUMENT OF STDTST WILL THEN BE 26, 27, 28.   YOU  NEED
C     TO BE AWARE THAT THE INTERNAL CODE, PUT IN VARIABLE ID AND USED IN
C     FCN, IVALU AND EVALU TO SELECT THE CORRECT SECTION  OF  SUBROUTINE
C     TO EXECUTE, IS 10 LESS THAN THIS, IE.  16, 17 OR 18.
C
C     THE  STEPS  INVOLVED  ARE:
C     A)  CODE THE  DEFINITION  OF   THE   DIFFERENTIAL   EQUATIONS   AT
C         THE APPROPRIATE PLACE IN FCN.  CHANGE THE COMPUTED GOTO AT THE
C         HEAD  OF  FCN SO THAT THE VALUE ID = 16, 17 OR 18 GIVES A JUMP
C         TO  THE CORRECT PLACE.
C     B)  CODE THE  INITIAL  VALUES,  "TRUE"  FINAL   VALUES  AND  OTHER
C         DATA INTO  THE  APPROPRIATE  PLACES  IN IVALU  AND  EVALU IN A
C         SIMILAR  WAY.   THE  TRUE  FINAL  VALUES  SHOULD  PROBABLY  BE
C         COMPUTED   BY   AN  INTEGRATOR   USING   HIGHER   THAN  DOUBLE
C         PRECISION, BUT THE ONLY CONSEQUENCE OF SLIGHT  INACCURACIES IS
C         TO  AFFECT  THE  END  PT   GLB ERR  STATISTIC   AT   STRINGENT
C         TOLERANCES.  AT THIS STAGE IGNORE THE  WEIGHTS  W(I)  AND  THE
C         TIMING DATA FCNTIM.
C     C)  IN THE ARGUMENT-CHECKING  ROUTINE   PARCHK  CHANGE  THE   DATA
C         STATEMENT  WHICH DEFINES ARRAY NSYSTM,  TO INDICATE THAT CLASS
C         B NOW HAS 8 MEMBERS.  (IE.   CHANGE ITS SECOND ELEMENT FROM  5
C         TO 8.)
C     D)  RUN THE  UTILITY  PROGRAM  STGWT.F ON THE TAPE TO COMPUTE  THE
C         VALUES   OF  THE  WEIGHTS  W(I).    SIMILARLY   RUN   STGTIM.F
C         TO DETERMINE FCNTIM ETC. FOR YOUR PROBLEMS.
C
C ADDING  AN  ENTIRE  NEW  PROBLEM CLASS IS  NO  MORE  DIFFICULT.   NOTE
C THAT  IT  INVOLVES  INCREASING  THE   VALUE   OF   NCLASS  IN THE DATA
C STATEMENT AND THE LENGTH OF NSYSTM IN THE  DIMENSIONING   STATEMENT IN
C PARCHK; ALSO CHECK THE STRING IDCLAS  IN  STDTST HAS ENOUGH LETTERS IN
C IT.
C
C  8.5.  OTHER STATISTICS TO PRINT
C
C STATISTICS  WHICH ARE GATHERED BUT DO  NOT  APPEAR   IN   THE   OUTPUT
C TABLES  INCLUDE   NSTART,  NSTL  AND  TRUTIM.  THEY ARE DEFINED IN THE
C DESCRIPTION   OF   COMMON  /STCOM3/  BELOW.   NSTART   ASSESSES    THE
C EFFICIENCY  OF  THE  STARTING  PHASE  OF  A CODE AND MAY BE OF GENERAL
C INTEREST.  TRUTIM IS OF USE  IF  YOU  ARE  TROUBLED  BY  THE OVERHEADS
C OF CALLS TO TRUE WITH OPT  >=  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<P<1 BECOMES '  .',
C  P OUTSIDE RANGE BECOMES '***'
CERR  CHARACTER*1 DIG(0:9)/'0','1','2','3','4','5','6','7','8','9'/
C     .. Scalar Arguments ..
      REAL                      P
C     .. Local Scalars ..
      INTEGER                   I, J
C     .. Local Arrays ..
      CHARACTER                 DIG(0:9)
C     .. Data statements ..
      DATA                      DIG/'0', '1', '2', '3', '4', '5', '6',
     *                          '7', '8', '9'/
C     .. Executable Statements ..
      DIG(0) = ' '
      IF (P.LT.0 .OR. P.GT.1) THEN
         STR3 = '***'
      ELSE IF (P.EQ.0.) THEN
         STR3 = '   '
      ELSE IF (P.LT..01) THEN
         STR3 = '  .'
      ELSE
         DO 20 J = 1, 3
            I = P
            P = P - I
            STR3(J:J) = DIG(I)
            IF (I.GT.0) DIG(0) = '0'
            P = 10.*P
   20    CONTINUE
      END IF
      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 ..
      DOUBLE PRECISION TOL, X, XEND
      INTEGER         IND, N, NDIM
C     .. Array Arguments ..
      DOUBLE PRECISION 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 ..
      DOUBLE PRECISION 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 ..
      DOUBLE PRECISION COEF(10), CTMP(10), POEF(10), PTMP(10)
C     .. External Functions ..
      DOUBLE PRECISION STEP
      REAL            CONST
      EXTERNAL        STEP, CONST
C     .. External Subroutines ..
      EXTERNAL        COEFF, DDCOMP, DSOLVE, NEWSTP
C     .. Intrinsic Functions ..
      INTRINSIC       DABS, DLOG10, DMAX1, DMIN1, DSIGN, DSQRT, 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.D0 .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.D0
   40 CONTINUE
      GO TO 140
   60 CONTINUE
      DO 80 I = 1, 5
         INF(I) = IABS(INF(I))
         C(I) = DABS(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) = DABS(C(I+20))
  100 CONTINUE
  120 CONTINUE
  140 CONTINUE
      C(6) = CONST(1)
      C(7) = CONST(2)
      C(16) = 0.D0
      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 - .51D0*DLOG10(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.D0
  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.D0/DABS(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.D0/DMAX1(C(1),DABS(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.D0/DMAX1(C(I+20),DABS(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.D0/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.D0/DMAX1(1.D0,DABS(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.D0) GO TO 540
C            FIRST - CALCULATE WEIGHTED Y NORM - C(8)
      C(8) = 0.D0
      DO 520 I = 1, N
         C(8) = DMAX1(C(8),Y(I)*WORK(I,3))
  520 CONTINUE
      C(9) = 10.D0*DMAX1(C(7),C(6)*DMAX1(C(8)/TOL,DABS(X)))
  540 CONTINUE
C        CALCULATE SCALE - USE DEFAULT UNLESS VALUE PRESCRIBED
      C(10) = C(3)
      IF (C(3).EQ.0.D0) C(10) = 1.D0
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.D0 .AND. C(3).NE.0.D0) C(11) = DMIN1(C(4),2.D0/C(3))
      IF (C(4).NE.0.D0 .AND. C(3).EQ.0.D0) C(11) = C(4)
      IF (C(4).EQ.0.D0 .AND. C(3).NE.0.D0) C(11) = 2.D0/C(3)
      IF (C(4).EQ.0.D0 .AND. C(3).EQ.0.D0) C(11) = DABS(XEND-C(17))/5.D0
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.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
