C      ALGORITHM 731, COLLECTED ALGORITHMS FROM ACM.
C      THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
C      VOL. 20, NO. 2, JUNE, 1994, PP. 194-214.
C#######################################################################
C
C Text material TOMS submission `A Moving-Grid Interface for Systems of
C    One-Dimensional Time-Dependent Partial Differential Equations' by
C    J.G. Blom and P.A. Zegeling.
C
C Contains, separated by a C######## line, the following files:
C ------------------------------------------------------------
C SRCFIL : description of contents of source code file
C DRVDOC : documentation of the test program which shows the use
C          of the moving-grid interface in a DASSL environment.
C MIFDOC : software documentation of the moving-grid interface itself.
C RESBAK : RESULT file from single precision version
C          for the first example problem
C RUNBAK : RUNINF file from single precision version
C          for the first example problem
C RESCYL : RESULT file from single precision version
C          for the second example problem
C RUNCYL : RUNINF file from single precision version
C          for the second example problem
C RESDSH : RESULT file from single precision version  !!!!!!!!!!!!!!!!!!
C          for the third example problem              !!! TAU = 1E-3 !!!
C RUNDSH : RUNINF file from single precision version  !!!  in driver !!!
C          for the third example problem              !!!!!!!!!!!!!!!!!!
C RESBAK : RESULT file from double precision version
C          for the first example problem
C RUNBAK : RUNINF file from double precision version
C          for the first example problem
C RESCYL : RESULT file from double precision version
C          for the second example problem
C RUNCYL : RUNINF file from double precision version
C          for the second example problem
C RESDSH : RESULT file from double precision version  !!!!!!!!!!!!!!!!!!
C          for the third example problem              !!! TAU = 1E-3 !!!
C RUNDSH : RUNINF file from double precision version  !!!  in driver !!!
C          for the third example problem              !!!!!!!!!!!!!!!!!!
C
C NB. The single precision results were obtained on a Cray Y-MP and
C     the double precision results on an SGI Indigo.
C#######################################################################
C
C SRCFIL : description of contents of source code file
C
C#######################################################################
C
C***********************************************************************
C
C                     Single Precision files
C
C***********************************************************************
C
C PRBBAK : problem dependent routines for first example problem
C PRBCYL : problem dependent routines for second example problem
C PRBDSH : problem dependent routines for third example problem
C          (Burgers' equation)
C DRIVER : test program to use the moving-grid interface in a DASSL
C          environment
C SPMDIF : moving-grid interface routines
C MACHAR : MACHAR routine from W.J. Cody
C          (available from Netlib: send machar from elefunt)
C SDASSL : DASSL DAE integrator from L.R. Petzold
C          (available from Netlib: send sdassl from ode)
C          NB. DASSL needs the following files:
C DASUSE : contains the routine
C          I1MACH to get the standard error message unit (6).
C             (also available from Netlib: send i1mach from core)
C          R1MACH to determine machine precision, uses value determined
C             by MACHAR
C             (also available from Netlib: send r1mach from core)
C          and the dummies for the routines SGEFA and SGESL from LINPACK
C             (available from Netlib: send sgefa/sgesl from linpack)
C DASLIP : LINPACK routines needed by DASSL
C          (available from Netlib: send sgbfa/sgbsl from linpack)
C
C***********************************************************************
C
C                     Double Precision files
C
C***********************************************************************
C
C PRBBAK : problem dependent routines for first example problem
C PRBCYL : problem dependent routines for second example problem
C PRBDSH : problem dependent routines for third example problem
C          (Burgers' equation)
C DRIVER : test program to use the moving-grid interface in a DASSL
C          environment
C SPMDIF : moving-grid interface routines
C MACHAR : MACHAR routine from W.J. Cody
C          (available from Netlib: send machar from elefunt)
C DDASSL : DASSL DAE integrator from L.R. Petzold
C          (available from Netlib: send ddassl from ode)
C          NB. DASSL needs the following files:
C DASUSE : contains the routine
C          I1MACH to get the standard error message unit (6).
C             (also available from Netlib: send i1mach from core)
C          D1MACH to determine machine precision, uses value determined
C             by MACHAR
C             (also available from Netlib: send d1mach from core)
C          and the dummies for the routines DGEFA and DGESL from LINPACK
C             (available from Netlib: send dgefa/dgesl from linpack)
C DASLIP : LINPACK routines needed by DASSL
C          (available from Netlib: send dgbfa/dgbsl from linpack)
C
C#######################################################################
C
C DRVDOC : documentation of the test program which shows the use
C          of the moving-grid interface in a DASSL environment.
C
C#######################################################################
C
C Description of DRIVER:
C ---------------------
C Main program MoL adaptive grid interface for DASSL
C   Calls problem initializer,
C   Initializes DASSL parameters + grid/solution
C   Put semi-discrete PDE system + Dorfi&Drury grid equation in DASSL
C   Write grid and solution at specific steps (TPRINT) to outputfile
C
C Problem choice by loading the specific problem file with the modules:
C
C     SUBROUTINE INIPRB (TEXT)
C     CHARACTER TEXT*80
C   Initialize /PROBLM/
C
C     SUBROUTINE UINIT (NPDE, NPTS, Y)
C     INTEGER NPDE, NPTS
C     REAL Y(NPDE+1,NPTS)
C   Initial solution; optionnally redefinition of (uniform) grid
C
C     SUBROUTINE SPDEF (T,X,NPDE, U, DUDX, C, Q, R, IRES)
C     INTEGER NPDE, IRES
C     REAL T, X
C     REAL U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), R(NPDE)
C   PDE defining functions C, Q, R
C
C     SUBROUTINE BNDR (T, BETA, GAMMA, U, UX, NPDE, LEFT, IRES)
C     INTEGER NPDE, IRES
C     LOGICAL LEFT
C     REAL T
C     REAL BETA(NPDE), GAMMA(NPDE), U(NPDE), UX(NPDE)
C   Boundary function
C
C     SUBROUTINE UEXACT (X, T, U)
C     REAL X, T
C     REAL U(NPDE)
C   Exact solution (only called if SOLAV=TRUE)
C

How to use the interface in a DASSL environment:
-----------------------------------------------
Compile and link the files
        DRIVER
        SPMDIF
        MACHAR
        SDASSL
        DASUSE
        DASLIP
and one of the problem dependent routines
        PRB...
NB. If PRBDSH is used the TAU parameter in DRIVER should be set to
==      TAU = 1E-3
    since the initial grid is not consistent with the DAE system.


The results and integration information can be found in the corresponding
files
        RES...
        RUN...
C
C#######################################################################
C
C MIFDOC : software documentation of the moving-grid interface itself.
C
C#######################################################################
C
C-----------------------------------------------------------------------
C
C Moving grid discretization module SPMDIF
C ----------------------------------------
C This module discretizes systems of partial differential equations
C in one space variable on a moving grid. The class of equations that
C can be handled is given by
C
C   NPDE                   k                      -m  m
C   sum  C   (x,t, u, u ) u  + Q (x,t, u, u ) =  x  (x  R (x,t, u, u ))
C   k=1   j,k      -  -x   t    j      -  -x             j      -  -x  x
C
C where            1         NPDE T
C           u = ( u , ... , u    )   ,  j = 1,... , NPDE,
C           -
C      k
C and u  is the partial derivative wrt time of the k-th component of u.
C      t
C
C The functions C, Q, and R are assumed to be continuous w.r.t. the
C space variable.
C
C The independent variables x and t satisfy  x  < x < x   with x  and x
C                                             L        R        L      R
C fixed and  t > t .
C                 0
C The boundary conditions have the form
C
C   BETA(x,t).R(x,t,u,u ) = GAMMA(x,t,u,u )  at x = x , x  ,
C                   - -x              - -x           L   R
C
C where not all of the functions BETA and GAMMA are set to zero.
C
C The initial conditions are given by
C                0
C   u (x,t )  = u (x)  for x  <= x <= x .
C   -     0     -           L          R
C The discretization method for the PDE in Lagrangian formulation
C used by this module is based on a lumped Galerkin / Petrov-Galerkin
C method and evaluates the PDE functions in a point between
C the (moving) grid points.
C
C References:
C   Fixed-grid spatial discretization
C            Skeel R.D. and Berzins M.
C            A Method for the Spatial Discretisation of Parabolic
C            Equations in one Space Variable.
C            Leeds Report no 217,
C            Dept. of Computer Studies, The University.
C   Grid movement
C            Verwer J.G., Blom J.G., Furzeland R.M. and Zegeling P.A.
C            A Moving-Grid Method for One-Dimensional PDEs based on
C            the Method of Lines.
C            Report NM-R8818,
C            Centre for Mathematics and Computer Science, Amsterdam.
C   Interface
C            Blom J.G. and Zegeling P.A.
C            A Moving-Grid Interface for Systems of One-Dimensional
C            Time-Dependent Partial Differential Equations.
C            Report NM-R8904,
C            Centre for Mathematics and Computer Science, Amsterdam.
C            (ACM TOMS algorithm)
C
C----------------------------------------------------------------------
C
C How to use this module
C ----------------------
C 1.  Set NPDE = # PDEs to be solved.
C     Set NPTS = # mesh points to be used.
C                (NC=NPTS-2 is # internal points)
C     Set M for space coordinate type
C         = 0 for Cartesian,  = 1 for cylindrical, = 2 for spherical.
C     Specify a workspace of size at least  (NPDE+1)*NPTS+(6+NPDE)*NPDE
C     for use by the routine SKMRES which defines the DAE system being
C     solved by the integrator.
C
C     Call the initialization routine SETSKM, see the documentation at
C     the head of this routine for the precise details of the call.
C
C     Set TS and TOUT for start and end integration times.
C     Initialize data as required for time integration,
C                - see documentation of DAE solver.
C     Call the DAE solver with as residual routine SKMRES or an
C     enveloping routine to satisfy the header requirements.
C
C 2.  Provide a set of routines which describe the precise form of the
C     PDEs to be solved. Three routines must be provided and the names
C     of these routines are fixed. These routines are:
C        SPDEF   forms the functions C, Q and R of the PDE in a
C                given x-point.
C        BNDR    forms the functions BETA and GAMMA associated with the
C                boundary conditions for the PDE.
C        UINIT   supplies the initial values of the PDE part.
C                An initial uniform grid is generated by SETSKM and
C                provided in Y(NPDE+1,I), I=1,NPTS. If required, a user
C                can redefine the mesh in a nonuniform way.
C     The headers of these routines are:
C
C      SUBROUTINE SPDEF (T, X, NPDE, U, DUDX, C, Q, R, IRES)
C      INTEGER NPDE, IRES
C      REAL T, X
C      REAL U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), R(NPDE)
C
C      SUBROUTINE BNDR (T, BETA, GAMMA, U, DUDX, NPDE, LEFT, IRES)
C      INTEGER NPDE, IRES
C      LOGICAL LEFT
C      REAL T
C      REAL BETA(NPDE), GAMMA(NPDE), U(NPDE), DUDX(NPDE)
C
C      SUBROUTINE UINIT (NPDE, NPTS, Y)
C      INTEGER NPDE, NPTS
C      REAL Y(NPDE+1,NPTS)
C
C
C Example problem
C ---------------
C The easiest way to describe how the problem description routines
C should be written is by a simple example. Consider the following
C problem from electrodynamics
C    u  = eps.p.u   - g(u-v)
C     t          xx
C and                             (so m = 0 and NPDE = 2)
C    v  =     p.v   + g(u-v)
C     t          xx
C with
C    g(z) = exp(eta.z/3) - exp(-2.eta.z/3) ,
C    0 <= x <= 1  and  0 <= t <= 4;
C    eps = 0.143, p = 0.1743, and eta = 17.19.
C
C The left boundary condition (LEFT = .TRUE.) is given by
C    u  = 0  and  v = 0   at x = 0,
C     x
C the right boundary condition (LEFT = .FALSE.) is
C    u = 0  and  v  = 0   at x = 1,
C                 x
C and the initial conditions are
C    u = 1  and  v = 0  at t = 0.
C
C The routines UINIT, SPDEF and BNDR are listed below.
C The component u of the PDE at the i-th grid point is held as Y(1,i)
C in the package, the component v as Y(2,i); the i-th grid point
C itself is stored in Y(3,i).
C
C
C
C     SUBROUTINE UINIT (NPDE, NPTS, Y)
C
C Routine for PDE initial values.
C Entry:
C   Y(NPDE+1,i) = x_i; uniform mesh, generated by package
C Exit:
C   Y(NPDE+1,i) = x_i; mesh, optionally changed by user
C   Y(     k,i) = u_k(x_i,t0); initial value of k-th component
C                                  i = 1,.., NPTS
C
C     INTEGER NPDE, NPTS
C     REAL Y(NPDE+1,NPTS)
C
C     INTEGER I
C
C     DO 10 I = 1, NPTS
C        Y(1,I) = 1.0
C        Y(2,I) = 0.0
C  10 CONTINUE
C
C     RETURN
C     END
C
C
C
C     SUBROUTINE SPDEF (T, X, NPDE, U, DUDX, C, Q, R, IRES)
C
C Routine to describe the body of the PDE system.
C The PDE is written as
C   NPDE               k                    -m   m
C   sum C  (x,t,u,u ) u  + Q (x,t,u,u )  = x   (x  R (x,t,u,u ) ) .
C   k=1  jk        x   t    j        x              j        x   x
C The functions C, Q and R must be defined in this routine.
C
C     INTEGER NPDE, IRES
C     REAL T, X
C     REAL U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), R(NPDE)
C
C     INTEGER J, K
C     REAL EPS, ETA, GZ, P, Z
C     DATA EPS /0.143/, ETA /17.19/, P /0.1743/
C
C     DO 10 K = 1, NPDE
C        DO 20 J = 1, NPDE
C           C(J,K) = 0.0
C  20    CONTINUE
C        C(K,K) = 1.0
C  10 CONTINUE
C
C     Z  = U(1) - U(2)
C     GZ = EXP(ETA*Z/3) - EXP(-2*ETA*Z/3)
C     Q(1) =  GZ
C     Q(2) = -GZ
C
C     R(1) = EPS*P * DUDX(1)
C     R(2) =     P * DUDX(2)
C
C     RETURN
C     END
C
C
C
C     SUBROUTINE BNDR (T, BETA, GAMMA, U, DUDX, NPDE, LEFT, IRES)
C
C Boundary conditions routine
C The boundary conditions are written as
C   BETA (x,t) R (x,t,u,u ) = GAMMA (x,t,u,u )
C       j       j        x         j        x
C The functions BETA and GAMMA should be defined in this routine.
C
C     INTEGER NPDE, IRES
C     LOGICAL LEFT
C     REAL T
C     REAL BETA(NPDE), GAMMA(NPDE), U(NPDE), DUDX(NPDE)
C
C     IF (LEFT) THEN
C        BETA (1) = 1.0
C        GAMMA(1) = 0.0
C        BETA (2) = 0.0
C        GAMMA(2) = U(2)
C     ELSE
C        BETA (1) = 0.0
C        GAMMA(1) = U(1) - 1.0
C        BETA (2) = 1.0
C        GAMMA(2) = 0.0
C     ENDIF
C
C     RETURN
C     END
C
C
C#######################################################################
C
C RESBAK : RESULT file from single precision version
C          for the first example problem
C
C#######################################################################
C
 Bakker, Electrodynamics problem; EPS=0.143, P=0.1743, ETA=17.19                
 MoL, PDE+D&D int.face; DAE int.: DASSL;  ID:ACM-TOMS, Ex.I                     
 NPTS= 21; RTOL=.100E-02, ATOL=.100E-02                                         
 TAU=.000E+00, KAPPA=.200E+01, ALPHA=.100E-01                                   
-T=  0.00000E+00
 X(S,TN):
   0.00000000000000E+00   0.50000000000000E-01   0.10000000000000E+00   0.15000000000000E+00   0.20000000000000E+00
   0.25000000000000E+00   0.30000000000000E+00   0.35000000000000E+00   0.40000000000000E+00   0.45000000000000E+00
   0.50000000000000E+00   0.55000000000000E+00   0.60000000000000E+00   0.65000000000000E+00   0.70000000000000E+00
   0.75000000000000E+00   0.80000000000000E+00   0.85000000000000E+00   0.90000000000000E+00   0.95000000000000E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01
   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01
   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01
   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:2
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00
-T=  0.10000E-03
 X(S,TN):
  -0.45929255914759E-19   0.25040640290220E-01   0.56481182704547E-01   0.95013746311533E-01   0.14035701231943E+00
   0.19172997170988E+00   0.24805286040399E+00   0.30815425177574E+00   0.37092073056414E+00   0.43536105966516E+00
   0.50059965537049E+00   0.56582746970413E+00   0.63023451172673E+00   0.69294260800311E+00   0.75295709500441E+00
   0.80916185657288E+00   0.86038575610616E+00   0.90555452167634E+00   0.94389834759477E+00   0.97514972312581E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.97256278203386E+00   0.97297329460978E+00   0.97347359747748E+00   0.97362279769018E+00   0.97365968612859E+00
   0.97366795251495E+00   0.97366993754457E+00   0.97367061718684E+00   0.97367094665945E+00   0.97367111097203E+00
   0.97367116090931E+00   0.97367110995003E+00   0.97367094675137E+00   0.97367066002049E+00   0.97367048643146E+00
   0.97367279232644E+00   0.97369354243553E+00   0.97382236618489E+00   0.97451336969171E+00   0.97805479165282E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:2
   0.10158626506619E-16   0.21863836925754E-01   0.25474655206463E-01   0.26176978370070E-01   0.26306690064825E-01
   0.26327294436488E-01   0.26329526698004E-01   0.26329338707842E-01   0.26329051464071E-01   0.26328889377324E-01
   0.26328839457234E-01   0.26328890549432E-01   0.26329056717380E-01   0.26329390760117E-01   0.26330088342959E-01
   0.26332151381840E-01   0.26340710279631E-01   0.26378419427779E-01   0.26528830856401E-01   0.27025637008333E-01
   0.27429641024853E-01
 Statistics:
    FNS, JACS:25,  9
    STEPS, ETF, CTF:14,  0,  0
-T=  0.10000E-02
 X(S,TN):
   0.10096741302168E-15   0.12035719074328E-01   0.27659128209353E-01   0.49865220895497E-01   0.81605103543717E-01
   0.12602462914175E+00   0.18619247847968E+00   0.26401810016408E+00   0.35861164907025E+00   0.46490893940724E+00
   0.57403954521281E+00   0.67610235632744E+00   0.76369477884377E+00   0.83368267073946E+00   0.88661980899191E+00
   0.92509600342961E+00   0.95229367331208E+00   0.97117431687522E+00   0.98419344028329E+00   0.99327637270227E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.84124639415634E+00   0.85198008579324E+00   0.86417805594088E+00   0.86767855237370E+00   0.86870605053580E+00
   0.86901606826152E+00   0.86910499154684E+00   0.86912953917044E+00   0.86913887899673E+00   0.86914157341817E+00
   0.86913640670443E+00   0.86912565320049E+00   0.86912013781261E+00   0.86915098186856E+00   0.86930686492989E+00
   0.86979879062790E+00   0.87108032245948E+00   0.87416884320602E+00   0.88202791044688E+00   0.90698269192593E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:2
   0.12906845854695E-14   0.85805240030432E-01   0.11962492264781E+00   0.12841936270931E+00   0.13028720055180E+00
   0.13074916685063E+00   0.13085454382600E+00   0.13086676156911E+00   0.13086128635510E+00   0.13085860201449E+00
   0.13086418709539E+00   0.13087854363622E+00   0.13090461500711E+00   0.13096181033273E+00   0.13110840596252E+00
   0.13150473184524E+00   0.13256554012321E+00   0.13517998806772E+00   0.14028780604146E+00   0.14665928624041E+00
   0.14940963004855E+00
 Statistics:
    FNS, JACS:61,  13
    STEPS, ETF, CTF:33,  0,  0
-T=  0.10000E-01
 X(S,TN):
   0.12321694707397E-15   0.16259046659784E-01   0.34383535895571E-01   0.56835836175499E-01   0.87041130186527E-01
   0.12957612320856E+00   0.18909463247710E+00   0.26896987480346E+00   0.36926606771224E+00   0.48381928143333E+00
   0.60023366312207E+00   0.70518181363670E+00   0.79064082999200E+00   0.85527719537961E+00   0.90186409643097E+00
   0.93448369137719E+00   0.95706820877491E+00   0.97276825821681E+00   0.98401711038015E+00   0.99265720180072E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.55402306951480E+00   0.58108910541637E+00   0.63225213431880E+00   0.66627322477729E+00   0.68085414520969E+00
   0.68521098036305E+00   0.68607431016619E+00   0.68618613358218E+00   0.68620358427590E+00   0.68620857279386E+00
   0.68620575805936E+00   0.68620193948851E+00   0.68622622321513E+00   0.68640895842475E+00   0.68722049724873E+00
   0.68983177811135E+00   0.69843379361656E+00   0.72636152222943E+00   0.78483376221049E+00   0.87331914958560E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:2
  -0.14423510781113E-15   0.10434572933473E+00   0.18773200936252E+00   0.25316318733207E+00   0.29495829171579E+00
   0.31083861716651E+00   0.31358221957824E+00   0.31379496379115E+00   0.31379634997062E+00   0.31379210702118E+00
   0.31379639822638E+00   0.31381263466474E+00   0.31387638022552E+00   0.31432301373424E+00   0.31681082856067E+00
   0.32390520899290E+00   0.33490016491657E+00   0.34648401666759E+00   0.35618494627395E+00   0.36293229887844E+00
   0.36542563003615E+00
 Statistics:
    FNS, JACS:87,  16
    STEPS, ETF, CTF:50,  0,  0
-T=  0.10000E+00
 X(S,TN):
   0.14331098239068E-15   0.27509483466300E-01   0.55993853613377E-01   0.86797397243380E-01   0.12184131719335E+00
   0.16382468916371E+00   0.21644008503414E+00   0.28414150959066E+00   0.37020737682426E+00   0.47234901909983E+00
   0.58046996527423E+00   0.68113151533455E+00   0.76479022471584E+00   0.82907726170566E+00   0.87662281502272E+00
   0.91151541453917E+00   0.93755459576611E+00   0.95766091089810E+00   0.97387210855655E+00   0.98760829949711E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.21974534394379E+00   0.24082376269937E+00   0.29058114641601E+00   0.34867167626356E+00   0.40416712783431E+00
   0.44973781796411E+00   0.48125524138903E+00   0.49908680544002E+00   0.50698569979986E+00   0.50962245266198E+00
   0.51055292014141E+00   0.51203188913654E+00   0.51609479116237E+00   0.52517648903438E+00   0.54436694256418E+00
   0.58048272381257E+00   0.63431426634869E+00   0.70289964791332E+00   0.78413731636754E+00   0.87974885845813E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:2
  -0.18368361340501E-14   0.88797802893640E-01   0.16833570592607E+00   0.24183227161984E+00   0.31039168545408E+00
   0.37292535255351E+00   0.42566498790975E+00   0.46296747411637E+00   0.48196669098422E+00   0.48823941471498E+00
   0.49030543486261E+00   0.49378948087089E+00   0.50305406913238E+00   0.51960809965608E+00   0.54068676663276E+00
   0.56194272044633E+00   0.58032800498320E+00   0.59478225700266E+00   0.60534675177147E+00   0.61217120657784E+00
   0.61461802433752E+00
 Statistics:
    FNS, JACS:109,  18
    STEPS, ETF, CTF:67,  0,  0
-T=  0.25000E+00
 X(S,TN):
   0.12725037865343E-15   0.35291254425231E-01   0.71018499650379E-01   0.10814727313561E+00   0.14806484107473E+00
   0.19254359390664E+00   0.24383356497859E+00   0.30463589317156E+00   0.37745877336233E+00   0.46262763941150E+00
   0.55547608492964E+00   0.64660341650348E+00   0.72720823654849E+00   0.79352530583887E+00   0.84616098410961E+00
   0.88743116331616E+00   0.91981720922314E+00   0.94553081719465E+00   0.96644700465101E+00   0.98413122687172E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.10805691125032E+00   0.12867780638170E+00   0.17698893961420E+00   0.23411712654762E+00   0.29233041000358E+00
   0.34784124009268E+00   0.39770932046008E+00   0.43884543498730E+00   0.46883295790019E+00   0.48788841142235E+00
   0.50012006547364E+00   0.51181131222257E+00   0.52821187130139E+00   0.55126970203934E+00   0.58088153128989E+00
   0.61789323477408E+00   0.66469191726619E+00   0.72340650173389E+00   0.79551790787835E+00   0.88411328778420E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:2
   0.32113325487618E-14   0.74015549627789E-01   0.14091574007736E+00   0.20354615192433E+00   0.26322295556401E+00
   0.32010382632822E+00   0.37315587636328E+00   0.41999805889254E+00   0.45728004537205E+00   0.48295016505953E+00
   0.50002278877089E+00   0.51592872114635E+00   0.53662059145540E+00   0.56286195944614E+00   0.59169029042505E+00
   0.61938021532653E+00   0.64316739171925E+00   0.66177161083460E+00   0.67509344374135E+00   0.68341946465375E+00
   0.68632734130789E+00
 Statistics:
    FNS, JACS:117,  19
    STEPS, ETF, CTF:74,  0,  0
-T=  0.50000E+00
 X(S,TN):
   0.14309716753197E-15   0.44439184054847E-01   0.88805154702960E-01   0.13392003828239E+00   0.18087866430320E+00
   0.23083518694143E+00   0.28495809726599E+00   0.34430991038575E+00   0.40951532593247E+00   0.48017618529946E+00
   0.55428281061888E+00   0.62829230260064E+00   0.69829246288909E+00   0.76140048913084E+00   0.81625745109764E+00
   0.86267957209169E+00   0.90118663330737E+00   0.93275317065160E+00   0.95869695796909E+00   0.98054839125876E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.61705872700837E-01   0.83571830093333E-01   0.13215150721409E+00   0.18633482340289E+00   0.24042708729016E+00
   0.29267592896158E+00   0.34206223729876E+00   0.38753962103392E+00   0.42811975474081E+00   0.46346837107444E+00
   0.49467327599739E+00   0.52422241421676E+00   0.55451688142558E+00   0.58639607641640E+00   0.61954782368977E+00
   0.65442523020765E+00   0.69380864711304E+00   0.74236191663913E+00   0.80489381307507E+00   0.88669439366782E+00
   0.99999999999999E+00
 U(X(S,TN),TN), COMP:2
   0.29357275824825E-14   0.63742469167286E-01   0.12163927031717E+00   0.17672723402117E+00   0.22997910286532E+00
   0.28151552181222E+00   0.33094496061509E+00   0.37748421738985E+00   0.42020712674656E+00   0.45860618995472E+00
   0.49330124460705E+00   0.52612422735900E+00   0.55894416347117E+00   0.59231651008286E+00   0.62533800603176E+00
   0.65630895899070E+00   0.68338628129423E+00   0.70513609405918E+00   0.72093103881909E+00   0.73076722895464E+00
   0.73416672114764E+00
 Statistics:
    FNS, JACS:125,  20
    STEPS, ETF, CTF:80,  0,  0
-T=  0.10000E+01
 X(S,TN):
   0.15579464091624E-15   0.54377796631882E-01   0.10808499702755E+00   0.16166534113479E+00   0.21573577426543E+00
   0.27077941894134E+00   0.32712512028561E+00   0.38491631485438E+00   0.44407755115856E+00   0.50430143165554E+00
   0.56502076662724E+00   0.62539846087767E+00   0.68439978007837E+00   0.74088134783070E+00   0.79366740937016E+00
   0.84166569394911E+00   0.88403012922474E+00   0.92037830480956E+00   0.95100855908446E+00   0.97697228843874E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.41855939535181E-01   0.64374251707875E-01   0.11186576987393E+00   0.16204980866788E+00   0.21164682386363E+00
   0.26020607448425E+00   0.30762778791832E+00   0.35384089867530E+00   0.39881014785837E+00   0.44257057790027E+00
   0.48519340782749E+00   0.52670743080367E+00   0.56703180609075E+00   0.60593798951026E+00   0.64314500553159E+00
   0.67890444579687E+00   0.71527246918554E+00   0.75721065734866E+00   0.81192653120524E+00   0.88782968033196E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:2
  -0.29428837436846E-14   0.57131864288686E-01   0.10922404384575E+00   0.15955951890530E+00   0.20880629258781E+00
   0.25712185005723E+00   0.30452055106568E+00   0.35095994941793E+00   0.39640073540404E+00   0.44081243225129E+00
   0.48416051562390E+00   0.52638421227051E+00   0.56733409386149E+00   0.60668419317797E+00   0.64387198669139E+00
   0.67806789646732E+00   0.70817472279515E+00   0.73294873042647E+00   0.75138144575774E+00   0.76298926846214E+00
   0.76699655461490E+00
 Statistics:
    FNS, JACS:134,  22
    STEPS, ETF, CTF:87,  0,  0
-T=  0.20000E+01
 X(S,TN):
   0.29409680181596E-15   0.60053312578581E-01   0.11903677672934E+00   0.17727611123687E+00   0.23511706509967E+00
   0.29279165598505E+00   0.35043595339502E+00   0.40810238795770E+00   0.46575791994838E+00   0.52327779388177E+00
   0.58042955175588E+00   0.63684463711884E+00   0.69199400983232E+00   0.74516472209928E+00   0.79546441287016E+00
   0.84188932882871E+00   0.88349316596151E+00   0.91966692030223E+00   0.95044811298548E+00   0.97668380211812E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.35153306610654E-01   0.57866835981245E-01   0.10462817309598E+00   0.15300641642817E+00   0.20100810899407E+00
   0.24855287024443E+00   0.29567823589677E+00   0.34238440863736E+00   0.38862216690770E+00   0.43429254093055E+00
   0.47923385334969E+00   0.52319895985026E+00   0.56583652449281E+00   0.60670223125468E+00   0.64540338585039E+00
   0.68213406960155E+00   0.71883586428744E+00   0.76036192060918E+00   0.81407465320883E+00   0.88880160013576E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:2
   0.83672220273541E-14   0.54320856370252E-01   0.10405126664540E+00   0.15262122839213E+00   0.20056433684308E+00
   0.24804132895257E+00   0.29511679638358E+00   0.34179518052582E+00   0.38802979007883E+00   0.43372020420521E+00
   0.47869659580729E+00   0.52270542162762E+00   0.56538312543830E+00   0.60622865018382E+00   0.64459146390332E+00
   0.67964650343230E+00   0.71036886968219E+00   0.73560345360282E+00   0.75438217175095E+00   0.76620774946117E+00
   0.77028755821621E+00
 Statistics:
    FNS, JACS:141,  23
    STEPS, ETF, CTF:92,  0,  0
-T=  0.30000E+01
 X(S,TN):
   0.28573248148445E-15   0.61545078541541E-01   0.12195028465348E+00   0.18152001114298E+00   0.24056090084449E+00
   0.29926758441615E+00   0.35774357225620E+00   0.41601581266998E+00   0.47403676436145E+00   0.53167582403960E+00
   0.58870138247998E+00   0.64475520163642E+00   0.69932378731912E+00   0.75171728897627E+00   0.80107736495090E+00
   0.84644881821691E+00   0.88695344395276E+00   0.92206692122934E+00   0.95190595527069E+00   0.97735239318904E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.33958724409891E-01   0.56829997983521E-01   0.10362924441254E+00   0.15176444318814E+00   0.19952056487269E+00
   0.24686675541916E+00   0.29384675605411E+00   0.34046027313350E+00   0.38665455929641E+00   0.43231818382776E+00
   0.47726846727143E+00   0.52123386881998E+00   0.56383965630444E+00   0.60463095475969E+00   0.64324849097419E+00
   0.68001327241054E+00   0.71707805635342E+00   0.75938810677969E+00   0.81403088298383E+00   0.88929997660461E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:2
  -0.19060764564055E-14   0.53908575476223E-01   0.10328102875282E+00   0.15158885010453E+00   0.19932380863160E+00
   0.24663694326002E+00   0.29358882170883E+00   0.34018116733100E+00   0.38636162646034E+00   0.43201868525592E+00
   0.47696902789347E+00   0.52093896719268E+00   0.56354233961505E+00   0.60425935917571E+00   0.64241850304921E+00
   0.67717428866561E+00   0.70749185143344E+00   0.73224719410853E+00   0.75056556132342E+00   0.76205903957098E+00
   0.76602026680388E+00
 Statistics:
    FNS, JACS:146,  24
    STEPS, ETF, CTF:95,  0,  0
-T=  0.40000E+01
 X(S,TN):
  -0.85468233905893E-16   0.62278089651929E-01   0.12338589600318E+00   0.18362097106100E+00   0.24327343518029E+00
   0.30252134231709E+00   0.36145307371032E+00   0.42008210677703E+00   0.47834931144713E+00   0.53611463939805E+00
   0.59313955698469E+00   0.64906209169345E+00   0.70336918356199E+00   0.75537733328420E+00   0.80424320252131E+00
   0.84903886446402E+00   0.88892831962760E+00   0.92344078672753E+00   0.95274240063757E+00   0.97773675557374E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.33421631420763E-01   0.56380094159363E-01   0.10321815438402E+00   0.15125338833211E+00   0.19890283667247E+00
   0.24615552130313E+00   0.29305621644875E+00   0.33960294650938E+00   0.38574020556715E+00   0.43135247048215E+00
   0.47625139131189E+00   0.52015834994579E+00   0.56269167606630E+00   0.60339604193638E+00   0.64193674077807E+00
   0.67871347153285E+00   0.71600107567396E+00   0.75878543377197E+00   0.81398050494738E+00   0.88957192118291E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:2
  -0.57131982845478E-15   0.53737185559809E-01   0.10295746219314E+00   0.15115351828478E+00   0.19879595065330E+00
   0.24603024097559E+00   0.29291446209511E+00   0.33944809845995E+00   0.38557597776079E+00   0.43118267915336E+00
   0.47607961326666E+00   0.51998620953497E+00   0.56250800482608E+00   0.60311585136995E+00   0.64112759825094E+00
   0.67568618264273E+00   0.70575090826504E+00   0.73021685319163E+00   0.74826369867698E+00   0.75956434986654E+00
   0.76345718816966E+00
 Statistics:
    FNS, JACS:147,  24
    STEPS, ETF, CTF:96,  0,  0
C
C#######################################################################
C
C RUNBAK : RUNINF file from single precision version
C          for the first example problem
C
C#######################################################################
C
 Bakker, Electrodynamics problem; EPS=0.143, P=0.1743, ETA=17.19                
 MoL, PDE+D&D int.face; DAE int.: DASSL;  ID:ACM-TOMS, Ex.I                     
 NPTS= 21; RTOL=.100E-02, ATOL=.100E-02                                         
 TAU=.000E+00, KAPPA=.200E+01, ALPHA=.100E-01                                   
 Time=  0.20000E-06; H=  0.10000E-06; Order= 1
 Time=  0.40000E-06; H=  0.20000E-06; Order= 2
 Time=  0.80000E-06; H=  0.40000E-06; Order= 1
 Time=  0.16000E-05; H=  0.80000E-06; Order= 1
 Time=  0.32000E-05; H=  0.16000E-05; Order= 1
 Time=  0.64000E-05; H=  0.32000E-05; Order= 1
 Time=  0.12800E-04; H=  0.64000E-05; Order= 1
 Time=  0.19200E-04; H=  0.64000E-05; Order= 1
 Time=  0.25600E-04; H=  0.64000E-05; Order= 1
 Time=  0.38400E-04; H=  0.12800E-04; Order= 2
 Time=  0.51200E-04; H=  0.12800E-04; Order= 2
 Time=  0.64000E-04; H=  0.12800E-04; Order= 2
 Time=  0.76800E-04; H=  0.12800E-04; Order= 2
 Time=  0.10240E-03; H=  0.25600E-04; Order= 2
 Time=  0.12800E-03; H=  0.25600E-04; Order= 1
 Time=  0.15104E-03; H=  0.23040E-04; Order= 1
 Time=  0.17408E-03; H=  0.23040E-04; Order= 1
 Time=  0.19712E-03; H=  0.23040E-04; Order= 1
 Time=  0.24320E-03; H=  0.46080E-04; Order= 2
 Time=  0.28928E-03; H=  0.46080E-04; Order= 2
 Time=  0.33536E-03; H=  0.46080E-04; Order= 2
 Time=  0.38144E-03; H=  0.46080E-04; Order= 2
 Time=  0.42752E-03; H=  0.46080E-04; Order= 2
 Time=  0.47360E-03; H=  0.46080E-04; Order= 3
 Time=  0.51968E-03; H=  0.46080E-04; Order= 2
 Time=  0.56576E-03; H=  0.46080E-04; Order= 2
 Time=  0.61184E-03; H=  0.46080E-04; Order= 2
 Time=  0.65792E-03; H=  0.46080E-04; Order= 2
 Time=  0.70400E-03; H=  0.46080E-04; Order= 1
 Time=  0.75008E-03; H=  0.46080E-04; Order= 1
 Time=  0.84224E-03; H=  0.92160E-04; Order= 1
 Time=  0.93440E-03; H=  0.92160E-04; Order= 1
 Time=  0.10266E-02; H=  0.92160E-04; Order= 1
 Time=  0.12109E-02; H=  0.18432E-03; Order= 2
 Time=  0.13952E-02; H=  0.18432E-03; Order= 2
 Time=  0.17638E-02; H=  0.36864E-03; Order= 2
 Time=  0.20956E-02; H=  0.33178E-03; Order= 2
 Time=  0.24274E-02; H=  0.33178E-03; Order= 2
 Time=  0.27592E-02; H=  0.33178E-03; Order= 2
 Time=  0.30909E-02; H=  0.33178E-03; Order= 2
 Time=  0.34227E-02; H=  0.33178E-03; Order= 3
 Time=  0.40863E-02; H=  0.66355E-03; Order= 3
 Time=  0.47498E-02; H=  0.66355E-03; Order= 3
 Time=  0.54134E-02; H=  0.66355E-03; Order= 3
 Time=  0.60769E-02; H=  0.66355E-03; Order= 3
 Time=  0.67405E-02; H=  0.66355E-03; Order= 2
 Time=  0.74040E-02; H=  0.66355E-03; Order= 2
 Time=  0.80676E-02; H=  0.66355E-03; Order= 2
 Time=  0.87311E-02; H=  0.66355E-03; Order= 2
 Time=  0.10058E-01; H=  0.13271E-02; Order= 2
 Time=  0.11385E-01; H=  0.13271E-02; Order= 2
 Time=  0.12712E-01; H=  0.13271E-02; Order= 2
 Time=  0.15367E-01; H=  0.26542E-02; Order= 2
 Time=  0.18021E-01; H=  0.26542E-02; Order= 2
 Time=  0.20675E-01; H=  0.26542E-02; Order= 2
 Time=  0.23329E-01; H=  0.26542E-02; Order= 2
 Time=  0.28638E-01; H=  0.53084E-02; Order= 3
 Time=  0.33946E-01; H=  0.53084E-02; Order= 3
 Time=  0.39255E-01; H=  0.53084E-02; Order= 3
 Time=  0.44563E-01; H=  0.53084E-02; Order= 3
 Time=  0.49871E-01; H=  0.53084E-02; Order= 3
 Time=  0.60488E-01; H=  0.10617E-01; Order= 2
 Time=  0.70043E-01; H=  0.95551E-02; Order= 2
 Time=  0.79598E-01; H=  0.95551E-02; Order= 2
 Time=  0.89154E-01; H=  0.95551E-02; Order= 2
 Time=  0.98709E-01; H=  0.95551E-02; Order= 2
 Time=  0.11782E+00; H=  0.19110E-01; Order= 3
 Time=  0.13693E+00; H=  0.19110E-01; Order= 3
 Time=  0.15604E+00; H=  0.19110E-01; Order= 3
 Time=  0.17515E+00; H=  0.19110E-01; Order= 3
 Time=  0.19426E+00; H=  0.19110E-01; Order= 3
 Time=  0.21337E+00; H=  0.19110E-01; Order= 2
 Time=  0.23248E+00; H=  0.19110E-01; Order= 2
 Time=  0.25159E+00; H=  0.19110E-01; Order= 2
 Time=  0.27070E+00; H=  0.19110E-01; Order= 2
 Time=  0.30892E+00; H=  0.38221E-01; Order= 2
 Time=  0.34714E+00; H=  0.38221E-01; Order= 2
 Time=  0.38536E+00; H=  0.38221E-01; Order= 2
 Time=  0.42358E+00; H=  0.38221E-01; Order= 2
 Time=  0.50003E+00; H=  0.76441E-01; Order= 3
 Time=  0.57647E+00; H=  0.76441E-01; Order= 3
 Time=  0.65291E+00; H=  0.76441E-01; Order= 3
 Time=  0.72935E+00; H=  0.76441E-01; Order= 3
 Time=  0.80579E+00; H=  0.76441E-01; Order= 2
 Time=  0.88223E+00; H=  0.76441E-01; Order= 2
 Time=  0.95867E+00; H=  0.76441E-01; Order= 2
 Time=  0.11116E+01; H=  0.15288E+00; Order= 2
 Time=  0.12644E+01; H=  0.15288E+00; Order= 2
 Time=  0.14173E+01; H=  0.15288E+00; Order= 2
 Time=  0.15702E+01; H=  0.15288E+00; Order= 2
 Time=  0.18760E+01; H=  0.30576E+00; Order= 3
 Time=  0.21817E+01; H=  0.30576E+00; Order= 2
 Time=  0.24875E+01; H=  0.30576E+00; Order= 1
 Time=  0.27933E+01; H=  0.30576E+00; Order= 1
 Time=  0.34048E+01; H=  0.61153E+00; Order= 1
C
C#######################################################################
C
C RESCYL : RESULT file from single precision version
C          for the second example problem
C
C#######################################################################
C
 Reaction-diffusion prob. in cyl. coord.; pars: 1.00000 0.00010 1.00000 0.10000 
 MoL, PDE+D&D int.face; DAE int.: DASSL;  ID:ACM-TOMS, Ex.I                     
 NPTS= 21; RTOL=.100E-02, ATOL=.100E-02                                         
 TAU=.000E+00, KAPPA=.200E+01, ALPHA=.100E-01                                   
-T=  0.00000E+00
 X(S,TN):
   0.00000000000000E+00   0.50000000000000E-01   0.10000000000000E+00   0.15000000000000E+00   0.20000000000000E+00
   0.25000000000000E+00   0.30000000000000E+00   0.35000000000000E+00   0.40000000000000E+00   0.45000000000000E+00
   0.50000000000000E+00   0.55000000000000E+00   0.60000000000000E+00   0.65000000000000E+00   0.70000000000000E+00
   0.75000000000000E+00   0.80000000000000E+00   0.85000000000000E+00   0.90000000000000E+00   0.95000000000000E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00
-T=  0.10000E+00
 X(S,TN):
   0.17639148112380E-13   0.14518591720821E+00   0.28623494020569E+00   0.41908322853390E+00   0.53995112401876E+00
   0.64574669552204E+00   0.73456039093228E+00   0.80600852725463E+00   0.86120333572151E+00   0.90233799155354E+00
   0.93209672542039E+00   0.95314513173228E+00   0.96780024888720E+00   0.97792439515230E+00   0.98491408768422E+00
   0.98976154174569E+00   0.99315738692336E+00   0.99558121156001E+00   0.99737371803429E+00   0.99878320185078E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.10541348790610E+00   0.10543381958359E+00   0.10542847038094E+00   0.10542698561245E+00   0.10541941978923E+00
   0.10539932404643E+00   0.10534688430917E+00   0.10522617224345E+00   0.10497842123410E+00   0.10451684160996E+00
   0.10371988734721E+00   0.10243217794020E+00   0.10051941919686E+00   0.97874678559643E-01   0.94308534012330E-01
   0.89498381115413E-01   0.82617079787539E-01   0.71960844347622E-01   0.55520642130282E-01   0.32050097751653E-01
   0.00000000000000E+00
 Statistics:
    FNS, JACS:71,  14
    STEPS, ETF, CTF:34,  1,  0
-T=  0.20000E+00
 X(S,TN):
   0.20148591518961E-13   0.18674340180469E+00   0.36161731116823E+00   0.51532438837841E+00   0.64273542221454E+00
   0.74303051546301E+00   0.81863893632480E+00   0.87370917883180E+00   0.91278857212731E+00   0.94000368973643E+00
   0.95871221473832E+00   0.97147405730986E+00   0.98015664892324E+00   0.98607530283489E+00   0.99014066752644E+00
   0.99298520768168E+00   0.99504836858055E+00   0.99662402836551E+00   0.99789913025558E+00   0.99899465059233E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.22303662617181E+00   0.22309304027603E+00   0.22307433305738E+00   0.22305843255700E+00   0.22301924865414E+00
   0.22293473648429E+00   0.22275310329416E+00   0.22239755183779E+00   0.22175950703551E+00   0.22069641796987E+00
   0.21903533515918E+00   0.21658489570770E+00   0.21305474068454E+00   0.20760619886524E+00   0.19806933569841E+00
   0.18136162840480E+00   0.15640109612775E+00   0.12479284080450E+00   0.88216927894771E-01   0.47050672011424E-01
   0.00000000000000E+00
 Statistics:
    FNS, JACS:80,  15
    STEPS, ETF, CTF:40,  1,  0
-T=  0.30000E+00
 X(S,TN):
   0.53661140544489E-13   0.20596987672642E+00   0.39457337922663E+00   0.55404366042406E+00   0.68026638445410E+00
   0.77520770909444E+00   0.84399862769418E+00   0.89253997394126E+00   0.92617272732337E+00   0.94919191822873E+00
   0.96482593746435E+00   0.97540703067471E+00   0.98257233151908E+00   0.98745437274742E+00   0.99084192915820E+00
   0.99328247630039E+00   0.99513367305359E+00   0.99661547342145E+00   0.99786366560713E+00   0.99896844131509E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.35555856393790E+00   0.35564179498772E+00   0.35561290333202E+00   0.35558216590891E+00   0.35551283442850E+00
   0.35537111488340E+00   0.35508524839620E+00   0.35455436764313E+00   0.35364048125503E+00   0.35216510754008E+00
   0.34989533767351E+00   0.34641973140339E+00   0.34044163235663E+00   0.32826224149205E+00   0.30487105733613E+00
   0.26953320481898E+00   0.22564359591173E+00   0.17619233914351E+00   0.12247986317158E+00   0.64325923644970E-01
   0.00000000000000E+00
 Statistics:
    FNS, JACS:88,  16
    STEPS, ETF, CTF:43,  1,  0
-T=  0.40000E+00
 X(S,TN):
   0.46828264956288E-13   0.21713138426698E+00   0.41308519312985E+00   0.57485266622599E+00   0.69952364253330E+00
   0.79102371564955E+00   0.85599655379241E+00   0.90113656859135E+00   0.93205310200147E+00   0.95303866124057E+00
   0.96721478928629E+00   0.97677836965145E+00   0.98324993850289E+00   0.98768568982783E+00   0.99082228899445E+00
   0.99314935067457E+00   0.99496964590112E+00   0.99646616424957E+00   0.99775359126552E+00   0.99891044855880E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.50696401125843E+00   0.50710652721560E+00   0.50705877632246E+00   0.50699933199617E+00   0.50688770090103E+00
   0.50667977952298E+00   0.50628448935737E+00   0.50557685210792E+00   0.50439029727777E+00   0.50250323286334E+00
   0.49954347494264E+00   0.49438836707380E+00   0.48309753422479E+00   0.45826240765102E+00   0.41653890291630E+00
   0.36194743277390E+00   0.29941381028357E+00   0.23177460801213E+00   0.15995654915335E+00   0.83410646792825E-01
   0.00000000000000E+00
 Statistics:
    FNS, JACS:92,  16
    STEPS, ETF, CTF:46,  1,  0
-T=  0.50000E+00
 X(S,TN):
   0.40235442704946E-13   0.22455567004220E+00   0.42509797066697E+00   0.58791547997105E+00   0.71119366706334E+00
   0.80028631885819E+00   0.86279267828944E+00   0.90583768172143E+00   0.93513171670697E+00   0.95492538616216E+00
   0.96825745122155E+00   0.97723861568980E+00   0.98332548194889E+00   0.98753804036679E+00   0.99057496690401E+00
   0.99288156839457E+00   0.99472620632395E+00   0.99627079519095E+00   0.99761843803344E+00   0.99884154065797E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.68251799340384E+00   0.68285017206474E+00   0.68275190528803E+00   0.68261318517223E+00   0.68240496603779E+00
   0.68207759388020E+00   0.68151970244396E+00   0.68057848929921E+00   0.67905606584379E+00   0.67666875194884E+00
   0.67273603469895E+00   0.66454508603979E+00   0.64400721976741E+00   0.60204511243175E+00   0.53992249003457E+00
   0.46476299302818E+00   0.38198113027309E+00   0.29423570618217E+00   0.20218521673193E+00   0.10496198255497E+00
   0.00000000000000E+00
 Statistics:
    FNS, JACS:97,  17
    STEPS, ETF, CTF:48,  1,  0
-T=  0.60000E+00
 X(S,TN):
   0.34921448494076E-13   0.22981439531097E+00   0.43346055130872E+00   0.59680570662002E+00   0.71893789946941E+00
   0.80625675496545E+00   0.86701301185096E+00   0.90860671815138E+00   0.93680826662235E+00   0.95582461227373E+00
   0.96861832147465E+00   0.97723715723382E+00   0.98309967448576E+00   0.98720152062877E+00   0.99021283166830E+00
   0.99254432472928E+00   0.99444027065991E+00   0.99604950748049E+00   0.99746839647591E+00   0.99876586731933E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.88960252996354E+00   0.88999280132192E+00   0.88987395954277E+00   0.88968476961142E+00   0.88940790618994E+00
   0.88898096654283E+00   0.88826891352185E+00   0.88708760048559E+00   0.88519170173226E+00   0.88216156906403E+00
   0.87661606889136E+00   0.86287741230203E+00   0.82815828170659E+00   0.76514531515533E+00   0.68019050045773E+00
   0.58211293088298E+00   0.47650032477986E+00   0.36587357891849E+00   0.25067036034383E+00   0.12971934592329E+00
   0.00000000000000E+00
 Statistics:
    FNS, JACS:99,  17
    STEPS, ETF, CTF:50,  1,  0
-T=  0.70000E+00
 X(S,TN):
   0.39581058538728E-13   0.23377905361721E+00   0.43967186810861E+00   0.60328029580792E+00   0.72445454104991E+00
   0.81040079391770E+00   0.86983970276644E+00   0.91035607986792E+00   0.93774942912838E+00   0.95618759355780E+00
   0.96858195358542E+00   0.97693769342118E+00   0.98265523524132E+00   0.98671713234524E+00   0.98975044632721E+00
   0.99213740355916E+00   0.99410577335986E+00   0.99579544804295E+00   0.99729814093372E+00   0.99868058138925E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.11405410367218E+01   0.11409879181167E+01   0.11408486427610E+01   0.11405938278885E+01   0.11402253729408E+01
   0.11396651889401E+01   0.11387476237349E+01   0.11372454294993E+01   0.11348389554149E+01   0.11308433409514E+01
   0.11225206803137E+01   0.10998127682288E+01   0.10462626728674E+01   0.95835064038583E+00   0.84668338522179E+00
   0.72153621317234E+00   0.58878963322130E+00   0.45092145719213E+00   0.30818413233869E+00   0.15907043748619E+00
   0.00000000000000E+00
 Statistics:
    FNS, JACS:102,  17
    STEPS, ETF, CTF:53,  1,  0
-T=  0.80000E+00
 X(S,TN):
   0.37954569523527E-13   0.23687844733439E+00   0.44446898274482E+00   0.60820018939986E+00   0.72856993752118E+00
   0.81342756023689E+00   0.87184797249918E+00   0.91154257347161E+00   0.93832208815600E+00   0.95632472656709E+00
   0.96842106795060E+00   0.97659284180957E+00   0.98222153825977E+00   0.98625636877570E+00   0.98931197841330E+00
   0.99174981122935E+00   0.99378501575304E+00   0.99555008203255E+00   0.99713268566197E+00   0.99859734992527E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.14552451152882E+01   0.14557792622974E+01   0.14556099550085E+01   0.14552524126281E+01   0.14547403822998E+01
   0.14539769354975E+01   0.14527543759338E+01   0.14507815423442E+01   0.14476047573307E+01   0.14420032892952E+01
   0.14287290500702E+01   0.13914372555694E+01   0.13111127078253E+01   0.11907322842023E+01   0.10453858234411E+01
   0.88684252484787E+00   0.72121918233434E+00   0.55080997935232E+00   0.37550634732565E+00   0.19331669648157E+00
   0.00000000000000E+00
 Statistics:
    FNS, JACS:107,  17
    STEPS, ETF, CTF:55,  1,  0
-T=  0.90000E+00
 X(S,TN):
   0.47004986274091E-13   0.23938161877579E+00   0.44826364294621E+00   0.61195878884688E+00   0.73154602184655E+00
   0.81542300544926E+00   0.87295424776024E+00   0.91194368711058E+00   0.93820195338006E+00   0.95583979314809E+00
   0.96769734821645E+00   0.97572783224168E+00   0.98132261250638E+00   0.98543524699746E+00   0.98860502588807E+00
   0.99116537947456E+00   0.99332334416035E+00   0.99520850016990E+00   0.99690765758174E+00   0.99848576494487E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.18699204923934E+01   0.18704670015640E+01   0.18702963036556E+01   0.18698193959790E+01   0.18691087247082E+01
   0.18680405971782E+01   0.18663435879801E+01   0.18636221340725E+01   0.18591754243072E+01   0.18507388165997E+01
   0.18289784636922E+01   0.17703324307399E+01   0.16558224901983E+01   0.14935810549739E+01   0.13037290227298E+01
   0.11008273301685E+01   0.89171884784704E+00   0.67870517463195E+00   0.46132327789948E+00   0.23687936558172E+00
   0.00000000000000E+00
 Statistics:
    FNS, JACS:115,  18
    STEPS, ETF, CTF:57,  1,  0
-T=  0.10000E+01
 X(S,TN):
   0.45801647286645E-13   0.24147668399788E+00   0.45139715052561E+00   0.61499570378881E+00   0.73386821331645E+00
   0.81688088048752E+00   0.87363738806035E+00   0.91201890854393E+00   0.93783685860958E+00   0.95517539904788E+00
   0.96684642682713E+00   0.97479298625964E+00   0.98038079875103E+00   0.98452195512474E+00   0.98776520396021E+00
   0.99043419357391E+00   0.99272230921026E+00   0.99475033009665E+00   0.99659953020852E+00   0.99833113953327E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.24595012097713E+01   0.24600911156977E+01   0.24598879793067E+01   0.24591931750024E+01   0.24581205619298E+01
   0.24564996299339E+01   0.24539415830210E+01   0.24498486518006E+01   0.24430018339040E+01   0.24290830349629E+01
   0.23920605128629E+01   0.22990009497997E+01   0.21327889917527E+01   0.19119343062940E+01   0.16620837886650E+01
   0.13994675928117E+01   0.11313861319206E+01   0.85984062228872E+00   0.58369866513344E+00   0.29933711963228E+00
   0.00000000000000E+00
 Statistics:
    FNS, JACS:123,  18
    STEPS, ETF, CTF:60,  1,  0
C
C#######################################################################
C
C RUNCYL : RUNINF file from single precision version
C          for the second example problem
C
C#######################################################################
C
 Reaction-diffusion prob. in cyl. coord.; pars: 1.00000 0.00010 1.00000 0.10000 
 MoL, PDE+D&D int.face; DAE int.: DASSL;  ID:ACM-TOMS, Ex.I                     
 NPTS= 21; RTOL=.100E-02, ATOL=.100E-02                                         
 TAU=.000E+00, KAPPA=.200E+01, ALPHA=.100E-01                                   
 Time=  0.20000E-03; H=  0.10000E-03; Order= 1
 Time=  0.40000E-03; H=  0.20000E-03; Order= 2
 Time=  0.80000E-03; H=  0.40000E-03; Order= 1
 Time=  0.16000E-02; H=  0.80000E-03; Order= 1
 Time=  0.32000E-02; H=  0.16000E-02; Order= 1
 Time=  0.48000E-02; H=  0.16000E-02; Order= 1
 Time=  0.64000E-02; H=  0.16000E-02; Order= 1
 Time=  0.96000E-02; H=  0.32000E-02; Order= 2
 Time=  0.12480E-01; H=  0.28800E-02; Order= 2
 Time=  0.15360E-01; H=  0.28800E-02; Order= 2
 Time=  0.18240E-01; H=  0.28800E-02; Order= 2
 Time=  0.21120E-01; H=  0.28800E-02; Order= 2
 Time=  0.24000E-01; H=  0.28800E-02; Order= 1
 Time=  0.26410E-01; H=  0.24103E-02; Order= 1
 Time=  0.28821E-01; H=  0.24103E-02; Order= 1
 Time=  0.31231E-01; H=  0.24103E-02; Order= 1
 Time=  0.33641E-01; H=  0.24103E-02; Order= 1
 Time=  0.35810E-01; H=  0.21693E-02; Order= 1
 Time=  0.37586E-01; H=  0.17755E-02; Order= 1
 Time=  0.39361E-01; H=  0.17755E-02; Order= 1
 Time=  0.41137E-01; H=  0.17755E-02; Order= 1
 Time=  0.44688E-01; H=  0.35509E-02; Order= 1
 Time=  0.48239E-01; H=  0.35509E-02; Order= 1
 Time=  0.51790E-01; H=  0.35509E-02; Order= 1
 Time=  0.55341E-01; H=  0.35509E-02; Order= 2
 Time=  0.58892E-01; H=  0.35509E-02; Order= 2
 Time=  0.65993E-01; H=  0.71019E-02; Order= 2
 Time=  0.73095E-01; H=  0.71019E-02; Order= 2
 Time=  0.80197E-01; H=  0.71019E-02; Order= 2
 Time=  0.87299E-01; H=  0.71019E-02; Order= 2
 Time=  0.91368E-01; H=  0.40692E-02; Order= 1
 Time=  0.95031E-01; H=  0.36623E-02; Order= 1
 Time=  0.98693E-01; H=  0.36623E-02; Order= 1
 Time=  0.10602E+00; H=  0.73246E-02; Order= 1
 Time=  0.11334E+00; H=  0.73246E-02; Order= 1
 Time=  0.12067E+00; H=  0.73246E-02; Order= 1
 Time=  0.13532E+00; H=  0.14649E-01; Order= 2
 Time=  0.14997E+00; H=  0.14649E-01; Order= 2
 Time=  0.17926E+00; H=  0.29299E-01; Order= 2
 Time=  0.20363E+00; H=  0.24371E-01; Order= 2
 Time=  0.22801E+00; H=  0.24371E-01; Order= 2
 Time=  0.25238E+00; H=  0.24371E-01; Order= 2
 Time=  0.30112E+00; H=  0.48741E-01; Order= 2
 Time=  0.34498E+00; H=  0.43867E-01; Order= 2
 Time=  0.38885E+00; H=  0.43867E-01; Order= 2
 Time=  0.43272E+00; H=  0.43867E-01; Order= 2
 Time=  0.47659E+00; H=  0.43867E-01; Order= 2
 Time=  0.52045E+00; H=  0.43867E-01; Order= 3
 Time=  0.56432E+00; H=  0.43867E-01; Order= 3
 Time=  0.60819E+00; H=  0.43867E-01; Order= 3
 Time=  0.65205E+00; H=  0.43867E-01; Order= 3
 Time=  0.69592E+00; H=  0.43867E-01; Order= 3
 Time=  0.73979E+00; H=  0.43867E-01; Order= 3
 Time=  0.78365E+00; H=  0.43867E-01; Order= 4
 Time=  0.82752E+00; H=  0.43867E-01; Order= 4
 Time=  0.87139E+00; H=  0.43867E-01; Order= 3
 Time=  0.91526E+00; H=  0.43867E-01; Order= 3
 Time=  0.95912E+00; H=  0.43867E-01; Order= 3
 Time=  0.99734E+00; H=  0.38219E-01; Order= 3
C
C#######################################################################
C
C RESDSH : RESULT file from single precision version  !!! TAU = 1E-3 !!!
C          for the third example problem              !!!  in driver !!!
C
C#######################################################################
C
 Burgers, double wave, eps=0.00100                                              
 MoL, PDE+D&D int.face; DAE int.: DASSL;  ID:ACM-TOMS, Ex.I                     
 NPTS= 21; RTOL=.100E-02, ATOL=.100E-02                                         
 TAU=.100E-02, KAPPA=.200E+01, ALPHA=.100E-01                                   
-T=  0.00000E+00
 X(S,TN):
   0.00000000000000E+00   0.50000000000000E-01   0.10000000000000E+00   0.15000000000000E+00   0.20000000000000E+00
   0.25000000000000E+00   0.30000000000000E+00   0.35000000000000E+00   0.40000000000000E+00   0.45000000000000E+00
   0.50000000000000E+00   0.55000000000000E+00   0.60000000000000E+00   0.65000000000000E+00   0.70000000000000E+00
   0.75000000000000E+00   0.80000000000000E+00   0.85000000000000E+00   0.90000000000000E+00   0.95000000000000E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01   0.99999999999306E+00   0.99999813668036E+00
   0.75000000000000E+00   0.50000186331964E+00   0.50000000000691E+00   0.49999999917554E+00   0.49998184085253E+00
   0.30000000000008E+00   0.10001815914748E+00   0.10000000082447E+00   0.10000000000003E+00   0.10000000000001E+00
   0.10000000000000E+00   0.10000000000000E+00   0.10000000000000E+00   0.10000000000000E+00   0.10000000000000E+00
   0.10000000000000E+00
 ERR_U:
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00
 MAX. NORM:0.
 TWO  NORM:0.
-T=  0.25000E+00
 X(S,TN):
  -0.37891601176756E-15   0.10848055509164E+00   0.20332174224602E+00   0.27818788926894E+00   0.33366992698232E+00
   0.37291449236776E+00   0.40083269943473E+00   0.42007773647351E+00   0.43538172016705E+00   0.45161440303086E+00
   0.47211390316070E+00   0.49609018968139E+00   0.52169029066663E+00   0.54552369889280E+00   0.56985721764227E+00
   0.60028585176896E+00   0.64240073633294E+00   0.70136740651490E+00   0.78157681490121E+00   0.88350477445082E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.10000000000000E+01   0.99716090200240E+00   0.10053914380846E+01   0.99398224508314E+00   0.99342161276444E+00
   0.10192371570112E+01   0.10241375073556E+01   0.91800355662522E+00   0.70721621975003E+00   0.55195732913796E+00
   0.52757264468458E+00   0.55692444902700E+00   0.54507000553550E+00   0.41902703094050E+00   0.24891573805615E+00
   0.15397698065475E+00   0.12084620954434E+00   0.10668399852427E+00   0.10148885109538E+00   0.10021053851896E+00
   0.10000000000000E+00
 ERR_U:
   0.00000000000000E+00  -0.28390979976081E-02   0.53914380846081E-02  -0.60177549168685E-02  -0.65783872328993E-02
   0.19237205616918E-01   0.24189725696601E-01  -0.75660183208942E-01  -0.10747518323472E+00   0.37702670997412E-01
   0.27485400773003E-01   0.56924287427126E-01   0.45079372751633E-01  -0.79875007156359E-01  -0.14573863875942E+00
   0.51447659838765E-01   0.20845650165781E-01   0.66839985200429E-02   0.14888510953797E-02   0.21053851895525E-03
  -0.57731597280508E-14
 MAX. NORM:0.1457386387594
 TWO  NORM:3.6673013640631E-2
 Statistics:
    FNS, JACS:122,  25
    STEPS, ETF, CTF:54,  2,  0
-T=  0.55000E+00
 X(S,TN):
  -0.27790329873557E-15   0.16055128031105E+00   0.30094085435990E+00   0.41131262906257E+00   0.49221934507321E+00
   0.54917312062871E+00   0.58840106248221E+00   0.61518844446592E+00   0.63348452026696E+00   0.64623977482739E+00
   0.65504882834307E+00   0.66207961766384E+00   0.66932004779528E+00   0.67862290146947E+00   0.69196938700943E+00
   0.71174600462994E+00   0.74073205670176E+00   0.78232068363145E+00   0.83987666567841E+00   0.91417604522829E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.10000000000000E+01   0.99404747348641E+00   0.99946722007484E+00   0.10044685471444E+01   0.99915580428724E+00
   0.99347717408065E+00   0.98419486010519E+00   0.99821262941603E+00   0.10343658159498E+01   0.10197795330447E+01
   0.85462754390147E+00   0.55618180739419E+00   0.28636978345933E+00   0.14920826026947E+00   0.10792619259334E+00
   0.10886929643692E+00   0.10812607952673E+00   0.10260598194636E+00   0.10090699464095E+00   0.10023516467595E+00
   0.10000000000000E+00
 ERR_U:
   0.00000000000000E+00  -0.59525265135889E-02  -0.53277992516598E-03   0.44685471444339E-02  -0.84419571276584E-03
  -0.65228259191130E-02  -0.15805135388920E-01  -0.17837212230880E-02   0.34720445840037E-01   0.28568673809389E-01
  -0.63165151554877E-01  -0.68370543165546E-01   0.27808787742817E-01   0.23637133557707E-01   0.61141218951626E-02
   0.88344851387885E-02   0.81259738311004E-02   0.26059819205542E-02   0.90699464095145E-03   0.23516467594931E-03
   0.00000000000000E+00
 MAX. NORM:6.8370543165546E-2
 TWO  NORM:1.1319532422608E-2
 Statistics:
    FNS, JACS:183,  35
    STEPS, ETF, CTF:77,  3,  0
-T=  0.10000E+01
 X(S,TN):
  -0.58445754991170E-15   0.21706569079431E+00   0.40780040570791E+00   0.55894047714684E+00   0.67056722424815E+00
   0.74955212777111E+00   0.80409863830369E+00   0.84125722184744E+00   0.86641102981316E+00   0.88337104837509E+00
   0.89477422199390E+00   0.90242422560976E+00   0.90755227028564E+00   0.91150486084567E+00   0.91550801896004E+00
   0.92077445074001E+00   0.92854361287370E+00   0.93980818553739E+00   0.95555600033186E+00   0.97609859264019E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:1
   0.99999999999999E+00   0.99915167486587E+00   0.99407749143252E+00   0.99698475698242E+00   0.99847110322787E+00
   0.10013005332587E+01   0.10042199615836E+01   0.99925106158264E+00   0.10035485428128E+01   0.10001426793997E+01
   0.10025714765328E+01   0.10012085019586E+01   0.85186413971121E+00   0.54287600370401E+00   0.24225328706092E+00
   0.10800863019187E+00   0.10040224796535E+00   0.10039561113376E+00   0.10035992330620E+00   0.10017137784193E+00
   0.10000000000000E+00
 ERR_U:
  -0.71054273576010E-14  -0.84832513412891E-03  -0.59225085674797E-02  -0.30152430175789E-02  -0.15288967721290E-02
   0.13005332586502E-02   0.42199615836367E-02  -0.74893841734891E-03   0.35485444662910E-02   0.14609078360905E-03
   0.31485147989585E-02   0.18906229345177E-01   0.28617238632087E-02   0.32639187076953E-01   0.32932764414708E-01
  -0.34764476103528E-02   0.49719108810020E-04   0.39339344797318E-03   0.35992145152353E-03   0.17137784174270E-03
   0.00000000000000E+00
 MAX. NORM:3.2932764414708E-2
 TWO  NORM:4.5316570225481E-3
 Statistics:
    FNS, JACS:291,  64
    STEPS, ETF, CTF:120,  10,  4
C
C#######################################################################
C
C RUNDSH : RUNINF file from single precision version  !!! TAU = 1E-3 !!!
C          for the third example problem              !!!  in driver !!!
C
C#######################################################################
C
 Burgers, double wave, eps=0.00100                                              
 MoL, PDE+D&D int.face; DAE int.: DASSL;  ID:ACM-TOMS, Ex.I                     
 NPTS= 21; RTOL=.100E-02, ATOL=.100E-02                                         
 TAU=.100E-02, KAPPA=.200E+01, ALPHA=.100E-01                                   
 Time=  0.65287E-05; H=  0.32643E-05; Order= 1
 Time=  0.13057E-04; H=  0.65287E-05; Order= 2
 Time=  0.26115E-04; H=  0.13057E-04; Order= 1
 Time=  0.52229E-04; H=  0.26115E-04; Order= 1
 Time=  0.78344E-04; H=  0.26115E-04; Order= 1
 Time=  0.13057E-03; H=  0.52229E-04; Order= 1
 Time=  0.17717E-03; H=  0.46598E-04; Order= 1
 Time=  0.22377E-03; H=  0.46598E-04; Order= 1
 Time=  0.27037E-03; H=  0.46598E-04; Order= 1
 Time=  0.31696E-03; H=  0.46598E-04; Order= 1
 Time=  0.36356E-03; H=  0.46598E-04; Order= 1
 Time=  0.40310E-03; H=  0.39538E-04; Order= 1
 Time=  0.44264E-03; H=  0.39538E-04; Order= 1
 Time=  0.48218E-03; H=  0.39538E-04; Order= 1
 Time=  0.56125E-03; H=  0.79076E-04; Order= 2
 Time=  0.64033E-03; H=  0.79076E-04; Order= 2
 Time=  0.79848E-03; H=  0.15815E-03; Order= 2
 Time=  0.93806E-03; H=  0.13958E-03; Order= 2
 Time=  0.10776E-02; H=  0.13958E-03; Order= 2
 Time=  0.12172E-02; H=  0.13958E-03; Order= 2
 Time=  0.13303E-02; H=  0.11307E-03; Order= 2
 Time=  0.14320E-02; H=  0.10176E-03; Order= 2
 Time=  0.15338E-02; H=  0.10176E-03; Order= 2
 Time=  0.16356E-02; H=  0.10176E-03; Order= 2
 Time=  0.17373E-02; H=  0.10176E-03; Order= 1
 Time=  0.18391E-02; H=  0.10176E-03; Order= 1
 Time=  0.20426E-02; H=  0.20352E-03; Order= 1
 Time=  0.22461E-02; H=  0.20352E-03; Order= 1
 Time=  0.24497E-02; H=  0.20352E-03; Order= 1
 Time=  0.28567E-02; H=  0.40704E-03; Order= 2
 Time=  0.32637E-02; H=  0.40704E-03; Order= 2
 Time=  0.39268E-02; H=  0.66305E-03; Order= 1
 Time=  0.45145E-02; H=  0.58773E-03; Order= 1
 Time=  0.56900E-02; H=  0.11755E-02; Order= 1
 Time=  0.68654E-02; H=  0.11755E-02; Order= 1
 Time=  0.92164E-02; H=  0.23509E-02; Order= 1
 Time=  0.11567E-01; H=  0.23509E-02; Order= 1
 Time=  0.16269E-01; H=  0.47018E-02; Order= 1
 Time=  0.25673E-01; H=  0.94037E-02; Order= 1
 Time=  0.35076E-01; H=  0.94037E-02; Order= 1
 Time=  0.44480E-01; H=  0.94037E-02; Order= 1
 Time=  0.63287E-01; H=  0.18807E-01; Order= 1
 Time=  0.80214E-01; H=  0.16927E-01; Order= 1
 Time=  0.95352E-01; H=  0.15138E-01; Order= 1
 Time=  0.11049E+00; H=  0.15138E-01; Order= 1
 Time=  0.12563E+00; H=  0.15138E-01; Order= 1
 Time=  0.13973E+00; H=  0.14103E-01; Order= 1
 Time=  0.15110E+00; H=  0.11366E-01; Order= 1
 Time=  0.16246E+00; H=  0.11366E-01; Order= 1
 Time=  0.17383E+00; H=  0.11366E-01; Order= 1
 Time=  0.18519E+00; H=  0.11366E-01; Order= 1
 Time=  0.20792E+00; H=  0.22732E-01; Order= 2
 Time=  0.23066E+00; H=  0.22732E-01; Order= 1
 Time=  0.25339E+00; H=  0.22732E-01; Order= 1
 Time=  0.26519E+00; H=  0.11805E-01; Order= 1
 Time=  0.27452E+00; H=  0.93318E-02; Order= 1
 Time=  0.28386E+00; H=  0.93318E-02; Order= 1
 Time=  0.29319E+00; H=  0.93318E-02; Order= 1
 Time=  0.30252E+00; H=  0.93318E-02; Order= 2
 Time=  0.31185E+00; H=  0.93318E-02; Order= 2
 Time=  0.32118E+00; H=  0.93318E-02; Order= 1
 Time=  0.33985E+00; H=  0.18664E-01; Order= 1
 Time=  0.35851E+00; H=  0.18664E-01; Order= 1
 Time=  0.37405E+00; H=  0.15540E-01; Order= 1
 Time=  0.38959E+00; H=  0.15540E-01; Order= 1
 Time=  0.40513E+00; H=  0.15540E-01; Order= 1
 Time=  0.41912E+00; H=  0.13986E-01; Order= 1
 Time=  0.43310E+00; H=  0.13986E-01; Order= 1
 Time=  0.44709E+00; H=  0.13986E-01; Order= 1
 Time=  0.46107E+00; H=  0.13986E-01; Order= 2
 Time=  0.47506E+00; H=  0.13986E-01; Order= 2
 Time=  0.48905E+00; H=  0.13986E-01; Order= 2
 Time=  0.50303E+00; H=  0.13986E-01; Order= 2
 Time=  0.51702E+00; H=  0.13986E-01; Order= 3
 Time=  0.53100E+00; H=  0.13986E-01; Order= 3
 Time=  0.54499E+00; H=  0.13986E-01; Order= 2
 Time=  0.55758E+00; H=  0.12587E-01; Order= 2
 Time=  0.57017E+00; H=  0.12587E-01; Order= 2
 Time=  0.58082E+00; H=  0.10654E-01; Order= 2
 Time=  0.59147E+00; H=  0.10654E-01; Order= 2
 Time=  0.60213E+00; H=  0.10654E-01; Order= 2
 Time=  0.61732E+00; H=  0.15190E-01; Order= 2
 Time=  0.62745E+00; H=  0.10137E-01; Order= 1
 Time=  0.63658E+00; H=  0.91232E-02; Order= 1
 Time=  0.64570E+00; H=  0.91232E-02; Order= 1
 Time=  0.65482E+00; H=  0.91232E-02; Order= 1
 Time=  0.66395E+00; H=  0.91232E-02; Order= 1
 Time=  0.68219E+00; H=  0.18246E-01; Order= 2
 Time=  0.70044E+00; H=  0.18246E-01; Order= 2
 Time=  0.71869E+00; H=  0.18246E-01; Order= 2
 Time=  0.71966E+00; H=  0.97011E-03; Order= 2
 Time=  0.72160E+00; H=  0.19402E-02; Order= 2
 Time=  0.72257E+00; H=  0.97011E-03; Order= 2
 Time=  0.72451E+00; H=  0.19402E-02; Order= 2
 Time=  0.72839E+00; H=  0.38804E-02; Order= 1
 Time=  0.73615E+00; H=  0.77609E-02; Order= 1
 Time=  0.74391E+00; H=  0.77609E-02; Order= 1
 Time=  0.75943E+00; H=  0.15522E-01; Order= 1
 Time=  0.77495E+00; H=  0.15522E-01; Order= 1
 Time=  0.79047E+00; H=  0.15522E-01; Order= 1
 Time=  0.82152E+00; H=  0.31043E-01; Order= 1
 Time=  0.83966E+00; H=  0.18145E-01; Order= 1
 Time=  0.85781E+00; H=  0.18145E-01; Order= 1
 Time=  0.87595E+00; H=  0.18145E-01; Order= 1
 Time=  0.89410E+00; H=  0.18145E-01; Order= 2
 Time=  0.91224E+00; H=  0.18145E-01; Order= 2
 Time=  0.93039E+00; H=  0.18145E-01; Order= 2
 Time=  0.94853E+00; H=  0.18145E-01; Order= 2
 Time=  0.96668E+00; H=  0.18145E-01; Order= 2
 Time=  0.96693E+00; H=  0.25517E-03; Order= 1
 Time=  0.96714E+00; H=  0.20321E-03; Order= 1
 Time=  0.96732E+00; H=  0.18289E-03; Order= 1
 Time=  0.96750E+00; H=  0.18289E-03; Order= 1
 Time=  0.96787E+00; H=  0.36577E-03; Order= 1
 Time=  0.96860E+00; H=  0.73154E-03; Order= 1
 Time=  0.97006E+00; H=  0.14631E-02; Order= 1
 Time=  0.97299E+00; H=  0.29262E-02; Order= 1
 Time=  0.97884E+00; H=  0.58524E-02; Order= 1
 Time=  0.99055E+00; H=  0.11705E-01; Order= 1
C
C#######################################################################
C
C RESBAK : RESULT file from double precision version
C          for the first example problem
C
C#######################################################################
C
 Bakker, Electrodynamics problem; EPS=0.143, P=0.1743, ETA=17.19                
 MoL, PDE+D&D int.face; DAE int.: DASSL;  ID:ACM-TOMS, Ex.I                     
 NPTS= 21; RTOL=.100E-02, ATOL=.100E-02                                         
 TAU=.000E+00, KAPPA=.200E+01, ALPHA=.100E-01                                   
-T=  0.00000E+00
 X(S,TN):
   0.00000000000000E+00   0.50000000000000E-01   0.10000000000000E+00   0.15000000000000E+00   0.20000000000000E+00
   0.25000000000000E+00   0.30000000000000E+00   0.35000000000000E+00   0.40000000000000E+00   0.45000000000000E+00
   0.50000000000000E+00   0.55000000000000E+00   0.60000000000000E+00   0.65000000000000E+00   0.70000000000000E+00
   0.75000000000000E+00   0.80000000000000E+00   0.85000000000000E+00   0.90000000000000E+00   0.95000000000000E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01
   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01
   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01
   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           2
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00
-T=  0.10000E-03
 X(S,TN):
   0.12735266044843E-20   0.25040639326087E-01   0.56481180725208E-01   0.95013743451470E-01   0.14035700864980E+00
   0.19172996726927E+00   0.24805285524386E+00   0.30815424596408E+00   0.37092072417169E+00   0.43536105277879E+00
   0.50059964810099E+00   0.56582746220412E+00   0.63023450420058E+00   0.69294260070383E+00   0.75295708822915E+00
   0.80916185063231E+00   0.86038575125554E+00   0.90555451801052E+00   0.94389834500290E+00   0.97514972171545E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.97256278198193E+00   0.97297329463441E+00   0.97347359749868E+00   0.97362279770200E+00   0.97365968616696E+00
   0.97366795253582E+00   0.97366993754548E+00   0.97367061722011E+00   0.97367094665865E+00   0.97367111095284E+00
   0.97367116090313E+00   0.97367110995316E+00   0.97367094676961E+00   0.97367066001102E+00   0.97367048642589E+00
   0.97367279233329E+00   0.97369354245866E+00   0.97382236631722E+00   0.97451337030300E+00   0.97805479283087E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           2
  -0.11133568923724E-18   0.21863837076523E-01   0.25474655266945E-01   0.26176978367779E-01   0.26306690020029E-01
   0.26327294406898E-01   0.26329526685214E-01   0.26329338687379E-01   0.26329051471724E-01   0.26328889401451E-01
   0.26328839463709E-01   0.26328890552885E-01   0.26329056710793E-01   0.26329390777144E-01   0.26330088349518E-01
   0.26332151383376E-01   0.26340710275091E-01   0.26378419453056E-01   0.26528830914739E-01   0.27025637086854E-01
   0.27429641093465E-01
 Statistics:
    FNS, JACS:          25           9
    STEPS, ETF, CTF:          14           0           0
-T=  0.10000E-02
 X(S,TN):
  -0.31906882002238E-17   0.12035734678889E-01   0.27659167677363E-01   0.49865296342561E-01   0.81605227784395E-01
   0.12602481635131E+00   0.18619274132530E+00   0.26401844342278E+00   0.35861206116750E+00   0.46490938763530E+00
   0.57403998234074E+00   0.67610273839132E+00   0.76369508101800E+00   0.83368289032634E+00   0.88661995793678E+00
   0.92509609767101E+00   0.95229372726289E+00   0.97117434284798E+00   0.98419344945419E+00   0.99327637429847E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.84124639823106E+00   0.85198010709681E+00   0.86417807430651E+00   0.86767855422229E+00   0.86870605012885E+00
   0.86901606864834E+00   0.86910499263221E+00   0.86912954072521E+00   0.86913888040758E+00   0.86914157449020E+00
   0.86913640725412E+00   0.86912565320863E+00   0.86912013739702E+00   0.86915098091298E+00   0.86930686281480E+00
   0.86979878730867E+00   0.87108032204927E+00   0.87416885665395E+00   0.88202796056816E+00   0.90698278831326E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           2
   0.27362584056932E-16   0.85805318132295E-01   0.11962496086593E+00   0.12841936075473E+00   0.13028719332919E+00
   0.13074916269906E+00   0.13085454149197E+00   0.13086675979615E+00   0.13086128491548E+00   0.13085860096827E+00
   0.13086418658332E+00   0.13087854377689E+00   0.13090461599334E+00   0.13096181266530E+00   0.13110841054542E+00
   0.13150474101938E+00   0.13256555854283E+00   0.13518001844746E+00   0.14028783863406E+00   0.14665930978927E+00
   0.14940965033950E+00
 Statistics:
    FNS, JACS:          61          13
    STEPS, ETF, CTF:          33           0           0
-T=  0.10000E-01
 X(S,TN):
  -0.34427396769781E-17   0.16258714721784E-01   0.34382803883098E-01   0.56834581624210E-01   0.87039190267673E-01
   0.12957331395931E+00   0.18909073892025E+00   0.26896477224061E+00   0.36925991127282E+00   0.48381263002083E+00
   0.60022732075013E+00   0.70517642808932E+00   0.79063665057306E+00   0.85527414673292E+00   0.90186196170236E+00
   0.93448224216549E+00   0.95706725596805E+00   0.97276766629829E+00   0.98401678064684E+00   0.99265705857935E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.55402381033045E+00   0.58108980934503E+00   0.63225335776498E+00   0.66627482059999E+00   0.68085510330969E+00
   0.68521135327001E+00   0.68607444631980E+00   0.68618620843153E+00   0.68620362725334E+00   0.68620857886650E+00
   0.68620572666962E+00   0.68620187972406E+00   0.68622615390488E+00   0.68640891833359E+00   0.68722055551815E+00
   0.68983205538279E+00   0.69843451101787E+00   0.72636209309199E+00   0.78483334969053E+00   0.87331834425110E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           2
   0.95184531308424E-17   0.10434520528725E+00   0.18773166403372E+00   0.25316357939666E+00   0.29495931453764E+00
   0.31083912490386E+00   0.31358223737728E+00   0.31379490184334E+00   0.31379630801653E+00   0.31379210106119E+00
   0.31379642970886E+00   0.31381269708857E+00   0.31387647556126E+00   0.31432320353576E+00   0.31681119642406E+00
   0.32390565438164E+00   0.33490067435648E+00   0.34648469633414E+00   0.35618582547805E+00   0.36293333411257E+00
   0.36542672394796E+00
 Statistics:
    FNS, JACS:          87          16
    STEPS, ETF, CTF:          50           0           0
-T=  0.10000E+00
 X(S,TN):
  -0.39301477256394E-17   0.27509404552255E-01   0.55993690934573E-01   0.86797140010640E-01   0.12184094937080E+00
   0.16382419162279E+00   0.21643943774507E+00   0.28414071410633E+00   0.37020645489382E+00   0.47234803523237E+00
   0.58046901407967E+00   0.68113067880431E+00   0.76478953875800E+00   0.82907672511573E+00   0.87662241250314E+00
   0.91151512663199E+00   0.93755439912681E+00   0.95766078321055E+00   0.97387203296257E+00   0.98760826479254E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.21974581958237E+00   0.24082420330226E+00   0.29058154205529E+00   0.34867209330565E+00   0.40416761691641E+00
   0.44973832739684E+00   0.48125563997830E+00   0.49908703254335E+00   0.50698579099418E+00   0.50962248204921E+00
   0.51055295173930E+00   0.51203197391951E+00   0.51609497811219E+00   0.52517682893805E+00   0.54436737672286E+00
   0.58048304001242E+00   0.63431439688620E+00   0.70289964811670E+00   0.78413725148810E+00   0.87974878778198E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           2
  -0.13624965605258E-15   0.88797777761149E-01   0.16833568476902E+00   0.24183227584845E+00   0.31039173924030E+00
   0.37292548234698E+00   0.42566520225675E+00   0.46296774306353E+00   0.48196688573240E+00   0.48823949841194E+00
   0.49030549079910E+00   0.49378958448182E+00   0.50305423421003E+00   0.51960830875674E+00   0.54068701843747E+00
   0.56194301928120E+00   0.58032835184249E+00   0.59478264507916E+00   0.60534717011268E+00   0.61217164379082E+00
   0.61461846804860E+00
 Statistics:
    FNS, JACS:         109          18
    STEPS, ETF, CTF:          67           0           0
-T=  0.25000E+00
 X(S,TN):
  -0.77394232436680E-17   0.35291221664463E-01   0.71018431022303E-01   0.10814716025685E+00   0.14806467131394E+00
   0.19254335127895E+00   0.24383323005932E+00   0.30463544673108E+00   0.37745820613596E+00   0.46262697494835E+00
   0.55547537960931E+00   0.64660274647643E+00   0.72720767170189E+00   0.79352487284645E+00   0.84616067038737E+00
   0.88743094489920E+00   0.91981706317539E+00   0.94553072421687E+00   0.96644695048773E+00   0.98413120226406E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.10805705916213E+00   0.12867791899390E+00   0.17698900114014E+00   0.23411718404617E+00   0.29233050707449E+00
   0.34784140635393E+00   0.39770957980354E+00   0.43884574066553E+00   0.46883323643915E+00   0.48788864682981E+00
   0.50012027062367E+00   0.51181152842142E+00   0.52821211043232E+00   0.55126994712413E+00   0.58088175239822E+00
   0.61789338302322E+00   0.66469197252236E+00   0.72340648718939E+00   0.79551786106221E+00   0.88411324464246E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           2
   0.17469927481663E-15   0.74015539998398E-01   0.14091572536753E+00   0.20354613540268E+00   0.26322294010332E+00
   0.32010381620710E+00   0.37315588660869E+00   0.41999812692253E+00   0.45728021060632E+00   0.48295040418049E+00
   0.50002303997364E+00   0.51592897230737E+00   0.53662083545962E+00   0.56286218700354E+00   0.59169050558857E+00
   0.61938043315802E+00   0.64316762431140E+00   0.66177186103287E+00   0.67509370824274E+00   0.68341973830992E+00
   0.68632761812349E+00
 Statistics:
    FNS, JACS:         117          19
    STEPS, ETF, CTF:          74           0           0
-T=  0.50000E+00
 X(S,TN):
  -0.10401087858425E-16   0.44439151133995E-01   0.88805088552306E-01   0.13391993683124E+00   0.18087852430772E+00
   0.23083500485522E+00   0.28495787019539E+00   0.34430963703802E+00   0.40951501036849E+00   0.48017583876915E+00
   0.55428244881976E+00   0.62829194501305E+00   0.69829213086099E+00   0.76140020008967E+00   0.81625721438405E+00
   0.86267938943143E+00   0.90118650103872E+00   0.93275308192034E+00   0.95869690488395E+00   0.98054836694031E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.61705929604197E-01   0.83571879788228E-01   0.13215155188268E+00   0.18633487608590E+00   0.24042715340552E+00
   0.29267601089896E+00   0.34206233746634E+00   0.38753974105531E+00   0.42811989595439E+00   0.46346853064190E+00
   0.49467344670541E+00   0.52422258784898E+00   0.55451705126760E+00   0.58639623915570E+00   0.61954797764149E+00
   0.65442536646998E+00   0.69380874783919E+00   0.74236196848809E+00   0.80489382030742E+00   0.88669437808147E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           2
   0.65700895428383E-17   0.63742488280905E-01   0.12163930610606E+00   0.17672728262708E+00   0.22997916299074E+00
   0.28151559410249E+00   0.33094504614227E+00   0.37748431817190E+00   0.42020724704906E+00   0.45860632934568E+00
   0.49330139885287E+00   0.52612438718385E+00   0.55894431980083E+00   0.59231666089018E+00   0.62533815417105E+00
   0.65630911076061E+00   0.68338644478598E+00   0.70513627431929E+00   0.72093123514864E+00   0.73076743644006E+00
   0.73416693255123E+00
 Statistics:
    FNS, JACS:         125          20
    STEPS, ETF, CTF:          80           0           0
-T=  0.10000E+01
 X(S,TN):
  -0.11406215963647E-16   0.54377770873218E-01   0.10808494545177E+00   0.16166526266715E+00   0.21573566831410E+00
   0.27077928634383E+00   0.32712495869159E+00   0.38491610794514E+00   0.44407728911349E+00   0.50430112562059E+00
   0.56502043001203E+00   0.62539812132548E+00   0.68439946357148E+00   0.74088106716049E+00   0.79366717370613E+00
   0.84166550692797E+00   0.88402998991767E+00   0.92037820941479E+00   0.95100850159024E+00   0.97697226217635E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.41855949411223E-01   0.64374253575332E-01   0.11186576458892E+00   0.16204981001984E+00   0.21164684415231E+00
   0.26020612617869E+00   0.30762787512131E+00   0.35384101391037E+00   0.39881029175374E+00   0.44257074787550E+00
   0.48519358417400E+00   0.52670759824464E+00   0.56703195717810E+00   0.60593811685108E+00   0.64314510985640E+00
   0.67890452838048E+00   0.71527252502504E+00   0.75721067809429E+00   0.81192651738417E+00   0.88782965096200E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           2
  -0.44578590086900E-16   0.57131871581142E-01   0.10922405912238E+00   0.15955954423639E+00   0.20880633444811E+00
   0.25712191626928E+00   0.30452064222066E+00   0.35096005997028E+00   0.39640086415878E+00   0.44081256300659E+00
   0.48416065118635E+00   0.52638435236646E+00   0.56733422813828E+00   0.60668431532277E+00   0.64387209625146E+00
   0.67806800042322E+00   0.70817483079002E+00   0.73294885035043E+00   0.75138158024705E+00   0.76298941454337E+00
   0.76699670502140E+00
 Statistics:
    FNS, JACS:         134          22
    STEPS, ETF, CTF:          87           0           0
-T=  0.20000E+01
 X(S,TN):
  -0.10453487080052E-16   0.60053286165933E-01   0.11903672452853E+00   0.17727603349834E+00   0.23511696218743E+00
   0.29279152957340E+00   0.35043580843501E+00   0.40810222875161E+00   0.46575775109282E+00   0.52327762269772E+00
   0.58042938272098E+00   0.63684447638083E+00   0.69199386223164E+00   0.74516459050855E+00   0.79546429961772E+00
   0.84188923579970E+00   0.88349309414755E+00   0.91966686949829E+00   0.95044808153492E+00   0.97668378749828E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.35153327381863E-01   0.57866852450919E-01   0.10462818533458E+00   0.15300642904687E+00   0.20100812276954E+00
   0.24855288696498E+00   0.29567825964121E+00   0.34238444016013E+00   0.38862220583891E+00   0.43429258712398E+00
   0.47923390467058E+00   0.52319901522740E+00   0.56583658406214E+00   0.60670229517203E+00   0.64540345319058E+00
   0.68213413695708E+00   0.71883592384255E+00   0.76036196145162E+00   0.81407466926679E+00   0.88880159770786E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           2
   0.34573933836692E-18   0.54320861090747E-01   0.10405127525504E+00   0.15262123911497E+00   0.20056434916891E+00
   0.24804134438884E+00   0.29511681793596E+00   0.34179520808725E+00   0.38802982418713E+00   0.43372024294874E+00
   0.47869664080500E+00   0.52270547185292E+00   0.56538317938318E+00   0.60622870963442E+00   0.64459152942830E+00
   0.67964657569350E+00   0.71036894935769E+00   0.73560354154483E+00   0.75438226804794E+00   0.76620785212957E+00
   0.77028766323688E+00
 Statistics:
    FNS, JACS:         141          23
    STEPS, ETF, CTF:          92           0           0
-T=  0.30000E+01
 X(S,TN):
  -0.13366324572080E-16   0.61545066361672E-01   0.12195026065175E+00   0.18151997567421E+00   0.24056085440098E+00
   0.29926752772999E+00   0.35774350631857E+00   0.41601573874462E+00   0.47403668402769E+00   0.53167573923565E+00
   0.58870129545288E+00   0.64475511493700E+00   0.69932370370229E+00   0.75171721125178E+00   0.80107729582830E+00
   0.84644876003778E+00   0.88695339831125E+00   0.92206688860662E+00   0.95190593494043E+00   0.97735238369153E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.33958735600296E-01   0.56830009133886E-01   0.10362925772185E+00   0.15176446083203E+00   0.19952058657809E+00
   0.24686678052552E+00   0.29384678387965E+00   0.34046030294035E+00   0.38665459035630E+00   0.43231821554821E+00
   0.47726849921186E+00   0.52123390078984E+00   0.56383968835967E+00   0.60463098717535E+00   0.64324852363152E+00
   0.68001330356171E+00   0.71707808141388E+00   0.75938811990011E+00   0.81403088224003E+00   0.88929996809431E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           2
   0.32393540150085E-16   0.53908581777006E-01   0.10328104059902E+00   0.15158886646974E+00   0.19932382877629E+00
   0.24663696648239E+00   0.29358884731443E+00   0.34018119462850E+00   0.38636165480727E+00   0.43201871410969E+00
   0.47696905690635E+00   0.52093899626580E+00   0.56354236893223E+00   0.60425938926314E+00   0.64241853481305E+00
   0.67717432344575E+00   0.70749189089217E+00   0.73224723964890E+00   0.75056561312875E+00   0.76205909614406E+00
   0.76602032515102E+00
 Statistics:
    FNS, JACS:         146          24
    STEPS, ETF, CTF:          95           0           0
-T=  0.40000E+01
 X(S,TN):
  -0.30297382444938E-16   0.62278095516011E-01   0.12338590729591E+00   0.18362098710431E+00   0.24327345506977E+00
   0.30252136489478E+00   0.36145309760915E+00   0.42008213052454E+00   0.47834933356615E+00   0.53611465838921E+00
   0.59313957155571E+00   0.64906210077329E+00   0.70336918646940E+00   0.75537732988776E+00   0.80424319346191E+00
   0.84903885130975E+00   0.88892830477937E+00   0.92344077295069E+00   0.95274239030673E+00   0.97773675015179E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.33421637963707E-01   0.56380108309802E-01   0.10321818263640E+00   0.15125342893774E+00   0.19890288798807E+00
   0.24615558139679E+00   0.29305628330806E+00   0.33960301773953E+00   0.38574027870982E+00   0.43135254308473E+00
   0.47625146113157E+00   0.52015841477004E+00   0.56269173428307E+00   0.60339609249792E+00   0.64193678328880E+00
   0.67871350581785E+00   0.71600110078959E+00   0.75878544728673E+00   0.81398050607894E+00   0.88957191502355E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           2
  -0.16828799093902E-15   0.53737200467624E-01   0.10295749014437E+00   0.15115355821891E+00   0.19879600105626E+00
   0.24603030001145E+00   0.29291452768396E+00   0.33944816827416E+00   0.38557604940157E+00   0.43118275023506E+00
   0.47607968142906E+00   0.51998627277971E+00   0.56250806145106E+00   0.60311590039048E+00   0.64112763947077E+00
   0.67568621693854E+00   0.70575093777841E+00   0.73021688086726E+00   0.74826372716550E+00   0.75956438029934E+00
   0.76345721968372E+00
 Statistics:
    FNS, JACS:         147          24
    STEPS, ETF, CTF:          96           0           0
C
C#######################################################################
C
C RUNBAK : RUNINF file from double precision version
C          for the first example problem
C
C#######################################################################
C
 Bakker, Electrodynamics problem; EPS=0.143, P=0.1743, ETA=17.19                
 MoL, PDE+D&D int.face; DAE int.: DASSL;  ID:ACM-TOMS, Ex.I                     
 NPTS= 21; RTOL=.100E-02, ATOL=.100E-02                                         
 TAU=.000E+00, KAPPA=.200E+01, ALPHA=.100E-01                                   
 Time=  0.20000E-06; H=  0.10000E-06; Order= 1
 Time=  0.40000E-06; H=  0.20000E-06; Order= 2
 Time=  0.80000E-06; H=  0.40000E-06; Order= 1
 Time=  0.16000E-05; H=  0.80000E-06; Order= 1
 Time=  0.32000E-05; H=  0.16000E-05; Order= 1
 Time=  0.64000E-05; H=  0.32000E-05; Order= 1
 Time=  0.12800E-04; H=  0.64000E-05; Order= 1
 Time=  0.19200E-04; H=  0.64000E-05; Order= 1
 Time=  0.25600E-04; H=  0.64000E-05; Order= 1
 Time=  0.38400E-04; H=  0.12800E-04; Order= 2
 Time=  0.51200E-04; H=  0.12800E-04; Order= 2
 Time=  0.64000E-04; H=  0.12800E-04; Order= 2
 Time=  0.76800E-04; H=  0.12800E-04; Order= 2
 Time=  0.10240E-03; H=  0.25600E-04; Order= 2
 Time=  0.12800E-03; H=  0.25600E-04; Order= 1
 Time=  0.15104E-03; H=  0.23040E-04; Order= 1
 Time=  0.17408E-03; H=  0.23040E-04; Order= 1
 Time=  0.19712E-03; H=  0.23040E-04; Order= 1
 Time=  0.24320E-03; H=  0.46080E-04; Order= 2
 Time=  0.28928E-03; H=  0.46080E-04; Order= 2
 Time=  0.33536E-03; H=  0.46080E-04; Order= 2
 Time=  0.38144E-03; H=  0.46080E-04; Order= 2
 Time=  0.42752E-03; H=  0.46080E-04; Order= 2
 Time=  0.47360E-03; H=  0.46080E-04; Order= 3
 Time=  0.51968E-03; H=  0.46080E-04; Order= 2
 Time=  0.56576E-03; H=  0.46080E-04; Order= 2
 Time=  0.61184E-03; H=  0.46080E-04; Order= 2
 Time=  0.65792E-03; H=  0.46080E-04; Order= 2
 Time=  0.70400E-03; H=  0.46080E-04; Order= 1
 Time=  0.75008E-03; H=  0.46080E-04; Order= 1
 Time=  0.84224E-03; H=  0.92160E-04; Order= 1
 Time=  0.93440E-03; H=  0.92160E-04; Order= 1
 Time=  0.10266E-02; H=  0.92160E-04; Order= 1
 Time=  0.12109E-02; H=  0.18432E-03; Order= 2
 Time=  0.13952E-02; H=  0.18432E-03; Order= 2
 Time=  0.17638E-02; H=  0.36864E-03; Order= 2
 Time=  0.20956E-02; H=  0.33178E-03; Order= 2
 Time=  0.24274E-02; H=  0.33178E-03; Order= 2
 Time=  0.27592E-02; H=  0.33178E-03; Order= 2
 Time=  0.30909E-02; H=  0.33178E-03; Order= 2
 Time=  0.34227E-02; H=  0.33178E-03; Order= 3
 Time=  0.40863E-02; H=  0.66355E-03; Order= 3
 Time=  0.47498E-02; H=  0.66355E-03; Order= 3
 Time=  0.54134E-02; H=  0.66355E-03; Order= 3
 Time=  0.60769E-02; H=  0.66355E-03; Order= 3
 Time=  0.67405E-02; H=  0.66355E-03; Order= 2
 Time=  0.74040E-02; H=  0.66355E-03; Order= 2
 Time=  0.80676E-02; H=  0.66355E-03; Order= 2
 Time=  0.87311E-02; H=  0.66355E-03; Order= 2
 Time=  0.10058E-01; H=  0.13271E-02; Order= 2
 Time=  0.11385E-01; H=  0.13271E-02; Order= 2
 Time=  0.12712E-01; H=  0.13271E-02; Order= 2
 Time=  0.15367E-01; H=  0.26542E-02; Order= 2
 Time=  0.18021E-01; H=  0.26542E-02; Order= 2
 Time=  0.20675E-01; H=  0.26542E-02; Order= 2
 Time=  0.23329E-01; H=  0.26542E-02; Order= 2
 Time=  0.28638E-01; H=  0.53084E-02; Order= 3
 Time=  0.33946E-01; H=  0.53084E-02; Order= 3
 Time=  0.39255E-01; H=  0.53084E-02; Order= 3
 Time=  0.44563E-01; H=  0.53084E-02; Order= 3
 Time=  0.49871E-01; H=  0.53084E-02; Order= 3
 Time=  0.60488E-01; H=  0.10617E-01; Order= 2
 Time=  0.70043E-01; H=  0.95551E-02; Order= 2
 Time=  0.79598E-01; H=  0.95551E-02; Order= 2
 Time=  0.89154E-01; H=  0.95551E-02; Order= 2
 Time=  0.98709E-01; H=  0.95551E-02; Order= 2
 Time=  0.11782E+00; H=  0.19110E-01; Order= 3
 Time=  0.13693E+00; H=  0.19110E-01; Order= 3
 Time=  0.15604E+00; H=  0.19110E-01; Order= 3
 Time=  0.17515E+00; H=  0.19110E-01; Order= 3
 Time=  0.19426E+00; H=  0.19110E-01; Order= 3
 Time=  0.21337E+00; H=  0.19110E-01; Order= 2
 Time=  0.23248E+00; H=  0.19110E-01; Order= 2
 Time=  0.25159E+00; H=  0.19110E-01; Order= 2
 Time=  0.27070E+00; H=  0.19110E-01; Order= 2
 Time=  0.30892E+00; H=  0.38221E-01; Order= 2
 Time=  0.34714E+00; H=  0.38221E-01; Order= 2
 Time=  0.38536E+00; H=  0.38221E-01; Order= 2
 Time=  0.42358E+00; H=  0.38221E-01; Order= 2
 Time=  0.50003E+00; H=  0.76441E-01; Order= 3
 Time=  0.57647E+00; H=  0.76441E-01; Order= 3
 Time=  0.65291E+00; H=  0.76441E-01; Order= 3
 Time=  0.72935E+00; H=  0.76441E-01; Order= 3
 Time=  0.80579E+00; H=  0.76441E-01; Order= 2
 Time=  0.88223E+00; H=  0.76441E-01; Order= 2
 Time=  0.95867E+00; H=  0.76441E-01; Order= 2
 Time=  0.11116E+01; H=  0.15288E+00; Order= 2
 Time=  0.12644E+01; H=  0.15288E+00; Order= 2
 Time=  0.14173E+01; H=  0.15288E+00; Order= 2
 Time=  0.15702E+01; H=  0.15288E+00; Order= 2
 Time=  0.18760E+01; H=  0.30576E+00; Order= 3
 Time=  0.21817E+01; H=  0.30576E+00; Order= 2
 Time=  0.24875E+01; H=  0.30576E+00; Order= 1
 Time=  0.27933E+01; H=  0.30576E+00; Order= 1
 Time=  0.34048E+01; H=  0.61153E+00; Order= 1
C
C#######################################################################
C
C RESCYL : RESULT file from double precision version
C          for the second example problem
C
C#######################################################################
C
 Reaction-diffusion prob. in cyl. coord.; pars: 1.00000 0.00010 1.00000 0.10000 
 MoL, PDE+D&D int.face; DAE int.: DASSL;  ID:ACM-TOMS, Ex.I                     
 NPTS= 21; RTOL=.100E-02, ATOL=.100E-02                                         
 TAU=.000E+00, KAPPA=.200E+01, ALPHA=.100E-01                                   
-T=  0.00000E+00
 X(S,TN):
   0.00000000000000E+00   0.50000000000000E-01   0.10000000000000E+00   0.15000000000000E+00   0.20000000000000E+00
   0.25000000000000E+00   0.30000000000000E+00   0.35000000000000E+00   0.40000000000000E+00   0.45000000000000E+00
   0.50000000000000E+00   0.55000000000000E+00   0.60000000000000E+00   0.65000000000000E+00   0.70000000000000E+00
   0.75000000000000E+00   0.80000000000000E+00   0.85000000000000E+00   0.90000000000000E+00   0.95000000000000E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00
-T=  0.10000E+00
 X(S,TN):
   0.29633654800193E-15   0.14518655828625E+00   0.28623613637578E+00   0.41908482419422E+00   0.53995292546954E+00
   0.64574851128986E+00   0.73456206846850E+00   0.80600997379943E+00   0.86120451999333E+00   0.90233892710470E+00
   0.93209744234193E+00   0.95314566548264E+00   0.96780068468390E+00   0.97792468340331E+00   0.98491427256273E+00
   0.98976166077815E+00   0.99315746314550E+00   0.99558125838569E+00   0.99737374380593E+00   0.99878321274549E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.10541347609001E+00   0.10543381112923E+00   0.10542846159353E+00   0.10542697669293E+00   0.10541941101237E+00
   0.10539931629053E+00   0.10534688061183E+00   0.10522618072056E+00   0.10497846200468E+00   0.10451695864439E+00
   0.10372016041888E+00   0.10243265616718E+00   0.10051987348868E+00   0.97875000660367E-01   0.94308778919243E-01
   0.89498639148020E-01   0.82617436086351E-01   0.71961270055454E-01   0.55520963493168E-01   0.32050224112808E-01
   0.00000000000000E+00
 Statistics:
    FNS, JACS:          71          14
    STEPS, ETF, CTF:          34           1           0
-T=  0.20000E+00
 X(S,TN):
  -0.11792638907364E-15   0.18674250139956E+00   0.36161564535805E+00   0.51532221836835E+00   0.64273309324947E+00
   0.74302837364521E+00   0.81863723215575E+00   0.87370797440104E+00   0.91278775931850E+00   0.94000314850915E+00
   0.95871185479410E+00   0.97147380412538E+00   0.98015646071269E+00   0.98607515933571E+00   0.99014055601709E+00
   0.99298512232870E+00   0.99504830872862E+00   0.99662399106867E+00   0.99789910993335E+00   0.99899464203903E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.22303632049749E+00   0.22309266720346E+00   0.22307397829205E+00   0.22305809941883E+00   0.22301894061950E+00
   0.22293445828391E+00   0.22275286764596E+00   0.22239738682208E+00   0.22175946457949E+00   0.22069656329038E+00
   0.21903567918989E+00   0.21658529656165E+00   0.21305503122072E+00   0.20760646433304E+00   0.19806940978031E+00
   0.18136093968360E+00   0.15639985596911E+00   0.12479179311940E+00   0.88216320484076E-01   0.47050433315259E-01
   0.00000000000000E+00
 Statistics:
    FNS, JACS:          80          15
    STEPS, ETF, CTF:          40           1           0
-T=  0.30000E+00
 X(S,TN):
   0.14320554396716E-14   0.20596968998444E+00   0.39457280855472E+00   0.55404257209325E+00   0.68026501628200E+00
   0.77520662843622E+00   0.84399823777437E+00   0.89254013062747E+00   0.92617300168885E+00   0.94919203774937E+00
   0.96482596838301E+00   0.97540703351966E+00   0.98257232511705E+00   0.98745436043302E+00   0.99084190132803E+00
   0.99328242344946E+00   0.99513361215211E+00   0.99661542102899E+00   0.99786362932057E+00   0.99896842313657E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.35555779828961E+00   0.35564085485280E+00   0.35561200548389E+00   0.35558132635160E+00   0.35551206832711E+00
   0.35537043764911E+00   0.35508468402543E+00   0.35455395478681E+00   0.35364027460106E+00   0.35216515432253E+00
   0.34989560276892E+00   0.34642011011708E+00   0.34044213754871E+00   0.32826236853721E+00   0.30487011125492E+00
   0.26953244954386E+00   0.22564377110062E+00   0.17619310916448E+00   0.12248074083887E+00   0.64326526707150E-01
   0.00000000000000E+00
 Statistics:
    FNS, JACS:          88          16
    STEPS, ETF, CTF:          43           1           0
-T=  0.40000E+00
 X(S,TN):
   0.17573661222888E-14   0.21714536240210E+00   0.41311648503976E+00   0.57490280278510E+00   0.69958607539812E+00
   0.79108933764365E+00   0.85606204614195E+00   0.90120200093970E+00   0.93211312844888E+00   0.95308623239553E+00
   0.96725184329120E+00   0.97680747363581E+00   0.98327317844469E+00   0.98770497165375E+00   0.99083765906992E+00
   0.99315989881063E+00   0.99497619854938E+00   0.99646998177328E+00   0.99775565086732E+00   0.99891133823822E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.50697530208446E+00   0.50715003288900E+00   0.50709494727959E+00   0.50702558068249E+00   0.50690423986777E+00
   0.50668764171967E+00   0.50628342135082E+00   0.50556561168646E+00   0.50436984080349E+00   0.50247956571493E+00
   0.49952917267571E+00   0.49441348538268E+00   0.48317911608222E+00   0.45833120911755E+00   0.41655674282601E+00
   0.36195417095601E+00   0.29943288273382E+00   0.23180283130867E+00   0.15998075931332E+00   0.83422347369468E-01
   0.00000000000000E+00
 Statistics:
    FNS, JACS:          91          16
    STEPS, ETF, CTF:          46           1           0
-T=  0.50000E+00
 X(S,TN):
   0.18445852701699E-14   0.22453039548393E+00   0.42504916702065E+00   0.58784710689971E+00   0.71110879801132E+00
   0.80018734147900E+00   0.86268417908266E+00   0.90572840731953E+00   0.93503532905967E+00   0.95485084780955E+00
   0.96820343631153E+00   0.97720051578603E+00   0.98329814851021E+00   0.98751582550847E+00   0.99055667647461E+00
   0.99286721727617E+00   0.99471537479902E+00   0.99626306865955E+00   0.99761349779020E+00   0.99883914463824E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.68243708640462E+00   0.68277810495631E+00   0.68267873731318E+00   0.68253669913763E+00   0.68232631092308E+00
   0.68199779228077E+00   0.68143722816467E+00   0.68048877619805E+00   0.67895569372489E+00   0.67655952419315E+00
   0.67260501069311E+00   0.66432549241951E+00   0.64357698297669E+00   0.60148578658400E+00   0.53953838751663E+00
   0.46464543953401E+00   0.38206588083428E+00   0.29441901207307E+00   0.20237363383063E+00   0.10508403679625E+00
   0.00000000000000E+00
 Statistics:
    FNS, JACS:          96          17
    STEPS, ETF, CTF:          48           1           0
-T=  0.60000E+00
 X(S,TN):
   0.19896455339228E-14   0.22976402276294E+00   0.43337374825586E+00   0.59669864979291E+00   0.71882415309975E+00
   0.80614720344578E+00   0.86691611718749E+00   0.90852702796460E+00   0.93674350280112E+00   0.95577029968016E+00
   0.96857117148520E+00   0.97719614208978E+00   0.98306587485048E+00   0.98717730441413E+00   0.99019725048412E+00
   0.99253472570486E+00   0.99443441614419E+00   0.99604595121440E+00   0.99746635393159E+00   0.99876493793765E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.88950214339158E+00   0.88989698872038E+00   0.88977833151036E+00   0.88958746131439E+00   0.88931080534037E+00
   0.88888543558770E+00   0.88817180295746E+00   0.88697659938512E+00   0.88504924113208E+00   0.88196669312571E+00
   0.87626925132628E+00   0.86213194539360E+00   0.82693477549876E+00   0.76378695805704E+00   0.67899271247124E+00
   0.58116118176215E+00   0.47579308917595E+00   0.36538723369220E+00   0.25037340103839E+00   0.12958244884495E+00
   0.00000000000000E+00
 Statistics:
    FNS, JACS:          98          17
    STEPS, ETF, CTF:          50           1           0
-T=  0.70000E+00
 X(S,TN):
   0.19261828521368E-14   0.23377659373911E+00   0.43965276875405E+00   0.60322954622865E+00   0.72436707982107E+00
   0.81028614300554E+00   0.86971691780380E+00   0.91023954877469E+00   0.93764119125336E+00   0.95608892373450E+00
   0.96849204591115E+00   0.97685680664204E+00   0.98258593401810E+00   0.98666312434109E+00   0.98971246522479E+00
   0.99211339722082E+00   0.99409215327768E+00   0.99578855129431E+00   0.99729507715551E+00   0.99867950240365E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.11404669177384E+01   0.11409401761389E+01   0.11407950664162E+01   0.11405304435312E+01   0.11401547215867E+01
   0.11395903046279E+01   0.11386658165488E+01   0.11371394869770E+01   0.11346804487025E+01   0.11305978410490E+01
   0.11220765449537E+01   0.10990532438480E+01   0.10454763873760E+01   0.95785277553727E+00   0.84631527260672E+00
   0.72105095539796E+00   0.58813400082146E+00   0.45020996259660E+00   0.30758753101720E+00   0.15873164955159E+00
   0.00000000000000E+00
 Statistics:
    FNS, JACS:         101          17
    STEPS, ETF, CTF:          52           1           0
-T=  0.80000E+00
 X(S,TN):
   0.19489983690457E-14   0.23687484247408E+00   0.44446215799979E+00   0.60818790358613E+00   0.72854965204118E+00
   0.81340009981196E+00   0.87181685342508E+00   0.91150890459368E+00   0.93828450007265E+00   0.95628464386745E+00
   0.96838244791295E+00   0.97655859879403E+00   0.98219255780115E+00   0.98622833151892E+00   0.98928315863532E+00
   0.99172155857119E+00   0.99375914717493E+00   0.99552866915387E+00   0.99711751247974E+00   0.99858952892382E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.14552918110825E+01   0.14558170992759E+01   0.14556539852505E+01   0.14553017251900E+01   0.14547973571279E+01
   0.14540405739271E+01   0.14528121711801E+01   0.14507981997373E+01   0.14475251243218E+01   0.14417245515669E+01
   0.14279616969269E+01   0.13899339048834E+01   0.13092952664750E+01   0.11892426695586E+01   0.10446088490089E+01
   0.88683351366206E+00   0.72182816509103E+00   0.55174921252904E+00   0.37643658786783E+00   0.19392013756469E+00
   0.00000000000000E+00
 Statistics:
    FNS, JACS:         109          18
    STEPS, ETF, CTF:          54           1           0
-T=  0.90000E+00
 X(S,TN):
   0.19522004004880E-14   0.23940409202118E+00   0.44830950111163E+00   0.61202518575909E+00   0.73162655965155E+00
   0.81551133939449E+00   0.87304550993000E+00   0.91203540705249E+00   0.93829377398775E+00   0.95593275472896E+00
   0.96779250259421E+00   0.97583217536967E+00   0.98142304149109E+00   0.98549487874875E+00   0.98862872790646E+00
   0.99116713373378E+00   0.99331380665166E+00   0.99519534780138E+00   0.99689620907578E+00   0.99847927530783E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.18703046072040E+01   0.18708707754603E+01   0.18706890057619E+01   0.18702116500391E+01   0.18695124340226E+01
   0.18684591699182E+01   0.18667607985324E+01   0.18639914674898E+01   0.18594301761913E+01   0.18507920200978E+01
   0.18286960031340E+01   0.17696548106000E+01   0.16548823480591E+01   0.14939893896297E+01   0.13061944743727E+01
   0.11048396889746E+01   0.89647985331882E+00   0.68334503881772E+00   0.46501924258866E+00   0.23896237801002E+00
   0.00000000000000E+00
 Statistics:
    FNS, JACS:         112          18
    STEPS, ETF, CTF:          56           1           0
-T=  0.10000E+01
 X(S,TN):
   0.19469824500562E-14   0.24148527447510E+00   0.45140991558508E+00   0.61500816141860E+00   0.73387823502942E+00
   0.81688810359375E+00   0.87364219573274E+00   0.91202198262112E+00   0.93783931979533E+00   0.95517868798202E+00
   0.96685159403756E+00   0.97480014157111E+00   0.98038849859694E+00   0.98453251352016E+00   0.98777877069999E+00
   0.99044969249063E+00   0.99273780114691E+00   0.99476373487584E+00   0.99660920760540E+00   0.99833615484976E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.24607685161092E+01   0.24614200363063E+01   0.24611902282900E+01   0.24604728113344E+01   0.24593954922007E+01
   0.24577770683979E+01   0.24552004285485E+01   0.24510291540584E+01   0.24440266874217E+01   0.24299089494885E+01
   0.23928508777186E+01   0.23004311051512E+01   0.21354741397201E+01   0.19157324556924E+01   0.16663203096580E+01
   0.14033722492618E+01   0.11344848770177E+01   0.86199757405020E+00   0.58498494342162E+00   0.29989817369661E+00
   0.00000000000000E+00
 Statistics:
    FNS, JACS:         117          18
    STEPS, ETF, CTF:          58           1           0
C
C#######################################################################
C
C RUNCYL : RUNINF file from double precision version
C          for the second example problem
C
C#######################################################################
C
 Reaction-diffusion prob. in cyl. coord.; pars: 1.00000 0.00010 1.00000 0.10000 
 MoL, PDE+D&D int.face; DAE int.: DASSL;  ID:ACM-TOMS, Ex.I                     
 NPTS= 21; RTOL=.100E-02, ATOL=.100E-02                                         
 TAU=.000E+00, KAPPA=.200E+01, ALPHA=.100E-01                                   
 Time=  0.20000E-03; H=  0.10000E-03; Order= 1
 Time=  0.40000E-03; H=  0.20000E-03; Order= 2
 Time=  0.80000E-03; H=  0.40000E-03; Order= 1
 Time=  0.16000E-02; H=  0.80000E-03; Order= 1
 Time=  0.32000E-02; H=  0.16000E-02; Order= 1
 Time=  0.48000E-02; H=  0.16000E-02; Order= 1
 Time=  0.64000E-02; H=  0.16000E-02; Order= 1
 Time=  0.96000E-02; H=  0.32000E-02; Order= 2
 Time=  0.12480E-01; H=  0.28800E-02; Order= 2
 Time=  0.15360E-01; H=  0.28800E-02; Order= 2
 Time=  0.18240E-01; H=  0.28800E-02; Order= 2
 Time=  0.21120E-01; H=  0.28800E-02; Order= 2
 Time=  0.24000E-01; H=  0.28800E-02; Order= 1
 Time=  0.26410E-01; H=  0.24103E-02; Order= 1
 Time=  0.28821E-01; H=  0.24103E-02; Order= 1
 Time=  0.31231E-01; H=  0.24103E-02; Order= 1
 Time=  0.33641E-01; H=  0.24103E-02; Order= 1
 Time=  0.35811E-01; H=  0.21693E-02; Order= 1
 Time=  0.37586E-01; H=  0.17756E-02; Order= 1
 Time=  0.39362E-01; H=  0.17756E-02; Order= 1
 Time=  0.41138E-01; H=  0.17756E-02; Order= 1
 Time=  0.44689E-01; H=  0.35512E-02; Order= 1
 Time=  0.48240E-01; H=  0.35512E-02; Order= 1
 Time=  0.51791E-01; H=  0.35512E-02; Order= 1
 Time=  0.55342E-01; H=  0.35512E-02; Order= 2
 Time=  0.58894E-01; H=  0.35512E-02; Order= 2
 Time=  0.65996E-01; H=  0.71025E-02; Order= 2
 Time=  0.73099E-01; H=  0.71025E-02; Order= 2
 Time=  0.80201E-01; H=  0.71025E-02; Order= 2
 Time=  0.87303E-01; H=  0.71025E-02; Order= 2
 Time=  0.91370E-01; H=  0.40665E-02; Order= 1
 Time=  0.95030E-01; H=  0.36599E-02; Order= 1
 Time=  0.98690E-01; H=  0.36599E-02; Order= 1
 Time=  0.10601E+00; H=  0.73198E-02; Order= 1
 Time=  0.11333E+00; H=  0.73198E-02; Order= 1
 Time=  0.12065E+00; H=  0.73198E-02; Order= 1
 Time=  0.13529E+00; H=  0.14640E-01; Order= 2
 Time=  0.14993E+00; H=  0.14640E-01; Order= 2
 Time=  0.17921E+00; H=  0.29279E-01; Order= 2
 Time=  0.20355E+00; H=  0.24338E-01; Order= 2
 Time=  0.22788E+00; H=  0.24338E-01; Order= 2
 Time=  0.25222E+00; H=  0.24338E-01; Order= 2
 Time=  0.30090E+00; H=  0.48677E-01; Order= 2
 Time=  0.34958E+00; H=  0.48677E-01; Order= 2
 Time=  0.39825E+00; H=  0.48677E-01; Order= 2
 Time=  0.44693E+00; H=  0.48677E-01; Order= 2
 Time=  0.49561E+00; H=  0.48677E-01; Order= 3
 Time=  0.54428E+00; H=  0.48677E-01; Order= 3
 Time=  0.59296E+00; H=  0.48677E-01; Order= 3
 Time=  0.64164E+00; H=  0.48677E-01; Order= 3
 Time=  0.69031E+00; H=  0.48677E-01; Order= 3
 Time=  0.73899E+00; H=  0.48677E-01; Order= 4
 Time=  0.78767E+00; H=  0.48677E-01; Order= 3
 Time=  0.83634E+00; H=  0.48677E-01; Order= 3
 Time=  0.88015E+00; H=  0.43809E-01; Order= 3
 Time=  0.92396E+00; H=  0.43809E-01; Order= 3
 Time=  0.96777E+00; H=  0.43809E-01; Order= 3
C
C#######################################################################
C
C RESDSH : RESULT file from double precision version  !!! TAU = 1E-3 !!!
C          for the third example problem              !!!  in driver !!!
C
C#######################################################################
C
 Burgers, double wave, eps=0.00100                                              
 MoL, PDE+D&D int.face; DAE int.: DASSL;  ID:ACM-TOMS, Ex.I                     
 NPTS= 21; RTOL=.100E-02, ATOL=.100E-02                                         
 TAU=.100E-02, KAPPA=.200E+01, ALPHA=.100E-01                                   
-T=  0.00000E+00
 X(S,TN):
   0.00000000000000E+00   0.50000000000000E-01   0.10000000000000E+00   0.15000000000000E+00   0.20000000000000E+00
   0.25000000000000E+00   0.30000000000000E+00   0.35000000000000E+00   0.40000000000000E+00   0.45000000000000E+00
   0.50000000000000E+00   0.55000000000000E+00   0.60000000000000E+00   0.65000000000000E+00   0.70000000000000E+00
   0.75000000000000E+00   0.80000000000000E+00   0.85000000000000E+00   0.90000000000000E+00   0.95000000000000E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.10000000000000E+01   0.10000000000000E+01   0.10000000000000E+01   0.99999999999306E+00   0.99999813668036E+00
   0.75000000000000E+00   0.50000186331964E+00   0.50000000000691E+00   0.49999999917554E+00   0.49998184085252E+00
   0.30000000000000E+00   0.10001815914748E+00   0.10000000082446E+00   0.10000000000004E+00   0.10000000000000E+00
   0.10000000000000E+00   0.10000000000000E+00   0.10000000000000E+00   0.10000000000000E+00   0.10000000000000E+00
   0.10000000000000E+00
 ERR_U:
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
   0.00000000000000E+00
 MAX. NORM:  0.0000000000000000E+00
 TWO  NORM:  0.0000000000000000E+00
-T=  0.25000E+00
 X(S,TN):
   0.39938631124805E-17   0.10848039902619E+00   0.20332143491505E+00   0.27818744594920E+00   0.33366936812585E+00
   0.37291383644095E+00   0.40083196608916E+00   0.42007706567635E+00   0.43538103087761E+00   0.45161358060903E+00
   0.47211289543100E+00   0.49608912621524E+00   0.52168938076279E+00   0.54552297753852E+00   0.56985660342795E+00
   0.60028529153006E+00   0.64240022494589E+00   0.70136696474965E+00   0.78157647910928E+00   0.88350458954221E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.10000000000000E+01   0.99716089594943E+00   0.10053914674654E+01   0.99398227506464E+00   0.99342130435753E+00
   0.10192369473142E+01   0.10241403571050E+01   0.91801071317624E+00   0.70722316658278E+00   0.55195999630692E+00
   0.52757210582003E+00   0.55692411740765E+00   0.54507289464643E+00   0.41903177710539E+00   0.24891870363783E+00
   0.15397788150532E+00   0.12084641861083E+00   0.10668405272291E+00   0.10148886169492E+00   0.10021053963123E+00
   0.10000000000000E+00
 ERR_U:
   0.22204460492503E-15  -0.28391040505725E-02   0.53914674653861E-02  -0.60177249353576E-02  -0.65786956398048E-02
   0.19236995911935E-01   0.24192565874387E-01  -0.75654075692869E-01  -0.10748833391832E+00   0.37702490610937E-01
   0.27484839929748E-01   0.56923955738010E-01   0.45082260157957E-01  -0.79870418949233E-01  -0.14574520567546E+00
   0.51448279061020E-01   0.20845859175062E-01   0.66840527186798E-02   0.14888616949214E-02   0.21053963123274E-03
   0.00000000000000E+00
 MAX. NORM:  0.1457452056754566    
 TWO  NORM:  3.6674051387714139E-02
 Statistics:
    FNS, JACS:         122          25
    STEPS, ETF, CTF:          54           2           0
-T=  0.55000E+00
 X(S,TN):
   0.42789669774584E-17   0.16054451804151E+00   0.30092880945903E+00   0.41129713314553E+00   0.49220185168819E+00
   0.54915446061045E+00   0.58838172674564E+00   0.61516881937511E+00   0.63346396078613E+00   0.64622568627158E+00
   0.65503654061962E+00   0.66206776470849E+00   0.66930854132777E+00   0.67861092376706E+00   0.69195689764799E+00
   0.71173453951118E+00   0.74072198769036E+00   0.78231249604778E+00   0.83987086327238E+00   0.91417304003956E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.10000000000000E+01   0.99404766813922E+00   0.99946681627913E+00   0.10044684114696E+01   0.99915737453175E+00
   0.99347950474687E+00   0.98418997423471E+00   0.99816960681373E+00   0.10343868913845E+01   0.10199481635346E+01
   0.85473686969265E+00   0.55624502985958E+00   0.28655923610120E+00   0.14939763647867E+00   0.10798078391628E+00
   0.10887166247564E+00   0.10812640776773E+00   0.10260672751600E+00   0.10090714897772E+00   0.10023518346668E+00
   0.10000000000000E+00
 ERR_U:
   0.00000000000000E+00  -0.59523318607845E-02  -0.53318372086508E-03   0.44684114695528E-02  -0.84262546825287E-03
  -0.65204952528811E-02  -0.15810021281136E-01  -0.18267616873753E-02   0.34739699727455E-01   0.28705944538099E-01
  -0.63306367878777E-01  -0.69030145673122E-01   0.27645226885963E-01   0.23766155939683E-01   0.61641937601004E-02
   0.88367712687488E-02   0.81263018590435E-02   0.26067274901526E-02   0.90714897771901E-03   0.23518346667772E-03
  -0.83266726846887E-16
 MAX. NORM:  6.9030145673121712E-02
 TWO  NORM:  1.1360035643140431E-02
 Statistics:
    FNS, JACS:         182          35
    STEPS, ETF, CTF:          77           3           0
-T=  0.10000E+01
 X(S,TN):
   0.65933069367097E-17   0.21712532792970E+00   0.40789355716805E+00   0.55903868093297E+00   0.67065296175650E+00
   0.74961920707661E+00   0.80415045798395E+00   0.84129569825018E+00   0.86644124701394E+00   0.88339842283443E+00
   0.89479947600615E+00   0.90244623955670E+00   0.90756630387598E+00   0.91151304527626E+00   0.91551636518356E+00
   0.92079199808315E+00   0.92855923742497E+00   0.93982088640938E+00   0.95556497937051E+00   0.97610322784590E+00
   0.10000000000000E+01
 U(X(S,TN),TN), COMP:           1
   0.10000000000000E+01   0.99916190570377E+00   0.99405196213500E+00   0.99696282523826E+00   0.99841866007516E+00
   0.10014099538875E+01   0.10042543009900E+01   0.99915608628413E+00   0.10036645912492E+01   0.10003563151071E+01
   0.10025371199935E+01   0.10011032079500E+01   0.84996071726458E+00   0.53810418710225E+00   0.23683306226127E+00
   0.10531371063189E+00   0.10042725788778E+00   0.10040599485127E+00   0.10036314505057E+00   0.10017167622878E+00
   0.10000000000000E+00
 ERR_U:
  -0.99920072216264E-15  -0.83809429623427E-03  -0.59480378649983E-02  -0.30371747617424E-02  -0.15813399248433E-02
   0.14099538874781E-02   0.42543009900244E-02  -0.84391371584724E-03   0.36645929253346E-02   0.35976877395583E-03
   0.31207490251667E-02   0.18973626733526E-01   0.17535496151199E-02   0.28689439130730E-01   0.27872740417935E-01
  -0.60821784156097E-02   0.77198024505315E-04   0.40378980423768E-03   0.36314320336787E-03   0.17167622859905E-03
   0.83266726846887E-16
 MAX. NORM:  2.8689439130729521E-02
 TWO  NORM:  4.2939725456811341E-03
 Statistics:
    FNS, JACS:         294          62
    STEPS, ETF, CTF:         121           4           7
C
C#######################################################################
C
C RUNDSH : RUNINF file from double precision version  !!! TAU = 1E-3 !!!
C          for the third example problem              !!!  in driver !!!
C
C#######################################################################
C
 Burgers, double wave, eps=0.00100                                              
 MoL, PDE+D&D int.face; DAE int.: DASSL;  ID:ACM-TOMS, Ex.I                     
 NPTS= 21; RTOL=.100E-02, ATOL=.100E-02                                         
 TAU=.100E-02, KAPPA=.200E+01, ALPHA=.100E-01                                   
 Time=  0.65287E-05; H=  0.32643E-05; Order= 1
 Time=  0.13057E-04; H=  0.65287E-05; Order= 2
 Time=  0.26115E-04; H=  0.13057E-04; Order= 1
 Time=  0.52229E-04; H=  0.26115E-04; Order= 1
 Time=  0.78344E-04; H=  0.26115E-04; Order= 1
 Time=  0.13057E-03; H=  0.52229E-04; Order= 1
 Time=  0.17717E-03; H=  0.46598E-04; Order= 1
 Time=  0.22377E-03; H=  0.46598E-04; Order= 1
 Time=  0.27037E-03; H=  0.46598E-04; Order= 1
 Time=  0.31696E-03; H=  0.46598E-04; Order= 1
 Time=  0.36356E-03; H=  0.46598E-04; Order= 1
 Time=  0.40310E-03; H=  0.39538E-04; Order= 1
 Time=  0.44264E-03; H=  0.39538E-04; Order= 1
 Time=  0.48218E-03; H=  0.39538E-04; Order= 1
 Time=  0.56125E-03; H=  0.79077E-04; Order= 2
 Time=  0.64033E-03; H=  0.79077E-04; Order= 2
 Time=  0.79848E-03; H=  0.15815E-03; Order= 2
 Time=  0.93806E-03; H=  0.13958E-03; Order= 2
 Time=  0.10776E-02; H=  0.13958E-03; Order= 2
 Time=  0.12172E-02; H=  0.13958E-03; Order= 2
 Time=  0.13303E-02; H=  0.11307E-03; Order= 2
 Time=  0.14320E-02; H=  0.10176E-03; Order= 2
 Time=  0.15338E-02; H=  0.10176E-03; Order= 2
 Time=  0.16356E-02; H=  0.10176E-03; Order= 2
 Time=  0.17373E-02; H=  0.10176E-03; Order= 1
 Time=  0.18391E-02; H=  0.10176E-03; Order= 1
 Time=  0.20426E-02; H=  0.20353E-03; Order= 1
 Time=  0.22462E-02; H=  0.20353E-03; Order= 1
 Time=  0.24497E-02; H=  0.20353E-03; Order= 1
 Time=  0.28567E-02; H=  0.40705E-03; Order= 2
 Time=  0.32638E-02; H=  0.40705E-03; Order= 2
 Time=  0.39269E-02; H=  0.66307E-03; Order= 1
 Time=  0.45146E-02; H=  0.58775E-03; Order= 1
 Time=  0.56901E-02; H=  0.11755E-02; Order= 1
 Time=  0.68656E-02; H=  0.11755E-02; Order= 1
 Time=  0.92166E-02; H=  0.23510E-02; Order= 1
 Time=  0.11568E-01; H=  0.23510E-02; Order= 1
 Time=  0.16270E-01; H=  0.47020E-02; Order= 1
 Time=  0.25674E-01; H=  0.94040E-02; Order= 1
 Time=  0.35078E-01; H=  0.94040E-02; Order= 1
 Time=  0.44482E-01; H=  0.94040E-02; Order= 1
 Time=  0.63290E-01; H=  0.18808E-01; Order= 1
 Time=  0.80217E-01; H=  0.16927E-01; Order= 1
 Time=  0.95355E-01; H=  0.15139E-01; Order= 1
 Time=  0.11049E+00; H=  0.15139E-01; Order= 1
 Time=  0.12563E+00; H=  0.15139E-01; Order= 1
 Time=  0.13974E+00; H=  0.14103E-01; Order= 1
 Time=  0.15110E+00; H=  0.11364E-01; Order= 1
 Time=  0.16247E+00; H=  0.11364E-01; Order= 1
 Time=  0.17383E+00; H=  0.11364E-01; Order= 1
 Time=  0.18519E+00; H=  0.11364E-01; Order= 1
 Time=  0.20792E+00; H=  0.22729E-01; Order= 2
 Time=  0.23065E+00; H=  0.22729E-01; Order= 1
 Time=  0.25338E+00; H=  0.22729E-01; Order= 1
 Time=  0.26519E+00; H=  0.11807E-01; Order= 1
 Time=  0.27452E+00; H=  0.93356E-02; Order= 1
 Time=  0.28386E+00; H=  0.93356E-02; Order= 1
 Time=  0.29319E+00; H=  0.93356E-02; Order= 1
 Time=  0.30253E+00; H=  0.93356E-02; Order= 2
 Time=  0.31187E+00; H=  0.93356E-02; Order= 2
 Time=  0.32120E+00; H=  0.93356E-02; Order= 1
 Time=  0.33987E+00; H=  0.18671E-01; Order= 1
 Time=  0.35854E+00; H=  0.18671E-01; Order= 1
 Time=  0.37410E+00; H=  0.15560E-01; Order= 1
 Time=  0.38966E+00; H=  0.15560E-01; Order= 1
 Time=  0.40522E+00; H=  0.15560E-01; Order= 1
 Time=  0.41923E+00; H=  0.14004E-01; Order= 1
 Time=  0.43323E+00; H=  0.14004E-01; Order= 1
 Time=  0.44723E+00; H=  0.14004E-01; Order= 1
 Time=  0.46124E+00; H=  0.14004E-01; Order= 2
 Time=  0.47524E+00; H=  0.14004E-01; Order= 2
 Time=  0.48924E+00; H=  0.14004E-01; Order= 2
 Time=  0.50325E+00; H=  0.14004E-01; Order= 2
 Time=  0.51725E+00; H=  0.14004E-01; Order= 3
 Time=  0.53126E+00; H=  0.14004E-01; Order= 3
 Time=  0.54526E+00; H=  0.14004E-01; Order= 2
 Time=  0.55926E+00; H=  0.14004E-01; Order= 2
 Time=  0.57327E+00; H=  0.14004E-01; Order= 2
 Time=  0.58515E+00; H=  0.11881E-01; Order= 2
 Time=  0.59287E+00; H=  0.77259E-02; Order= 2
 Time=  0.60060E+00; H=  0.77259E-02; Order= 2
 Time=  0.60832E+00; H=  0.77259E-02; Order= 2
 Time=  0.61605E+00; H=  0.77259E-02; Order= 2
 Time=  0.61991E+00; H=  0.38629E-02; Order= 2
 Time=  0.62378E+00; H=  0.38629E-02; Order= 2
 Time=  0.62691E+00; H=  0.31327E-02; Order= 2
 Time=  0.63317E+00; H=  0.62655E-02; Order= 1
 Time=  0.64571E+00; H=  0.12531E-01; Order= 1
 Time=  0.65671E+00; H=  0.11008E-01; Order= 1
 Time=  0.66772E+00; H=  0.11008E-01; Order= 1
 Time=  0.67873E+00; H=  0.11008E-01; Order= 1
 Time=  0.70075E+00; H=  0.22017E-01; Order= 2
 Time=  0.72276E+00; H=  0.22017E-01; Order= 2
 Time=  0.74478E+00; H=  0.22017E-01; Order= 2
 Time=  0.76680E+00; H=  0.22017E-01; Order= 2
 Time=  0.78534E+00; H=  0.18547E-01; Order= 1
 Time=  0.80389E+00; H=  0.18547E-01; Order= 1
 Time=  0.82244E+00; H=  0.18547E-01; Order= 1
 Time=  0.84099E+00; H=  0.18547E-01; Order= 1
 Time=  0.85953E+00; H=  0.18547E-01; Order= 1
 Time=  0.87808E+00; H=  0.18547E-01; Order= 1
 Time=  0.87814E+00; H=  0.65204E-04; Order= 1
 Time=  0.87827E+00; H=  0.13041E-03; Order= 1
 Time=  0.87838E+00; H=  0.10282E-03; Order= 1
 Time=  0.87848E+00; H=  0.10282E-03; Order= 1
 Time=  0.87869E+00; H=  0.20564E-03; Order= 1
 Time=  0.87889E+00; H=  0.20564E-03; Order= 1
 Time=  0.87930E+00; H=  0.41127E-03; Order= 1
 Time=  0.88013E+00; H=  0.82255E-03; Order= 1
 Time=  0.88177E+00; H=  0.16451E-02; Order= 1
 Time=  0.88259E+00; H=  0.82255E-03; Order= 1
 Time=  0.88424E+00; H=  0.16451E-02; Order= 1
 Time=  0.88753E+00; H=  0.32902E-02; Order= 1
 Time=  0.89411E+00; H=  0.65804E-02; Order= 1
 Time=  0.90727E+00; H=  0.13161E-01; Order= 1
 Time=  0.92043E+00; H=  0.13161E-01; Order= 1
 Time=  0.93359E+00; H=  0.13161E-01; Order= 1
 Time=  0.95991E+00; H=  0.26322E-01; Order= 2
 Time=  0.98623E+00; H=  0.26322E-01; Order= 2
 Time=  0.99216E+00; H=  0.59224E-02; Order= 2

8<-------------------------------------------------------------------------

C#######################################################################
C
C Source code TOMS submission `A Moving-Grid Interface for Systems of
C    One-Dimensional Time-Dependent Partial Differential Equations' by
C    J.G. Blom and P.A. Zegeling.
C
C First the single precision version then, separated by a
C C*********** line, the double precision version
C
C***********************************************************************
C
C                     Single Precision files
C
C***********************************************************************
C
C Contains, separated by a C######## line, the following files:
C ------------------------------------------------------------
C PRBBAK : problem dependent routines for first example problem
C PRBCYL : problem dependent routines for second example problem
C PRBDSH : problem dependent routines for third example problem
C          (Burgers' equation)
C DRIVER : test program to use the moving-grid interface in a DASSL
C          environment
C SPMDIF : moving-grid interface routines
C MACHAR : MACHAR routine from W.J. Cody
C          (available from Netlib: send machar from elefunt)
C SDASSL : DASSL DAE integrator from L.R. Petzold
C          (available from Netlib: send sdassl from ode)
C          NB. DASSL needs the following files:
C DASUSE : contains the routine
C          I1MACH to get the standard error message unit (6).
C             (also available from Netlib: send i1mach from core)
C          R1MACH to determine machine precision, uses value determined
C             by MACHAR
C             (also available from Netlib: send r1mach from core)
C          and the dummies for the routines SGEFA and SGESL from LINPACK
C             (available from Netlib: send sgefa/sgesl from linpack)
C DASLIP : LINPACK routines needed by DASSL
C          (available from Netlib: send sgbfa/sgbsl from linpack)
C
C
C Of the next three problem dependent files only one should be loaded
C
C#######################################################################
C
C PRBBAK : problem dependent routines for first example problem
C
C#######################################################################
C
      SUBROUTINE INIPRB (TEXT)
      CHARACTER TEXT*80
C
C   Initialize /PROBLM/
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      REAL XL, XR, T0, TE
      REAL DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT
C
      INTEGER M
      REAL EPS, P, ETA
      DATA EPS /0.143/, ETA /17.19/, P /0.1743/
C
      NPDE = 2
      M    = 0
      XL   = 0.0
      XR   = 1.0
      T0   = 0.0
      TE   = 4.0
      ANAJAC = .FALSE.
      SOLAV  = .FALSE.
      NPRINT = 10
      TPRINT(1) = 1.0E-4
      TPRINT(2) = 1.0E-3
      TPRINT(3) = 1.0E-2
      TPRINT(4) = 0.1
      TPRINT(5) = 0.25
      TPRINT(6) = 0.5
      TPRINT(7) = 1.0
      TPRINT(8) = 2.0
      TPRINT(9) = 3.0
      TPRINT(10) = 4.0

      TEXT = ' Bakker, Electrodynamics problem'
      WRITE(TEXT(33:80),'(6H; EPS=,F5.3,4H, P=,F6.4,6H, ETA=,F5.2)')
     +     EPS, P, ETA

      DUMPRO(1) = M
      DUMPRO(2) = EPS
      DUMPRO(3) = P
      DUMPRO(4) = ETA

      RETURN
      END
      SUBROUTINE UINIT (NPDE, NPTS, Y)
C
C Routine for PDE initial values.
C Entry:
C   Y(NPDE+1,i) = x_i; uniform mesh, generated by package
C Exit:
C   Y(NPDE+1,i) = x_i; mesh, optionally changed by user
C   Y(     k,i) = u_k(x_i,t0); initial value of k-th component
C                                  i = 1,.., NPTS
C
      INTEGER NPDE, NPTS
      REAL Y(NPDE+1,NPTS)

      INTEGER I

      DO 10 I = 1, NPTS
         Y(1,I) = 1.0
         Y(2,I) = 0.0
   10 CONTINUE

      RETURN
      END
      SUBROUTINE SPDEF (T, X, NPDE, U, DUDX, C, Q, R, IRES)
C
C Routine to describe the body of the PDE system.
C The PDE is written as
C   NPDE               k                    -m   m
C   sum C  (x,t,u,u ) u  + Q (x,t,u,u )  = x   (x  R (x,t,u,u ) )
C   k=1  jk        x   t    j        x              j        x   x
C the functions C, Q and R must be defined in this routine.
C
      INTEGER NPDE, IRES
      REAL T, X
      REAL U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), R(NPDE)

      INTEGER J, K
      REAL EPS, ETA, GZ, P, Z
      DATA EPS /0.143/, ETA /17.19/, P /0.1743/

      DO 10 K = 1, NPDE
         DO 20 J = 1, NPDE
            C(J,K) = 0.0
   20    CONTINUE
         C(K,K) = 1.0
   10 CONTINUE

      Z  = U(1) - U(2)
      GZ = EXP(ETA*Z/3) - EXP(-2*ETA*Z/3)
      Q(1) =  GZ
      Q(2) = -GZ

      R(1) = EPS*P * DUDX(1)
      R(2) =     P * DUDX(2)

      RETURN
      END
      SUBROUTINE BNDR (T, BETA, GAMMA, U, DUDX, NPDE, LEFT, IRES)
C
C Boundary conditions routine
C The boundary conditions are written as
C   BETA (x,t) R (x,t,u,u ) = GAMMA (x,t,u,u )
C       j       j        x         j        x
C The functions BETA and GAMMA should be defined in this routine.
C
      INTEGER NPDE, IRES
      LOGICAL LEFT
      REAL T
      REAL BETA(NPDE), GAMMA(NPDE), U(NPDE), DUDX(NPDE)

      IF (LEFT) THEN
         BETA (1) = 1.0
         GAMMA(1) = 0.0
         BETA (2) = 0.0
         GAMMA(2) = U(2)
      ELSE
         BETA (1) = 0.0
         GAMMA(1) = U(1) - 1.0
         BETA (2) = 1.0
         GAMMA(2) = 0.0
      ENDIF

      RETURN
      END
      SUBROUTINE UEXACT (X, T, U)
      REAL X, T
      REAL U(*)
C
      RETURN
      END
C
C#######################################################################
C
C PRBCYL : problem dependent routines for second example problem
C
C#######################################################################
C
      SUBROUTINE INIPRB (TEXT)
      CHARACTER TEXT*80
C
C   Initialize /PROBLM/
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      REAL XL, XR, T0, TE
      REAL DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT
C
      INTEGER I, M
      REAL ALPHA, BETA, GAMMA, EPS
C
      NPDE = 1
      M    = 1
      XL   = 0.0
      XR   = 1.0
      T0   = 0.0
      TE   = 1.0
      ANAJAC = .FALSE.
      SOLAV  = .FALSE.
      NPRINT = 10
      DO 10 I = 1, NPRINT
         TPRINT(I) = 0.1*I
   10 CONTINUE

      ALPHA = 1.0
      BETA  = 0.0001
      GAMMA = 1.0
      EPS   = 0.1
      TEXT = ' Reaction-diffusion prob. in cyl. coord.; pars:'
      WRITE(TEXT(48:80),'(4F8.5)') ALPHA, BETA, GAMMA, EPS

      DUMPRO(1) = M
      DUMPRO(2) = ALPHA
      DUMPRO(3) = BETA
      DUMPRO(4) = GAMMA
      DUMPRO(5) = EPS

      RETURN
      END
      SUBROUTINE UINIT (NPD, NPTS, Y)
C
C Routine for PDE initial values.
C Entry:
C   Y(NPDE+1,i) = x_i; uniform mesh, generated by package
C Exit:
C   Y(NPDE+1,i) = x_i; mesh, optionally changed by user
C   Y(     k,i) = u_k(x_i,t0); initial value of k-th component
C                                  i = 1,.., NPTS
C
      INTEGER NPD, NPTS
      REAL Y(NPDE+1,NPTS)
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      REAL XL, XR, T0, TE
      REAL DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT
C
      INTEGER I

      DO 10 I = 1, NPTS
         Y(1,I) = 0.0
   10 CONTINUE

      RETURN
      END
      SUBROUTINE SPDEF (T,X, NPD, U, DUDX, C, Q, R, IRES)
C
C Routine to describe the body of the PDE system.
C The PDE is written as
C   NPDE               k                    -m   m
C   sum C  (x,t,u,u ) u  + Q (x,t,u,u )  = x   (x  R (x,t,u,u ) )
C   k=1  jk        x   t    j        x              j        x   x
C the functions C, Q and R must be defined in this routine.
C
      INTEGER NPD, IRES
      REAL T, X
      REAL U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), R(NPDE)
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      REAL XL, XR, T0, TE
      REAL DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT

      REAL ALPHA, BETA, GAMMA, EPS
C
      ALPHA = DUMPRO(2)
      BETA  = DUMPRO(3)
      GAMMA = DUMPRO(4)
      EPS   = DUMPRO(5)

      C(1,1) = ALPHA
      Q(1) = -GAMMA*EXP(U(1)/(1+EPS*U(1)))
      R(1) = BETA*DUDX(1)

      RETURN
      END
      SUBROUTINE BNDR (T, BETA, GAMMA, U, DUDX, NPD, LEFT, IRES)
C
C Boundary conditions routine
C The boundary conditions are written as
C   BETA (x,t) R (x,t,u,u ) = GAMMA (x,t,u,u )
C       j       j        x         j        x
C The functions BETA and GAMMA should be defined in this routine.
C
      INTEGER NPD, IRES
      LOGICAL LEFT
      REAL T
      REAL BETA(NPDE), GAMMA(NPDE), U(NPDE), DUDX(NPDE)
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      REAL XL, XR, T0, TE
      REAL DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT
C
      IF (LEFT) THEN
         BETA(1)  = 1.0
         GAMMA(1) = 0.0
      ELSE
         BETA(1)  = 0.0
         GAMMA(1) = U(1) - 0.0
      ENDIF

      RETURN
      END
      SUBROUTINE UEXACT (X, T, U)
C
C Exact solution
C
      REAL X, T
      REAL U(*)

      RETURN
      END
C
C#######################################################################
C
C PRBDSH : problem dependent routines for third example problem
C          (Burgers' equation)
C
C#######################################################################
C
      SUBROUTINE INIPRB (TEXT)
      CHARACTER TEXT*80
C
C ----------------------------------------------------------------------
C
C Burgers' equation
C    u_t = -u.u_x + eps.u_xx,   0 < x < 1,   t > 0
C    Dirichlet boundary conditions
C Exact solution available (see SUBROUTINE UEXACT)
C
C ----------------------------------------------------------------------
C
C   Initialize /PROBLM/
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      REAL XL, XR, T0, TE
      REAL DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT
C
      INTEGER M
      REAL EPS
C
      NPDE = 1
      M  = 0
      XL = 0.0
      XR = 1.0
      T0 = 0.0
      TE = 1.0
      ANAJAC = .FALSE.
      SOLAV  = .TRUE.
      NPRINT = 3
      TPRINT(1) = 0.25
      TPRINT(2) = 0.55
      TPRINT(3) = 1.0

      EPS = 1E-3
      TEXT = ' Burgers, double wave, eps='
      WRITE(TEXT(28:80),'(F7.5)') EPS

      DUMPRO(1) = M
      DUMPRO(2) = EPS

      RETURN
      END
      SUBROUTINE UINIT (NPD, NPTS, Y)
C
C Routine for PDE initial values.
C Entry:
C   Y(NPDE+1,i) = x_i; uniform mesh, generated by package
C Exit:
C   Y(NPDE+1,i) = x_i; mesh, optionally changed by user
C   Y(     k,i) = u_k(x_i,t0); initial value of k-th component
C                                  i = 1,.., NPTS
C
      INTEGER NPD, NPTS
      REAL Y(NPDE+1,NPTS)
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      REAL XL, XR, T0, TE
      REAL DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT

      INTEGER I
C
      DO 10 I = 1, NPTS
         CALL UEXACT (Y(NPDE+1,I), T0, Y(1,I))
   10 CONTINUE

      RETURN
      END
      SUBROUTINE SPDEF (T,X, NPD, U, DUDX, C, Q, R, IRES)
C
C Routine to describe the body of the PDE system.
C The PDE is written as
C   NPDE               k                    -m   m
C   sum C  (x,t,u,u ) u  + Q (x,t,u,u )  = x   (x  R (x,t,u,u ) )
C   k=1  jk        x   t    j        x              j        x   x
C the functions C, Q and R must be defined in this routine.
C
      INTEGER NPD, IRES
      REAL T, X
      REAL U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), R(NPDE)
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      REAL XL, XR, T0, TE
      REAL DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT

      REAL EPS

      EPS = DUMPRO(2)

      C(1,1) = 1.0
      Q(1) = U(1)*DUDX(1)
      R(1) = EPS*DUDX(1)

      RETURN
      END
      SUBROUTINE BNDR (T, BETA, GAMMA, U, UX, NPD, LEFT, IRES)
C
C Boundary conditions routine
C The boundary conditions are written as
C   BETA (x,t) R (x,t,u,u ) = GAMMA (x,t,u,u )
C       j       j        x         j        x
C The functions BETA and GAMMA should be defined in this routine.
C
      INTEGER NPD, IRES
      LOGICAL LEFT
      REAL T
      REAL BETA(NPDE), GAMMA(NPDE), U(NPDE), UX(NPDE)
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      REAL XL, XR, T0, TE
      REAL DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT
C
      REAL X

      IF (LEFT) THEN
         X = XL
      ELSE
         X = XR
      ENDIF
      CALL UEXACT (X, T, GAMMA)
      BETA(1)  = 0.0
      GAMMA(1) = U(1) - GAMMA(1)

      RETURN
      END
      SUBROUTINE UEXACT (X, T, U)
C
C Exact solution
C
      REAL X, T
      REAL U(NPDE)
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      REAL XL, XR, T0, TE
      REAL DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT
C
      REAL EPS, R1, R2, R3, R123

      EPS = DUMPRO(2)

      R1 = EXP(-(X-0.5)/(20*EPS)-99*T/(400*EPS))
      R2 = EXP(-(X-0.5)/(4*EPS)-3*T/(16*EPS))
      R3 = EXP(-(X-0.375)/(2*EPS))
      R123 = R1+R2+R3
      U(1) = 1.0 - (0.9*R1 + 0.5*R2) / R123

      RETURN
      END
C
C#######################################################################
C
C DRIVER : test program to use the moving-grid interface in a DASSL
C          environment
C
C#######################################################################
C
      PROGRAM DRIVER
C
C ----------------------------------------------------------------------
C
C Main program MoL adaptive grid interface for DASSL
C   Calls problem initializer,
C   Initializes DASSL parameters + grid/solution
C   Put semi-discrete PDE system + Dorfi&Drury grid equation in DASSL
C   Write grid and solution at specific steps (TPRINT) to outputfile
C
C Problem choice by loading the specific problem file with the modules:
C
C     SUBROUTINE INIPRB (TEXT)
C     CHARACTER TEXT*80
C   Initialize /PROBLM/
C
C     SUBROUTINE UINIT (NPDE, NPTS, Y)
C     INTEGER NPDE, NPTS
C     REAL Y(NPDE+1,NPTS)
C   Initial solution; optionnally redefinition of (uniform) grid
C
C     SUBROUTINE SPDEF (T,X,NPDE, U, DUDX, C, Q, R, IRES)
C     INTEGER NPDE, IRES
C     REAL T, X
C     REAL U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), R(NPDE)
C   PDE defining functions C, Q, R
C
C     SUBROUTINE BNDR (T, BETA, GAMMA, U, UX, NPDE, LEFT, IRES)
C     INTEGER NPDE, IRES
C     LOGICAL LEFT
C     REAL T
C     REAL BETA(NPDE), GAMMA(NPDE), U(NPDE), UX(NPDE)
C   Boundary function
C
C     SUBROUTINE UEXACT (X, T, U)
C     REAL X, T
C     REAL U(NPDE)
C   Exact solution (only called if SOLAV=TRUE)
C
      INTEGER MXNPDE, MXNEQ, MXLIW, MXLRW, MXNRWK
      PARAMETER (MXNPDE = 2, MXNEQ = 303)
      PARAMETER (MXLIW = 20+MXNEQ, MXLRW = (6*MXNPDE+20)*MXNEQ)
      PARAMETER (MXNRWK = MXNEQ+(6+MXNPDE)*MXNPDE)
      INTEGER INFO(15), IWORK(MXLIW), IPAR(1)
      REAL Y(MXNEQ), YPRIME(MXNEQ), RTOL(1), ATOL(1), RWORK(MXLRW),
     +     RWK(MXNRWK)
C
C   Y     : Grid and solution values
C   YPRIME: Derivative of Y
C   INFO  : Task_communication with DASSL
C   RTOL  : Relative tolerance for DASSL
C   ATOL  : Absolute tolerance for DASSL
C   RWORK : (Optional) REAL input values for DASSL
C   IWORK : (Optional) INTEGER input values for DASSL
C   RWK   : Workspace SKMRES
C
C COMMONs used:
C
      INTEGER NPTS, LUNR, LUNI
      COMMON /MOLIF/ NPTS, LUNR, LUNI
C
C   NPTS  : # grid points (needed in residual routine)
C   LUNR  : log. unit # output file for results
C   LUNI  : log. unit # run information file
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      REAL XL, XR, T0, TE
      REAL DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT
C
C NPDE   # partial differential equations
C XL     Left boundary
C XR     Right boundary
C T0     Starting time
C TE     Final time
C DUMPRO Storage reserved for problem parameters
C        DUMPRO(1) = M (space coordinate type)
C ANAJAC TRUE, if user specified Jacobian
C        (SUBROUTINE JAC, see documentation of DAE solver)
C SOLAV  TRUE, if exact solution is available
C        (SUBROUTINE UEXACT)
C TPRINT NPRINT output times
C NPRINT DIMENSION TPRINT
C
      EXTERNAL INIPRB, OUT, RESID, RUNOUT, SETSKM, SDASSL
C
C ---------------------------------------------------------------------
C
      CHARACTER IDENT*30, TEXT*80
      INTEGER I, IBAND, IDID, IPRINT, IRES, LIW, LRW, M, MAXORD, NCTF,
     +        NEQ, NETF, NFCN, NOINV, NRWK, NSTEPS
      REAL ALPHA, KAPPA, T, TAU, TOUT
C
C ccc Open files for results and run info
      LUNR = 4
      LUNI = 8
      OPEN (UNIT=LUNR, FILE='RESULT')
      OPEN (UNIT=LUNI, FILE='RUNINF')
C
C   Run identification
      IDENT = 'ACM-TOMS, Ex.I'
C
C ccc Initialize /PROBLM/
      CALL INIPRB (TEXT)
C   TEXT: Problem information
      WRITE(LUNR,'(A80)') TEXT
      WRITE(LUNI,'(A80)') TEXT
C
C ccc Initialize method parameters, grid, solution and derivative at T0
C     DASSL input
C
C   Method parameters; for Burgers equation (PRBDSH file) TAU = 1E-3
      NPTS  = 21
      M     = NINT(DUMPRO(1))
      TAU   = 0.0
      KAPPA = 2.0
      ALPHA = 0.01
      NRWK  = MXNRWK
C
C   Call initialization routine SETSKM; determine initial grid;
C     store initial values of U in Y
      CALL SETSKM (NEQ, NPDE, NPTS, XL,XR, TAU, KAPPA, ALPHA,
     +             Y, RWK, NRWK, M, T0, IBAND, IRES)
      IF (IRES .EQ. -1) THEN
         STOP 'Error in SETSKM'
      ENDIF
C
C   Initial Yprime = 0
      DO 1 I = 1, NEQ
         YPRIME(I) = 0.0
    1 CONTINUE
C
C   Initialize DASSL input
      DO 5 I = 1, 15
         INFO(I) = 0
    5 CONTINUE
C    Both tolerances are scalars (default)
      ATOL(1) = 1E-3
      RTOL(1) = 1E-3
C    Intermediate output mode
      INFO( 3) = 1
C    Analytical Jacobian
      IF (ANAJAC) INFO(5) = 1
C    Banded Jacobian
      INFO( 6) = 1
      IWORK(1) = IBAND
      IWORK(2) = IBAND
C    Default maximum integration order
      MAXORD = 5
C    Y, YPRIME probably inconsistent at T0
      INFO(11) = 1
C
C ccc Check length arrays
      IF (NEQ .GT. MXNEQ) THEN
         PRINT *, 'MXNEQ too small, needed:', NEQ
         STOP 'Workspace too small'
      ENDIF
      LIW = 20+NEQ
      IF (LIW .GT. MXLIW) THEN
         PRINT *, 'MXLIW too small, needed:', LIW
         STOP 'Workspace too small'
      ENDIF
      LRW    = 40+(MAXORD+6+3*IBAND+1)*NEQ + 2*(NEQ/(2*IBAND+1)+1)
      IF (LRW .GT. MXLRW) THEN
         PRINT *, 'MXLRW too small, needed:', LRW
         STOP 'Workspace too small'
      ENDIF
C
C ccc Write run header to files
      TEXT = ' MoL, PDE+D&D int.face; DAE int.: DASSL'
      I = 40
      TEXT(I:80) = ';  ID:'
      WRITE(TEXT(I+6:80),'(A30)') IDENT
      WRITE(LUNR,'(A80)') TEXT
      WRITE(LUNI,'(A80)') TEXT
      I = 1
      TEXT(I:80) = ' NPTS='
      WRITE(TEXT(I+6:I+8),'(I3)') NPTS
      I = I+9
      TEXT(I:I+6) = '; RTOL='
      WRITE(TEXT(I+7:I+14),'(E8.3)') RTOL(1)
      I = I+15
      TEXT(I:I+6) = ', ATOL='
      WRITE(TEXT(I+7:I+14),'(E8.3)') ATOL(1)
      WRITE(LUNR,'(A80)') TEXT
      WRITE(LUNI,'(A80)') TEXT
      I = 1
      TEXT(I:80) = ' TAU='
      WRITE(TEXT(I+5:I+12),'(E8.3)') TAU
      I = I+13
      TEXT(I:I+7) = ', KAPPA='
      WRITE(TEXT(I+8:I+15),'(E8.3)') KAPPA
      I = I+16
      TEXT(I:I+7) = ', ALPHA='
      WRITE(TEXT(I+8:I+15),'(E8.3)') ALPHA
      WRITE(LUNR,'(A80)') TEXT
      WRITE(LUNI,'(A80)') TEXT
C
C
C ccc Write initial grid and solution to output file
      CALL OUT (T0, Y, RWK(1), RWK(NRWK-NPTS+1))
C
C
C
C ccc DASSL loop
C     Call DASSL with as residual routine RESID, the enveloping routine
C     of SKMRES
      T = T0
      DO 10 IPRINT = 1, NPRINT
         TOUT = TPRINT(IPRINT)
   15    CALL SDASSL (RESID, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL,
     +                IDID, RWORK, LRW, IWORK, LIW, RWK, IPAR, JAC)
         IF (IDID .EQ. 1) THEN
C     One step in intermediate-output mode
C
C      Write Run info to file
            CALL RUNOUT(RWORK, IWORK)
C
            GOTO 15
         ENDIF
C
C   Write grid and solution to output file
         CALL OUT(T, Y, RWK(1), RWK(NRWK-NPTS+1))
C
C   Give run statistics until t = TOUT
         NSTEPS = IWORK(11)
         NFCN   = IWORK(12)
         NOINV  = IWORK(13)
C        NOSOLV = NFCN
         NETF   = IWORK(14)
         NCTF   = IWORK(15)
         WRITE(LUNR,*) 'Statistics:'
         WRITE(LUNR,*) '   FNS, JACS:', NFCN, NOINV
         WRITE(LUNR,*) '   STEPS, ETF, CTF:', NSTEPS, NETF, NCTF

         IF (IDID .LT. 0) GOTO 900
   10 CONTINUE

      CLOSE(LUNR)
      CLOSE(LUNI)
      STOP 'Ready'
C
C ccc Error return
  900 CONTINUE
      WRITE(LUNR,*) 'IDID=', IDID
      STOP 'DASSL error'
      END
      SUBROUTINE RESID (T, Y, YPRIME, DELTA, IRES, RWK, IPAR)
      INTEGER IRES
      INTEGER IPAR(*)
      REAL T
      REAL Y(*), YPRIME(*), DELTA(*), RWK(*)
C
C Determine DAE system for DASSL
C   residual DELTA = A.YPRIME - G
C
C Entry:
C   T     : Current time
C   Y     : Current grid + solution
C   YPRIME: Time derivative of Y
C Exit:
C   DELTA : A.YPRIME - G
C   IRES  : -1, if user thinks solution is illegal or ico node crossing
C
C ---------------------------------------------------------------------
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      REAL XL, XR, T0, TE
      REAL DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT
C
      INTEGER NPTS, LUNR, LUNI
      COMMON /MOLIF/ NPTS, LUNR, LUNI
C
      SAVE /PROBLM/, /MOLIF/
C
C
      EXTERNAL SKMRES
C
C ---------------------------------------------------------------------
C
      INTEGER NEQ, NRWK
C
      NEQ  = NPTS*(NPDE+1)
      NRWK = NEQ + (6+NPDE)*NPDE
C
C ccc Call SKMRES with IRES=0 to compute total residual
      CALL SKMRES (NEQ, T, Y, YPRIME, DELTA, IRES, RWK, NRWK)
      IF (IRES .EQ. 2) THEN
         IRES = -2
         RETURN
      ELSE IF (IRES .EQ. 3) THEN
         WRITE(LUNI,999) T
  999      FORMAT(' Illegal solution at T= ', E12.4)
         IRES = -1
         RETURN
      ENDIF
C
      RETURN
      END
      SUBROUTINE OUT (T, Y, UEX, ERR)
      REAL T
      REAL Y(NPDE+1,NPTS), UEX(NPDE,NPTS), ERR(NPTS)
C
C Write grid, solution and, if possible, error in sol. to output file
C
C Entry:
C   T     : Current time
C   Y     : Current grid + solution
C   UEX   : Workspace to store exact solution
C   UERR  : Workspace to store error for a component in each gridpoint
C
C ---------------------------------------------------------------------
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      REAL XL, XR, T0, TE
      REAL DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT
C
      INTEGER NPTS, LUNR, LUNI
      COMMON /MOLIF/ NPTS, LUNR, LUNI
C
      SAVE /PROBLM/, /MOLIF/
C
      REAL INFNRM, L2NRM
      EXTERNAL INFNRM, L2NRM, UEXACT
C
C ----------------------------------------------------------------------
C
      INTEGER NPDEMX
      PARAMETER (NPDEMX = 4)
      INTEGER IC, J, NPDE1
      REAL ERRINF
      REAL ERRTWO(NPDEMX)
C
      NPDE1 = NPDE+1
      IF (SOLAV) THEN
         DO 1 J = 1, NPTS
            CALL UEXACT(Y(NPDE1,J),T,UEX(1,J))
    1    CONTINUE
      ENDIF

      WRITE(LUNR,'(3H-T=,E13.5)') T
      WRITE(LUNR,*) 'X(S,TN):'
      WRITE(LUNR,'(5E23.14)') (Y(NPDE1,J), J=1, NPTS)
      DO 10 IC = 1, NPDE
         WRITE(LUNR,*) 'U(X(S,TN),TN), COMP:', IC
         WRITE(LUNR,'(5E23.14)') (Y(IC,J), J=1, NPTS)
         IF (SOLAV) THEN
            DO 20 J = 1, NPTS
               ERR(J) = Y(IC,J) - UEX(IC,J)
   20       CONTINUE
            ERRINF     = INFNRM (ERR, NPTS)
            ERRTWO(IC) = L2NRM  (ERR, Y(NPDE1,1), NPDE1, NPTS)
            WRITE(LUNR,*) 'ERR_U:'
            WRITE(LUNR,'(5E23.14)') (ERR(J), J=1, NPTS)
            WRITE(LUNR,*) 'MAX. NORM:', ERRINF
            WRITE(LUNR,*) 'TWO  NORM:', ERRTWO(IC)
         ENDIF
   10 CONTINUE

      RETURN
      END
      SUBROUTINE RUNOUT (RWORK, IWORK)
      INTEGER IWORK(*)
      REAL RWORK(*)
C
C Write statistics after each successful step to run info file
C
C Entry:
C   RWORK: REAL info DASSL
C   IWORK: INTEGER info DASSL
C
C ---------------------------------------------------------------------
C
      INTEGER NPTS, LUNR, LUNI
      COMMON /MOLIF/ NPTS, LUNR, LUNI
C
      SAVE /MOLIF/
C
C ---------------------------------------------------------------------
C
      INTEGER IQ
      REAL H, T
C
      T  = RWORK(4)
      H  = RWORK(7)
      IQ = IWORK(8)
      WRITE (LUNI,'(6H Time=,E13.5, 4H; H=,E13.5, 8H; Order=,I2)')
     +       T, H, IQ

      RETURN
      END
      REAL FUNCTION INFNRM (V, N)
      INTEGER N
      REAL V(N)
C
C Exit: INFNRM = (J=1,N) MAX !V(J)!
C
C ----------------------------------------------------------------------
C
      INTEGER J
C
      INFNRM = 0.0
      DO 10 J = 1, N
         INFNRM = MAX(INFNRM,ABS(V(J)))
   10 CONTINUE

      RETURN
      END
      REAL FUNCTION L2NRM (V, X, INCX, N)
      INTEGER INCX, N
      REAL V(N), X(INCX,N)
C
C Exit: L2NRM = SQRT((J=2,N) SUM ((X(J)-X(J-1))/2.(V(J)^2+V(J-1)^2))
C
C ----------------------------------------------------------------------
C
      INTEGER J
      REAL VJM1S, VJS
C
      L2NRM = 0.0
      VJM1S = V(1)*V(1)
      DO 10 J = 2, N
         VJS   = V(J)*V(J)
         L2NRM = L2NRM + (X(1,J)-X(1,J-1))/2*(VJS+VJM1S)
         VJM1S = VJS
   10 CONTINUE
      L2NRM = SQRT(L2NRM)

      RETURN
      END
C
C#######################################################################
C
C SPMDIF : moving-grid interface routines
C
C#######################################################################
C
C-----------------------------------------------------------------------
C
C Moving grid discretization module SPMDIF
C ----------------------------------------
C This module discretizes systems of partial differential equations
C in one space variable on a moving grid. The class of equations that
C can be handled is given by
C
C   NPDE                   k                      -m  m
C   sum  C   (x,t, u, u ) u  + Q (x,t, u, u ) =  x  (x  R (x,t, u, u ))
C   k=1   j,k      -  -x   t    j      -  -x             j      -  -x  x
C
C where            1         NPDE T
C           u = ( u , ... , u    )   ,  j = 1,... , NPDE,
C           -
C      k
C and u  is the partial derivative wrt time of the k-th component of u.
C      t
C
C The functions C, Q, and R are assumed to be continuous w.r.t. the
C space variable.
C
C The independent variables x and t satisfy  x  < x < x   with x  and x
C                                             L        R        L      R
C fixed and  t > t .
C                 0
C The boundary conditions have the form
C
C   BETA(x,t).R(x,t,u,u ) = GAMMA(x,t,u,u )  at x = x , x  ,
C                   - -x              - -x           L   R
C
C where not all of the functions BETA and GAMMA are set to zero.
C
C The initial conditions are given by
C                0
C   u (x,t )  = u (x)  for x  <= x <= x .
C   -     0     -           L          R
C The discretization method for the PDE in Lagrangian formulation
C used by this module is based on a lumped Galerkin / Petrov-Galerkin
C method and evaluates the PDE functions in a point between
C the (moving) grid points.
C
C References:
C   Fixed-grid spatial discretization
C            Skeel R.D. and Berzins M.
C            A Method for the Spatial Discretisation of Parabolic
C            Equations in one Space Variable.
C            Leeds Report no 217,
C            Dept. of Computer Studies, The University.
C   Grid movement
C            Verwer J.G., Blom J.G., Furzeland R.M. and Zegeling P.A.
C            A Moving-Grid Method for One-Dimensional PDEs based on
C            the Method of Lines.
C            Report NM-R8818,
C            Centre for Mathematics and Computer Science, Amsterdam.
C   Interface
C            Blom J.G. and Zegeling P.A.
C            A Moving-Grid Interface for Systems of One-Dimensional
C            Time-Dependent Partial Differential Equations.
C            Report NM-R8904,
C            Centre for Mathematics and Computer Science, Amsterdam.
C            (submitted to ACM TOMS)
C
C----------------------------------------------------------------------
C
C How to use this module
C ----------------------
C 1.  Set NPDE = # PDEs to be solved.
C     Set NPTS = # mesh points to be used.
C                (NC=NPTS-2 is # internal points)
C     Set M for space coordinate type
C         = 0 for Cartesian,  = 1 for cylindrical, = 2 for spherical.
C     Specify a workspace of size at least  (NPDE+1)*NPTS+(6+NPDE)*NPDE
C     for use by the routine SKMRES which defines the DAE system being
C     solved by the integrator.
C
C     Call the initialization routine SETSKM, see the documentation at
C     the head of this routine for the precise details of the call.
C
C     Set TS and TOUT for start and end integration times.
C     Initialize data as required for time integration,
C                - see documentation of DAE solver.
C     Call the DAE solver with as residual routine SKMRES or an
C     enveloping routine to satisfy the header requirements.
C
C 2.  Provide a set of routines which describe the precise form of the
C     PDEs to be solved. Three routines must be provided and the names
C     of these routines are fixed. These routines are:
C        SPDEF   forms the functions C, Q and R of the PDE in a
C                given x-point.
C        BNDR    forms the functions BETA and GAMMA associated with the
C                boundary conditions for the PDE.
C        UINIT   supplies the initial values of the PDE part.
C                An initial uniform grid is generated by SETSKM and
C                provided in Y(NPDE+1,I), I=1,NPTS. If required, a user
C                can redefine the mesh in a nonuniform way.
C     The headers of these routines are:
C
C      SUBROUTINE SPDEF (T, X, NPDE, U, DUDX, C, Q, R, IRES)
C      INTEGER NPDE, IRES
C      REAL T, X
C      REAL U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), R(NPDE)
C
C      SUBROUTINE BNDR (T, BETA, GAMMA, U, DUDX, NPDE, LEFT, IRES)
C      INTEGER NPDE, IRES
C      LOGICAL LEFT
C      REAL T
C      REAL BETA(NPDE), GAMMA(NPDE), U(NPDE), DUDX(NPDE)
C
C      SUBROUTINE UINIT (NPDE, NPTS, Y)
C      INTEGER NPDE, NPTS
C      REAL Y(NPDE+1,NPTS)
C
C
C Example problem
C ---------------
C The easiest way to describe how the problem description routines
C should be written is by a simple example. Consider the following
C problem from electrodynamics
C    u  = eps.p.u   - g(u-v)
C     t          xx
C and                             (so m = 0 and NPDE = 2)
C    v  =     p.v   + g(u-v)
C     t          xx
C with
C    g(z) = exp(eta.z/3) - exp(-2.eta.z/3) ,
C    0 <= x <= 1  and  0 <= t <= 4;
C    eps = 0.143, p = 0.1743, and eta = 17.19.
C
C The left boundary condition (LEFT = .TRUE.) is given by
C    u  = 0  and  v = 0   at x = 0,
C     x
C the right boundary condition (LEFT = .FALSE.) is
C    u = 0  and  v  = 0   at x = 1,
C                 x
C and the initial conditions are
C    u = 1  and  v = 0  at t = 0.
C
C The routines UINIT, SPDEF and BNDR are listed below.
C The component u of the PDE at the i-th grid point is held as Y(1,i)
C in the package, the component v as Y(2,i); the i-th grid point
C itself is stored in Y(3,i).
C
C
C
C     SUBROUTINE UINIT (NPDE, NPTS, Y)
C
C Routine for PDE initial values.
C Entry:
C   Y(NPDE+1,i) = x_i; uniform mesh, generated by package
C Exit:
C   Y(NPDE+1,i) = x_i; mesh, optionally changed by user
C   Y(     k,i) = u_k(x_i,t0); initial value of k-th component
C                                  i = 1,.., NPTS
C
C     INTEGER NPDE, NPTS
C     REAL Y(NPDE+1,NPTS)
C
C     INTEGER I
C
C     DO 10 I = 1, NPTS
C        Y(1,I) = 1.0
C        Y(2,I) = 0.0
C  10 CONTINUE
C
C     RETURN
C     END
C
C
C
C     SUBROUTINE SPDEF (T, X, NPDE, U, DUDX, C, Q, R, IRES)
C
C Routine to describe the body of the PDE system.
C The PDE is written as
C   NPDE               k                    -m   m
C   sum C  (x,t,u,u ) u  + Q (x,t,u,u )  = x   (x  R (x,t,u,u ) ) .
C   k=1  jk        x   t    j        x              j        x   x
C The functions C, Q and R must be defined in this routine.
C
C     INTEGER NPDE, IRES
C     REAL T, X
C     REAL U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), R(NPDE)
C
C     INTEGER J, K
C     REAL EPS, ETA, GZ, P, Z
C     DATA EPS /0.143/, ETA /17.19/, P /0.1743/
C
C     DO 10 K = 1, NPDE
C        DO 20 J = 1, NPDE
C           C(J,K) = 0.0
C  20    CONTINUE
C        C(K,K) = 1.0
C  10 CONTINUE
C
C     Z  = U(1) - U(2)
C     GZ = EXP(ETA*Z/3) - EXP(-2*ETA*Z/3)
C     Q(1) =  GZ
C     Q(2) = -GZ
C
C     R(1) = EPS*P * DUDX(1)
C     R(2) =     P * DUDX(2)
C
C     RETURN
C     END
C
C
C
C     SUBROUTINE BNDR (T, BETA, GAMMA, U, DUDX, NPDE, LEFT, IRES)
C
C Boundary conditions routine
C The boundary conditions are written as
C   BETA (x,t) R (x,t,u,u ) = GAMMA (x,t,u,u )
C       j       j        x         j        x
C The functions BETA and GAMMA should be defined in this routine.
C
C     INTEGER NPDE, IRES
C     LOGICAL LEFT
C     REAL T
C     REAL BETA(NPDE), GAMMA(NPDE), U(NPDE), DUDX(NPDE)
C
C     IF (LEFT) THEN
C        BETA (1) = 1.0
C        GAMMA(1) = 0.0
C        BETA (2) = 0.0
C        GAMMA(2) = U(2)
C     ELSE
C        BETA (1) = 0.0
C        GAMMA(1) = U(1) - 1.0
C        BETA (2) = 1.0
C        GAMMA(2) = 0.0
C     ENDIF
C
C     RETURN
C     END
C
      SUBROUTINE SETSKM (NEQN, NPDE, NPTS, XL, XR, TAU, KAPPA, ALPHA,
     +                   Y, RWK, NRWK, M, TS, IBAND, IRES)
C
C-----------------------------------------------------------------------
C Purpose:
C -------
C Initializing routine for moving-grid spatial discretization.
C
C Parameters:
C ----------
      INTEGER NEQN, NPDE, NPTS, NRWK, M, IBAND, IRES
      REAL XL, XR, TAU, KAPPA, ALPHA, TS
      REAL Y(*), RWK(NRWK)
C
C NEQN  Exit: the size of the DAE system generated when the PDE +
C       the grid equations are discretized. This value is (NPDE+1).NPTS.
C NPDE  Entry: the number of PDEs.
C NPTS  Entry: the number of spatial mesh points, including the
C       boundary points.
C XL    Entry: left boundary point.
C XR    Entry: right boundary point.
C TAU   Entry: time-smoothing parameter.
C       If the initial grid satisfies the grid equation with TAU=0 at
C       TS=0, TAU can be chosen equal to zero. If this is not the case
C       and if the initial grid has to be adapted, or if time-smoothing
C       is desired a typical value of TAU = 1E-3, but TAU should be
C       related to the time scale of the problem.
C KAPPA Entry: spatial smoothing parameter (REAL).
C       KAPPA = 2.0 was found to be satisfying for all problems tested.
C       For less spatial smoothing KAPPA = 1.0 will suffice.
C ALPHA Entry: monitor regularizing parameter.
C       ALPHA = 0.01 is recommended (for a well-scaled system of PDEs)
C Y     Exit: array of length >= (NPDE+1).NPTS that contains the initial
C       (uniformly spaced) grid and the corresponding initial PDE
C       solution values. This array must be passed across as a one-
C       dimensional array of length NEQN to the DAE solver. This
C       array is ordered as
C          PDE comp.  : Y((NPDE+1)*l + j) l=0,...,NPTS-1,
C                                         j=1,...,NPDE
C          grid points: Y((NPDE+1)*(l+1)) l=0,...,NPTS-1.
C RWK   workspace of length NRWK for the residual routine SKMRES which
C       actually performs the semi-discretization of the PDEs and
C       defines the grid equations.
C NRWK  Entry: dimension of workspace RWK.
C       NRWK must be >= (NPDE+1).NPTS + (6+NPDE).NPDE.
C M     Entry: integer >= 0 which determines the coordinate system used.
C          0: Cartesian coordinates,
C          1: cylindrical polar coordinates,
C          2: spherical polar coordinates.
C TS    Entry: the time at which the integration starts.
C IBAND Exit: an upper bound on the half bandwidth of the Jacobian
C       matrix when this module is used. (If the DAE solver is called
C       with banded matrix routines this parameter should be
C       supplied to MATSET (SPRINT) or to DASSL (IWORK(1) and IWORK(2)).
C IRES  Exit: this parameter is set to -1 if an error is found by
C       this routine.
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C
C From here the comments are only meant as aid and assistance to
C understand the program.
C
C Four parameters are passed across from here in
C      COMMON /SPSKM/  NPDE1, NC, M, SING
C
C NPDE1 = NPDE+1   the number of PDEs + 1 (for the grid equation).
C NC    = NPTS-2   the number of internal mesh points.
C M     = M_user   = 0,1,2, if resp., Cartesian, cylindrical or
C                           spherical polar coordinates in use.
C SING  = .TRUE.   if PDE has a polar singularity.
C
C A common block filled with method parameters is initialized
C in this routine
C      COMMON /METPAR/ RTAU, RKAPPA, ALFA
C
C RTAU   time-smoothing parameter grid equation (= TAU)
C RKAPPA spatial smoothing parameter grid equation (= KAPPA)
C ALFA   monitor constant (= ALPHA)
C
C A common block filled with machine constants is also initialized
C in this routine
C      COMMON /MACH/ NERR, SRELPR
C
C NERR   logical unit number of error unit
C SRELPR machine eps as determined by MACHAR
C
C
C Detailed description of workspace:
C ---------------------------------
C Size:  NRWK must be >=  (NPDE+1)*NPTS + (6+NPDE)*NPDE
C
C RWK(  1:.+(NPDE+1)*NPTS) G(NPDE+1,0:NC+1), part of residual not
C                          dependent on time-derivative.
C RWK(IW1:.+ NPDE)         UKSI(NPDE), solution values at evaluat. point
C RWK(IW2:.+ NPDE)         UXKSI(NPDE), space derivs. at evaluat. point
C RWK(IW3:.+ NPDE)         BETA(NPDE), boundary function BETA
C RWK(IW4:.+ NPDE)         GAMMA(NPDE), boundary function GAMMA
C RWK(IW5:.+ NPDE)         RC(NPDE), flux at evaluation point
C RWK(IW6:.+ NPDE)         QC(NPDE), source term at evaluation point
C RWK(IW7:.+ NPDE*NPDE)    CC(NPDE,NPDE), udot factor at evaluat. point
C
C-----------------------------------------------------------------------
C
      CHARACTER*6 PDCODE
      COMMON /DISCHK/ PDCODE
C
      INTEGER NPDE1, NC, MM
      LOGICAL SING
      COMMON /SPSKM/ NPDE1, NC, MM, SING
C
      REAL RTAU, RKAPPA, ALFA
      COMMON /METPAR/ RTAU, RKAPPA, ALFA
C
      INTEGER NERR
      REAL SRELPR
      COMMON /MACH/ NERR, SRELPR
C
      SAVE   /DISCHK/, /SPSKM/, /METPAR/, /MACH/
C
      EXTERNAL MACHAR, YINIT
C
C-----------------------------------------------------------------------
C
      INTEGER IW1, IW2, IW3, IW4, IW5, IW6, IW7, IWE
      INTEGER IBETA, IT,IRND, NGRD, MACHEP, NEGEP, IEXP, MINEXP,
     +        MAXEXP
      REAL EPS, EPSNEG, XMIN, XMAX

      NPDE1 = NPDE+1
      NC = NPTS-2
      MM = M
      SING = M .GE. 1 .AND. ABS(XL) .LE. SRELPR*(XR-XL)

      RTAU   = TAU
      RKAPPA = KAPPA
      ALFA   = ALPHA

      NERR   = 8
      CALL MACHAR (IBETA, IT,IRND, NGRD, MACHEP, NEGEP, IEXP, MINEXP,
     +             MAXEXP, EPS, EPSNEG, XMIN, XMAX)
      SRELPR = MAX (EPS, EPSNEG)

C Fill IBAND; ML = MU=2*NPDE1
      IBAND = 2*NPDE1

      NEQN = NPDE1*NPTS

      IW1 =   1 + NEQN
      IW2 = IW1 + NPDE
      IW3 = IW2 + NPDE
      IW4 = IW3 + NPDE
      IW5 = IW4 + NPDE
      IW6 = IW5 + NPDE
      IW7 = IW6 + NPDE
      IWE = IW7 + NPDE*NPDE - 1
      IF (IWE .GT. NRWK) THEN
         WRITE(NERR,'(38H SETSKM - ERROR REAL WORKSPACE OF SIZE, I10,
     +                28H, IS SMALLER THAN REQUIRED :, I10)') NRWK, IWE
         IRES = -1
      ENDIF
      IF (M .LT. 0) THEN
         WRITE(NERR,'(44H SETSKM - POLAR PARAMETER LESS THAN ZERO, M=,
     +                I10)') M
         IRES = -1
      END IF
      IF (IRES .EQ. -1) RETURN
C
C Initialize grid and PDE variables by appropriate calls.
C
      CALL YINIT (NPDE, NPTS, XL, XR, Y)
C
      PDCODE = 'SPSKLM'

      RETURN
      END
      SUBROUTINE YINIT (NPDE, NPTS, XL, XR, Y)
      INTEGER NPDE, NPTS
      REAL XL, XR
      REAL Y(NPDE+1,0:NPTS-1)
C
      INTEGER NPDE1, NC, M
      LOGICAL SING
      COMMON /SPSKM/ NPDE1, NC, M, SING
      SAVE   /SPSKM/
C
      EXTERNAL UINIT
C
      INTEGER I
      REAL DX, XI
C
C Equidistant grid
      DX = (XR-XL)/(NC+1)
      DO 10 I = 0, NC+1
         XI = XL+I*DX
         Y(NPDE1,I) = XI
   10 CONTINUE
      CALL UINIT (NPDE, NPTS, Y)

      RETURN
      END
      SUBROUTINE SKMRES (NEQN, T, Y, YDOT, RES, IRES, RWK, NRWK)
C
C-----------------------------------------------------------------------
C Purpose:
C -------
C Enveloping routine to compute the residual of the PDE and of the grid
C equations. SKMRES checks on node-crossing, partitions the workspace
C and calls CWRESU for the spatial discretization and the computation
C of the residual of the PDE in Lagrangian formulation and CWRESX for
C the spatial discretization and the residual computation of the grid
C equations.
C
C Parameters:
C ----------
      INTEGER NEQN, IRES, NRWK
      REAL T
      REAL Y(NEQN), YDOT(NEQN), RES(NEQN), RWK(NRWK)
C
C NEQN  Entry: the size of the DAE system generated when the PDE +
C       the grid equations are discretized.
C T     Entry: evaluation time.
C Y     Entry: array of length NEQN containing the DAE vector consisting
C       of the spatial mesh and the corresponding initial PDE solution
C       values at time T. This array is ordered as
C          PDE comp.  : Y((NPDE+1)*l + j) l=0,...,NPTS-1,
C                                         j=1,...,NPDE
C          grid points: Y((NPDE+1)*(l+1)) l=0,...,NPTS-1.
C RES   Exit: residual vector.
C       If IRES = -1 RES should contain only the part of the residual
C       dependent on the time-derivative, if IRES /= -1 RES should
C       contain the full residual  A.ydot - g.
C IRES  Entry: see above.
C       Exit: 2, if setup routine SETSKM has not been called.
C             3, if one of the DAE solutions in the vector Y is not
C                acceptable.
C RWK   working storage of length NRWK.
C NRWK  Entry: dimension of RWK. Should be >= NEQN + (6+NPDE)*NPDE.
C
C-----------------------------------------------------------------------
C
      CHARACTER*6 PDCODE
      COMMON /DISCHK/ PDCODE
C
      INTEGER NPDE1, NC, M
      LOGICAL SING
      COMMON /SPSKM/ NPDE1, NC, M, SING
C
      INTEGER NERR
      REAL SRELPR
      COMMON /MACH/ NERR, SRELPR
C
      SAVE   /DISCHK/, /SPSKM/, /MACH/
C
      EXTERNAL CWRESU, CWRESX
C
C-----------------------------------------------------------------------
C
      INTEGER I, IW1, IW2, IW3, IW4, IW5, IW6, IW7, J, NPDE

      IF (PDCODE .NE. 'SPSKLM') THEN
         WRITE(NERR,*) ' ERROR IN SKLMRES ROUTINE - THE SETUP ROUTINE'//
     +                 ' SETSKM WAS NOT CALLED PRIOR TO SPRINT ENTRY'
         IRES = 2
         RETURN
      ENDIF

      NPDE = NPDE1-1

C Check on node-crossing
      DO 5 I = NPDE1, NEQN-NPDE1, NPDE1
         IF (Y(I) .GE. Y(I+NPDE1)) THEN
            WRITE(NERR,'(30H SKMRES - NON-MONOTONOUS GRID,,
     +                   22H VALUES OF GRID POINTS, I3,1H,,I3,
     +                    4H ARE, E13.5,1H1,E13.5)')
     +                   I/NPDE1, I/NPDE1+1, Y(I), Y(I+NPDE1)
            IRES = 3
         ENDIF
    5 CONTINUE

C Partition workspace
      IW1 =   1 + NEQN
      IW2 = IW1 + NPDE
      IW3 = IW2 + NPDE
      IW4 = IW3 + NPDE
      IW5 = IW4 + NPDE
      IW6 = IW5 + NPDE
      IW7 = IW6 + NPDE

C Calculate A.ydot and g for Lagrangian PDE
      CALL CWRESU (T, Y, YDOT, NPDE1-1, NC, M, SING,
     +             RWK(IW1), RWK(IW2), RWK(IW3), RWK(IW4),
     +             RWK(IW5), RWK(IW6), RWK(IW7),
     +             RES, RWK(1), IRES)
      IF (IRES .GE. 3) RETURN

C Calculate A.ydot and g for grid equations
      CALL CWRESX (T, Y, YDOT, NPDE1, NC, RES, RWK(1), IRES)
      IF (IRES .GE. 3) RETURN

      IF (IRES .NE. -1) THEN
C      Full residual needed; RES = A.ydot - g
         DO 10 J = 1, NEQN
            RES(J) = RES(J) - RWK(J)
   10    CONTINUE
      ENDIF

      RETURN
      END
      SUBROUTINE CWRESU (T, Y, YDOT, NPDE, NC, M, SING,
     +                   UKSI, UXKSI, BETA, GAMMA, RC, QC, CC,
     +                   AYDOT, G, IRES)
C
C-----------------------------------------------------------------------
C Purpose:
C -------
C Compute PDE part of residual equations A.ydot - g.
C   Return A.ydot in AYDOT and g in G to satisfy both
C   SPRINT and DASSL.
C
C Method:
C ------
C The Lagrangian form of the PDE is:
C   NPDE                   .k   k .
C   sum  C   (x,t, u, u ) (u - u  x)  + Q (x,t, u, u )
C   k=1   j,k      -  -x        x        j      -  -x
C
C                                    -m   m
C                                =  x   (x  R (x,t, u, u ))
C                                            j      -  -x  x
C     where        1         NPDE T
C           u = ( u , ... , u    )   ,  j = 1,... , NPDE,
C           -
C         .k                                                         .
C     and u  is the total time-derivative of the k-th comp. of u and x
C     is the derivative wrt to time of x.
C
C This equation is semi-discretized by a lumped finite-element method
C   (udot and ux.xdot lumped).
C   Integration over the l-1_th interval and over the l_th interval
C   both give an expression for the flux in X . Eliminating this value
C                                            l
C   gives a difference equation for l=1,...,N:
C
C                                               .                     .
C fR  R (ksi ) - fR   R (ksi   ) = fS1  S (ksi ,U ) + fSl   S (ksi   ,U )
C   l  j    l      l-1 j    l-1       l  j    l -l       l-1 j    l-1 -l
C
C   with:
C
C          m-mu   mu
C fR = zeta    ksi        , mu = -1 if PDE singular otherwise mu = m
C   l      l      l
C
C            m+1   m+1
C fS1 = (zeta   - X   ) / (m+1)
C    l       l     l
C
C           m+1      m+1
C fSl   = (X   - zeta   ) / (m+1)
C    l-1    l        l-1
C
C         .     NPDE            .p        p     .
C S (ksi ,U ) = sum C  (ksi ) [ U (X ) - U (X ) X ] + Q (ksi )
C  j    k -l    p=1  jp    k        l     x  l   l     j    k
C
C R , j_th component of flux evaluated at quadrature point ksi,
C  j
C Q , j_th component of source term evaluated at quadrature point ksi,
C  j
C C  , element j,p of matrix multiplying u , evaluated at ksi.
C  jp                                     t
C
C Left boundary equation, if non-singular:
C
C BETA (x ,t) R (x ) = GAMMA (x ,t, U , U (x ))
C     j  L     j  L         j  L    -0  -x  L
C
C   with
C              m                       .       m
C R (x ) = (ksi R (ksi ) - fS1 S (ksi ,U )) / x
C  j  L        0 j    0       0 j    0 -0      L
C
C                         if singular:
C         .
C S (ksi ,U )/(m+1) - R (ksi )/ksi  = 0
C  j    0 -0           j    0     0
C
C Right boundary equation:
C
C BETA (x ,t) R (x ) = GAMMA (x ,t, U   , U (x ))
C     j  R     j  R         j  R    -N+1  -x  R
C
C   with
C                                      .         m
C R (x ) = (fR  R (ksi ) + fSl S (ksi ,U   )) / x
C  j  R       N  j    N       N j    N -N+1      R
C
C
C Parameters:
C ----------
      INTEGER NPDE, NC, M, IRES
      LOGICAL SING
      REAL T
      REAL Y(NPDE+1,0:NC+1), YDOT(NPDE+1,0:NC+1),
     +     UKSI(NPDE), UXKSI(NPDE), BETA(NPDE), GAMMA(NPDE),
     +     RC(NPDE), QC(NPDE), CC(NPDE,NPDE),
     +     AYDOT(NPDE+1,0:NC+1), G(NPDE+1,0:NC+1)
C
C T      Entry: evaluation time
C Y      Entry: solution and grid at time T.
C        (Y(1:NPDE,L): U_l, Y(NPDE+1,L): X_l)
C YDOT   Entry: derivative of Y at T.
C NPDE   Entry: # PDEs.
C NC     Entry: # internal grid points.
C M      Entry: coordinate system indicator.
C SING   Entry: true, if PDE has a polar singularity (M>0, x_L=0).
C UKSI   workspace to hold the solution value at an evaluation point.
C UXKSI  workspace to hold the space derivatives at an evaluation point.
C BETA   workspace to hold the boundary function BETA.
C GAMMA  workspace to hold the boundary function GAMMA
C RC     workspace to hold the PDE function R.
C QC     workspace to hold the PDE function Q.
C CC     workspace to hold the PDE function C.
C AYDOT  Exit: A.ydot part of the residual.
C G      Exit: g part of the residual.
C IRES   Exit: 3 if some user function indicated that a solution value
C        is unphysical.
C
C Local variables:
C ---------------
      INTEGER MU
      REAL FSCL, FSC1, SCLMQ, SCL1MQ,
     +     DENOMI, KSI, KSIMU, ZETA, ZETAMU, PHIL, PHILX
C MU     if sing. then -1 else m.
C FSCL   fS1_l.
C FSC1   fSl_l+1.
C SCLMQ  S(ksi_l,udot_l)   - Q(ksi_l).
C SCL1MQ S(ksi_l,udot_l+1) - Q(ksi_l).
C DENOMI 1 / [ (X_l,X_l+1) int y**(-m) dy ]
C KSI    quadrature point for l_th interval
C KSIMU  ksi**mu
C ZETA   zeta_l ** (m+1); if sing. and l=0 then
C                         zeta = 0.0
C                         else   (X_l,X_l+1) int y dy * denomi
C ZETAMU zeta_l ** (m-mu)
C PHIL   'left' trial function for l_th interval in eval. point ksi
C        NB. phi_l+1 = 1 - phil
C PHILX  deriv. of phi_l wrt x in eval. point ksi
C        NB. phi_l+1_x = - phil_x
C
C
      EXTERNAL BNDR, SPDEF
C
C -------------------------------------------------------------------
C
      INTEGER IP, J, L, NPDE1
      REAL DENPHI, RCJDOT, RCJG, UXL, UXL1, X0, X0M, XL, XL1, XN1M

      NPDE1 = NPDE+1

      X0 = Y(NPDE1,0)
      IF (SING) THEN
         MU = -1
      ELSE
         MU = M
      ENDIF
C
C First interval, compute contribution to residual eq. in X_1 and
C   left boundary equation
C
      L = 0
         XL  = X0
         XL1 = Y(NPDE1,L+1)
         IF (.NOT. SING) THEN
            IF (M .EQ. 1) THEN
               DENOMI = 1/LOG(XL1/XL)
            ELSE
               DENOMI = (1-M)/(XL1**(1-M) - XL**(1-M))
            ENDIF
         ENDIF
         IF (SING) THEN
            KSI = 2/3. * (XL1**3-XL**3) / (XL1**2-XL**2)
            KSIMU = 1/KSI
         ELSE IF (M .EQ. 1) THEN
            KSI = (XL1-XL) * DENOMI
            KSIMU = KSI
         ELSE IF (M .EQ. 2) THEN
            KSI = LOG(XL1/XL) * DENOMI
            KSIMU = KSI*KSI
         ELSE
            KSI = (XL1**(2-M)-XL**(2-M)) / (2-M) * DENOMI
            IF (M .EQ. 0) THEN
               KSIMU = 1.0
            ELSE
               KSIMU = KSI**MU
            ENDIF
         ENDIF
         IF (SING) THEN
            ZETA = 0.0
            ZETAMU = ZETA
            DENPHI = 1/(XL1*XL1-XL*XL)
            PHIL = (XL1*XL1-KSI*KSI)*DENPHI
            PHILX = -2*KSI*DENPHI
         ELSE
            ZETA = 0.5*(XL1*XL1-XL*XL) * DENOMI
            ZETAMU = 1.0
            IF (M .EQ. 1) THEN
               PHIL = LOG(XL1/KSI) * DENOMI
               PHILX = -1/KSI * DENOMI
            ELSE IF (M .EQ. 0) THEN
               PHIL = (XL1 - KSI) * DENOMI
               PHILX = -DENOMI
            ELSE
               PHIL = (XL1**(1-M) - KSI**(1-M)) / (1-M) * DENOMI
               PHILX = -KSI**(-M) * DENOMI
            ENDIF
         ENDIF
         IF (M .EQ. 0) THEN
            X0M = 1.0
         ELSE
            X0M = X0**M
         ENDIF

C      Get left boundary function values
         DO 5 J = 1, NPDE
            UXKSI(J) = (Y(J,1)-Y(J,0)) / (XL1-XL)
    5    CONTINUE
         CALL BNDR (T, BETA, GAMMA, Y(1,0), UXKSI,
     +              NPDE, .TRUE., IRES)
         IF (IRES .EQ. 3) RETURN

C Compute U and Ux in evaluation point
         DO 10 J = 1, NPDE
            UKSI(J)  = Y(J,L)*PHIL  + Y(J,L+1)*(1-PHIL)
            UXKSI(J) = Y(J,L)*PHILX + Y(J,L+1)*(-PHILX)
   10    CONTINUE
C Get C, Q and R in evaluation point
         CALL SPDEF (T, KSI, NPDE, UKSI, UXKSI, CC, QC, RC, IRES)
         IF (IRES .EQ. 3) RETURN

         FSCL = (ZETA- XL**(M+1))/(M+1)
         FSC1 = (XL1**(M+1)-ZETA)/(M+1)
         DO 20 J = 1, NPDE
            SCLMQ  = 0.0
            SCL1MQ = 0.0
            DO 30 IP = 1, NPDE
               UXL1 = (Y(IP,L+2)-Y(IP,L  ))/(Y(NPDE1,L+2)-Y(NPDE1,L  ))
               SCLMQ  = SCLMQ  +
     +                  CC(J,IP)*(YDOT(IP,L  ))
               SCL1MQ = SCL1MQ +
     +                  CC(J,IP)*(YDOT(IP,L+1)-UXL1*YDOT(NPDE1,L+1))
   30       CONTINUE
C Store contribution from l_th interval to residual equation in X_l+1
            AYDOT(J,L+1) = FSC1 * SCL1MQ
            G    (J,L+1) = -ZETAMU*KSIMU*RC(J) - FSC1*QC(J)
C Compute boundary equations
            IF (SING) THEN
	       IF (BETA(J) .NE. 0) THEN
C               Bnd.eq. is contribution from 0_th interval to
C               difference eq. in x_L
                  AYDOT(J,0) = SCLMQ / (M+1)
                  G    (J,0) = RC(J)/KSI - QC(J)/(M+1)
	       ELSE
                  AYDOT(J,0) = 0.0
                  G    (J,0) = GAMMA(J)
	       ENDIF
            ELSE
C            Otherwise compute flux in x_L from contribution from 0_th
C            interval to difference equation in x_L, and substitute in
C            user's boundary equation.
               RCJDOT = -FSCL * SCLMQ / X0M
               RCJG   = (KSIMU*RC(J) - FSCL*QC(J)) / X0M
               AYDOT(J,0) = -BETA(J)*RCJDOT
               G    (J,0) = BETA(J)*RCJG - GAMMA(J)
            ENDIF
   20    CONTINUE

      DO 100 L = 1, NC-1
C
C Evaluate PDE functions in quadrature point in l_th interval.
C Add contribution from [X_l,X_l+1] to that of previous interval to
C get residual equation in X_l.
C Store contribution from l_th interval to residual equation in X_l+1.
C
         XL  = XL1
         XL1 = Y(NPDE1,L+1)
         IF (M .EQ. 1) THEN
            DENOMI = 1/LOG(XL1/XL)
         ELSE
            DENOMI = (1-M)/(XL1**(1-M) - XL**(1-M))
         ENDIF
         IF (SING) THEN
            KSI = 2/3. * (XL1**3-XL**3) / (XL1**2-XL**2)
            KSIMU = 1/KSI
         ELSE IF (M .EQ. 1) THEN
            KSI = (XL1-XL) * DENOMI
            KSIMU = KSI
         ELSE IF (M .EQ. 2) THEN
            KSI = LOG(XL1/XL) * DENOMI
            KSIMU = KSI*KSI
         ELSE
            KSI = (XL1**(2-M)-XL**(2-M)) / (2-M) * DENOMI
            IF (M .EQ. 0) THEN
               KSIMU = 1.0
            ELSE
               KSIMU = KSI**MU
            ENDIF
         ENDIF
         ZETA = 0.5*(XL1*XL1-XL*XL) * DENOMI
         IF (SING) THEN
            ZETAMU = ZETA
            DENPHI = 1/(XL1*XL1-XL*XL)
            PHIL = (XL1*XL1-KSI*KSI)*DENPHI
            PHILX = -2*KSI*DENPHI
         ELSE
            ZETAMU = 1.0
            IF (M .EQ. 1) THEN
               PHIL = LOG(XL1/KSI) * DENOMI
               PHILX = -1/KSI * DENOMI
            ELSE IF (M .EQ. 0) THEN
               PHIL = (XL1 - KSI) * DENOMI
               PHILX = -DENOMI
            ELSE
               PHIL = (XL1**(1-M) - KSI**(1-M)) / (1-M) * DENOMI
               PHILX = -KSI**(-M) * DENOMI
            ENDIF
         ENDIF

C Compute U and Ux in evaluation point
         DO 110 J = 1, NPDE
            UKSI(J)  = Y(J,L)*PHIL  + Y(J,L+1)*(1-PHIL)
            UXKSI(J) = Y(J,L)*PHILX + Y(J,L+1)*(-PHILX)
  110    CONTINUE
C Get C, Q and R in evaluation point
         CALL SPDEF (T, KSI, NPDE, UKSI, UXKSI, CC, QC, RC, IRES)
         IF (IRES .EQ. 3) RETURN

         FSCL = (ZETA- XL**(M+1))/(M+1)
         FSC1 = (XL1**(M+1)-ZETA)/(M+1)
         DO 120 J = 1, NPDE
            SCLMQ  = 0.0
            SCL1MQ = 0.0
            DO 130 IP = 1, NPDE
               UXL  = (Y(IP,L+1)-Y(IP,L-1))/(Y(NPDE1,L+1)-Y(NPDE1,L-1))
               UXL1 = (Y(IP,L+2)-Y(IP,L  ))/(Y(NPDE1,L+2)-Y(NPDE1,L  ))
               SCLMQ  = SCLMQ  +
     +                  CC(J,IP)*(YDOT(IP,L  )-UXL *YDOT(NPDE1,L  ))
               SCL1MQ = SCL1MQ +
     +                  CC(J,IP)*(YDOT(IP,L+1)-UXL1*YDOT(NPDE1,L+1))
  130       CONTINUE
C Add contribution over l_th interval to residual equation in X_l
            AYDOT(J,L) = AYDOT(J,L) + FSCL * SCLMQ
            G    (J,L) = G    (J,L) + ZETAMU*KSIMU*RC(J) - FSCL*QC(J)
C Store contribution from l_th interval to residual equation in X_l+1
            AYDOT(J,L+1) = FSC1 * SCL1MQ
            G    (J,L+1) = -ZETAMU*KSIMU*RC(J) - FSC1*QC(J)
  120    CONTINUE
  100 CONTINUE

      L = NC
C
C Add contribution over N_th interval to residual equation in X_N.
C Compute right boundary equation.
C
         XL  = XL1
         XL1 = Y(NPDE1,L+1)
         IF (M .EQ. 1) THEN
            DENOMI = 1/LOG(XL1/XL)
         ELSE
            DENOMI = (1-M)/(XL1**(1-M) - XL**(1-M))
         ENDIF
         IF (SING) THEN
            KSI = 2/3. * (XL1**3-XL**3) / (XL1**2-XL**2)
            KSIMU = 1/KSI
         ELSE IF (M .EQ. 1) THEN
            KSI = (XL1-XL) * DENOMI
            KSIMU = KSI
         ELSE IF (M .EQ. 2) THEN
            KSI = LOG(XL1/XL) * DENOMI
            KSIMU = KSI*KSI
         ELSE
            KSI = (XL1**(2-M)-XL**(2-M)) / (2-M) * DENOMI
            IF (M .EQ. 0) THEN
               KSIMU = 1.0
            ELSE
               KSIMU = KSI**MU
            ENDIF
         ENDIF
         ZETA = 0.5*(XL1*XL1-XL*XL) * DENOMI
         IF (SING) THEN
            ZETAMU = ZETA
            DENPHI = 1/(XL1*XL1-XL*XL)
            PHIL = (XL1*XL1-KSI*KSI)*DENPHI
            PHILX = -2*KSI*DENPHI
         ELSE
            ZETAMU = 1.0
            IF (M .EQ. 1) THEN
               PHIL = LOG(XL1/KSI) * DENOMI
               PHILX = -1/KSI * DENOMI
            ELSE IF (M .EQ. 0) THEN
               PHIL = (XL1 - KSI) * DENOMI
               PHILX = -DENOMI
            ELSE
               PHIL = (XL1**(1-M) - KSI**(1-M)) / (1-M) * DENOMI
               PHILX = -KSI**(-M) * DENOMI
            ENDIF
         ENDIF
         IF (M .EQ. 0) THEN
            XN1M = 1.0
         ELSE
            XN1M = XL1**M
         ENDIF

C Get right boundary function values
         DO 205 J = 1, NPDE
            UXKSI(J) = (Y(J,NC+1)-Y(J,NC)) / (XL1-XL)
  205    CONTINUE
         CALL BNDR (T, BETA, GAMMA, Y(1,NC+1), UXKSI,
     +              NPDE, .FALSE., IRES)
         IF (IRES .EQ. 3) RETURN

C Compute U and Ux in evaluation point
         DO 210 J = 1, NPDE
            UKSI(J)  = Y(J,L)*PHIL  + Y(J,L+1)*(1-PHIL)
            UXKSI(J) = Y(J,L)*PHILX + Y(J,L+1)*(-PHILX)
  210    CONTINUE
C Get C, Q and R in evaluation point
         CALL SPDEF (T, KSI, NPDE, UKSI, UXKSI, CC, QC, RC, IRES)
         IF (IRES .EQ. 3) RETURN

         FSCL = (ZETA- XL**(M+1))/(M+1)
         FSC1 = (XL1**(M+1)-ZETA)/(M+1)
         DO 220 J = 1, NPDE
            SCLMQ  = 0.0
            SCL1MQ = 0.0
            DO 230 IP = 1, NPDE
               UXL  = (Y(IP,L+1)-Y(IP,L-1))/(Y(NPDE1,L+1)-Y(NPDE1,L-1))
               SCLMQ  = SCLMQ  +
     +                  CC(J,IP)*(YDOT(IP,L  )-UXL *YDOT(NPDE1,L  ))
               SCL1MQ = SCL1MQ +
     +                  CC(J,IP)*(YDOT(IP,L+1))
  230       CONTINUE
C Add contribution over N_th interval to residual equation in X_N
            AYDOT(J,L) = AYDOT(J,L) + FSCL * SCLMQ
            G    (J,L) = G    (J,L) + ZETAMU*KSIMU*RC(J) - FSCL*QC(J)
C Compute flux in x_R and substitute in user's boundary condition
            RCJDOT = FSC1 * SCL1MQ / XN1M
            RCJG   = (ZETAMU*KSIMU*RC(J) + FSC1*QC(J)) / XN1M
            AYDOT(J,NC+1) = -BETA(J)*RCJDOT
            G    (J,NC+1) = BETA(J)*RCJG - GAMMA(J)
  220    CONTINUE

      RETURN
      END
      SUBROUTINE CWRESX (T, Y, YDOT, NPDE1, NC, AYDOT, G, IRES)
C
C-----------------------------------------------------------------------
C Purpose:
C -------
C Define grid part of DAE system in general form, i.e. A.ydot and g
C separated to satisfy both SPRINT and DASSL.
C The equations for the moving grid are
C              .                  .
C   nt   + tau.nt        nt + tau.nt
C     i-1        i-1       i        i
C   ----------------  -  ------------  =  0       1 <= i <= N,
C         M                   M
C          i-1                 i
C
C with nt  = n - fac.(n   - 2.n + n   );  fac = rkappa.(rkappa+1)  and
C        i    i        i+1     i   i-1
C
C       n  = 1 / (X   - X ),   n   = n , n    = n .
C        i         i+1   i      -1    0    N+1   N
C
C For simplicity reasons x  and x  are also part of the DAE vector; since
C                         L      R
C the boundaries are fixed we have used as ODEs for these variables
C   .    .
C   X  = X    = 0.
C    0    N+1
C
C Parameters:
C ----------
      INTEGER NPDE1, NC, IRES
      REAL T
      REAL Y(NPDE1,0:NC+1), YDOT(NPDE1,0:NC+1),
     +     AYDOT(NPDE1,0:NC+1), G(NPDE1,0:NC+1)
C
C T      Entry: evaluation time
C Y      Entry: solution and grid at time T.
C        (Y(1:NPDE,L): U_l, Y(NPDE+1,L): X_l)
C YDOT   Entry: derivative of Y at T.
C NPDE1  Entry: # PDEs + 1.
C NC     Entry: # internal grid points.
C AYDOT  Exit: A.ydot part of the residual.
C G      Exit: g part of the residual.
C IRES   Exit:  not used.
C
C-----------------------------------------------------------------------
C
      REAL TAU, RKAPPA, ALFA
      COMMON /METPAR/ TAU, RKAPPA, ALFA
      SAVE   /METPAR/
C
C-----------------------------------------------------------------------
C
      INTEGER I, NPDE
      REAL A0, AM, FAC, G0, GM, NIM1, NI, NIP1, NTI, NTDI
C
      NPDE = NPDE1-1
C
C ccc Define smoothing factor
      FAC = RKAPPA*(RKAPPA+1)
C
C ccc Compute monitor values; store M(I) temp. in G(NPDE1,I), I=0, NC
      CALL XMNTR (Y, G, NPDE, NC)
C
C ccc Compute A.xdot and g for grid equations.
C   Interior equations:
C     A.xdot (I) = TAU/M(I-1).NTDOT(I-1) - TAU/M(I).NTDOT(I)
C     g(I)       = NT(I)/M(I) - NT(I-1)/M(I-1)
C     NT(I) = N(I) - FAC.(N(I-1)-2.N(I)+N(I+1))
C     N (I) = 1 / (X(I+1)-X(I))
      I = 0
         NI   = 1/(Y(NPDE1,I+1)-Y(NPDE1,I  ))
         NIM1 = NI
         NIP1 = 1/(Y(NPDE1,I+2)-Y(NPDE1,I+1))

         NTI  = NI - FAC*(NIM1-2*NI+NIP1)
         NTDI = -
     +          (1+  FAC)*NI  *NI  *(YDOT(NPDE1,I+1)-YDOT(NPDE1,I  )) +
     +               FAC *NIP1*NIP1*(YDOT(NPDE1,I+2)-YDOT(NPDE1,I+1))

         A0 = TAU / G(NPDE1,I) * NTDI
         G0 = NTI / G(NPDE1,I)

      DO 10 I = 1, NC-1
         NIM1 = NI
         NI   = NIP1
         AM   = A0
         GM   = G0

         NIP1 = 1/(Y(NPDE1,I+2)-Y(NPDE1,I+1))

         NTI  = NI - FAC*(NIM1-2*NI+NIP1)
         NTDI =      FAC *NIM1*NIM1*(YDOT(NPDE1,I  )-YDOT(NPDE1,I-1)) -
     +          (1+2*FAC)*NI  *NI  *(YDOT(NPDE1,I+1)-YDOT(NPDE1,I  )) +
     +               FAC *NIP1*NIP1*(YDOT(NPDE1,I+2)-YDOT(NPDE1,I+1))

         A0 = TAU / G(NPDE1,I) * NTDI
         G0 = NTI / G(NPDE1,I)

         AYDOT(NPDE1,I) = AM - A0
         G    (NPDE1,I) = G0 - GM
   10 CONTINUE
      I = NC
         NIM1 = NI
         NI   = NIP1
         AM   = A0
         GM   = G0

         NIP1 = NI

         NTI  = NI - FAC*(NIM1-2*NI+NIP1)
         NTDI =      FAC *NIM1*NIM1*(YDOT(NPDE1,I  )-YDOT(NPDE1,I-1)) -
     +          (1+  FAC)*NI  *NI  *(YDOT(NPDE1,I+1)-YDOT(NPDE1,I  ))

         A0 = TAU / G(NPDE1,I) * NTDI
         G0 = NTI / G(NPDE1,I)

         AYDOT(NPDE1,I) = AM - A0
         G    (NPDE1,I) = G0 - GM

C   Boundary equations grid.
C      Fixed endpoints, xdot=0
      I=0
         AYDOT(NPDE1,I) = YDOT(NPDE1,I)
         G(NPDE1,I) = 0.0
      I=NC+1
         AYDOT(NPDE1,I) = YDOT(NPDE1,I)
         G(NPDE1,I) = 0.0
C
      RETURN
      END
      SUBROUTINE XMNTR (Y, G, NPDE, N)
      INTEGER NPDE, N
      REAL Y(NPDE+1,0:N+1), G(NPDE+1,0:N+1)
C
C-----------------------------------------------------------------------
C Purpose:
C -------
C Compute monitor for grid equation,
C   M_i = M(x(i+1/2)) = sqrt(alfa + !!ux!!**2)
C
C Exit:
C   G(NPDE+1,i) = M(i)
C
C-----------------------------------------------------------------------
C
      REAL TAU, RKAPPA, ALFA
      COMMON /METPAR/ TAU, RKAPPA, ALFA
      SAVE   /METPAR/
C
C-----------------------------------------------------------------------
C
      INTEGER I, K, NPDE1
      REAL DU, DX, SUX2
C
      NPDE1 = NPDE+1

      DO 10 I = 0, N
         SUX2 = 0.0
         DO 20 K = 1, NPDE
            DU = Y(K,I+1)-Y(K,I)
            SUX2 = SUX2 + DU*DU
   20    CONTINUE
         DX = Y(NPDE1,I+1)-Y(NPDE1,I)
         SUX2 = SUX2 / (DX*DX)
         G(NPDE1,I) = SQRT(ALFA + SUX2/NPDE)
   10 CONTINUE

      RETURN
      END
C
C#######################################################################
C
C MACHAR : MACHAR routine from W.J. Cody
C          (available from Netlib: send machar from elefunt)
C
C#######################################################################
C
      SUBROUTINE MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1                   MAXEXP,EPS,EPSNEG,XMIN,XMAX)
C-----------------------------------------------------------------------
C  This Fortran 77 subroutine is intended to determine the parameters
C   of the floating-point arithmetic system specified below.  The
C   determination of the first three uses an extension of an algorithm
C   due to M. Malcolm, CACM 15 (1972), pp. 949-951, incorporating some,
C   but not all, of the improvements suggested by M. Gentleman and S.
C   Marovich, CACM 17 (1974), pp. 276-277.  An earlier version of this
C   program was published in the book Software Manual for the
C   Elementary Functions by W. J. Cody and W. Waite, Prentice-Hall,
C   Englewood Cliffs, NJ, 1980.  The present version is documented in
C   W. J. Cody, "MACHAR: A subroutine to dynamically determine machine
C   parameters," TOMS 14, December, 1988.
C
C  The program as given here must be modified before compiling.  If
C   a single (double) precision version is desired, change all
C   occurrences of CS (CD) in columns 1 and 2 to blanks.
C
C  Parameter values reported are as follows:
C
C       IBETA   - the radix for the floating-point representation
C       IT      - the number of base IBETA digits in the floating-point
C                 significand
C       IRND    - 0 if floating-point addition chops
C                 1 if floating-point addition rounds, but not in the
C                   IEEE style
C                 2 if floating-point addition rounds in the IEEE style
C                 3 if floating-point addition chops, and there is
C                   partial underflow
C                 4 if floating-point addition rounds, but not in the
C                   IEEE style, and there is partial underflow
C                 5 if floating-point addition rounds in the IEEE style,
C                   and there is partial underflow
C       NGRD    - the number of guard digits for multiplication with
C                 truncating arithmetic.  It is
C                 0 if floating-point arithmetic rounds, or if it
C                   truncates and only  IT  base  IBETA digits
C                   participate in the post-normalization shift of the
C                   floating-point significand in multiplication;
C                 1 if floating-point arithmetic truncates and more
C                   than  IT  base  IBETA  digits participate in the
C                   post-normalization shift of the floating-point
C                   significand in multiplication.
C       MACHEP  - the largest negative integer such that
C                 1.0+FLOAT(IBETA)**MACHEP .NE. 1.0, except that
C                 MACHEP is bounded below by  -(IT+3)
C       NEGEPS  - the largest negative integer such that
C                 1.0-FLOAT(IBETA)**NEGEPS .NE. 1.0, except that
C                 NEGEPS is bounded below by  -(IT+3)
C       IEXP    - the number of bits (decimal places if IBETA = 10)
C                 reserved for the representation of the exponent
C                 (including the bias or sign) of a floating-point
C                 number
C       MINEXP  - the largest in magnitude negative integer such that
C                 FLOAT(IBETA)**MINEXP is positive and normalized
C       MAXEXP  - the smallest positive power of  BETA  that overflows
C       EPS     - the smallest positive floating-point number such
C                 that  1.0+EPS .NE. 1.0. In particular, if either
C                 IBETA = 2  or  IRND = 0, EPS = FLOAT(IBETA)**MACHEP.
C                 Otherwise,  EPS = (FLOAT(IBETA)**MACHEP)/2
C       EPSNEG  - A small positive floating-point number such that
C                 1.0-EPSNEG .NE. 1.0. In particular, if IBETA = 2
C                 or  IRND = 0, EPSNEG = FLOAT(IBETA)**NEGEPS.
C                 Otherwise,  EPSNEG = (IBETA**NEGEPS)/2.  Because
C                 NEGEPS is bounded below by -(IT+3), EPSNEG may not
C                 be the smallest number that can alter 1.0 by
C                 subtraction.
C       XMIN    - the smallest non-vanishing normalized floating-point
C                 power of the radix, i.e.,  XMIN = FLOAT(IBETA)**MINEXP
C       XMAX    - the largest finite floating-point number.  In
C                 particular  XMAX = (1.0-EPSNEG)*FLOAT(IBETA)**MAXEXP
C                 Note - on some machines  XMAX  will be only the
C                 second, or perhaps third, largest number, being
C                 too small by 1 or 2 units in the last digit of
C                 the significand.
C
C     Latest revision - December 4, 1987
C
C     Author - W. J. Cody
C              Argonne National Laboratory
C
C-----------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,IRND,IT,ITEMP,IZ,J,K,MACHEP,MAXEXP,
     1        MINEXP,MX,NEGEP,NGRD,NXRES
      REAL
CD    DOUBLE PRECISION
     1   A,B,BETA,BETAIN,BETAH,CONV,EPS,EPSNEG,ONE,T,TEMP,TEMPA,
     2   TEMP1,TWO,XMAX,XMIN,Y,Z,ZERO
C-----------------------------------------------------------------------
      CONV(I) = REAL(I)
CD    CONV(I) = DBLE(I)
      ONE = CONV(1)
      TWO = ONE + ONE
      ZERO = ONE - ONE
C-----------------------------------------------------------------------
C  Determine IBETA, BETA ala Malcolm.
C-----------------------------------------------------------------------
      A = ONE
   10 A = A + A
         TEMP = A+ONE
         TEMP1 = TEMP-A
         IF (TEMP1-ONE .EQ. ZERO) GO TO 10
      B = ONE
   20 B = B + B
         TEMP = A+B
         ITEMP = INT(TEMP-A)
         IF (ITEMP .EQ. 0) GO TO 20
      IBETA = ITEMP
      BETA = CONV(IBETA)
C-----------------------------------------------------------------------
C  Determine IT, IRND.
C-----------------------------------------------------------------------
      IT = 0
      B = ONE
  100 IT = IT + 1
         B = B * BETA
         TEMP = B+ONE
         TEMP1 = TEMP-B
         IF (TEMP1-ONE .EQ. ZERO) GO TO 100
      IRND = 0
      BETAH = BETA / TWO
      TEMP = A+BETAH
      IF (TEMP-A .NE. ZERO) IRND = 1
      TEMPA = A + BETA
      TEMP = TEMPA+BETAH
      IF ((IRND .EQ. 0) .AND. (TEMP-TEMPA .NE. ZERO)) IRND = 2
C-----------------------------------------------------------------------
C  Determine NEGEP, EPSNEG.
C-----------------------------------------------------------------------
      NEGEP = IT + 3
      BETAIN = ONE / BETA
      A = ONE
      DO 200 I = 1, NEGEP
         A = A * BETAIN
  200 CONTINUE
      B = A
  210 TEMP = ONE-A
         IF (TEMP-ONE .NE. ZERO) GO TO 220
         A = A * BETA
         NEGEP = NEGEP - 1
      GO TO 210
  220 NEGEP = -NEGEP
      EPSNEG = A
C-----------------------------------------------------------------------
C  Determine MACHEP, EPS.
C-----------------------------------------------------------------------
      MACHEP = -IT - 3
      A = B
  300 TEMP = ONE+A
         IF (TEMP-ONE .NE. ZERO) GO TO 320
         A = A * BETA
         MACHEP = MACHEP + 1
      GO TO 300
  320 EPS = A
C-----------------------------------------------------------------------
C  Determine NGRD.
C-----------------------------------------------------------------------
      NGRD = 0
      TEMP = ONE+EPS
      IF ((IRND .EQ. 0) .AND. (TEMP*ONE-ONE .NE. ZERO)) NGRD = 1
C-----------------------------------------------------------------------
C  Determine IEXP, MINEXP, XMIN.
C
C  Loop to determine largest I and K = 2**I such that
C         (1/BETA) ** (2**(I))
C  does not underflow.
C  Exit from loop is signaled by an underflow.
C-----------------------------------------------------------------------
      I = 0
      K = 1
      Z = BETAIN
      T = ONE + EPS
      NXRES = 0
  400 Y = Z
         Z = Y * Y
C-----------------------------------------------------------------------
C  Check for underflow here.
C-----------------------------------------------------------------------
         A = Z * ONE
         TEMP = Z * T
         IF ((A+A .EQ. ZERO) .OR. (ABS(Z) .GE. Y)) GO TO 410
         TEMP1 = TEMP * BETAIN
         IF (TEMP1*BETA .EQ. Z) GO TO 410
         I = I + 1
         K = K + K
      GO TO 400
  410 IF (IBETA .EQ. 10) GO TO 420
      IEXP = I + 1
      MX = K + K
      GO TO 450
C-----------------------------------------------------------------------
C  This segment is for decimal machines only.
C-----------------------------------------------------------------------
  420 IEXP = 2
      IZ = IBETA
  430 IF (K .LT. IZ) GO TO 440
         IZ = IZ * IBETA
         IEXP = IEXP + 1
      GO TO 430
  440 MX = IZ + IZ - 1
C-----------------------------------------------------------------------
C  Loop to determine MINEXP, XMIN.
C  Exit from loop is signaled by an underflow.
C-----------------------------------------------------------------------
  450 XMIN = Y
         Y = Y * BETAIN
C-----------------------------------------------------------------------
C  Check for underflow here.
C-----------------------------------------------------------------------
         A = Y * ONE
         TEMP = Y * T
         IF (((A+A) .EQ. ZERO) .OR. (ABS(Y) .GE. XMIN)) GO TO 460
         K = K + 1
         TEMP1 = TEMP * BETAIN
         IF ((TEMP1*BETA .NE. Y) .OR. (TEMP .EQ. Y)) THEN
               GO TO 450
            ELSE
               NXRES = 3
               XMIN = Y
         END IF
  460 MINEXP = -K
C-----------------------------------------------------------------------
C  Determine MAXEXP, XMAX.
C-----------------------------------------------------------------------
      IF ((MX .GT. K+K-3) .OR. (IBETA .EQ. 10)) GO TO 500
      MX = MX + MX
      IEXP = IEXP + 1
  500 MAXEXP = MX + MINEXP
C-----------------------------------------------------------------
C  Adjust IRND to reflect partial underflow.
C-----------------------------------------------------------------
      IRND = IRND + NXRES
C-----------------------------------------------------------------
C  Adjust for IEEE-style machines.
C-----------------------------------------------------------------
      IF (IRND .GE. 2) MAXEXP = MAXEXP - 2
C-----------------------------------------------------------------
C  Adjust for machines with implicit leading bit in binary
C  significand, and machines with radix point at extreme
C  right of significand.
C-----------------------------------------------------------------
      I = MAXEXP + MINEXP
      IF ((IBETA .EQ. 2) .AND. (I .EQ. 0)) MAXEXP = MAXEXP - 1
      IF (I .GT. 20) MAXEXP = MAXEXP - 1
      IF (A .NE. Y) MAXEXP = MAXEXP - 2
      XMAX = ONE - EPSNEG
      IF (XMAX*ONE .NE. XMAX) XMAX = ONE - BETA * EPSNEG
      XMAX = XMAX / (BETA * BETA * BETA * XMIN)
      I = MAXEXP + MINEXP + 3
      IF (I .LE. 0) GO TO 520
      DO 510 J = 1, I
          IF (IBETA .EQ. 2) XMAX = XMAX + XMAX
          IF (IBETA .NE. 2) XMAX = XMAX * BETA
  510 CONTINUE
  520 RETURN
C---------- LAST CARD OF MACHAR ----------
      END
C
C#######################################################################
C
C Next three files contain sources used to solve the resulting DAE
C    system with DASSL.
C
C#######################################################################
C
C#######################################################################
C
C SDASSL : DASSL DAE integrator from L.R. Petzold
C          (available from Netlib: send sdassl from ode)
C
C#######################################################################
C
      SUBROUTINE SDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL,
     +   IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC)
C***BEGIN PROLOGUE  SDASSL
C***PURPOSE  This code solves a system of differential/algebraic
C            equations of the form G(T,Y,YPRIME) = 0.
C***LIBRARY   SLATEC (DASSL)
C***CATEGORY  I1A2
C***TYPE      SINGLE PRECISION (SDASSL-S, DDASSL-D)
C***KEYWORDS  DIFFERENTIAL/ALGEBRAIC, BACKWARD DIFFERENTIATION FORMULAS,
C             IMPLICIT DIFFERENTIAL SYSTEMS
C***AUTHOR  PETZOLD, LINDA R., (LLNL)
C             COMPUTING AND MATHEMATICS RESEARCH DIVISION
C             LAWRENCE LIVERMORE NATIONAL LABORATORY
C             L - 316, P.O. BOX 808,
C             LIVERMORE, CA.    94550
C***DESCRIPTION
C
C *Usage:
C
C      EXTERNAL RES, JAC
C      INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR
C      REAL T, Y(NEQ), YPRIME(NEQ), TOUT, RTOL, ATOL,
C     *   RWORK(LRW), RPAR
C
C      CALL SDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL,
C     *   IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC)
C
C
C *Arguments:
C
C  RES:EXT     This is a subroutine which you provide to define the
C              differential/algebraic system.
C
C  NEQ:IN      This is the number of equations to be solved.
C
C  T:INOUT     This is the current value of the independent variable.
C
C  Y(*):INOUT  This array contains the solution components at T.
C
C  YPRIME(*):INOUT  This array contains the derivatives of the solution
C              components at T.
C
C  TOUT:IN     This is a point at which a solution is desired.
C
C  INFO(N):IN  The basic task of the code is to solve the system from T
C              to TOUT and return an answer at TOUT.  INFO is an integer
C              array which is used to communicate exactly how you want
C              this task to be carried out.  (See below for details.)
C              N must be greater than or equal to 15.
C
C  RTOL,ATOL:INOUT  These quantities represent relative and absolute
C              error tolerances which you provide to indicate how
C              accurately you wish the solution to be computed.  You
C              may choose them to be both scalars or else both vectors.
C              Caution:  In Fortran 77, a scalar is not the same as an
C                        array of length 1.  Some compilers may object
C                        to using scalars for RTOL,ATOL.
C
C  IDID:OUT    This scalar quantity is an indicator reporting what the
C              code did.  You must monitor this integer variable to
C              decide  what action to take next.
C
C  RWORK:WORK  A real work array of length LRW which provides the
C              code with needed storage space.
C
C  LRW:IN      The length of RWORK.  (See below for required length.)
C
C  IWORK:WORK  An integer work array of length LIW which probides the
C              code with needed storage space.
C
C  LIW:IN      The length of IWORK.  (See below for required length.)
C
C  RPAR,IPAR:IN  These are real and integer parameter arrays which
C              you can use for communication between your calling
C              program and the RES subroutine (and the JAC subroutine)
C
C  JAC:EXT     This is the name of a subroutine which you may choose
C              to provide for defining a matrix of partial derivatives
C              described below.
C
C  Quantities which may be altered by SDASSL are:
C     T, Y(*), YPRIME(*), INFO(1), RTOL, ATOL,
C     IDID, RWORK(*) AND IWORK(*)
C
C *Description
C
C  Subroutine SDASSL uses the backward differentiation formulas of
C  orders one through five to solve a system of the above form for Y and
C  YPRIME.  Values for Y and YPRIME at the initial time must be given as
C  input.  These values must be consistent, (that is, if T,Y,YPRIME are
C  the given initial values, they must satisfy G(T,Y,YPRIME) = 0.).  The
C  subroutine solves the system from T to TOUT.  It is easy to continue
C  the solution to get results at additional TOUT.  This is the interval
C  mode of operation.  Intermediate results can also be obtained easily
C  by using the intermediate-output capability.
C
C  The following detailed description is divided into subsections:
C    1. Input required for the first call to SDASSL.
C    2. Output after any return from SDASSL.
C    3. What to do to continue the integration.
C    4. Error messages.
C
C
C  -------- INPUT -- WHAT TO DO ON THE FIRST CALL TO SDASSL ------------
C
C  The first call of the code is defined to be the start of each new
C  problem. Read through the descriptions of all the following items,
C  provide sufficient storage space for designated arrays, set
C  appropriate variables for the initialization of the problem, and
C  give information about how you want the problem to be solved.
C
C
C  RES -- Provide a subroutine of the form
C             SUBROUTINE RES(T,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
C         to define the system of differential/algebraic
C         equations which is to be solved. For the given values
C         of T,Y and YPRIME, the subroutine should
C         return the residual of the defferential/algebraic
C         system
C             DELTA = G(T,Y,YPRIME)
C         (DELTA(*) is a vector of length NEQ which is
C         output for RES.)
C
C         Subroutine RES must not alter T,Y or YPRIME.
C         You must declare the name RES in an external
C         statement in your program that calls SDASSL.
C         You must dimension Y,YPRIME and DELTA in RES.
C
C         IRES is an integer flag which is always equal to
C         zero on input. Subroutine RES should alter IRES
C         only if it encounters an illegal value of Y or
C         a stop condition. Set IRES = -1 if an input value
C         is illegal, and SDASSL will try to solve the problem
C         without getting IRES = -1. If IRES = -2, SDASSL
C         will return control to the calling program
C         with IDID = -11.
C
C         RPAR and IPAR are real and integer parameter arrays which
C         you can use for communication between your calling program
C         and subroutine RES. They are not altered by SDASSL. If you
C         do not need RPAR or IPAR, ignore these parameters by treat-
C         ing them as dummy arguments. If you do choose to use them,
C         dimension them in your calling program and in RES as arrays
C         of appropriate length.
C
C  NEQ -- Set it to the number of differential equations.
C         (NEQ .GE. 1)
C
C  T -- Set it to the initial point of the integration.
C         T must be defined as a variable.
C
C  Y(*) -- Set this vector to the initial values of the NEQ solution
C         components at the initial point. You must dimension Y of
C         length at least NEQ in your calling program.
C
C  YPRIME(*) -- Set this vector to the initial values of the NEQ
C         first derivatives of the solution components at the initial
C         point.  You must dimension YPRIME at least NEQ in your
C         calling program. If you do not know initial values of some
C         of the solution components, see the explanation of INFO(11).
C
C  TOUT -- Set it to the first point at which a solution
C         is desired. You can not take TOUT = T.
C         integration either forward in T (TOUT .GT. T) or
C         backward in T (TOUT .LT. T) is permitted.
C
C         The code advances the solution from T to TOUT using
C         step sizes which are automatically selected so as to
C         achieve the desired accuracy. If you wish, the code will
C         return with the solution and its derivative at
C         intermediate steps (intermediate-output mode) so that
C         you can monitor them, but you still must provide TOUT in
C         accord with the basic aim of the code.
C
C         The first step taken by the code is a critical one
C         because it must reflect how fast the solution changes near
C         the initial point. The code automatically selects an
C         initial step size which is practically always suitable for
C         the problem. By using the fact that the code will not step
C         past TOUT in the first step, you could, if necessary,
C         restrict the length of the initial step size.
C
C         For some problems it may not be permissible to integrate
C         past a point TSTOP because a discontinuity occurs there
C         or the solution or its derivative is not defined beyond
C         TSTOP. When you have declared a TSTOP point (SEE INFO(4)
C         and RWORK(1)), you have told the code not to integrate
C         past TSTOP. In this case any TOUT beyond TSTOP is invalid
C         input.
C
C  INFO(*) -- Use the INFO array to give the code more details about
C         how you want your problem solved.  This array should be
C         dimensioned of length 15, though SDASSL uses only the first
C         eleven entries.  You must respond to all of the following
C         items, which are arranged as questions.  The simplest use
C         of the code corresponds to answering all questions as yes,
C         i.e. setting all entries of INFO to 0.
C
C       INFO(1) - This parameter enables the code to initialize
C              itself. You must set it to indicate the start of every
C              new problem.
C
C          **** Is this the first call for this problem ...
C                Yes - Set INFO(1) = 0
C                 No - Not applicable here.
C                      See below for continuation calls.  ****
C
C       INFO(2) - How much accuracy you want of your solution
C              is specified by the error tolerances RTOL and ATOL.
C              The simplest use is to take them both to be scalars.
C              To obtain more flexibility, they can both be vectors.
C              The code must be told your choice.
C
C          **** Are both error tolerances RTOL, ATOL scalars ...
C                Yes - Set INFO(2) = 0
C                      and input scalars for both RTOL and ATOL
C                 No - Set INFO(2) = 1
C                      and input arrays for both RTOL and ATOL ****
C
C       INFO(3) - The code integrates from T in the direction
C              of TOUT by steps. If you wish, it will return the
C              computed solution and derivative at the next
C              intermediate step (the intermediate-output mode) or
C              TOUT, whichever comes first. This is a good way to
C              proceed if you want to see the behavior of the solution.
C              If you must have solutions at a great many specific
C              TOUT points, this code will compute them efficiently.
C
C          **** Do you want the solution only at
C                TOUT (and not at the next intermediate step) ...
C                 Yes - Set INFO(3) = 0
C                  No - Set INFO(3) = 1 ****
C
C       INFO(4) - To handle solutions at a great many specific
C              values TOUT efficiently, this code may integrate past
C              TOUT and interpolate to obtain the result at TOUT.
C              Sometimes it is not possible to integrate beyond some
C              point TSTOP because the equation changes there or it is
C              not defined past TSTOP. Then you must tell the code
C              not to go past.
C
C           **** Can the integration be carried out without any
C                restrictions on the independent variable T ...
C                 Yes - Set INFO(4)=0
C                  No - Set INFO(4)=1
C                       and define the stopping point TSTOP by
C                       setting RWORK(1)=TSTOP ****
C
C       INFO(5) - To solve differential/algebraic problems it is
C              necessary to use a matrix of partial derivatives of the
C              system of differential equations. If you do not
C              provide a subroutine to evaluate it analytically (see
C              description of the item JAC in the call list), it will
C              be approximated by numerical differencing in this code.
C              although it is less trouble for you to have the code
C              compute partial derivatives by numerical differencing,
C              the solution will be more reliable if you provide the
C              derivatives via JAC. Sometimes numerical differencing
C              is cheaper than evaluating derivatives in JAC and
C              sometimes it is not - this depends on your problem.
C
C           **** Do you want the code to evaluate the partial
C                derivatives automatically by numerical differences ...
C                   Yes - Set INFO(5)=0
C                    No - Set INFO(5)=1
C                  and provide subroutine JAC for evaluating the
C                  matrix of partial derivatives ****
C
C       INFO(6) - SDASSL will perform much better if the matrix of
C              partial derivatives, DG/DY + CJ*DG/DYPRIME,
C              (here CJ is a scalar determined by SDASSL)
C              is banded and the code is told this. In this
C              case, the storage needed will be greatly reduced,
C              numerical differencing will be performed much cheaper,
C              and a number of important algorithms will execute much
C              faster. The differential equation is said to have
C              half-bandwidths ML (lower) and MU (upper) if equation i
C              involves only unknowns Y(J) with
C                             I-ML .LE. J .LE. I+MU
C              for all I=1,2,...,NEQ. Thus, ML and MU are the widths
C              of the lower and upper parts of the band, respectively,
C              with the main diagonal being excluded. If you do not
C              indicate that the equation has a banded matrix of partial
C              derivatives, the code works with a full matrix of NEQ**2
C              elements (stored in the conventional way). Computations
C              with banded matrices cost less time and storage than with
C              full matrices if 2*ML+MU .LT. NEQ. If you tell the
C              code that the matrix of partial derivatives has a banded
C              structure and you want to provide subroutine JAC to
C              compute the partial derivatives, then you must be careful
C              to store the elements of the matrix in the special form
C              indicated in the description of JAC.
C
C          **** Do you want to solve the problem using a full
C               (dense) matrix (and not a special banded
C               structure) ...
C                Yes - Set INFO(6)=0
C                 No - Set INFO(6)=1
C                       and provide the lower (ML) and upper (MU)
C                       bandwidths by setting
C                       IWORK(1)=ML
C                       IWORK(2)=MU ****
C
C
C        INFO(7) -- You can specify a maximum (absolute value of)
C              stepsize, so that the code
C              will avoid passing over very
C              large regions.
C
C          ****  Do you want the code to decide
C                on its own maximum stepsize?
C                Yes - Set INFO(7)=0
C                 No - Set INFO(7)=1
C                      and define HMAX by setting
C                      RWORK(2)=HMAX ****
C
C        INFO(8) -- Differential/algebraic problems
C              may occaisionally suffer from
C              severe scaling difficulties on the
C              first step. If you know a great deal
C              about the scaling of your problem, you can
C              help to alleviate this problem by
C              specifying an initial stepsize HO.
C
C          ****  Do you want the code to define
C                its own initial stepsize?
C                Yes - Set INFO(8)=0
C                 No - Set INFO(8)=1
C                      and define HO by setting
C                      RWORK(3)=HO ****
C
C        INFO(9) -- If storage is a severe problem,
C              you can save some locations by
C              restricting the maximum order MAXORD.
C              the default value is 5. for each
C              order decrease below 5, the code
C              requires NEQ fewer locations, however
C              it is likely to be slower. In any
C              case, you must have 1 .LE. MAXORD .LE. 5
C          ****  Do you want the maximum order to
C                default to 5?
C                Yes - Set INFO(9)=0
C                 No - Set INFO(9)=1
C                      and define MAXORD by setting
C                      IWORK(3)=MAXORD ****
C
C        INFO(10) --If you know that the solutions to your equations
C               will always be nonnegative, it may help to set this
C               parameter. However, it is probably best to
C               try the code without using this option first,
C               and only to use this option if that doesn't
C               work very well.
C           ****  Do you want the code to solve the problem without
C                 invoking any special nonnegativity constraints?
C                  Yes - Set INFO(10)=0
C                   No - Set INFO(10)=1
C
C        INFO(11) --SDASSL normally requires the initial T,
C               Y, and YPRIME to be consistent. That is,
C               you must have G(T,Y,YPRIME) = 0 at the initial
C               time. If you do not know the initial
C               derivative precisely, you can let SDASSL try
C               to compute it.
C          ****   Are the initialHE INITIAL T, Y, YPRIME consistent?
C                 Yes - Set INFO(11) = 0
C                  No - Set INFO(11) = 1,
C                       and set YPRIME to an initial approximation
C                       to YPRIME.  (If you have no idea what
C                       YPRIME should be, set it to zero. Note
C                       that the initial Y should be such
C                       that there must exist a YPRIME so that
C                       G(T,Y,YPRIME) = 0.)
C
C  RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL
C         error tolerances to tell the code how accurately you
C         want the solution to be computed.  They must be defined
C         as variables because the code may change them.  You
C         have two choices --
C               Both RTOL and ATOL are scalars. (INFO(2)=0)
C               Both RTOL and ATOL are vectors. (INFO(2)=1)
C         in either case all components must be non-negative.
C
C         The tolerances are used by the code in a local error
C         test at each step which requires roughly that
C               ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL
C         for each vector component.
C         (More specifically, a root-mean-square norm is used to
C         measure the size of vectors, and the error test uses the
C         magnitude of the solution at the beginning of the step.)
C
C         The true (global) error is the difference between the
C         true solution of the initial value problem and the
C         computed approximation.  Practically all present day
C         codes, including this one, control the local error at
C         each step and do not even attempt to control the global
C         error directly.
C         Usually, but not always, the true accuracy of the
C         computed Y is comparable to the error tolerances. This
C         code will usually, but not always, deliver a more
C         accurate solution if you reduce the tolerances and
C         integrate again.  By comparing two such solutions you
C         can get a fairly reliable idea of the true error in the
C         solution at the bigger tolerances.
C
C         Setting ATOL=0. results in a pure relative error test on
C         that component.  Setting RTOL=0. results in a pure
C         absolute error test on that component.  A mixed test
C         with non-zero RTOL and ATOL corresponds roughly to a
C         relative error test when the solution component is much
C         bigger than ATOL and to an absolute error test when the
C         solution component is smaller than the threshhold ATOL.
C
C         The code will not attempt to compute a solution at an
C         accuracy unreasonable for the machine being used.  It will
C         advise you if you ask for too much accuracy and inform
C         you as to the maximum accuracy it believes possible.
C
C  RWORK(*) --  Dimension this real work array of length LRW in your
C         calling program.
C
C  LRW -- Set it to the declared length of the RWORK array.
C               You must have
C                    LRW .GE. 40+(MAXORD+4)*NEQ+NEQ**2
C               for the full (dense) JACOBIAN case (when INFO(6)=0), or
C                    LRW .GE. 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ
C               for the banded user-defined JACOBIAN case
C               (when INFO(5)=1 and INFO(6)=1), or
C                     LRW .GE. 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ
C                           +2*(NEQ/(ML+MU+1)+1)
C               for the banded finite-difference-generated JACOBIAN case
C               (when INFO(5)=0 and INFO(6)=1)
C
C  IWORK(*) --  Dimension this integer work array of length LIW in
C         your calling program.
C
C  LIW -- Set it to the declared length of the IWORK array.
C               You must have LIW .GE. 20+NEQ
C
C  RPAR, IPAR -- These are parameter arrays, of real and integer
C         type, respectively.  You can use them for communication
C         between your program that calls SDASSL and the
C         RES subroutine (and the JAC subroutine).  They are not
C         altered by SDASSL.  If you do not need RPAR or IPAR,
C         ignore these parameters by treating them as dummy
C         arguments.  If you do choose to use them, dimension
C         them in your calling program and in RES (and in JAC)
C         as arrays of appropriate length.
C
C  JAC -- If you have set INFO(5)=0, you can ignore this parameter
C         by treating it as a dummy argument.  Otherwise, you must
C         provide a subroutine of the form
C             SUBROUTINE JAC(T,Y,YPRIME,PD,CJ,RPAR,IPAR)
C         to define the matrix of partial derivatives
C             PD=DG/DY+CJ*DG/DYPRIME
C         CJ is a scalar which is input to JAC.
C         For the given values of T,Y,YPRIME, the
C         subroutine must evaluate the non-zero partial
C         derivatives for each equation and each solution
C         component, and store these values in the
C         matrix PD.  The elements of PD are set to zero
C         before each call to JAC so only non-zero elements
C         need to be defined.
C
C         Subroutine JAC must not alter T,Y,(*),YPRIME(*), or CJ.
C         You must declare the name JAC in an EXTERNAL statement in
C         your program that calls SDASSL.  You must dimension Y,
C         YPRIME and PD in JAC.
C
C         The way you must store the elements into the PD matrix
C         depends on the structure of the matrix which you
C         indicated by INFO(6).
C               *** INFO(6)=0 -- Full (dense) matrix ***
C                   Give PD a first dimension of NEQ.
C                   When you evaluate the (non-zero) partial derivative
C                   of equation I with respect to variable J, you must
C                   store it in PD according to
C                   PD(I,J) = "DG(I)/DY(J)+CJ*DG(I)/DYPRIME(J)"
C               *** INFO(6)=1 -- Banded JACOBIAN with ML lower and MU
C                   upper diagonal bands (refer to INFO(6) description
C                   of ML and MU) ***
C                   Give PD a first dimension of 2*ML+MU+1.
C                   when you evaluate the (non-zero) partial derivative
C                   of equation I with respect to variable J, you must
C                   store it in PD according to
C                   IROW = I - J + ML + MU + 1
C                   PD(IROW,J) = "DG(I)/DY(J)+CJ*DG(I)/DYPRIME(J)"
C
C         RPAR and IPAR are real and integer parameter arrays
C         which you can use for communication between your calling
C         program and your JACOBIAN subroutine JAC. They are not
C         altered by SDASSL. If you do not need RPAR or IPAR,
C         ignore these parameters by treating them as dummy
C         arguments. If you do choose to use them, dimension
C         them in your calling program and in JAC as arrays of
C         appropriate length.
C
C
C  OPTIONALLY REPLACEABLE NORM ROUTINE:
C
C     SDASSL uses a weighted norm SDANRM to measure the size
C     of vectors such as the estimated error in each step.
C     A FUNCTION subprogram
C       REAL FUNCTION SDANRM(NEQ,V,WT,RPAR,IPAR)
C       DIMENSION V(NEQ),WT(NEQ)
C     is used to define this norm. Here, V is the vector
C     whose norm is to be computed, and WT is a vector of
C     weights.  A SDANRM routine has been included with SDASSL
C     which computes the weighted root-mean-square norm
C     given by
C       SDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2)
C     this norm is suitable for most problems. In some
C     special cases, it may be more convenient and/or
C     efficient to define your own norm by writing a function
C     subprogram to be called instead of SDANRM. This should,
C     however, be attempted only after careful thought and
C     consideration.
C
C
C  -------- OUTPUT -- AFTER ANY RETURN FROM SDASSL ---------------------
C
C  The principal aim of the code is to return a computed solution at
C  TOUT, although it is also possible to obtain intermediate results
C  along the way. To find out whether the code achieved its goal
C  or if the integration process was interrupted before the task was
C  completed, you must check the IDID parameter.
C
C
C  T -- The solution was successfully advanced to the
C               output value of T.
C
C  Y(*) -- Contains the computed solution approximation at T.
C
C  YPRIME(*) -- Contains the computed derivative
C               approximation at T.
C
C  IDID -- Reports what the code did.
C
C                     *** Task completed ***
C                Reported by positive values of IDID
C
C           IDID = 1 -- A step was successfully taken in the
C                   intermediate-output mode. The code has not
C                   yet reached TOUT.
C
C           IDID = 2 -- The integration to TSTOP was successfully
C                   completed (T=TSTOP) by stepping exactly to TSTOP.
C
C           IDID = 3 -- The integration to TOUT was successfully
C                   completed (T=TOUT) by stepping past TOUT.
C                   Y(*) is obtained by interpolation.
C                   YPRIME(*) is obtained by interpolation.
C
C                    *** Task interrupted ***
C                Reported by negative values of IDID
C
C           IDID = -1 -- A large amount of work has been expended.
C                   (About 500 steps)
C
C           IDID = -2 -- The error tolerances are too stringent.
C
C           IDID = -3 -- The local error test cannot be satisfied
C                   because you specified a zero component in ATOL
C                   and the corresponding computed solution
C                   component is zero. Thus, a pure relative error
C                   test is impossible for this component.
C
C           IDID = -6 -- SDASSL had repeated error test
C                   failures on the last attempted step.
C
C           IDID = -7 -- The corrector could not converge.
C
C           IDID = -8 -- The matrix of partial derivatives
C                   is singular.
C
C           IDID = -9 -- The corrector could not converge.
C                   there were repeated error test failures
C                   in this step.
C
C           IDID =-10 -- The corrector could not converge
C                   because IRES was equal to minus one.
C
C           IDID =-11 -- IRES equal to -2 was encountered
C                   and control is being returned to the
C                   calling program.
C
C           IDID =-12 -- SDASSL failed to compute the initial
C                   YPRIME.
C
C
C
C           IDID = -13,..,-32 -- Not applicable for this code
C
C                    *** Task terminated ***
C                Reported by the value of IDID=-33
C
C           IDID = -33 -- The code has encountered trouble from which
C                   it cannot recover. A message is printed
C                   explaining the trouble and control is returned
C                   to the calling program. For example, this occurs
C                   when invalid input is detected.
C
C  RTOL, ATOL -- These quantities remain unchanged except when
C               IDID = -2. In this case, the error tolerances have been
C               increased by the code to values which are estimated to
C               be appropriate for continuing the integration. However,
C               the reported solution at T was obtained using the input
C               values of RTOL and ATOL.
C
C  RWORK, IWORK -- Contain information which is usually of no
C               interest to the user but necessary for subsequent calls.
C               However, you may find use for
C
C               RWORK(3)--Which contains the step size H to be
C                       attempted on the next step.
C
C               RWORK(4)--Which contains the current value of the
C                       independent variable, i.e., the farthest point
C                       integration has reached. This will be different
C                       from T only when interpolation has been
C                       performed (IDID=3).
C
C               RWORK(7)--Which contains the stepsize used
C                       on the last successful step.
C
C               IWORK(7)--Which contains the order of the method to
C                       be attempted on the next step.
C
C               IWORK(8)--Which contains the order of the method used
C                       on the last step.
C
C               IWORK(11)--Which contains the number of steps taken so
C                        far.
C
C               IWORK(12)--Which contains the number of calls to RES
C                        so far.
C
C               IWORK(13)--Which contains the number of evaluations of
C                        the matrix of partial derivatives needed so
C                        far.
C
C               IWORK(14)--Which contains the total number
C                        of error test failures so far.
C
C               IWORK(15)--Which contains the total number
C                        of convergence test failures so far.
C                        (includes singular iteration matrix
C                        failures.)
C
C
C  -------- INPUT -- WHAT TO DO TO CONTINUE THE INTEGRATION ------------
C                    (CALLS AFTER THE FIRST)
C
C  This code is organized so that subsequent calls to continue the
C  integration involve little (if any) additional effort on your
C  part. You must monitor the IDID parameter in order to determine
C  what to do next.
C
C  Recalling that the principal task of the code is to integrate
C  from T to TOUT (the interval mode), usually all you will need
C  to do is specify a new TOUT upon reaching the current TOUT.
C
C  Do not alter any quantity not specifically permitted below,
C  in particular do not alter NEQ,T,Y(*),YPRIME(*),RWORK(*),IWORK(*)
C  or the differential equation in subroutine RES. Any such
C  alteration constitutes a new problem and must be treated as such,
C  i.e., you must start afresh.
C
C  You cannot change from vector to scalar error control or vice
C  versa (INFO(2)), but you can change the size of the entries of
C  RTOL, ATOL. Increasing a tolerance makes the equation easier
C  to integrate. Decreasing a tolerance will make the equation
C  harder to integrate and should generally be avoided.
C
C  You can switch from the intermediate-output mode to the
C  interval mode (INFO(3)) or vice versa at any time.
C
C  If it has been necessary to prevent the integration from going
C  past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the
C  code will not integrate to any TOUT beyond the currently
C  specified TSTOP. Once TSTOP has been reached you must change
C  the value of TSTOP or set INFO(4)=0. You may change INFO(4)
C  or TSTOP at any time but you must supply the value of TSTOP in
C  RWORK(1) whenever you set INFO(4)=1.
C
C  Do not change INFO(5), INFO(6), IWORK(1), or IWORK(2)
C  unless you are going to restart the code.
C
C                 *** Following a completed task ***
C  If
C     IDID = 1, call the code again to continue the integration
C                  another step in the direction of TOUT.
C
C     IDID = 2 or 3, define a new TOUT and call the code again.
C                  TOUT must be different from T. You cannot change
C                  the direction of integration without restarting.
C
C                 *** Following an interrupted task ***
C               To show the code that you realize the task was
C               interrupted and that you want to continue, you
C               must take appropriate action and set INFO(1) = 1
C  If
C    IDID = -1, The code has taken about 500 steps.
C                  If you want to continue, set INFO(1) = 1 and
C                  call the code again. An additional 500 steps
C                  will be allowed.
C
C    IDID = -2, The error tolerances RTOL, ATOL have been
C                  increased to values the code estimates appropriate
C                  for continuing. You may want to change them
C                  yourself. If you are sure you want to continue
C                  with relaxed error tolerances, set INFO(1)=1 and
C                  call the code again.
C
C    IDID = -3, A solution component is zero and you set the
C                  corresponding component of ATOL to zero. If you
C                  are sure you want to continue, you must first
C                  alter the error criterion to use positive values
C                  for those components of ATOL corresponding to zero
C                  solution components, then set INFO(1)=1 and call
C                  the code again.
C
C    IDID = -4,-5  --- Cannot occur with this code.
C
C    IDID = -6, Repeated error test failures occurred on the
C                  last attempted step in SDASSL. A singularity in the
C                  solution may be present. If you are absolutely
C                  certain you want to continue, you should restart
C                  the integration. (Provide initial values of Y and
C                  YPRIME which are consistent)
C
C    IDID = -7, Repeated convergence test failures occurred
C                  on the last attempted step in SDASSL. An inaccurate
C                  or ill-conditioned JACOBIAN may be the problem. If
C                  you are absolutely certain you want to continue, you
C                  should restart the integration.
C
C    IDID = -8, The matrix of partial derivatives is singular.
C                  Some of your equations may be redundant.
C                  SDASSL cannot solve the problem as stated.
C                  It is possible that the redundant equations
C                  could be removed, and then SDASSL could
C                  solve the problem. It is also possible
C                  that a solution to your problem either
C                  does not exist or is not unique.
C
C    IDID = -9, SDASSL had multiple convergence test
C                  failures, preceeded by multiple error
C                  test failures, on the last attempted step.
C                  It is possible that your problem
C                  is ill-posed, and cannot be solved
C                  using this code. Or, there may be a
C                  discontinuity or a singularity in the
C                  solution. If you are absolutely certain
C                  you want to continue, you should restart
C                  the integration.
C
C    IDID =-10, SDASSL had multiple convergence test failures
C                  because IRES was equal to minus one.
C                  If you are absolutely certain you want
C                  to continue, you should restart the
C                  integration.
C
C    IDID =-11, IRES=-2 was encountered, and control is being
C                  returned to the calling program.
C
C    IDID =-12, SDASSL failed to compute the initial YPRIME.
C                  This could happen because the initial
C                  approximation to YPRIME was not very good, or
C                  if a YPRIME consistent with the initial Y
C                  does not exist. The problem could also be caused
C                  by an inaccurate or singular iteration matrix.
C
C    IDID = -13,..,-32  --- Cannot occur with this code.
C
C
C                 *** Following a terminated task ***
C
C  If IDID= -33, you cannot continue the solution of this problem.
C                  An attempt to do so will result in your
C                  run being terminated.
C
C
C  -------- ERROR MESSAGES ---------------------------------------------
C
C      The SLATEC error print routine XERMSG is called in the event of
C   unsuccessful completion of a task.  Most of these are treated as
C   "recoverable errors", which means that (unless the user has directed
C   otherwise) control will be returned to the calling program for
C   possible action after the message has been printed.
C
C   In the event of a negative value of IDID other than -33, an appro-
C   priate message is printed and the "error number" printed by XERMSG
C   is the value of IDID.  There are quite a number of illegal input
C   errors that can lead to a returned value IDID=-33.  The conditions
C   and their printed "error numbers" are as follows:
C
C   Error number       Condition
C
C        1       Some element of INFO vector is not zero or one.
C        2       NEQ .le. 0
C        3       MAXORD not in range.
C        4       LRW is less than the required length for RWORK.
C        5       LIW is less than the required length for IWORK.
C        6       Some element of RTOL is .lt. 0
C        7       Some element of ATOL is .lt. 0
C        8       All elements of RTOL and ATOL are zero.
C        9       INFO(4)=1 and TSTOP is behind TOUT.
C       10       HMAX .lt. 0.0
C       11       TOUT is behind T.
C       12       INFO(8)=1 and H0=0.0
C       13       Some element of WT is .le. 0.0
C       14       TOUT is too close to T to start integration.
C       15       INFO(4)=1 and TSTOP is behind T.
C       16       --( Not used in this version )--
C       17       ML illegal.  Either .lt. 0 or .gt. NEQ
C       18       MU illegal.  Either .lt. 0 or .gt. NEQ
C       19       TOUT = T.
C
C   If SDASSL is called again without any action taken to remove the
C   cause of an unsuccessful return, XERMSG will be called with a fatal
C   error flag, which will cause unconditional termination of the
C   program.  There are two such fatal errors:
C
C   Error number -998:  The last step was terminated with a negative
C       value of IDID other than -33, and no appropriate action was
C       taken.
C
C   Error number -999:  The previous call was terminated because of
C       illegal input (IDID=-33) and there is illegal input in the
C       present call, as well.  (Suspect infinite loop.)
C
C  ---------------------------------------------------------------------
C
C***REFERENCES  A DESCRIPTION OF DASSL: A DIFFERENTIAL/ALGEBRAIC
C                 SYSTEM SOLVER, L. R. PETZOLD, SAND82-8637,
C                 SANDIA NATIONAL LABORATORIES, SEPTEMBER 1982.
C***ROUTINES CALLED  R1MACH, SDAINI, SDANRM, SDASTP, SDATRP, SDAWTS,
C                    XERMSG
C***REVISION HISTORY  (YYMMDD)
C   830315  DATE WRITTEN
C   880387  Code changes made.  All common statements have been
C           replaced by a DATA statement, which defines pointers into
C           RWORK, and PARAMETER statements which define pointers
C           into IWORK.  As well the documentation has gone through
C           grammatical changes.
C   881005  The prologue has been changed to mixed case.
C           The subordinate routines had revision dates changed to
C           this date, although the documentation for these routines
C           is all upper case.  No code changes.
C   890511  Code changes made.  The DATA statement in the declaration
C           section of SDASSL was replaced with a PARAMETER
C           statement.  Also the statement S = 100.E0 was removed
C           from the top of the Newton iteration in SDASTP.
C           The subordinate routines had revision dates changed to
C           this date.
C   890517  The revision date syntax was replaced with the revision
C           history syntax.  Also the "DECK" comment was added to
C           the top of all subroutines.  These changes are consistent
C           with new SLATEC guidelines.
C           The subordinate routines had revision dates changed to
C           this date.  No code changes.
C   891013  Code changes made.
C           Removed all occurrances of FLOAT.  All operations
C           are now performed with "mixed-mode" arithmetic.
C           Also, specific function names were replaced with generic
C           function names to be consistent with new SLATEC guidelines.
C           In particular:
C              Replaced AMIN1 with MIN everywhere.
C              Replaced MIN0 with MIN everywhere.
C              Replaced AMAX1 with MAX everywhere.
C              Replaced MAX0 with MAX everywhere.
C           Also replaced REVISION DATE with REVISION HISTORY in all
C           subordinate routines.
C  901004  Miscellaneous changes to prologue to complete conversion
C          to SLATEC 4.0 format.  No code changes.  (F.N.Fritsch)
C  901009  Corrected GAMS classification code and converted subsidiary
C          routines to 4.0 format.  No code changes.  (F.N.Fritsch)
C  901010  Converted XERRWV calls to XERMSG calls.  (R.Clemens,AFWL)
C  901019  Code changes made.
C          Merged SLATEC 4.0 changes with previous changes made
C          by C. Ulrich.  Below is a history of the changes made by
C          C. Ulrich. (Changes in subsidiary routines are implied
C          by this history)
C          891228  Bug was found and repaired inside the SDASSL
C                  and SDAINI routines.  SDAINI was incorrectly
C                  returning the initial T with Y and YPRIME
C                  computed at T+H.  The routine now returns T+H
C                  rather than the initial T.
C                  Cosmetic changes made to SDASTP.
C          900904  Three modifications were made to fix a bug (inside
C                  SDASSL) re interpolation for continuation calls and
C                  cases where TN is very close to TSTOP:
C
C                  1) In testing for whether H is too large, just
C                     compare H to (TSTOP - TN), rather than
C                     (TSTOP - TN) * (1-4*UROUND), and set H to
C                     TSTOP - TN.  This will force SDASTP to step
C                     exactly to TSTOP under certain situations
C                     (i.e. when H returned from SDASTP would otherwise
C                     take TN beyond TSTOP).
C
C                  2) Inside the SDASTP loop, interpolate exactly to
C                     TSTOP if TN is very close to TSTOP (rather than
C                     interpolating to within roundoff of TSTOP).
C
C                  3) Modified IDID description for IDID = 2 to say that
C                     the solution is returned by stepping exactly to
C                     TSTOP, rather than TOUT.  (In some cases the
C                     solution is actually obtained by extrapolating
C                     over a distance near unit roundoff to TSTOP,
C                     but this small distance is deemed acceptable in
C                     these circumstances.)
C   901026  Added explicit declarations for all variables and minor
C           cosmetic changes to prologue, removed unreferenced labels,
C           and improved XERMSG calls.  (FNF)
C   901030  Added ERROR MESSAGES section and reworked other sections to
C           be of more uniform format.  (FNF)
C   910624  Fixed minor bug related to HMAX (five lines ending
C           in label 526).  (LRP)
C
C***END PROLOGUE  SDASSL
C
C**End
C
C     Declare arguments.
C
      INTEGER  NEQ, INFO(15), IDID, LRW, IWORK(*), LIW, IPAR(*)
      REAL  T, Y(*), YPRIME(*), TOUT, RTOL(*), ATOL(*), RWORK(*),
     *   RPAR(*)
      EXTERNAL  RES, JAC
C
C     Declare externals.
C
      EXTERNAL  R1MACH, SDAINI, SDANRM, SDASTP, SDATRP, SDAWTS, XERMSG
      REAL  R1MACH, SDANRM
C
C     Declare local variables.
C
      INTEGER  I, ITEMP, LALPHA, LBETA, LCJ, LCJOLD, LCTF, LDELTA,
     *   LENIW, LENPD, LENRW, LE, LETF, LGAMMA, LH, LHMAX, LHOLD, LIPVT,
     *   LJCALC, LK, LKOLD, LIWM, LML, LMTYPE, LMU, LMXORD, LNJE, LNPD,
     *   LNRE, LNS, LNST, LNSTL, LPD, LPHASE, LPHI, LPSI, LROUND, LS,
     *   LSIGMA, LTN, LTSTOP, LWM, LWT, MBAND, MSAVE, MXORD, NPD, NTEMP,
     *   NZFLG
      REAL  ATOLI, H, HMAX, HMIN, HO, R, RH, RTOLI, TDIST, TN, TNEXT,
     *   TSTOP, UROUND, YPNORM
      LOGICAL  DONE
C       Auxiliary variables for conversion of values to be included in
C       error messages.
      CHARACTER*8  XERN1, XERN2
      CHARACTER*16 XERN3, XERN4
C
C     SET POINTERS INTO IWORK
      PARAMETER (LML=1, LMU=2, LMXORD=3, LMTYPE=4, LNST=11,
     *  LNRE=12, LNJE=13, LETF=14, LCTF=15, LNPD=16,
     *  LIPVT=21, LJCALC=5, LPHASE=6, LK=7, LKOLD=8,
     *  LNS=9, LNSTL=10, LIWM=1)
C
C     SET RELATIVE OFFSET INTO RWORK
      PARAMETER (NPD=1)
C
C     SET POINTERS INTO RWORK
      PARAMETER (LTSTOP=1, LHMAX=2, LH=3, LTN=4,
     *  LCJ=5, LCJOLD=6, LHOLD=7, LS=8, LROUND=9,
     *  LALPHA=11, LBETA=17, LGAMMA=23,
     *  LPSI=29, LSIGMA=35, LDELTA=41)
C
C***FIRST EXECUTABLE STATEMENT  SDASSL
      IF(INFO(1).NE.0)GO TO 100
C
C-----------------------------------------------------------------------
C     THIS BLOCK IS EXECUTED FOR THE INITIAL CALL ONLY.
C     IT CONTAINS CHECKING OF INPUTS AND INITIALIZATIONS.
C-----------------------------------------------------------------------
C
C     FIRST CHECK INFO ARRAY TO MAKE SURE ALL ELEMENTS OF INFO
C     ARE EITHER ZERO OR ONE.
      DO 10 I=2,11
         IF(INFO(I).NE.0.AND.INFO(I).NE.1)GO TO 701
10       CONTINUE
C
      IF(NEQ.LE.0)GO TO 702
C
C     CHECK AND COMPUTE MAXIMUM ORDER
      MXORD=5
      IF(INFO(9).EQ.0)GO TO 20
         MXORD=IWORK(LMXORD)
         IF(MXORD.LT.1.OR.MXORD.GT.5)GO TO 703
20       IWORK(LMXORD)=MXORD
C
C     COMPUTE MTYPE,LENPD,LENRW.CHECK ML AND MU.
      IF(INFO(6).NE.0)GO TO 40
         LENPD=NEQ**2
         LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD
         IF(INFO(5).NE.0)GO TO 30
            IWORK(LMTYPE)=2
            GO TO 60
30          IWORK(LMTYPE)=1
            GO TO 60
40    IF(IWORK(LML).LT.0.OR.IWORK(LML).GE.NEQ)GO TO 717
      IF(IWORK(LMU).LT.0.OR.IWORK(LMU).GE.NEQ)GO TO 718
      LENPD=(2*IWORK(LML)+IWORK(LMU)+1)*NEQ
      IF(INFO(5).NE.0)GO TO 50
         IWORK(LMTYPE)=5
         MBAND=IWORK(LML)+IWORK(LMU)+1
         MSAVE=(NEQ/MBAND)+1
         LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD+2*MSAVE
         GO TO 60
50       IWORK(LMTYPE)=4
         LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD
C
C     CHECK LENGTHS OF RWORK AND IWORK
60    LENIW=20+NEQ
      IWORK(LNPD)=LENPD
      IF(LRW.LT.LENRW)GO TO 704
      IF(LIW.LT.LENIW)GO TO 705
C
C     CHECK TO SEE THAT TOUT IS DIFFERENT FROM T
      IF(TOUT .EQ. T)GO TO 719
C
C     CHECK HMAX
      IF(INFO(7).EQ.0)GO TO 70
         HMAX=RWORK(LHMAX)
         IF(HMAX.LE.0.0E0)GO TO 710
70    CONTINUE
C
C     INITIALIZE COUNTERS
      IWORK(LNST)=0
      IWORK(LNRE)=0
      IWORK(LNJE)=0
C
      IWORK(LNSTL)=0
      IDID=1
      GO TO 200
C
C-----------------------------------------------------------------------
C     THIS BLOCK IS FOR CONTINUATION CALLS
C     ONLY. HERE WE CHECK INFO(1),AND IF THE
C     LAST STEP WAS INTERRUPTED WE CHECK WHETHER
C     APPROPRIATE ACTION WAS TAKEN.
C-----------------------------------------------------------------------
C
100   CONTINUE
      IF(INFO(1).EQ.1)GO TO 110
      IF(INFO(1).NE.-1)GO TO 701
C
C     IF WE ARE HERE, THE LAST STEP WAS INTERRUPTED
C     BY AN ERROR CONDITION FROM SDASTP,AND
C     APPROPRIATE ACTION WAS NOT TAKEN. THIS
C     IS A FATAL ERROR.
      WRITE (XERN1, '(I8)') IDID
      CALL XERMSG ('SLATEC', 'SDASSL',
     *   'THE LAST STEP TERMINATED WITH A NEGATIVE VALUE OF IDID = ' //
     *   XERN1 // ' AND NO APPROPRIATE ACTION WAS TAKEN.  ' //
     *   'RUN TERMINATED', -998, 2)
      RETURN
110   CONTINUE
      IWORK(LNSTL)=IWORK(LNST)
C
C-----------------------------------------------------------------------
C     THIS BLOCK IS EXECUTED ON ALL CALLS.
C     THE ERROR TOLERANCE PARAMETERS ARE
C     CHECKED, AND THE WORK ARRAY POINTERS
C     ARE SET.
C-----------------------------------------------------------------------
C
200   CONTINUE
C     CHECK RTOL,ATOL
      NZFLG=0
      RTOLI=RTOL(1)
      ATOLI=ATOL(1)
      DO 210 I=1,NEQ
         IF(INFO(2).EQ.1)RTOLI=RTOL(I)
         IF(INFO(2).EQ.1)ATOLI=ATOL(I)
         IF(RTOLI.GT.0.0E0.OR.ATOLI.GT.0.0E0)NZFLG=1
         IF(RTOLI.LT.0.0E0)GO TO 706
         IF(ATOLI.LT.0.0E0)GO TO 707
210      CONTINUE
      IF(NZFLG.EQ.0)GO TO 708
C
C     SET UP RWORK STORAGE.IWORK STORAGE IS FIXED
C     IN DATA STATEMENT.
      LE=LDELTA+NEQ
      LWT=LE+NEQ
      LPHI=LWT+NEQ
      LPD=LPHI+(IWORK(LMXORD)+1)*NEQ
      LWM=LPD
      NTEMP=NPD+IWORK(LNPD)
      IF(INFO(1).EQ.1)GO TO 400
C
C-----------------------------------------------------------------------
C     THIS BLOCK IS EXECUTED ON THE INITIAL CALL
C     ONLY. SET THE INITIAL STEP SIZE, AND
C     THE ERROR WEIGHT VECTOR, AND PHI.
C     COMPUTE INITIAL YPRIME, IF NECESSARY.
C-----------------------------------------------------------------------
C
      TN=T
      IDID=1
C
C     SET ERROR WEIGHT VECTOR WT
      CALL SDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR)
      DO 305 I = 1,NEQ
         IF(RWORK(LWT+I-1).LE.0.0E0) GO TO 713
305      CONTINUE
C
C     COMPUTE UNIT ROUNDOFF AND HMIN
      UROUND = R1MACH(4)
      RWORK(LROUND) = UROUND
      HMIN = 4.0E0*UROUND*MAX(ABS(T),ABS(TOUT))
C
C     CHECK INITIAL INTERVAL TO SEE THAT IT IS LONG ENOUGH
      TDIST = ABS(TOUT - T)
      IF(TDIST .LT. HMIN) GO TO 714
C
C     CHECK HO, IF THIS WAS INPUT
      IF (INFO(8) .EQ. 0) GO TO 310
         HO = RWORK(LH)
         IF ((TOUT - T)*HO .LT. 0.0E0) GO TO 711
         IF (HO .EQ. 0.0E0) GO TO 712
         GO TO 320
310    CONTINUE
C
C     COMPUTE INITIAL STEPSIZE, TO BE USED BY EITHER
C     SDASTP OR SDAINI, DEPENDING ON INFO(11)
      HO = 0.001E0*TDIST
      YPNORM = SDANRM(NEQ,YPRIME,RWORK(LWT),RPAR,IPAR)
      IF (YPNORM .GT. 0.5E0/HO) HO = 0.5E0/YPNORM
      HO = SIGN(HO,TOUT-T)
C     ADJUST HO IF NECESSARY TO MEET HMAX BOUND
320   IF (INFO(7) .EQ. 0) GO TO 330
         RH = ABS(HO)/RWORK(LHMAX)
         IF (RH .GT. 1.0E0) HO = HO/RH
C     COMPUTE TSTOP, IF APPLICABLE
330   IF (INFO(4) .EQ. 0) GO TO 340
         TSTOP = RWORK(LTSTOP)
         IF ((TSTOP - T)*HO .LT. 0.0E0) GO TO 715
         IF ((T + HO - TSTOP)*HO .GT. 0.0E0) HO = TSTOP - T
         IF ((TSTOP - TOUT)*HO .LT. 0.0E0) GO TO 709
C
C     COMPUTE INITIAL DERIVATIVE, UPDATING TN AND Y, IF APPLICABLE
340   IF (INFO(11) .EQ. 0) GO TO 350
      CALL SDAINI(TN,Y,YPRIME,NEQ,
     *  RES,JAC,HO,RWORK(LWT),IDID,RPAR,IPAR,
     *  RWORK(LPHI),RWORK(LDELTA),RWORK(LE),
     *  RWORK(LWM),IWORK(LIWM),HMIN,RWORK(LROUND),
     *  INFO(10),NTEMP)
      IF (IDID .LT. 0) GO TO 390
C
C     LOAD H WITH HO.  STORE H IN RWORK(LH)
350   H = HO
      RWORK(LH) = H
C
C     LOAD Y AND H*YPRIME INTO PHI(*,1) AND PHI(*,2)
      ITEMP = LPHI + NEQ
      DO 370 I = 1,NEQ
         RWORK(LPHI + I - 1) = Y(I)
370      RWORK(ITEMP + I - 1) = H*YPRIME(I)
C
390   GO TO 500
C
C-------------------------------------------------------
C     THIS BLOCK IS FOR CONTINUATION CALLS ONLY. ITS
C     PURPOSE IS TO CHECK STOP CONDITIONS BEFORE
C     TAKING A STEP.
C     ADJUST H IF NECESSARY TO MEET HMAX BOUND
C-------------------------------------------------------
C
400   CONTINUE
      UROUND=RWORK(LROUND)
      DONE = .FALSE.
      TN=RWORK(LTN)
      H=RWORK(LH)
      IF(INFO(7) .EQ. 0) GO TO 410
         RH = ABS(H)/RWORK(LHMAX)
         IF(RH .GT. 1.0E0) H = H/RH
410   CONTINUE
      IF(T .EQ. TOUT) GO TO 719
      IF((T - TOUT)*H .GT. 0.0E0) GO TO 711
      IF(INFO(4) .EQ. 1) GO TO 430
      IF(INFO(3) .EQ. 1) GO TO 420
      IF((TN-TOUT)*H.LT.0.0E0)GO TO 490
      CALL SDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
     *  RWORK(LPHI),RWORK(LPSI))
      T=TOUT
      IDID = 3
      DONE = .TRUE.
      GO TO 490
420   IF((TN-T)*H .LE. 0.0E0) GO TO 490
      IF((TN - TOUT)*H .GT. 0.0E0) GO TO 425
      CALL SDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD),
     *  RWORK(LPHI),RWORK(LPSI))
      T = TN
      IDID = 1
      DONE = .TRUE.
      GO TO 490
425   CONTINUE
      CALL SDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
     *  RWORK(LPHI),RWORK(LPSI))
      T = TOUT
      IDID = 3
      DONE = .TRUE.
      GO TO 490
430   IF(INFO(3) .EQ. 1) GO TO 440
      TSTOP=RWORK(LTSTOP)
      IF((TN-TSTOP)*H.GT.0.0E0) GO TO 715
      IF((TSTOP-TOUT)*H.LT.0.0E0)GO TO 709
      IF((TN-TOUT)*H.LT.0.0E0)GO TO 450
      CALL SDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
     *   RWORK(LPHI),RWORK(LPSI))
      T=TOUT
      IDID = 3
      DONE = .TRUE.
      GO TO 490
440   TSTOP = RWORK(LTSTOP)
      IF((TN-TSTOP)*H .GT. 0.0E0) GO TO 715
      IF((TSTOP-TOUT)*H .LT. 0.0E0) GO TO 709
      IF((TN-T)*H .LE. 0.0E0) GO TO 450
      IF((TN - TOUT)*H .GT. 0.0E0) GO TO 445
      CALL SDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD),
     *  RWORK(LPHI),RWORK(LPSI))
      T = TN
      IDID = 1
      DONE = .TRUE.
      GO TO 490
445   CONTINUE
      CALL SDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
     *  RWORK(LPHI),RWORK(LPSI))
      T = TOUT
      IDID = 3
      DONE = .TRUE.
      GO TO 490
450   CONTINUE
C     CHECK WHETHER WE ARE WITHIN ROUNDOFF OF TSTOP
      IF(ABS(TN-TSTOP).GT.100.0E0*UROUND*
     *   (ABS(TN)+ABS(H)))GO TO 460
      CALL SDATRP(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD),
     *  RWORK(LPHI),RWORK(LPSI))
      IDID=2
      T=TSTOP
      DONE = .TRUE.
      GO TO 490
460   TNEXT=TN+H
      IF((TNEXT-TSTOP)*H.LE.0.0E0)GO TO 490
      H=TSTOP-TN
      RWORK(LH)=H
C
490   IF (DONE) GO TO 580
C
C-------------------------------------------------------
C     THE NEXT BLOCK CONTAINS THE CALL TO THE
C     ONE-STEP INTEGRATOR SDASTP.
C     THIS IS A LOOPING POINT FOR THE INTEGRATION STEPS.
C     CHECK FOR TOO MANY STEPS.
C     UPDATE WT.
C     CHECK FOR TOO MUCH ACCURACY REQUESTED.
C     COMPUTE MINIMUM STEPSIZE.
C-------------------------------------------------------
C
500   CONTINUE
C     CHECK FOR FAILURE TO COMPUTE INITIAL YPRIME
      IF (IDID .EQ. -12) GO TO 527
C
C     CHECK FOR TOO MANY STEPS
      IF((IWORK(LNST)-IWORK(LNSTL)).LT.500)
     *   GO TO 510
           IDID=-1
           GO TO 527
C
C     UPDATE WT
510   CALL SDAWTS(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI),
     *  RWORK(LWT),RPAR,IPAR)
      DO 520 I=1,NEQ
         IF(RWORK(I+LWT-1).GT.0.0E0)GO TO 520
           IDID=-3
           GO TO 527
520   CONTINUE
C
C     TEST FOR TOO MUCH ACCURACY REQUESTED.
      R=SDANRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)*
     *   100.0E0*UROUND
      IF(R.LE.1.0E0)GO TO 525
C     MULTIPLY RTOL AND ATOL BY R AND RETURN
      IF(INFO(2).EQ.1)GO TO 523
           RTOL(1)=R*RTOL(1)
           ATOL(1)=R*ATOL(1)
           IDID=-2
           GO TO 527
523   DO 524 I=1,NEQ
           RTOL(I)=R*RTOL(I)
524        ATOL(I)=R*ATOL(I)
      IDID=-2
      GO TO 527
525   CONTINUE
C
C     COMPUTE MINIMUM STEPSIZE
      HMIN=4.0E0*UROUND*MAX(ABS(TN),ABS(TOUT))
C
C     TEST H VS. HMAX
      IF (INFO(7) .EQ. 0) GO TO 526
         RH = ABS(H)/RWORK(LHMAX)
         IF (RH .GT. 1.0E0) H = H/RH
526   CONTINUE   
C
      CALL SDASTP(TN,Y,YPRIME,NEQ,
     *   RES,JAC,H,RWORK(LWT),INFO(1),IDID,RPAR,IPAR,
     *   RWORK(LPHI),RWORK(LDELTA),RWORK(LE),
     *   RWORK(LWM),IWORK(LIWM),
     *   RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA),
     *   RWORK(LPSI),RWORK(LSIGMA),
     *   RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD),
     *   RWORK(LS),HMIN,RWORK(LROUND),
     *   IWORK(LPHASE),IWORK(LJCALC),IWORK(LK),
     *   IWORK(LKOLD),IWORK(LNS),INFO(10),NTEMP)
527   IF(IDID.LT.0)GO TO 600
C
C--------------------------------------------------------
C     THIS BLOCK HANDLES THE CASE OF A SUCCESSFUL RETURN
C     FROM SDASTP (IDID=1).  TEST FOR STOP CONDITIONS.
C--------------------------------------------------------
C
      IF(INFO(4).NE.0)GO TO 540
           IF(INFO(3).NE.0)GO TO 530
             IF((TN-TOUT)*H.LT.0.0E0)GO TO 500
             CALL SDATRP(TN,TOUT,Y,YPRIME,NEQ,
     *         IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI))
             IDID=3
             T=TOUT
             GO TO 580
530          IF((TN-TOUT)*H.GE.0.0E0)GO TO 535
             T=TN
             IDID=1
             GO TO 580
535          CALL SDATRP(TN,TOUT,Y,YPRIME,NEQ,
     *         IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI))
             IDID=3
             T=TOUT
             GO TO 580
540   IF(INFO(3).NE.0)GO TO 550
      IF((TN-TOUT)*H.LT.0.0E0)GO TO 542
         CALL SDATRP(TN,TOUT,Y,YPRIME,NEQ,
     *     IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI))
         T=TOUT
         IDID=3
         GO TO 580
542   IF(ABS(TN-TSTOP).LE.100.0E0*UROUND*
     *   (ABS(TN)+ABS(H)))GO TO 545
      TNEXT=TN+H
      IF((TNEXT-TSTOP)*H.LE.0.0E0)GO TO 500
      H=TSTOP-TN
      GO TO 500
545   CALL SDATRP(TN,TSTOP,Y,YPRIME,NEQ,
     *  IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI))
      IDID=2
      T=TSTOP
      GO TO 580
550   IF((TN-TOUT)*H.GE.0.0E0)GO TO 555
      IF(ABS(TN-TSTOP).LE.100.0E0*UROUND*(ABS(TN)+ABS(H)))GO TO 552
      T=TN
      IDID=1
      GO TO 580
552   CALL SDATRP(TN,TSTOP,Y,YPRIME,NEQ,
     *  IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI))
      IDID=2
      T=TSTOP
      GO TO 580
555   CALL SDATRP(TN,TOUT,Y,YPRIME,NEQ,
     *   IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI))
      T=TOUT
      IDID=3
      GO TO 580
C
C--------------------------------------------------------
C     ALL SUCCESSFUL RETURNS FROM SDASSL ARE MADE FROM
C     THIS BLOCK.
C--------------------------------------------------------
C
580   CONTINUE
      RWORK(LTN)=TN
      RWORK(LH)=H
      RETURN
C
C-----------------------------------------------------------------------
C     THIS BLOCK HANDLES ALL UNSUCCESSFUL
C     RETURNS OTHER THAN FOR ILLEGAL INPUT.
C-----------------------------------------------------------------------
C
600   CONTINUE
      ITEMP=-IDID
      GO TO (610,620,630,690,690,640,650,660,670,675,
     *  680,685), ITEMP
C
C     THE MAXIMUM NUMBER OF STEPS WAS TAKEN BEFORE
C     REACHING TOUT
610   WRITE (XERN3, '(1P,E15.6)') TN
      CALL XERMSG ('SLATEC', 'SDASSL',
     *   'AT CURRENT T = ' // XERN3 // ' 500 STEPS TAKEN ON THIS ' //
     *   'CALL BEFORE REACHING TOUT', IDID, 1)
      GO TO 690
C
C     TOO MUCH ACCURACY FOR MACHINE PRECISION
620   WRITE (XERN3, '(1P,E15.6)') TN
      CALL XERMSG ('SLATEC', 'SDASSL',
     *   'AT T = ' // XERN3 // ' TOO MUCH ACCURACY REQUESTED FOR ' //
     *   'PRECISION OF MACHINE. RTOL AND ATOL WERE INCREASED TO ' //
     *   'APPROPRIATE VALUES', IDID, 1)
      GO TO 690
C
C     WT(I) .LE. 0.0 FOR SOME I (NOT AT START OF PROBLEM)
630   WRITE (XERN3, '(1P,E15.6)') TN
      CALL XERMSG ('SLATEC', 'SDASSL',
     *   'AT T = ' // XERN3 // ' SOME ELEMENT OF WT HAS BECOME .LE. ' //
     *   '0.0', IDID, 1)
      GO TO 690
C
C     ERROR TEST FAILED REPEATEDLY OR WITH H=HMIN
640   WRITE (XERN3, '(1P,E15.6)') TN
      WRITE (XERN4, '(1P,E15.6)') H
      CALL XERMSG ('SLATEC', 'SDASSL',
     *   'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 //
     *   ' THE ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN',
     *   IDID, 1)
      GO TO 690
C
C     CORRECTOR CONVERGENCE FAILED REPEATEDLY OR WITH H=HMIN
650   WRITE (XERN3, '(1P,E15.6)') TN
      WRITE (XERN4, '(1P,E15.6)') H
      CALL XERMSG ('SLATEC', 'SDASSL',
     *   'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 //
     *   ' THE CORRECTOR FAILED TO CONVERGE REPEATEDLY OR WITH ' //
     *   'ABS(H)=HMIN', IDID, 1)
      GO TO 690
C
C     THE ITERATION MATRIX IS SINGULAR
660   WRITE (XERN3, '(1P,E15.6)') TN
      WRITE (XERN4, '(1P,E15.6)') H
      CALL XERMSG ('SLATEC', 'SDASSL',
     *   'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 //
     *   ' THE ITERATION MATRIX IS SINGULAR', IDID, 1)
      GO TO 690
C
C     CORRECTOR FAILURE PRECEEDED BY ERROR TEST FAILURES.
670   WRITE (XERN3, '(1P,E15.6)') TN
      WRITE (XERN4, '(1P,E15.6)') H
      CALL XERMSG ('SLATEC', 'SDASSL',
     *   'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 //
     *   ' THE CORRECTOR COULD NOT CONVERGE.  ALSO, THE ERROR TEST ' //
     *   'FAILED REPEATEDLY.', IDID, 1)
      GO TO 690
C
C     CORRECTOR FAILURE BECAUSE IRES = -1
675   WRITE (XERN3, '(1P,E15.6)') TN
      WRITE (XERN4, '(1P,E15.6)') H
      CALL XERMSG ('SLATEC', 'SDASSL',
     *   'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 //
     *   ' THE CORRECTOR COULD NOT CONVERGE BECAUSE IRES WAS EQUAL ' //
     *   'TO MINUS ONE', IDID, 1)
      GO TO 690
C
C     FAILURE BECAUSE IRES = -2
680   WRITE (XERN3, '(1P,E15.6)') TN
      WRITE (XERN4, '(1P,E15.6)') H
      CALL XERMSG ('SLATEC', 'SDASSL',
     *   'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 //
     *   ' IRES WAS EQUAL TO MINUS TWO', IDID, 1)
      GO TO 690
C
C     FAILED TO COMPUTE INITIAL YPRIME
685   WRITE (XERN3, '(1P,E15.6)') TN
      WRITE (XERN4, '(1P,E15.6)') HO
      CALL XERMSG ('SLATEC', 'SDASSL',
     *   'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 //
     *   ' THE INITIAL YPRIME COULD NOT BE COMPUTED', IDID, 1)
      GO TO 690
C
690   CONTINUE
      INFO(1)=-1
      T=TN
      RWORK(LTN)=TN
      RWORK(LH)=H
      RETURN
C
C-----------------------------------------------------------------------
C     THIS BLOCK HANDLES ALL ERROR RETURNS DUE
C     TO ILLEGAL INPUT, AS DETECTED BEFORE CALLING
C     SDASTP. FIRST THE ERROR MESSAGE ROUTINE IS
C     CALLED. IF THIS HAPPENS TWICE IN
C     SUCCESSION, EXECUTION IS TERMINATED
C
C-----------------------------------------------------------------------
701   CALL XERMSG ('SLATEC', 'SDASSL',
     *   'SOME ELEMENT OF INFO VECTOR IS NOT ZERO OR ONE', 1, 1)
      GO TO 750
C
702   WRITE (XERN1, '(I8)') NEQ
      CALL XERMSG ('SLATEC', 'SDASSL',
     *   'NEQ = ' // XERN1 // ' .LE. 0', 2, 1)
      GO TO 750
C
703   WRITE (XERN1, '(I8)') MXORD
      CALL XERMSG ('SLATEC', 'SDASSL',
     *   'MAXORD = ' // XERN1 // ' NOT IN RANGE', 3, 1)
      GO TO 750
C
704   WRITE (XERN1, '(I8)') LENRW
      WRITE (XERN2, '(I8)') LRW
      CALL XERMSG ('SLATEC', 'SDASSL',
     *   'RWORK LENGTH NEEDED, LENRW = ' // XERN1 //
     *   ', EXCEEDS LRW = ' // XERN2, 4, 1)
      GO TO 750
C
705   WRITE (XERN1, '(I8)') LENIW
      WRITE (XERN2, '(I8)') LIW
      CALL XERMSG ('SLATEC', 'SDASSL',
     *   'IWORK LENGTH NEEDED, LENIW = ' // XERN1 //
     *   ', EXCEEDS LIW = ' // XERN2, 5, 1)
      GO TO 750
C
706   CALL XERMSG ('SLATEC', 'SDASSL',
     *   'SOME ELEMENT OF RTOL IS .LT. 0', 6, 1)
      GO TO 750
C
707   CALL XERMSG ('SLATEC', 'SDASSL',
     *   'SOME ELEMENT OF ATOL IS .LT. 0', 7, 1)
      GO TO 750
C
708   CALL XERMSG ('SLATEC', 'SDASSL',
     *   'ALL ELEMENTS OF RTOL AND ATOL ARE ZERO', 8, 1)
      GO TO 750
C
709   WRITE (XERN3, '(1P,E15.6)') TSTOP
      WRITE (XERN4, '(1P,E15.6)') TOUT
      CALL XERMSG ('SLATEC', 'SDASSL',
     *   'INFO(4) = 1 AND TSTOP = ' // XERN3 // ' BEHIND TOUT = ' //
     *   XERN4, 9, 1)
      GO TO 750
C
710   WRITE (XERN3, '(1P,E15.6)') HMAX
      CALL XERMSG ('SLATEC', 'SDASSL',
     *   'HMAX = ' // XERN3 // ' .LT. 0.0', 10, 1)
      GO TO 750
C
711   WRITE (XERN3, '(1P,E15.6)') TOUT
      WRITE (XERN4, '(1P,E15.6)') T
      CALL XERMSG ('SLATEC', 'SDASSL',
     *   'TOUT = ' // XERN3 // ' BEHIND T = ' // XERN4, 11, 1)
      GO TO 750
C
712   CALL XERMSG ('SLATEC', 'SDASSL',
     *   'INFO(8)=1 AND H0=0.0', 12, 1)
      GO TO 750
C
713   CALL XERMSG ('SLATEC', 'SDASSL',
     *   'SOME ELEMENT OF WT IS .LE. 0.0', 13, 1)
      GO TO 750
C
714   WRITE (XERN3, '(1P,E15.6)') TOUT
      WRITE (XERN4, '(1P,E15.6)') T
      CALL XERMSG ('SLATEC', 'SDASSL',
     *   'TOUT = ' // XERN3 // ' TOO CLOSE TO T = ' // XERN4 //
     *   ' TO START INTEGRATION', 14, 1)
      GO TO 750
C
715   WRITE (XERN3, '(1P,E15.6)') TSTOP
      WRITE (XERN4, '(1P,E15.6)') T
      CALL XERMSG ('SLATEC', 'SDASSL',
     *   'INFO(4)=1 AND TSTOP = ' // XERN3 // ' BEHIND T = ' // XERN4,
     *   15, 1)
      GO TO 750
C
717   WRITE (XERN1, '(I8)') IWORK(LML)
      CALL XERMSG ('SLATEC', 'SDASSL',
     *   'ML = ' // XERN1 // ' ILLEGAL.  EITHER .LT. 0 OR .GT. NEQ',
     *   17, 1)
      GO TO 750
C
718   WRITE (XERN1, '(I8)') IWORK(LMU)
      CALL XERMSG ('SLATEC', 'SDASSL',
     *   'MU = ' // XERN1 // ' ILLEGAL.  EITHER .LT. 0 OR .GT. NEQ',
     *   18, 1)
      GO TO 750
C
719   WRITE (XERN3, '(1P,E15.6)') TOUT
      CALL XERMSG ('SLATEC', 'SDASSL',
     *  'TOUT = T = ' // XERN3, 19, 1)
      GO TO 750
C
750   IDID=-33
      IF(INFO(1).EQ.-1) THEN
         CALL XERMSG ('SLATEC', 'SDASSL',
     *      'REPEATED OCCURRENCES OF ILLEGAL INPUT$$' //
     *      'RUN TERMINATED. APPARENT INFINITE LOOP', -999, 2)
      ENDIF
C
      INFO(1)=-1
      RETURN
C-----------END OF SUBROUTINE SDASSL------------------------------------
      END
      SUBROUTINE SDAWTS (NEQ, IWT, RTOL, ATOL, Y, WT, RPAR, IPAR)
C***BEGIN PROLOGUE  SDAWTS
C***SUBSIDIARY
C***PURPOSE  Set error weight vector for SDASSL.
C***LIBRARY   SLATEC (DASSL)
C***TYPE      SINGLE PRECISION (SDAWTS-S, DDAWTS-D)
C***AUTHOR  PETZOLD, LINDA R., (LLNL)
C***DESCRIPTION
C-----------------------------------------------------------------------
C     THIS SUBROUTINE SETS THE ERROR WEIGHT VECTOR
C     WT ACCORDING TO WT(I)=RTOL(I)*ABS(Y(I))+ATOL(I),
C     I=1,-,N.
C     RTOL AND ATOL ARE SCALARS IF IWT = 0,
C     AND VECTORS IF IWT = 1.
C-----------------------------------------------------------------------
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   830315  DATE WRITTEN
C   901009  Finished conversion to SLATEC 4.0 format (F.N.Fritsch)
C   901019  Merged changes made by C. Ulrich with SLATEC 4.0 format.
C   901026  Added explicit declarations for all variables and minor
C           cosmetic changes to prologue.  (FNF)
C***END PROLOGUE  SDAWTS
C
      INTEGER  NEQ, IWT, IPAR(*)
      REAL  RTOL(*), ATOL(*), Y(*), WT(*), RPAR(*)
C
      INTEGER  I
      REAL  ATOLI, RTOLI
C
C***FIRST EXECUTABLE STATEMENT  SDAWTS
      RTOLI=RTOL(1)
      ATOLI=ATOL(1)
      DO 20 I=1,NEQ
         IF (IWT .EQ.0) GO TO 10
           RTOLI=RTOL(I)
           ATOLI=ATOL(I)
10         WT(I)=RTOLI*ABS(Y(I))+ATOLI
20         CONTINUE
      RETURN
C-----------END OF SUBROUTINE SDAWTS------------------------------------
      END
      REAL FUNCTION SDANRM (NEQ, V, WT, RPAR, IPAR)
C***BEGIN PROLOGUE  SDANRM
C***SUBSIDIARY
C***PURPOSE  Compute vector norm for SDASSL.
C***LIBRARY   SLATEC (DASSL)
C***TYPE      SINGLE PRECISION (SDANRM-S, DDANRM-D)
C***AUTHOR  PETZOLD, LINDA R., (LLNL)
C***DESCRIPTION
C-----------------------------------------------------------------------
C     THIS FUNCTION ROUTINE COMPUTES THE WEIGHTED
C     ROOT-MEAN-SQUARE NORM OF THE VECTOR OF LENGTH
C     NEQ CONTAINED IN THE ARRAY V,WITH WEIGHTS
C     CONTAINED IN THE ARRAY WT OF LENGTH NEQ.
C        SDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2)
C-----------------------------------------------------------------------
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   830315  DATE WRITTEN
C   901009  Finished conversion to SLATEC 4.0 format (F.N.Fritsch)
C   901019  Merged changes made by C. Ulrich with SLATEC 4.0 format.
C   901026  Added explicit declarations for all variables and minor
C           cosmetic changes to prologue.  (FNF)
C***END PROLOGUE  SDANRM
C
      INTEGER  NEQ, IPAR(*)
      REAL  V(NEQ), WT(NEQ), RPAR(*)
C
      INTEGER  I
      REAL  SUM, VMAX
C
C***FIRST EXECUTABLE STATEMENT  SDANRM
      SDANRM = 0.0E0
      VMAX = 0.0E0
      DO 10 I = 1,NEQ
        IF(ABS(V(I)/WT(I)) .GT. VMAX) VMAX = ABS(V(I)/WT(I))
10      CONTINUE
      IF(VMAX .LE. 0.0E0) GO TO 30
      SUM = 0.0E0
      DO 20 I = 1,NEQ
20      SUM = SUM + ((V(I)/WT(I))/VMAX)**2
      SDANRM = VMAX*SQRT(SUM/NEQ)
30    CONTINUE
      RETURN
C------END OF FUNCTION SDANRM------
      END
      SUBROUTINE SDAINI (X, Y, YPRIME, NEQ, RES, JAC, H, WT, IDID, RPAR,
     +   IPAR, PHI, DELTA, E, WM, IWM, HMIN, UROUND, NONNEG, NTEMP)
C***BEGIN PROLOGUE  SDAINI
C***SUBSIDIARY
C***PURPOSE  Initialization routine for SDASSL.
C***LIBRARY   SLATEC (DASSL)
C***TYPE      SINGLE PRECISION (SDAINI-S, DDAINI-D)
C***AUTHOR  PETZOLD, LINDA R., (LLNL)
C***DESCRIPTION
C-----------------------------------------------------------------
C     SDAINI TAKES ONE STEP OF SIZE H OR SMALLER
C     WITH THE BACKWARD EULER METHOD, TO
C     FIND YPRIME.  X AND Y ARE UPDATED TO BE CONSISTENT WITH THE
C     NEW STEP.  A MODIFIED DAMPED NEWTON ITERATION IS USED TO
C     SOLVE THE CORRECTOR ITERATION.
C
C     THE INITIAL GUESS FOR YPRIME IS USED IN THE
C     PREDICTION, AND IN FORMING THE ITERATION
C     MATRIX, BUT IS NOT INVOLVED IN THE
C     ERROR TEST. THIS MAY HAVE TROUBLE
C     CONVERGING IF THE INITIAL GUESS IS NO
C     GOOD, OR IF G(X,Y,YPRIME) DEPENDS
C     NONLINEARLY ON YPRIME.
C
C     THE PARAMETERS REPRESENT:
C     X --         INDEPENDENT VARIABLE
C     Y --         SOLUTION VECTOR AT X
C     YPRIME --    DERIVATIVE OF SOLUTION VECTOR
C     NEQ --       NUMBER OF EQUATIONS
C     H --         STEPSIZE. IMDER MAY USE A STEPSIZE
C                  SMALLER THAN H.
C     WT --        VECTOR OF WEIGHTS FOR ERROR
C                  CRITERION
C     IDID --      COMPLETION CODE WITH THE FOLLOWING MEANINGS
C                  IDID= 1 -- YPRIME WAS FOUND SUCCESSFULLY
C                  IDID=-12 -- SDAINI FAILED TO FIND YPRIME
C     RPAR,IPAR -- REAL AND INTEGER PARAMETER ARRAYS
C                  THAT ARE NOT ALTERED BY SDAINI
C     PHI --       WORK SPACE FOR SDAINI
C     DELTA,E --   WORK SPACE FOR SDAINI
C     WM,IWM --    REAL AND INTEGER ARRAYS STORING
C                  MATRIX INFORMATION
C
C-----------------------------------------------------------------
C***ROUTINES CALLED  SDAJAC, SDANRM, SDASLV
C***REVISION HISTORY  (YYMMDD)
C   830315  DATE WRITTEN
C   901009  Finished conversion to SLATEC 4.0 format (F.N.Fritsch)
C   901019  Merged changes made by C. Ulrich with SLATEC 4.0 format.
C   901026  Added explicit declarations for all variables and minor
C           cosmetic changes to prologue.  (FNF)
C   901030  Minor corrections to declarations.  (FNF)
C***END PROLOGUE  SDAINI
C
      INTEGER  NEQ, IDID, IPAR(*), IWM(*), NONNEG, NTEMP
      REAL  X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*),
     *   E(*), WM(*), HMIN, UROUND
      EXTERNAL  RES, JAC
C
      EXTERNAL  SDAJAC, SDANRM, SDASLV
      REAL  SDANRM
C
      INTEGER  I, IER, IRES, JCALC, LNJE, LNRE, M, MAXIT, MJAC, NCF,
     *   NEF, NSF
      REAL  CJ, DAMP, DELNRM, ERR, OLDNRM, R, RATE, S, XOLD, YNORM
      LOGICAL  CONVGD
C
      PARAMETER (LNRE=12)
      PARAMETER (LNJE=13)
C
      DATA MAXIT/10/,MJAC/5/
      DATA DAMP/0.75E0/
C
C
C---------------------------------------------------
C     BLOCK 1.
C     INITIALIZATIONS.
C---------------------------------------------------
C
C***FIRST EXECUTABLE STATEMENT  SDAINI
      IDID=1
      NEF=0
      NCF=0
      NSF=0
      XOLD=X
      YNORM=SDANRM(NEQ,Y,WT,RPAR,IPAR)
C
C     SAVE Y AND YPRIME IN PHI
      DO 100 I=1,NEQ
         PHI(I,1)=Y(I)
100      PHI(I,2)=YPRIME(I)
C
C
C----------------------------------------------------
C     BLOCK 2.
C     DO ONE BACKWARD EULER STEP.
C----------------------------------------------------
C
C     SET UP FOR START OF CORRECTOR ITERATION
200   CJ=1.0E0/H
      X=X+H
C
C     PREDICT SOLUTION AND DERIVATIVE
      DO 250 I=1,NEQ
250     Y(I)=Y(I)+H*YPRIME(I)
C
      JCALC=-1
      M=0
      CONVGD=.TRUE.
C
C
C     CORRECTOR LOOP.
300   IWM(LNRE)=IWM(LNRE)+1
      IRES=0
C
      CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
      IF (IRES.LT.0) GO TO 430
C
C
C     EVALUATE THE ITERATION MATRIX
      IF (JCALC.NE.-1) GO TO 310
      IWM(LNJE)=IWM(LNJE)+1
      JCALC=0
      CALL SDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H,
     *   IER,WT,E,WM,IWM,RES,IRES,
     *   UROUND,JAC,RPAR,IPAR,NTEMP)
C
      S=1000000.E0
      IF (IRES.LT.0) GO TO 430
      IF (IER.NE.0) GO TO 430
      NSF=0
C
C
C
C     MULTIPLY RESIDUAL BY DAMPING FACTOR
310   CONTINUE
      DO 320 I=1,NEQ
320      DELTA(I)=DELTA(I)*DAMP
C
C     COMPUTE A NEW ITERATE (BACK SUBSTITUTION)
C     STORE THE CORRECTION IN DELTA
C
      CALL SDASLV(NEQ,DELTA,WM,IWM)
C
C     UPDATE Y AND YPRIME
      DO 330 I=1,NEQ
         Y(I)=Y(I)-DELTA(I)
330      YPRIME(I)=YPRIME(I)-CJ*DELTA(I)
C
C     TEST FOR CONVERGENCE OF THE ITERATION.
C
      DELNRM=SDANRM(NEQ,DELTA,WT,RPAR,IPAR)
      IF (DELNRM.LE.100.E0*UROUND*YNORM)
     *   GO TO 400
C
      IF (M.GT.0) GO TO 340
         OLDNRM=DELNRM
         GO TO 350
C
340   RATE=(DELNRM/OLDNRM)**(1.0E0/M)
      IF (RATE.GT.0.90E0) GO TO 430
      S=RATE/(1.0E0-RATE)
C
350   IF (S*DELNRM .LE. 0.33E0) GO TO 400
C
C
C     THE CORRECTOR HAS NOT YET CONVERGED. UPDATE
C     M AND AND TEST WHETHER THE MAXIMUM
C     NUMBER OF ITERATIONS HAVE BEEN TRIED.
C     EVERY MJAC ITERATIONS, GET A NEW
C     ITERATION MATRIX.
C
      M=M+1
      IF (M.GE.MAXIT) GO TO 430
C
      IF ((M/MJAC)*MJAC.EQ.M) JCALC=-1
      GO TO 300
C
C
C     THE ITERATION HAS CONVERGED.
C     CHECK NONNEGATIVITY CONSTRAINTS
400   IF (NONNEG.EQ.0) GO TO 450
      DO 410 I=1,NEQ
410      DELTA(I)=MIN(Y(I),0.0E0)
C
      DELNRM=SDANRM(NEQ,DELTA,WT,RPAR,IPAR)
      IF (DELNRM.GT.0.33E0) GO TO 430
C
      DO 420 I=1,NEQ
         Y(I)=Y(I)-DELTA(I)
420      YPRIME(I)=YPRIME(I)-CJ*DELTA(I)
      GO TO 450
C
C
C     EXITS FROM CORRECTOR LOOP.
430   CONVGD=.FALSE.
450   IF (.NOT.CONVGD) GO TO 600
C
C
C
C-----------------------------------------------------
C     BLOCK 3.
C     THE CORRECTOR ITERATION CONVERGED.
C     DO ERROR TEST.
C-----------------------------------------------------
C
      DO 510 I=1,NEQ
510      E(I)=Y(I)-PHI(I,1)
      ERR=SDANRM(NEQ,E,WT,RPAR,IPAR)
C
      IF (ERR.LE.1.0E0) RETURN
C
C
C
C--------------------------------------------------------
C     BLOCK 4.
C     THE BACKWARD EULER STEP FAILED. RESTORE X, Y
C     AND YPRIME TO THEIR ORIGINAL VALUES.
C     REDUCE STEPSIZE AND TRY AGAIN, IF
C     POSSIBLE.
C---------------------------------------------------------
C
600   CONTINUE
      X = XOLD
      DO 610 I=1,NEQ
         Y(I)=PHI(I,1)
610      YPRIME(I)=PHI(I,2)
C
      IF (CONVGD) GO TO 640
      IF (IER.EQ.0) GO TO 620
         NSF=NSF+1
         H=H*0.25E0
         IF (NSF.LT.3.AND.ABS(H).GE.HMIN) GO TO 690
         IDID=-12
         RETURN
620   IF (IRES.GT.-2) GO TO 630
         IDID=-12
         RETURN
630   NCF=NCF+1
      H=H*0.25E0
      IF (NCF.LT.10.AND.ABS(H).GE.HMIN) GO TO 690
         IDID=-12
         RETURN
C
640   NEF=NEF+1
      R=0.90E0/(2.0E0*ERR+0.0001E0)
      R=MAX(0.1E0,MIN(0.5E0,R))
      H=H*R
      IF (ABS(H).GE.HMIN.AND.NEF.LT.10) GO TO 690
         IDID=-12
         RETURN
690      GO TO 200
C
C-------------END OF SUBROUTINE SDAINI----------------------
      END
      SUBROUTINE SDATRP (X, XOUT, YOUT, YPOUT, NEQ, KOLD, PHI, PSI)
C***BEGIN PROLOGUE  SDATRP
C***SUBSIDIARY
C***PURPOSE  Interpolation routine for SDASSL.
C***LIBRARY   SLATEC (DASSL)
C***TYPE      SINGLE PRECISION (SDATRP-S, DDATRP-D)
C***AUTHOR  PETZOLD, LINDA R., (LLNL)
C***DESCRIPTION
C-----------------------------------------------------------------------
C     THE METHODS IN SUBROUTINE SDASTP USE POLYNOMIALS
C     TO APPROXIMATE THE SOLUTION. SDATRP APPROXIMATES THE
C     SOLUTION AND ITS DERIVATIVE AT TIME XOUT BY EVALUATING
C     ONE OF THESE POLYNOMIALS,AND ITS DERIVATIVE,THERE.
C     INFORMATION DEFINING THIS POLYNOMIAL IS PASSED FROM
C     SDASTP, SO SDATRP CANNOT BE USED ALONE.
C
C     THE PARAMETERS ARE:
C     X     THE CURRENT TIME IN THE INTEGRATION.
C     XOUT  THE TIME AT WHICH THE SOLUTION IS DESIRED
C     YOUT  THE INTERPOLATED APPROXIMATION TO Y AT XOUT
C           (THIS IS OUTPUT)
C     YPOUT THE INTERPOLATED APPROXIMATION TO YPRIME AT XOUT
C           (THIS IS OUTPUT)
C     NEQ   NUMBER OF EQUATIONS
C     KOLD  ORDER USED ON LAST SUCCESSFUL STEP
C     PHI   ARRAY OF SCALED DIVIDED DIFFERENCES OF Y
C     PSI   ARRAY OF PAST STEPSIZE HISTORY
C-----------------------------------------------------------------------
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   830315  DATE WRITTEN
C   901009  Finished conversion to SLATEC 4.0 format (F.N.Fritsch)
C   901019  Merged changes made by C. Ulrich with SLATEC 4.0 format.
C   901026  Added explicit declarations for all variables and minor
C           cosmetic changes to prologue.  (FNF)
C***END PROLOGUE  SDATRP
C
      INTEGER  NEQ, KOLD
      REAL  X, XOUT, YOUT(*), YPOUT(*), PHI(NEQ,*), PSI(*)
C
      INTEGER  I, J, KOLDP1
      REAL  C, D, GAMMA, TEMP1
C
C***FIRST EXECUTABLE STATEMENT  SDATRP
      KOLDP1=KOLD+1
      TEMP1=XOUT-X
      DO 10 I=1,NEQ
         YOUT(I)=PHI(I,1)
10       YPOUT(I)=0.0E0
      C=1.0E0
      D=0.0E0
      GAMMA=TEMP1/PSI(1)
      DO 30 J=2,KOLDP1
         D=D*GAMMA+C/PSI(J-1)
         C=C*GAMMA
         GAMMA=(TEMP1+PSI(J-1))/PSI(J)
         DO 20 I=1,NEQ
            YOUT(I)=YOUT(I)+C*PHI(I,J)
20          YPOUT(I)=YPOUT(I)+D*PHI(I,J)
30       CONTINUE
      RETURN
C
C------END OF SUBROUTINE SDATRP------
      END
      SUBROUTINE SDASTP (X, Y, YPRIME, NEQ, RES, JAC, H, WT, JSTART,
     +   IDID, RPAR, IPAR, PHI, DELTA, E, WM, IWM, ALPHA, BETA, GAMMA,
     +   PSI, SIGMA, CJ, CJOLD, HOLD, S, HMIN, UROUND, IPHASE, JCALC,
     +   K, KOLD, NS, NONNEG, NTEMP)
C***BEGIN PROLOGUE  SDASTP
C***SUBSIDIARY
C***PURPOSE  Perform one step of the SDASSL integration.
C***LIBRARY   SLATEC (DASSL)
C***TYPE      SINGLE PRECISION (SDASTP-S, DDASTP-D)
C***AUTHOR  PETZOLD, LINDA R., (LLNL)
C***DESCRIPTION
C-----------------------------------------------------------------------
C     SDASTP SOLVES A SYSTEM OF DIFFERENTIAL/
C     ALGEBRAIC EQUATIONS OF THE FORM
C     G(X,Y,YPRIME) = 0,  FOR ONE STEP (NORMALLY
C     FROM X TO X+H).
C
C     THE METHODS USED ARE MODIFIED DIVIDED
C     DIFFERENCE,FIXED LEADING COEFFICIENT
C     FORMS OF BACKWARD DIFFERENTIATION
C     FORMULAS. THE CODE ADJUSTS THE STEPSIZE
C     AND ORDER TO CONTROL THE LOCAL ERROR PER
C     STEP.
C
C
C     THE PARAMETERS REPRESENT
C     X  --        INDEPENDENT VARIABLE
C     Y  --        SOLUTION VECTOR AT X
C     YPRIME --    DERIVATIVE OF SOLUTION VECTOR
C                  AFTER SUCCESSFUL STEP
C     NEQ --       NUMBER OF EQUATIONS TO BE INTEGRATED
C     RES --       EXTERNAL USER-SUPPLIED SUBROUTINE
C                  TO EVALUATE THE RESIDUAL.  THE CALL IS
C                  CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
C                  X,Y,YPRIME ARE INPUT.  DELTA IS OUTPUT.
C                  ON INPUT, IRES=0.  RES SHOULD ALTER IRES ONLY
C                  IF IT ENCOUNTERS AN ILLEGAL VALUE OF Y OR A
C                  STOP CONDITION.  SET IRES=-1 IF AN INPUT VALUE
C                  OF Y IS ILLEGAL, AND SDASTP WILL TRY TO SOLVE
C                  THE PROBLEM WITHOUT GETTING IRES = -1.  IF
C                  IRES=-2, SDASTP RETURNS CONTROL TO THE CALLING
C                  PROGRAM WITH IDID = -11.
C     JAC --       EXTERNAL USER-SUPPLIED ROUTINE TO EVALUATE
C                  THE ITERATION MATRIX (THIS IS OPTIONAL)
C                  THE CALL IS OF THE FORM
C                  CALL JAC(X,Y,YPRIME,PD,CJ,RPAR,IPAR)
C                  PD IS THE MATRIX OF PARTIAL DERIVATIVES,
C                  PD=DG/DY+CJ*DG/DYPRIME
C     H --         APPROPRIATE STEP SIZE FOR NEXT STEP.
C                  NORMALLY DETERMINED BY THE CODE
C     WT --        VECTOR OF WEIGHTS FOR ERROR CRITERION.
C     JSTART --    INTEGER VARIABLE SET 0 FOR
C                  FIRST STEP, 1 OTHERWISE.
C     IDID --      COMPLETION CODE WITH THE FOLLOWING MEANINGS:
C                  IDID= 1 -- THE STEP WAS COMPLETED SUCCESSFULLY
C                  IDID=-6 -- THE ERROR TEST FAILED REPEATEDLY
C                  IDID=-7 -- THE CORRECTOR COULD NOT CONVERGE
C                  IDID=-8 -- THE ITERATION MATRIX IS SINGULAR
C                  IDID=-9 -- THE CORRECTOR COULD NOT CONVERGE.
C                             THERE WERE REPEATED ERROR TEST
C                             FAILURES ON THIS STEP.
C                  IDID=-10-- THE CORRECTOR COULD NOT CONVERGE
C                             BECAUSE IRES WAS EQUAL TO MINUS ONE
C                  IDID=-11-- IRES EQUAL TO -2 WAS ENCOUNTERED,
C                             AND CONTROL IS BEING RETURNED TO
C                             THE CALLING PROGRAM
C     RPAR,IPAR -- REAL AND INTEGER PARAMETER ARRAYS THAT
C                  ARE USED FOR COMMUNICATION BETWEEN THE
C                  CALLING PROGRAM AND EXTERNAL USER ROUTINES
C                  THEY ARE NOT ALTERED BY SDASTP
C     PHI --       ARRAY OF DIVIDED DIFFERENCES USED BY
C                  SDASTP. THE LENGTH IS NEQ*(K+1),WHERE
C                  K IS THE MAXIMUM ORDER
C     DELTA,E --   WORK VECTORS FOR SDASTP OF LENGTH NEQ
C     WM,IWM --    REAL AND INTEGER ARRAYS STORING
C                  MATRIX INFORMATION SUCH AS THE MATRIX
C                  OF PARTIAL DERIVATIVES,PERMUTATION
C                  VECTOR,AND VARIOUS OTHER INFORMATION.
C
C     THE OTHER PARAMETERS ARE INFORMATION
C     WHICH IS NEEDED INTERNALLY BY SDASTP TO
C     CONTINUE FROM STEP TO STEP.
C
C-----------------------------------------------------------------------
C***ROUTINES CALLED  SDAJAC, SDANRM, SDASLV, SDATRP
C***REVISION HISTORY  (YYMMDD)
C   830315  DATE WRITTEN
C   901009  Finished conversion to SLATEC 4.0 format (F.N.Fritsch)
C   901019  Merged changes made by C. Ulrich with SLATEC 4.0 format.
C   901026  Added explicit declarations for all variables and minor
C           cosmetic changes to prologue.  (FNF)
C***END PROLOGUE  SDASTP
C
      INTEGER  NEQ, JSTART, IDID, IPAR(*), IWM(*), IPHASE, JCALC, K,
     *   KOLD, NS, NONNEG, NTEMP
      REAL  X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*),
     *   E(*), WM(*), ALPHA(*), BETA(*), GAMMA(*), PSI(*), SIGMA(*), CJ,
     *   CJOLD, HOLD, S, HMIN, UROUND
      EXTERNAL  RES, JAC
C
      EXTERNAL  SDAJAC, SDANRM, SDASLV, SDATRP
      REAL  SDANRM
C
      INTEGER  I, IER, IRES, J, J1, KDIFF, KM1, KNEW, KP1, KP2, LCTF,
     *   LETF, LMXORD, LNJE, LNRE, LNST, M, MAXIT, NCF, NEF, NSF, NSP1
      REAL  ALPHA0, ALPHAS, CJLAST, CK, DELNRM, ENORM, ERK, ERKM1,
     *   ERKM2, ERKP1, ERR, EST, HNEW, OLDNRM, PNORM, R, RATE, TEMP1,
     *   TEMP2, TERK, TERKM1, TERKM2, TERKP1, XOLD, XRATE
      LOGICAL  CONVGD
C
      PARAMETER (LMXORD=3)
      PARAMETER (LNST=11)
      PARAMETER (LNRE=12)
      PARAMETER (LNJE=13)
      PARAMETER (LETF=14)
      PARAMETER (LCTF=15)
C
      DATA MAXIT/4/
      DATA XRATE/0.25E0/
C
C
C
C
C
C-----------------------------------------------------------------------
C     BLOCK 1.
C     INITIALIZE. ON THE FIRST CALL,SET
C     THE ORDER TO 1 AND INITIALIZE
C     OTHER VARIABLES.
C-----------------------------------------------------------------------
C
C     INITIALIZATIONS FOR ALL CALLS
C***FIRST EXECUTABLE STATEMENT  SDASTP
      IDID=1
      XOLD=X
      NCF=0
      NSF=0
      NEF=0
      IF(JSTART .NE. 0) GO TO 120
C
C     IF THIS IS THE FIRST STEP,PERFORM
C     OTHER INITIALIZATIONS
      IWM(LETF) = 0
      IWM(LCTF) = 0
      K=1
      KOLD=0
      HOLD=0.0E0
      JSTART=1
      PSI(1)=H
      CJOLD = 1.0E0/H
      CJ = CJOLD
      S = 100.E0
      JCALC = -1
      DELNRM=1.0E0
      IPHASE = 0
      NS=0
120   CONTINUE
C
C
C
C
C
C-----------------------------------------------------------------------
C     BLOCK 2
C     COMPUTE COEFFICIENTS OF FORMULAS FOR
C     THIS STEP.
C-----------------------------------------------------------------------
200   CONTINUE
      KP1=K+1
      KP2=K+2
      KM1=K-1
      XOLD=X
      IF(H.NE.HOLD.OR.K .NE. KOLD) NS = 0
      NS=MIN(NS+1,KOLD+2)
      NSP1=NS+1
      IF(KP1 .LT. NS)GO TO 230
C
      BETA(1)=1.0E0
      ALPHA(1)=1.0E0
      TEMP1=H
      GAMMA(1)=0.0E0
      SIGMA(1)=1.0E0
      DO 210 I=2,KP1
         TEMP2=PSI(I-1)
         PSI(I-1)=TEMP1
         BETA(I)=BETA(I-1)*PSI(I-1)/TEMP2
         TEMP1=TEMP2+H
         ALPHA(I)=H/TEMP1
         SIGMA(I)=(I-1)*SIGMA(I-1)*ALPHA(I)
         GAMMA(I)=GAMMA(I-1)+ALPHA(I-1)/H
210      CONTINUE
      PSI(KP1)=TEMP1
230   CONTINUE
C
C     COMPUTE ALPHAS, ALPHA0
      ALPHAS = 0.0E0
      ALPHA0 = 0.0E0
      DO 240 I = 1,K
        ALPHAS = ALPHAS - 1.0E0/I
        ALPHA0 = ALPHA0 - ALPHA(I)
240     CONTINUE
C
C     COMPUTE LEADING COEFFICIENT CJ
      CJLAST = CJ
      CJ = -ALPHAS/H
C
C     COMPUTE VARIABLE STEPSIZE ERROR COEFFICIENT CK
      CK = ABS(ALPHA(KP1) + ALPHAS - ALPHA0)
      CK = MAX(CK,ALPHA(KP1))
C
C     DECIDE WHETHER NEW JACOBIAN IS NEEDED
      TEMP1 = (1.0E0 - XRATE)/(1.0E0 + XRATE)
      TEMP2 = 1.0E0/TEMP1
      IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1
      IF (CJ .NE. CJLAST) S = 100.E0
C
C     CHANGE PHI TO PHI STAR
      IF(KP1 .LT. NSP1) GO TO 280
      DO 270 J=NSP1,KP1
         DO 260 I=1,NEQ
260         PHI(I,J)=BETA(J)*PHI(I,J)
270      CONTINUE
280   CONTINUE
C
C     UPDATE TIME
      X=X+H
C
C
C
C
C
C-----------------------------------------------------------------------
C     BLOCK 3
C     PREDICT THE SOLUTION AND DERIVATIVE,
C     AND SOLVE THE CORRECTOR EQUATION
C-----------------------------------------------------------------------
C
C     FIRST,PREDICT THE SOLUTION AND DERIVATIVE
300   CONTINUE
      DO 310 I=1,NEQ
         Y(I)=PHI(I,1)
310      YPRIME(I)=0.0E0
      DO 330 J=2,KP1
         DO 320 I=1,NEQ
            Y(I)=Y(I)+PHI(I,J)
320         YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J)
330   CONTINUE
      PNORM = SDANRM (NEQ,Y,WT,RPAR,IPAR)
C
C
C
C     SOLVE THE CORRECTOR EQUATION USING A
C     MODIFIED NEWTON SCHEME.
      CONVGD= .TRUE.
      M=0
      IWM(LNRE)=IWM(LNRE)+1
      IRES = 0
      CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
      IF (IRES .LT. 0) GO TO 380
C
C
C     IF INDICATED,REEVALUATE THE
C     ITERATION MATRIX PD = DG/DY + CJ*DG/DYPRIME
C     (WHERE G(X,Y,YPRIME)=0). SET
C     JCALC TO 0 AS AN INDICATOR THAT
C     THIS HAS BEEN DONE.
      IF(JCALC .NE. -1)GO TO 340
      IWM(LNJE)=IWM(LNJE)+1
      JCALC=0
      CALL SDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H,
     * IER,WT,E,WM,IWM,RES,IRES,UROUND,JAC,RPAR,
     * IPAR,NTEMP)
      CJOLD=CJ
      S = 100.E0
      IF (IRES .LT. 0) GO TO 380
      IF(IER .NE. 0)GO TO 380
      NSF=0
C
C
C     INITIALIZE THE ERROR ACCUMULATION VECTOR E.
340   CONTINUE
      DO 345 I=1,NEQ
345      E(I)=0.0E0
C
C
C     CORRECTOR LOOP.
350   CONTINUE
C
C     MULTIPLY RESIDUAL BY TEMP1 TO ACCELERATE CONVERGENCE
      TEMP1 = 2.0E0/(1.0E0 + CJ/CJOLD)
      DO 355 I = 1,NEQ
355     DELTA(I) = DELTA(I) * TEMP1
C
C     COMPUTE A NEW ITERATE (BACK-SUBSTITUTION).
C     STORE THE CORRECTION IN DELTA.
      CALL SDASLV(NEQ,DELTA,WM,IWM)
C
C     UPDATE Y,E,AND YPRIME
      DO 360 I=1,NEQ
         Y(I)=Y(I)-DELTA(I)
         E(I)=E(I)-DELTA(I)
360      YPRIME(I)=YPRIME(I)-CJ*DELTA(I)
C
C     TEST FOR CONVERGENCE OF THE ITERATION
      DELNRM=SDANRM(NEQ,DELTA,WT,RPAR,IPAR)
      IF (DELNRM .LE. 100.E0*UROUND*PNORM) GO TO 375
      IF (M .GT. 0) GO TO 365
         OLDNRM = DELNRM
         GO TO 367
365   RATE = (DELNRM/OLDNRM)**(1.0E0/M)
      IF (RATE .GT. 0.90E0) GO TO 370
      S = RATE/(1.0E0 - RATE)
367   IF (S*DELNRM .LE. 0.33E0) GO TO 375
C
C     THE CORRECTOR HAS NOT YET CONVERGED.
C     UPDATE M AND TEST WHETHER THE
C     MAXIMUM NUMBER OF ITERATIONS HAVE
C     BEEN TRIED.
      M=M+1
      IF(M.GE.MAXIT)GO TO 370
C
C     EVALUATE THE RESIDUAL
C     AND GO BACK TO DO ANOTHER ITERATION
      IWM(LNRE)=IWM(LNRE)+1
      IRES = 0
      CALL RES(X,Y,YPRIME,DELTA,IRES,
     *  RPAR,IPAR)
      IF (IRES .LT. 0) GO TO 380
      GO TO 350
C
C
C     THE CORRECTOR FAILED TO CONVERGE IN MAXIT
C     ITERATIONS. IF THE ITERATION MATRIX
C     IS NOT CURRENT,RE-DO THE STEP WITH
C     A NEW ITERATION MATRIX.
370   CONTINUE
      IF(JCALC.EQ.0)GO TO 380
      JCALC=-1
      GO TO 300
C
C
C     THE ITERATION HAS CONVERGED.  IF NONNEGATIVITY OF SOLUTION IS
C     REQUIRED, SET THE SOLUTION NONNEGATIVE, IF THE PERTURBATION
C     TO DO IT IS SMALL ENOUGH.  IF THE CHANGE IS TOO LARGE, THEN
C     CONSIDER THE CORRECTOR ITERATION TO HAVE FAILED.
375   IF(NONNEG .EQ. 0) GO TO 390
      DO 377 I = 1,NEQ
377      DELTA(I) = MIN(Y(I),0.0E0)
      DELNRM = SDANRM(NEQ,DELTA,WT,RPAR,IPAR)
      IF(DELNRM .GT. 0.33E0) GO TO 380
      DO 378 I = 1,NEQ
378      E(I) = E(I) - DELTA(I)
      GO TO 390
C
C
C     EXITS FROM BLOCK 3
C     NO CONVERGENCE WITH CURRENT ITERATION
C     MATRIX,OR SINGULAR ITERATION MATRIX
380   CONVGD= .FALSE.
390   JCALC = 1
      IF(.NOT.CONVGD)GO TO 600
C
C
C
C
C
C-----------------------------------------------------------------------
C     BLOCK 4
C     ESTIMATE THE ERRORS AT ORDERS K,K-1,K-2
C     AS IF CONSTANT STEPSIZE WAS USED. ESTIMATE
C     THE LOCAL ERROR AT ORDER K AND TEST
C     WHETHER THE CURRENT STEP IS SUCCESSFUL.
C-----------------------------------------------------------------------
C
C     ESTIMATE ERRORS AT ORDERS K,K-1,K-2
      ENORM = SDANRM(NEQ,E,WT,RPAR,IPAR)
      ERK = SIGMA(K+1)*ENORM
      TERK = (K+1)*ERK
      EST = ERK
      KNEW=K
      IF(K .EQ. 1)GO TO 430
      DO 405 I = 1,NEQ
405     DELTA(I) = PHI(I,KP1) + E(I)
      ERKM1=SIGMA(K)*SDANRM(NEQ,DELTA,WT,RPAR,IPAR)
      TERKM1 = K*ERKM1
      IF(K .GT. 2)GO TO 410
      IF(TERKM1 .LE. 0.5E0*TERK)GO TO 420
      GO TO 430
410   CONTINUE
      DO 415 I = 1,NEQ
415     DELTA(I) = PHI(I,K) + DELTA(I)
      ERKM2=SIGMA(K-1)*SDANRM(NEQ,DELTA,WT,RPAR,IPAR)
      TERKM2 = (K-1)*ERKM2
      IF(MAX(TERKM1,TERKM2).GT.TERK)GO TO 430
C     LOWER THE ORDER
420   CONTINUE
      KNEW=K-1
      EST = ERKM1
C
C
C     CALCULATE THE LOCAL ERROR FOR THE CURRENT STEP
C     TO SEE IF THE STEP WAS SUCCESSFUL
430   CONTINUE
      ERR = CK * ENORM
      IF(ERR .GT. 1.0E0)GO TO 600
C
C
C
C
C
C-----------------------------------------------------------------------
C     BLOCK 5
C     THE STEP IS SUCCESSFUL. DETERMINE
C     THE BEST ORDER AND STEPSIZE FOR
C     THE NEXT STEP. UPDATE THE DIFFERENCES
C     FOR THE NEXT STEP.
C-----------------------------------------------------------------------
      IDID=1
      IWM(LNST)=IWM(LNST)+1
      KDIFF=K-KOLD
      KOLD=K
      HOLD=H
C
C
C     ESTIMATE THE ERROR AT ORDER K+1 UNLESS:
C        ALREADY DECIDED TO LOWER ORDER, OR
C        ALREADY USING MAXIMUM ORDER, OR
C        STEPSIZE NOT CONSTANT, OR
C        ORDER RAISED IN PREVIOUS STEP
      IF(KNEW.EQ.KM1.OR.K.EQ.IWM(LMXORD))IPHASE=1
      IF(IPHASE .EQ. 0)GO TO 545
      IF(KNEW.EQ.KM1)GO TO 540
      IF(K.EQ.IWM(LMXORD)) GO TO 550
      IF(KP1.GE.NS.OR.KDIFF.EQ.1)GO TO 550
      DO 510 I=1,NEQ
510      DELTA(I)=E(I)-PHI(I,KP2)
      ERKP1 = (1.0E0/(K+2))*SDANRM(NEQ,DELTA,WT,RPAR,IPAR)
      TERKP1 = (K+2)*ERKP1
      IF(K.GT.1)GO TO 520
      IF(TERKP1.GE.0.5E0*TERK)GO TO 550
      GO TO 530
520   IF(TERKM1.LE.MIN(TERK,TERKP1))GO TO 540
      IF(TERKP1.GE.TERK.OR.K.EQ.IWM(LMXORD))GO TO 550
C
C     RAISE ORDER
530   K=KP1
      EST = ERKP1
      GO TO 550
C
C     LOWER ORDER
540   K=KM1
      EST = ERKM1
      GO TO 550
C
C     IF IPHASE = 0, INCREASE ORDER BY ONE AND MULTIPLY STEPSIZE BY
C     FACTOR TWO
545   K = KP1
      HNEW = H*2.0E0
      H = HNEW
      GO TO 575
C
C
C     DETERMINE THE APPROPRIATE STEPSIZE FOR
C     THE NEXT STEP.
550   HNEW=H
      TEMP2=K+1
      R=(2.0E0*EST+0.0001E0)**(-1.0E0/TEMP2)
      IF(R .LT. 2.0E0) GO TO 555
      HNEW = 2.0E0*H
      GO TO 560
555   IF(R .GT. 1.0E0) GO TO 560
      R = MAX(0.5E0,MIN(0.9E0,R))
      HNEW = H*R
560   H=HNEW
C
C
C     UPDATE DIFFERENCES FOR NEXT STEP
575   CONTINUE
      IF(KOLD.EQ.IWM(LMXORD))GO TO 585
      DO 580 I=1,NEQ
580      PHI(I,KP2)=E(I)
585   CONTINUE
      DO 590 I=1,NEQ
590      PHI(I,KP1)=PHI(I,KP1)+E(I)
      DO 595 J1=2,KP1
         J=KP1-J1+1
         DO 595 I=1,NEQ
595      PHI(I,J)=PHI(I,J)+PHI(I,J+1)
      RETURN
C
C
C
C
C
C-----------------------------------------------------------------------
C     BLOCK 6
C     THE STEP IS UNSUCCESSFUL. RESTORE X,PSI,PHI
C     DETERMINE APPROPRIATE STEPSIZE FOR
C     CONTINUING THE INTEGRATION, OR EXIT WITH
C     AN ERROR FLAG IF THERE HAVE BEEN MANY
C     FAILURES.
C-----------------------------------------------------------------------
600   IPHASE = 1
C
C     RESTORE X,PHI,PSI
      X=XOLD
      IF(KP1.LT.NSP1)GO TO 630
      DO 620 J=NSP1,KP1
         TEMP1=1.0E0/BETA(J)
         DO 610 I=1,NEQ
610         PHI(I,J)=TEMP1*PHI(I,J)
620      CONTINUE
630   CONTINUE
      DO 640 I=2,KP1
640      PSI(I-1)=PSI(I)-H
C
C
C     TEST WHETHER FAILURE IS DUE TO CORRECTOR ITERATION
C     OR ERROR TEST
      IF(CONVGD)GO TO 660
      IWM(LCTF)=IWM(LCTF)+1
C
C
C     THE NEWTON ITERATION FAILED TO CONVERGE WITH
C     A CURRENT ITERATION MATRIX.  DETERMINE THE CAUSE
C     OF THE FAILURE AND TAKE APPROPRIATE ACTION.
      IF(IER.EQ.0)GO TO 650
C
C     THE ITERATION MATRIX IS SINGULAR. REDUCE
C     THE STEPSIZE BY A FACTOR OF 4. IF
C     THIS HAPPENS THREE TIMES IN A ROW ON
C     THE SAME STEP, RETURN WITH AN ERROR FLAG
      NSF=NSF+1
      R = 0.25E0
      H=H*R
      IF (NSF .LT. 3 .AND. ABS(H) .GE. HMIN) GO TO 690
      IDID=-8
      GO TO 675
C
C
C     THE NEWTON ITERATION FAILED TO CONVERGE FOR A REASON
C     OTHER THAN A SINGULAR ITERATION MATRIX.  IF IRES = -2, THEN
C     RETURN.  OTHERWISE, REDUCE THE STEPSIZE AND TRY AGAIN, UNLESS
C     TOO MANY FAILURES HAVE OCCURED.
650   CONTINUE
      IF (IRES .GT. -2) GO TO 655
      IDID = -11
      GO TO 675
655   NCF = NCF + 1
      R = 0.25E0
      H = H*R
      IF (NCF .LT. 10 .AND. ABS(H) .GE. HMIN) GO TO 690
      IDID = -7
      IF (IRES .LT. 0) IDID = -10
      IF (NEF .GE. 3) IDID = -9
      GO TO 675
C
C
C     THE NEWTON SCHEME CONVERGED,AND THE CAUSE
C     OF THE FAILURE WAS THE ERROR ESTIMATE
C     EXCEEDING THE TOLERANCE.
660   NEF=NEF+1
      IWM(LETF)=IWM(LETF)+1
      IF (NEF .GT. 1) GO TO 665
C
C     ON FIRST ERROR TEST FAILURE, KEEP CURRENT ORDER OR LOWER
C     ORDER BY ONE.  COMPUTE NEW STEPSIZE BASED ON DIFFERENCES
C     OF THE SOLUTION.
      K = KNEW
      TEMP2 = K + 1
      R = 0.90E0*(2.0E0*EST+0.0001E0)**(-1.0E0/TEMP2)
      R = MAX(0.25E0,MIN(0.9E0,R))
      H = H*R
      IF (ABS(H) .GE. HMIN) GO TO 690
      IDID = -6
      GO TO 675
C
C     ON SECOND ERROR TEST FAILURE, USE THE CURRENT ORDER OR
C     DECREASE ORDER BY ONE.  REDUCE THE STEPSIZE BY A FACTOR OF
C     FOUR.
665   IF (NEF .GT. 2) GO TO 670
      K = KNEW
      H = 0.25E0*H
      IF (ABS(H) .GE. HMIN) GO TO 690
      IDID = -6
      GO TO 675
C
C     ON THIRD AND SUBSEQUENT ERROR TEST FAILURES, SET THE ORDER TO
C     ONE AND REDUCE THE STEPSIZE BY A FACTOR OF FOUR.
670   K = 1
      H = 0.25E0*H
      IF (ABS(H) .GE. HMIN) GO TO 690
      IDID = -6
      GO TO 675
C
C
C
C
C     FOR ALL CRASHES, RESTORE Y TO ITS LAST VALUE,
C     INTERPOLATE TO FIND YPRIME AT LAST X, AND RETURN
675   CONTINUE
      CALL SDATRP(X,X,Y,YPRIME,NEQ,K,PHI,PSI)
      RETURN
C
C
C     GO BACK AND TRY THIS STEP AGAIN
690   GO TO 200
C
C------END OF SUBROUTINE SDASTP------
      END
      SUBROUTINE SDAJAC (NEQ, X, Y, YPRIME, DELTA, CJ, H,
     +   IER, WT, E, WM, IWM, RES, IRES, UROUND, JAC, RPAR,
     +   IPAR, NTEMP)
C***BEGIN PROLOGUE  SDAJAC
C***SUBSIDIARY
C***PURPOSE  Compute the iteration matrix for SDASSL and form the
C            LU-decomposition.
C***LIBRARY   SLATEC (DASSL)
C***TYPE      SINGLE PRECISION (SDAJAC-S, DDAJAC-D)
C***AUTHOR  PETZOLD, LINDA R., (LLNL)
C***DESCRIPTION
C-----------------------------------------------------------------------
C     THIS ROUTINE COMPUTES THE ITERATION MATRIX
C     PD=DG/DY+CJ*DG/DYPRIME (WHERE G(X,Y,YPRIME)=0).
C     HERE PD IS COMPUTED BY THE USER-SUPPLIED
C     ROUTINE JAC IF IWM(MTYPE) IS 1 OR 4, AND
C     IT IS COMPUTED BY NUMERICAL FINITE DIFFERENCING
C     IF IWM(MTYPE)IS 2 OR 5
C     THE PARAMETERS HAVE THE FOLLOWING MEANINGS.
C     Y        = ARRAY CONTAINING PREDICTED VALUES
C     YPRIME   = ARRAY CONTAINING PREDICTED DERIVATIVES
C     DELTA    = RESIDUAL EVALUATED AT (X,Y,YPRIME)
C                (USED ONLY IF IWM(MTYPE)=2 OR 5)
C     CJ       = SCALAR PARAMETER DEFINING ITERATION MATRIX
C     H        = CURRENT STEPSIZE IN INTEGRATION
C     IER      = VARIABLE WHICH IS .NE. 0
C                IF ITERATION MATRIX IS SINGULAR,
C                AND 0 OTHERWISE.
C     WT       = VECTOR OF WEIGHTS FOR COMPUTING NORMS
C     E        = WORK SPACE (TEMPORARY) OF LENGTH NEQ
C     WM       = REAL WORK SPACE FOR MATRICES. ON
C                OUTPUT IT CONTAINS THE LU DECOMPOSITION
C                OF THE ITERATION MATRIX.
C     IWM      = INTEGER WORK SPACE CONTAINING
C                MATRIX INFORMATION
C     RES      = NAME OF THE EXTERNAL USER-SUPPLIED ROUTINE
C                TO EVALUATE THE RESIDUAL FUNCTION G(X,Y,YPRIME)
C     IRES     = FLAG WHICH IS EQUAL TO ZERO IF NO ILLEGAL VALUES
C                IN RES, AND LESS THAN ZERO OTHERWISE.  (IF IRES
C                IS LESS THAN ZERO, THE MATRIX WAS NOT COMPLETED)
C                IN THIS CASE (IF IRES .LT. 0), THEN IER = 0.
C     UROUND   = THE UNIT ROUNDOFF ERROR OF THE MACHINE BEING USED.
C     JAC      = NAME OF THE EXTERNAL USER-SUPPLIED ROUTINE
C                TO EVALUATE THE ITERATION MATRIX (THIS ROUTINE
C                IS ONLY USED IF IWM(MTYPE) IS 1 OR 4)
C-----------------------------------------------------------------------
C***ROUTINES CALLED  SGBFA, SGEFA
C***REVISION HISTORY  (YYMMDD)
C   830315  DATE WRITTEN
C   901009  Finished conversion to SLATEC 4.0 format (F.N.Fritsch)
C   901010  Modified three MAX calls to be all on one line.  (FNF)
C   901019  Merged changes made by C. Ulrich with SLATEC 4.0 format.
C   901026  Added explicit declarations for all variables and minor
C           cosmetic changes to prologue.  (FNF)
C   901101  Corrected PURPOSE.  (FNF)
C***END PROLOGUE  SDAJAC
C
      INTEGER  NEQ, IER, IWM(*), IRES, IPAR(*), NTEMP
      REAL  X, Y(*), YPRIME(*), DELTA(*), CJ, H, WT(*), E(*), WM(*),
     *   UROUND, RPAR(*)
      EXTERNAL  RES, JAC
C
      EXTERNAL  SGBFA, SGEFA
C
      INTEGER  I, I1, I2, II, IPSAVE, ISAVE, J, K, L, LENPD, LIPVT,
     *   LML, LMTYPE, LMU, MBA, MBAND, MEB1, MEBAND, MSAVE, MTYPE, N,
     *   NPD, NPDM1, NROW
      REAL  DEL, DELINV, SQUR, YPSAVE, YSAVE
C
      PARAMETER (NPD=1)
      PARAMETER (LML=1)
      PARAMETER (LMU=2)
      PARAMETER (LMTYPE=4)
      PARAMETER (LIPVT=21)
C
C***FIRST EXECUTABLE STATEMENT  SDAJAC
      IER = 0
      NPDM1=NPD-1
      MTYPE=IWM(LMTYPE)
      GO TO (100,200,300,400,500),MTYPE
C
C
C     DENSE USER-SUPPLIED MATRIX
100   LENPD=NEQ*NEQ
      DO 110 I=1,LENPD
110      WM(NPDM1+I)=0.0E0
      CALL JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR)
      GO TO 230
C
C
C     DENSE FINITE-DIFFERENCE-GENERATED MATRIX
200   IRES=0
      NROW=NPDM1
      SQUR = SQRT(UROUND)
      DO 210 I=1,NEQ
         DEL=SQUR*MAX(ABS(Y(I)),ABS(H*YPRIME(I)),ABS(WT(I)))
         DEL=SIGN(DEL,H*YPRIME(I))
         DEL=(Y(I)+DEL)-Y(I)
         YSAVE=Y(I)
         YPSAVE=YPRIME(I)
         Y(I)=Y(I)+DEL
         YPRIME(I)=YPRIME(I)+CJ*DEL
         CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR)
         IF (IRES .LT. 0) RETURN
         DELINV=1.0E0/DEL
         DO 220 L=1,NEQ
220      WM(NROW+L)=(E(L)-DELTA(L))*DELINV
      NROW=NROW+NEQ
      Y(I)=YSAVE
      YPRIME(I)=YPSAVE
210   CONTINUE
C
C
C     DO DENSE-MATRIX LU DECOMPOSITION ON PD
230      CALL SGEFA(WM(NPD),NEQ,NEQ,IWM(LIPVT),IER)
      RETURN
C
C
C     DUMMY SECTION FOR IWM(MTYPE)=3
300   RETURN
C
C
C     BANDED USER-SUPPLIED MATRIX
400   LENPD=(2*IWM(LML)+IWM(LMU)+1)*NEQ
      DO 410 I=1,LENPD
410      WM(NPDM1+I)=0.0E0
      CALL JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR)
      MEBAND=2*IWM(LML)+IWM(LMU)+1
      GO TO 550
C
C
C     BANDED FINITE-DIFFERENCE-GENERATED MATRIX
500   MBAND=IWM(LML)+IWM(LMU)+1
      MBA=MIN(MBAND,NEQ)
      MEBAND=MBAND+IWM(LML)
      MEB1=MEBAND-1
      MSAVE=(NEQ/MBAND)+1
      ISAVE=NTEMP-1
      IPSAVE=ISAVE+MSAVE
      IRES=0
      SQUR=SQRT(UROUND)
      DO 540 J=1,MBA
         DO 510 N=J,NEQ,MBAND
          K= (N-J)/MBAND + 1
          WM(ISAVE+K)=Y(N)
          WM(IPSAVE+K)=YPRIME(N)
          DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)),ABS(WT(N)))
          DEL=SIGN(DEL,H*YPRIME(N))
          DEL=(Y(N)+DEL)-Y(N)
          Y(N)=Y(N)+DEL
510       YPRIME(N)=YPRIME(N)+CJ*DEL
      CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR)
      IF (IRES .LT. 0) RETURN
      DO 530 N=J,NEQ,MBAND
          K= (N-J)/MBAND + 1
          Y(N)=WM(ISAVE+K)
          YPRIME(N)=WM(IPSAVE+K)
          DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)),ABS(WT(N)))
          DEL=SIGN(DEL,H*YPRIME(N))
          DEL=(Y(N)+DEL)-Y(N)
          DELINV=1.0E0/DEL
          I1=MAX(1,(N-IWM(LMU)))
          I2=MIN(NEQ,(N+IWM(LML)))
          II=N*MEB1-IWM(LML)+NPDM1
          DO 520 I=I1,I2
520         WM(II+I)=(E(I)-DELTA(I))*DELINV
530      CONTINUE
540   CONTINUE
C
C
C     DO LU DECOMPOSITION OF BANDED PD
550   CALL SGBFA(WM(NPD),MEBAND,NEQ,
     *    IWM(LML),IWM(LMU),IWM(LIPVT),IER)
      RETURN
C------END OF SUBROUTINE SDAJAC------
      END
      SUBROUTINE SDASLV (NEQ, DELTA, WM, IWM)
C***BEGIN PROLOGUE  SDASLV
C***SUBSIDIARY
C***PURPOSE  Linear system solver for SDASSL.
C***LIBRARY   SLATEC (DASSL)
C***TYPE      SINGLE PRECISION (SDASLV-S, DDASLV-D)
C***AUTHOR  PETZOLD, LINDA R., (LLNL)
C***DESCRIPTION
C-----------------------------------------------------------------------
C     THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR
C     SYSTEM ARISING IN THE NEWTON ITERATION.
C     MATRICES AND REAL TEMPORARY STORAGE AND
C     REAL INFORMATION ARE STORED IN THE ARRAY WM.
C     INTEGER MATRIX INFORMATION IS STORED IN
C     THE ARRAY IWM.
C     FOR A DENSE MATRIX, THE LINPACK ROUTINE
C     SGESL IS CALLED.
C     FOR A BANDED MATRIX,THE LINPACK ROUTINE
C     SGBSL IS CALLED.
C-----------------------------------------------------------------------
C***ROUTINES CALLED  SGBSL, SGESL
C***REVISION HISTORY  (YYMMDD)
C   830315  DATE WRITTEN
C   901009  Finished conversion to SLATEC 4.0 format (F.N.Fritsch)
C   901019  Merged changes made by C. Ulrich with SLATEC 4.0 format.
C   901026  Added explicit declarations for all variables and minor
C           cosmetic changes to prologue.  (FNF)
C***END PROLOGUE  SDASLV
C
      INTEGER  NEQ, IWM(*)
      REAL  DELTA(*), WM(*)
C
      EXTERNAL  SGBSL, SGESL
C
      INTEGER  LIPVT, LML, LMU, LMTYPE, MEBAND, MTYPE, NPD
      PARAMETER (NPD=1)
      PARAMETER (LML=1)
      PARAMETER (LMU=2)
      PARAMETER (LMTYPE=4)
      PARAMETER (LIPVT=21)
C
C***FIRST EXECUTABLE STATEMENT  SDASLV
      MTYPE=IWM(LMTYPE)
      GO TO(100,100,300,400,400),MTYPE
C
C     DENSE MATRIX
100   CALL SGESL(WM(NPD),NEQ,NEQ,IWM(LIPVT),DELTA,0)
      RETURN
C
C     DUMMY SECTION FOR MTYPE=3
300   CONTINUE
      RETURN
C
C     BANDED MATRIX
400   MEBAND=2*IWM(LML)+IWM(LMU)+1
      CALL SGBSL(WM(NPD),MEBAND,NEQ,IWM(LML),
     *  IWM(LMU),IWM(LIPVT),DELTA,0)
      RETURN
C------END OF SUBROUTINE SDASLV------
      END
      SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL)
C***BEGIN PROLOGUE  XERMSG
C***PURPOSE  Processes error messages for SLATEC and other libraries
C***LIBRARY   SLATEC
C***CATEGORY  R3C
C***TYPE      ALL
C***KEYWORDS  ERROR MESSAGE, XERROR
C***AUTHOR  FONG, KIRBY, (NMFECC AT LLNL)
C             Modified by
C           FRITSCH, F. N., (LLNL)
C***DESCRIPTION
C
C   XERMSG processes a diagnostic message in a manner determined by the
C   value of LEVEL and the current value of the library error control
C   flag, KONTRL.  See subroutine XSETF for details.
C       (XSETF is inoperable in this version.).
C
C    LIBRAR   A character constant (or character variable) with the name
C             of the library.  This will be 'SLATEC' for the SLATEC
C             Common Math Library.  The error handling package is
C             general enough to be used by many libraries
C             simultaneously, so it is desirable for the routine that
C             detects and reports an error to identify the library name
C             as well as the routine name.
C
C    SUBROU   A character constant (or character variable) with the name
C             of the routine that detected the error.  Usually it is the
C             name of the routine that is calling XERMSG.  There are
C             some instances where a user callable library routine calls
C             lower level subsidiary routines where the error is
C             detected.  In such cases it may be more informative to
C             supply the name of the routine the user called rather than
C             the name of the subsidiary routine that detected the
C             error.
C
C    MESSG    A character constant (or character variable) with the text
C             of the error or warning message.  In the example below,
C             the message is a character constant that contains a
C             generic message.
C
C                   CALL XERMSG ('SLATEC', 'MMPY',
C                  *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION',
C                  *3, 1)
C
C             It is possible (and is sometimes desirable) to generate a
C             specific message--e.g., one that contains actual numeric
C             values.  Specific numeric values can be converted into
C             character strings using formatted WRITE statements into
C             character variables.  This is called standard Fortran
C             internal file I/O and is exemplified in the first three
C             lines of the following example.  You can also catenate
C             substrings of characters to construct the error message.
C             Here is an example showing the use of both writing to
C             an internal file and catenating character strings.
C
C                   CHARACTER*5 CHARN, CHARL
C                   WRITE (CHARN,10) N
C                   WRITE (CHARL,10) LDA
C                10 FORMAT(I5)
C                   CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN//
C                  *   ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'//
C                  *   CHARL, 3, 1)
C
C             There are two subtleties worth mentioning.  One is that
C             the // for character catenation is used to construct the
C             error message so that no single character constant is
C             continued to the next line.  This avoids confusion as to
C             whether there are trailing blanks at the end of the line.
C             The second is that by catenating the parts of the message
C             as an actual argument rather than encoding the entire
C             message into one large character variable, we avoid
C             having to know how long the message will be in order to
C             declare an adequate length for that large character
C             variable.  XERMSG calls XERPRN to print the message using
C             multiple lines if necessary.  If the message is very long,
C             XERPRN will break it into pieces of 72 characters (as
C             requested by XERMSG) for printing on multiple lines.
C             Also, XERMSG asks XERPRN to prefix each line with ' *  '
C             so that the total line length could be 76 characters.
C             Note also that XERPRN scans the error message backwards
C             to ignore trailing blanks.  Another feature is that
C             the substring '$$' is treated as a new line sentinel
C             by XERPRN.  If you want to construct a multiline
C             message without having to count out multiples of 72
C             characters, just use '$$' as a separator.  '$$'
C             obviously must occur within 72 characters of the
C             start of each line to have its intended effect since
C             XERPRN is asked to wrap around at 72 characters in
C             addition to looking for '$$'.
C
C    NERR     An integer value that is chosen by the library routine's
C             author.  It must be in the range -9999999 to 99999999 (8
C             printable digits).  Each distinct error should have its
C             own error number.  These error numbers should be described
C             in the machine readable documentation for the routine.
C             The error numbers need be unique only within each routine,
C             so it is reasonable for each routine to start enumerating
C             errors from 1 and proceeding to the next integer.
C
C    LEVEL    An integer value in the range 0 to 2 that indicates the
C             level (severity) of the error.  Their meanings are
C
C            -1  A warning message.  This is used if it is not clear
C                that there really is an error, but the user's attention
C                may be needed.  An attempt is made to only print this
C                message once.
C
C             0  A warning message.  This is used if it is not clear
C                that there really is an error, but the user's attention
C                may be needed.
C
C             1  A recoverable error.  This is used even if the error is
C                so serious that the routine cannot return any useful
C                answer.  If the user has told the error package to
C                return after recoverable errors, then XERMSG will
C                return to the Library routine which can then return to
C                the user's routine.  The user may also permit the error
C                package to terminate the program upon encountering a
C                recoverable error.
C
C             2  A fatal error.  XERMSG will not return to its caller
C                after it receives a fatal error.  This level should
C                hardly ever be used; it is much better to allow the
C                user a chance to recover.  An example of one of the few
C                cases in which it is permissible to declare a level 2
C                error is a reverse communication Library routine that
C                is likely to be called repeatedly until it integrates
C                across some interval.  If there is a serious error in
C                the input such that another step cannot be taken and
C                the Library routine is called again without the input
C                error having been corrected by the caller, the Library
C                routine will probably be called forever with improper
C                input.  In this case, it is reasonable to declare the
C                error to be fatal.
C
C    Each of the arguments to XERMSG is input; none will be modified by
C    XERMSG.  A routine may make multiple calls to XERMSG with warning
C    level messages; however, after a call to XERMSG with a recoverable
C    error, the routine should return to the user.
C
C***REFERENCES  JONES, RONDALL E. AND KAHANER, DAVID K., "XERROR, THE
C                 SLATEC ERROR-HANDLING PACKAGE", SOFTWARE - PRACTICE
C                 AND EXPERIENCE, VOLUME 13, NO. 3, PP. 251-257,
C                 MARCH, 1983.
C***ROUTINES CALLED  XERHLT, XERPRN
C***REVISION HISTORY  (YYMMDD)
C   880101  DATE WRITTEN
C   880621  REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988.
C           THERE ARE TWO BASIC CHANGES.
C           1.  A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO
C               PRINT MESSAGES.  THIS ROUTINE WILL BREAK LONG MESSAGES
C               INTO PIECES FOR PRINTING ON MULTIPLE LINES.  '$$' IS
C               ACCEPTED AS A NEW LINE SENTINEL.  A PREFIX CAN BE
C               ADDED TO EACH LINE TO BE PRINTED.  XERMSG USES EITHER
C               ' ***' OR ' *  ' AND LONG MESSAGES ARE BROKEN EVERY
C               72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE
C               LENGTH OUTPUT CAN NOW BE AS GREAT AS 76.
C           2.  THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE
C               FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE
C               OF LOWER CASE.
C   880708  REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30.
C           THE PRINCIPAL CHANGES ARE
C           1.  CLARIFY COMMENTS IN THE PROLOGUES
C           2.  RENAME XRPRNT TO XERPRN
C           3.  REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES
C               SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE /
C               CHARACTER FOR NEW RECORDS.
C   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO
C           CLEAN UP THE CODING.
C   890721  REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN
C           PREFIX.
C   891013  REVISED TO CORRECT COMMENTS.
C   891214  Prologue converted to Version 4.0 format.  (WRB)
C   900510  Changed test on NERR to be -9999999 < NERR < 99999999, but
C           NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3.  Added
C           LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and
C           XERCTL to XERCNT.  (RWC)
C   901011  Removed error saving features to produce a simplified
C           version for distribution with DASSL and other LLNL codes.
C           (FNF)
C***END PROLOGUE  XERMSG
      CHARACTER*(*) LIBRAR, SUBROU, MESSG
      CHARACTER*72  TEMP
C***FIRST EXECUTABLE STATEMENT  XERMSG
C
C       WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN
C          CALLING XERMSG.  THE ERROR NUMBER SHOULD BE POSITIVE,
C          AND THE LEVEL SHOULD BE BETWEEN 0 AND 2.
C
      IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR.
     *   LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN
         CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' //
     *      'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '//
     *      'JOB ABORT DUE TO FATAL ERROR.', 72)
         CALL XERHLT (' ***XERMSG -- INVALID INPUT')
         RETURN
      ENDIF
C
C       SET DEFAULT VALUES FOR CONTROL PARAMETERS.
C
      LKNTRL = 1
      MKNTRL = 1
C
C       ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A
C       MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS)
C       AND SENDING IT OUT VIA XERPRN.  PRINT ONLY IF CONTROL FLAG
C       IS NOT ZERO.
C
      IF (LKNTRL .NE. 0) THEN
         TEMP(1:21) = 'MESSAGE FROM ROUTINE '
         I = MIN(LEN(SUBROU), 16)
         TEMP(22:21+I) = SUBROU(1:I)
         TEMP(22+I:33+I) = ' IN LIBRARY '
         LTEMP = 33 + I
         I = MIN(LEN(LIBRAR), 16)
         TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I)
         TEMP(LTEMP+I+1:LTEMP+I+1) = '.'
         LTEMP = LTEMP + I + 1
         CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
      ENDIF
C
C       IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE
C       PRINTING THE MESSAGE.  THE INTRODUCTORY LINE TELLS THE CHOICE
C       FROM EACH OF THE FOLLOWING TWO OPTIONS.
C       1.  LEVEL OF THE MESSAGE
C              'INFORMATIVE MESSAGE'
C              'POTENTIALLY RECOVERABLE ERROR'
C              'FATAL ERROR'
C       2.  WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE
C              'PROGRAM CONTINUES'
C              'PROGRAM ABORTED'
C       NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT
C       EXCEED 74 CHARACTERS.
C       WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED.
C
      IF (LKNTRL .GT. 0) THEN
C
C       THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL.
C
         IF (LEVEL .LE. 0) THEN
            TEMP(1:20) = 'INFORMATIVE MESSAGE,'
            LTEMP = 20
         ELSEIF (LEVEL .EQ. 1) THEN
            TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,'
            LTEMP = 30
         ELSE
            TEMP(1:12) = 'FATAL ERROR,'
            LTEMP = 12
         ENDIF
C
C       THEN WHETHER THE PROGRAM WILL CONTINUE.
C
         IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR.
     *       (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN
            TEMP(LTEMP+1:LTEMP+17) = ' PROGRAM ABORTED.'
            LTEMP = LTEMP + 17
         ELSE
            TEMP(LTEMP+1:LTEMP+19) = ' PROGRAM CONTINUES.'
            LTEMP = LTEMP + 19
         ENDIF
C
         CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
      ENDIF
C
C       NOW SEND OUT THE MESSAGE.
C
      CALL XERPRN (' *  ', -1, MESSG, 72)
C
C       IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER.
C
      IF (LKNTRL .GT. 0) THEN
         WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR
         DO 10 I=16,22
            IF (TEMP(I:I) .NE. ' ') GO TO 20
   10    CONTINUE
C
   20    CALL XERPRN (' *  ', -1, TEMP(1:15) // TEMP(I:23), 72)
      ENDIF
C
C       IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE.
C
      IF (LKNTRL .NE. 0) THEN
         CALL XERPRN (' *  ', -1, ' ', 72)
         CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72)
         CALL XERPRN ('    ',  0, ' ', 72)
      ENDIF
C
C       IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE
C       CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN.
C
   30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN
C
C       THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A
C       FATAL ERROR.  PRINT THE REASON FOR THE ABORT AND THE ERROR
C       SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT.
C
      IF (LKNTRL.GT.0) THEN
         IF (LEVEL .EQ. 1) THEN
            CALL XERPRN
     *         (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72)
         ELSE
            CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72)
         ENDIF
         CALL XERHLT (' ')
      ENDIF
      RETURN
      END
      SUBROUTINE XERHLT (MESSG)
C***BEGIN PROLOGUE  XERHLT
C***SUBSIDIARY
C***PURPOSE  Abort program execution and print error message.
C***LIBRARY   SLATEC (XERROR)
C***CATEGORY  R3C
C***TYPE      ALL (XERHLT-A)
C***KEYWORDS  ERROR, XERROR
C***AUTHOR  JONES, R. E., (SNLA)
C***DESCRIPTION
C
C     Abstract
C        ***Note*** machine dependent routine
C        XERHLT aborts the execution of the program.
C        The error message causing the abort is given in the calling
C        sequence, in case one needs it for printing on a dayfile,
C        for example.
C
C     Description of Parameters
C        MESSG is as in XERROR.
C
C***REFERENCES  JONES R.E., KAHANER D.K., 'XERROR, THE SLATEC ERROR-
C                 HANDLING PACKAGE', SAND82-0800, SANDIA LABORATORIES,
C                 1982.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   790801  DATE WRITTEN as XERABT
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900206  Routine changed from user-callable to subsidiary.  (WRB)
C   900510  Changed calling sequence to delete length of char string
C           Changed subroutine name from XERABT to XERHLT.  (RWC)
C***END PROLOGUE  XERHLT
      CHARACTER*(*) MESSG
C***FIRST EXECUTABLE STATEMENT  XERHLT
      STOP
      END
C*DECK XERPRN
      SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP)
C***BEGIN PROLOGUE  XERPRN
C***SUBSIDIARY
C***PURPOSE  This routine is called by XERMSG to print error messages
C***LIBRARY   SLATEC
C***CATEGORY  R3C
C***TYPE      ALL
C***KEYWORDS  ERROR MESSAGES, PRINTING, XERROR
C***AUTHOR  FONG, KIRBY, (NMFECC AT LLNL)
C***DESCRIPTION
C
C This routine sends one or more lines to each of the (up to five)
C logical units to which error messages are to be sent.  This routine
C is called several times by XERMSG, sometimes with a single line to
C print and sometimes with a (potentially very long) message that may
C wrap around into multiple lines.
C
C PREFIX  Input argument of type CHARACTER.  This argument contains
C         characters to be put at the beginning of each line before
C         the body of the message.  No more than 16 characters of
C         PREFIX will be used.
C
C NPREF   Input argument of type INTEGER.  This argument is the number
C         of characters to use from PREFIX.  If it is negative, the
C         intrinsic function LEN is used to determine its length.  If
C         it is zero, PREFIX is not used.  If it exceeds 16 or if
C         LEN(PREFIX) exceeds 16, only the first 16 characters will be
C         used.  If NPREF is positive and the length of PREFIX is less
C         than NPREF, a copy of PREFIX extended with blanks to length
C         NPREF will be used.
C
C MESSG   Input argument of type CHARACTER.  This is the text of a
C         message to be printed.  If it is a long message, it will be
C         broken into pieces for printing on multiple lines.  Each line
C         will start with the appropriate prefix and be followed by a
C         piece of the message.  NWRAP is the number of characters per
C         piece; that is, after each NWRAP characters, we break and
C         start a new line.  In addition the characters '$$' embedded
C         in MESSG are a sentinel for a new line.  The counting of
C         characters up to NWRAP starts over for each new line.  The
C         value of NWRAP typically used by XERMSG is 72 since many
C         older error messages in the SLATEC Library are laid out to
C         rely on wrap-around every 72 characters.
C
C NWRAP   Input argument of type INTEGER.  This gives the maximum size
C         piece into which to break MESSG for printing on multiple
C         lines.  An embedded '$$' ends a line, and the count restarts
C         at the following character.  If a line break does not occur
C         on a blank (it would split a word) that word is moved to the
C         next line.  Values of NWRAP less than 16 will be treated as
C         16.  Values of NWRAP greater than 132 will be treated as 132.
C         The actual line length will be NPREF + NWRAP after NPREF has
C         been adjusted to fall between 0 and 16 and NWRAP has been
C         adjusted to fall between 16 and 132.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  I1MACH, XGETUA
C***REVISION HISTORY  (YYMMDD)
C   880621  DATE WRITTEN
C   880708  REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF
C           JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK
C           THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE
C           SLASH CHARACTER IN FORMAT STATEMENTS.
C   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMMENS TO
C           STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK
C           LINES TO BE PRINTED.
C   890721  REVISED TO ADD A NEW FEATURE.  A NEGATIVE VALUE OF NPREF
C           CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH.
C   891013  REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH.
C   891214  Prologue converted to Version 4.0 format.  (WRB)
C   900510  Added code to break messages between words.  (RWC)
C***END PROLOGUE  XERPRN
      CHARACTER*(*) PREFIX, MESSG
      INTEGER NPREF, NWRAP
      CHARACTER*148 CBUFF
      INTEGER IU(5), NUNIT
      CHARACTER*2 NEWLIN
      PARAMETER (NEWLIN = '$$')
C***FIRST EXECUTABLE STATEMENT  XERPRN
      CALL XGETUA(IU,NUNIT)
C
C       A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD
C       ERROR MESSAGE UNIT INSTEAD.  I1MACH(4) RETRIEVES THE STANDARD
C       ERROR MESSAGE UNIT.
C
      N = I1MACH(4)
      DO 10 I=1,NUNIT
         IF (IU(I) .EQ. 0) IU(I) = N
   10 CONTINUE
C
C       LPREF IS THE LENGTH OF THE PREFIX.  THE PREFIX IS PLACED AT THE
C       BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING
C       THE REST OF THIS ROUTINE.
C
      IF ( NPREF .LT. 0 ) THEN
         LPREF = LEN(PREFIX)
      ELSE
         LPREF = NPREF
      ENDIF
      LPREF = MIN(16, LPREF)
      IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX
C
C       LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE
C       TIME FROM MESSG TO PRINT ON ONE LINE.
C
      LWRAP = MAX(16, MIN(132, NWRAP))
C
C       SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS.
C
      LENMSG = LEN(MESSG)
      N = LENMSG
      DO 20 I=1,N
         IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30
         LENMSG = LENMSG - 1
   20 CONTINUE
   30 CONTINUE
C
C       IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE.
C
      IF (LENMSG .EQ. 0) THEN
         CBUFF(LPREF+1:LPREF+1) = ' '
         DO 40 I=1,NUNIT
            WRITE(IU(I), '(A)') CBUFF(1:LPREF+1)
   40    CONTINUE
         RETURN
      ENDIF
C
C       SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING
C       STARTS.  FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL.
C       WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT.
C       WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED.
C
C       WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL.  THE
C       INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE
C       OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH
C       OF THE SECOND ARGUMENT.
C
C       THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE
C       FOLLOWING ORDER.  WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER
C       OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT
C       POSITION NEXTC.
C
C       LPIECE .EQ. 0   THE NEW LINE SENTINEL DOES NOT OCCUR IN THE
C                       REMAINDER OF THE CHARACTER STRING.  LPIECE
C                       SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC,
C                       WHICHEVER IS LESS.
C
C       LPIECE .EQ. 1   THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC:
C                       NEXTC).  LPIECE IS EFFECTIVELY ZERO, AND WE
C                       PRINT NOTHING TO AVOID PRODUCING UNNECESSARY
C                       BLANK LINES.  THIS TAKES CARE OF THE SITUATION
C                       WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF
C                       EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE
C                       SENTINEL FOLLOWED BY MORE CHARACTERS.  NEXTC
C                       SHOULD BE INCREMENTED BY 2.
C
C       LPIECE .GT. LWRAP+1  REDUCE LPIECE TO LWRAP.
C
C       ELSE            THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1
C                       RESET LPIECE = LPIECE-1.  NOTE THAT THIS
C                       PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ.
C                       LWRAP+1.  THAT IS, THE SENTINEL FALLS EXACTLY
C                       AT THE END OF A LINE.
C
      NEXTC = 1
   50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN)
      IF (LPIECE .EQ. 0) THEN
C
C       THERE WAS NO NEW LINE SENTINEL FOUND.
C
         IDELTA = 0
         LPIECE = MIN(LWRAP, LENMSG+1-NEXTC)
         IF (LPIECE .LT. LENMSG+1-NEXTC) THEN
            DO 52 I=LPIECE+1,2,-1
               IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN
                  LPIECE = I-1
                  IDELTA = 1
                  GOTO 54
               ENDIF
   52       CONTINUE
         ENDIF
   54    CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
         NEXTC = NEXTC + LPIECE + IDELTA
      ELSEIF (LPIECE .EQ. 1) THEN
C
C       WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1).
C       DON'T PRINT A BLANK LINE.
C
         NEXTC = NEXTC + 2
         GO TO 50
      ELSEIF (LPIECE .GT. LWRAP+1) THEN
C
C       LPIECE SHOULD BE SET DOWN TO LWRAP.
C
         IDELTA = 0
         LPIECE = LWRAP
         DO 56 I=LPIECE+1,2,-1
            IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN
               LPIECE = I-1
               IDELTA = 1
               GOTO 58
            ENDIF
   56    CONTINUE
   58    CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
         NEXTC = NEXTC + LPIECE + IDELTA
      ELSE
C
C       IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1.
C       WE SHOULD DECREMENT LPIECE BY ONE.
C
         LPIECE = LPIECE - 1
         CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
         NEXTC  = NEXTC + LPIECE + 2
      ENDIF
C
C       PRINT
C
      DO 60 I=1,NUNIT
         WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE)
   60 CONTINUE
C
      IF (NEXTC .LE. LENMSG) GO TO 50
      RETURN
      END
C*DECK XGETUA
      SUBROUTINE XGETUA (IUNITA, N)
C***BEGIN PROLOGUE  XGETUA
C***PURPOSE  Return unit number(s) to which error messages are being
C            sent.
C***LIBRARY   SLATEC (XERROR)
C***CATEGORY  R3C
C***TYPE      ALL (XGETUA-A)
C***KEYWORDS  ERROR, XERROR
C***AUTHOR  JONES, R. E., (SNLA)
C             Modified by
C           FRITSCH, F. N., (LLNL)
C***DESCRIPTION
C
C     Abstract
C        XGETUA may be called to determine the unit number or numbers
C        to which error messages are being sent.
C        These unit numbers may have been set by a call to XSETUN,
C        or a call to XSETUA, or may be a default value.
C
C     Description of Parameters
C      --Output--
C        IUNIT - an array of one to five unit numbers, depending
C                on the value of N.  A value of zero refers to the
C                default unit, as defined by the I1MACH machine
C                constant routine.  Only IUNIT(1),...,IUNIT(N) are
C                defined by XGETUA.  The values of IUNIT(N+1),...,
C                IUNIT(5) are not defined (for N .LT. 5) or altered
C                in any way by XGETUA.
C        N     - the number of units to which copies of the
C                error messages are being sent.  N will be in the
C                range from 1 to 5.
C
C     CAUTION:  The use of COMMON in this version is not safe for
C               multiprocessing.
C
C***REFERENCES  JONES R.E., KAHANER D.K., 'XERROR, THE SLATEC ERROR-
C                 HANDLING PACKAGE', SAND82-0800, SANDIA LABORATORIES,
C                 1982.
C***ROUTINES CALLED  (NONE)
C***COMMON BLOCKS    XERUNI
C***REVISION HISTORY  (YYMMDD)
C   790801  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   901011  Rewritten to not use J4SAVE.  (FNF)
C   901012  Corrected initialization problem.  (FNF)
C***END PROLOGUE  XGETUA
      DIMENSION IUNITA(5)
      INTEGER  NUNIT, IUNIT(5)
      COMMON /XERUNI/ NUNIT, IUNIT
C***FIRST EXECUTABLE STATEMENT  XGETUA
C       Initialize so XERMSG will use standard error unit number if
C       block has not been set up by a CALL XSETUA.
C       CAUTION:  This assumes uninitialized COMMON tests .LE.0 .
      IF (NUNIT.LE.0) THEN
         NUNIT = 1
         IUNIT(1) = 0
      ENDIF
      N = NUNIT
      DO 30 I=1,N
         IUNITA(I) = IUNIT(I)
   30 CONTINUE
      RETURN
      END
C*DECK XSETUA
      SUBROUTINE XSETUA (IUNITA, N)
C***BEGIN PROLOGUE  XSETUA
C***PURPOSE  Set logical unit numbers (up to 5) to which error
C            messages are to be sent.
C***LIBRARY   SLATEC (XERROR)
C***CATEGORY  R3B
C***TYPE      ALL (XSETUA-A)
C***KEYWORDS  ERROR, XERROR
C***AUTHOR  JONES, R. E., (SNLA)
C             Modified by
C           FRITSCH, F. N., (LLNL)
C***DESCRIPTION
C
C     Abstract
C        XSETUA may be called to declare a list of up to five
C        logical units, each of which is to receive a copy of
C        each error message processed by this package.
C        The purpose of XSETUA is to allow simultaneous printing
C        of each error message on, say, a main output file,
C        an interactive terminal, and other files such as graphics
C        communication files.
C
C     Description of Parameters
C      --Input--
C        IUNIT - an array of up to five unit numbers.
C                Normally these numbers should all be different
C                (but duplicates are not prohibited.)
C        N     - the number of unit numbers provided in IUNIT
C                must have 1 .LE. N .LE. 5.
C
C     CAUTION:  The use of COMMON in this version is not safe for
C               multiprocessing.
C
C***REFERENCES  JONES R.E., KAHANER D.K., 'XERROR, THE SLATEC ERROR-
C                 HANDLING PACKAGE', SAND82-0800, SANDIA LABORATORIES,
C                 1982.
C***ROUTINES CALLED  XERMSG
C***COMMON BLOCKS    XERUNI
C***REVISION HISTORY  (YYMMDD)
C   790801  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900510  Change call to XERRWV to XERMSG.  (RWC)
C   901011  Rewritten to not use J4SAVE.  (FNF)
C***END PROLOGUE  XSETUA
      DIMENSION IUNITA(5)
      INTEGER  NUNIT, IUNIT(5)
      COMMON /XERUNI/ NUNIT, IUNIT
      CHARACTER *8 XERN1
C***FIRST EXECUTABLE STATEMENT  XSETUA
C
      IF (N.LT.1 .OR. N.GT.5) THEN
         WRITE (XERN1, '(I8)') N
         CALL XERMSG ('SLATEC', 'XSETUA',
     *      'INVALID NUMBER OF UNITS, N = ' // XERN1, 1, 2)
         RETURN
      ENDIF
C
      DO 10 I=1,N
         IUNIT(I) = IUNITA(I)
   10 CONTINUE
      NUNIT = N
      RETURN
      END
C
C#######################################################################
C
C DASUSE : contains the routine
C          I1MACH to get the standard error message unit (6).
C             (also available from Netlib: send i1mach from core)
C          R1MACH to determine machine precision, uses value determined
C             by MACHAR
C             (also available from Netlib: send r1mach from core)
C          and the dummies for the routines SGEFA and SGESL from LINPACK
C             (available from Netlib: send sgefa/sgesl from linpack)
C
C#######################################################################
C
      INTEGER FUNCTION I1MACH(IDUM)
      INTEGER IDUM
C
C  I/O UNIT NUMBERS.
C
C    I1MACH( 4) = THE STANDARD ERROR MESSAGE UNIT.

      I1MACH = 6
      RETURN
C----------------------- END OF FUNCTION I1MACH ------------------------
      END
      REAL FUNCTION R1MACH (IDUM)
      INTEGER IDUM
C-----------------------------------------------------------------------
C This routine returns the unit roundoff of the machine in single
C precision as computed by MACHAR and stored in SRELPR in the routine
C SETSKM.
C-----------------------------------------------------------------------
      INTEGER NERR
      REAL SRELPR
      COMMON /MACH/ NERR, SRELPR

      R1MACH = SRELPR
      RETURN
C----------------------- END OF FUNCTION R1MACH ------------------------
      END
      SUBROUTINE SGEFA
      RETURN
      END
      SUBROUTINE SGESL
      RETURN
      END
C
C#######################################################################
C
C DASLIP : LINPACK routines needed by DASSL
C          (available from Netlib: send sgbfa/sgbsl from linpack)
C
C#######################################################################
C
      subroutine sgbfa(abd,lda,n,ml,mu,ipvt,info)
      integer lda,n,ml,mu,ipvt(1),info
      real abd(lda,1)
c
c     sgbfa factors a real band matrix by elimination.
c
c     sgbfa is usually called by sgbco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c
c     on entry
c
c        abd     real(lda, n)
c                contains the matrix in band storage.  the columns
c                of the matrix are stored in the columns of  abd  and
c                the diagonals of the matrix are stored in rows
c                ml+1 through 2*ml+mu+1 of  abd .
c                see the comments below for details.
c
c        lda     integer
c                the leading dimension of the array  abd .
c                lda must be .ge. 2*ml + mu + 1 .
c
c        n       integer
c                the order of the original matrix.
c
c        ml      integer
c                number of diagonals below the main diagonal.
c                0 .le. ml .lt. n .
c
c        mu      integer
c                number of diagonals above the main diagonal.
c                0 .le. mu .lt. n .
c                more efficient if  ml .le. mu .
c     on return
c
c        abd     an upper triangular matrix in band storage and
c                the multipliers which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if  u(k,k) .eq. 0.0 .  this is not an error
c                     condition for this subroutine, but it does
c                     indicate that sgbsl will divide by zero if
c                     called.  use  rcond  in sgbco for a reliable
c                     indication of singularity.
c
c     band storage
c
c           if  a  is a band matrix, the following program segment
c           will set up the input.
c
c                   ml = (band width below the diagonal)
c                   mu = (band width above the diagonal)
c                   m = ml + mu + 1
c                   do 20 j = 1, n
c                      i1 = max0(1, j-mu)
c                      i2 = min0(n, j+ml)
c                      do 10 i = i1, i2
c                         k = i - j + m
c                         abd(k,j) = a(i,j)
c                10    continue
c                20 continue
c
c           this uses rows  ml+1  through  2*ml+mu+1  of  abd .
c           in addition, the first  ml  rows in  abd  are used for
c           elements generated during the triangularization.
c           the total number of rows needed in  abd  is  2*ml+mu+1 .
c           the  ml+mu by ml+mu  upper left triangle and the
c           ml by ml  lower right triangle are not referenced.
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas saxpy,sscal,isamax
c     fortran max0,min0
c
c     internal variables
c
      real t
      integer i,isamax,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1
c
c
      m = ml + mu + 1
      info = 0
c
c     zero initial fill-in columns
c
      j0 = mu + 2
      j1 = min0(n,m) - 1
      if (j1 .lt. j0) go to 30
      do 20 jz = j0, j1
         i0 = m + 1 - jz
         do 10 i = i0, ml
            abd(i,jz) = 0.0e0
   10    continue
   20 continue
   30 continue
      jz = j1
      ju = 0
c
c     gaussian elimination with partial pivoting
c
      nm1 = n - 1
      if (nm1 .lt. 1) go to 130
      do 120 k = 1, nm1
         kp1 = k + 1
c
c        zero next fill-in column
c
         jz = jz + 1
         if (jz .gt. n) go to 50
         if (ml .lt. 1) go to 50
            do 40 i = 1, ml
               abd(i,jz) = 0.0e0
   40       continue
   50    continue
c
c        find l = pivot index
c
         lm = min0(ml,n-k)
         l = isamax(lm+1,abd(m,k),1) + m - 1
         ipvt(k) = l + k - m
c
c        zero pivot implies this column already triangularized
c
         if (abd(l,k) .eq. 0.0e0) go to 100
c
c           interchange if necessary
c
            if (l .eq. m) go to 60
               t = abd(l,k)
               abd(l,k) = abd(m,k)
               abd(m,k) = t
   60       continue
c
c           compute multipliers
c
            t = -1.0e0/abd(m,k)
            call sscal(lm,t,abd(m+1,k),1)
c
c           row elimination with column indexing
c
            ju = min0(max0(ju,mu+ipvt(k)),n)
            mm = m
            if (ju .lt. kp1) go to 90
            do 80 j = kp1, ju
               l = l - 1
               mm = mm - 1
               t = abd(l,j)
               if (l .eq. mm) go to 70
                  abd(l,j) = abd(mm,j)
                  abd(mm,j) = t
   70          continue
               call saxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1)
   80       continue
   90       continue
         go to 110
  100    continue
            info = k
  110    continue
  120 continue
  130 continue
      ipvt(n) = n
      if (abd(m,n) .eq. 0.0e0) info = n
      return
      end
      subroutine sscal(n,sa,sx,incx)
c
c     scales a vector by a constant.
c     uses unrolled loops for increment equal to 1.
c     jack dongarra, linpack, 3/11/78.
c     modified to correct problem with negative increments, 9/29/88.
c
      real sa,sx(1)
      integer i,ix,incx,m,mp1,n
c
      if(n.le.0)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      do 10 i = 1,n
        sx(ix) = sa*sx(ix)
        ix = ix + incx
   10 continue
      return
c
c        code for increment equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        sx(i) = sa*sx(i)
   30 continue
      if( n .lt. 5 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        sx(i) = sa*sx(i)
        sx(i + 1) = sa*sx(i + 1)
        sx(i + 2) = sa*sx(i + 2)
        sx(i + 3) = sa*sx(i + 3)
        sx(i + 4) = sa*sx(i + 4)
   50 continue
      return
      end
      subroutine saxpy(n,sa,sx,incx,sy,incy)
c
c     constant times a vector plus a vector.
c     uses unrolled loop for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      real sx(1),sy(1),sa
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if (sa .eq. 0.0) return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        sy(iy) = sy(iy) + sa*sx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,4)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        sy(i) = sy(i) + sa*sx(i)
   30 continue
      if( n .lt. 4 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,4
        sy(i) = sy(i) + sa*sx(i)
        sy(i + 1) = sy(i + 1) + sa*sx(i + 1)
        sy(i + 2) = sy(i + 2) + sa*sx(i + 2)
        sy(i + 3) = sy(i + 3) + sa*sx(i + 3)
   50 continue
      return
      end
      subroutine sgbsl(abd,lda,n,ml,mu,ipvt,b,job)
      integer lda,n,ml,mu,ipvt(1),job
      real abd(lda,1),b(1)
c
c     sgbsl solves the real band system
c     a * x = b  or  trans(a) * x = b
c     using the factors computed by sgbco or sgbfa.
c
c     on entry
c
c        abd     real(lda, n)
c                the output from sgbco or sgbfa.
c
c        lda     integer
c                the leading dimension of the array  abd .
c
c        n       integer
c                the order of the original matrix.
c
c        ml      integer
c                number of diagonals below the main diagonal.
c
c        mu      integer
c                number of diagonals above the main diagonal.
c
c        ipvt    integer(n)
c                the pivot vector from sgbco or sgbfa.
c
c        b       real(n)
c                the right hand side vector.
c
c        job     integer
c                = 0         to solve  a*x = b ,
c                = nonzero   to solve  trans(a)*x = b , where
c                            trans(a)  is the transpose.
c
c     on return
c
c        b       the solution vector  x .
c
c     error condition
c
c        a division by zero will occur if the input factor contains a
c        zero on the diagonal.  technically this indicates singularity
c        but it is often caused by improper arguments or improper
c        setting of lda .  it will not occur if the subroutines are
c        called correctly and if sgbco has set rcond .gt. 0.0
c        or sgbfa has set info .eq. 0 .
c
c     to compute  inverse(a) * c  where  c  is a matrix
c     with  p  columns
c           call sgbco(abd,lda,n,ml,mu,ipvt,rcond,z)
c           if (rcond is too small) go to ...
c           do 10 j = 1, p
c              call sgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0)
c        10 continue
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas saxpy,sdot
c     fortran min0
c
c     internal variables
c
      real sdot,t
      integer k,kb,l,la,lb,lm,m,nm1
c
      m = mu + ml + 1
      nm1 = n - 1
      if (job .ne. 0) go to 50
c
c        job = 0 , solve  a * x = b
c        first solve l*y = b
c
         if (ml .eq. 0) go to 30
         if (nm1 .lt. 1) go to 30
            do 20 k = 1, nm1
               lm = min0(ml,n-k)
               l = ipvt(k)
               t = b(l)
               if (l .eq. k) go to 10
                  b(l) = b(k)
                  b(k) = t
   10          continue
               call saxpy(lm,t,abd(m+1,k),1,b(k+1),1)
   20       continue
   30    continue
c
c        now solve  u*x = y
c
         do 40 kb = 1, n
            k = n + 1 - kb
            b(k) = b(k)/abd(m,k)
            lm = min0(k,m) - 1
            la = m - lm
            lb = k - lm
            t = -b(k)
            call saxpy(lm,t,abd(la,k),1,b(lb),1)
   40    continue
      go to 100
   50 continue
c
c        job = nonzero, solve  trans(a) * x = b
c        first solve  trans(u)*y = b
c
         do 60 k = 1, n
            lm = min0(k,m) - 1
            la = m - lm
            lb = k - lm
            t = sdot(lm,abd(la,k),1,b(lb),1)
            b(k) = (b(k) - t)/abd(m,k)
   60    continue
c
c        now solve trans(l)*x = y
c
         if (ml .eq. 0) go to 90
         if (nm1 .lt. 1) go to 90
            do 80 kb = 1, nm1
               k = n - kb
               lm = min0(ml,n-k)
               b(k) = b(k) + sdot(lm,abd(m+1,k),1,b(k+1),1)
               l = ipvt(k)
               if (l .eq. k) go to 70
                  t = b(l)
                  b(l) = b(k)
                  b(k) = t
   70          continue
   80       continue
   90    continue
  100 continue
      return
      end
      real function sdot(n,sx,incx,sy,incy)
c
c     forms the dot product of two vectors.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      real sx(1),sy(1),stemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      stemp = 0.0e0
      sdot = 0.0e0
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        stemp = stemp + sx(ix)*sy(iy)
        ix = ix + incx
        iy = iy + incy
   10 continue
      sdot = stemp
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        stemp = stemp + sx(i)*sy(i)
   30 continue
      if( n .lt. 5 ) go to 60
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        stemp = stemp + sx(i)*sy(i) + sx(i + 1)*sy(i + 1) +
     *   sx(i + 2)*sy(i + 2) + sx(i + 3)*sy(i + 3) + sx(i + 4)*sy(i + 4)
   50 continue
   60 sdot = stemp
      return
      end
      integer function isamax(n,sx,incx)
c
c     finds the index of element having max. absolute value.
c     jack dongarra, linpack, 3/11/78.
c     modified to correct problem with negative increments, 9/29/88.
c
      real sx(1),smax
      integer i,incx,ix,n
c
      isamax = 0
      if( n .lt. 1 ) return
      isamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      smax = abs(sx(ix))
      ix = ix + incx
      do 10 i = 2,n
         if(abs(sx(ix)).le.smax) go to 5
         isamax = i
         smax = abs(sx(ix))
    5    ix = ix + incx
   10 continue
      return
c
c        code for increment equal to 1
c
   20 smax = abs(sx(1))
      do 30 i = 2,n
         if(abs(sx(i)).le.smax) go to 30
         isamax = i
         smax = abs(sx(i))
   30 continue
      return
      end
C***********************************************************************
C
C                     Double Precision files
C
C***********************************************************************
C
C Contains, separated by a C######## line, the following files:
C ------------------------------------------------------------
C PRBBAK : problem dependent routines for first example problem
C PRBCYL : problem dependent routines for second example problem
C PRBDSH : problem dependent routines for third example problem
C          (Burgers' equation)
C DRIVER : test program to use the moving-grid interface in a DASSL
C          environment
C SPMDIF : moving-grid interface routines
C MACHAR : MACHAR routine from W.J. Cody
C          (available from Netlib: send machar from elefunt)
C DDASSL : DASSL DAE integrator from L.R. Petzold
C          (available from Netlib: send ddassl from ode)
C          NB. DASSL needs the following files:
C DASUSE : contains the routine
C          I1MACH to get the standard error message unit (6).
C             (also available from Netlib: send i1mach from core)
C          D1MACH to determine machine precision, uses value determined
C             by MACHAR
C             (also available from Netlib: send d1mach from core)
C          and the dummies for the routines DGEFA and DGESL from LINPACK
C             (available from Netlib: send dgefa/dgesl from linpack)
C DASLIP : LINPACK routines needed by DASSL
C          (available from Netlib: send dgbfa/dgbsl from linpack)
C
C
C Of the next three problem dependent files only one should be loaded
C
C#######################################################################
C
C PRBBAK : problem dependent routines for first example problem
C
C#######################################################################
C
      SUBROUTINE INIPRB (TEXT)
      CHARACTER TEXT*80
C
C   Initialize /PROBLM/
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      DOUBLE PRECISION XL, XR, T0, TE
      DOUBLE PRECISION DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT
C
      INTEGER M
      DOUBLE PRECISION EPS, P, ETA
      DATA EPS /0.143/, ETA /17.19/, P /0.1743/
C
      NPDE = 2
      M    = 0
      XL   = 0.0
      XR   = 1.0
      T0   = 0.0
      TE   = 4.0
      ANAJAC = .FALSE.
      SOLAV  = .FALSE.
      NPRINT = 10
      TPRINT(1) = 1.0E-4
      TPRINT(2) = 1.0E-3
      TPRINT(3) = 1.0E-2
      TPRINT(4) = 0.1
      TPRINT(5) = 0.25
      TPRINT(6) = 0.5
      TPRINT(7) = 1.0
      TPRINT(8) = 2.0
      TPRINT(9) = 3.0
      TPRINT(10) = 4.0

      TEXT = ' Bakker, Electrodynamics problem'
      WRITE(TEXT(33:80),'(6H; EPS=,F5.3,4H, P=,F6.4,6H, ETA=,F5.2)')
     +     EPS, P, ETA

      DUMPRO(1) = M
      DUMPRO(2) = EPS
      DUMPRO(3) = P
      DUMPRO(4) = ETA

      RETURN
      END
      SUBROUTINE UINIT (NPDE, NPTS, Y)
C
C Routine for PDE initial values.
C Entry:
C   Y(NPDE+1,i) = x_i; uniform mesh, generated by package
C Exit:
C   Y(NPDE+1,i) = x_i; mesh, optionally changed by user
C   Y(     k,i) = u_k(x_i,t0); initial value of k-th component
C                                  i = 1,.., NPTS
C
      INTEGER NPDE, NPTS
      DOUBLE PRECISION Y(NPDE+1,NPTS)

      INTEGER I

      DO 10 I = 1, NPTS
         Y(1,I) = 1.0
         Y(2,I) = 0.0
   10 CONTINUE

      RETURN
      END
      SUBROUTINE SPDEF (T, X, NPDE, U, DUDX, C, Q, R, IRES)
C
C Routine to describe the body of the PDE system.
C The PDE is written as
C   NPDE               k                    -m   m
C   sum C  (x,t,u,u ) u  + Q (x,t,u,u )  = x   (x  R (x,t,u,u ) )
C   k=1  jk        x   t    j        x              j        x   x
C the functions C, Q and R must be defined in this routine.
C
      INTEGER NPDE, IRES
      DOUBLE PRECISION T, X
      DOUBLE PRECISION U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE),
     +     R(NPDE)

      INTEGER J, K
      DOUBLE PRECISION EPS, ETA, GZ, P, Z
      DATA EPS /0.143/, ETA /17.19/, P /0.1743/

      DO 10 K = 1, NPDE
         DO 20 J = 1, NPDE
            C(J,K) = 0.0
   20    CONTINUE
         C(K,K) = 1.0
   10 CONTINUE

      Z  = U(1) - U(2)
      GZ = EXP(ETA*Z/3) - EXP(-2*ETA*Z/3)
      Q(1) =  GZ
      Q(2) = -GZ

      R(1) = EPS*P * DUDX(1)
      R(2) =     P * DUDX(2)

      RETURN
      END
      SUBROUTINE BNDR (T, BETA, GAMMA, U, DUDX, NPDE, LEFT, IRES)
C
C Boundary conditions routine
C The boundary conditions are written as
C   BETA (x,t) R (x,t,u,u ) = GAMMA (x,t,u,u )
C       j       j        x         j        x
C The functions BETA and GAMMA should be defined in this routine.
C
      INTEGER NPDE, IRES
      LOGICAL LEFT
      DOUBLE PRECISION T
      DOUBLE PRECISION BETA(NPDE), GAMMA(NPDE), U(NPDE), DUDX(NPDE)

      IF (LEFT) THEN
         BETA (1) = 1.0
         GAMMA(1) = 0.0
         BETA (2) = 0.0
         GAMMA(2) = U(2)
      ELSE
         BETA (1) = 0.0
         GAMMA(1) = U(1) - 1.0
         BETA (2) = 1.0
         GAMMA(2) = 0.0
      ENDIF

      RETURN
      END
      SUBROUTINE UEXACT (X, T, U)
      DOUBLE PRECISION X, T
      DOUBLE PRECISION U(*)
C
      RETURN
      END
C
C#######################################################################
C
C PRBCYL : problem dependent routines for second example problem
C
C#######################################################################
C
      SUBROUTINE INIPRB (TEXT)
      CHARACTER TEXT*80
C
C   Initialize /PROBLM/
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      DOUBLE PRECISION XL, XR, T0, TE
      DOUBLE PRECISION DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT
C
      INTEGER I, M
      DOUBLE PRECISION ALPHA, BETA, GAMMA, EPS
C
      NPDE = 1
      M    = 1
      XL   = 0.0
      XR   = 1.0
      T0   = 0.0
      TE   = 1.0
      ANAJAC = .FALSE.
      SOLAV  = .FALSE.
      NPRINT = 10
      DO 10 I = 1, NPRINT
         TPRINT(I) = 0.1*I
   10 CONTINUE

      ALPHA = 1.0
      BETA  = 0.0001
      GAMMA = 1.0
      EPS   = 0.1
      TEXT = ' Reaction-diffusion prob. in cyl. coord.; pars:'
      WRITE(TEXT(48:80),'(4F8.5)') ALPHA, BETA, GAMMA, EPS

      DUMPRO(1) = M
      DUMPRO(2) = ALPHA
      DUMPRO(3) = BETA
      DUMPRO(4) = GAMMA
      DUMPRO(5) = EPS

      RETURN
      END
      SUBROUTINE UINIT (NPD, NPTS, Y)
C
C Routine for PDE initial values.
C Entry:
C   Y(NPDE+1,i) = x_i; uniform mesh, generated by package
C Exit:
C   Y(NPDE+1,i) = x_i; mesh, optionally changed by user
C   Y(     k,i) = u_k(x_i,t0); initial value of k-th component
C                                  i = 1,.., NPTS
C
      INTEGER NPD, NPTS
      DOUBLE PRECISION Y(NPDE+1,NPTS)
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      DOUBLE PRECISION XL, XR, T0, TE
      DOUBLE PRECISION DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT
C
      INTEGER I

      DO 10 I = 1, NPTS
         Y(1,I) = 0.0
   10 CONTINUE

      RETURN
      END
      SUBROUTINE SPDEF (T,X, NPD, U, DUDX, C, Q, R, IRES)
C
C Routine to describe the body of the PDE system.
C The PDE is written as
C   NPDE               k                    -m   m
C   sum C  (x,t,u,u ) u  + Q (x,t,u,u )  = x   (x  R (x,t,u,u ) )
C   k=1  jk        x   t    j        x              j        x   x
C the functions C, Q and R must be defined in this routine.
C
      INTEGER NPD, IRES
      DOUBLE PRECISION T, X
      DOUBLE PRECISION U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE),
     +     R(NPDE)
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      DOUBLE PRECISION XL, XR, T0, TE
      DOUBLE PRECISION DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT

      DOUBLE PRECISION ALPHA, BETA, GAMMA, EPS
C
      ALPHA = DUMPRO(2)
      BETA  = DUMPRO(3)
      GAMMA = DUMPRO(4)
      EPS   = DUMPRO(5)

      C(1,1) = ALPHA
      Q(1) = -GAMMA*EXP(U(1)/(1+EPS*U(1)))
      R(1) = BETA*DUDX(1)

      RETURN
      END
      SUBROUTINE BNDR (T, BETA, GAMMA, U, DUDX, NPD, LEFT, IRES)
C
C Boundary conditions routine
C The boundary conditions are written as
C   BETA (x,t) R (x,t,u,u ) = GAMMA (x,t,u,u )
C       j       j        x         j        x
C The functions BETA and GAMMA should be defined in this routine.
C
      INTEGER NPD, IRES
      LOGICAL LEFT
      DOUBLE PRECISION T
      DOUBLE PRECISION BETA(NPDE), GAMMA(NPDE), U(NPDE), DUDX(NPDE)
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      DOUBLE PRECISION XL, XR, T0, TE
      DOUBLE PRECISION DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT
C
      IF (LEFT) THEN
         BETA(1)  = 1.0
         GAMMA(1) = 0.0
      ELSE
         BETA(1)  = 0.0
         GAMMA(1) = U(1) - 0.0
      ENDIF

      RETURN
      END
      SUBROUTINE UEXACT (X, T, U)
C
C Exact solution
C
      DOUBLE PRECISION X, T
      DOUBLE PRECISION U(*)

      RETURN
      END
C
C#######################################################################
C
C PRBDSH : problem dependent routines for third example problem
C          (Burgers' equation)
C
C#######################################################################
C
      SUBROUTINE INIPRB (TEXT)
      CHARACTER TEXT*80
C
C ----------------------------------------------------------------------
C
C Burgers' equation
C    u_t = -u.u_x + eps.u_xx,   0 < x < 1,   t > 0
C    Dirichlet boundary conditions
C Exact solution available (see SUBROUTINE UEXACT)
C
C ----------------------------------------------------------------------
C
C   Initialize /PROBLM/
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      DOUBLE PRECISION XL, XR, T0, TE
      DOUBLE PRECISION DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT
C
      INTEGER M
      DOUBLE PRECISION EPS
C
      NPDE = 1
      M  = 0
      XL = 0.0
      XR = 1.0
      T0 = 0.0
      TE = 1.0
      ANAJAC = .FALSE.
      SOLAV  = .TRUE.
      NPRINT = 3
      TPRINT(1) = 0.25
      TPRINT(2) = 0.55
      TPRINT(3) = 1.0

      EPS = 1E-3
      TEXT = ' Burgers, double wave, eps='
      WRITE(TEXT(28:80),'(F7.5)') EPS

      DUMPRO(1) = M
      DUMPRO(2) = EPS

      RETURN
      END
      SUBROUTINE UINIT (NPD, NPTS, Y)
C
C Routine for PDE initial values.
C Entry:
C   Y(NPDE+1,i) = x_i; uniform mesh, generated by package
C Exit:
C   Y(NPDE+1,i) = x_i; mesh, optionally changed by user
C   Y(     k,i) = u_k(x_i,t0); initial value of k-th component
C                                  i = 1,.., NPTS
C
      INTEGER NPD, NPTS
      DOUBLE PRECISION Y(NPDE+1,NPTS)
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      DOUBLE PRECISION XL, XR, T0, TE
      DOUBLE PRECISION DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT

      INTEGER I
C
      DO 10 I = 1, NPTS
         CALL UEXACT (Y(NPDE+1,I), T0, Y(1,I))
   10 CONTINUE

      RETURN
      END
      SUBROUTINE SPDEF (T,X, NPD, U, DUDX, C, Q, R, IRES)
C
C Routine to describe the body of the PDE system.
C The PDE is written as
C   NPDE               k                    -m   m
C   sum C  (x,t,u,u ) u  + Q (x,t,u,u )  = x   (x  R (x,t,u,u ) )
C   k=1  jk        x   t    j        x              j        x   x
C the functions C, Q and R must be defined in this routine.
C
      INTEGER NPD, IRES
      DOUBLE PRECISION T, X
      DOUBLE PRECISION U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE),
     +     R(NPDE)
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      DOUBLE PRECISION XL, XR, T0, TE
      DOUBLE PRECISION DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT

      DOUBLE PRECISION EPS

      EPS = DUMPRO(2)

      C(1,1) = 1.0
      Q(1) = U(1)*DUDX(1)
      R(1) = EPS*DUDX(1)

      RETURN
      END
      SUBROUTINE BNDR (T, BETA, GAMMA, U, UX, NPD, LEFT, IRES)
C
C Boundary conditions routine
C The boundary conditions are written as
C   BETA (x,t) R (x,t,u,u ) = GAMMA (x,t,u,u )
C       j       j        x         j        x
C The functions BETA and GAMMA should be defined in this routine.
C
      INTEGER NPD, IRES
      LOGICAL LEFT
      DOUBLE PRECISION T
      DOUBLE PRECISION BETA(NPDE), GAMMA(NPDE), U(NPDE), UX(NPDE)
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      DOUBLE PRECISION XL, XR, T0, TE
      DOUBLE PRECISION DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT
C
      DOUBLE PRECISION X

      IF (LEFT) THEN
         X = XL
      ELSE
         X = XR
      ENDIF
      CALL UEXACT (X, T, GAMMA)
      BETA(1)  = 0.0
      GAMMA(1) = U(1) - GAMMA(1)

      RETURN
      END
      SUBROUTINE UEXACT (X, T, U)
C
C Exact solution
C
      DOUBLE PRECISION X, T
      DOUBLE PRECISION U(NPDE)
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      DOUBLE PRECISION XL, XR, T0, TE
      DOUBLE PRECISION DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT
C
      DOUBLE PRECISION EPS, R1, R2, R3, R123

      EPS = DUMPRO(2)

      R1 = EXP(-(X-0.5)/(20*EPS)-99*T/(400*EPS))
      R2 = EXP(-(X-0.5)/(4*EPS)-3*T/(16*EPS))
      R3 = EXP(-(X-0.375)/(2*EPS))
      R123 = R1+R2+R3
      U(1) = 1.0 - (0.9*R1 + 0.5*R2) / R123

      RETURN
      END
C
C#######################################################################
C
C DRIVER : test program to use the moving-grid interface in a DASSL
C          environment
C
C#######################################################################
C
      PROGRAM DRIVER
C
C ----------------------------------------------------------------------
C
C Main program MoL adaptive grid interface for DASSL
C   Calls problem initializer,
C   Initializes DASSL parameters + grid/solution
C   Put semi-discrete PDE system + Dorfi&Drury grid equation in DASSL
C   Write grid and solution at specific steps (TPRINT) to outputfile
C
C Problem choice by loading the specific problem file with the modules:
C
C     SUBROUTINE INIPRB (TEXT)
C     CHARACTER TEXT*80
C   Initialize /PROBLM/
C
C     SUBROUTINE UINIT (NPDE, NPTS, Y)
C     INTEGER NPDE, NPTS
C     DOUBLE PRECISION Y(NPDE+1,NPTS)
C   Initial solution; optionnally redefinition of (uniform) grid
C
C     SUBROUTINE SPDEF (T,X,NPDE, U, DUDX, C, Q, R, IRES)
C     INTEGER NPDE, IRES
C     DOUBLE PRECISION T, X
C     DOUBLE PRECISION U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE),
C    +     R(NPDE)
C   PDE defining functions C, Q, R
C
C     SUBROUTINE BNDR (T, BETA, GAMMA, U, UX, NPDE, LEFT, IRES)
C     INTEGER NPDE, IRES
C     LOGICAL LEFT
C     DOUBLE PRECISION T
C     DOUBLE PRECISION BETA(NPDE), GAMMA(NPDE), U(NPDE), UX(NPDE)
C   Boundary function
C
C     SUBROUTINE UEXACT (X, T, U)
C     DOUBLE PRECISION X, T
C     DOUBLE PRECISION U(NPDE)
C   Exact solution (only called if SOLAV=TRUE)
C
      INTEGER MXNPDE, MXNEQ, MXLIW, MXLRW, MXNRWK
      PARAMETER (MXNPDE = 2, MXNEQ = 303)
      PARAMETER (MXLIW = 20+MXNEQ, MXLRW = (6*MXNPDE+20)*MXNEQ)
      PARAMETER (MXNRWK = MXNEQ+(6+MXNPDE)*MXNPDE)
      INTEGER INFO(15), IWORK(MXLIW), IPAR(1)
      DOUBLE PRECISION Y(MXNEQ), YPRIME(MXNEQ), RTOL(1), ATOL(1),
     +     RWORK(MXLRW), RWK(MXNRWK)
C
C   Y     : Grid and solution values
C   YPRIME: Derivative of Y
C   INFO  : Task_communication with DASSL
C   RTOL  : Relative tolerance for DASSL
C   ATOL  : Absolute tolerance for DASSL
C   RWORK : (Optional) DOUBLE PRECISION input values for DASSL
C   IWORK : (Optional) INTEGER input values for DASSL
C   RWK   : Workspace SKMRES
C
C COMMONs used:
C
      INTEGER NPTS, LUNR, LUNI
      COMMON /MOLIF/ NPTS, LUNR, LUNI
C
C   NPTS  : # grid points (needed in residual routine)
C   LUNR  : log. unit # output file for results
C   LUNI  : log. unit # run information file
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      DOUBLE PRECISION XL, XR, T0, TE
      DOUBLE PRECISION DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT
C
C NPDE   # partial differential equations
C XL     Left boundary
C XR     Right boundary
C T0     Starting time
C TE     Final time
C DUMPRO Storage reserved for problem parameters
C        DUMPRO(1) = M (space coordinate type)
C ANAJAC TRUE, if user specified Jacobian
C        (SUBROUTINE JAC, see documentation of DAE solver)
C SOLAV  TRUE, if exact solution is available
C        (SUBROUTINE UEXACT)
C TPRINT NPRINT output times
C NPRINT DIMENSION TPRINT
C
      EXTERNAL INIPRB, OUT, RESID, RUNOUT, SETSKM, DDASSL
C
C ---------------------------------------------------------------------
C
      CHARACTER IDENT*30, TEXT*80
      INTEGER I, IBAND, IDID, IPRINT, IRES, LIW, LRW, M, MAXORD, NCTF,
     +        NEQ, NETF, NFCN, NOINV, NRWK, NSTEPS
      DOUBLE PRECISION ALPHA, KAPPA, T, TAU, TOUT
C
C ccc Open files for results and run info
      LUNR = 4
      LUNI = 8
      OPEN (UNIT=LUNR, FILE='RESULT')
      OPEN (UNIT=LUNI, FILE='RUNINF')
C
C   Run identification
      IDENT = 'ACM-TOMS, Ex.I'
C
C ccc Initialize /PROBLM/
      CALL INIPRB (TEXT)
C   TEXT: Problem information
      WRITE(LUNR,'(A80)') TEXT
      WRITE(LUNI,'(A80)') TEXT
C
C ccc Initialize method parameters, grid, solution and derivative at T0
C     DASSL input
C
C   Method parameters; for Burgers equation (PRBDSH file) TAU = 1E-3
      NPTS  = 21
      M     = NINT(DUMPRO(1))
      TAU   = 0.0
      KAPPA = 2.0
      ALPHA = 0.01
      NRWK  = MXNRWK
C
C   Call initialization routine SETSKM; determine initial grid;
C     store initial values of U in Y
      CALL SETSKM (NEQ, NPDE, NPTS, XL,XR, TAU, KAPPA, ALPHA,
     +             Y, RWK, NRWK, M, T0, IBAND, IRES)
      IF (IRES .EQ. -1) THEN
         STOP 'Error in SETSKM'
      ENDIF
C
C   Initial Yprime = 0
      DO 1 I = 1, NEQ
         YPRIME(I) = 0.0
    1 CONTINUE
C
C   Initialize DASSL input
      DO 5 I = 1, 15
         INFO(I) = 0
    5 CONTINUE
C    Both tolerances are scalars (default)
      ATOL(1) = 1E-3
      RTOL(1) = 1E-3
C    Intermediate output mode
      INFO( 3) = 1
C    Analytical Jacobian
      IF (ANAJAC) INFO(5) = 1
C    Banded Jacobian
      INFO( 6) = 1
      IWORK(1) = IBAND
      IWORK(2) = IBAND
C    Default maximum integration order
      MAXORD = 5
C    Y, YPRIME probably inconsistent at T0
      INFO(11) = 1
C
C ccc Check length arrays
      IF (NEQ .GT. MXNEQ) THEN
         PRINT *, 'MXNEQ too small, needed:', NEQ
         STOP 'Workspace too small'
      ENDIF
      LIW = 20+NEQ
      IF (LIW .GT. MXLIW) THEN
         PRINT *, 'MXLIW too small, needed:', LIW
         STOP 'Workspace too small'
      ENDIF
      LRW    = 40+(MAXORD+6+3*IBAND+1)*NEQ + 2*(NEQ/(2*IBAND+1)+1)
      IF (LRW .GT. MXLRW) THEN
         PRINT *, 'MXLRW too small, needed:', LRW
         STOP 'Workspace too small'
      ENDIF
C
C ccc Write run header to files
      TEXT = ' MoL, PDE+D&D int.face; DAE int.: DASSL'
      I = 40
      TEXT(I:80) = ';  ID:'
      WRITE(TEXT(I+6:80),'(A30)') IDENT
      WRITE(LUNR,'(A80)') TEXT
      WRITE(LUNI,'(A80)') TEXT
      I = 1
      TEXT(I:80) = ' NPTS='
      WRITE(TEXT(I+6:I+8),'(I3)') NPTS
      I = I+9
      TEXT(I:I+6) = '; RTOL='
      WRITE(TEXT(I+7:I+14),'(E8.3)') RTOL(1)
      I = I+15
      TEXT(I:I+6) = ', ATOL='
      WRITE(TEXT(I+7:I+14),'(E8.3)') ATOL(1)
      WRITE(LUNR,'(A80)') TEXT
      WRITE(LUNI,'(A80)') TEXT
      I = 1
      TEXT(I:80) = ' TAU='
      WRITE(TEXT(I+5:I+12),'(E8.3)') TAU
      I = I+13
      TEXT(I:I+7) = ', KAPPA='
      WRITE(TEXT(I+8:I+15),'(E8.3)') KAPPA
      I = I+16
      TEXT(I:I+7) = ', ALPHA='
      WRITE(TEXT(I+8:I+15),'(E8.3)') ALPHA
      WRITE(LUNR,'(A80)') TEXT
      WRITE(LUNI,'(A80)') TEXT
C
C
C ccc Write initial grid and solution to output file
      CALL OUT (T0, Y, RWK(1), RWK(NRWK-NPTS+1))
C
C
C
C ccc DASSL loop
C     Call DASSL with as residual routine RESID, the enveloping routine
C     of SKMRES
      T = T0
      DO 10 IPRINT = 1, NPRINT
         TOUT = TPRINT(IPRINT)
   15    CALL DDASSL (RESID, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL,
     +                IDID, RWORK, LRW, IWORK, LIW, RWK, IPAR, JAC)
         IF (IDID .EQ. 1) THEN
C     One step in intermediate-output mode
C
C      Write Run info to file
            CALL RUNOUT(RWORK, IWORK)
C
            GOTO 15
         ENDIF
C
C   Write grid and solution to output file
         CALL OUT(T, Y, RWK(1), RWK(NRWK-NPTS+1))
C
C   Give run statistics until t = TOUT
         NSTEPS = IWORK(11)
         NFCN   = IWORK(12)
         NOINV  = IWORK(13)
C        NOSOLV = NFCN
         NETF   = IWORK(14)
         NCTF   = IWORK(15)
         WRITE(LUNR,*) 'Statistics:'
         WRITE(LUNR,*) '   FNS, JACS:', NFCN, NOINV
         WRITE(LUNR,*) '   STEPS, ETF, CTF:', NSTEPS, NETF, NCTF

         IF (IDID .LT. 0) GOTO 900
   10 CONTINUE

      CLOSE(LUNR)
      CLOSE(LUNI)
      STOP 'Ready'
C
C ccc Error return
  900 CONTINUE
      WRITE(LUNR,*) 'IDID=', IDID
      STOP 'DASSL error'
      END
      SUBROUTINE RESID (T, Y, YPRIME, DELTA, IRES, RWK, IPAR)
      INTEGER IRES
      INTEGER IPAR(*)
      DOUBLE PRECISION T
      DOUBLE PRECISION Y(*), YPRIME(*), DELTA(*), RWK(*)
C
C Determine DAE system for DASSL
C   residual DELTA = A.YPRIME - G
C
C Entry:
C   T     : Current time
C   Y     : Current grid + solution
C   YPRIME: Time derivative of Y
C Exit:
C   DELTA : A.YPRIME - G
C   IRES  : -1, if user thinks solution is illegal or ico node crossing
C
C ---------------------------------------------------------------------
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      DOUBLE PRECISION XL, XR, T0, TE
      DOUBLE PRECISION DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT
C
      INTEGER NPTS, LUNR, LUNI
      COMMON /MOLIF/ NPTS, LUNR, LUNI
C
      SAVE /PROBLM/, /MOLIF/
C
C
      EXTERNAL SKMRES
C
C ---------------------------------------------------------------------
C
      INTEGER NEQ, NRWK
C
      NEQ  = NPTS*(NPDE+1)
      NRWK = NEQ + (6+NPDE)*NPDE
C
C ccc Call SKMRES with IRES=0 to compute total residual
      CALL SKMRES (NEQ, T, Y, YPRIME, DELTA, IRES, RWK, NRWK)
      IF (IRES .EQ. 2) THEN
         IRES = -2
         RETURN
      ELSE IF (IRES .EQ. 3) THEN
         WRITE(LUNI,999) T
  999      FORMAT(' Illegal solution at T= ', E12.4)
         IRES = -1
         RETURN
      ENDIF
C
      RETURN
      END
      SUBROUTINE OUT (T, Y, UEX, ERR)
      DOUBLE PRECISION T
      DOUBLE PRECISION Y(NPDE+1,NPTS), UEX(NPDE,NPTS), ERR(NPTS)
C
C Write grid, solution and, if possible, error in sol. to output file
C
C Entry:
C   T     : Current time
C   Y     : Current grid + solution
C   UEX   : Workspace to store exact solution
C   UERR  : Workspace to store error for a component in each gridpoint
C
C ---------------------------------------------------------------------
C
      INTEGER NPDE, NPRINT
      LOGICAL ANAJAC, SOLAV
      DOUBLE PRECISION XL, XR, T0, TE
      DOUBLE PRECISION DUMPRO(5), TPRINT(10)
      COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO,
     +                ANAJAC, SOLAV, TPRINT, NPRINT
C
      INTEGER NPTS, LUNR, LUNI
      COMMON /MOLIF/ NPTS, LUNR, LUNI
C
      SAVE /PROBLM/, /MOLIF/
C
      DOUBLE PRECISION INFNRM, L2NRM
      EXTERNAL INFNRM, L2NRM, UEXACT
C
C ----------------------------------------------------------------------
C
      INTEGER NPDEMX
      PARAMETER (NPDEMX = 4)
      INTEGER IC, J, NPDE1
      DOUBLE PRECISION ERRINF
      DOUBLE PRECISION ERRTWO(NPDEMX)
C
      NPDE1 = NPDE+1
      IF (SOLAV) THEN
         DO 1 J = 1, NPTS
            CALL UEXACT(Y(NPDE1,J),T,UEX(1,J))
    1    CONTINUE
      ENDIF

      WRITE(LUNR,'(3H-T=,E13.5)') T
      WRITE(LUNR,*) 'X(S,TN):'
      WRITE(LUNR,'(5E23.14)') (Y(NPDE1,J), J=1, NPTS)
      DO 10 IC = 1, NPDE
         WRITE(LUNR,*) 'U(X(S,TN),TN), COMP:', IC
         WRITE(LUNR,'(5E23.14)') (Y(IC,J), J=1, NPTS)
         IF (SOLAV) THEN
            DO 20 J = 1, NPTS
               ERR(J) = Y(IC,J) - UEX(IC,J)
   20       CONTINUE
            ERRINF     = INFNRM (ERR, NPTS)
            ERRTWO(IC) = L2NRM  (ERR, Y(NPDE1,1), NPDE1, NPTS)
            WRITE(LUNR,*) 'ERR_U:'
            WRITE(LUNR,'(5E23.14)') (ERR(J), J=1, NPTS)
            WRITE(LUNR,*) 'MAX. NORM:', ERRINF
            WRITE(LUNR,*) 'TWO  NORM:', ERRTWO(IC)
         ENDIF
   10 CONTINUE

      RETURN
      END
      SUBROUTINE RUNOUT (RWORK, IWORK)
      INTEGER IWORK(*)
      DOUBLE PRECISION RWORK(*)
C
C Write statistics after each successful step to run info file
C
C Entry:
C   RWORK: DOUBLE PRECISION info DASSL
C   IWORK: INTEGER info DASSL
C
C ---------------------------------------------------------------------
C
      INTEGER NPTS, LUNR, LUNI
      COMMON /MOLIF/ NPTS, LUNR, LUNI
C
      SAVE /MOLIF/
C
C ---------------------------------------------------------------------
C
      INTEGER IQ
      DOUBLE PRECISION H, T
C
      T  = RWORK(4)
      H  = RWORK(7)
      IQ = IWORK(8)
      WRITE (LUNI,'(6H Time=,E13.5, 4H; H=,E13.5, 8H; Order=,I2)')
     +       T, H, IQ

      RETURN
      END
      DOUBLE PRECISION FUNCTION INFNRM (V, N)
      INTEGER N
      DOUBLE PRECISION V(N)
C
C Exit: INFNRM = (J=1,N) MAX !V(J)!
C
C ----------------------------------------------------------------------
C
      INTEGER J
C
      INFNRM = 0.0
      DO 10 J = 1, N
         INFNRM = MAX(INFNRM,ABS(V(J)))
   10 CONTINUE

      RETURN
      END
      DOUBLE PRECISION FUNCTION L2NRM (V, X, INCX, N)
      INTEGER INCX, N
      DOUBLE PRECISION V(N), X(INCX,N)
C
C Exit: L2NRM = SQRT((J=2,N) SUM ((X(J)-X(J-1))/2.(V(J)^2+V(J-1)^2))
C
C ----------------------------------------------------------------------
C
      INTEGER J
      DOUBLE PRECISION VJM1S, VJS
C
      L2NRM = 0.0
      VJM1S = V(1)*V(1)
      DO 10 J = 2, N
         VJS   = V(J)*V(J)
         L2NRM = L2NRM + (X(1,J)-X(1,J-1))/2*(VJS+VJM1S)
         VJM1S = VJS
   10 CONTINUE
      L2NRM = SQRT(L2NRM)

      RETURN
      END
C
C#######################################################################
C
C SPMDIF : moving-grid interface routines
C
C#######################################################################
C
C-----------------------------------------------------------------------
C
C Moving grid discretization module SPMDIF
C ----------------------------------------
C This module discretizes systems of partial differential equations
C in one space variable on a moving grid. The class of equations that
C can be handled is given by
C
C   NPDE                   k                      -m  m
C   sum  C   (x,t, u, u ) u  + Q (x,t, u, u ) =  x  (x  R (x,t, u, u ))
C   k=1   j,k      -  -x   t    j      -  -x             j      -  -x  x
C
C where            1         NPDE T
C           u = ( u , ... , u    )   ,  j = 1,... , NPDE,
C           -
C      k
C and u  is the partial derivative wrt time of the k-th component of u.
C      t
C
C The functions C, Q, and R are assumed to be continuous w.r.t. the
C space variable.
C
C The independent variables x and t satisfy  x  < x < x   with x  and x
C                                             L        R        L      R
C fixed and  t > t .
C                 0
C The boundary conditions have the form
C
C   BETA(x,t).R(x,t,u,u ) = GAMMA(x,t,u,u )  at x = x , x  ,
C                   - -x              - -x           L   R
C
C where not all of the functions BETA and GAMMA are set to zero.
C
C The initial conditions are given by
C                0
C   u (x,t )  = u (x)  for x  <= x <= x .
C   -     0     -           L          R
C The discretization method for the PDE in Lagrangian formulation
C used by this module is based on a lumped Galerkin / Petrov-Galerkin
C method and evaluates the PDE functions in a point between
C the (moving) grid points.
C
C References:
C   Fixed-grid spatial discretization
C            Skeel R.D. and Berzins M.
C            A Method for the Spatial Discretisation of Parabolic
C            Equations in one Space Variable.
C            Leeds Report no 217,
C            Dept. of Computer Studies, The University.
C   Grid movement
C            Verwer J.G., Blom J.G., Furzeland R.M. and Zegeling P.A.
C            A Moving-Grid Method for One-Dimensional PDEs based on
C            the Method of Lines.
C            Report NM-R8818,
C            Centre for Mathematics and Computer Science, Amsterdam.
C   Interface
C            Blom J.G. and Zegeling P.A.
C            A Moving-Grid Interface for Systems of One-Dimensional
C            Time-Dependent Partial Differential Equations.
C            Report NM-R8904,
C            Centre for Mathematics and Computer Science, Amsterdam.
C            (submitted to ACM TOMS)
C
C----------------------------------------------------------------------
C
C How to use this module
C ----------------------
C 1.  Set NPDE = # PDEs to be solved.
C     Set NPTS = # mesh points to be used.
C                (NC=NPTS-2 is # internal points)
C     Set M for space coordinate type
C         = 0 for Cartesian,  = 1 for cylindrical, = 2 for spherical.
C     Specify a workspace of size at least  (NPDE+1)*NPTS+(6+NPDE)*NPDE
C     for use by the routine SKMRES which defines the DAE system being
C     solved by the integrator.
C
C     Call the initialization routine SETSKM, see the documentation at
C     the head of this routine for the precise details of the call.
C
C     Set TS and TOUT for start and end integration times.
C     Initialize data as required for time integration,
C                - see documentation of DAE solver.
C     Call the DAE solver with as residual routine SKMRES or an
C     enveloping routine to satisfy the header requirements.
C
C 2.  Provide a set of routines which describe the precise form of the
C     PDEs to be solved. Three routines must be provided and the names
C     of these routines are fixed. These routines are:
C        SPDEF   forms the functions C, Q and R of the PDE in a
C                given x-point.
C        BNDR    forms the functions BETA and GAMMA associated with the
C                boundary conditions for the PDE.
C        UINIT   supplies the initial values of the PDE part.
C                An initial uniform grid is generated by SETSKM and
C                provided in Y(NPDE+1,I), I=1,NPTS. If required, a user
C                can redefine the mesh in a nonuniform way.
C     The headers of these routines are:
C
C      SUBROUTINE SPDEF (T, X, NPDE, U, DUDX, C, Q, R, IRES)
C      INTEGER NPDE, IRES
C      DOUBLE PRECISION T, X
C      DOUBLE PRECISION U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE),
C     +     R(NPDE)
C
C      SUBROUTINE BNDR (T, BETA, GAMMA, U, DUDX, NPDE, LEFT, IRES)
C      INTEGER NPDE, IRES
C      LOGICAL LEFT
C      DOUBLE PRECISION T
C      DOUBLE PRECISION BETA(NPDE), GAMMA(NPDE), U(NPDE), DUDX(NPDE)
C
C      SUBROUTINE UINIT (NPDE, NPTS, Y)
C      INTEGER NPDE, NPTS
C      DOUBLE PRECISION Y(NPDE+1,NPTS)
C
C
C Example problem
C ---------------
C The easiest way to describe how the problem description routines
C should be written is by a simple example. Consider the following
C problem from electrodynamics
C    u  = eps.p.u   - g(u-v)
C     t          xx
C and                             (so m = 0 and NPDE = 2)
C    v  =     p.v   + g(u-v)
C     t          xx
C with
C    g(z) = exp(eta.z/3) - exp(-2.eta.z/3) ,
C    0 <= x <= 1  and  0 <= t <= 4;
C    eps = 0.143, p = 0.1743, and eta = 17.19.
C
C The left boundary condition (LEFT = .TRUE.) is given by
C    u  = 0  and  v = 0   at x = 0,
C     x
C the right boundary condition (LEFT = .FALSE.) is
C    u = 0  and  v  = 0   at x = 1,
C                 x
C and the initial conditions are
C    u = 1  and  v = 0  at t = 0.
C
C The routines UINIT, SPDEF and BNDR are listed below.
C The component u of the PDE at the i-th grid point is held as Y(1,i)
C in the package, the component v as Y(2,i); the i-th grid point
C itself is stored in Y(3,i).
C
C
C
C     SUBROUTINE UINIT (NPDE, NPTS, Y)
C
C Routine for PDE initial values.
C Entry:
C   Y(NPDE+1,i) = x_i; uniform mesh, generated by package
C Exit:
C   Y(NPDE+1,i) = x_i; mesh, optionally changed by user
C   Y(     k,i) = u_k(x_i,t0); initial value of k-th component
C                                  i = 1,.., NPTS
C
C     INTEGER NPDE, NPTS
C     DOUBLE PRECISION Y(NPDE+1,NPTS)
C
C     INTEGER I
C
C     DO 10 I = 1, NPTS
C        Y(1,I) = 1.0
C        Y(2,I) = 0.0
C  10 CONTINUE
C
C     RETURN
C     END
C
C
C
C     SUBROUTINE SPDEF (T, X, NPDE, U, DUDX, C, Q, R, IRES)
C
C Routine to describe the body of the PDE system.
C The PDE is written as
C   NPDE               k                    -m   m
C   sum C  (x,t,u,u ) u  + Q (x,t,u,u )  = x   (x  R (x,t,u,u ) ) .
C   k=1  jk        x   t    j        x              j        x   x
C The functions C, Q and R must be defined in this routine.
C
C     INTEGER NPDE, IRES
C     DOUBLE PRECISION T, X
C     DOUBLE PRECISION U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE),
C    +     R(NPDE)
C
C     INTEGER J, K
C     DOUBLE PRECISION EPS, ETA, GZ, P, Z
C     DATA EPS /0.143/, ETA /17.19/, P /0.1743/
C
C     DO 10 K = 1, NPDE
C        DO 20 J = 1, NPDE
C           C(J,K) = 0.0
C  20    CONTINUE
C        C(K,K) = 1.0
C  10 CONTINUE
C
C     Z  = U(1) - U(2)
C     GZ = EXP(ETA*Z/3) - EXP(-2*ETA*Z/3)
C     Q(1) =  GZ
C     Q(2) = -GZ
C
C     R(1) = EPS*P * DUDX(1)
C     R(2) =     P * DUDX(2)
C
C     RETURN
C     END
C
C
C
C     SUBROUTINE BNDR (T, BETA, GAMMA, U, DUDX, NPDE, LEFT, IRES)
C
C Boundary conditions routine
C The boundary conditions are written as
C   BETA (x,t) R (x,t,u,u ) = GAMMA (x,t,u,u )
C       j       j        x         j        x
C The functions BETA and GAMMA should be defined in this routine.
C
C     INTEGER NPDE, IRES
C     LOGICAL LEFT
C     DOUBLE PRECISION T
C     DOUBLE PRECISION BETA(NPDE), GAMMA(NPDE), U(NPDE), DUDX(NPDE)
C
C     IF (LEFT) THEN
C        BETA (1) = 1.0
C        GAMMA(1) = 0.0
C        BETA (2) = 0.0
C        GAMMA(2) = U(2)
C     ELSE
C        BETA (1) = 0.0
C        GAMMA(1) = U(1) - 1.0
C        BETA (2) = 1.0
C        GAMMA(2) = 0.0
C     ENDIF
C
C     RETURN
C     END
C
      SUBROUTINE SETSKM (NEQN, NPDE, NPTS, XL, XR, TAU, KAPPA, ALPHA,
     +                   Y, RWK, NRWK, M, TS, IBAND, IRES)
C
C-----------------------------------------------------------------------
C Purpose:
C -------
C Initializing routine for moving-grid spatial discretization.
C
C Parameters:
C ----------
      INTEGER NEQN, NPDE, NPTS, NRWK, M, IBAND, IRES
      DOUBLE PRECISION XL, XR, TAU, KAPPA, ALPHA, TS
      DOUBLE PRECISION Y(*), RWK(NRWK)
C
C NEQN  Exit: the size of the DAE system generated when the PDE +
C       the grid equations are discretized. This value is (NPDE+1).NPTS.
C NPDE  Entry: the number of PDEs.
C NPTS  Entry: the number of spatial mesh points, including the
C       boundary points.
C XL    Entry: left boundary point.
C XR    Entry: right boundary point.
C TAU   Entry: time-smoothing parameter.
C       If the initial grid satisfies the grid equation with TAU=0 at
C       TS=0, TAU can be chosen equal to zero. If this is not the case
C       and if the initial grid has to be adapted, or if time-smoothing
C       is desired a typical value of TAU = 1E-3, but TAU should be
C       related to the time scale of the problem.
C KAPPA Entry: spatial smoothing parameter (DOUBLE PRECISION).
C       KAPPA = 2.0 was found to be satisfying for all problems tested.
C       For less spatial smoothing KAPPA = 1.0 will suffice.
C ALPHA Entry: monitor regularizing parameter.
C       ALPHA = 0.01 is recommended (for a well-scaled system of PDEs)
C Y     Exit: array of length >= (NPDE+1).NPTS that contains the initial
C       (uniformly spaced) grid and the corresponding initial PDE
C       solution values. This array must be passed across as a one-
C       dimensional array of length NEQN to the DAE solver. This
C       array is ordered as
C          PDE comp.  : Y((NPDE+1)*l + j) l=0,...,NPTS-1,
C                                         j=1,...,NPDE
C          grid points: Y((NPDE+1)*(l+1)) l=0,...,NPTS-1.
C RWK   workspace of length NRWK for the residual routine SKMRES which
C       actually performs the semi-discretization of the PDEs and
C       defines the grid equations.
C NRWK  Entry: dimension of workspace RWK.
C       NRWK must be >= (NPDE+1).NPTS + (6+NPDE).NPDE.
C M     Entry: integer >= 0 which determines the coordinate system used.
C          0: Cartesian coordinates,
C          1: cylindrical polar coordinates,
C          2: spherical polar coordinates.
C TS    Entry: the time at which the integration starts.
C IBAND Exit: an upper bound on the half bandwidth of the Jacobian
C       matrix when this module is used. (If the DAE solver is called
C       with banded matrix routines this parameter should be
C       supplied to MATSET (SPRINT) or to DASSL (IWORK(1) and IWORK(2)).
C IRES  Exit: this parameter is set to -1 if an error is found by
C       this routine.
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C
C From here the comments are only meant as aid and assistance to
C understand the program.
C
C Four parameters are passed across from here in
C      COMMON /SPSKM/  NPDE1, NC, M, SING
C
C NPDE1 = NPDE+1   the number of PDEs + 1 (for the grid equation).
C NC    = NPTS-2   the number of internal mesh points.
C M     = M_user   = 0,1,2, if resp., Cartesian, cylindrical or
C                           spherical polar coordinates in use.
C SING  = .TRUE.   if PDE has a polar singularity.
C
C A common block filled with method parameters is initialized
C in this routine
C      COMMON /METPAR/ RTAU, RKAPPA, ALFA
C
C RTAU   time-smoothing parameter grid equation (= TAU)
C RKAPPA spatial smoothing parameter grid equation (= KAPPA)
C ALFA   monitor constant (= ALPHA)
C
C A common block filled with machine constants is also initialized
C in this routine
C      COMMON /MACH/ NERR, SRELPR
C
C NERR   logical unit number of error unit
C SRELPR machine eps as determined by MACHAR
C
C
C Detailed description of workspace:
C ---------------------------------
C Size:  NRWK must be >=  (NPDE+1)*NPTS + (6+NPDE)*NPDE
C
C RWK(  1:.+(NPDE+1)*NPTS) G(NPDE+1,0:NC+1), part of residual not
C                          dependent on time-derivative.
C RWK(IW1:.+ NPDE)         UKSI(NPDE), solution values at evaluat. point
C RWK(IW2:.+ NPDE)         UXKSI(NPDE), space derivs. at evaluat. point
C RWK(IW3:.+ NPDE)         BETA(NPDE), boundary function BETA
C RWK(IW4:.+ NPDE)         GAMMA(NPDE), boundary function GAMMA
C RWK(IW5:.+ NPDE)         RC(NPDE), flux at evaluation point
C RWK(IW6:.+ NPDE)         QC(NPDE), source term at evaluation point
C RWK(IW7:.+ NPDE*NPDE)    CC(NPDE,NPDE), udot factor at evaluat. point
C
C-----------------------------------------------------------------------
C
      CHARACTER*6 PDCODE
      COMMON /DISCHK/ PDCODE
C
      INTEGER NPDE1, NC, MM
      LOGICAL SING
      COMMON /SPSKM/ NPDE1, NC, MM, SING
C
      DOUBLE PRECISION RTAU, RKAPPA, ALFA
      COMMON /METPAR/ RTAU, RKAPPA, ALFA
C
      INTEGER NERR
      DOUBLE PRECISION SRELPR
      COMMON /MACH/ NERR, SRELPR
C
      SAVE   /DISCHK/, /SPSKM/, /METPAR/, /MACH/
C
      EXTERNAL MACHAR, YINIT
C
C-----------------------------------------------------------------------
C
      INTEGER IW1, IW2, IW3, IW4, IW5, IW6, IW7, IWE
      INTEGER IBETA, IT,IRND, NGRD, MACHEP, NEGEP, IEXP, MINEXP,
     +        MAXEXP
      DOUBLE PRECISION EPS, EPSNEG, XMIN, XMAX

      NPDE1 = NPDE+1
      NC = NPTS-2
      MM = M
      SING = M .GE. 1 .AND. ABS(XL) .LE. SRELPR*(XR-XL)

      RTAU   = TAU
      RKAPPA = KAPPA
      ALFA   = ALPHA

      NERR   = 8
      CALL MACHAR (IBETA, IT,IRND, NGRD, MACHEP, NEGEP, IEXP, MINEXP,
     +             MAXEXP, EPS, EPSNEG, XMIN, XMAX)
      SRELPR = MAX (EPS, EPSNEG)

C Fill IBAND; ML = MU=2*NPDE1
      IBAND = 2*NPDE1

      NEQN = NPDE1*NPTS

      IW1 =   1 + NEQN
      IW2 = IW1 + NPDE
      IW3 = IW2 + NPDE
      IW4 = IW3 + NPDE
      IW5 = IW4 + NPDE
      IW6 = IW5 + NPDE
      IW7 = IW6 + NPDE
      IWE = IW7 + NPDE*NPDE - 1
      IF (IWE .GT. NRWK) THEN
         WRITE(NERR,'(38H SETSKM - ERROR REAL WORKSPACE OF SIZE, I10,
     +                28H, IS SMALLER THAN REQUIRED :, I10)') NRWK, IWE
         IRES = -1
      ENDIF
      IF (M .LT. 0) THEN
         WRITE(NERR,'(44H SETSKM - POLAR PARAMETER LESS THAN ZERO, M=,
     +                I10)') M
         IRES = -1
      END IF
      IF (IRES .EQ. -1) RETURN
C
C Initialize grid and PDE variables by appropriate calls.
C
      CALL YINIT (NPDE, NPTS, XL, XR, Y)
C
      PDCODE = 'SPSKLM'

      RETURN
      END
      SUBROUTINE YINIT (NPDE, NPTS, XL, XR, Y)
      INTEGER NPDE, NPTS
      DOUBLE PRECISION XL, XR
      DOUBLE PRECISION Y(NPDE+1,0:NPTS-1)
C
      INTEGER NPDE1, NC, M
      LOGICAL SING
      COMMON /SPSKM/ NPDE1, NC, M, SING
      SAVE   /SPSKM/
C
      EXTERNAL UINIT
C
      INTEGER I
      DOUBLE PRECISION DX, XI
C
C Equidistant grid
      DX = (XR-XL)/(NC+1)
      DO 10 I = 0, NC+1
         XI = XL+I*DX
         Y(NPDE1,I) = XI
   10 CONTINUE
      CALL UINIT (NPDE, NPTS, Y)

      RETURN
      END
      SUBROUTINE SKMRES (NEQN, T, Y, YDOT, RES, IRES, RWK, NRWK)
C
C-----------------------------------------------------------------------
C Purpose:
C -------
C Enveloping routine to compute the residual of the PDE and of the grid
C equations. SKMRES checks on node-crossing, partitions the workspace
C and calls CWRESU for the spatial discretization and the computation
C of the residual of the PDE in Lagrangian formulation and CWRESX for
C the spatial discretization and the residual computation of the grid
C equations.
C
C Parameters:
C ----------
      INTEGER NEQN, IRES, NRWK
      DOUBLE PRECISION T
      DOUBLE PRECISION Y(NEQN), YDOT(NEQN), RES(NEQN), RWK(NRWK)
C
C NEQN  Entry: the size of the DAE system generated when the PDE +
C       the grid equations are discretized.
C T     Entry: evaluation time.
C Y     Entry: array of length NEQN containing the DAE vector consisting
C       of the spatial mesh and the corresponding initial PDE solution
C       values at time T. This array is ordered as
C          PDE comp.  : Y((NPDE+1)*l + j) l=0,...,NPTS-1,
C                                         j=1,...,NPDE
C          grid points: Y((NPDE+1)*(l+1)) l=0,...,NPTS-1.
C RES   Exit: residual vector.
C       If IRES = -1 RES should contain only the part of the residual
C       dependent on the time-derivative, if IRES /= -1 RES should
C       contain the full residual  A.ydot - g.
C IRES  Entry: see above.
C       Exit: 2, if setup routine SETSKM has not been called.
C             3, if one of the DAE solutions in the vector Y is not
C                acceptable.
C RWK   working storage of length NRWK.
C NRWK  Entry: dimension of RWK. Should be >= NEQN + (6+NPDE)*NPDE.
C
C-----------------------------------------------------------------------
C
      CHARACTER*6 PDCODE
      COMMON /DISCHK/ PDCODE
C
      INTEGER NPDE1, NC, M
      LOGICAL SING
      COMMON /SPSKM/ NPDE1, NC, M, SING
C
      INTEGER NERR
      DOUBLE PRECISION SRELPR
      COMMON /MACH/ NERR, SRELPR
C
      SAVE   /DISCHK/, /SPSKM/, /MACH/
C
      EXTERNAL CWRESU, CWRESX
C
C-----------------------------------------------------------------------
C
      INTEGER I, IW1, IW2, IW3, IW4, IW5, IW6, IW7, J, NPDE

      IF (PDCODE .NE. 'SPSKLM') THEN
         WRITE(NERR,*) ' ERROR IN SKLMRES ROUTINE - THE SETUP ROUTINE'//
     +                 ' SETSKM WAS NOT CALLED PRIOR TO SPRINT ENTRY'
         IRES = 2
         RETURN
      ENDIF

      NPDE = NPDE1-1

C Check on node-crossing
      DO 5 I = NPDE1, NEQN-NPDE1, NPDE1
         IF (Y(I) .GE. Y(I+NPDE1)) THEN
            WRITE(NERR,'(30H SKMRES - NON-MONOTONOUS GRID,,
     +                   22H VALUES OF GRID POINTS, I3,1H,,I3,
     +                    4H ARE, E13.5,1H1,E13.5)')
     +                   I/NPDE1, I/NPDE1+1, Y(I), Y(I+NPDE1)
            IRES = 3
         ENDIF
    5 CONTINUE

C Partition workspace
      IW1 =   1 + NEQN
      IW2 = IW1 + NPDE
      IW3 = IW2 + NPDE
      IW4 = IW3 + NPDE
      IW5 = IW4 + NPDE
      IW6 = IW5 + NPDE
      IW7 = IW6 + NPDE

C Calculate A.ydot and g for Lagrangian PDE
      CALL CWRESU (T, Y, YDOT, NPDE1-1, NC, M, SING,
     +             RWK(IW1), RWK(IW2), RWK(IW3), RWK(IW4),
     +             RWK(IW5), RWK(IW6), RWK(IW7),
     +             RES, RWK(1), IRES)
      IF (IRES .GE. 3) RETURN

C Calculate A.ydot and g for grid equations
      CALL CWRESX (T, Y, YDOT, NPDE1, NC, RES, RWK(1), IRES)
      IF (IRES .GE. 3) RETURN

      IF (IRES .NE. -1) THEN
C      Full residual needed; RES = A.ydot - g
         DO 10 J = 1, NEQN
            RES(J) = RES(J) - RWK(J)
   10    CONTINUE
      ENDIF

      RETURN
      END
      SUBROUTINE CWRESU (T, Y, YDOT, NPDE, NC, M, SING,
     +                   UKSI, UXKSI, BETA, GAMMA, RC, QC, CC,
     +                   AYDOT, G, IRES)
C
C-----------------------------------------------------------------------
C Purpose:
C -------
C Compute PDE part of residual equations A.ydot - g.
C   Return A.ydot in AYDOT and g in G to satisfy both
C   SPRINT and DASSL.
C
C Method:
C ------
C The Lagrangian form of the PDE is:
C   NPDE                   .k   k .
C   sum  C   (x,t, u, u ) (u - u  x)  + Q (x,t, u, u )
C   k=1   j,k      -  -x        x        j      -  -x
C
C                                    -m   m
C                                =  x   (x  R (x,t, u, u ))
C                                            j      -  -x  x
C     where        1         NPDE T
C           u = ( u , ... , u    )   ,  j = 1,... , NPDE,
C           -
C         .k                                                         .
C     and u  is the total time-derivative of the k-th comp. of u and x
C     is the derivative wrt to time of x.
C
C This equation is semi-discretized by a lumped finite-element method
C   (udot and ux.xdot lumped).
C   Integration over the l-1_th interval and over the l_th interval
C   both give an expression for the flux in X . Eliminating this value
C                                            l
C   gives a difference equation for l=1,...,N:
C
C                                               .                     .
C fR  R (ksi ) - fR   R (ksi   ) = fS1  S (ksi ,U ) + fSl   S (ksi   ,U )
C   l  j    l      l-1 j    l-1       l  j    l -l       l-1 j    l-1 -l
C
C   with:
C
C          m-mu   mu
C fR = zeta    ksi        , mu = -1 if PDE singular otherwise mu = m
C   l      l      l
C
C            m+1   m+1
C fS1 = (zeta   - X   ) / (m+1)
C    l       l     l
C
C           m+1      m+1
C fSl   = (X   - zeta   ) / (m+1)
C    l-1    l        l-1
C
C         .     NPDE            .p        p     .
C S (ksi ,U ) = sum C  (ksi ) [ U (X ) - U (X ) X ] + Q (ksi )
C  j    k -l    p=1  jp    k        l     x  l   l     j    k
C
C R , j_th component of flux evaluated at quadrature point ksi,
C  j
C Q , j_th component of source term evaluated at quadrature point ksi,
C  j
C C  , element j,p of matrix multiplying u , evaluated at ksi.
C  jp                                     t
C
C Left boundary equation, if non-singular:
C                                               .
C BETA (x ,t) R (x ) = GAMMA (x ,t, U , U (x ))
C     j  L     j  L         j  L    -0  -x  L
C
C   with
C              m                       .       m
C R (x ) = (ksi R (ksi ) - fS1 S (ksi ,U )) / x
C  j  L        0 j    0       0 j    0 -0      L
C
C                         if singular:
C         .
C S (ksi ,U )/(m+1) - R (ksi )/ksi  = 0
C  j    0 -0           j    0     0
C
C Right boundary equation:
C                                                 .
C BETA (x ,t) R (x ) = GAMMA (x ,t, U   , U (x ))
C     j  R     j  R         j  R    -N+1  -x  R
C
C   with
C                                      .         m
C R (x ) = (fR  R (ksi ) + fSl S (ksi ,U   )) / x
C  j  R       N  j    N       N j    N -N+1      R
C
C
C Parameters:
C ----------
      INTEGER NPDE, NC, M, IRES
      LOGICAL SING
      DOUBLE PRECISION T
      DOUBLE PRECISION Y(NPDE+1,0:NC+1), YDOT(NPDE+1,0:NC+1),
     +     UKSI(NPDE), UXKSI(NPDE), BETA(NPDE), GAMMA(NPDE),
     +     RC(NPDE), QC(NPDE), CC(NPDE,NPDE),
     +     AYDOT(NPDE+1,0:NC+1), G(NPDE+1,0:NC+1)
C
C T      Entry: evaluation time
C Y      Entry: solution and grid at time T.
C        (Y(1:NPDE,L): U_l, Y(NPDE+1,L): X_l)
C YDOT   Entry: derivative of Y at T.
C NPDE   Entry: # PDEs.
C NC     Entry: # internal grid points.
C M      Entry: coordinate system indicator.
C SING   Entry: true, if PDE has a polar singularity (M>0, x_L=0).
C UKSI   workspace to hold the solution value at an evaluation point.
C UXKSI  workspace to hold the space derivatives at an evaluation point.
C BETA   workspace to hold the boundary function BETA.
C GAMMA  workspace to hold the boundary function GAMMA
C RC     workspace to hold the PDE function R.
C QC     workspace to hold the PDE function Q.
C CC     workspace to hold the PDE function C.
C AYDOT  Exit: A.ydot part of the residual.
C G      Exit: g part of the residual.
C IRES   Exit: 3 if some user function indicated that a solution value
C        is unphysical.
C
C Local variables:
C ---------------
      INTEGER MU
      DOUBLE PRECISION FSCL, FSC1, SCLMQ, SCL1MQ,
     +     DENOMI, KSI, KSIMU, ZETA, ZETAMU, PHIL, PHILX
C MU     if sing. then -1 else m.
C FSCL   fS1_l.
C FSC1   fSl_l+1.
C SCLMQ  S(ksi_l,udot_l)   - Q(ksi_l).
C SCL1MQ S(ksi_l,udot_l+1) - Q(ksi_l).
C DENOMI 1 / [ (X_l,X_l+1) int y**(-m) dy ]
C KSI    quadrature point for l_th interval
C KSIMU  ksi**mu
C ZETA   zeta_l ** (m+1); if sing. and l=0 then
C                         zeta = 0.0
C                         else   (X_l,X_l+1) int y dy * denomi
C ZETAMU zeta_l ** (m-mu)
C PHIL   'left' trial function for l_th interval in eval. point ksi
C        NB. phi_l+1 = 1 - phil
C PHILX  deriv. of phi_l wrt x in eval. point ksi
C        NB. phi_l+1_x = - phil_x
C
C
      EXTERNAL BNDR, SPDEF
C
C -------------------------------------------------------------------
C
      INTEGER IP, J, L, NPDE1
      DOUBLE PRECISION DENPHI, RCJDOT, RCJG, UXL, UXL1, X0, X0M, XL,
     +     XL1, XN1M

      NPDE1 = NPDE+1

      X0 = Y(NPDE1,0)
      IF (SING) THEN
         MU = -1
      ELSE
         MU = M
      ENDIF
C
C First interval, compute contribution to residual eq. in X_1 and
C   left boundary equation
C
      L = 0
         XL  = X0
         XL1 = Y(NPDE1,L+1)
         IF (.NOT. SING) THEN
            IF (M .EQ. 1) THEN
               DENOMI = 1/LOG(XL1/XL)
            ELSE
               DENOMI = (1-M)/(XL1**(1-M) - XL**(1-M))
            ENDIF
         ENDIF
         IF (SING) THEN
            KSI = 2/3. * (XL1**3-XL**3) / (XL1**2-XL**2)
            KSIMU = 1/KSI
         ELSE IF (M .EQ. 1) THEN
            KSI = (XL1-XL) * DENOMI
            KSIMU = KSI
         ELSE IF (M .EQ. 2) THEN
            KSI = LOG(XL1/XL) * DENOMI
            KSIMU = KSI*KSI
         ELSE
            KSI = (XL1**(2-M)-XL**(2-M)) / (2-M) * DENOMI
            IF (M .EQ. 0) THEN
               KSIMU = 1.0
            ELSE
               KSIMU = KSI**MU
            ENDIF
         ENDIF
         IF (SING) THEN
            ZETA = 0.0
            ZETAMU = ZETA
            DENPHI = 1/(XL1*XL1-XL*XL)
            PHIL = (XL1*XL1-KSI*KSI)*DENPHI
            PHILX = -2*KSI*DENPHI
         ELSE
            ZETA = 0.5*(XL1*XL1-XL*XL) * DENOMI
            ZETAMU = 1.0
            IF (M .EQ. 1) THEN
               PHIL = LOG(XL1/KSI) * DENOMI
               PHILX = -1/KSI * DENOMI
            ELSE IF (M .EQ. 0) THEN
               PHIL = (XL1 - KSI) * DENOMI
               PHILX = -DENOMI
            ELSE
               PHIL = (XL1**(1-M) - KSI**(1-M)) / (1-M) * DENOMI
               PHILX = -KSI**(-M) * DENOMI
            ENDIF
         ENDIF
         IF (M .EQ. 0) THEN
            X0M = 1.0
         ELSE
            X0M = X0**M
         ENDIF

C      Get left boundary function values
         DO 5 J = 1, NPDE
            UXKSI(J) = (Y(J,1)-Y(J,0)) / (XL1-XL)
    5    CONTINUE
         CALL BNDR (T, BETA, GAMMA, Y(1,0), UXKSI,
     +              NPDE, .TRUE., IRES)
         IF (IRES .EQ. 3) RETURN

C Compute U and Ux in evaluation point
         DO 10 J = 1, NPDE
            UKSI(J)  = Y(J,L)*PHIL  + Y(J,L+1)*(1-PHIL)
            UXKSI(J) = Y(J,L)*PHILX + Y(J,L+1)*(-PHILX)
   10    CONTINUE
C Get C, Q and R in evaluation point
         CALL SPDEF (T, KSI, NPDE, UKSI, UXKSI, CC, QC, RC, IRES)
         IF (IRES .EQ. 3) RETURN

         FSCL = (ZETA- XL**(M+1))/(M+1)
         FSC1 = (XL1**(M+1)-ZETA)/(M+1)
         DO 20 J = 1, NPDE
            SCLMQ  = 0.0
            SCL1MQ = 0.0
            DO 30 IP = 1, NPDE
               UXL1 = (Y(IP,L+2)-Y(IP,L  ))/(Y(NPDE1,L+2)-Y(NPDE1,L  ))
               SCLMQ  = SCLMQ  +
     +                  CC(J,IP)*(YDOT(IP,L  ))
               SCL1MQ = SCL1MQ +
     +                  CC(J,IP)*(YDOT(IP,L+1)-UXL1*YDOT(NPDE1,L+1))
   30       CONTINUE
C Store contribution from l_th interval to residual equation in X_l+1
            AYDOT(J,L+1) = FSC1 * SCL1MQ
            G    (J,L+1) = -ZETAMU*KSIMU*RC(J) - FSC1*QC(J)
C Compute boundary equations
            IF (SING) THEN
	       IF (BETA(J) .NE. 0) THEN
C               Bnd.eq. is contribution from 0_th interval to
C               difference eq. in x_L
                  AYDOT(J,0) = SCLMQ / (M+1)
                  G    (J,0) = RC(J)/KSI - QC(J)/(M+1)
	       ELSE
                  AYDOT(J,0) = 0.0
                  G    (J,0) = GAMMA(J)
	       ENDIF
            ELSE
C            Otherwise compute flux in x_L from contribution from 0_th
C            interval to difference equation in x_L, and substitute in
C            user's boundary equation.
               RCJDOT = -FSCL * SCLMQ / X0M
               RCJG   = (KSIMU*RC(J) - FSCL*QC(J)) / X0M
               AYDOT(J,0) = -BETA(J)*RCJDOT
               G    (J,0) = BETA(J)*RCJG - GAMMA(J)
            ENDIF
   20    CONTINUE

      DO 100 L = 1, NC-1
C
C Evaluate PDE functions in quadrature point in l_th interval.
C Add contribution from [X_l,X_l+1] to that of previous interval to
C get residual equation in X_l.
C Store contribution from l_th interval to residual equation in X_l+1.
C
         XL  = XL1
         XL1 = Y(NPDE1,L+1)
         IF (M .EQ. 1) THEN
            DENOMI = 1/LOG(XL1/XL)
         ELSE
            DENOMI = (1-M)/(XL1**(1-M) - XL**(1-M))
         ENDIF
         IF (SING) THEN
            KSI = 2/3. * (XL1**3-XL**3) / (XL1**2-XL**2)
            KSIMU = 1/KSI
         ELSE IF (M .EQ. 1) THEN
            KSI = (XL1-XL) * DENOMI
            KSIMU = KSI
         ELSE IF (M .EQ. 2) THEN
            KSI = LOG(XL1/XL) * DENOMI
            KSIMU = KSI*KSI
         ELSE
            KSI = (XL1**(2-M)-XL**(2-M)) / (2-M) * DENOMI
            IF (M .EQ. 0) THEN
               KSIMU = 1.0
            ELSE
               KSIMU = KSI**MU
            ENDIF
         ENDIF
         ZETA = 0.5*(XL1*XL1-XL*XL) * DENOMI
         IF (SING) THEN
            ZETAMU = ZETA
            DENPHI = 1/(XL1*XL1-XL*XL)
            PHIL = (XL1*XL1-KSI*KSI)*DENPHI
            PHILX = -2*KSI*DENPHI
         ELSE
            ZETAMU = 1.0
            IF (M .EQ. 1) THEN
               PHIL = LOG(XL1/KSI) * DENOMI
               PHILX = -1/KSI * DENOMI
            ELSE IF (M .EQ. 0) THEN
               PHIL = (XL1 - KSI) * DENOMI
               PHILX = -DENOMI
            ELSE
               PHIL = (XL1**(1-M) - KSI**(1-M)) / (1-M) * DENOMI
               PHILX = -KSI**(-M) * DENOMI
            ENDIF
         ENDIF

C Compute U and Ux in evaluation point
         DO 110 J = 1, NPDE
            UKSI(J)  = Y(J,L)*PHIL  + Y(J,L+1)*(1-PHIL)
            UXKSI(J) = Y(J,L)*PHILX + Y(J,L+1)*(-PHILX)
  110    CONTINUE
C Get C, Q and R in evaluation point
         CALL SPDEF (T, KSI, NPDE, UKSI, UXKSI, CC, QC, RC, IRES)
         IF (IRES .EQ. 3) RETURN

         FSCL = (ZETA- XL**(M+1))/(M+1)
         FSC1 = (XL1**(M+1)-ZETA)/(M+1)
         DO 120 J = 1, NPDE
            SCLMQ  = 0.0
            SCL1MQ = 0.0
            DO 130 IP = 1, NPDE
               UXL  = (Y(IP,L+1)-Y(IP,L-1))/(Y(NPDE1,L+1)-Y(NPDE1,L-1))
               UXL1 = (Y(IP,L+2)-Y(IP,L  ))/(Y(NPDE1,L+2)-Y(NPDE1,L  ))
               SCLMQ  = SCLMQ  +
     +                  CC(J,IP)*(YDOT(IP,L  )-UXL *YDOT(NPDE1,L  ))
               SCL1MQ = SCL1MQ +
     +                  CC(J,IP)*(YDOT(IP,L+1)-UXL1*YDOT(NPDE1,L+1))
  130       CONTINUE
C Add contribution over l_th interval to residual equation in X_l
            AYDOT(J,L) = AYDOT(J,L) + FSCL * SCLMQ
            G    (J,L) = G    (J,L) + ZETAMU*KSIMU*RC(J) - FSCL*QC(J)
C Store contribution from l_th interval to residual equation in X_l+1
            AYDOT(J,L+1) = FSC1 * SCL1MQ
            G    (J,L+1) = -ZETAMU*KSIMU*RC(J) - FSC1*QC(J)
  120    CONTINUE
  100 CONTINUE

      L = NC
C
C Add contribution over N_th interval to residual equation in X_N.
C Compute right boundary equation.
C
         XL  = XL1
         XL1 = Y(NPDE1,L+1)
         IF (M .EQ. 1) THEN
            DENOMI = 1/LOG(XL1/XL)
         ELSE
            DENOMI = (1-M)/(XL1**(1-M) - XL**(1-M))
         ENDIF
         IF (SING) THEN
            KSI = 2/3. * (XL1**3-XL**3) / (XL1**2-XL**2)
            KSIMU = 1/KSI
         ELSE IF (M .EQ. 1) THEN
            KSI = (XL1-XL) * DENOMI
            KSIMU = KSI
         ELSE IF (M .EQ. 2) THEN
            KSI = LOG(XL1/XL) * DENOMI
            KSIMU = KSI*KSI
         ELSE
            KSI = (XL1**(2-M)-XL**(2-M)) / (2-M) * DENOMI
            IF (M .EQ. 0) THEN
               KSIMU = 1.0
            ELSE
               KSIMU = KSI**MU
            ENDIF
         ENDIF
         ZETA = 0.5*(XL1*XL1-XL*XL) * DENOMI
         IF (SING) THEN
            ZETAMU = ZETA
            DENPHI = 1/(XL1*XL1-XL*XL)
            PHIL = (XL1*XL1-KSI*KSI)*DENPHI
            PHILX = -2*KSI*DENPHI
         ELSE
            ZETAMU = 1.0
            IF (M .EQ. 1) THEN
               PHIL = LOG(XL1/KSI) * DENOMI
               PHILX = -1/KSI * DENOMI
            ELSE IF (M .EQ. 0) THEN
               PHIL = (XL1 - KSI) * DENOMI
               PHILX = -DENOMI
            ELSE
               PHIL = (XL1**(1-M) - KSI**(1-M)) / (1-M) * DENOMI
               PHILX = -KSI**(-M) * DENOMI
            ENDIF
         ENDIF
         IF (M .EQ. 0) THEN
            XN1M = 1.0
         ELSE
            XN1M = XL1**M
         ENDIF

C Get right boundary function values
         DO 205 J = 1, NPDE
            UXKSI(J) = (Y(J,NC+1)-Y(J,NC)) / (XL1-XL)
  205    CONTINUE
         CALL BNDR (T, BETA, GAMMA, Y(1,NC+1), UXKSI,
     +              NPDE, .FALSE., IRES)
         IF (IRES .EQ. 3) RETURN

C Compute U and Ux in evaluation point
         DO 210 J = 1, NPDE
            UKSI(J)  = Y(J,L)*PHIL  + Y(J,L+1)*(1-PHIL)
            UXKSI(J) = Y(J,L)*PHILX + Y(J,L+1)*(-PHILX)
  210    CONTINUE
C Get C, Q and R in evaluation point
         CALL SPDEF (T, KSI, NPDE, UKSI, UXKSI, CC, QC, RC, IRES)
         IF (IRES .EQ. 3) RETURN

         FSCL = (ZETA- XL**(M+1))/(M+1)
         FSC1 = (XL1**(M+1)-ZETA)/(M+1)
         DO 220 J = 1, NPDE
            SCLMQ  = 0.0
            SCL1MQ = 0.0
            DO 230 IP = 1, NPDE
               UXL  = (Y(IP,L+1)-Y(IP,L-1))/(Y(NPDE1,L+1)-Y(NPDE1,L-1))
               SCLMQ  = SCLMQ  +
     +                  CC(J,IP)*(YDOT(IP,L  )-UXL *YDOT(NPDE1,L  ))
               SCL1MQ = SCL1MQ +
     +                  CC(J,IP)*(YDOT(IP,L+1))
  230       CONTINUE
C Add contribution over N_th interval to residual equation in X_N
            AYDOT(J,L) = AYDOT(J,L) + FSCL * SCLMQ
            G    (J,L) = G    (J,L) + ZETAMU*KSIMU*RC(J) - FSCL*QC(J)
C Compute flux in x_R and substitute in user's boundary condition
            RCJDOT = FSC1 * SCL1MQ / XN1M
            RCJG   = (ZETAMU*KSIMU*RC(J) + FSC1*QC(J)) / XN1M
            AYDOT(J,NC+1) = -BETA(J)*RCJDOT
            G    (J,NC+1) = BETA(J)*RCJG - GAMMA(J)
  220    CONTINUE

      RETURN
      END
      SUBROUTINE CWRESX (T, Y, YDOT, NPDE1, NC, AYDOT, G, IRES)
C
C-----------------------------------------------------------------------
C Purpose:
C -------
C Define grid part of DAE system in general form, i.e. A.ydot and g
C separated to satisfy both SPRINT and DASSL.
C The equations for the moving grid are
C              .                  .
C   nt   + tau.nt        nt + tau.nt
C     i-1        i-1       i        i
C   ----------------  -  ------------  =  0       1 <= i <= N,
C         M                   M
C          i-1                 i
C
C with nt  = n - fac.(n   - 2.n + n   );  fac = rkappa.(rkappa+1)  and
C        i    i        i+1     i   i-1
C
C       n  = 1 / (X   - X ),   n   = n , n    = n .
C        i         i+1   i      -1    0    N+1   N
C
C For simplicity reasons x  and x  are also part of the DAE vector; since
C                         L      R
C the boundaries are fixed we have used as ODEs for these variables
C   .    .
C   X  = X    = 0.
C    0    N+1
C
C Parameters:
C ----------
      INTEGER NPDE1, NC, IRES
      DOUBLE PRECISION T
      DOUBLE PRECISION Y(NPDE1,0:NC+1), YDOT(NPDE1,0:NC+1),
     +     AYDOT(NPDE1,0:NC+1), G(NPDE1,0:NC+1)
C
C T      Entry: evaluation time
C Y      Entry: solution and grid at time T.
C        (Y(1:NPDE,L): U_l, Y(NPDE+1,L): X_l)
C YDOT   Entry: derivative of Y at T.
C NPDE1  Entry: # PDEs + 1.
C NC     Entry: # internal grid points.
C AYDOT  Exit: A.ydot part of the residual.
C G      Exit: g part of the residual.
C IRES   Exit:  not used.
C
C-----------------------------------------------------------------------
C
      DOUBLE PRECISION TAU, RKAPPA, ALFA
      COMMON /METPAR/ TAU, RKAPPA, ALFA
      SAVE   /METPAR/
C
C-----------------------------------------------------------------------
C
      INTEGER I, NPDE
      DOUBLE PRECISION A0, AM, FAC, G0, GM, NIM1, NI, NIP1, NTI, NTDI
C
      NPDE = NPDE1-1
C
C ccc Define smoothing factor
      FAC = RKAPPA*(RKAPPA+1)
C
C ccc Compute monitor values; store M(I) temp. in G(NPDE1,I), I=0, NC
      CALL XMNTR (Y, G, NPDE, NC)
C
C ccc Compute A.xdot and g for grid equations.
C   Interior equations:
C     A.xdot (I) = TAU/M(I-1).NTDOT(I-1) - TAU/M(I).NTDOT(I)
C     g(I)       = NT(I)/M(I) - NT(I-1)/M(I-1)
C     NT(I) = N(I) - FAC.(N(I-1)-2.N(I)+N(I+1))
C     N (I) = 1 / (X(I+1)-X(I))
      I = 0
         NI   = 1/(Y(NPDE1,I+1)-Y(NPDE1,I  ))
         NIM1 = NI
         NIP1 = 1/(Y(NPDE1,I+2)-Y(NPDE1,I+1))

         NTI  = NI - FAC*(NIM1-2*NI+NIP1)
         NTDI = -
     +          (1+  FAC)*NI  *NI  *(YDOT(NPDE1,I+1)-YDOT(NPDE1,I  )) +
     +               FAC *NIP1*NIP1*(YDOT(NPDE1,I+2)-YDOT(NPDE1,I+1))

         A0 = TAU / G(NPDE1,I) * NTDI
         G0 = NTI / G(NPDE1,I)

      DO 10 I = 1, NC-1
         NIM1 = NI
         NI   = NIP1
         AM   = A0
         GM   = G0

         NIP1 = 1/(Y(NPDE1,I+2)-Y(NPDE1,I+1))

         NTI  = NI - FAC*(NIM1-2*NI+NIP1)
         NTDI =      FAC *NIM1*NIM1*(YDOT(NPDE1,I  )-YDOT(NPDE1,I-1)) -
     +          (1+2*FAC)*NI  *NI  *(YDOT(NPDE1,I+1)-YDOT(NPDE1,I  )) +
     +               FAC *NIP1*NIP1*(YDOT(NPDE1,I+2)-YDOT(NPDE1,I+1))

         A0 = TAU / G(NPDE1,I) * NTDI
         G0 = NTI / G(NPDE1,I)

         AYDOT(NPDE1,I) = AM - A0
         G    (NPDE1,I) = G0 - GM
   10 CONTINUE
      I = NC
         NIM1 = NI
         NI   = NIP1
         AM   = A0
         GM   = G0

         NIP1 = NI

         NTI  = NI - FAC*(NIM1-2*NI+NIP1)
         NTDI =      FAC *NIM1*NIM1*(YDOT(NPDE1,I  )-YDOT(NPDE1,I-1)) -
     +          (1+  FAC)*NI  *NI  *(YDOT(NPDE1,I+1)-YDOT(NPDE1,I  ))

         A0 = TAU / G(NPDE1,I) * NTDI
         G0 = NTI / G(NPDE1,I)

         AYDOT(NPDE1,I) = AM - A0
         G    (NPDE1,I) = G0 - GM

C   Boundary equations grid.
C      Fixed endpoints, xdot=0
      I=0
         AYDOT(NPDE1,I) = YDOT(NPDE1,I)
         G(NPDE1,I) = 0.0
      I=NC+1
         AYDOT(NPDE1,I) = YDOT(NPDE1,I)
         G(NPDE1,I) = 0.0
C
      RETURN
      END
      SUBROUTINE XMNTR (Y, G, NPDE, N)
      INTEGER NPDE, N
      DOUBLE PRECISION Y(NPDE+1,0:N+1), G(NPDE+1,0:N+1)
C
C-----------------------------------------------------------------------
C Purpose:
C -------
C Compute monitor for grid equation,
C   M_i = M(x(i+1/2)) = sqrt(alfa + !!ux!!**2)
C
C Exit:
C   G(NPDE+1,i) = M(i)
C
C-----------------------------------------------------------------------
C
      DOUBLE PRECISION TAU, RKAPPA, ALFA
      COMMON /METPAR/ TAU, RKAPPA, ALFA
      SAVE   /METPAR/
C
C-----------------------------------------------------------------------
C
      INTEGER I, K, NPDE1
      DOUBLE PRECISION DU, DX, SUX2
C
      NPDE1 = NPDE+1

      DO 10 I = 0, N
         SUX2 = 0.0
         DO 20 K = 1, NPDE
            DU = Y(K,I+1)-Y(K,I)
            SUX2 = SUX2 + DU*DU
   20    CONTINUE
         DX = Y(NPDE1,I+1)-Y(NPDE1,I)
         SUX2 = SUX2 / (DX*DX)
         G(NPDE1,I) = SQRT(ALFA + SUX2/NPDE)
   10 CONTINUE

      RETURN
      END
C
C#######################################################################
C
C MACHAR : MACHAR routine from W.J. Cody
C          (available from Netlib: send machar from elefunt)
C
C#######################################################################
C
      SUBROUTINE MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1                   MAXEXP,EPS,EPSNEG,XMIN,XMAX)
C-----------------------------------------------------------------------
C  This Fortran 77 subroutine is intended to determine the parameters
C   of the floating-point arithmetic system specified below.  The
C   determination of the first three uses an extension of an algorithm
C   due to M. Malcolm, CACM 15 (1972), pp. 949-951, incorporating some,
C   but not all, of the improvements suggested by M. Gentleman and S.
C   Marovich, CACM 17 (1974), pp. 276-277.  An earlier version of this
C   program was published in the book Software Manual for the
C   Elementary Functions by W. J. Cody and W. Waite, Prentice-Hall,
C   Englewood Cliffs, NJ, 1980.  The present version is documented in
C   W. J. Cody, "MACHAR: A subroutine to dynamically determine machine
C   parameters," TOMS 14, December, 1988.
C
C  The program as given here must be modified before compiling.  If
C   a single (double) precision version is desired, change all
C   occurrences of CS (CD) in columns 1 and 2 to blanks.
C
C  Parameter values reported are as follows:
C
C       IBETA   - the radix for the floating-point representation
C       IT      - the number of base IBETA digits in the floating-point
C                 significand
C       IRND    - 0 if floating-point addition chops
C                 1 if floating-point addition rounds, but not in the
C                   IEEE style
C                 2 if floating-point addition rounds in the IEEE style
C                 3 if floating-point addition chops, and there is
C                   partial underflow
C                 4 if floating-point addition rounds, but not in the
C                   IEEE style, and there is partial underflow
C                 5 if floating-point addition rounds in the IEEE style,
C                   and there is partial underflow
C       NGRD    - the number of guard digits for multiplication with
C                 truncating arithmetic.  It is
C                 0 if floating-point arithmetic rounds, or if it
C                   truncates and only  IT  base  IBETA digits
C                   participate in the post-normalization shift of the
C                   floating-point significand in multiplication;
C                 1 if floating-point arithmetic truncates and more
C                   than  IT  base  IBETA  digits participate in the
C                   post-normalization shift of the floating-point
C                   significand in multiplication.
C       MACHEP  - the largest negative integer such that
C                 1.0+FLOAT(IBETA)**MACHEP .NE. 1.0, except that
C                 MACHEP is bounded below by  -(IT+3)
C       NEGEPS  - the largest negative integer such that
C                 1.0-FLOAT(IBETA)**NEGEPS .NE. 1.0, except that
C                 NEGEPS is bounded below by  -(IT+3)
C       IEXP    - the number of bits (decimal places if IBETA = 10)
C                 reserved for the representation of the exponent
C                 (including the bias or sign) of a floating-point
C                 number
C       MINEXP  - the largest in magnitude negative integer such that
C                 FLOAT(IBETA)**MINEXP is positive and normalized
C       MAXEXP  - the smallest positive power of  BETA  that overflows
C       EPS     - the smallest positive floating-point number such
C                 that  1.0+EPS .NE. 1.0. In particular, if either
C                 IBETA = 2  or  IRND = 0, EPS = FLOAT(IBETA)**MACHEP.
C                 Otherwise,  EPS = (FLOAT(IBETA)**MACHEP)/2
C       EPSNEG  - A small positive floating-point number such that
C                 1.0-EPSNEG .NE. 1.0. In particular, if IBETA = 2
C                 or  IRND = 0, EPSNEG = FLOAT(IBETA)**NEGEPS.
C                 Otherwise,  EPSNEG = (IBETA**NEGEPS)/2.  Because
C                 NEGEPS is bounded below by -(IT+3), EPSNEG may not
C                 be the smallest number that can alter 1.0 by
C                 subtraction.
C       XMIN    - the smallest non-vanishing normalized floating-point
C                 power of the radix, i.e.,  XMIN = FLOAT(IBETA)**MINEXP
C       XMAX    - the largest finite floating-point number.  In
C                 particular  XMAX = (1.0-EPSNEG)*FLOAT(IBETA)**MAXEXP
C                 Note - on some machines  XMAX  will be only the
C                 second, or perhaps third, largest number, being
C                 too small by 1 or 2 units in the last digit of
C                 the significand.
C
C     Latest revision - December 4, 1987
C
C     Author - W. J. Cody
C              Argonne National Laboratory
C
C-----------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,IRND,IT,ITEMP,IZ,J,K,MACHEP,MAXEXP,
     1        MINEXP,MX,NEGEP,NGRD,NXRES
CS    REAL
      DOUBLE PRECISION
     1   A,B,BETA,BETAIN,BETAH,CONV,EPS,EPSNEG,ONE,T,TEMP,TEMPA,
     2   TEMP1,TWO,XMAX,XMIN,Y,Z,ZERO
C-----------------------------------------------------------------------
CS    CONV(I) = REAL(I)
      CONV(I) = DBLE(I)
      ONE = CONV(1)
      TWO = ONE + ONE
      ZERO = ONE - ONE
C-----------------------------------------------------------------------
C  Determine IBETA, BETA ala Malcolm.
C-----------------------------------------------------------------------
      A = ONE
   10 A = A + A
         TEMP = A+ONE
         TEMP1 = TEMP-A
         IF (TEMP1-ONE .EQ. ZERO) GO TO 10
      B = ONE
   20 B = B + B
         TEMP = A+B
         ITEMP = INT(TEMP-A)
         IF (ITEMP .EQ. 0) GO TO 20
      IBETA = ITEMP
      BETA = CONV(IBETA)
C-----------------------------------------------------------------------
C  Determine IT, IRND.
C-----------------------------------------------------------------------
      IT = 0
      B = ONE
  100 IT = IT + 1
         B = B * BETA
         TEMP = B+ONE
         TEMP1 = TEMP-B
         IF (TEMP1-ONE .EQ. ZERO) GO TO 100
      IRND = 0
      BETAH = BETA / TWO
      TEMP = A+BETAH
      IF (TEMP-A .NE. ZERO) IRND = 1
      TEMPA = A + BETA
      TEMP = TEMPA+BETAH
      IF ((IRND .EQ. 0) .AND. (TEMP-TEMPA .NE. ZERO)) IRND = 2
C-----------------------------------------------------------------------
C  Determine NEGEP, EPSNEG.
C-----------------------------------------------------------------------
      NEGEP = IT + 3
      BETAIN = ONE / BETA
      A = ONE
      DO 200 I = 1, NEGEP
         A = A * BETAIN
  200 CONTINUE
      B = A
  210 TEMP = ONE-A
         IF (TEMP-ONE .NE. ZERO) GO TO 220
         A = A * BETA
         NEGEP = NEGEP - 1
      GO TO 210
  220 NEGEP = -NEGEP
      EPSNEG = A
C-----------------------------------------------------------------------
C  Determine MACHEP, EPS.
C-----------------------------------------------------------------------
      MACHEP = -IT - 3
      A = B
  300 TEMP = ONE+A
         IF (TEMP-ONE .NE. ZERO) GO TO 320
         A = A * BETA
         MACHEP = MACHEP + 1
      GO TO 300
  320 EPS = A
C-----------------------------------------------------------------------
C  Determine NGRD.
C-----------------------------------------------------------------------
      NGRD = 0
      TEMP = ONE+EPS
      IF ((IRND .EQ. 0) .AND. (TEMP*ONE-ONE .NE. ZERO)) NGRD = 1
C-----------------------------------------------------------------------
C  Determine IEXP, MINEXP, XMIN.
C
C  Loop to determine largest I and K = 2**I such that
C         (1/BETA) ** (2**(I))
C  does not underflow.
C  Exit from loop is signaled by an underflow.
C-----------------------------------------------------------------------
      I = 0
      K = 1
      Z = BETAIN
      T = ONE + EPS
      NXRES = 0
  400 Y = Z
         Z = Y * Y
C-----------------------------------------------------------------------
C  Check for underflow here.
C-----------------------------------------------------------------------
         A = Z * ONE
         TEMP = Z * T
         IF ((A+A .EQ. ZERO) .OR. (ABS(Z) .GE. Y)) GO TO 410
         TEMP1 = TEMP * BETAIN
         IF (TEMP1*BETA .EQ. Z) GO TO 410
         I = I + 1
         K = K + K
      GO TO 400
  410 IF (IBETA .EQ. 10) GO TO 420
      IEXP = I + 1
      MX = K + K
      GO TO 450
C-----------------------------------------------------------------------
C  This segment is for decimal machines only.
C-----------------------------------------------------------------------
  420 IEXP = 2
      IZ = IBETA
  430 IF (K .LT. IZ) GO TO 440
         IZ = IZ * IBETA
         IEXP = IEXP + 1
      GO TO 430
  440 MX = IZ + IZ - 1
C-----------------------------------------------------------------------
C  Loop to determine MINEXP, XMIN.
C  Exit from loop is signaled by an underflow.
C-----------------------------------------------------------------------
  450 XMIN = Y
         Y = Y * BETAIN
C-----------------------------------------------------------------------
C  Check for underflow here.
C-----------------------------------------------------------------------
         A = Y * ONE
         TEMP = Y * T
         IF (((A+A) .EQ. ZERO) .OR. (ABS(Y) .GE. XMIN)) GO TO 460
         K = K + 1
         TEMP1 = TEMP * BETAIN
         IF ((TEMP1*BETA .NE. Y) .OR. (TEMP .EQ. Y)) THEN
               GO TO 450
            ELSE
               NXRES = 3
               XMIN = Y
         END IF
  460 MINEXP = -K
C-----------------------------------------------------------------------
C  Determine MAXEXP, XMAX.
C-----------------------------------------------------------------------
      IF ((MX .GT. K+K-3) .OR. (IBETA .EQ. 10)) GO TO 500
      MX = MX + MX
      IEXP = IEXP + 1
  500 MAXEXP = MX + MINEXP
C-----------------------------------------------------------------
C  Adjust IRND to reflect partial underflow.
C-----------------------------------------------------------------
      IRND = IRND + NXRES
C-----------------------------------------------------------------
C  Adjust for IEEE-style machines.
C-----------------------------------------------------------------
      IF (IRND .GE. 2) MAXEXP = MAXEXP - 2
C-----------------------------------------------------------------
C  Adjust for machines with implicit leading bit in binary
C  significand, and machines with radix point at extreme
C  right of significand.
C-----------------------------------------------------------------
      I = MAXEXP + MINEXP
      IF ((IBETA .EQ. 2) .AND. (I .EQ. 0)) MAXEXP = MAXEXP - 1
      IF (I .GT. 20) MAXEXP = MAXEXP - 1
      IF (A .NE. Y) MAXEXP = MAXEXP - 2
      XMAX = ONE - EPSNEG
      IF (XMAX*ONE .NE. XMAX) XMAX = ONE - BETA * EPSNEG
      XMAX = XMAX / (BETA * BETA * BETA * XMIN)
      I = MAXEXP + MINEXP + 3
      IF (I .LE. 0) GO TO 520
      DO 510 J = 1, I
          IF (IBETA .EQ. 2) XMAX = XMAX + XMAX
          IF (IBETA .NE. 2) XMAX = XMAX * BETA
  510 CONTINUE
  520 RETURN
C---------- LAST CARD OF MACHAR ----------
      END
C
C#######################################################################
C
C Next three files contain sources used to solve the resulting DAE
C    system with DASSL.
C
C#######################################################################
C
C#######################################################################
C
C DDASSL : DASSL DAE integrator from L.R. Petzold
C          (available from Netlib: send ddassl from ode)
C
C#######################################################################
C
      SUBROUTINE DDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL,
     +   IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC)
C***BEGIN PROLOGUE  DDASSL
C***PURPOSE  This code solves a system of differential/algebraic
C            equations of the form G(T,Y,YPRIME) = 0.
C***LIBRARY   SLATEC (DASSL)
C***CATEGORY  I1A2
C***TYPE      DOUBLE PRECISION (SDASSL-S, DDASSL-D)
C***KEYWORDS  DIFFERENTIAL/ALGEBRAIC, BACKWARD DIFFERENTIATION FORMULAS,
C             IMPLICIT DIFFERENTIAL SYSTEMS
C***AUTHOR  PETZOLD, LINDA R., (LLNL)
C             COMPUTING AND MATHEMATICS RESEARCH DIVISION
C             LAWRENCE LIVERMORE NATIONAL LABORATORY
C             L - 316, P.O. BOX 808,
C             LIVERMORE, CA.    94550
C***DESCRIPTION
C
C *Usage:
C
C      EXTERNAL RES, JAC
C      INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR
C      DOUBLE PRECISION T, Y(NEQ), YPRIME(NEQ), TOUT, RTOL, ATOL,
C     *   RWORK(LRW), RPAR
C
C      CALL DDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL,
C     *   IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC)
C
C
C *Arguments:
C  (In the following, all real arrays should be type DOUBLE PRECISION.)
C
C  RES:EXT     This is a subroutine which you provide to define the
C              differential/algebraic system.
C
C  NEQ:IN      This is the number of equations to be solved.
C
C  T:INOUT     This is the current value of the independent variable.
C
C  Y(*):INOUT  This array contains the solution components at T.
C
C  YPRIME(*):INOUT  This array contains the derivatives of the solution
C              components at T.
C
C  TOUT:IN     This is a point at which a solution is desired.
C
C  INFO(N):IN  The basic task of the code is to solve the system from T
C              to TOUT and return an answer at TOUT.  INFO is an integer
C              array which is used to communicate exactly how you want
C              this task to be carried out.  (See below for details.)
C              N must be greater than or equal to 15.
C
C  RTOL,ATOL:INOUT  These quantities represent relative and absolute
C              error tolerances which you provide to indicate how
C              accurately you wish the solution to be computed.  You
C              may choose them to be both scalars or else both vectors.
C              Caution:  In Fortran 77, a scalar is not the same as an
C                        array of length 1.  Some compilers may object
C                        to using scalars for RTOL,ATOL.
C
C  IDID:OUT    This scalar quantity is an indicator reporting what the
C              code did.  You must monitor this integer variable to
C              decide  what action to take next.
C
C  RWORK:WORK  A real work array of length LRW which provides the
C              code with needed storage space.
C
C  LRW:IN      The length of RWORK.  (See below for required length.)
C
C  IWORK:WORK  An integer work array of length LIW which probides the
C              code with needed storage space.
C
C  LIW:IN      The length of IWORK.  (See below for required length.)
C
C  RPAR,IPAR:IN  These are real and integer parameter arrays which
C              you can use for communication between your calling
C              program and the RES subroutine (and the JAC subroutine)
C
C  JAC:EXT     This is the name of a subroutine which you may choose
C              to provide for defining a matrix of partial derivatives
C              described below.
C
C  Quantities which may be altered by DDASSL are:
C     T, Y(*), YPRIME(*), INFO(1), RTOL, ATOL,
C     IDID, RWORK(*) AND IWORK(*)
C
C *Description
C
C  Subroutine DDASSL uses the backward differentiation formulas of
C  orders one through five to solve a system of the above form for Y and
C  YPRIME.  Values for Y and YPRIME at the initial time must be given as
C  input.  These values must be consistent, (that is, if T,Y,YPRIME are
C  the given initial values, they must satisfy G(T,Y,YPRIME) = 0.).  The
C  subroutine solves the system from T to TOUT.  It is easy to continue
C  the solution to get results at additional TOUT.  This is the interval
C  mode of operation.  Intermediate results can also be obtained easily
C  by using the intermediate-output capability.
C
C  The following detailed description is divided into subsections:
C    1. Input required for the first call to DDASSL.
C    2. Output after any return from DDASSL.
C    3. What to do to continue the integration.
C    4. Error messages.
C
C
C  -------- INPUT -- WHAT TO DO ON THE FIRST CALL TO DDASSL ------------
C
C  The first call of the code is defined to be the start of each new
C  problem. Read through the descriptions of all the following items,
C  provide sufficient storage space for designated arrays, set
C  appropriate variables for the initialization of the problem, and
C  give information about how you want the problem to be solved.
C
C
C  RES -- Provide a subroutine of the form
C             SUBROUTINE RES(T,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
C         to define the system of differential/algebraic
C         equations which is to be solved. For the given values
C         of T,Y and YPRIME, the subroutine should
C         return the residual of the defferential/algebraic
C         system
C             DELTA = G(T,Y,YPRIME)
C         (DELTA(*) is a vector of length NEQ which is
C         output for RES.)
C
C         Subroutine RES must not alter T,Y or YPRIME.
C         You must declare the name RES in an external
C         statement in your program that calls DDASSL.
C         You must dimension Y,YPRIME and DELTA in RES.
C
C         IRES is an integer flag which is always equal to
C         zero on input. Subroutine RES should alter IRES
C         only if it encounters an illegal value of Y or
C         a stop condition. Set IRES = -1 if an input value
C         is illegal, and DDASSL will try to solve the problem
C         without getting IRES = -1. If IRES = -2, DDASSL
C         will return control to the calling program
C         with IDID = -11.
C
C         RPAR and IPAR are real and integer parameter arrays which
C         you can use for communication between your calling program
C         and subroutine RES. They are not altered by DDASSL. If you
C         do not need RPAR or IPAR, ignore these parameters by treat-
C         ing them as dummy arguments. If you do choose to use them,
C         dimension them in your calling program and in RES as arrays
C         of appropriate length.
C
C  NEQ -- Set it to the number of differential equations.
C         (NEQ .GE. 1)
C
C  T -- Set it to the initial point of the integration.
C         T must be defined as a variable.
C
C  Y(*) -- Set this vector to the initial values of the NEQ solution
C         components at the initial point. You must dimension Y of
C         length at least NEQ in your calling program.
C
C  YPRIME(*) -- Set this vector to the initial values of the NEQ
C         first derivatives of the solution components at the initial
C         point.  You must dimension YPRIME at least NEQ in your
C         calling program. If you do not know initial values of some
C         of the solution components, see the explanation of INFO(11).
C
C  TOUT -- Set it to the first point at which a solution
C         is desired. You can not take TOUT = T.
C         integration either forward in T (TOUT .GT. T) or
C         backward in T (TOUT .LT. T) is permitted.
C
C         The code advances the solution from T to TOUT using
C         step sizes which are automatically selected so as to
C         achieve the desired accuracy. If you wish, the code will
C         return with the solution and its derivative at
C         intermediate steps (intermediate-output mode) so that
C         you can monitor them, but you still must provide TOUT in
C         accord with the basic aim of the code.
C
C         The first step taken by the code is a critical one
C         because it must reflect how fast the solution changes near
C         the initial point. The code automatically selects an
C         initial step size which is practically always suitable for
C         the problem. By using the fact that the code will not step
C         past TOUT in the first step, you could, if necessary,
C         restrict the length of the initial step size.
C
C         For some problems it may not be permissible to integrate
C         past a point TSTOP because a discontinuity occurs there
C         or the solution or its derivative is not defined beyond
C         TSTOP. When you have declared a TSTOP point (SEE INFO(4)
C         and RWORK(1)), you have told the code not to integrate
C         past TSTOP. In this case any TOUT beyond TSTOP is invalid
C         input.
C
C  INFO(*) -- Use the INFO array to give the code more details about
C         how you want your problem solved.  This array should be
C         dimensioned of length 15, though DDASSL uses only the first
C         eleven entries.  You must respond to all of the following
C         items, which are arranged as questions.  The simplest use
C         of the code corresponds to answering all questions as yes,
C         i.e. setting all entries of INFO to 0.
C
C       INFO(1) - This parameter enables the code to initialize
C              itself. You must set it to indicate the start of every
C              new problem.
C
C          **** Is this the first call for this problem ...
C                Yes - Set INFO(1) = 0
C                 No - Not applicable here.
C                      See below for continuation calls.  ****
C
C       INFO(2) - How much accuracy you want of your solution
C              is specified by the error tolerances RTOL and ATOL.
C              The simplest use is to take them both to be scalars.
C              To obtain more flexibility, they can both be vectors.
C              The code must be told your choice.
C
C          **** Are both error tolerances RTOL, ATOL scalars ...
C                Yes - Set INFO(2) = 0
C                      and input scalars for both RTOL and ATOL
C                 No - Set INFO(2) = 1
C                      and input arrays for both RTOL and ATOL ****
C
C       INFO(3) - The code integrates from T in the direction
C              of TOUT by steps. If you wish, it will return the
C              computed solution and derivative at the next
C              intermediate step (the intermediate-output mode) or
C              TOUT, whichever comes first. This is a good way to
C              proceed if you want to see the behavior of the solution.
C              If you must have solutions at a great many specific
C              TOUT points, this code will compute them efficiently.
C
C          **** Do you want the solution only at
C                TOUT (and not at the next intermediate step) ...
C                 Yes - Set INFO(3) = 0
C                  No - Set INFO(3) = 1 ****
C
C       INFO(4) - To handle solutions at a great many specific
C              values TOUT efficiently, this code may integrate past
C              TOUT and interpolate to obtain the result at TOUT.
C              Sometimes it is not possible to integrate beyond some
C              point TSTOP because the equation changes there or it is
C              not defined past TSTOP. Then you must tell the code
C              not to go past.
C
C           **** Can the integration be carried out without any
C                restrictions on the independent variable T ...
C                 Yes - Set INFO(4)=0
C                  No - Set INFO(4)=1
C                       and define the stopping point TSTOP by
C                       setting RWORK(1)=TSTOP ****
C
C       INFO(5) - To solve differential/algebraic problems it is
C              necessary to use a matrix of partial derivatives of the
C              system of differential equations. If you do not
C              provide a subroutine to evaluate it analytically (see
C              description of the item JAC in the call list), it will
C              be approximated by numerical differencing in this code.
C              although it is less trouble for you to have the code
C              compute partial derivatives by numerical differencing,
C              the solution will be more reliable if you provide the
C              derivatives via JAC. Sometimes numerical differencing
C              is cheaper than evaluating derivatives in JAC and
C              sometimes it is not - this depends on your problem.
C
C           **** Do you want the code to evaluate the partial
C                derivatives automatically by numerical differences ...
C                   Yes - Set INFO(5)=0
C                    No - Set INFO(5)=1
C                  and provide subroutine JAC for evaluating the
C                  matrix of partial derivatives ****
C
C       INFO(6) - DDASSL will perform much better if the matrix of
C              partial derivatives, DG/DY + CJ*DG/DYPRIME,
C              (here CJ is a scalar determined by DDASSL)
C              is banded and the code is told this. In this
C              case, the storage needed will be greatly reduced,
C              numerical differencing will be performed much cheaper,
C              and a number of important algorithms will execute much
C              faster. The differential equation is said to have
C              half-bandwidths ML (lower) and MU (upper) if equation i
C              involves only unknowns Y(J) with
C                             I-ML .LE. J .LE. I+MU
C              for all I=1,2,...,NEQ. Thus, ML and MU are the widths
C              of the lower and upper parts of the band, respectively,
C              with the main diagonal being excluded. If you do not
C              indicate that the equation has a banded matrix of partial
C              derivatives, the code works with a full matrix of NEQ**2
C              elements (stored in the conventional way). Computations
C              with banded matrices cost less time and storage than with
C              full matrices if 2*ML+MU .LT. NEQ. If you tell the
C              code that the matrix of partial derivatives has a banded
C              structure and you want to provide subroutine JAC to
C              compute the partial derivatives, then you must be careful
C              to store the elements of the matrix in the special form
C              indicated in the description of JAC.
C
C          **** Do you want to solve the problem using a full
C               (dense) matrix (and not a special banded
C               structure) ...
C                Yes - Set INFO(6)=0
C                 No - Set INFO(6)=1
C                       and provide the lower (ML) and upper (MU)
C                       bandwidths by setting
C                       IWORK(1)=ML
C                       IWORK(2)=MU ****
C
C
C        INFO(7) -- You can specify a maximum (absolute value of)
C              stepsize, so that the code
C              will avoid passing over very
C              large regions.
C
C          ****  Do you want the code to decide
C                on its own maximum stepsize?
C                Yes - Set INFO(7)=0
C                 No - Set INFO(7)=1
C                      and define HMAX by setting
C                      RWORK(2)=HMAX ****
C
C        INFO(8) -- Differential/algebraic problems
C              may occaisionally suffer from
C              severe scaling difficulties on the
C              first step. If you know a great deal
C              about the scaling of your problem, you can
C              help to alleviate this problem by
C              specifying an initial stepsize HO.
C
C          ****  Do you want the code to define
C                its own initial stepsize?
C                Yes - Set INFO(8)=0
C                 No - Set INFO(8)=1
C                      and define HO by setting
C                      RWORK(3)=HO ****
C
C        INFO(9) -- If storage is a severe problem,
C              you can save some locations by
C              restricting the maximum order MAXORD.
C              the default value is 5. for each
C              order decrease below 5, the code
C              requires NEQ fewer locations, however
C              it is likely to be slower. In any
C              case, you must have 1 .LE. MAXORD .LE. 5
C          ****  Do you want the maximum order to
C                default to 5?
C                Yes - Set INFO(9)=0
C                 No - Set INFO(9)=1
C                      and define MAXORD by setting
C                      IWORK(3)=MAXORD ****
C
C        INFO(10) --If you know that the solutions to your equations
C               will always be nonnegative, it may help to set this
C               parameter. However, it is probably best to
C               try the code without using this option first,
C               and only to use this option if that doesn't
C               work very well.
C           ****  Do you want the code to solve the problem without
C                 invoking any special nonnegativity constraints?
C                  Yes - Set INFO(10)=0
C                   No - Set INFO(10)=1
C
C        INFO(11) --DDASSL normally requires the initial T,
C               Y, and YPRIME to be consistent. That is,
C               you must have G(T,Y,YPRIME) = 0 at the initial
C               time. If you do not know the initial
C               derivative precisely, you can let DDASSL try
C               to compute it.
C          ****   Are the initialHE INITIAL T, Y, YPRIME consistent?
C                 Yes - Set INFO(11) = 0
C                  No - Set INFO(11) = 1,
C                       and set YPRIME to an initial approximation
C                       to YPRIME.  (If you have no idea what
C                       YPRIME should be, set it to zero. Note
C                       that the initial Y should be such
C                       that there must exist a YPRIME so that
C                       G(T,Y,YPRIME) = 0.)
C
C  RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL
C         error tolerances to tell the code how accurately you
C         want the solution to be computed.  They must be defined
C         as variables because the code may change them.  You
C         have two choices --
C               Both RTOL and ATOL are scalars. (INFO(2)=0)
C               Both RTOL and ATOL are vectors. (INFO(2)=1)
C         in either case all components must be non-negative.
C
C         The tolerances are used by the code in a local error
C         test at each step which requires roughly that
C               ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL
C         for each vector component.
C         (More specifically, a root-mean-square norm is used to
C         measure the size of vectors, and the error test uses the
C         magnitude of the solution at the beginning of the step.)
C
C         The true (global) error is the difference between the
C         true solution of the initial value problem and the
C         computed approximation.  Practically all present day
C         codes, including this one, control the local error at
C         each step and do not even attempt to control the global
C         error directly.
C         Usually, but not always, the true accuracy of the
C         computed Y is comparable to the error tolerances. This
C         code will usually, but not always, deliver a more
C         accurate solution if you reduce the tolerances and
C         integrate again.  By comparing two such solutions you
C         can get a fairly reliable idea of the true error in the
C         solution at the bigger tolerances.
C
C         Setting ATOL=0. results in a pure relative error test on
C         that component.  Setting RTOL=0. results in a pure
C         absolute error test on that component.  A mixed test
C         with non-zero RTOL and ATOL corresponds roughly to a
C         relative error test when the solution component is much
C         bigger than ATOL and to an absolute error test when the
C         solution component is smaller than the threshhold ATOL.
C
C         The code will not attempt to compute a solution at an
C         accuracy unreasonable for the machine being used.  It will
C         advise you if you ask for too much accuracy and inform
C         you as to the maximum accuracy it believes possible.
C
C  RWORK(*) --  Dimension this real work array of length LRW in your
C         calling program.
C
C  LRW -- Set it to the declared length of the RWORK array.
C               You must have
C                    LRW .GE. 40+(MAXORD+4)*NEQ+NEQ**2
C               for the full (dense) JACOBIAN case (when INFO(6)=0), or
C                    LRW .GE. 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ
C               for the banded user-defined JACOBIAN case
C               (when INFO(5)=1 and INFO(6)=1), or
C                     LRW .GE. 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ
C                           +2*(NEQ/(ML+MU+1)+1)
C               for the banded finite-difference-generated JACOBIAN case
C               (when INFO(5)=0 and INFO(6)=1)
C
C  IWORK(*) --  Dimension this integer work array of length LIW in
C         your calling program.
C
C  LIW -- Set it to the declared length of the IWORK array.
C               You must have LIW .GE. 20+NEQ
C
C  RPAR, IPAR -- These are parameter arrays, of real and integer
C         type, respectively.  You can use them for communication
C         between your program that calls DDASSL and the
C         RES subroutine (and the JAC subroutine).  They are not
C         altered by DDASSL.  If you do not need RPAR or IPAR,
C         ignore these parameters by treating them as dummy
C         arguments.  If you do choose to use them, dimension
C         them in your calling program and in RES (and in JAC)
C         as arrays of appropriate length.
C
C  JAC -- If you have set INFO(5)=0, you can ignore this parameter
C         by treating it as a dummy argument.  Otherwise, you must
C         provide a subroutine of the form
C             SUBROUTINE JAC(T,Y,YPRIME,PD,CJ,RPAR,IPAR)
C         to define the matrix of partial derivatives
C             PD=DG/DY+CJ*DG/DYPRIME
C         CJ is a scalar which is input to JAC.
C         For the given values of T,Y,YPRIME, the
C         subroutine must evaluate the non-zero partial
C         derivatives for each equation and each solution
C         component, and store these values in the
C         matrix PD.  The elements of PD are set to zero
C         before each call to JAC so only non-zero elements
C         need to be defined.
C
C         Subroutine JAC must not alter T,Y,(*),YPRIME(*), or CJ.
C         You must declare the name JAC in an EXTERNAL statement in
C         your program that calls DDASSL.  You must dimension Y,
C         YPRIME and PD in JAC.
C
C         The way you must store the elements into the PD matrix
C         depends on the structure of the matrix which you
C         indicated by INFO(6).
C               *** INFO(6)=0 -- Full (dense) matrix ***
C                   Give PD a first dimension of NEQ.
C                   When you evaluate the (non-zero) partial derivative
C                   of equation I with respect to variable J, you must
C                   store it in PD according to
C                   PD(I,J) = "DG(I)/DY(J)+CJ*DG(I)/DYPRIME(J)"
C               *** INFO(6)=1 -- Banded JACOBIAN with ML lower and MU
C                   upper diagonal bands (refer to INFO(6) description
C                   of ML and MU) ***
C                   Give PD a first dimension of 2*ML+MU+1.
C                   when you evaluate the (non-zero) partial derivative
C                   of equation I with respect to variable J, you must
C                   store it in PD according to
C                   IROW = I - J + ML + MU + 1
C                   PD(IROW,J) = "DG(I)/DY(J)+CJ*DG(I)/DYPRIME(J)"
C
C         RPAR and IPAR are real and integer parameter arrays
C         which you can use for communication between your calling
C         program and your JACOBIAN subroutine JAC. They are not
C         altered by DDASSL. If you do not need RPAR or IPAR,
C         ignore these parameters by treating them as dummy
C         arguments. If you do choose to use them, dimension
C         them in your calling program and in JAC as arrays of
C         appropriate length.
C
C
C  OPTIONALLY REPLACEABLE NORM ROUTINE:
C
C     DDASSL uses a weighted norm DDANRM to measure the size
C     of vectors such as the estimated error in each step.
C     A FUNCTION subprogram
C       DOUBLE PRECISION FUNCTION DDANRM(NEQ,V,WT,RPAR,IPAR)
C       DIMENSION V(NEQ),WT(NEQ)
C     is used to define this norm. Here, V is the vector
C     whose norm is to be computed, and WT is a vector of
C     weights.  A DDANRM routine has been included with DDASSL
C     which computes the weighted root-mean-square norm
C     given by
C       DDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2)
C     this norm is suitable for most problems. In some
C     special cases, it may be more convenient and/or
C     efficient to define your own norm by writing a function
C     subprogram to be called instead of DDANRM. This should,
C     however, be attempted only after careful thought and
C     consideration.
C
C
C  -------- OUTPUT -- AFTER ANY RETURN FROM DDASSL ---------------------
C
C  The principal aim of the code is to return a computed solution at
C  TOUT, although it is also possible to obtain intermediate results
C  along the way. To find out whether the code achieved its goal
C  or if the integration process was interrupted before the task was
C  completed, you must check the IDID parameter.
C
C
C  T -- The solution was successfully advanced to the
C               output value of T.
C
C  Y(*) -- Contains the computed solution approximation at T.
C
C  YPRIME(*) -- Contains the computed derivative
C               approximation at T.
C
C  IDID -- Reports what the code did.
C
C                     *** Task completed ***
C                Reported by positive values of IDID
C
C           IDID = 1 -- A step was successfully taken in the
C                   intermediate-output mode. The code has not
C                   yet reached TOUT.
C
C           IDID = 2 -- The integration to TSTOP was successfully
C                   completed (T=TSTOP) by stepping exactly to TSTOP.
C
C           IDID = 3 -- The integration to TOUT was successfully
C                   completed (T=TOUT) by stepping past TOUT.
C                   Y(*) is obtained by interpolation.
C                   YPRIME(*) is obtained by interpolation.
C
C                    *** Task interrupted ***
C                Reported by negative values of IDID
C
C           IDID = -1 -- A large amount of work has been expended.
C                   (About 500 steps)
C
C           IDID = -2 -- The error tolerances are too stringent.
C
C           IDID = -3 -- The local error test cannot be satisfied
C                   because you specified a zero component in ATOL
C                   and the corresponding computed solution
C                   component is zero. Thus, a pure relative error
C                   test is impossible for this component.
C
C           IDID = -6 -- DDASSL had repeated error test
C                   failures on the last attempted step.
C
C           IDID = -7 -- The corrector could not converge.
C
C           IDID = -8 -- The matrix of partial derivatives
C                   is singular.
C
C           IDID = -9 -- The corrector could not converge.
C                   there were repeated error test failures
C                   in this step.
C
C           IDID =-10 -- The corrector could not converge
C                   because IRES was equal to minus one.
C
C           IDID =-11 -- IRES equal to -2 was encountered
C                   and control is being returned to the
C                   calling program.
C
C           IDID =-12 -- DDASSL failed to compute the initial
C                   YPRIME.
C
C
C
C           IDID = -13,..,-32 -- Not applicable for this code
C
C                    *** Task terminated ***
C                Reported by the value of IDID=-33
C
C           IDID = -33 -- The code has encountered trouble from which
C                   it cannot recover. A message is printed
C                   explaining the trouble and control is returned
C                   to the calling program. For example, this occurs
C                   when invalid input is detected.
C
C  RTOL, ATOL -- These quantities remain unchanged except when
C               IDID = -2. In this case, the error tolerances have been
C               increased by the code to values which are estimated to
C               be appropriate for continuing the integration. However,
C               the reported solution at T was obtained using the input
C               values of RTOL and ATOL.
C
C  RWORK, IWORK -- Contain information which is usually of no
C               interest to the user but necessary for subsequent calls.
C               However, you may find use for
C
C               RWORK(3)--Which contains the step size H to be
C                       attempted on the next step.
C
C               RWORK(4)--Which contains the current value of the
C                       independent variable, i.e., the farthest point
C                       integration has reached. This will be different
C                       from T only when interpolation has been
C                       performed (IDID=3).
C
C               RWORK(7)--Which contains the stepsize used
C                       on the last successful step.
C
C               IWORK(7)--Which contains the order of the method to
C                       be attempted on the next step.
C
C               IWORK(8)--Which contains the order of the method used
C                       on the last step.
C
C               IWORK(11)--Which contains the number of steps taken so
C                        far.
C
C               IWORK(12)--Which contains the number of calls to RES
C                        so far.
C
C               IWORK(13)--Which contains the number of evaluations of
C                        the matrix of partial derivatives needed so
C                        far.
C
C               IWORK(14)--Which contains the total number
C                        of error test failures so far.
C
C               IWORK(15)--Which contains the total number
C                        of convergence test failures so far.
C                        (includes singular iteration matrix
C                        failures.)
C
C
C  -------- INPUT -- WHAT TO DO TO CONTINUE THE INTEGRATION ------------
C                    (CALLS AFTER THE FIRST)
C
C  This code is organized so that subsequent calls to continue the
C  integration involve little (if any) additional effort on your
C  part. You must monitor the IDID parameter in order to determine
C  what to do next.
C
C  Recalling that the principal task of the code is to integrate
C  from T to TOUT (the interval mode), usually all you will need
C  to do is specify a new TOUT upon reaching the current TOUT.
C
C  Do not alter any quantity not specifically permitted below,
C  in particular do not alter NEQ,T,Y(*),YPRIME(*),RWORK(*),IWORK(*)
C  or the differential equation in subroutine RES. Any such
C  alteration constitutes a new problem and must be treated as such,
C  i.e., you must start afresh.
C
C  You cannot change from vector to scalar error control or vice
C  versa (INFO(2)), but you can change the size of the entries of
C  RTOL, ATOL. Increasing a tolerance makes the equation easier
C  to integrate. Decreasing a tolerance will make the equation
C  harder to integrate and should generally be avoided.
C
C  You can switch from the intermediate-output mode to the
C  interval mode (INFO(3)) or vice versa at any time.
C
C  If it has been necessary to prevent the integration from going
C  past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the
C  code will not integrate to any TOUT beyond the currently
C  specified TSTOP. Once TSTOP has been reached you must change
C  the value of TSTOP or set INFO(4)=0. You may change INFO(4)
C  or TSTOP at any time but you must supply the value of TSTOP in
C  RWORK(1) whenever you set INFO(4)=1.
C
C  Do not change INFO(5), INFO(6), IWORK(1), or IWORK(2)
C  unless you are going to restart the code.
C
C                 *** Following a completed task ***
C  If
C     IDID = 1, call the code again to continue the integration
C                  another step in the direction of TOUT.
C
C     IDID = 2 or 3, define a new TOUT and call the code again.
C                  TOUT must be different from T. You cannot change
C                  the direction of integration without restarting.
C
C                 *** Following an interrupted task ***
C               To show the code that you realize the task was
C               interrupted and that you want to continue, you
C               must take appropriate action and set INFO(1) = 1
C  If
C    IDID = -1, The code has taken about 500 steps.
C                  If you want to continue, set INFO(1) = 1 and
C                  call the code again. An additional 500 steps
C                  will be allowed.
C
C    IDID = -2, The error tolerances RTOL, ATOL have been
C                  increased to values the code estimates appropriate
C                  for continuing. You may want to change them
C                  yourself. If you are sure you want to continue
C                  with relaxed error tolerances, set INFO(1)=1 and
C                  call the code again.
C
C    IDID = -3, A solution component is zero and you set the
C                  corresponding component of ATOL to zero. If you
C                  are sure you want to continue, you must first
C                  alter the error criterion to use positive values
C                  for those components of ATOL corresponding to zero
C                  solution components, then set INFO(1)=1 and call
C                  the code again.
C
C    IDID = -4,-5  --- Cannot occur with this code.
C
C    IDID = -6, Repeated error test failures occurred on the
C                  last attempted step in DDASSL. A singularity in the
C                  solution may be present. If you are absolutely
C                  certain you want to continue, you should restart
C                  the integration. (Provide initial values of Y and
C                  YPRIME which are consistent)
C
C    IDID = -7, Repeated convergence test failures occurred
C                  on the last attempted step in DDASSL. An inaccurate
C                  or ill-conditioned JACOBIAN may be the problem. If
C                  you are absolutely certain you want to continue, you
C                  should restart the integration.
C
C    IDID = -8, The matrix of partial derivatives is singular.
C                  Some of your equations may be redundant.
C                  DDASSL cannot solve the problem as stated.
C                  It is possible that the redundant equations
C                  could be removed, and then DDASSL could
C                  solve the problem. It is also possible
C                  that a solution to your problem either
C                  does not exist or is not unique.
C
C    IDID = -9, DDASSL had multiple convergence test
C                  failures, preceeded by multiple error
C                  test failures, on the last attempted step.
C                  It is possible that your problem
C                  is ill-posed, and cannot be solved
C                  using this code. Or, there may be a
C                  discontinuity or a singularity in the
C                  solution. If you are absolutely certain
C                  you want to continue, you should restart
C                  the integration.
C
C    IDID =-10, DDASSL had multiple convergence test failures
C                  because IRES was equal to minus one.
C                  If you are absolutely certain you want
C                  to continue, you should restart the
C                  integration.
C
C    IDID =-11, IRES=-2 was encountered, and control is being
C                  returned to the calling program.
C
C    IDID =-12, DDASSL failed to compute the initial YPRIME.
C                  This could happen because the initial
C                  approximation to YPRIME was not very good, or
C                  if a YPRIME consistent with the initial Y
C                  does not exist. The problem could also be caused
C                  by an inaccurate or singular iteration matrix.
C
C    IDID = -13,..,-32  --- Cannot occur with this code.
C
C
C                 *** Following a terminated task ***
C
C  If IDID= -33, you cannot continue the solution of this problem.
C                  An attempt to do so will result in your
C                  run being terminated.
C
C
C  -------- ERROR MESSAGES ---------------------------------------------
C
C      The SLATEC error print routine XERMSG is called in the event of
C   unsuccessful completion of a task.  Most of these are treated as
C   "recoverable errors", which means that (unless the user has directed
C   otherwise) control will be returned to the calling program for
C   possible action after the message has been printed.
C
C   In the event of a negative value of IDID other than -33, an appro-
C   priate message is printed and the "error number" printed by XERMSG
C   is the value of IDID.  There are quite a number of illegal input
C   errors that can lead to a returned value IDID=-33.  The conditions
C   and their printed "error numbers" are as follows:
C
C   Error number       Condition
C
C        1       Some element of INFO vector is not zero or one.
C        2       NEQ .le. 0
C        3       MAXORD not in range.
C        4       LRW is less than the required length for RWORK.
C        5       LIW is less than the required length for IWORK.
C        6       Some element of RTOL is .lt. 0
C        7       Some element of ATOL is .lt. 0
C        8       All elements of RTOL and ATOL are zero.
C        9       INFO(4)=1 and TSTOP is behind TOUT.
C       10       HMAX .lt. 0.0
C       11       TOUT is behind T.
C       12       INFO(8)=1 and H0=0.0
C       13       Some element of WT is .le. 0.0
C       14       TOUT is too close to T to start integration.
C       15       INFO(4)=1 and TSTOP is behind T.
C       16       --( Not used in this version )--
C       17       ML illegal.  Either .lt. 0 or .gt. NEQ
C       18       MU illegal.  Either .lt. 0 or .gt. NEQ
C       19       TOUT = T.
C
C   If DDASSL is called again without any action taken to remove the
C   cause of an unsuccessful return, XERMSG will be called with a fatal
C   error flag, which will cause unconditional termination of the
C   program.  There are two such fatal errors:
C
C   Error number -998:  The last step was terminated with a negative
C       value of IDID other than -33, and no appropriate action was
C       taken.
C
C   Error number -999:  The previous call was terminated because of
C       illegal input (IDID=-33) and there is illegal input in the
C       present call, as well.  (Suspect infinite loop.)
C
C  ---------------------------------------------------------------------
C
C***REFERENCES  A DESCRIPTION OF DASSL: A DIFFERENTIAL/ALGEBRAIC
C                 SYSTEM SOLVER, L. R. PETZOLD, SAND82-8637,
C                 SANDIA NATIONAL LABORATORIES, SEPTEMBER 1982.
C***ROUTINES CALLED  D1MACH, DDAINI, DDANRM, DDASTP, DDATRP, DDAWTS,
C                    XERMSG
C***REVISION HISTORY  (YYMMDD)
C   830315  DATE WRITTEN
C   880387  Code changes made.  All common statements have been
C           replaced by a DATA statement, which defines pointers into
C           RWORK, and PARAMETER statements which define pointers
C           into IWORK.  As well the documentation has gone through
C           grammatical changes.
C   881005  The prologue has been changed to mixed case.
C           The subordinate routines had revision dates changed to
C           this date, although the documentation for these routines
C           is all upper case.  No code changes.
C   890511  Code changes made.  The DATA statement in the declaration
C           section of DDASSL was replaced with a PARAMETER
C           statement.  Also the statement S = 100.D0 was removed
C           from the top of the Newton iteration in DDASTP.
C           The subordinate routines had revision dates changed to
C           this date.
C   890517  The revision date syntax was replaced with the revision
C           history syntax.  Also the "DECK" comment was added to
C           the top of all subroutines.  These changes are consistent
C           with new SLATEC guidelines.
C           The subordinate routines had revision dates changed to
C           this date.  No code changes.
C   891013  Code changes made.
C           Removed all occurrances of FLOAT or DBLE.  All operations
C           are now performed with "mixed-mode" arithmetic.
C           Also, specific function names were replaced with generic
C           function names to be consistent with new SLATEC guidelines.
C           In particular:
C              Replaced DSQRT with SQRT everywhere.
C              Replaced DABS with ABS everywhere.
C              Replaced DMIN1 with MIN everywhere.
C              Replaced MIN0 with MIN everywhere.
C              Replaced DMAX1 with MAX everywhere.
C              Replaced MAX0 with MAX everywhere.
C              Replaced DSIGN with SIGN everywhere.
C           Also replaced REVISION DATE with REVISION HISTORY in all
C           subordinate routines.
C  901004  Miscellaneous changes to prologue to complete conversion
C          to SLATEC 4.0 format.  No code changes.  (F.N.Fritsch)
C  901009  Corrected GAMS classification code and converted subsidiary
C          routines to 4.0 format.  No code changes.  (F.N.Fritsch)
C  901010  Converted XERRWV calls to XERMSG calls.  (R.Clemens,AFWL)
C  901019  Code changes made.
C          Merged SLATEC 4.0 changes with previous changes made
C          by C. Ulrich.  Below is a history of the changes made by
C          C. Ulrich. (Changes in subsidiary routines are implied
C          by this history)
C          891228  Bug was found and repaired inside the DDASSL
C                  and DDAINI routines.  DDAINI was incorrectly
C                  returning the initial T with Y and YPRIME
C                  computed at T+H.  The routine now returns T+H
C                  rather than the initial T.
C                  Cosmetic changes made to DDASTP.
C          900904  Three modifications were made to fix a bug (inside
C                  DDASSL) re interpolation for continuation calls and
C                  cases where TN is very close to TSTOP:
C
C                  1) In testing for whether H is too large, just
C                     compare H to (TSTOP - TN), rather than
C                     (TSTOP - TN) * (1-4*UROUND), and set H to
C                     TSTOP - TN.  This will force DDASTP to step
C                     exactly to TSTOP under certain situations
C                     (i.e. when H returned from DDASTP would otherwise
C                     take TN beyond TSTOP).
C
C                  2) Inside the DDASTP loop, interpolate exactly to
C                     TSTOP if TN is very close to TSTOP (rather than
C                     interpolating to within roundoff of TSTOP).
C
C                  3) Modified IDID description for IDID = 2 to say that
C                     the solution is returned by stepping exactly to
C                     TSTOP, rather than TOUT.  (In some cases the
C                     solution is actually obtained by extrapolating
C                     over a distance near unit roundoff to TSTOP,
C                     but this small distance is deemed acceptable in
C                     these circumstances.)
C   901026  Added explicit declarations for all variables and minor
C           cosmetic changes to prologue, removed unreferenced labels,
C           and improved XERMSG calls.  (FNF)
C   901030  Added ERROR MESSAGES section and reworked other sections to
C           be of more uniform format.  (FNF)
C   910624  Fixed minor bug related to HMAX (five lines ending in
C           statement 526 in DDASSL).   (LRP)
C
C***END PROLOGUE  DDASSL
C
C**End
C
C     Declare arguments.
C
      INTEGER  NEQ, INFO(15), IDID, LRW, IWORK(*), LIW, IPAR(*)
      DOUBLE PRECISION
     *   T, Y(*), YPRIME(*), TOUT, RTOL(*), ATOL(*), RWORK(*),
     *   RPAR(*)
      EXTERNAL  RES, JAC
C
C     Declare externals.
C
      EXTERNAL  D1MACH, DDAINI, DDANRM, DDASTP, DDATRP, DDAWTS, XERMSG
      DOUBLE PRECISION  D1MACH, DDANRM
C
C     Declare local variables.
C
      INTEGER  I, ITEMP, LALPHA, LBETA, LCJ, LCJOLD, LCTF, LDELTA,
     *   LENIW, LENPD, LENRW, LE, LETF, LGAMMA, LH, LHMAX, LHOLD, LIPVT,
     *   LJCALC, LK, LKOLD, LIWM, LML, LMTYPE, LMU, LMXORD, LNJE, LNPD,
     *   LNRE, LNS, LNST, LNSTL, LPD, LPHASE, LPHI, LPSI, LROUND, LS,
     *   LSIGMA, LTN, LTSTOP, LWM, LWT, MBAND, MSAVE, MXORD, NPD, NTEMP,
     *   NZFLG
      DOUBLE PRECISION
     *   ATOLI, H, HMAX, HMIN, HO, R, RH, RTOLI, TDIST, TN, TNEXT,
     *   TSTOP, UROUND, YPNORM
      LOGICAL  DONE
C       Auxiliary variables for conversion of values to be included in
C       error messages.
      CHARACTER*8  XERN1, XERN2
      CHARACTER*16 XERN3, XERN4
C
C     SET POINTERS INTO IWORK
      PARAMETER (LML=1, LMU=2, LMXORD=3, LMTYPE=4, LNST=11,
     *  LNRE=12, LNJE=13, LETF=14, LCTF=15, LNPD=16,
     *  LIPVT=21, LJCALC=5, LPHASE=6, LK=7, LKOLD=8,
     *  LNS=9, LNSTL=10, LIWM=1)
C
C     SET RELATIVE OFFSET INTO RWORK
      PARAMETER (NPD=1)
C
C     SET POINTERS INTO RWORK
      PARAMETER (LTSTOP=1, LHMAX=2, LH=3, LTN=4,
     *  LCJ=5, LCJOLD=6, LHOLD=7, LS=8, LROUND=9,
     *  LALPHA=11, LBETA=17, LGAMMA=23,
     *  LPSI=29, LSIGMA=35, LDELTA=41)
C
C***FIRST EXECUTABLE STATEMENT  DDASSL
      IF(INFO(1).NE.0)GO TO 100
C
C-----------------------------------------------------------------------
C     THIS BLOCK IS EXECUTED FOR THE INITIAL CALL ONLY.
C     IT CONTAINS CHECKING OF INPUTS AND INITIALIZATIONS.
C-----------------------------------------------------------------------
C
C     FIRST CHECK INFO ARRAY TO MAKE SURE ALL ELEMENTS OF INFO
C     ARE EITHER ZERO OR ONE.
      DO 10 I=2,11
         IF(INFO(I).NE.0.AND.INFO(I).NE.1)GO TO 701
10       CONTINUE
C
      IF(NEQ.LE.0)GO TO 702
C
C     CHECK AND COMPUTE MAXIMUM ORDER
      MXORD=5
      IF(INFO(9).EQ.0)GO TO 20
         MXORD=IWORK(LMXORD)
         IF(MXORD.LT.1.OR.MXORD.GT.5)GO TO 703
20       IWORK(LMXORD)=MXORD
C
C     COMPUTE MTYPE,LENPD,LENRW.CHECK ML AND MU.
      IF(INFO(6).NE.0)GO TO 40
         LENPD=NEQ**2
         LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD
         IF(INFO(5).NE.0)GO TO 30
            IWORK(LMTYPE)=2
            GO TO 60
30          IWORK(LMTYPE)=1
            GO TO 60
40    IF(IWORK(LML).LT.0.OR.IWORK(LML).GE.NEQ)GO TO 717
      IF(IWORK(LMU).LT.0.OR.IWORK(LMU).GE.NEQ)GO TO 718
      LENPD=(2*IWORK(LML)+IWORK(LMU)+1)*NEQ
      IF(INFO(5).NE.0)GO TO 50
         IWORK(LMTYPE)=5
         MBAND=IWORK(LML)+IWORK(LMU)+1
         MSAVE=(NEQ/MBAND)+1
         LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD+2*MSAVE
         GO TO 60
50       IWORK(LMTYPE)=4
         LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD
C
C     CHECK LENGTHS OF RWORK AND IWORK
60    LENIW=20+NEQ
      IWORK(LNPD)=LENPD
      IF(LRW.LT.LENRW)GO TO 704
      IF(LIW.LT.LENIW)GO TO 705
C
C     CHECK TO SEE THAT TOUT IS DIFFERENT FROM T
      IF(TOUT .EQ. T)GO TO 719
C
C     CHECK HMAX
      IF(INFO(7).EQ.0)GO TO 70
         HMAX=RWORK(LHMAX)
         IF(HMAX.LE.0.0D0)GO TO 710
70    CONTINUE
C
C     INITIALIZE COUNTERS
      IWORK(LNST)=0
      IWORK(LNRE)=0
      IWORK(LNJE)=0
C
      IWORK(LNSTL)=0
      IDID=1
      GO TO 200
C
C-----------------------------------------------------------------------
C     THIS BLOCK IS FOR CONTINUATION CALLS
C     ONLY. HERE WE CHECK INFO(1),AND IF THE
C     LAST STEP WAS INTERRUPTED WE CHECK WHETHER
C     APPROPRIATE ACTION WAS TAKEN.
C-----------------------------------------------------------------------
C
100   CONTINUE
      IF(INFO(1).EQ.1)GO TO 110
      IF(INFO(1).NE.-1)GO TO 701
C
C     IF WE ARE HERE, THE LAST STEP WAS INTERRUPTED
C     BY AN ERROR CONDITION FROM DDASTP,AND
C     APPROPRIATE ACTION WAS NOT TAKEN. THIS
C     IS A FATAL ERROR.
      WRITE (XERN1, '(I8)') IDID
      CALL XERMSG ('SLATEC', 'DDASSL',
     *   'THE LAST STEP TERMINATED WITH A NEGATIVE VALUE OF IDID = ' //
     *   XERN1 // ' AND NO APPROPRIATE ACTION WAS TAKEN.  ' //
     *   'RUN TERMINATED', -998, 2)
      RETURN
110   CONTINUE
      IWORK(LNSTL)=IWORK(LNST)
C
C-----------------------------------------------------------------------
C     THIS BLOCK IS EXECUTED ON ALL CALLS.
C     THE ERROR TOLERANCE PARAMETERS ARE
C     CHECKED, AND THE WORK ARRAY POINTERS
C     ARE SET.
C-----------------------------------------------------------------------
C
200   CONTINUE
C     CHECK RTOL,ATOL
      NZFLG=0
      RTOLI=RTOL(1)
      ATOLI=ATOL(1)
      DO 210 I=1,NEQ
         IF(INFO(2).EQ.1)RTOLI=RTOL(I)
         IF(INFO(2).EQ.1)ATOLI=ATOL(I)
         IF(RTOLI.GT.0.0D0.OR.ATOLI.GT.0.0D0)NZFLG=1
         IF(RTOLI.LT.0.0D0)GO TO 706
         IF(ATOLI.LT.0.0D0)GO TO 707
210      CONTINUE
      IF(NZFLG.EQ.0)GO TO 708
C
C     SET UP RWORK STORAGE.IWORK STORAGE IS FIXED
C     IN DATA STATEMENT.
      LE=LDELTA+NEQ
      LWT=LE+NEQ
      LPHI=LWT+NEQ
      LPD=LPHI+(IWORK(LMXORD)+1)*NEQ
      LWM=LPD
      NTEMP=NPD+IWORK(LNPD)
      IF(INFO(1).EQ.1)GO TO 400
C
C-----------------------------------------------------------------------
C     THIS BLOCK IS EXECUTED ON THE INITIAL CALL
C     ONLY. SET THE INITIAL STEP SIZE, AND
C     THE ERROR WEIGHT VECTOR, AND PHI.
C     COMPUTE INITIAL YPRIME, IF NECESSARY.
C-----------------------------------------------------------------------
C
      TN=T
      IDID=1
C
C     SET ERROR WEIGHT VECTOR WT
      CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR)
      DO 305 I = 1,NEQ
         IF(RWORK(LWT+I-1).LE.0.0D0) GO TO 713
305      CONTINUE
C
C     COMPUTE UNIT ROUNDOFF AND HMIN
      UROUND = D1MACH(4)
      RWORK(LROUND) = UROUND
      HMIN = 4.0D0*UROUND*MAX(ABS(T),ABS(TOUT))
C
C     CHECK INITIAL INTERVAL TO SEE THAT IT IS LONG ENOUGH
      TDIST = ABS(TOUT - T)
      IF(TDIST .LT. HMIN) GO TO 714
C
C     CHECK HO, IF THIS WAS INPUT
      IF (INFO(8) .EQ. 0) GO TO 310
         HO = RWORK(LH)
         IF ((TOUT - T)*HO .LT. 0.0D0) GO TO 711
         IF (HO .EQ. 0.0D0) GO TO 712
         GO TO 320
310    CONTINUE
C
C     COMPUTE INITIAL STEPSIZE, TO BE USED BY EITHER
C     DDASTP OR DDAINI, DEPENDING ON INFO(11)
      HO = 0.001D0*TDIST
      YPNORM = DDANRM(NEQ,YPRIME,RWORK(LWT),RPAR,IPAR)
      IF (YPNORM .GT. 0.5D0/HO) HO = 0.5D0/YPNORM
      HO = SIGN(HO,TOUT-T)
C     ADJUST HO IF NECESSARY TO MEET HMAX BOUND
320   IF (INFO(7) .EQ. 0) GO TO 330
         RH = ABS(HO)/RWORK(LHMAX)
         IF (RH .GT. 1.0D0) HO = HO/RH
C     COMPUTE TSTOP, IF APPLICABLE
330   IF (INFO(4) .EQ. 0) GO TO 340
         TSTOP = RWORK(LTSTOP)
         IF ((TSTOP - T)*HO .LT. 0.0D0) GO TO 715
         IF ((T + HO - TSTOP)*HO .GT. 0.0D0) HO = TSTOP - T
         IF ((TSTOP - TOUT)*HO .LT. 0.0D0) GO TO 709
C
C     COMPUTE INITIAL DERIVATIVE, UPDATING TN AND Y, IF APPLICABLE
340   IF (INFO(11) .EQ. 0) GO TO 350
      CALL DDAINI(TN,Y,YPRIME,NEQ,
     *  RES,JAC,HO,RWORK(LWT),IDID,RPAR,IPAR,
     *  RWORK(LPHI),RWORK(LDELTA),RWORK(LE),
     *  RWORK(LWM),IWORK(LIWM),HMIN,RWORK(LROUND),
     *  INFO(10),NTEMP)
      IF (IDID .LT. 0) GO TO 390
C
C     LOAD H WITH HO.  STORE H IN RWORK(LH)
350   H = HO
      RWORK(LH) = H
C
C     LOAD Y AND H*YPRIME INTO PHI(*,1) AND PHI(*,2)
      ITEMP = LPHI + NEQ
      DO 370 I = 1,NEQ
         RWORK(LPHI + I - 1) = Y(I)
370      RWORK(ITEMP + I - 1) = H*YPRIME(I)
C
390   GO TO 500
C
C-------------------------------------------------------
C     THIS BLOCK IS FOR CONTINUATION CALLS ONLY. ITS
C     PURPOSE IS TO CHECK STOP CONDITIONS BEFORE
C     TAKING A STEP.
C     ADJUST H IF NECESSARY TO MEET HMAX BOUND
C-------------------------------------------------------
C
400   CONTINUE
      UROUND=RWORK(LROUND)
      DONE = .FALSE.
      TN=RWORK(LTN)
      H=RWORK(LH)
      IF(INFO(7) .EQ. 0) GO TO 410
         RH = ABS(H)/RWORK(LHMAX)
         IF(RH .GT. 1.0D0) H = H/RH
410   CONTINUE
      IF(T .EQ. TOUT) GO TO 719
      IF((T - TOUT)*H .GT. 0.0D0) GO TO 711
      IF(INFO(4) .EQ. 1) GO TO 430
      IF(INFO(3) .EQ. 1) GO TO 420
      IF((TN-TOUT)*H.LT.0.0D0)GO TO 490
      CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
     *  RWORK(LPHI),RWORK(LPSI))
      T=TOUT
      IDID = 3
      DONE = .TRUE.
      GO TO 490
420   IF((TN-T)*H .LE. 0.0D0) GO TO 490
      IF((TN - TOUT)*H .GT. 0.0D0) GO TO 425
      CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD),
     *  RWORK(LPHI),RWORK(LPSI))
      T = TN
      IDID = 1
      DONE = .TRUE.
      GO TO 490
425   CONTINUE
      CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
     *  RWORK(LPHI),RWORK(LPSI))
      T = TOUT
      IDID = 3
      DONE = .TRUE.
      GO TO 490
430   IF(INFO(3) .EQ. 1) GO TO 440
      TSTOP=RWORK(LTSTOP)
      IF((TN-TSTOP)*H.GT.0.0D0) GO TO 715
      IF((TSTOP-TOUT)*H.LT.0.0D0)GO TO 709
      IF((TN-TOUT)*H.LT.0.0D0)GO TO 450
      CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
     *   RWORK(LPHI),RWORK(LPSI))
      T=TOUT
      IDID = 3
      DONE = .TRUE.
      GO TO 490
440   TSTOP = RWORK(LTSTOP)
      IF((TN-TSTOP)*H .GT. 0.0D0) GO TO 715
      IF((TSTOP-TOUT)*H .LT. 0.0D0) GO TO 709
      IF((TN-T)*H .LE. 0.0D0) GO TO 450
      IF((TN - TOUT)*H .GT. 0.0D0) GO TO 445
      CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD),
     *  RWORK(LPHI),RWORK(LPSI))
      T = TN
      IDID = 1
      DONE = .TRUE.
      GO TO 490
445   CONTINUE
      CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
     *  RWORK(LPHI),RWORK(LPSI))
      T = TOUT
      IDID = 3
      DONE = .TRUE.
      GO TO 490
450   CONTINUE
C     CHECK WHETHER WE ARE WITHIN ROUNDOFF OF TSTOP
      IF(ABS(TN-TSTOP).GT.100.0D0*UROUND*
     *   (ABS(TN)+ABS(H)))GO TO 460
      CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD),
     *  RWORK(LPHI),RWORK(LPSI))
      IDID=2
      T=TSTOP
      DONE = .TRUE.
      GO TO 490
460   TNEXT=TN+H
      IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 490
      H=TSTOP-TN
      RWORK(LH)=H
C
490   IF (DONE) GO TO 580
C
C-------------------------------------------------------
C     THE NEXT BLOCK CONTAINS THE CALL TO THE
C     ONE-STEP INTEGRATOR DDASTP.
C     THIS IS A LOOPING POINT FOR THE INTEGRATION STEPS.
C     CHECK FOR TOO MANY STEPS.
C     UPDATE WT.
C     CHECK FOR TOO MUCH ACCURACY REQUESTED.
C     COMPUTE MINIMUM STEPSIZE.
C-------------------------------------------------------
C
500   CONTINUE
C     CHECK FOR FAILURE TO COMPUTE INITIAL YPRIME
      IF (IDID .EQ. -12) GO TO 527
C
C     CHECK FOR TOO MANY STEPS
      IF((IWORK(LNST)-IWORK(LNSTL)).LT.500)
     *   GO TO 510
           IDID=-1
           GO TO 527
C
C     UPDATE WT
510   CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI),
     *  RWORK(LWT),RPAR,IPAR)
      DO 520 I=1,NEQ
         IF(RWORK(I+LWT-1).GT.0.0D0)GO TO 520
           IDID=-3
           GO TO 527
520   CONTINUE
C
C     TEST FOR TOO MUCH ACCURACY REQUESTED.
      R=DDANRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)*
     *   100.0D0*UROUND
      IF(R.LE.1.0D0)GO TO 525
C     MULTIPLY RTOL AND ATOL BY R AND RETURN
      IF(INFO(2).EQ.1)GO TO 523
           RTOL(1)=R*RTOL(1)
           ATOL(1)=R*ATOL(1)
           IDID=-2
           GO TO 527
523   DO 524 I=1,NEQ
           RTOL(I)=R*RTOL(I)
524        ATOL(I)=R*ATOL(I)
      IDID=-2
      GO TO 527
525   CONTINUE
C
C     COMPUTE MINIMUM STEPSIZE
      HMIN=4.0D0*UROUND*MAX(ABS(TN),ABS(TOUT))
C
C     TEST H VS. HMAX
      IF (INFO(7) .EQ. 0) GO TO 526
         RH = ABS(H)/RWORK(LHMAX)
         IF (RH .GT. 1.0D0) H = H/RH
526   CONTINUE           
C
      CALL DDASTP(TN,Y,YPRIME,NEQ,
     *   RES,JAC,H,RWORK(LWT),INFO(1),IDID,RPAR,IPAR,
     *   RWORK(LPHI),RWORK(LDELTA),RWORK(LE),
     *   RWORK(LWM),IWORK(LIWM),
     *   RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA),
     *   RWORK(LPSI),RWORK(LSIGMA),
     *   RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD),
     *   RWORK(LS),HMIN,RWORK(LROUND),
     *   IWORK(LPHASE),IWORK(LJCALC),IWORK(LK),
     *   IWORK(LKOLD),IWORK(LNS),INFO(10),NTEMP)
527   IF(IDID.LT.0)GO TO 600
C
C--------------------------------------------------------
C     THIS BLOCK HANDLES THE CASE OF A SUCCESSFUL RETURN
C     FROM DDASTP (IDID=1).  TEST FOR STOP CONDITIONS.
C--------------------------------------------------------
C
      IF(INFO(4).NE.0)GO TO 540
           IF(INFO(3).NE.0)GO TO 530
             IF((TN-TOUT)*H.LT.0.0D0)GO TO 500
             CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,
     *         IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI))
             IDID=3
             T=TOUT
             GO TO 580
530          IF((TN-TOUT)*H.GE.0.0D0)GO TO 535
             T=TN
             IDID=1
             GO TO 580
535          CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,
     *         IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI))
             IDID=3
             T=TOUT
             GO TO 580
540   IF(INFO(3).NE.0)GO TO 550
      IF((TN-TOUT)*H.LT.0.0D0)GO TO 542
         CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,
     *     IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI))
         T=TOUT
         IDID=3
         GO TO 580
542   IF(ABS(TN-TSTOP).LE.100.0D0*UROUND*
     *   (ABS(TN)+ABS(H)))GO TO 545
      TNEXT=TN+H
      IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 500
      H=TSTOP-TN
      GO TO 500
545   CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ,
     *  IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI))
      IDID=2
      T=TSTOP
      GO TO 580
550   IF((TN-TOUT)*H.GE.0.0D0)GO TO 555
      IF(ABS(TN-TSTOP).LE.100.0D0*UROUND*(ABS(TN)+ABS(H)))GO TO 552
      T=TN
      IDID=1
      GO TO 580
552   CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ,
     *  IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI))
      IDID=2
      T=TSTOP
      GO TO 580
555   CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,
     *   IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI))
      T=TOUT
      IDID=3
      GO TO 580
C
C--------------------------------------------------------
C     ALL SUCCESSFUL RETURNS FROM DDASSL ARE MADE FROM
C     THIS BLOCK.
C--------------------------------------------------------
C
580   CONTINUE
      RWORK(LTN)=TN
      RWORK(LH)=H
      RETURN
C
C-----------------------------------------------------------------------
C     THIS BLOCK HANDLES ALL UNSUCCESSFUL
C     RETURNS OTHER THAN FOR ILLEGAL INPUT.
C-----------------------------------------------------------------------
C
600   CONTINUE
      ITEMP=-IDID
      GO TO (610,620,630,690,690,640,650,660,670,675,
     *  680,685), ITEMP
C
C     THE MAXIMUM NUMBER OF STEPS WAS TAKEN BEFORE
C     REACHING TOUT
610   WRITE (XERN3, '(1P,D15.6)') TN
      CALL XERMSG ('SLATEC', 'DDASSL',
     *   'AT CURRENT T = ' // XERN3 // ' 500 STEPS TAKEN ON THIS ' //
     *   'CALL BEFORE REACHING TOUT', IDID, 1)
      GO TO 690
C
C     TOO MUCH ACCURACY FOR MACHINE PRECISION
620   WRITE (XERN3, '(1P,D15.6)') TN
      CALL XERMSG ('SLATEC', 'DDASSL',
     *   'AT T = ' // XERN3 // ' TOO MUCH ACCURACY REQUESTED FOR ' //
     *   'PRECISION OF MACHINE. RTOL AND ATOL WERE INCREASED TO ' //
     *   'APPROPRIATE VALUES', IDID, 1)
      GO TO 690
C
C     WT(I) .LE. 0.0 FOR SOME I (NOT AT START OF PROBLEM)
630   WRITE (XERN3, '(1P,D15.6)') TN
      CALL XERMSG ('SLATEC', 'DDASSL',
     *   'AT T = ' // XERN3 // ' SOME ELEMENT OF WT HAS BECOME .LE. ' //
     *   '0.0', IDID, 1)
      GO TO 690
C
C     ERROR TEST FAILED REPEATEDLY OR WITH H=HMIN
640   WRITE (XERN3, '(1P,D15.6)') TN
      WRITE (XERN4, '(1P,D15.6)') H
      CALL XERMSG ('SLATEC', 'DDASSL',
     *   'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 //
     *   ' THE ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN',
     *   IDID, 1)
      GO TO 690
C
C     CORRECTOR CONVERGENCE FAILED REPEATEDLY OR WITH H=HMIN
650   WRITE (XERN3, '(1P,D15.6)') TN
      WRITE (XERN4, '(1P,D15.6)') H
      CALL XERMSG ('SLATEC', 'DDASSL',
     *   'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 //
     *   ' THE CORRECTOR FAILED TO CONVERGE REPEATEDLY OR WITH ' //
     *   'ABS(H)=HMIN', IDID, 1)
      GO TO 690
C
C     THE ITERATION MATRIX IS SINGULAR
660   WRITE (XERN3, '(1P,D15.6)') TN
      WRITE (XERN4, '(1P,D15.6)') H
      CALL XERMSG ('SLATEC', 'DDASSL',
     *   'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 //
     *   ' THE ITERATION MATRIX IS SINGULAR', IDID, 1)
      GO TO 690
C
C     CORRECTOR FAILURE PRECEEDED BY ERROR TEST FAILURES.
670   WRITE (XERN3, '(1P,D15.6)') TN
      WRITE (XERN4, '(1P,D15.6)') H
      CALL XERMSG ('SLATEC', 'DDASSL',
     *   'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 //
     *   ' THE CORRECTOR COULD NOT CONVERGE.  ALSO, THE ERROR TEST ' //
     *   'FAILED REPEATEDLY.', IDID, 1)
      GO TO 690
C
C     CORRECTOR FAILURE BECAUSE IRES = -1
675   WRITE (XERN3, '(1P,D15.6)') TN
      WRITE (XERN4, '(1P,D15.6)') H
      CALL XERMSG ('SLATEC', 'DDASSL',
     *   'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 //
     *   ' THE CORRECTOR COULD NOT CONVERGE BECAUSE IRES WAS EQUAL ' //
     *   'TO MINUS ONE', IDID, 1)
      GO TO 690
C
C     FAILURE BECAUSE IRES = -2
680   WRITE (XERN3, '(1P,D15.6)') TN
      WRITE (XERN4, '(1P,D15.6)') H
      CALL XERMSG ('SLATEC', 'DDASSL',
     *   'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 //
     *   ' IRES WAS EQUAL TO MINUS TWO', IDID, 1)
      GO TO 690
C
C     FAILED TO COMPUTE INITIAL YPRIME
685   WRITE (XERN3, '(1P,D15.6)') TN
      WRITE (XERN4, '(1P,D15.6)') HO
      CALL XERMSG ('SLATEC', 'DDASSL',
     *   'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 //
     *   ' THE INITIAL YPRIME COULD NOT BE COMPUTED', IDID, 1)
      GO TO 690
C
690   CONTINUE
      INFO(1)=-1
      T=TN
      RWORK(LTN)=TN
      RWORK(LH)=H
      RETURN
C
C-----------------------------------------------------------------------
C     THIS BLOCK HANDLES ALL ERROR RETURNS DUE
C     TO ILLEGAL INPUT, AS DETECTED BEFORE CALLING
C     DDASTP. FIRST THE ERROR MESSAGE ROUTINE IS
C     CALLED. IF THIS HAPPENS TWICE IN
C     SUCCESSION, EXECUTION IS TERMINATED
C
C-----------------------------------------------------------------------
701   CALL XERMSG ('SLATEC', 'DDASSL',
     *   'SOME ELEMENT OF INFO VECTOR IS NOT ZERO OR ONE', 1, 1)
      GO TO 750
C
702   WRITE (XERN1, '(I8)') NEQ
      CALL XERMSG ('SLATEC', 'DDASSL',
     *   'NEQ = ' // XERN1 // ' .LE. 0', 2, 1)
      GO TO 750
C
703   WRITE (XERN1, '(I8)') MXORD
      CALL XERMSG ('SLATEC', 'DDASSL',
     *   'MAXORD = ' // XERN1 // ' NOT IN RANGE', 3, 1)
      GO TO 750
C
704   WRITE (XERN1, '(I8)') LENRW
      WRITE (XERN2, '(I8)') LRW
      CALL XERMSG ('SLATEC', 'DDASSL',
     *   'RWORK LENGTH NEEDED, LENRW = ' // XERN1 //
     *   ', EXCEEDS LRW = ' // XERN2, 4, 1)
      GO TO 750
C
705   WRITE (XERN1, '(I8)') LENIW
      WRITE (XERN2, '(I8)') LIW
      CALL XERMSG ('SLATEC', 'DDASSL',
     *   'IWORK LENGTH NEEDED, LENIW = ' // XERN1 //
     *   ', EXCEEDS LIW = ' // XERN2, 5, 1)
      GO TO 750
C
706   CALL XERMSG ('SLATEC', 'DDASSL',
     *   'SOME ELEMENT OF RTOL IS .LT. 0', 6, 1)
      GO TO 750
C
707   CALL XERMSG ('SLATEC', 'DDASSL',
     *   'SOME ELEMENT OF ATOL IS .LT. 0', 7, 1)
      GO TO 750
C
708   CALL XERMSG ('SLATEC', 'DDASSL',
     *   'ALL ELEMENTS OF RTOL AND ATOL ARE ZERO', 8, 1)
      GO TO 750
C
709   WRITE (XERN3, '(1P,D15.6)') TSTOP
      WRITE (XERN4, '(1P,D15.6)') TOUT
      CALL XERMSG ('SLATEC', 'DDASSL',
     *   'INFO(4) = 1 AND TSTOP = ' // XERN3 // ' BEHIND TOUT = ' //
     *   XERN4, 9, 1)
      GO TO 750
C
710   WRITE (XERN3, '(1P,D15.6)') HMAX
      CALL XERMSG ('SLATEC', 'DDASSL',
     *   'HMAX = ' // XERN3 // ' .LT. 0.0', 10, 1)
      GO TO 750
C
711   WRITE (XERN3, '(1P,D15.6)') TOUT
      WRITE (XERN4, '(1P,D15.6)') T
      CALL XERMSG ('SLATEC', 'DDASSL',
     *   'TOUT = ' // XERN3 // ' BEHIND T = ' // XERN4, 11, 1)
      GO TO 750
C
712   CALL XERMSG ('SLATEC', 'DDASSL',
     *   'INFO(8)=1 AND H0=0.0', 12, 1)
      GO TO 750
C
713   CALL XERMSG ('SLATEC', 'DDASSL',
     *   'SOME ELEMENT OF WT IS .LE. 0.0', 13, 1)
      GO TO 750
C
714   WRITE (XERN3, '(1P,D15.6)') TOUT
      WRITE (XERN4, '(1P,D15.6)') T
      CALL XERMSG ('SLATEC', 'DDASSL',
     *   'TOUT = ' // XERN3 // ' TOO CLOSE TO T = ' // XERN4 //
     *   ' TO START INTEGRATION', 14, 1)
      GO TO 750
C
715   WRITE (XERN3, '(1P,D15.6)') TSTOP
      WRITE (XERN4, '(1P,D15.6)') T
      CALL XERMSG ('SLATEC', 'DDASSL',
     *   'INFO(4)=1 AND TSTOP = ' // XERN3 // ' BEHIND T = ' // XERN4,
     *   15, 1)
      GO TO 750
C
717   WRITE (XERN1, '(I8)') IWORK(LML)
      CALL XERMSG ('SLATEC', 'DDASSL',
     *   'ML = ' // XERN1 // ' ILLEGAL.  EITHER .LT. 0 OR .GT. NEQ',
     *   17, 1)
      GO TO 750
C
718   WRITE (XERN1, '(I8)') IWORK(LMU)
      CALL XERMSG ('SLATEC', 'DDASSL',
     *   'MU = ' // XERN1 // ' ILLEGAL.  EITHER .LT. 0 OR .GT. NEQ',
     *   18, 1)
      GO TO 750
C
719   WRITE (XERN3, '(1P,D15.6)') TOUT
      CALL XERMSG ('SLATEC', 'DDASSL',
     *  'TOUT = T = ' // XERN3, 19, 1)
      GO TO 750
C
750   IDID=-33
      IF(INFO(1).EQ.-1) THEN
         CALL XERMSG ('SLATEC', 'DDASSL',
     *      'REPEATED OCCURRENCES OF ILLEGAL INPUT$$' //
     *      'RUN TERMINATED. APPARENT INFINITE LOOP', -999, 2)
      ENDIF
C
      INFO(1)=-1
      RETURN
C-----------END OF SUBROUTINE DDASSL------------------------------------
      END
      SUBROUTINE DDAWTS (NEQ, IWT, RTOL, ATOL, Y, WT, RPAR, IPAR)
C***BEGIN PROLOGUE  DDAWTS
C***SUBSIDIARY
C***PURPOSE  Set error weight vector for DDASSL.
C***LIBRARY   SLATEC (DASSL)
C***TYPE      DOUBLE PRECISION (SDAWTS-S, DDAWTS-D)
C***AUTHOR  PETZOLD, LINDA R., (LLNL)
C***DESCRIPTION
C-----------------------------------------------------------------------
C     THIS SUBROUTINE SETS THE ERROR WEIGHT VECTOR
C     WT ACCORDING TO WT(I)=RTOL(I)*ABS(Y(I))+ATOL(I),
C     I=1,-,N.
C     RTOL AND ATOL ARE SCALARS IF IWT = 0,
C     AND VECTORS IF IWT = 1.
C-----------------------------------------------------------------------
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   830315  DATE WRITTEN
C   901009  Finished conversion to SLATEC 4.0 format (F.N.Fritsch)
C   901019  Merged changes made by C. Ulrich with SLATEC 4.0 format.
C   901026  Added explicit declarations for all variables and minor
C           cosmetic changes to prologue.  (FNF)
C***END PROLOGUE  DDAWTS
C
      INTEGER  NEQ, IWT, IPAR(*)
      DOUBLE PRECISION  RTOL(*), ATOL(*), Y(*), WT(*), RPAR(*)
C
      INTEGER  I
      DOUBLE PRECISION  ATOLI, RTOLI
C
C***FIRST EXECUTABLE STATEMENT  DDAWTS
      RTOLI=RTOL(1)
      ATOLI=ATOL(1)
      DO 20 I=1,NEQ
         IF (IWT .EQ.0) GO TO 10
           RTOLI=RTOL(I)
           ATOLI=ATOL(I)
10         WT(I)=RTOLI*ABS(Y(I))+ATOLI
20         CONTINUE
      RETURN
C-----------END OF SUBROUTINE DDAWTS------------------------------------
      END
      DOUBLE PRECISION FUNCTION DDANRM (NEQ, V, WT, RPAR, IPAR)
C***BEGIN PROLOGUE  DDANRM
C***SUBSIDIARY
C***PURPOSE  Compute vector norm for DDASSL.
C***LIBRARY   SLATEC (DASSL)
C***TYPE      DOUBLE PRECISION (SDANRM-S, DDANRM-D)
C***AUTHOR  PETZOLD, LINDA R., (LLNL)
C***DESCRIPTION
C-----------------------------------------------------------------------
C     THIS FUNCTION ROUTINE COMPUTES THE WEIGHTED
C     ROOT-MEAN-SQUARE NORM OF THE VECTOR OF LENGTH
C     NEQ CONTAINED IN THE ARRAY V,WITH WEIGHTS
C     CONTAINED IN THE ARRAY WT OF LENGTH NEQ.
C        DDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2)
C-----------------------------------------------------------------------
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   830315  DATE WRITTEN
C   901009  Finished conversion to SLATEC 4.0 format (F.N.Fritsch)
C   901019  Merged changes made by C. Ulrich with SLATEC 4.0 format.
C   901026  Added explicit declarations for all variables and minor
C           cosmetic changes to prologue.  (FNF)
C***END PROLOGUE  DDANRM
C
      INTEGER  NEQ, IPAR(*)
      DOUBLE PRECISION  V(NEQ), WT(NEQ), RPAR(*)
C
      INTEGER  I
      DOUBLE PRECISION  SUM, VMAX
C
C***FIRST EXECUTABLE STATEMENT  DDANRM
      DDANRM = 0.0D0
      VMAX = 0.0D0
      DO 10 I = 1,NEQ
        IF(ABS(V(I)/WT(I)) .GT. VMAX) VMAX = ABS(V(I)/WT(I))
10      CONTINUE
      IF(VMAX .LE. 0.0D0) GO TO 30
      SUM = 0.0D0
      DO 20 I = 1,NEQ
20      SUM = SUM + ((V(I)/WT(I))/VMAX)**2
      DDANRM = VMAX*SQRT(SUM/NEQ)
30    CONTINUE
      RETURN
C------END OF FUNCTION DDANRM------
      END
      SUBROUTINE DDAINI (X, Y, YPRIME, NEQ, RES, JAC, H, WT, IDID, RPAR,
     +   IPAR, PHI, DELTA, E, WM, IWM, HMIN, UROUND, NONNEG, NTEMP)
C***BEGIN PROLOGUE  DDAINI
C***SUBSIDIARY
C***PURPOSE  Initialization routine for DDASSL.
C***LIBRARY   SLATEC (DASSL)
C***TYPE      DOUBLE PRECISION (SDAINI-S, DDAINI-D)
C***AUTHOR  PETZOLD, LINDA R., (LLNL)
C***DESCRIPTION
C-----------------------------------------------------------------
C     DDAINI TAKES ONE STEP OF SIZE H OR SMALLER
C     WITH THE BACKWARD EULER METHOD, TO
C     FIND YPRIME.  X AND Y ARE UPDATED TO BE CONSISTENT WITH THE
C     NEW STEP.  A MODIFIED DAMPED NEWTON ITERATION IS USED TO
C     SOLVE THE CORRECTOR ITERATION.
C
C     THE INITIAL GUESS FOR YPRIME IS USED IN THE
C     PREDICTION, AND IN FORMING THE ITERATION
C     MATRIX, BUT IS NOT INVOLVED IN THE
C     ERROR TEST. THIS MAY HAVE TROUBLE
C     CONVERGING IF THE INITIAL GUESS IS NO
C     GOOD, OR IF G(X,Y,YPRIME) DEPENDS
C     NONLINEARLY ON YPRIME.
C
C     THE PARAMETERS REPRESENT:
C     X --         INDEPENDENT VARIABLE
C     Y --         SOLUTION VECTOR AT X
C     YPRIME --    DERIVATIVE OF SOLUTION VECTOR
C     NEQ --       NUMBER OF EQUATIONS
C     H --         STEPSIZE. IMDER MAY USE A STEPSIZE
C                  SMALLER THAN H.
C     WT --        VECTOR OF WEIGHTS FOR ERROR
C                  CRITERION
C     IDID --      COMPLETION CODE WITH THE FOLLOWING MEANINGS
C                  IDID= 1 -- YPRIME WAS FOUND SUCCESSFULLY
C                  IDID=-12 -- DDAINI FAILED TO FIND YPRIME
C     RPAR,IPAR -- REAL AND INTEGER PARAMETER ARRAYS
C                  THAT ARE NOT ALTERED BY DDAINI
C     PHI --       WORK SPACE FOR DDAINI
C     DELTA,E --   WORK SPACE FOR DDAINI
C     WM,IWM --    REAL AND INTEGER ARRAYS STORING
C                  MATRIX INFORMATION
C
C-----------------------------------------------------------------
C***ROUTINES CALLED  DDAJAC, DDANRM, DDASLV
C***REVISION HISTORY  (YYMMDD)
C   830315  DATE WRITTEN
C   901009  Finished conversion to SLATEC 4.0 format (F.N.Fritsch)
C   901019  Merged changes made by C. Ulrich with SLATEC 4.0 format.
C   901026  Added explicit declarations for all variables and minor
C           cosmetic changes to prologue.  (FNF)
C   901030  Minor corrections to declarations.  (FNF)
C***END PROLOGUE  DDAINI
C
      INTEGER  NEQ, IDID, IPAR(*), IWM(*), NONNEG, NTEMP
      DOUBLE PRECISION
     *   X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*),
     *   E(*), WM(*), HMIN, UROUND
      EXTERNAL  RES, JAC
C
      EXTERNAL  DDAJAC, DDANRM, DDASLV
      DOUBLE PRECISION  DDANRM
C
      INTEGER  I, IER, IRES, JCALC, LNJE, LNRE, M, MAXIT, MJAC, NCF,
     *   NEF, NSF
      DOUBLE PRECISION
     *   CJ, DAMP, DELNRM, ERR, OLDNRM, R, RATE, S, XOLD, YNORM
      LOGICAL  CONVGD
C
      PARAMETER (LNRE=12)
      PARAMETER (LNJE=13)
C
      DATA MAXIT/10/,MJAC/5/
      DATA DAMP/0.75D0/
C
C
C---------------------------------------------------
C     BLOCK 1.
C     INITIALIZATIONS.
C---------------------------------------------------
C
C***FIRST EXECUTABLE STATEMENT  DDAINI
      IDID=1
      NEF=0
      NCF=0
      NSF=0
      XOLD=X
      YNORM=DDANRM(NEQ,Y,WT,RPAR,IPAR)
C
C     SAVE Y AND YPRIME IN PHI
      DO 100 I=1,NEQ
         PHI(I,1)=Y(I)
100      PHI(I,2)=YPRIME(I)
C
C
C----------------------------------------------------
C     BLOCK 2.
C     DO ONE BACKWARD EULER STEP.
C----------------------------------------------------
C
C     SET UP FOR START OF CORRECTOR ITERATION
200   CJ=1.0D0/H
      X=X+H
C
C     PREDICT SOLUTION AND DERIVATIVE
      DO 250 I=1,NEQ
250     Y(I)=Y(I)+H*YPRIME(I)
C
      JCALC=-1
      M=0
      CONVGD=.TRUE.
C
C
C     CORRECTOR LOOP.
300   IWM(LNRE)=IWM(LNRE)+1
      IRES=0
C
      CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
      IF (IRES.LT.0) GO TO 430
C
C
C     EVALUATE THE ITERATION MATRIX
      IF (JCALC.NE.-1) GO TO 310
      IWM(LNJE)=IWM(LNJE)+1
      JCALC=0
      CALL DDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H,
     *   IER,WT,E,WM,IWM,RES,IRES,
     *   UROUND,JAC,RPAR,IPAR,NTEMP)
C
      S=1000000.D0
      IF (IRES.LT.0) GO TO 430
      IF (IER.NE.0) GO TO 430
      NSF=0
C
C
C
C     MULTIPLY RESIDUAL BY DAMPING FACTOR
310   CONTINUE
      DO 320 I=1,NEQ
320      DELTA(I)=DELTA(I)*DAMP
C
C     COMPUTE A NEW ITERATE (BACK SUBSTITUTION)
C     STORE THE CORRECTION IN DELTA
C
      CALL DDASLV(NEQ,DELTA,WM,IWM)
C
C     UPDATE Y AND YPRIME
      DO 330 I=1,NEQ
         Y(I)=Y(I)-DELTA(I)
330      YPRIME(I)=YPRIME(I)-CJ*DELTA(I)
C
C     TEST FOR CONVERGENCE OF THE ITERATION.
C
      DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR)
      IF (DELNRM.LE.100.D0*UROUND*YNORM)
     *   GO TO 400
C
      IF (M.GT.0) GO TO 340
         OLDNRM=DELNRM
         GO TO 350
C
340   RATE=(DELNRM/OLDNRM)**(1.0D0/M)
      IF (RATE.GT.0.90D0) GO TO 430
      S=RATE/(1.0D0-RATE)
C
350   IF (S*DELNRM .LE. 0.33D0) GO TO 400
C
C
C     THE CORRECTOR HAS NOT YET CONVERGED. UPDATE
C     M AND AND TEST WHETHER THE MAXIMUM
C     NUMBER OF ITERATIONS HAVE BEEN TRIED.
C     EVERY MJAC ITERATIONS, GET A NEW
C     ITERATION MATRIX.
C
      M=M+1
      IF (M.GE.MAXIT) GO TO 430
C
      IF ((M/MJAC)*MJAC.EQ.M) JCALC=-1
      GO TO 300
C
C
C     THE ITERATION HAS CONVERGED.
C     CHECK NONNEGATIVITY CONSTRAINTS
400   IF (NONNEG.EQ.0) GO TO 450
      DO 410 I=1,NEQ
410      DELTA(I)=MIN(Y(I),0.0D0)
C
      DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR)
      IF (DELNRM.GT.0.33D0) GO TO 430
C
      DO 420 I=1,NEQ
         Y(I)=Y(I)-DELTA(I)
420      YPRIME(I)=YPRIME(I)-CJ*DELTA(I)
      GO TO 450
C
C
C     EXITS FROM CORRECTOR LOOP.
430   CONVGD=.FALSE.
450   IF (.NOT.CONVGD) GO TO 600
C
C
C
C-----------------------------------------------------
C     BLOCK 3.
C     THE CORRECTOR ITERATION CONVERGED.
C     DO ERROR TEST.
C-----------------------------------------------------
C
      DO 510 I=1,NEQ
510      E(I)=Y(I)-PHI(I,1)
      ERR=DDANRM(NEQ,E,WT,RPAR,IPAR)
C
      IF (ERR.LE.1.0D0) RETURN
C
C
C
C--------------------------------------------------------
C     BLOCK 4.
C     THE BACKWARD EULER STEP FAILED. RESTORE X, Y
C     AND YPRIME TO THEIR ORIGINAL VALUES.
C     REDUCE STEPSIZE AND TRY AGAIN, IF
C     POSSIBLE.
C---------------------------------------------------------
C
600   CONTINUE
      X = XOLD
      DO 610 I=1,NEQ
         Y(I)=PHI(I,1)
610      YPRIME(I)=PHI(I,2)
C
      IF (CONVGD) GO TO 640
      IF (IER.EQ.0) GO TO 620
         NSF=NSF+1
         H=H*0.25D0
         IF (NSF.LT.3.AND.ABS(H).GE.HMIN) GO TO 690
         IDID=-12
         RETURN
620   IF (IRES.GT.-2) GO TO 630
         IDID=-12
         RETURN
630   NCF=NCF+1
      H=H*0.25D0
      IF (NCF.LT.10.AND.ABS(H).GE.HMIN) GO TO 690
         IDID=-12
         RETURN
C
640   NEF=NEF+1
      R=0.90D0/(2.0D0*ERR+0.0001D0)
      R=MAX(0.1D0,MIN(0.5D0,R))
      H=H*R
      IF (ABS(H).GE.HMIN.AND.NEF.LT.10) GO TO 690
         IDID=-12
         RETURN
690      GO TO 200
C
C-------------END OF SUBROUTINE DDAINI----------------------
      END
      SUBROUTINE DDATRP (X, XOUT, YOUT, YPOUT, NEQ, KOLD, PHI, PSI)
C***BEGIN PROLOGUE  DDATRP
C***SUBSIDIARY
C***PURPOSE  Interpolation routine for DDASSL.
C***LIBRARY   SLATEC (DASSL)
C***TYPE      DOUBLE PRECISION (SDATRP-S, DDATRP-D)
C***AUTHOR  PETZOLD, LINDA R., (LLNL)
C***DESCRIPTION
C-----------------------------------------------------------------------
C     THE METHODS IN SUBROUTINE DDASTP USE POLYNOMIALS
C     TO APPROXIMATE THE SOLUTION. DDATRP APPROXIMATES THE
C     SOLUTION AND ITS DERIVATIVE AT TIME XOUT BY EVALUATING
C     ONE OF THESE POLYNOMIALS,AND ITS DERIVATIVE,THERE.
C     INFORMATION DEFINING THIS POLYNOMIAL IS PASSED FROM
C     DDASTP, SO DDATRP CANNOT BE USED ALONE.
C
C     THE PARAMETERS ARE:
C     X     THE CURRENT TIME IN THE INTEGRATION.
C     XOUT  THE TIME AT WHICH THE SOLUTION IS DESIRED
C     YOUT  THE INTERPOLATED APPROXIMATION TO Y AT XOUT
C           (THIS IS OUTPUT)
C     YPOUT THE INTERPOLATED APPROXIMATION TO YPRIME AT XOUT
C           (THIS IS OUTPUT)
C     NEQ   NUMBER OF EQUATIONS
C     KOLD  ORDER USED ON LAST SUCCESSFUL STEP
C     PHI   ARRAY OF SCALED DIVIDED DIFFERENCES OF Y
C     PSI   ARRAY OF PAST STEPSIZE HISTORY
C-----------------------------------------------------------------------
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   830315  DATE WRITTEN
C   901009  Finished conversion to SLATEC 4.0 format (F.N.Fritsch)
C   901019  Merged changes made by C. Ulrich with SLATEC 4.0 format.
C   901026  Added explicit declarations for all variables and minor
C           cosmetic changes to prologue.  (FNF)
C***END PROLOGUE  DDATRP
C
      INTEGER  NEQ, KOLD
      DOUBLE PRECISION  X, XOUT, YOUT(*), YPOUT(*), PHI(NEQ,*), PSI(*)
C
      INTEGER  I, J, KOLDP1
      DOUBLE PRECISION  C, D, GAMMA, TEMP1
C
C***FIRST EXECUTABLE STATEMENT  DDATRP
      KOLDP1=KOLD+1
      TEMP1=XOUT-X
      DO 10 I=1,NEQ
         YOUT(I)=PHI(I,1)
10       YPOUT(I)=0.0D0
      C=1.0D0
      D=0.0D0
      GAMMA=TEMP1/PSI(1)
      DO 30 J=2,KOLDP1
         D=D*GAMMA+C/PSI(J-1)
         C=C*GAMMA
         GAMMA=(TEMP1+PSI(J-1))/PSI(J)
         DO 20 I=1,NEQ
            YOUT(I)=YOUT(I)+C*PHI(I,J)
20          YPOUT(I)=YPOUT(I)+D*PHI(I,J)
30       CONTINUE
      RETURN
C
C------END OF SUBROUTINE DDATRP------
      END
      SUBROUTINE DDASTP (X, Y, YPRIME, NEQ, RES, JAC, H, WT, JSTART,
     +   IDID, RPAR, IPAR, PHI, DELTA, E, WM, IWM, ALPHA, BETA, GAMMA,
     +   PSI, SIGMA, CJ, CJOLD, HOLD, S, HMIN, UROUND, IPHASE, JCALC,
     +   K, KOLD, NS, NONNEG, NTEMP)
C***BEGIN PROLOGUE  DDASTP
C***SUBSIDIARY
C***PURPOSE  Perform one step of the DDASSL integration.
C***LIBRARY   SLATEC (DASSL)
C***TYPE      DOUBLE PRECISION (SDASTP-S, DDASTP-D)
C***AUTHOR  PETZOLD, LINDA R., (LLNL)
C***DESCRIPTION
C-----------------------------------------------------------------------
C     DDASTP SOLVES A SYSTEM OF DIFFERENTIAL/
C     ALGEBRAIC EQUATIONS OF THE FORM
C     G(X,Y,YPRIME) = 0,  FOR ONE STEP (NORMALLY
C     FROM X TO X+H).
C
C     THE METHODS USED ARE MODIFIED DIVIDED
C     DIFFERENCE,FIXED LEADING COEFFICIENT
C     FORMS OF BACKWARD DIFFERENTIATION
C     FORMULAS. THE CODE ADJUSTS THE STEPSIZE
C     AND ORDER TO CONTROL THE LOCAL ERROR PER
C     STEP.
C
C
C     THE PARAMETERS REPRESENT
C     X  --        INDEPENDENT VARIABLE
C     Y  --        SOLUTION VECTOR AT X
C     YPRIME --    DERIVATIVE OF SOLUTION VECTOR
C                  AFTER SUCCESSFUL STEP
C     NEQ --       NUMBER OF EQUATIONS TO BE INTEGRATED
C     RES --       EXTERNAL USER-SUPPLIED SUBROUTINE
C                  TO EVALUATE THE RESIDUAL.  THE CALL IS
C                  CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
C                  X,Y,YPRIME ARE INPUT.  DELTA IS OUTPUT.
C                  ON INPUT, IRES=0.  RES SHOULD ALTER IRES ONLY
C                  IF IT ENCOUNTERS AN ILLEGAL VALUE OF Y OR A
C                  STOP CONDITION.  SET IRES=-1 IF AN INPUT VALUE
C                  OF Y IS ILLEGAL, AND DDASTP WILL TRY TO SOLVE
C                  THE PROBLEM WITHOUT GETTING IRES = -1.  IF
C                  IRES=-2, DDASTP RETURNS CONTROL TO THE CALLING
C                  PROGRAM WITH IDID = -11.
C     JAC --       EXTERNAL USER-SUPPLIED ROUTINE TO EVALUATE
C                  THE ITERATION MATRIX (THIS IS OPTIONAL)
C                  THE CALL IS OF THE FORM
C                  CALL JAC(X,Y,YPRIME,PD,CJ,RPAR,IPAR)
C                  PD IS THE MATRIX OF PARTIAL DERIVATIVES,
C                  PD=DG/DY+CJ*DG/DYPRIME
C     H --         APPROPRIATE STEP SIZE FOR NEXT STEP.
C                  NORMALLY DETERMINED BY THE CODE
C     WT --        VECTOR OF WEIGHTS FOR ERROR CRITERION.
C     JSTART --    INTEGER VARIABLE SET 0 FOR
C                  FIRST STEP, 1 OTHERWISE.
C     IDID --      COMPLETION CODE WITH THE FOLLOWING MEANINGS:
C                  IDID= 1 -- THE STEP WAS COMPLETED SUCCESSFULLY
C                  IDID=-6 -- THE ERROR TEST FAILED REPEATEDLY
C                  IDID=-7 -- THE CORRECTOR COULD NOT CONVERGE
C                  IDID=-8 -- THE ITERATION MATRIX IS SINGULAR
C                  IDID=-9 -- THE CORRECTOR COULD NOT CONVERGE.
C                             THERE WERE REPEATED ERROR TEST
C                             FAILURES ON THIS STEP.
C                  IDID=-10-- THE CORRECTOR COULD NOT CONVERGE
C                             BECAUSE IRES WAS EQUAL TO MINUS ONE
C                  IDID=-11-- IRES EQUAL TO -2 WAS ENCOUNTERED,
C                             AND CONTROL IS BEING RETURNED TO
C                             THE CALLING PROGRAM
C     RPAR,IPAR -- REAL AND INTEGER PARAMETER ARRAYS THAT
C                  ARE USED FOR COMMUNICATION BETWEEN THE
C                  CALLING PROGRAM AND EXTERNAL USER ROUTINES
C                  THEY ARE NOT ALTERED BY DDASTP
C     PHI --       ARRAY OF DIVIDED DIFFERENCES USED BY
C                  DDASTP. THE LENGTH IS NEQ*(K+1),WHERE
C                  K IS THE MAXIMUM ORDER
C     DELTA,E --   WORK VECTORS FOR DDASTP OF LENGTH NEQ
C     WM,IWM --    REAL AND INTEGER ARRAYS STORING
C                  MATRIX INFORMATION SUCH AS THE MATRIX
C                  OF PARTIAL DERIVATIVES,PERMUTATION
C                  VECTOR,AND VARIOUS OTHER INFORMATION.
C
C     THE OTHER PARAMETERS ARE INFORMATION
C     WHICH IS NEEDED INTERNALLY BY DDASTP TO
C     CONTINUE FROM STEP TO STEP.
C
C-----------------------------------------------------------------------
C***ROUTINES CALLED  DDAJAC, DDANRM, DDASLV, DDATRP
C***REVISION HISTORY  (YYMMDD)
C   830315  DATE WRITTEN
C   901009  Finished conversion to SLATEC 4.0 format (F.N.Fritsch)
C   901019  Merged changes made by C. Ulrich with SLATEC 4.0 format.
C   901026  Added explicit declarations for all variables and minor
C           cosmetic changes to prologue.  (FNF)
C***END PROLOGUE  DDASTP
C
      INTEGER  NEQ, JSTART, IDID, IPAR(*), IWM(*), IPHASE, JCALC, K,
     *   KOLD, NS, NONNEG, NTEMP
      DOUBLE PRECISION
     *   X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*),
     *   E(*), WM(*), ALPHA(*), BETA(*), GAMMA(*), PSI(*), SIGMA(*), CJ,
     *   CJOLD, HOLD, S, HMIN, UROUND
      EXTERNAL  RES, JAC
C
      EXTERNAL  DDAJAC, DDANRM, DDASLV, DDATRP
      DOUBLE PRECISION  DDANRM
C
      INTEGER  I, IER, IRES, J, J1, KDIFF, KM1, KNEW, KP1, KP2, LCTF,
     *   LETF, LMXORD, LNJE, LNRE, LNST, M, MAXIT, NCF, NEF, NSF, NSP1
      DOUBLE PRECISION
     *   ALPHA0, ALPHAS, CJLAST, CK, DELNRM, ENORM, ERK, ERKM1,
     *   ERKM2, ERKP1, ERR, EST, HNEW, OLDNRM, PNORM, R, RATE, TEMP1,
     *   TEMP2, TERK, TERKM1, TERKM2, TERKP1, XOLD, XRATE
      LOGICAL  CONVGD
C
      PARAMETER (LMXORD=3)
      PARAMETER (LNST=11)
      PARAMETER (LNRE=12)
      PARAMETER (LNJE=13)
      PARAMETER (LETF=14)
      PARAMETER (LCTF=15)
C
      DATA MAXIT/4/
      DATA XRATE/0.25D0/
C
C
C
C
C
C-----------------------------------------------------------------------
C     BLOCK 1.
C     INITIALIZE. ON THE FIRST CALL,SET
C     THE ORDER TO 1 AND INITIALIZE
C     OTHER VARIABLES.
C-----------------------------------------------------------------------
C
C     INITIALIZATIONS FOR ALL CALLS
C***FIRST EXECUTABLE STATEMENT  DDASTP
      IDID=1
      XOLD=X
      NCF=0
      NSF=0
      NEF=0
      IF(JSTART .NE. 0) GO TO 120
C
C     IF THIS IS THE FIRST STEP,PERFORM
C     OTHER INITIALIZATIONS
      IWM(LETF) = 0
      IWM(LCTF) = 0
      K=1
      KOLD=0
      HOLD=0.0D0
      JSTART=1
      PSI(1)=H
      CJOLD = 1.0D0/H
      CJ = CJOLD
      S = 100.D0
      JCALC = -1
      DELNRM=1.0D0
      IPHASE = 0
      NS=0
120   CONTINUE
C
C
C
C
C
C-----------------------------------------------------------------------
C     BLOCK 2
C     COMPUTE COEFFICIENTS OF FORMULAS FOR
C     THIS STEP.
C-----------------------------------------------------------------------
200   CONTINUE
      KP1=K+1
      KP2=K+2
      KM1=K-1
      XOLD=X
      IF(H.NE.HOLD.OR.K .NE. KOLD) NS = 0
      NS=MIN(NS+1,KOLD+2)
      NSP1=NS+1
      IF(KP1 .LT. NS)GO TO 230
C
      BETA(1)=1.0D0
      ALPHA(1)=1.0D0
      TEMP1=H
      GAMMA(1)=0.0D0
      SIGMA(1)=1.0D0
      DO 210 I=2,KP1
         TEMP2=PSI(I-1)
         PSI(I-1)=TEMP1
         BETA(I)=BETA(I-1)*PSI(I-1)/TEMP2
         TEMP1=TEMP2+H
         ALPHA(I)=H/TEMP1
         SIGMA(I)=(I-1)*SIGMA(I-1)*ALPHA(I)
         GAMMA(I)=GAMMA(I-1)+ALPHA(I-1)/H
210      CONTINUE
      PSI(KP1)=TEMP1
230   CONTINUE
C
C     COMPUTE ALPHAS, ALPHA0
      ALPHAS = 0.0D0
      ALPHA0 = 0.0D0
      DO 240 I = 1,K
        ALPHAS = ALPHAS - 1.0D0/I
        ALPHA0 = ALPHA0 - ALPHA(I)
240     CONTINUE
C
C     COMPUTE LEADING COEFFICIENT CJ
      CJLAST = CJ
      CJ = -ALPHAS/H
C
C     COMPUTE VARIABLE STEPSIZE ERROR COEFFICIENT CK
      CK = ABS(ALPHA(KP1) + ALPHAS - ALPHA0)
      CK = MAX(CK,ALPHA(KP1))
C
C     DECIDE WHETHER NEW JACOBIAN IS NEEDED
      TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE)
      TEMP2 = 1.0D0/TEMP1
      IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1
      IF (CJ .NE. CJLAST) S = 100.D0
C
C     CHANGE PHI TO PHI STAR
      IF(KP1 .LT. NSP1) GO TO 280
      DO 270 J=NSP1,KP1
         DO 260 I=1,NEQ
260         PHI(I,J)=BETA(J)*PHI(I,J)
270      CONTINUE
280   CONTINUE
C
C     UPDATE TIME
      X=X+H
C
C
C
C
C
C-----------------------------------------------------------------------
C     BLOCK 3
C     PREDICT THE SOLUTION AND DERIVATIVE,
C     AND SOLVE THE CORRECTOR EQUATION
C-----------------------------------------------------------------------
C
C     FIRST,PREDICT THE SOLUTION AND DERIVATIVE
300   CONTINUE
      DO 310 I=1,NEQ
         Y(I)=PHI(I,1)
310      YPRIME(I)=0.0D0
      DO 330 J=2,KP1
         DO 320 I=1,NEQ
            Y(I)=Y(I)+PHI(I,J)
320         YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J)
330   CONTINUE
      PNORM = DDANRM (NEQ,Y,WT,RPAR,IPAR)
C
C
C
C     SOLVE THE CORRECTOR EQUATION USING A
C     MODIFIED NEWTON SCHEME.
      CONVGD= .TRUE.
      M=0
      IWM(LNRE)=IWM(LNRE)+1
      IRES = 0
      CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
      IF (IRES .LT. 0) GO TO 380
C
C
C     IF INDICATED,REEVALUATE THE
C     ITERATION MATRIX PD = DG/DY + CJ*DG/DYPRIME
C     (WHERE G(X,Y,YPRIME)=0). SET
C     JCALC TO 0 AS AN INDICATOR THAT
C     THIS HAS BEEN DONE.
      IF(JCALC .NE. -1)GO TO 340
      IWM(LNJE)=IWM(LNJE)+1
      JCALC=0
      CALL DDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H,
     * IER,WT,E,WM,IWM,RES,IRES,UROUND,JAC,RPAR,
     * IPAR,NTEMP)
      CJOLD=CJ
      S = 100.D0
      IF (IRES .LT. 0) GO TO 380
      IF(IER .NE. 0)GO TO 380
      NSF=0
C
C
C     INITIALIZE THE ERROR ACCUMULATION VECTOR E.
340   CONTINUE
      DO 345 I=1,NEQ
345      E(I)=0.0D0
C
C
C     CORRECTOR LOOP.
350   CONTINUE
C
C     MULTIPLY RESIDUAL BY TEMP1 TO ACCELERATE CONVERGENCE
      TEMP1 = 2.0D0/(1.0D0 + CJ/CJOLD)
      DO 355 I = 1,NEQ
355     DELTA(I) = DELTA(I) * TEMP1
C
C     COMPUTE A NEW ITERATE (BACK-SUBSTITUTION).
C     STORE THE CORRECTION IN DELTA.
      CALL DDASLV(NEQ,DELTA,WM,IWM)
C
C     UPDATE Y,E,AND YPRIME
      DO 360 I=1,NEQ
         Y(I)=Y(I)-DELTA(I)
         E(I)=E(I)-DELTA(I)
360      YPRIME(I)=YPRIME(I)-CJ*DELTA(I)
C
C     TEST FOR CONVERGENCE OF THE ITERATION
      DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR)
      IF (DELNRM .LE. 100.D0*UROUND*PNORM) GO TO 375
      IF (M .GT. 0) GO TO 365
         OLDNRM = DELNRM
         GO TO 367
365   RATE = (DELNRM/OLDNRM)**(1.0D0/M)
      IF (RATE .GT. 0.90D0) GO TO 370
      S = RATE/(1.0D0 - RATE)
367   IF (S*DELNRM .LE. 0.33D0) GO TO 375
C
C     THE CORRECTOR HAS NOT YET CONVERGED.
C     UPDATE M AND TEST WHETHER THE
C     MAXIMUM NUMBER OF ITERATIONS HAVE
C     BEEN TRIED.
      M=M+1
      IF(M.GE.MAXIT)GO TO 370
C
C     EVALUATE THE RESIDUAL
C     AND GO BACK TO DO ANOTHER ITERATION
      IWM(LNRE)=IWM(LNRE)+1
      IRES = 0
      CALL RES(X,Y,YPRIME,DELTA,IRES,
     *  RPAR,IPAR)
      IF (IRES .LT. 0) GO TO 380
      GO TO 350
C
C
C     THE CORRECTOR FAILED TO CONVERGE IN MAXIT
C     ITERATIONS. IF THE ITERATION MATRIX
C     IS NOT CURRENT,RE-DO THE STEP WITH
C     A NEW ITERATION MATRIX.
370   CONTINUE
      IF(JCALC.EQ.0)GO TO 380
      JCALC=-1
      GO TO 300
C
C
C     THE ITERATION HAS CONVERGED.  IF NONNEGATIVITY OF SOLUTION IS
C     REQUIRED, SET THE SOLUTION NONNEGATIVE, IF THE PERTURBATION
C     TO DO IT IS SMALL ENOUGH.  IF THE CHANGE IS TOO LARGE, THEN
C     CONSIDER THE CORRECTOR ITERATION TO HAVE FAILED.
375   IF(NONNEG .EQ. 0) GO TO 390
      DO 377 I = 1,NEQ
377      DELTA(I) = MIN(Y(I),0.0D0)
      DELNRM = DDANRM(NEQ,DELTA,WT,RPAR,IPAR)
      IF(DELNRM .GT. 0.33D0) GO TO 380
      DO 378 I = 1,NEQ
378      E(I) = E(I) - DELTA(I)
      GO TO 390
C
C
C     EXITS FROM BLOCK 3
C     NO CONVERGENCE WITH CURRENT ITERATION
C     MATRIX,OR SINGULAR ITERATION MATRIX
380   CONVGD= .FALSE.
390   JCALC = 1
      IF(.NOT.CONVGD)GO TO 600
C
C
C
C
C
C-----------------------------------------------------------------------
C     BLOCK 4
C     ESTIMATE THE ERRORS AT ORDERS K,K-1,K-2
C     AS IF CONSTANT STEPSIZE WAS USED. ESTIMATE
C     THE LOCAL ERROR AT ORDER K AND TEST
C     WHETHER THE CURRENT STEP IS SUCCESSFUL.
C-----------------------------------------------------------------------
C
C     ESTIMATE ERRORS AT ORDERS K,K-1,K-2
      ENORM = DDANRM(NEQ,E,WT,RPAR,IPAR)
      ERK = SIGMA(K+1)*ENORM
      TERK = (K+1)*ERK
      EST = ERK
      KNEW=K
      IF(K .EQ. 1)GO TO 430
      DO 405 I = 1,NEQ
405     DELTA(I) = PHI(I,KP1) + E(I)
      ERKM1=SIGMA(K)*DDANRM(NEQ,DELTA,WT,RPAR,IPAR)
      TERKM1 = K*ERKM1
      IF(K .GT. 2)GO TO 410
      IF(TERKM1 .LE. 0.5D0*TERK)GO TO 420
      GO TO 430
410   CONTINUE
      DO 415 I = 1,NEQ
415     DELTA(I) = PHI(I,K) + DELTA(I)
      ERKM2=SIGMA(K-1)*DDANRM(NEQ,DELTA,WT,RPAR,IPAR)
      TERKM2 = (K-1)*ERKM2
      IF(MAX(TERKM1,TERKM2).GT.TERK)GO TO 430
C     LOWER THE ORDER
420   CONTINUE
      KNEW=K-1
      EST = ERKM1
C
C
C     CALCULATE THE LOCAL ERROR FOR THE CURRENT STEP
C     TO SEE IF THE STEP WAS SUCCESSFUL
430   CONTINUE
      ERR = CK * ENORM
      IF(ERR .GT. 1.0D0)GO TO 600
C
C
C
C
C
C-----------------------------------------------------------------------
C     BLOCK 5
C     THE STEP IS SUCCESSFUL. DETERMINE
C     THE BEST ORDER AND STEPSIZE FOR
C     THE NEXT STEP. UPDATE THE DIFFERENCES
C     FOR THE NEXT STEP.
C-----------------------------------------------------------------------
      IDID=1
      IWM(LNST)=IWM(LNST)+1
      KDIFF=K-KOLD
      KOLD=K
      HOLD=H
C
C
C     ESTIMATE THE ERROR AT ORDER K+1 UNLESS:
C        ALREADY DECIDED TO LOWER ORDER, OR
C        ALREADY USING MAXIMUM ORDER, OR
C        STEPSIZE NOT CONSTANT, OR
C        ORDER RAISED IN PREVIOUS STEP
      IF(KNEW.EQ.KM1.OR.K.EQ.IWM(LMXORD))IPHASE=1
      IF(IPHASE .EQ. 0)GO TO 545
      IF(KNEW.EQ.KM1)GO TO 540
      IF(K.EQ.IWM(LMXORD)) GO TO 550
      IF(KP1.GE.NS.OR.KDIFF.EQ.1)GO TO 550
      DO 510 I=1,NEQ
510      DELTA(I)=E(I)-PHI(I,KP2)
      ERKP1 = (1.0D0/(K+2))*DDANRM(NEQ,DELTA,WT,RPAR,IPAR)
      TERKP1 = (K+2)*ERKP1
      IF(K.GT.1)GO TO 520
      IF(TERKP1.GE.0.5D0*TERK)GO TO 550
      GO TO 530
520   IF(TERKM1.LE.MIN(TERK,TERKP1))GO TO 540
      IF(TERKP1.GE.TERK.OR.K.EQ.IWM(LMXORD))GO TO 550
C
C     RAISE ORDER
530   K=KP1
      EST = ERKP1
      GO TO 550
C
C     LOWER ORDER
540   K=KM1
      EST = ERKM1
      GO TO 550
C
C     IF IPHASE = 0, INCREASE ORDER BY ONE AND MULTIPLY STEPSIZE BY
C     FACTOR TWO
545   K = KP1
      HNEW = H*2.0D0
      H = HNEW
      GO TO 575
C
C
C     DETERMINE THE APPROPRIATE STEPSIZE FOR
C     THE NEXT STEP.
550   HNEW=H
      TEMP2=K+1
      R=(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2)
      IF(R .LT. 2.0D0) GO TO 555
      HNEW = 2.0D0*H
      GO TO 560
555   IF(R .GT. 1.0D0) GO TO 560
      R = MAX(0.5D0,MIN(0.9D0,R))
      HNEW = H*R
560   H=HNEW
C
C
C     UPDATE DIFFERENCES FOR NEXT STEP
575   CONTINUE
      IF(KOLD.EQ.IWM(LMXORD))GO TO 585
      DO 580 I=1,NEQ
580      PHI(I,KP2)=E(I)
585   CONTINUE
      DO 590 I=1,NEQ
590      PHI(I,KP1)=PHI(I,KP1)+E(I)
      DO 595 J1=2,KP1
         J=KP1-J1+1
         DO 595 I=1,NEQ
595      PHI(I,J)=PHI(I,J)+PHI(I,J+1)
      RETURN
C
C
C
C
C
C-----------------------------------------------------------------------
C     BLOCK 6
C     THE STEP IS UNSUCCESSFUL. RESTORE X,PSI,PHI
C     DETERMINE APPROPRIATE STEPSIZE FOR
C     CONTINUING THE INTEGRATION, OR EXIT WITH
C     AN ERROR FLAG IF THERE HAVE BEEN MANY
C     FAILURES.
C-----------------------------------------------------------------------
600   IPHASE = 1
C
C     RESTORE X,PHI,PSI
      X=XOLD
      IF(KP1.LT.NSP1)GO TO 630
      DO 620 J=NSP1,KP1
         TEMP1=1.0D0/BETA(J)
         DO 610 I=1,NEQ
610         PHI(I,J)=TEMP1*PHI(I,J)
620      CONTINUE
630   CONTINUE
      DO 640 I=2,KP1
640      PSI(I-1)=PSI(I)-H
C
C
C     TEST WHETHER FAILURE IS DUE TO CORRECTOR ITERATION
C     OR ERROR TEST
      IF(CONVGD)GO TO 660
      IWM(LCTF)=IWM(LCTF)+1
C
C
C     THE NEWTON ITERATION FAILED TO CONVERGE WITH
C     A CURRENT ITERATION MATRIX.  DETERMINE THE CAUSE
C     OF THE FAILURE AND TAKE APPROPRIATE ACTION.
      IF(IER.EQ.0)GO TO 650
C
C     THE ITERATION MATRIX IS SINGULAR. REDUCE
C     THE STEPSIZE BY A FACTOR OF 4. IF
C     THIS HAPPENS THREE TIMES IN A ROW ON
C     THE SAME STEP, RETURN WITH AN ERROR FLAG
      NSF=NSF+1
      R = 0.25D0
      H=H*R
      IF (NSF .LT. 3 .AND. ABS(H) .GE. HMIN) GO TO 690
      IDID=-8
      GO TO 675
C
C
C     THE NEWTON ITERATION FAILED TO CONVERGE FOR A REASON
C     OTHER THAN A SINGULAR ITERATION MATRIX.  IF IRES = -2, THEN
C     RETURN.  OTHERWISE, REDUCE THE STEPSIZE AND TRY AGAIN, UNLESS
C     TOO MANY FAILURES HAVE OCCURED.
650   CONTINUE
      IF (IRES .GT. -2) GO TO 655
      IDID = -11
      GO TO 675
655   NCF = NCF + 1
      R = 0.25D0
      H = H*R
      IF (NCF .LT. 10 .AND. ABS(H) .GE. HMIN) GO TO 690
      IDID = -7
      IF (IRES .LT. 0) IDID = -10
      IF (NEF .GE. 3) IDID = -9
      GO TO 675
C
C
C     THE NEWTON SCHEME CONVERGED,AND THE CAUSE
C     OF THE FAILURE WAS THE ERROR ESTIMATE
C     EXCEEDING THE TOLERANCE.
660   NEF=NEF+1
      IWM(LETF)=IWM(LETF)+1
      IF (NEF .GT. 1) GO TO 665
C
C     ON FIRST ERROR TEST FAILURE, KEEP CURRENT ORDER OR LOWER
C     ORDER BY ONE.  COMPUTE NEW STEPSIZE BASED ON DIFFERENCES
C     OF THE SOLUTION.
      K = KNEW
      TEMP2 = K + 1
      R = 0.90D0*(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2)
      R = MAX(0.25D0,MIN(0.9D0,R))
      H = H*R
      IF (ABS(H) .GE. HMIN) GO TO 690
      IDID = -6
      GO TO 675
C
C     ON SECOND ERROR TEST FAILURE, USE THE CURRENT ORDER OR
C     DECREASE ORDER BY ONE.  REDUCE THE STEPSIZE BY A FACTOR OF
C     FOUR.
665   IF (NEF .GT. 2) GO TO 670
      K = KNEW
      H = 0.25D0*H
      IF (ABS(H) .GE. HMIN) GO TO 690
      IDID = -6
      GO TO 675
C
C     ON THIRD AND SUBSEQUENT ERROR TEST FAILURES, SET THE ORDER TO
C     ONE AND REDUCE THE STEPSIZE BY A FACTOR OF FOUR.
670   K = 1
      H = 0.25D0*H
      IF (ABS(H) .GE. HMIN) GO TO 690
      IDID = -6
      GO TO 675
C
C
C
C
C     FOR ALL CRASHES, RESTORE Y TO ITS LAST VALUE,
C     INTERPOLATE TO FIND YPRIME AT LAST X, AND RETURN
675   CONTINUE
      CALL DDATRP(X,X,Y,YPRIME,NEQ,K,PHI,PSI)
      RETURN
C
C
C     GO BACK AND TRY THIS STEP AGAIN
690   GO TO 200
C
C------END OF SUBROUTINE DDASTP------
      END
      SUBROUTINE DDAJAC (NEQ, X, Y, YPRIME, DELTA, CJ, H,
     +   IER, WT, E, WM, IWM, RES, IRES, UROUND, JAC, RPAR,
     +   IPAR, NTEMP)
C***BEGIN PROLOGUE  DDAJAC
C***SUBSIDIARY
C***PURPOSE  Compute the iteration matrix for DDASSL and form the
C            LU-decomposition.
C***LIBRARY   SLATEC (DASSL)
C***TYPE      DOUBLE PRECISION (SDAJAC-S, DDAJAC-D)
C***AUTHOR  PETZOLD, LINDA R., (LLNL)
C***DESCRIPTION
C-----------------------------------------------------------------------
C     THIS ROUTINE COMPUTES THE ITERATION MATRIX
C     PD=DG/DY+CJ*DG/DYPRIME (WHERE G(X,Y,YPRIME)=0).
C     HERE PD IS COMPUTED BY THE USER-SUPPLIED
C     ROUTINE JAC IF IWM(MTYPE) IS 1 OR 4, AND
C     IT IS COMPUTED BY NUMERICAL FINITE DIFFERENCING
C     IF IWM(MTYPE)IS 2 OR 5
C     THE PARAMETERS HAVE THE FOLLOWING MEANINGS.
C     Y        = ARRAY CONTAINING PREDICTED VALUES
C     YPRIME   = ARRAY CONTAINING PREDICTED DERIVATIVES
C     DELTA    = RESIDUAL EVALUATED AT (X,Y,YPRIME)
C                (USED ONLY IF IWM(MTYPE)=2 OR 5)
C     CJ       = SCALAR PARAMETER DEFINING ITERATION MATRIX
C     H        = CURRENT STEPSIZE IN INTEGRATION
C     IER      = VARIABLE WHICH IS .NE. 0
C                IF ITERATION MATRIX IS SINGULAR,
C                AND 0 OTHERWISE.
C     WT       = VECTOR OF WEIGHTS FOR COMPUTING NORMS
C     E        = WORK SPACE (TEMPORARY) OF LENGTH NEQ
C     WM       = REAL WORK SPACE FOR MATRICES. ON
C                OUTPUT IT CONTAINS THE LU DECOMPOSITION
C                OF THE ITERATION MATRIX.
C     IWM      = INTEGER WORK SPACE CONTAINING
C                MATRIX INFORMATION
C     RES      = NAME OF THE EXTERNAL USER-SUPPLIED ROUTINE
C                TO EVALUATE THE RESIDUAL FUNCTION G(X,Y,YPRIME)
C     IRES     = FLAG WHICH IS EQUAL TO ZERO IF NO ILLEGAL VALUES
C                IN RES, AND LESS THAN ZERO OTHERWISE.  (IF IRES
C                IS LESS THAN ZERO, THE MATRIX WAS NOT COMPLETED)
C                IN THIS CASE (IF IRES .LT. 0), THEN IER = 0.
C     UROUND   = THE UNIT ROUNDOFF ERROR OF THE MACHINE BEING USED.
C     JAC      = NAME OF THE EXTERNAL USER-SUPPLIED ROUTINE
C                TO EVALUATE THE ITERATION MATRIX (THIS ROUTINE
C                IS ONLY USED IF IWM(MTYPE) IS 1 OR 4)
C-----------------------------------------------------------------------
C***ROUTINES CALLED  DGBFA, DGEFA
C***REVISION HISTORY  (YYMMDD)
C   830315  DATE WRITTEN
C   901009  Finished conversion to SLATEC 4.0 format (F.N.Fritsch)
C   901010  Modified three MAX calls to be all on one line.  (FNF)
C   901019  Merged changes made by C. Ulrich with SLATEC 4.0 format.
C   901026  Added explicit declarations for all variables and minor
C           cosmetic changes to prologue.  (FNF)
C   901101  Corrected PURPOSE.  (FNF)
C***END PROLOGUE  DDAJAC
C
      INTEGER  NEQ, IER, IWM(*), IRES, IPAR(*), NTEMP
      DOUBLE PRECISION
     *   X, Y(*), YPRIME(*), DELTA(*), CJ, H, WT(*), E(*), WM(*),
     *   UROUND, RPAR(*)
      EXTERNAL  RES, JAC
C
      EXTERNAL  DGBFA, DGEFA
C
      INTEGER  I, I1, I2, II, IPSAVE, ISAVE, J, K, L, LENPD, LIPVT,
     *   LML, LMTYPE, LMU, MBA, MBAND, MEB1, MEBAND, MSAVE, MTYPE, N,
     *   NPD, NPDM1, NROW
      DOUBLE PRECISION  DEL, DELINV, SQUR, YPSAVE, YSAVE
C
      PARAMETER (NPD=1)
      PARAMETER (LML=1)
      PARAMETER (LMU=2)
      PARAMETER (LMTYPE=4)
      PARAMETER (LIPVT=21)
C
C***FIRST EXECUTABLE STATEMENT  DDAJAC
      IER = 0
      NPDM1=NPD-1
      MTYPE=IWM(LMTYPE)
      GO TO (100,200,300,400,500),MTYPE
C
C
C     DENSE USER-SUPPLIED MATRIX
100   LENPD=NEQ*NEQ
      DO 110 I=1,LENPD
110      WM(NPDM1+I)=0.0D0
      CALL JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR)
      GO TO 230
C
C
C     DENSE FINITE-DIFFERENCE-GENERATED MATRIX
200   IRES=0
      NROW=NPDM1
      SQUR = SQRT(UROUND)
      DO 210 I=1,NEQ
         DEL=SQUR*MAX(ABS(Y(I)),ABS(H*YPRIME(I)),ABS(WT(I)))
         DEL=SIGN(DEL,H*YPRIME(I))
         DEL=(Y(I)+DEL)-Y(I)
         YSAVE=Y(I)
         YPSAVE=YPRIME(I)
         Y(I)=Y(I)+DEL
         YPRIME(I)=YPRIME(I)+CJ*DEL
         CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR)
         IF (IRES .LT. 0) RETURN
         DELINV=1.0D0/DEL
         DO 220 L=1,NEQ
220      WM(NROW+L)=(E(L)-DELTA(L))*DELINV
      NROW=NROW+NEQ
      Y(I)=YSAVE
      YPRIME(I)=YPSAVE
210   CONTINUE
C
C
C     DO DENSE-MATRIX LU DECOMPOSITION ON PD
230      CALL DGEFA(WM(NPD),NEQ,NEQ,IWM(LIPVT),IER)
      RETURN
C
C
C     DUMMY SECTION FOR IWM(MTYPE)=3
300   RETURN
C
C
C     BANDED USER-SUPPLIED MATRIX
400   LENPD=(2*IWM(LML)+IWM(LMU)+1)*NEQ
      DO 410 I=1,LENPD
410      WM(NPDM1+I)=0.0D0
      CALL JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR)
      MEBAND=2*IWM(LML)+IWM(LMU)+1
      GO TO 550
C
C
C     BANDED FINITE-DIFFERENCE-GENERATED MATRIX
500   MBAND=IWM(LML)+IWM(LMU)+1
      MBA=MIN(MBAND,NEQ)
      MEBAND=MBAND+IWM(LML)
      MEB1=MEBAND-1
      MSAVE=(NEQ/MBAND)+1
      ISAVE=NTEMP-1
      IPSAVE=ISAVE+MSAVE
      IRES=0
      SQUR=SQRT(UROUND)
      DO 540 J=1,MBA
         DO 510 N=J,NEQ,MBAND
          K= (N-J)/MBAND + 1
          WM(ISAVE+K)=Y(N)
          WM(IPSAVE+K)=YPRIME(N)
          DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)),ABS(WT(N)))
          DEL=SIGN(DEL,H*YPRIME(N))
          DEL=(Y(N)+DEL)-Y(N)
          Y(N)=Y(N)+DEL
510       YPRIME(N)=YPRIME(N)+CJ*DEL
      CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR)
      IF (IRES .LT. 0) RETURN
      DO 530 N=J,NEQ,MBAND
          K= (N-J)/MBAND + 1
          Y(N)=WM(ISAVE+K)
          YPRIME(N)=WM(IPSAVE+K)
          DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)),ABS(WT(N)))
          DEL=SIGN(DEL,H*YPRIME(N))
          DEL=(Y(N)+DEL)-Y(N)
          DELINV=1.0D0/DEL
          I1=MAX(1,(N-IWM(LMU)))
          I2=MIN(NEQ,(N+IWM(LML)))
          II=N*MEB1-IWM(LML)+NPDM1
          DO 520 I=I1,I2
520         WM(II+I)=(E(I)-DELTA(I))*DELINV
530      CONTINUE
540   CONTINUE
C
C
C     DO LU DECOMPOSITION OF BANDED PD
550   CALL DGBFA(WM(NPD),MEBAND,NEQ,
     *    IWM(LML),IWM(LMU),IWM(LIPVT),IER)
      RETURN
C------END OF SUBROUTINE DDAJAC------
      END
      SUBROUTINE DDASLV (NEQ, DELTA, WM, IWM)
C***BEGIN PROLOGUE  DDASLV
C***SUBSIDIARY
C***PURPOSE  Linear system solver for DDASSL.
C***LIBRARY   SLATEC (DASSL)
C***TYPE      DOUBLE PRECISION (SDASLV-S, DDASLV-D)
C***AUTHOR  PETZOLD, LINDA R., (LLNL)
C***DESCRIPTION
C-----------------------------------------------------------------------
C     THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR
C     SYSTEM ARISING IN THE NEWTON ITERATION.
C     MATRICES AND REAL TEMPORARY STORAGE AND
C     REAL INFORMATION ARE STORED IN THE ARRAY WM.
C     INTEGER MATRIX INFORMATION IS STORED IN
C     THE ARRAY IWM.
C     FOR A DENSE MATRIX, THE LINPACK ROUTINE
C     DGESL IS CALLED.
C     FOR A BANDED MATRIX,THE LINPACK ROUTINE
C     DGBSL IS CALLED.
C-----------------------------------------------------------------------
C***ROUTINES CALLED  DGBSL, DGESL
C***REVISION HISTORY  (YYMMDD)
C   830315  DATE WRITTEN
C   901009  Finished conversion to SLATEC 4.0 format (F.N.Fritsch)
C   901019  Merged changes made by C. Ulrich with SLATEC 4.0 format.
C   901026  Added explicit declarations for all variables and minor
C           cosmetic changes to prologue.  (FNF)
C***END PROLOGUE  DDASLV
C
      INTEGER  NEQ, IWM(*)
      DOUBLE PRECISION  DELTA(*), WM(*)
C
      EXTERNAL  DGBSL, DGESL
C
      INTEGER  LIPVT, LML, LMU, LMTYPE, MEBAND, MTYPE, NPD
      PARAMETER (NPD=1)
      PARAMETER (LML=1)
      PARAMETER (LMU=2)
      PARAMETER (LMTYPE=4)
      PARAMETER (LIPVT=21)
C
C***FIRST EXECUTABLE STATEMENT  DDASLV
      MTYPE=IWM(LMTYPE)
      GO TO(100,100,300,400,400),MTYPE
C
C     DENSE MATRIX
100   CALL DGESL(WM(NPD),NEQ,NEQ,IWM(LIPVT),DELTA,0)
      RETURN
C
C     DUMMY SECTION FOR MTYPE=3
300   CONTINUE
      RETURN
C
C     BANDED MATRIX
400   MEBAND=2*IWM(LML)+IWM(LMU)+1
      CALL DGBSL(WM(NPD),MEBAND,NEQ,IWM(LML),
     *  IWM(LMU),IWM(LIPVT),DELTA,0)
      RETURN
C------END OF SUBROUTINE DDASLV------
      END
C*DECK XERMSG
      SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL)
C***BEGIN PROLOGUE  XERMSG
C***PURPOSE  Processes error messages for SLATEC and other libraries
C***LIBRARY   SLATEC
C***CATEGORY  R3C
C***TYPE      ALL
C***KEYWORDS  ERROR MESSAGE, XERROR
C***AUTHOR  FONG, KIRBY, (NMFECC AT LLNL)
C             Modified by
C           FRITSCH, F. N., (LLNL)
C***DESCRIPTION
C
C   XERMSG processes a diagnostic message in a manner determined by the
C   value of LEVEL and the current value of the library error control
C   flag, KONTRL.  See subroutine XSETF for details.
C       (XSETF is inoperable in this version.).
C
C    LIBRAR   A character constant (or character variable) with the name
C             of the library.  This will be 'SLATEC' for the SLATEC
C             Common Math Library.  The error handling package is
C             general enough to be used by many libraries
C             simultaneously, so it is desirable for the routine that
C             detects and reports an error to identify the library name
C             as well as the routine name.
C
C    SUBROU   A character constant (or character variable) with the name
C             of the routine that detected the error.  Usually it is the
C             name of the routine that is calling XERMSG.  There are
C             some instances where a user callable library routine calls
C             lower level subsidiary routines where the error is
C             detected.  In such cases it may be more informative to
C             supply the name of the routine the user called rather than
C             the name of the subsidiary routine that detected the
C             error.
C
C    MESSG    A character constant (or character variable) with the text
C             of the error or warning message.  In the example below,
C             the message is a character constant that contains a
C             generic message.
C
C                   CALL XERMSG ('SLATEC', 'MMPY',
C                  *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION',
C                  *3, 1)
C
C             It is possible (and is sometimes desirable) to generate a
C             specific message--e.g., one that contains actual numeric
C             values.  Specific numeric values can be converted into
C             character strings using formatted WRITE statements into
C             character variables.  This is called standard Fortran
C             internal file I/O and is exemplified in the first three
C             lines of the following example.  You can also catenate
C             substrings of characters to construct the error message.
C             Here is an example showing the use of both writing to
C             an internal file and catenating character strings.
C
C                   CHARACTER*5 CHARN, CHARL
C                   WRITE (CHARN,10) N
C                   WRITE (CHARL,10) LDA
C                10 FORMAT(I5)
C                   CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN//
C                  *   ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'//
C                  *   CHARL, 3, 1)
C
C             There are two subtleties worth mentioning.  One is that
C             the // for character catenation is used to construct the
C             error message so that no single character constant is
C             continued to the next line.  This avoids confusion as to
C             whether there are trailing blanks at the end of the line.
C             The second is that by catenating the parts of the message
C             as an actual argument rather than encoding the entire
C             message into one large character variable, we avoid
C             having to know how long the message will be in order to
C             declare an adequate length for that large character
C             variable.  XERMSG calls XERPRN to print the message using
C             multiple lines if necessary.  If the message is very long,
C             XERPRN will break it into pieces of 72 characters (as
C             requested by XERMSG) for printing on multiple lines.
C             Also, XERMSG asks XERPRN to prefix each line with ' *  '
C             so that the total line length could be 76 characters.
C             Note also that XERPRN scans the error message backwards
C             to ignore trailing blanks.  Another feature is that
C             the substring '$$' is treated as a new line sentinel
C             by XERPRN.  If you want to construct a multiline
C             message without having to count out multiples of 72
C             characters, just use '$$' as a separator.  '$$'
C             obviously must occur within 72 characters of the
C             start of each line to have its intended effect since
C             XERPRN is asked to wrap around at 72 characters in
C             addition to looking for '$$'.
C
C    NERR     An integer value that is chosen by the library routine's
C             author.  It must be in the range -9999999 to 99999999 (8
C             printable digits).  Each distinct error should have its
C             own error number.  These error numbers should be described
C             in the machine readable documentation for the routine.
C             The error numbers need be unique only within each routine,
C             so it is reasonable for each routine to start enumerating
C             errors from 1 and proceeding to the next integer.
C
C    LEVEL    An integer value in the range 0 to 2 that indicates the
C             level (severity) of the error.  Their meanings are
C
C            -1  A warning message.  This is used if it is not clear
C                that there really is an error, but the user's attention
C                may be needed.  An attempt is made to only print this
C                message once.
C
C             0  A warning message.  This is used if it is not clear
C                that there really is an error, but the user's attention
C                may be needed.
C
C             1  A recoverable error.  This is used even if the error is
C                so serious that the routine cannot return any useful
C                answer.  If the user has told the error package to
C                return after recoverable errors, then XERMSG will
C                return to the Library routine which can then return to
C                the user's routine.  The user may also permit the error
C                package to terminate the program upon encountering a
C                recoverable error.
C
C             2  A fatal error.  XERMSG will not return to its caller
C                after it receives a fatal error.  This level should
C                hardly ever be used; it is much better to allow the
C                user a chance to recover.  An example of one of the few
C                cases in which it is permissible to declare a level 2
C                error is a reverse communication Library routine that
C                is likely to be called repeatedly until it integrates
C                across some interval.  If there is a serious error in
C                the input such that another step cannot be taken and
C                the Library routine is called again without the input
C                error having been corrected by the caller, the Library
C                routine will probably be called forever with improper
C                input.  In this case, it is reasonable to declare the
C                error to be fatal.
C
C    Each of the arguments to XERMSG is input; none will be modified by
C    XERMSG.  A routine may make multiple calls to XERMSG with warning
C    level messages; however, after a call to XERMSG with a recoverable
C    error, the routine should return to the user.
C
C***REFERENCES  JONES, RONDALL E. AND KAHANER, DAVID K., "XERROR, THE
C                 SLATEC ERROR-HANDLING PACKAGE", SOFTWARE - PRACTICE
C                 AND EXPERIENCE, VOLUME 13, NO. 3, PP. 251-257,
C                 MARCH, 1983.
C***ROUTINES CALLED  XERHLT, XERPRN
C***REVISION HISTORY  (YYMMDD)
C   880101  DATE WRITTEN
C   880621  REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988.
C           THERE ARE TWO BASIC CHANGES.
C           1.  A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO
C               PRINT MESSAGES.  THIS ROUTINE WILL BREAK LONG MESSAGES
C               INTO PIECES FOR PRINTING ON MULTIPLE LINES.  '$$' IS
C               ACCEPTED AS A NEW LINE SENTINEL.  A PREFIX CAN BE
C               ADDED TO EACH LINE TO BE PRINTED.  XERMSG USES EITHER
C               ' ***' OR ' *  ' AND LONG MESSAGES ARE BROKEN EVERY
C               72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE
C               LENGTH OUTPUT CAN NOW BE AS GREAT AS 76.
C           2.  THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE
C               FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE
C               OF LOWER CASE.
C   880708  REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30.
C           THE PRINCIPAL CHANGES ARE
C           1.  CLARIFY COMMENTS IN THE PROLOGUES
C           2.  RENAME XRPRNT TO XERPRN
C           3.  REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES
C               SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE /
C               CHARACTER FOR NEW RECORDS.
C   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO
C           CLEAN UP THE CODING.
C   890721  REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN
C           PREFIX.
C   891013  REVISED TO CORRECT COMMENTS.
C   891214  Prologue converted to Version 4.0 format.  (WRB)
C   900510  Changed test on NERR to be -9999999 < NERR < 99999999, but
C           NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3.  Added
C           LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and
C           XERCTL to XERCNT.  (RWC)
C   901011  Removed error saving features to produce a simplified
C           version for distribution with DASSL and other LLNL codes.
C           (FNF)
C***END PROLOGUE  XERMSG
      CHARACTER*(*) LIBRAR, SUBROU, MESSG
      CHARACTER*72  TEMP
C***FIRST EXECUTABLE STATEMENT  XERMSG
C
C       WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN
C          CALLING XERMSG.  THE ERROR NUMBER SHOULD BE POSITIVE,
C          AND THE LEVEL SHOULD BE BETWEEN 0 AND 2.
C
      IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR.
     *   LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN
         CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' //
     *      'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '//
     *      'JOB ABORT DUE TO FATAL ERROR.', 72)
         CALL XERHLT (' ***XERMSG -- INVALID INPUT')
         RETURN
      ENDIF
C
C       SET DEFAULT VALUES FOR CONTROL PARAMETERS.
C
      LKNTRL = 1
      MKNTRL = 1
C
C       ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A
C       MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS)
C       AND SENDING IT OUT VIA XERPRN.  PRINT ONLY IF CONTROL FLAG
C       IS NOT ZERO.
C
      IF (LKNTRL .NE. 0) THEN
         TEMP(1:21) = 'MESSAGE FROM ROUTINE '
         I = MIN(LEN(SUBROU), 16)
         TEMP(22:21+I) = SUBROU(1:I)
         TEMP(22+I:33+I) = ' IN LIBRARY '
         LTEMP = 33 + I
         I = MIN(LEN(LIBRAR), 16)
         TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I)
         TEMP(LTEMP+I+1:LTEMP+I+1) = '.'
         LTEMP = LTEMP + I + 1
         CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
      ENDIF
C
C       IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE
C       PRINTING THE MESSAGE.  THE INTRODUCTORY LINE TELLS THE CHOICE
C       FROM EACH OF THE FOLLOWING TWO OPTIONS.
C       1.  LEVEL OF THE MESSAGE
C              'INFORMATIVE MESSAGE'
C              'POTENTIALLY RECOVERABLE ERROR'
C              'FATAL ERROR'
C       2.  WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE
C              'PROGRAM CONTINUES'
C              'PROGRAM ABORTED'
C       NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT
C       EXCEED 74 CHARACTERS.
C       WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED.
C
      IF (LKNTRL .GT. 0) THEN
C
C       THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL.
C
         IF (LEVEL .LE. 0) THEN
            TEMP(1:20) = 'INFORMATIVE MESSAGE,'
            LTEMP = 20
         ELSEIF (LEVEL .EQ. 1) THEN
            TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,'
            LTEMP = 30
         ELSE
            TEMP(1:12) = 'FATAL ERROR,'
            LTEMP = 12
         ENDIF
C
C       THEN WHETHER THE PROGRAM WILL CONTINUE.
C
         IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR.
     *       (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN
            TEMP(LTEMP+1:LTEMP+17) = ' PROGRAM ABORTED.'
            LTEMP = LTEMP + 17
         ELSE
            TEMP(LTEMP+1:LTEMP+19) = ' PROGRAM CONTINUES.'
            LTEMP = LTEMP + 19
         ENDIF
C
         CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
      ENDIF
C
C       NOW SEND OUT THE MESSAGE.
C
      CALL XERPRN (' *  ', -1, MESSG, 72)
C
C       IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER.
C
      IF (LKNTRL .GT. 0) THEN
         WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR
         DO 10 I=16,22
            IF (TEMP(I:I) .NE. ' ') GO TO 20
   10    CONTINUE
C
   20    CALL XERPRN (' *  ', -1, TEMP(1:15) // TEMP(I:23), 72)
      ENDIF
C
C       IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE.
C
      IF (LKNTRL .NE. 0) THEN
         CALL XERPRN (' *  ', -1, ' ', 72)
         CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72)
         CALL XERPRN ('    ',  0, ' ', 72)
      ENDIF
C
C       IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE
C       CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN.
C
   30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN
C
C       THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A
C       FATAL ERROR.  PRINT THE REASON FOR THE ABORT AND THE ERROR
C       SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT.
C
      IF (LKNTRL.GT.0) THEN
         IF (LEVEL .EQ. 1) THEN
            CALL XERPRN
     *         (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72)
         ELSE
            CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72)
         ENDIF
         CALL XERHLT (' ')
      ENDIF
      RETURN
      END
      SUBROUTINE XERHLT (MESSG)
C***BEGIN PROLOGUE  XERHLT
C***SUBSIDIARY
C***PURPOSE  Abort program execution and print error message.
C***LIBRARY   SLATEC (XERROR)
C***CATEGORY  R3C
C***TYPE      ALL (XERHLT-A)
C***KEYWORDS  ERROR, XERROR
C***AUTHOR  JONES, R. E., (SNLA)
C***DESCRIPTION
C
C     Abstract
C        ***Note*** machine dependent routine
C        XERHLT aborts the execution of the program.
C        The error message causing the abort is given in the calling
C        sequence, in case one needs it for printing on a dayfile,
C        for example.
C
C     Description of Parameters
C        MESSG is as in XERROR.
C
C***REFERENCES  JONES R.E., KAHANER D.K., 'XERROR, THE SLATEC ERROR-
C                 HANDLING PACKAGE', SAND82-0800, SANDIA LABORATORIES,
C                 1982.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   790801  DATE WRITTEN as XERABT
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900206  Routine changed from user-callable to subsidiary.  (WRB)
C   900510  Changed calling sequence to delete length of char string
C           Changed subroutine name from XERABT to XERHLT.  (RWC)
C***END PROLOGUE  XERHLT
      CHARACTER*(*) MESSG
C***FIRST EXECUTABLE STATEMENT  XERHLT
      STOP
      END
C*DECK XERPRN
      SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP)
C***BEGIN PROLOGUE  XERPRN
C***SUBSIDIARY
C***PURPOSE  This routine is called by XERMSG to print error messages
C***LIBRARY   SLATEC
C***CATEGORY  R3C
C***TYPE      ALL
C***KEYWORDS  ERROR MESSAGES, PRINTING, XERROR
C***AUTHOR  FONG, KIRBY, (NMFECC AT LLNL)
C***DESCRIPTION
C
C This routine sends one or more lines to each of the (up to five)
C logical units to which error messages are to be sent.  This routine
C is called several times by XERMSG, sometimes with a single line to
C print and sometimes with a (potentially very long) message that may
C wrap around into multiple lines.
C
C PREFIX  Input argument of type CHARACTER.  This argument contains
C         characters to be put at the beginning of each line before
C         the body of the message.  No more than 16 characters of
C         PREFIX will be used.
C
C NPREF   Input argument of type INTEGER.  This argument is the number
C         of characters to use from PREFIX.  If it is negative, the
C         intrinsic function LEN is used to determine its length.  If
C         it is zero, PREFIX is not used.  If it exceeds 16 or if
C         LEN(PREFIX) exceeds 16, only the first 16 characters will be
C         used.  If NPREF is positive and the length of PREFIX is less
C         than NPREF, a copy of PREFIX extended with blanks to length
C         NPREF will be used.
C
C MESSG   Input argument of type CHARACTER.  This is the text of a
C         message to be printed.  If it is a long message, it will be
C         broken into pieces for printing on multiple lines.  Each line
C         will start with the appropriate prefix and be followed by a
C         piece of the message.  NWRAP is the number of characters per
C         piece; that is, after each NWRAP characters, we break and
C         start a new line.  In addition the characters '$$' embedded
C         in MESSG are a sentinel for a new line.  The counting of
C         characters up to NWRAP starts over for each new line.  The
C         value of NWRAP typically used by XERMSG is 72 since many
C         older error messages in the SLATEC Library are laid out to
C         rely on wrap-around every 72 characters.
C
C NWRAP   Input argument of type INTEGER.  This gives the maximum size
C         piece into which to break MESSG for printing on multiple
C         lines.  An embedded '$$' ends a line, and the count restarts
C         at the following character.  If a line break does not occur
C         on a blank (it would split a word) that word is moved to the
C         next line.  Values of NWRAP less than 16 will be treated as
C         16.  Values of NWRAP greater than 132 will be treated as 132.
C         The actual line length will be NPREF + NWRAP after NPREF has
C         been adjusted to fall between 0 and 16 and NWRAP has been
C         adjusted to fall between 16 and 132.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  I1MACH, XGETUA
C***REVISION HISTORY  (YYMMDD)
C   880621  DATE WRITTEN
C   880708  REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF
C           JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK
C           THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE
C           SLASH CHARACTER IN FORMAT STATEMENTS.
C   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMMENS TO
C           STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK
C           LINES TO BE PRINTED.
C   890721  REVISED TO ADD A NEW FEATURE.  A NEGATIVE VALUE OF NPREF
C           CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH.
C   891013  REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH.
C   891214  Prologue converted to Version 4.0 format.  (WRB)
C   900510  Added code to break messages between words.  (RWC)
C***END PROLOGUE  XERPRN
      CHARACTER*(*) PREFIX, MESSG
      INTEGER NPREF, NWRAP
      CHARACTER*148 CBUFF
      INTEGER IU(5), NUNIT
      CHARACTER*2 NEWLIN
      PARAMETER (NEWLIN = '$$')
C***FIRST EXECUTABLE STATEMENT  XERPRN
      CALL XGETUA(IU,NUNIT)
C
C       A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD
C       ERROR MESSAGE UNIT INSTEAD.  I1MACH(4) RETRIEVES THE STANDARD
C       ERROR MESSAGE UNIT.
C
      N = I1MACH(4)
      DO 10 I=1,NUNIT
         IF (IU(I) .EQ. 0) IU(I) = N
   10 CONTINUE
C
C       LPREF IS THE LENGTH OF THE PREFIX.  THE PREFIX IS PLACED AT THE
C       BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING
C       THE REST OF THIS ROUTINE.
C
      IF ( NPREF .LT. 0 ) THEN
         LPREF = LEN(PREFIX)
      ELSE
         LPREF = NPREF
      ENDIF
      LPREF = MIN(16, LPREF)
      IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX
C
C       LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE
C       TIME FROM MESSG TO PRINT ON ONE LINE.
C
      LWRAP = MAX(16, MIN(132, NWRAP))
C
C       SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS.
C
      LENMSG = LEN(MESSG)
      N = LENMSG
      DO 20 I=1,N
         IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30
         LENMSG = LENMSG - 1
   20 CONTINUE
   30 CONTINUE
C
C       IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE.
C
      IF (LENMSG .EQ. 0) THEN
         CBUFF(LPREF+1:LPREF+1) = ' '
         DO 40 I=1,NUNIT
            WRITE(IU(I), '(A)') CBUFF(1:LPREF+1)
   40    CONTINUE
         RETURN
      ENDIF
C
C       SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING
C       STARTS.  FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL.
C       WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT.
C       WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED.
C
C       WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL.  THE
C       INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE
C       OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH
C       OF THE SECOND ARGUMENT.
C
C       THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE
C       FOLLOWING ORDER.  WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER
C       OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT
C       POSITION NEXTC.
C
C       LPIECE .EQ. 0   THE NEW LINE SENTINEL DOES NOT OCCUR IN THE
C                       REMAINDER OF THE CHARACTER STRING.  LPIECE
C                       SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC,
C                       WHICHEVER IS LESS.
C
C       LPIECE .EQ. 1   THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC:
C                       NEXTC).  LPIECE IS EFFECTIVELY ZERO, AND WE
C                       PRINT NOTHING TO AVOID PRODUCING UNNECESSARY
C                       BLANK LINES.  THIS TAKES CARE OF THE SITUATION
C                       WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF
C                       EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE
C                       SENTINEL FOLLOWED BY MORE CHARACTERS.  NEXTC
C                       SHOULD BE INCREMENTED BY 2.
C
C       LPIECE .GT. LWRAP+1  REDUCE LPIECE TO LWRAP.
C
C       ELSE            THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1
C                       RESET LPIECE = LPIECE-1.  NOTE THAT THIS
C                       PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ.
C                       LWRAP+1.  THAT IS, THE SENTINEL FALLS EXACTLY
C                       AT THE END OF A LINE.
C
      NEXTC = 1
   50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN)
      IF (LPIECE .EQ. 0) THEN
C
C       THERE WAS NO NEW LINE SENTINEL FOUND.
C
         IDELTA = 0
         LPIECE = MIN(LWRAP, LENMSG+1-NEXTC)
         IF (LPIECE .LT. LENMSG+1-NEXTC) THEN
            DO 52 I=LPIECE+1,2,-1
               IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN
                  LPIECE = I-1
                  IDELTA = 1
                  GOTO 54
               ENDIF
   52       CONTINUE
         ENDIF
   54    CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
         NEXTC = NEXTC + LPIECE + IDELTA
      ELSEIF (LPIECE .EQ. 1) THEN
C
C       WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1).
C       DON'T PRINT A BLANK LINE.
C
         NEXTC = NEXTC + 2
         GO TO 50
      ELSEIF (LPIECE .GT. LWRAP+1) THEN
C
C       LPIECE SHOULD BE SET DOWN TO LWRAP.
C
         IDELTA = 0
         LPIECE = LWRAP
         DO 56 I=LPIECE+1,2,-1
            IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN
               LPIECE = I-1
               IDELTA = 1
               GOTO 58
            ENDIF
   56    CONTINUE
   58    CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
         NEXTC = NEXTC + LPIECE + IDELTA
      ELSE
C
C       IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1.
C       WE SHOULD DECREMENT LPIECE BY ONE.
C
         LPIECE = LPIECE - 1
         CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
         NEXTC  = NEXTC + LPIECE + 2
      ENDIF
C
C       PRINT
C
      DO 60 I=1,NUNIT
         WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE)
   60 CONTINUE
C
      IF (NEXTC .LE. LENMSG) GO TO 50
      RETURN
      END
C*DECK XGETUA
      SUBROUTINE XGETUA (IUNITA, N)
C***BEGIN PROLOGUE  XGETUA
C***PURPOSE  Return unit number(s) to which error messages are being
C            sent.
C***LIBRARY   SLATEC (XERROR)
C***CATEGORY  R3C
C***TYPE      ALL (XGETUA-A)
C***KEYWORDS  ERROR, XERROR
C***AUTHOR  JONES, R. E., (SNLA)
C             Modified by
C           FRITSCH, F. N., (LLNL)
C***DESCRIPTION
C
C     Abstract
C        XGETUA may be called to determine the unit number or numbers
C        to which error messages are being sent.
C        These unit numbers may have been set by a call to XSETUN,
C        or a call to XSETUA, or may be a default value.
C
C     Description of Parameters
C      --Output--
C        IUNIT - an array of one to five unit numbers, depending
C                on the value of N.  A value of zero refers to the
C                default unit, as defined by the I1MACH machine
C                constant routine.  Only IUNIT(1),...,IUNIT(N) are
C                defined by XGETUA.  The values of IUNIT(N+1),...,
C                IUNIT(5) are not defined (for N .LT. 5) or altered
C                in any way by XGETUA.
C        N     - the number of units to which copies of the
C                error messages are being sent.  N will be in the
C                range from 1 to 5.
C
C     CAUTION:  The use of COMMON in this version is not safe for
C               multiprocessing.
C
C***REFERENCES  JONES R.E., KAHANER D.K., 'XERROR, THE SLATEC ERROR-
C                 HANDLING PACKAGE', SAND82-0800, SANDIA LABORATORIES,
C                 1982.
C***ROUTINES CALLED  (NONE)
C***COMMON BLOCKS    XERUNI
C***REVISION HISTORY  (YYMMDD)
C   790801  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   901011  Rewritten to not use J4SAVE.  (FNF)
C   901012  Corrected initialization problem.  (FNF)
C***END PROLOGUE  XGETUA
      DIMENSION IUNITA(5)
      INTEGER  NUNIT, IUNIT(5)
      COMMON /XERUNI/ NUNIT, IUNIT
C***FIRST EXECUTABLE STATEMENT  XGETUA
C       Initialize so XERMSG will use standard error unit number if
C       block has not been set up by a CALL XSETUA.
C       CAUTION:  This assumes uninitialized COMMON tests .LE.0 .
      IF (NUNIT.LE.0) THEN
         NUNIT = 1
         IUNIT(1) = 0
      ENDIF
      N = NUNIT
      DO 30 I=1,N
         IUNITA(I) = IUNIT(I)
   30 CONTINUE
      RETURN
      END
C*DECK XSETUA
      SUBROUTINE XSETUA (IUNITA, N)
C***BEGIN PROLOGUE  XSETUA
C***PURPOSE  Set logical unit numbers (up to 5) to which error
C            messages are to be sent.
C***LIBRARY   SLATEC (XERROR)
C***CATEGORY  R3B
C***TYPE      ALL (XSETUA-A)
C***KEYWORDS  ERROR, XERROR
C***AUTHOR  JONES, R. E., (SNLA)
C             Modified by
C           FRITSCH, F. N., (LLNL)
C***DESCRIPTION
C
C     Abstract
C        XSETUA may be called to declare a list of up to five
C        logical units, each of which is to receive a copy of
C        each error message processed by this package.
C        The purpose of XSETUA is to allow simultaneous printing
C        of each error message on, say, a main output file,
C        an interactive terminal, and other files such as graphics
C        communication files.
C
C     Description of Parameters
C      --Input--
C        IUNIT - an array of up to five unit numbers.
C                Normally these numbers should all be different
C                (but duplicates are not prohibited.)
C        N     - the number of unit numbers provided in IUNIT
C                must have 1 .LE. N .LE. 5.
C
C     CAUTION:  The use of COMMON in this version is not safe for
C               multiprocessing.
C
C***REFERENCES  JONES R.E., KAHANER D.K., 'XERROR, THE SLATEC ERROR-
C                 HANDLING PACKAGE', SAND82-0800, SANDIA LABORATORIES,
C                 1982.
C***ROUTINES CALLED  XERMSG
C***COMMON BLOCKS    XERUNI
C***REVISION HISTORY  (YYMMDD)
C   790801  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900510  Change call to XERRWV to XERMSG.  (RWC)
C   901011  Rewritten to not use J4SAVE.  (FNF)
C***END PROLOGUE  XSETUA
      DIMENSION IUNITA(5)
      INTEGER  NUNIT, IUNIT(5)
      COMMON /XERUNI/ NUNIT, IUNIT
      CHARACTER *8 XERN1
C***FIRST EXECUTABLE STATEMENT  XSETUA
C
      IF (N.LT.1 .OR. N.GT.5) THEN
         WRITE (XERN1, '(I8)') N
         CALL XERMSG ('SLATEC', 'XSETUA',
     *      'INVALID NUMBER OF UNITS, N = ' // XERN1, 1, 2)
         RETURN
      ENDIF
C
      DO 10 I=1,N
         IUNIT(I) = IUNITA(I)
   10 CONTINUE
      NUNIT = N
      RETURN
      END
C
C#######################################################################
C
C DASUSE : contains the routine
C          I1MACH to get the standard error message unit (6).
C             (also available from Netlib: send i1mach from core)
C          D1MACH to determine machine precision, uses value determined
C             by MACHAR
C             (also available from Netlib: send r1mach from core)
C          and the dummies for the routines DGEFA and DGESL from LINPACK
C             (available from Netlib: send dgefa/dgesl from linpack)
C
C#######################################################################
C
      INTEGER FUNCTION I1MACH(IDUM)
      INTEGER IDUM
C
C  I/O UNIT NUMBERS.
C
C    I1MACH( 4) = THE STANDARD ERROR MESSAGE UNIT.

      I1MACH = 6
      RETURN
C----------------------- END OF FUNCTION I1MACH ------------------------
      END
      DOUBLE PRECISION FUNCTION D1MACH(IDUM)
      INTEGER IDUM
C-----------------------------------------------------------------------
C This routine returns the unit roundoff of the machine in single
C precision as computed by MACHAR and stored in SRELPR in the routine
C SETSKM.
C-----------------------------------------------------------------------
      INTEGER NERR
      DOUBLE PRECISION SRELPR
      COMMON /MACH/ NERR, SRELPR

      D1MACH = SRELPR
      RETURN
C----------------------- END OF FUNCTION R1MACH ------------------------
      END
      SUBROUTINE DGEFA
      RETURN
      END
      SUBROUTINE DGESL
      RETURN
      END
C
C#######################################################################
C
C DASLIP : LINPACK routines needed by DASSL
C          (available from Netlib: send dgbfa/dgbsl from linpack)
C
C#######################################################################
C
      subroutine dgbfa(abd,lda,n,ml,mu,ipvt,info)
      integer lda,n,ml,mu,ipvt(1),info
      double precision abd(lda,1)
c
c     dgbfa factors a double precision band matrix by elimination.
c
c     dgbfa is usually called by dgbco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c
c     on entry
c
c        abd     double precision(lda, n)
c                contains the matrix in band storage.  the columns
c                of the matrix are stored in the columns of  abd  and
c                the diagonals of the matrix are stored in rows
c                ml+1 through 2*ml+mu+1 of  abd .
c                see the comments below for details.
c
c        lda     integer
c                the leading dimension of the array  abd .
c                lda must be .ge. 2*ml + mu + 1 .
c
c        n       integer
c                the order of the original matrix.
c
c        ml      integer
c                number of diagonals below the main diagonal.
c                0 .le. ml .lt. n .
c
c        mu      integer
c                number of diagonals above the main diagonal.
c                0 .le. mu .lt. n .
c                more efficient if  ml .le. mu .
c     on return
c
c        abd     an upper triangular matrix in band storage and
c                the multipliers which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if  u(k,k) .eq. 0.0 .  this is not an error
c                     condition for this subroutine, but it does
c                     indicate that dgbsl will divide by zero if
c                     called.  use  rcond  in dgbco for a reliable
c                     indication of singularity.
c
c     band storage
c
c           if  a  is a band matrix, the following program segment
c           will set up the input.
c
c                   ml = (band width below the diagonal)
c                   mu = (band width above the diagonal)
c                   m = ml + mu + 1
c                   do 20 j = 1, n
c                      i1 = max0(1, j-mu)
c                      i2 = min0(n, j+ml)
c                      do 10 i = i1, i2
c                         k = i - j + m
c                         abd(k,j) = a(i,j)
c                10    continue
c                20 continue
c
c           this uses rows  ml+1  through  2*ml+mu+1  of  abd .
c           in addition, the first  ml  rows in  abd  are used for
c           elements generated during the triangularization.
c           the total number of rows needed in  abd  is  2*ml+mu+1 .
c           the  ml+mu by ml+mu  upper left triangle and the
c           ml by ml  lower right triangle are not referenced.
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,dscal,idamax
c     fortran max0,min0
c
c     internal variables
c
      double precision t
      integer i,idamax,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1
c
c
      m = ml + mu + 1
      info = 0
c
c     zero initial fill-in columns
c
      j0 = mu + 2
      j1 = min0(n,m) - 1
      if (j1 .lt. j0) go to 30
      do 20 jz = j0, j1
         i0 = m + 1 - jz
         do 10 i = i0, ml
            abd(i,jz) = 0.0d0
   10    continue
   20 continue
   30 continue
      jz = j1
      ju = 0
c
c     gaussian elimination with partial pivoting
c
      nm1 = n - 1
      if (nm1 .lt. 1) go to 130
      do 120 k = 1, nm1
         kp1 = k + 1
c
c        zero next fill-in column
c
         jz = jz + 1
         if (jz .gt. n) go to 50
         if (ml .lt. 1) go to 50
            do 40 i = 1, ml
               abd(i,jz) = 0.0d0
   40       continue
   50    continue
c
c        find l = pivot index
c
         lm = min0(ml,n-k)
         l = idamax(lm+1,abd(m,k),1) + m - 1
         ipvt(k) = l + k - m
c
c        zero pivot implies this column already triangularized
c
         if (abd(l,k) .eq. 0.0d0) go to 100
c
c           interchange if necessary
c
            if (l .eq. m) go to 60
               t = abd(l,k)
               abd(l,k) = abd(m,k)
               abd(m,k) = t
   60       continue
c
c           compute multipliers
c
            t = -1.0d0/abd(m,k)
            call dscal(lm,t,abd(m+1,k),1)
c
c           row elimination with column indexing
c
            ju = min0(max0(ju,mu+ipvt(k)),n)
            mm = m
            if (ju .lt. kp1) go to 90
            do 80 j = kp1, ju
               l = l - 1
               mm = mm - 1
               t = abd(l,j)
               if (l .eq. mm) go to 70
                  abd(l,j) = abd(mm,j)
                  abd(mm,j) = t
   70          continue
               call daxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1)
   80       continue
   90       continue
         go to 110
  100    continue
            info = k
  110    continue
  120 continue
  130 continue
      ipvt(n) = n
      if (abd(m,n) .eq. 0.0d0) info = n
      return
      end
      subroutine daxpy(n,da,dx,incx,dy,incy)
c
c     constant times a vector plus a vector.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(1),dy(1),da
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if (da .eq. 0.0d0) return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dy(iy) = dy(iy) + da*dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,4)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dy(i) = dy(i) + da*dx(i)
   30 continue
      if( n .lt. 4 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,4
        dy(i) = dy(i) + da*dx(i)
        dy(i + 1) = dy(i + 1) + da*dx(i + 1)
        dy(i + 2) = dy(i + 2) + da*dx(i + 2)
        dy(i + 3) = dy(i + 3) + da*dx(i + 3)
   50 continue
      return
      end
      subroutine  dscal(n,da,dx,incx)
c
c     scales a vector by a constant.
c     uses unrolled loops for increment equal to one.
c     jack dongarra, linpack, 3/11/78.
c     modified to correct problem with negative increment, 8/21/90.
c
      double precision da,dx(1)
      integer i,incx,ix,m,mp1,n
c
      if(n.le.0)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      do 10 i = 1,n
        dx(ix) = da*dx(ix)
        ix = ix + incx
   10 continue
      return
c
c        code for increment equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dx(i) = da*dx(i)
   30 continue
      if( n .lt. 5 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dx(i) = da*dx(i)
        dx(i + 1) = da*dx(i + 1)
        dx(i + 2) = da*dx(i + 2)
        dx(i + 3) = da*dx(i + 3)
        dx(i + 4) = da*dx(i + 4)
   50 continue
      return
      end
      integer function idamax(n,dx,incx)
c
c     finds the index of element having max. absolute value.
c     jack dongarra, linpack, 3/11/78.
c     modified to correct problem with negative increment, 8/21/90.
c
      double precision dx(1),dmax
      integer i,incx,ix,n
c
      idamax = 0
      if( n .lt. 1 ) return
      idamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      dmax = dabs(dx(ix))
      ix = ix + incx
      do 10 i = 2,n
         if(dabs(dx(ix)).le.dmax) go to 5
         idamax = i
         dmax = dabs(dx(ix))
    5    ix = ix + incx
   10 continue
      return
c
c        code for increment equal to 1
c
   20 dmax = dabs(dx(1))
      do 30 i = 2,n
         if(dabs(dx(i)).le.dmax) go to 30
         idamax = i
         dmax = dabs(dx(i))
   30 continue
      return
      end
      subroutine dgbsl(abd,lda,n,ml,mu,ipvt,b,job)
      integer lda,n,ml,mu,ipvt(1),job
      double precision abd(lda,1),b(1)
c
c     dgbsl solves the double precision band system
c     a * x = b  or  trans(a) * x = b
c     using the factors computed by dgbco or dgbfa.
c
c     on entry
c
c        abd     double precision(lda, n)
c                the output from dgbco or dgbfa.
c
c        lda     integer
c                the leading dimension of the array  abd .
c
c        n       integer
c                the order of the original matrix.
c
c        ml      integer
c                number of diagonals below the main diagonal.
c
c        mu      integer
c                number of diagonals above the main diagonal.
c
c        ipvt    integer(n)
c                the pivot vector from dgbco or dgbfa.
c
c        b       double precision(n)
c                the right hand side vector.
c
c        job     integer
c                = 0         to solve  a*x = b ,
c                = nonzero   to solve  trans(a)*x = b , where
c                            trans(a)  is the transpose.
c
c     on return
c
c        b       the solution vector  x .
c
c     error condition
c
c        a division by zero will occur if the input factor contains a
c        zero on the diagonal.  technically this indicates singularity
c        but it is often caused by improper arguments or improper
c        setting of lda .  it will not occur if the subroutines are
c        called correctly and if dgbco has set rcond .gt. 0.0
c        or dgbfa has set info .eq. 0 .
c
c     to compute  inverse(a) * c  where  c  is a matrix
c     with  p  columns
c           call dgbco(abd,lda,n,ml,mu,ipvt,rcond,z)
c           if (rcond is too small) go to ...
c           do 10 j = 1, p
c              call dgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0)
c        10 continue
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,ddot
c     fortran min0
c
c     internal variables
c
      double precision ddot,t
      integer k,kb,l,la,lb,lm,m,nm1
c
      m = mu + ml + 1
      nm1 = n - 1
      if (job .ne. 0) go to 50
c
c        job = 0 , solve  a * x = b
c        first solve l*y = b
c
         if (ml .eq. 0) go to 30
         if (nm1 .lt. 1) go to 30
            do 20 k = 1, nm1
               lm = min0(ml,n-k)
               l = ipvt(k)
               t = b(l)
               if (l .eq. k) go to 10
                  b(l) = b(k)
                  b(k) = t
   10          continue
               call daxpy(lm,t,abd(m+1,k),1,b(k+1),1)
   20       continue
   30    continue
c
c        now solve  u*x = y
c
         do 40 kb = 1, n
            k = n + 1 - kb
            b(k) = b(k)/abd(m,k)
            lm = min0(k,m) - 1
            la = m - lm
            lb = k - lm
            t = -b(k)
            call daxpy(lm,t,abd(la,k),1,b(lb),1)
   40    continue
      go to 100
   50 continue
c
c        job = nonzero, solve  trans(a) * x = b
c        first solve  trans(u)*y = b
c
         do 60 k = 1, n
            lm = min0(k,m) - 1
            la = m - lm
            lb = k - lm
            t = ddot(lm,abd(la,k),1,b(lb),1)
            b(k) = (b(k) - t)/abd(m,k)
   60    continue
c
c        now solve trans(l)*x = y
c
         if (ml .eq. 0) go to 90
         if (nm1 .lt. 1) go to 90
            do 80 kb = 1, nm1
               k = n - kb
               lm = min0(ml,n-k)
               b(k) = b(k) + ddot(lm,abd(m+1,k),1,b(k+1),1)
               l = ipvt(k)
               if (l .eq. k) go to 70
                  t = b(l)
                  b(l) = b(k)
                  b(k) = t
   70          continue
   80       continue
   90    continue
  100 continue
      return
      end
      double precision function ddot(n,dx,incx,dy,incy)
c
c     forms the dot product of two vectors.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(1),dy(1),dtemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      ddot = 0.0d0
      dtemp = 0.0d0
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = dtemp + dx(ix)*dy(iy)
        ix = ix + incx
        iy = iy + incy
   10 continue
      ddot = dtemp
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dtemp + dx(i)*dy(i)
   30 continue
      if( n .lt. 5 ) go to 60
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) +
     *   dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4)
   50 continue
   60 ddot = dtemp
      return
      end
