* Bug #13512 fixed - DE: dae crashed if the evaluation function had wrong prototype
[scilab.git] / scilab / modules / differential_equations / src / fortran / ddaskr.f
1       SUBROUTINE DDASKR (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL,
2      *   IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC, PSOL,
3      *   RT, NRT, JROOT)
4 C
5 C***BEGIN PROLOGUE  DDASKR
6 C***SOURCE  http://www.netlib.org/ode/daskr.tgz
7 C***MODIFICATIONS_FROM_SOURCE  added "2" to DRCHEK, DDAWTS, DROOTS,
8 C   DDATRP, D1MACH, DNRM to be sure not to call other files' functions
9 C***REVISION HISTORY  (YYMMDD)
10 C   020815  DATE WRITTEN   
11 C   021105  Changed yprime argument in DRCHEK2 calls to YPRIME.
12 C   021217  Modified error return for zeros found too close together.
13 C   021217  Added root direction output in JROOT.
14 C   040518  Changed adjustment to X2 in Subr. DROOTS2.
15 C   050511  Revised stopping tests in statements 530 - 580; reordered
16 C           to test for tn at tstop before testing for tn past tout.
17 C   060712  In DMATD, changed minimum D.Q. increment to 1/EWT(j).
18 C   071003  In DRCHEK2, fixed bug in TEMP2 (HMINR) below 110.
19 C   110608  In DRCHEK2, fixed bug in setting of T1 at 300.
20 C***CATEGORY NO.  I1A2
21 C***KEYWORDS  DIFFERENTIAL/ALGEBRAIC, BACKWARD DIFFERENTIATION FORMULAS,
22 C             IMPLICIT DIFFERENTIAL SYSTEMS, KRYLOV ITERATION
23 C***AUTHORS   Linda R. Petzold, Peter N. Brown, Alan C. Hindmarsh, and
24 C                  Clement W. Ulrich
25 C             Center for Computational Sciences & Engineering, L-316
26 C             Lawrence Livermore National Laboratory
27 C             P.O. Box 808,
28 C             Livermore, CA 94551
29 C***PURPOSE  This code solves a system of differential/algebraic 
30 C            equations of the form 
31 C               G(t,y,y') = 0 , 
32 C            using a combination of Backward Differentiation Formula 
33 C            (BDF) methods and a choice of two linear system solution 
34 C            methods: direct (dense or band) or Krylov (iterative).
35 C            This version is in double precision.
36 C-----------------------------------------------------------------------
37 C***DESCRIPTION
38 C
39 C *Usage:
40 C
41 C      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
42 C      INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR(*)
43 C      DOUBLE PRECISION T, Y(*), YPRIME(*), TOUT, RTOL(*), ATOL(*),
44 C         RWORK(LRW), RPAR(*)
45 C      EXTERNAL RES, JAC, PSOL, RT
46 C
47 C      CALL DDASKR (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL,
48 C     *             IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC, PSOL,
49 C     *             RT, NRT, JROOT)
50 C
51 C  Quantities which may be altered by the code are:
52 C     T, Y(*), YPRIME(*), INFO(1), RTOL, ATOL, IDID, RWORK(*), IWORK(*)
53 C
54 C
55 C *Arguments:
56 C
57 C  RES:EXT          This is the name of a subroutine which you
58 C                   provide to define the residual function G(t,y,y')
59 C                   of the differential/algebraic system.
60 C
61 C  NEQ:IN           This is the number of equations in the system.
62 C
63 C  T:INOUT          This is the current value of the independent 
64 C                   variable.
65 C
66 C  Y(*):INOUT       This array contains the solution components at T.
67 C
68 C  YPRIME(*):INOUT  This array contains the derivatives of the solution
69 C                   components at T.
70 C
71 C  TOUT:IN          This is a point at which a solution is desired.
72 C
73 C  INFO(N):IN       This is an integer array used to communicate details
74 C                   of how the solution is to be carried out, such as
75 C                   tolerance type, matrix structure, step size and
76 C                   order limits, and choice of nonlinear system method.
77 C                   N must be at least 20.
78 C
79 C  RTOL,ATOL:INOUT  These quantities represent absolute and relative
80 C                   error tolerances (on local error) which you provide
81 C                   to indicate how accurately you wish the solution to
82 C                   be computed.  You may choose them to be both scalars
83 C                   or else both arrays of length NEQ.
84 C
85 C  IDID:OUT         This integer scalar is an indicator reporting what
86 C                   the code did.  You must monitor this variable to
87 C                   decide what action to take next.
88 C
89 C  RWORK:WORK       A real work array of length LRW which provides the
90 C                   code with needed storage space.
91 C
92 C  LRW:IN           The length of RWORK.
93 C
94 C  IWORK:WORK       An integer work array of length LIW which provides
95 C                   the code with needed storage space.
96 C
97 C  LIW:IN           The length of IWORK.
98 C
99 C  RPAR,IPAR:IN     These are real and integer parameter arrays which
100 C                   you can use for communication between your calling
101 C                   program and the RES, JAC, and PSOL subroutines.
102 C
103 C  JAC:EXT          This is the name of a subroutine which you may
104 C                   provide (optionally) for calculating Jacobian 
105 C                   (partial derivative) data involved in solving linear
106 C                   systems within DDASKR.
107 C
108 C  PSOL:EXT         This is the name of a subroutine which you must
109 C                   provide for solving linear systems if you selected
110 C                   a Krylov method.  The purpose of PSOL is to solve
111 C                   linear systems involving a left preconditioner P.
112 C
113 C  RT:EXT           This is the name of the subroutine for defining
114 C                   constraint functions Ri(T,Y,Y')) whose roots are
115 C                   desired during the integration.  This name must be
116 C                   declared external in the calling program.
117 C
118 C  NRT:IN           This is the number of constraint functions
119 C                   Ri(T,Y,Y').  If there are no constraints, set
120 C                   NRT = 0, and pass a dummy name for RT.
121 C
122 C  JROOT:OUT        This is an integer array of length NRT for output
123 C                   of root information.
124 C
125 C *Overview
126 C
127 C  The DDASKR solver uses the backward differentiation formulas of
128 C  orders one through five to solve a system of the form G(t,y,y') = 0
129 C  for y = Y and y' = YPRIME.  Values for Y and YPRIME at the initial 
130 C  time must be given as input.  These values should be consistent, 
131 C  that is, if T, Y, YPRIME are the given initial values, they should 
132 C  satisfy G(T,Y,YPRIME) = 0.  However, if consistent values are not
133 C  known, in many cases you can have DDASKR solve for them -- see
134 C  INFO(11). (This and other options are described in detail below.)
135 C
136 C  Normally, DDASKR solves the system from T to TOUT.  It is easy to
137 C  continue the solution to get results at additional TOUT.  This is
138 C  the interval mode of operation.  Intermediate results can also be
139 C  obtained easily by specifying INFO(3).
140 C
141 C  On each step taken by DDASKR, a sequence of nonlinear algebraic  
142 C  systems arises.  These are solved by one of two types of
143 C  methods:
144 C    * a Newton iteration with a direct method for the linear
145 C      systems involved (INFO(12) = 0), or
146 C    * a Newton iteration with a preconditioned Krylov iterative 
147 C      method for the linear systems involved (INFO(12) = 1).
148 C
149 C  The direct method choices are dense and band matrix solvers, 
150 C  with either a user-supplied or an internal difference quotient 
151 C  Jacobian matrix, as specified by INFO(5) and INFO(6).
152 C  In the band case, INFO(6) = 1, you must supply half-bandwidths
153 C  in IWORK(1) and IWORK(2).
154 C
155 C  The Krylov method is the Generalized Minimum Residual (GMRES) 
156 C  method, in either complete or incomplete form, and with 
157 C  scaling and preconditioning.  The method is implemented
158 C  in an algorithm called SPIGMR.  Certain options in the Krylov 
159 C  method case are specified by INFO(13) and INFO(15).
160 C
161 C  If the Krylov method is chosen, you may supply a pair of routines,
162 C  JAC and PSOL, to apply preconditioning to the linear system.
163 C  If the system is A*x = b, the matrix is A = dG/dY + CJ*dG/dYPRIME
164 C  (of order NEQ).  This system can then be preconditioned in the form
165 C  (P-inverse)*A*x = (P-inverse)*b, with left preconditioner P.
166 C  (DDASKR does not allow right preconditioning.)
167 C  Then the Krylov method is applied to this altered, but equivalent,
168 C  linear system, hopefully with much better performance than without
169 C  preconditioning.  (In addition, a diagonal scaling matrix based on
170 C  the tolerances is also introduced into the altered system.)
171 C
172 C  The JAC routine evaluates any data needed for solving systems
173 C  with coefficient matrix P, and PSOL carries out that solution.
174 C  In any case, in order to improve convergence, you should try to
175 C  make P approximate the matrix A as much as possible, while keeping
176 C  the system P*x = b reasonably easy and inexpensive to solve for x,
177 C  given a vector b.
178 C
179 C  While integrating the given DAE system, DDASKR also searches for
180 C  roots of the given constraint functions Ri(T,Y,Y') given by RT.
181 C  If DDASKR detects a sign change in any Ri(T,Y,Y'), it will return
182 C  the intermediate value of T and Y for which Ri(T,Y,Y') = 0.
183 C  Caution: If some Ri has a root at or very near the initial time,
184 C  DDASKR may fail to find it, or may find extraneous roots there,
185 C  because it does not yet have a sufficient history of the solution.
186 C
187 C *Description
188 C
189 C------INPUT - WHAT TO DO ON THE FIRST CALL TO DDASKR-------------------
190 C
191 C
192 C  The first call of the code is defined to be the start of each new
193 C  problem.  Read through the descriptions of all the following items,
194 C  provide sufficient storage space for designated arrays, set
195 C  appropriate variables for the initialization of the problem, and
196 C  give information about how you want the problem to be solved.
197 C
198 C
199 C  RES -- Provide a subroutine of the form
200 C
201 C             SUBROUTINE RES (T, Y, YPRIME, DELTA, IRES, RPAR, IPAR)
202 C
203 C         to define the system of differential/algebraic
204 C         equations which is to be solved. For the given values
205 C         of T, Y and YPRIME, the subroutine should return
206 C         the residual of the differential/algebraic system
207 C             DELTA = G(T,Y,YPRIME)
208 C         DELTA is a vector of length NEQ which is output from RES.
209 C
210 C         Subroutine RES must not alter T, Y, YPRIME, or CJ.
211 C         You must declare the name RES in an EXTERNAL
212 C         statement in your program that calls DDASKR.
213 C         You must dimension Y, YPRIME, and DELTA in RES.
214 C
215 C         The input argument CJ can be ignored, or used to rescale
216 C         constraint equations in the system (see Ref. 2, p. 145).
217 C         Note: In this respect, DDASKR is not downward-compatible
218 C         with DDASSL, which does not have the RES argument CJ.
219 C
220 C         IRES is an integer flag which is always equal to zero
221 C         on input.  Subroutine RES should alter IRES only if it
222 C         encounters an illegal value of Y or a stop condition.
223 C         Set IRES = -1 if an input value is illegal, and DDASKR
224 C         will try to solve the problem without getting IRES = -1.
225 C         If IRES = -2, DDASKR will return control to the calling
226 C         program with IDID = -11.
227 C
228 C         RPAR and IPAR are real and integer parameter arrays which
229 C         you can use for communication between your calling program
230 C         and subroutine RES. They are not altered by DDASKR. If you
231 C         do not need RPAR or IPAR, ignore these parameters by treat-
232 C         ing them as dummy arguments. If you do choose to use them,
233 C         dimension them in your calling program and in RES as arrays
234 C         of appropriate length.
235 C
236 C  NEQ -- Set it to the number of equations in the system (NEQ .GE. 1).
237 C
238 C  T -- Set it to the initial point of the integration. (T must be
239 C       a variable.)
240 C
241 C  Y(*) -- Set this array to the initial values of the NEQ solution
242 C          components at the initial point.  You must dimension Y of
243 C          length at least NEQ in your calling program.
244 C
245 C  YPRIME(*) -- Set this array to the initial values of the NEQ first
246 C               derivatives of the solution components at the initial
247 C               point.  You must dimension YPRIME at least NEQ in your
248 C               calling program. 
249 C
250 C  TOUT - Set it to the first point at which a solution is desired.
251 C         You cannot take TOUT = T.  Integration either forward in T
252 C         (TOUT .GT. T) or backward in T (TOUT .LT. T) is permitted.
253 C
254 C         The code advances the solution from T to TOUT using step
255 C         sizes which are automatically selected so as to achieve the
256 C         desired accuracy.  If you wish, the code will return with the
257 C         solution and its derivative at intermediate steps (the
258 C         intermediate-output mode) so that you can monitor them,
259 C         but you still must provide TOUT in accord with the basic
260 C         aim of the code.
261 C
262 C         The first step taken by the code is a critical one because
263 C         it must reflect how fast the solution changes near the
264 C         initial point.  The code automatically selects an initial
265 C         step size which is practically always suitable for the
266 C         problem.  By using the fact that the code will not step past
267 C         TOUT in the first step, you could, if necessary, restrict the
268 C         length of the initial step.
269 C
270 C         For some problems it may not be permissible to integrate
271 C         past a point TSTOP, because a discontinuity occurs there
272 C         or the solution or its derivative is not defined beyond
273 C         TSTOP.  When you have declared a TSTOP point (see INFO(4)
274 C         and RWORK(1)), you have told the code not to integrate past
275 C         TSTOP.  In this case any tout beyond TSTOP is invalid input.
276 C
277 C  INFO(*) - Use the INFO array to give the code more details about
278 C            how you want your problem solved.  This array should be
279 C            dimensioned of length 20, though DDASKR uses only the 
280 C            first 15 entries.  You must respond to all of the following
281 C            items, which are arranged as questions.  The simplest use
282 C            of DDASKR corresponds to setting all entries of INFO to 0.
283 C
284 C       INFO(1) - This parameter enables the code to initialize itself.
285 C              You must set it to indicate the start of every new 
286 C              problem.
287 C
288 C          **** Is this the first call for this problem ...
289 C                yes - set INFO(1) = 0
290 C                 no - not applicable here.
291 C                      See below for continuation calls.  ****
292 C
293 C       INFO(2) - How much accuracy you want of your solution
294 C              is specified by the error tolerances RTOL and ATOL.
295 C              The simplest use is to take them both to be scalars.
296 C              To obtain more flexibility, they can both be arrays.
297 C              The code must be told your choice.
298 C
299 C          **** Are both error tolerances RTOL, ATOL scalars ...
300 C                yes - set INFO(2) = 0
301 C                      and input scalars for both RTOL and ATOL
302 C                 no - set INFO(2) = 1
303 C                      and input arrays for both RTOL and ATOL ****
304 C
305 C       INFO(3) - The code integrates from T in the direction of TOUT
306 C              by steps.  If you wish, it will return the computed
307 C              solution and derivative at the next intermediate step
308 C              (the intermediate-output mode) or TOUT, whichever comes
309 C              first.  This is a good way to proceed if you want to
310 C              see the behavior of the solution.  If you must have
311 C              solutions at a great many specific TOUT points, this
312 C              code will compute them efficiently.
313 C
314 C          **** Do you want the solution only at
315 C               TOUT (and not at the next intermediate step) ...
316 C                yes - set INFO(3) = 0 (interval-output mode)
317 C                 no - set INFO(3) = 1 (intermediate-output mode) ****
318 C
319 C       INFO(4) - To handle solutions at a great many specific
320 C              values TOUT efficiently, this code may integrate past
321 C              TOUT and interpolate to obtain the result at TOUT.
322 C              Sometimes it is not possible to integrate beyond some
323 C              point TSTOP because the equation changes there or it is
324 C              not defined past TSTOP.  Then you must tell the code
325 C              this stop condition.
326 C
327 C           **** Can the integration be carried out without any
328 C                restrictions on the independent variable T ...
329 C                 yes - set INFO(4) = 0
330 C                  no - set INFO(4) = 1
331 C                       and define the stopping point TSTOP by
332 C                       setting RWORK(1) = TSTOP ****
333 C
334 C       INFO(5) - used only when INFO(12) = 0 (direct methods).
335 C              To solve differential/algebraic systems you may wish
336 C              to use a matrix of partial derivatives of the
337 C              system of differential equations.  If you do not
338 C              provide a subroutine to evaluate it analytically (see
339 C              description of the item JAC in the call list), it will
340 C              be approximated by numerical differencing in this code.
341 C              Although it is less trouble for you to have the code
342 C              compute partial derivatives by numerical differencing,
343 C              the solution will be more reliable if you provide the
344 C              derivatives via JAC.  Usually numerical differencing is
345 C              more costly than evaluating derivatives in JAC, but
346 C              sometimes it is not - this depends on your problem.
347 C
348 C           **** Do you want the code to evaluate the partial deriv-
349 C                atives automatically by numerical differences ...
350 C                 yes - set INFO(5) = 0
351 C                  no - set INFO(5) = 1
352 C                       and provide subroutine JAC for evaluating the
353 C                       matrix of partial derivatives ****
354 C
355 C       INFO(6) - used only when INFO(12) = 0 (direct methods).
356 C              DDASKR will perform much better if the matrix of
357 C              partial derivatives, dG/dY + CJ*dG/dYPRIME (here CJ is
358 C              a scalar determined by DDASKR), is banded and the code
359 C              is told this.  In this case, the storage needed will be
360 C              greatly reduced, numerical differencing will be performed
361 C              much cheaper, and a number of important algorithms will
362 C              execute much faster.  The differential equation is said 
363 C              to have half-bandwidths ML (lower) and MU (upper) if 
364 C              equation i involves only unknowns Y(j) with
365 C                             i-ML .le. j .le. i+MU .
366 C              For all i=1,2,...,NEQ.  Thus, ML and MU are the widths
367 C              of the lower and upper parts of the band, respectively,
368 C              with the main diagonal being excluded.  If you do not
369 C              indicate that the equation has a banded matrix of partial
370 C              derivatives the code works with a full matrix of NEQ**2
371 C              elements (stored in the conventional way).  Computations
372 C              with banded matrices cost less time and storage than with
373 C              full matrices if  2*ML+MU .lt. NEQ.  If you tell the
374 C              code that the matrix of partial derivatives has a banded
375 C              structure and you want to provide subroutine JAC to
376 C              compute the partial derivatives, then you must be careful
377 C              to store the elements of the matrix in the special form
378 C              indicated in the description of JAC.
379 C
380 C          **** Do you want to solve the problem using a full (dense)
381 C               matrix (and not a special banded structure) ...
382 C                yes - set INFO(6) = 0
383 C                 no - set INFO(6) = 1
384 C                       and provide the lower (ML) and upper (MU)
385 C                       bandwidths by setting
386 C                       IWORK(1)=ML
387 C                       IWORK(2)=MU ****
388 C
389 C       INFO(7) - You can specify a maximum (absolute value of)
390 C              stepsize, so that the code will avoid passing over very
391 C              large regions.
392 C
393 C          ****  Do you want the code to decide on its own the maximum
394 C                stepsize ...
395 C                 yes - set INFO(7) = 0
396 C                  no - set INFO(7) = 1
397 C                       and define HMAX by setting
398 C                       RWORK(2) = HMAX ****
399 C
400 C       INFO(8) -  Differential/algebraic problems may occasionally
401 C              suffer from severe scaling difficulties on the first
402 C              step.  If you know a great deal about the scaling of 
403 C              your problem, you can help to alleviate this problem 
404 C              by specifying an initial stepsize H0.
405 C
406 C          ****  Do you want the code to define its own initial
407 C                stepsize ...
408 C                 yes - set INFO(8) = 0
409 C                  no - set INFO(8) = 1
410 C                       and define H0 by setting
411 C                       RWORK(3) = H0 ****
412 C
413 C       INFO(9) -  If storage is a severe problem, you can save some
414 C              storage by restricting the maximum method order MAXORD.
415 C              The default value is 5.  For each order decrease below 5,
416 C              the code requires NEQ fewer locations, but it is likely 
417 C              to be slower.  In any case, you must have 
418 C              1 .le. MAXORD .le. 5.
419 C          ****  Do you want the maximum order to default to 5 ...
420 C                 yes - set INFO(9) = 0
421 C                  no - set INFO(9) = 1
422 C                       and define MAXORD by setting
423 C                       IWORK(3) = MAXORD ****
424 C
425 C       INFO(10) - If you know that certain components of the
426 C              solutions to your equations are always nonnegative
427 C              (or nonpositive), it may help to set this
428 C              parameter.  There are three options that are
429 C              available:
430 C              1.  To have constraint checking only in the initial
431 C                  condition calculation.
432 C              2.  To enforce nonnegativity in Y during the integration.
433 C              3.  To enforce both options 1 and 2.
434 C
435 C              When selecting option 2 or 3, it is probably best to try
436 C              the code without using this option first, and only use
437 C              this option if that does not work very well.
438 C
439 C          ****  Do you want the code to solve the problem without
440 C                invoking any special inequality constraints ...
441 C                 yes - set INFO(10) = 0
442 C                  no - set INFO(10) = 1 to have option 1 enforced 
443 C                  no - set INFO(10) = 2 to have option 2 enforced
444 C                  no - set INFO(10) = 3 to have option 3 enforced ****
445 C
446 C                  If you have specified INFO(10) = 1 or 3, then you
447 C                  will also need to identify how each component of Y
448 C                  in the initial condition calculation is constrained.
449 C                  You must set:
450 C                  IWORK(40+I) = +1 if Y(I) must be .GE. 0,
451 C                  IWORK(40+I) = +2 if Y(I) must be .GT. 0,
452 C                  IWORK(40+I) = -1 if Y(I) must be .LE. 0, while
453 C                  IWORK(40+I) = -2 if Y(I) must be .LT. 0, while
454 C                  IWORK(40+I) =  0 if Y(I) is not constrained.
455 C
456 C       INFO(11) - DDASKR normally requires the initial T, Y, and
457 C              YPRIME to be consistent.  That is, you must have
458 C              G(T,Y,YPRIME) = 0 at the initial T.  If you do not know
459 C              the initial conditions precisely, in some cases
460 C              DDASKR may be able to compute it.
461 C
462 C              Denoting the differential variables in Y by Y_d
463 C              and the algebraic variables by Y_a, DDASKR can solve
464 C              one of two initialization problems:
465 C              1.  Given Y_d, calculate Y_a and Y'_d, or
466 C              2.  Given Y', calculate Y.
467 C              In either case, initial values for the given
468 C              components are input, and initial guesses for
469 C              the unknown components must also be provided as input.
470 C
471 C          ****  Are the initial T, Y, YPRIME consistent ...
472 C
473 C                 yes - set INFO(11) = 0
474 C                  no - set INFO(11) = 1 to calculate option 1 above,
475 C                    or set INFO(11) = 2 to calculate option 2 ****
476 C
477 C                  If you have specified INFO(11) = 1, then you
478 C                  will also need to identify  which are the
479 C                  differential and which are the algebraic
480 C                  components (algebraic components are components
481 C                  whose derivatives do not appear explicitly
482 C                  in the function G(T,Y,YPRIME)).  You must set:
483 C                  IWORK(LID+I) = +1 if Y(I) is a differential variable
484 C                  IWORK(LID+I) = -1 if Y(I) is an algebraic variable,
485 C                  where LID = 40 if INFO(10) = 0 or 2 and LID = 40+NEQ
486 C                  if INFO(10) = 1 or 3.
487 C
488 C       INFO(12) - Except for the addition of the RES argument CJ,
489 C              DDASKR by default is downward-compatible with DDASSL,
490 C              which uses only direct (dense or band) methods to solve 
491 C              the linear systems involved.  You must set INFO(12) to
492 C              indicate whether you want the direct methods or the
493 C              Krylov iterative method.
494 C          ****   Do you want DDASKR to use standard direct methods
495 C                 (dense or band) or the Krylov (iterative) method ...
496 C                   direct methods - set INFO(12) = 0.
497 C                   Krylov method  - set INFO(12) = 1,
498 C                       and check the settings of INFO(13) and INFO(15).
499 C
500 C       INFO(13) - used when INFO(12) = 1 (Krylov methods).  
501 C              DDASKR uses scalars MAXL, KMP, NRMAX, and EPLI for the
502 C              iterative solution of linear systems.  INFO(13) allows 
503 C              you to override the default values of these parameters.  
504 C              These parameters and their defaults are as follows:
505 C              MAXL = maximum number of iterations in the SPIGMR 
506 C                 algorithm (MAXL .le. NEQ).  The default is 
507 C                 MAXL = MIN(5,NEQ).
508 C              KMP = number of vectors on which orthogonalization is 
509 C                 done in the SPIGMR algorithm.  The default is 
510 C                 KMP = MAXL, which corresponds to complete GMRES 
511 C                 iteration, as opposed to the incomplete form.  
512 C              NRMAX = maximum number of restarts of the SPIGMR 
513 C                 algorithm per nonlinear iteration.  The default is
514 C                 NRMAX = 5.
515 C              EPLI = convergence test constant in SPIGMR algorithm.
516 C                 The default is EPLI = 0.05.
517 C              Note that the length of RWORK depends on both MAXL 
518 C              and KMP.  See the definition of LRW below.
519 C          ****   Are MAXL, KMP, and EPLI to be given their
520 C                 default values ...
521 C                  yes - set INFO(13) = 0
522 C                   no - set INFO(13) = 1,
523 C                        and set all of the following:
524 C                        IWORK(24) = MAXL (1 .le. MAXL .le. NEQ)
525 C                        IWORK(25) = KMP  (1 .le. KMP .le. MAXL)
526 C                        IWORK(26) = NRMAX  (NRMAX .ge. 0)
527 C                        RWORK(10) = EPLI (0 .lt. EPLI .lt. 1.0) ****
528 C
529 C        INFO(14) - used with INFO(11) > 0 (initial condition 
530 C               calculation is requested).  In this case, you may
531 C               request control to be returned to the calling program
532 C               immediately after the initial condition calculation,
533 C               before proceeding to the integration of the system
534 C               (e.g. to examine the computed Y and YPRIME).
535 C               If this is done, and if the initialization succeeded
536 C               (IDID = 4), you should reset INFO(11) to 0 for the
537 C               next call, to prevent the solver from repeating the 
538 C               initialization (and to avoid an infinite loop). 
539 C          ****   Do you want to proceed to the integration after
540 C                 the initial condition calculation is done ...
541 C                 yes - set INFO(14) = 0
542 C                  no - set INFO(14) = 1                        ****
543 C
544 C        INFO(15) - used when INFO(12) = 1 (Krylov methods).
545 C               When using preconditioning in the Krylov method,
546 C               you must supply a subroutine, PSOL, which solves the
547 C               associated linear systems using P.
548 C               The usage of DDASKR is simpler if PSOL can carry out
549 C               the solution without any prior calculation of data.
550 C               However, if some partial derivative data is to be
551 C               calculated in advance and used repeatedly in PSOL,
552 C               then you must supply a JAC routine to do this,
553 C               and set INFO(15) to indicate that JAC is to be called
554 C               for this purpose.  For example, P might be an
555 C               approximation to a part of the matrix A which can be
556 C               calculated and LU-factored for repeated solutions of
557 C               the preconditioner system.  The arrays WP and IWP
558 C               (described under JAC and PSOL) can be used to
559 C               communicate data between JAC and PSOL.
560 C          ****   Does PSOL operate with no prior preparation ...
561 C                 yes - set INFO(15) = 0 (no JAC routine)
562 C                  no - set INFO(15) = 1
563 C                       and supply a JAC routine to evaluate and
564 C                       preprocess any required Jacobian data.  ****
565 C
566 C         INFO(16) - option to exclude algebraic variables from
567 C               the error test.  
568 C          ****   Do you wish to control errors locally on
569 C                 all the variables...
570 C                 yes - set INFO(16) = 0
571 C                  no - set INFO(16) = 1
572 C                       If you have specified INFO(16) = 1, then you
573 C                       will also need to identify  which are the
574 C                       differential and which are the algebraic
575 C                       components (algebraic components are components
576 C                       whose derivatives do not appear explicitly
577 C                       in the function G(T,Y,YPRIME)).  You must set:
578 C                       IWORK(LID+I) = +1 if Y(I) is a differential 
579 C                                      variable, and
580 C                       IWORK(LID+I) = -1 if Y(I) is an algebraic
581 C                                      variable,
582 C                       where LID = 40 if INFO(10) = 0 or 2 and 
583 C                       LID = 40 + NEQ if INFO(10) = 1 or 3.
584 C
585 C       INFO(17) - used when INFO(11) > 0 (DDASKR is to do an 
586 C              initial condition calculation).
587 C              DDASKR uses several heuristic control quantities in the
588 C              initial condition calculation.  They have default values,
589 C              but can  also be set by the user using INFO(17).
590 C              These parameters and their defaults are as follows:
591 C              MXNIT  = maximum number of Newton iterations
592 C                 per Jacobian or preconditioner evaluation.
593 C                 The default is:
594 C                 MXNIT =  5 in the direct case (INFO(12) = 0), and
595 C                 MXNIT = 15 in the Krylov case (INFO(12) = 1).
596 C              MXNJ   = maximum number of Jacobian or preconditioner
597 C                 evaluations.  The default is:
598 C                 MXNJ = 6 in the direct case (INFO(12) = 0), and
599 C                 MXNJ = 2 in the Krylov case (INFO(12) = 1).
600 C              MXNH   = maximum number of values of the artificial
601 C                 stepsize parameter H to be tried if INFO(11) = 1.
602 C                 The default is MXNH = 5.
603 C                 NOTE: the maximum number of Newton iterations
604 C                 allowed in all is MXNIT*MXNJ*MXNH if INFO(11) = 1,
605 C                 and MXNIT*MXNJ if INFO(11) = 2.
606 C              LSOFF  = flag to turn off the linesearch algorithm
607 C                 (LSOFF = 0 means linesearch is on, LSOFF = 1 means
608 C                 it is turned off).  The default is LSOFF = 0.
609 C              STPTOL = minimum scaled step in linesearch algorithm.
610 C                 The default is STPTOL = (unit roundoff)**(2/3).
611 C              EPINIT = swing factor in the Newton iteration convergence
612 C                 test.  The test is applied to the residual vector,
613 C                 premultiplied by the approximate Jacobian (in the
614 C                 direct case) or the preconditioner (in the Krylov
615 C                 case).  For convergence, the weighted RMS norm of
616 C                 this vector (scaled by the error weights) must be
617 C                 less than EPINIT*EPCON, where EPCON = .33 is the
618 C                 analogous test constant used in the time steps.
619 C                 The default is EPINIT = .01.
620 C          ****   Are the initial condition heuristic controls to be 
621 C                 given their default values...
622 C                  yes - set INFO(17) = 0
623 C                   no - set INFO(17) = 1,
624 C                        and set all of the following:
625 C                        IWORK(32) = MXNIT (.GT. 0)
626 C                        IWORK(33) = MXNJ (.GT. 0)
627 C                        IWORK(34) = MXNH (.GT. 0)
628 C                        IWORK(35) = LSOFF ( = 0 or 1)
629 C                        RWORK(14) = STPTOL (.GT. 0.0)
630 C                        RWORK(15) = EPINIT (.GT. 0.0)  ****
631 C
632 C         INFO(18) - option to get extra printing in initial condition 
633 C                calculation.
634 C          ****   Do you wish to have extra printing...
635 C                 no  - set INFO(18) = 0
636 C                 yes - set INFO(18) = 1 for minimal printing, or
637 C                       set INFO(18) = 2 for full printing.
638 C                       If you have specified INFO(18) .ge. 1, data
639 C                       will be printed with the error handler routines.
640 C                       To print to a non-default unit number L, include
641 C                       the line  CALL XSETUN(L)  in your program.  ****
642 C
643 C   RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL)
644 C               error tolerances to tell the code how accurately you
645 C               want the solution to be computed.  They must be defined
646 C               as variables because the code may change them.
647 C               you have two choices --
648 C                     Both RTOL and ATOL are scalars (INFO(2) = 0), or
649 C                     both RTOL and ATOL are vectors (INFO(2) = 1).
650 C               In either case all components must be non-negative.
651 C
652 C               The tolerances are used by the code in a local error
653 C               test at each step which requires roughly that
654 C                        abs(local error in Y(i)) .le. EWT(i) ,
655 C               where EWT(i) = RTOL*abs(Y(i)) + ATOL is an error weight 
656 C               quantity, for each vector component.
657 C               (More specifically, a root-mean-square norm is used to
658 C               measure the size of vectors, and the error test uses the
659 C               magnitude of the solution at the beginning of the step.)
660 C
661 C               The true (global) error is the difference between the
662 C               true solution of the initial value problem and the
663 C               computed approximation.  Practically all present day
664 C               codes, including this one, control the local error at
665 C               each step and do not even attempt to control the global
666 C               error directly.
667 C
668 C               Usually, but not always, the true accuracy of
669 C               the computed Y is comparable to the error tolerances.
670 C               This code will usually, but not always, deliver a more
671 C               accurate solution if you reduce the tolerances and
672 C               integrate again.  By comparing two such solutions you 
673 C               can get a fairly reliable idea of the true error in the
674 C               solution at the larger tolerances.
675 C
676 C               Setting ATOL = 0. results in a pure relative error test
677 C               on that component.  Setting RTOL = 0. results in a pure
678 C               absolute error test on that component.  A mixed test
679 C               with non-zero RTOL and ATOL corresponds roughly to a
680 C               relative error test when the solution component is
681 C               much bigger than ATOL and to an absolute error test
682 C               when the solution component is smaller than the
683 C               threshold ATOL.
684 C
685 C               The code will not attempt to compute a solution at an
686 C               accuracy unreasonable for the machine being used.  It
687 C               will advise you if you ask for too much accuracy and
688 C               inform you as to the maximum accuracy it believes
689 C               possible.
690 C
691 C  RWORK(*) -- a real work array, which should be dimensioned in your
692 C               calling program with a length equal to the value of
693 C               LRW (or greater).
694 C
695 C  LRW -- Set it to the declared length of the RWORK array.  The
696 C               minimum length depends on the options you have selected,
697 C               given by a base value plus additional storage as
698 C               described below.
699 C
700 C               If INFO(12) = 0 (standard direct method), the base value
701 C               is BASE = 60 + max(MAXORD+4,7)*NEQ + 3*NRT.
702 C               The default value is MAXORD = 5 (see INFO(9)).  With the
703 C               default MAXORD, BASE = 60 + 9*NEQ + 3*NRT.
704 C               Additional storage must be added to the base value for
705 C               any or all of the following options:
706 C                 If INFO(6) = 0 (dense matrix), add NEQ**2.
707 C                 If INFO(6) = 1 (banded matrix), then:
708 C                    if INFO(5) = 0, add (2*ML+MU+1)*NEQ
709 C                                           + 2*[NEQ/(ML+MU+1) + 1], and
710 C                    if INFO(5) = 1, add (2*ML+MU+1)*NEQ.
711 C                 If INFO(16) = 1, add NEQ.
712 C
713 C               If INFO(12) = 1 (Krylov method), the base value is
714 C               BASE = 60 + (MAXORD+5)*NEQ + 3*NRT
715 C                         + [MAXL + 3 + min(1,MAXL-KMP)]*NEQ
716 C                         + (MAXL+3)*MAXL + 1 + LENWP.
717 C               See PSOL for description of LENWP.  The default values
718 C               are: MAXORD = 5 (see INFO(9)), MAXL = min(5,NEQ) and
719 C               KMP = MAXL  (see INFO(13)).  With these default values,
720 C               BASE = 101 + 18*NEQ + 3*NRT + LENWP.
721 C               Additional storage must be added to the base value for
722 C               the following option:
723 C                 If INFO(16) = 1, add NEQ.
724 C
725 C
726 C  IWORK(*) -- an integer work array, which should be dimensioned in
727 C              your calling program with a length equal to the value
728 C              of LIW (or greater).
729 C
730 C  LIW -- Set it to the declared length of the IWORK array.  The
731 C             minimum length depends on the options you have selected,
732 C             given by a base value plus additions as described below.
733 C
734 C             If INFO(12) = 0 (standard direct method), the base value
735 C             is BASE = 40 + NEQ.
736 C             IF INFO(10) = 1 or 3, add NEQ to the base value.
737 C             If INFO(11) = 1 or INFO(16) =1, add NEQ to the base value.
738 C
739 C             If INFO(12) = 1 (Krylov method), the base value is
740 C             BASE = 40 + LENIWP.  See PSOL for description of LENIWP.
741 C             If INFO(10) = 1 or 3, add NEQ to the base value.
742 C             If INFO(11) = 1 or INFO(16) =1, add NEQ to the base value.
743 C
744 C
745 C  RPAR, IPAR -- These are arrays of double precision and integer type,
746 C             respectively, which are available for you to use
747 C             for communication between your program that calls
748 C             DDASKR and the RES subroutine (and the JAC and PSOL
749 C             subroutines).  They are not altered by DDASKR.
750 C             If you do not need RPAR or IPAR, ignore these
751 C             parameters by treating them as dummy arguments.
752 C             If you do choose to use them, dimension them in
753 C             your calling program and in RES (and in JAC and PSOL)
754 C             as arrays of appropriate length.
755 C
756 C  JAC -- This is the name of a routine that you may supply
757 C         (optionally) that relates to the Jacobian matrix of the
758 C         nonlinear system that the code must solve at each T step.
759 C         The role of JAC (and its call sequence) depends on whether
760 C         a direct (INFO(12) = 0) or Krylov (INFO(12) = 1) method 
761 C         is selected.
762 C
763 C         **** INFO(12) = 0 (direct methods):
764 C           If you are letting the code generate partial derivatives
765 C           numerically (INFO(5) = 0), then JAC can be absent
766 C           (or perhaps a dummy routine to satisfy the loader).
767 C           Otherwise you must supply a JAC routine to compute
768 C           the matrix A = dG/dY + CJ*dG/dYPRIME.  It must have
769 C           the form
770 C
771 C           SUBROUTINE JAC (T, Y, YPRIME, PD, CJ, RPAR, IPAR)
772 C
773 C           The JAC routine must dimension Y, YPRIME, and PD (and RPAR
774 C           and IPAR if used).  CJ is a scalar which is input to JAC.
775 C           For the given values of T, Y, and YPRIME, the JAC routine
776 C           must evaluate the nonzero elements of the matrix A, and 
777 C           store these values in the array PD.  The elements of PD are 
778 C           set to zero before each call to JAC, so that only nonzero
779 C           elements need to be defined.
780 C           The way you store the elements into the PD array depends
781 C           on the structure of the matrix indicated by INFO(6).
782 C           *** INFO(6) = 0 (full or dense matrix) ***
783 C               Give PD a first dimension of NEQ.  When you evaluate the
784 C               nonzero partial derivatives of equation i (i.e. of G(i))
785 C               with respect to component j (of Y and YPRIME), you must
786 C               store the element in PD according to
787 C                  PD(i,j) = dG(i)/dY(j) + CJ*dG(i)/dYPRIME(j).
788 C           *** INFO(6) = 1 (banded matrix with half-bandwidths ML, MU
789 C                            as described under INFO(6)) ***
790 C               Give PD a first dimension of 2*ML+MU+1.  When you 
791 C               evaluate the nonzero partial derivatives of equation i 
792 C               (i.e. of G(i)) with respect to component j (of Y and 
793 C               YPRIME), you must store the element in PD according to 
794 C                  IROW = i - j + ML + MU + 1
795 C                  PD(IROW,j) = dG(i)/dY(j) + CJ*dG(i)/dYPRIME(j).
796 C
797 C          **** INFO(12) = 1 (Krylov method):
798 C            If you are not calculating Jacobian data in advance for use
799 C            in PSOL (INFO(15) = 0), JAC can be absent (or perhaps a
800 C            dummy routine to satisfy the loader).  Otherwise, you may
801 C            supply a JAC routine to compute and preprocess any parts of
802 C            of the Jacobian matrix  A = dG/dY + CJ*dG/dYPRIME that are
803 C            involved in the preconditioner matrix P.
804 C            It is to have the form
805 C
806 C            SUBROUTINE JAC (RES, IRES, NEQ, T, Y, YPRIME, REWT, SAVR,
807 C                            WK, H, CJ, WP, IWP, IER, RPAR, IPAR)
808 C
809 C           The JAC routine must dimension Y, YPRIME, REWT, SAVR, WK,
810 C           and (if used) WP, IWP, RPAR, and IPAR.
811 C           The Y, YPRIME, and SAVR arrays contain the current values
812 C           of Y, YPRIME, and the residual G, respectively.  
813 C           The array WK is work space of length NEQ.  
814 C           H is the step size.  CJ is a scalar, input to JAC, that is
815 C           normally proportional to 1/H.  REWT is an array of 
816 C           reciprocal error weights, 1/EWT(i), where EWT(i) is
817 C           RTOL*abs(Y(i)) + ATOL (unless you supplied routine DDAWTS2
818 C           instead), for use in JAC if needed.  For example, if JAC
819 C           computes difference quotient approximations to partial
820 C           derivatives, the REWT array may be useful in setting the
821 C           increments used.  The JAC routine should do any
822 C           factorization operations called for, in preparation for
823 C           solving linear systems in PSOL.  The matrix P should
824 C           be an approximation to the Jacobian,
825 C           A = dG/dY + CJ*dG/dYPRIME.
826 C
827 C           WP and IWP are real and integer work arrays which you may
828 C           use for communication between your JAC routine and your
829 C           PSOL routine.  These may be used to store elements of the 
830 C           preconditioner P, or related matrix data (such as factored
831 C           forms).  They are not altered by DDASKR.
832 C           If you do not need WP or IWP, ignore these parameters by
833 C           treating them as dummy arguments.  If you do use them,
834 C           dimension them appropriately in your JAC and PSOL routines.
835 C           See the PSOL description for instructions on setting 
836 C           the lengths of WP and IWP.
837 C
838 C           On return, JAC should set the error flag IER as follows..
839 C             IER = 0    if JAC was successful,
840 C             IER .ne. 0 if JAC was unsuccessful (e.g. if Y or YPRIME
841 C                        was illegal, or a singular matrix is found).
842 C           (If IER .ne. 0, a smaller stepsize will be tried.)
843 C           IER = 0 on entry to JAC, so need be reset only on a failure.
844 C           If RES is used within JAC, then a nonzero value of IRES will
845 C           override any nonzero value of IER (see the RES description).
846 C
847 C         Regardless of the method type, subroutine JAC must not
848 C         alter T, Y(*), YPRIME(*), H, CJ, or REWT(*).
849 C         You must declare the name JAC in an EXTERNAL statement in
850 C         your program that calls DDASKR.
851 C
852 C PSOL --  This is the name of a routine you must supply if you have
853 C         selected a Krylov method (INFO(12) = 1) with preconditioning.
854 C         In the direct case (INFO(12) = 0), PSOL can be absent 
855 C         (a dummy routine may have to be supplied to satisfy the 
856 C         loader).  Otherwise, you must provide a PSOL routine to 
857 C         solve linear systems arising from preconditioning.
858 C         When supplied with INFO(12) = 1, the PSOL routine is to 
859 C         have the form
860 C
861 C         SUBROUTINE PSOL (NEQ, T, Y, YPRIME, SAVR, WK, CJ, WGHT,
862 C                          WP, IWP, B, EPLIN, IER, RPAR, IPAR)
863 C
864 C         The PSOL routine must solve linear systems of the form 
865 C         P*x = b where P is the left preconditioner matrix.
866 C
867 C         The right-hand side vector b is in the B array on input, and
868 C         PSOL must return the solution vector x in B.
869 C         The Y, YPRIME, and SAVR arrays contain the current values
870 C         of Y, YPRIME, and the residual G, respectively.  
871 C
872 C         Work space required by JAC and/or PSOL, and space for data to
873 C         be communicated from JAC to PSOL is made available in the form
874 C         of arrays WP and IWP, which are parts of the RWORK and IWORK
875 C         arrays, respectively.  The lengths of these real and integer
876 C         work spaces WP and IWP must be supplied in LENWP and LENIWP,
877 C         respectively, as follows..
878 C           IWORK(27) = LENWP = length of real work space WP
879 C           IWORK(28) = LENIWP = length of integer work space IWP.
880 C
881 C         WK is a work array of length NEQ for use by PSOL.
882 C         CJ is a scalar, input to PSOL, that is normally proportional
883 C         to 1/H (H = stepsize).  If the old value of CJ
884 C         (at the time of the last JAC call) is needed, it must have
885 C         been saved by JAC in WP.
886 C
887 C         WGHT is an array of weights, to be used if PSOL uses an
888 C         iterative method and performs a convergence test.  (In terms
889 C         of the argument REWT to JAC, WGHT is REWT/sqrt(NEQ).)
890 C         If PSOL uses an iterative method, it should use EPLIN
891 C         (a heuristic parameter) as the bound on the weighted norm of
892 C         the residual for the computed solution.  Specifically, the
893 C         residual vector R should satisfy
894 C              SQRT (SUM ( (R(i)*WGHT(i))**2 ) ) .le. EPLIN
895 C
896 C         PSOL must not alter NEQ, T, Y, YPRIME, SAVR, CJ, WGHT, EPLIN.
897 C
898 C         On return, PSOL should set the error flag IER as follows..
899 C           IER = 0 if PSOL was successful,
900 C           IER .lt. 0 if an unrecoverable error occurred, meaning
901 C                 control will be passed to the calling routine,
902 C           IER .gt. 0 if a recoverable error occurred, meaning that
903 C                 the step will be retried with the same step size
904 C                 but with a call to JAC to update necessary data,
905 C                 unless the Jacobian data is current, in which case
906 C                 the step will be retried with a smaller step size.
907 C           IER = 0 on entry to PSOL so need be reset only on a failure.
908 C
909 C         You must declare the name PSOL in an EXTERNAL statement in
910 C         your program that calls DDASKR.
911 C
912 C RT --   This is the name of the subroutine for defining the vector
913 C         R(T,Y,Y') of constraint functions Ri(T,Y,Y'), whose roots
914 C         are desired during the integration.  It is to have the form
915 C             SUBROUTINE RT(NEQ, T, Y NRT, RVAL, RPAR, IPAR)
916 C             DIMENSION Y(NEQ), YP(NEQ), RVAL(NRT),
917 C         where NEQ, T, Y and NRT are INPUT, and the array RVAL is
918 C         output.  NEQ, T, Y, and YP have the same meaning as in the
919 C         RES routine, and RVAL is an array of length NRT.
920 C         For i = 1,...,NRT, this routine is to load into RVAL(i) the
921 C         value at (T,Y,Y') of the i-th constraint function Ri(T,Y,Y').
922 C         DDASKR will find roots of the Ri of odd multiplicity
923 C         (that is, sign changes) as they occur during the integration.
924 C         RT must be declared EXTERNAL in the calling program.
925 C
926 C         CAUTION.. Because of numerical errors in the functions Ri
927 C         due to roundoff and integration error, DDASKR may return
928 C         false roots, or return the same root at two or more nearly
929 C         equal values of T.  If such false roots are suspected,
930 C         the user should consider smaller error tolerances and/or
931 C         higher precision in the evaluation of the Ri.
932 C
933 C         If a root of some Ri defines the end of the problem,
934 C         the input to DDASKR should nevertheless allow
935 C         integration to a point slightly past that root, so
936 C         that DDASKR can locate the root by interpolation.
937 C
938 C NRT --  The number of constraint functions Ri(T,Y,Y').  If there are
939 C         no constraints, set NRT = 0 and pass a dummy name for RT.
940 C
941 C JROOT -- This is an integer array of length NRT, used only for output.
942 C         On a return where one or more roots were found (IDID = 5),
943 C         JROOT(i) = 1 or -1 if Ri(T,Y,Y') has a root at T, and
944 C         JROOT(i) = 0 if not.  If nonzero, JROOT(i) shows the direction
945 C         of the sign change in Ri in the direction of integration: 
946 C         JROOT(i) = 1  means Ri changed from negative to positive.
947 C         JROOT(i) = -1 means Ri changed from positive to negative.
948 C
949 C
950 C  OPTIONALLY REPLACEABLE SUBROUTINE:
951 C
952 C  DDASKR uses a weighted root-mean-square norm to measure the 
953 C  size of various error vectors.  The weights used in this norm
954 C  are set in the following subroutine:
955 C
956 C    SUBROUTINE DDAWTS2 (NEQ, IWT, RTOL, ATOL, Y, EWT, RPAR, IPAR)
957 C    DIMENSION RTOL(*), ATOL(*), Y(*), EWT(*), RPAR(*), IPAR(*)
958 C
959 C  A DDAWTS2 routine has been included with DDASKR which sets the
960 C  weights according to
961 C    EWT(I) = RTOL*ABS(Y(I)) + ATOL
962 C  in the case of scalar tolerances (IWT = 0) or
963 C    EWT(I) = RTOL(I)*ABS(Y(I)) + ATOL(I)
964 C  in the case of array tolerances (IWT = 1).  (IWT is INFO(2).)
965 C  In some special cases, it may be appropriate for you to define
966 C  your own error weights by writing a subroutine DDAWTS2 to be 
967 C  called instead of the version supplied.  However, this should 
968 C  be attempted only after careful thought and consideration. 
969 C  If you supply this routine, you may use the tolerances and Y 
970 C  as appropriate, but do not overwrite these variables.  You
971 C  may also use RPAR and IPAR to communicate data as appropriate.
972 C  ***Note: Aside from the values of the weights, the choice of 
973 C  norm used in DDASKR (weighted root-mean-square) is not subject
974 C  to replacement by the user.  In this respect, DDASKR is not
975 C  downward-compatible with the original DDASSL solver (in which
976 C  the norm routine was optionally user-replaceable).
977 C
978 C
979 C------OUTPUT - AFTER ANY RETURN FROM DDASKR----------------------------
980 C
981 C  The principal aim of the code is to return a computed solution at
982 C  T = TOUT, although it is also possible to obtain intermediate
983 C  results along the way.  To find out whether the code achieved its
984 C  goal or if the integration process was interrupted before the task
985 C  was completed, you must check the IDID parameter.
986 C
987 C
988 C   T -- The output value of T is the point to which the solution
989 C        was successfully advanced.
990 C
991 C   Y(*) -- contains the computed solution approximation at T.
992 C
993 C   YPRIME(*) -- contains the computed derivative approximation at T.
994 C
995 C   IDID -- reports what the code did, described as follows:
996 C
997 C                     *** TASK COMPLETED ***
998 C                Reported by positive values of IDID
999 C
1000 C           IDID = 1 -- A step was successfully taken in the
1001 C                   interval-output mode.  The code has not
1002 C                   yet reached TOUT.
1003 C
1004 C           IDID = 2 -- The integration to TSTOP was successfully
1005 C                   completed (T = TSTOP) by stepping exactly to TSTOP.
1006 C
1007 C           IDID = 3 -- The integration to TOUT was successfully
1008 C                   completed (T = TOUT) by stepping past TOUT.
1009 C                   Y(*) and YPRIME(*) are obtained by interpolation.
1010 C
1011 C           IDID = 4 -- The initial condition calculation, with
1012 C                   INFO(11) > 0, was successful, and INFO(14) = 1.
1013 C                   No integration steps were taken, and the solution
1014 C                   is not considered to have been started.
1015 C
1016 C           IDID = 5 -- The integration was successfully completed
1017 C                   by finding one or more roots of R(T,Y,Y') at T.
1018 C
1019 C                    *** TASK INTERRUPTED ***
1020 C                Reported by negative values of IDID
1021 C
1022 C           IDID = -1 -- A large amount of work has been expended
1023 C                     (about 500 steps).
1024 C
1025 C           IDID = -2 -- The error tolerances are too stringent.
1026 C
1027 C           IDID = -3 -- The local error test cannot be satisfied
1028 C                     because you specified a zero component in ATOL
1029 C                     and the corresponding computed solution component
1030 C                     is zero.  Thus, a pure relative error test is
1031 C                     impossible for this component.
1032 C
1033 C           IDID = -5 -- There were repeated failures in the evaluation
1034 C                     or processing of the preconditioner (in JAC).
1035 C
1036 C           IDID = -6 -- DDASKR had repeated error test failures on the
1037 C                     last attempted step.
1038 C
1039 C           IDID = -7 -- The nonlinear system solver in the time
1040 C                     integration could not converge.
1041 C
1042 C           IDID = -8 -- The matrix of partial derivatives appears
1043 C                     to be singular (direct method).
1044 C
1045 C           IDID = -9 -- The nonlinear system solver in the integration
1046 C                     failed to achieve convergence, and there were
1047 C                     repeated  error test failures in this step.
1048 C
1049 C           IDID =-10 -- The nonlinear system solver in the integration 
1050 C                     failed to achieve convergence because IRES was
1051 C                     equal  to -1.
1052 C
1053 C           IDID =-11 -- IRES = -2 was encountered and control is
1054 C                     being returned to the calling program.
1055 C
1056 C           IDID =-12 -- DDASKR failed to compute the initial Y, YPRIME.
1057 C
1058 C           IDID =-13 -- An unrecoverable error was encountered inside
1059 C                     the user's PSOL routine, and control is being
1060 C                     returned to the calling program.
1061 C
1062 C           IDID =-14 -- The Krylov linear system solver could not 
1063 C                     achieve convergence.
1064 C
1065 C           IDID =-15,..,-32 -- Not applicable for this code.
1066 C
1067 C                    *** TASK TERMINATED ***
1068 C                reported by the value of IDID=-33
1069 C
1070 C           IDID = -33 -- The code has encountered trouble from which
1071 C                   it cannot recover.  A message is printed
1072 C                   explaining the trouble and control is returned
1073 C                   to the calling program.  For example, this occurs
1074 C                   when invalid input is detected.
1075 C
1076 C   RTOL, ATOL -- these quantities remain unchanged except when
1077 C               IDID = -2.  In this case, the error tolerances have been
1078 C               increased by the code to values which are estimated to
1079 C               be appropriate for continuing the integration.  However,
1080 C               the reported solution at T was obtained using the input
1081 C               values of RTOL and ATOL.
1082 C
1083 C   RWORK, IWORK -- contain information which is usually of no interest
1084 C               to the user but necessary for subsequent calls. 
1085 C               However, you may be interested in the performance data
1086 C               listed below.  These quantities are accessed in RWORK 
1087 C               and IWORK but have internal mnemonic names, as follows..
1088 C
1089 C               RWORK(3)--contains H, the step size h to be attempted
1090 C                        on the next step.
1091 C
1092 C               RWORK(4)--contains TN, the current value of the
1093 C                        independent variable, i.e. the farthest point
1094 C                        integration has reached.  This will differ 
1095 C                        from T if interpolation has been performed 
1096 C                        (IDID = 3).
1097 C
1098 C               RWORK(7)--contains HOLD, the stepsize used on the last
1099 C                        successful step.  If INFO(11) = INFO(14) = 1,
1100 C                        this contains the value of H used in the
1101 C                        initial condition calculation.
1102 C
1103 C               IWORK(7)--contains K, the order of the method to be 
1104 C                        attempted on the next step.
1105 C
1106 C               IWORK(8)--contains KOLD, the order of the method used
1107 C                        on the last step.
1108 C
1109 C               IWORK(11)--contains NST, the number of steps (in T) 
1110 C                        taken so far.
1111 C
1112 C               IWORK(12)--contains NRE, the number of calls to RES 
1113 C                        so far.
1114 C
1115 C               IWORK(13)--contains NJE, the number of calls to JAC so
1116 C                        far (Jacobian or preconditioner evaluations).
1117 C
1118 C               IWORK(14)--contains NETF, the total number of error test
1119 C                        failures so far.
1120 C
1121 C               IWORK(15)--contains NCFN, the total number of nonlinear
1122 C                        convergence failures so far (includes counts
1123 C                        of singular iteration matrix or singular
1124 C                        preconditioners).
1125 C
1126 C               IWORK(16)--contains NCFL, the number of convergence
1127 C                        failures of the linear iteration so far.
1128 C
1129 C               IWORK(17)--contains LENIW, the length of IWORK actually
1130 C                        required.  This is defined on normal returns 
1131 C                        and on an illegal input return for
1132 C                        insufficient storage.
1133 C
1134 C               IWORK(18)--contains LENRW, the length of RWORK actually
1135 C                        required.  This is defined on normal returns 
1136 C                        and on an illegal input return for
1137 C                        insufficient storage.
1138 C
1139 C               IWORK(19)--contains NNI, the total number of nonlinear
1140 C                        iterations so far (each of which calls a
1141 C                        linear solver).
1142 C
1143 C               IWORK(20)--contains NLI, the total number of linear
1144 C                        (Krylov) iterations so far.
1145 C
1146 C               IWORK(21)--contains NPS, the number of PSOL calls so
1147 C                        far, for preconditioning solve operations or
1148 C                        for solutions with the user-supplied method.
1149 C
1150 C               IWORK(36)--contains the total number of calls to the
1151 C                        constraint function routine RT so far.
1152 C
1153 C               Note: The various counters in IWORK do not include 
1154 C               counts during a prior call made with INFO(11) > 0 and
1155 C               INFO(14) = 1.
1156 C
1157 C
1158 C------INPUT - WHAT TO DO TO CONTINUE THE INTEGRATION  -----------------
1159 C              (CALLS AFTER THE FIRST)
1160 C
1161 C     This code is organized so that subsequent calls to continue the
1162 C     integration involve little (if any) additional effort on your
1163 C     part.  You must monitor the IDID parameter in order to determine
1164 C     what to do next.
1165 C
1166 C     Recalling that the principal task of the code is to integrate
1167 C     from T to TOUT (the interval mode), usually all you will need
1168 C     to do is specify a new TOUT upon reaching the current TOUT.
1169 C
1170 C     Do not alter any quantity not specifically permitted below.  In
1171 C     particular do not alter NEQ, T, Y(*), YPRIME(*), RWORK(*), 
1172 C     IWORK(*), or the differential equation in subroutine RES.  Any 
1173 C     such alteration constitutes a new problem and must be treated 
1174 C     as such, i.e. you must start afresh.
1175 C
1176 C     You cannot change from array to scalar error control or vice
1177 C     versa (INFO(2)), but you can change the size of the entries of
1178 C     RTOL or ATOL.  Increasing a tolerance makes the equation easier
1179 C     to integrate.  Decreasing a tolerance will make the equation
1180 C     harder to integrate and should generally be avoided.
1181 C
1182 C     You can switch from the intermediate-output mode to the
1183 C     interval mode (INFO(3)) or vice versa at any time.
1184 C
1185 C     If it has been necessary to prevent the integration from going
1186 C     past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the
1187 C     code will not integrate to any TOUT beyond the currently
1188 C     specified TSTOP.  Once TSTOP has been reached, you must change
1189 C     the value of TSTOP or set INFO(4) = 0.  You may change INFO(4)
1190 C     or TSTOP at any time but you must supply the value of TSTOP in
1191 C     RWORK(1) whenever you set INFO(4) = 1.
1192 C
1193 C     Do not change INFO(5), INFO(6), INFO(12-17) or their associated
1194 C     IWORK/RWORK locations unless you are going to restart the code.
1195 C
1196 C                    *** FOLLOWING A COMPLETED TASK ***
1197 C
1198 C     If..
1199 C     IDID = 1, call the code again to continue the integration
1200 C                  another step in the direction of TOUT.
1201 C
1202 C     IDID = 2 or 3, define a new TOUT and call the code again.
1203 C                  TOUT must be different from T.  You cannot change
1204 C                  the direction of integration without restarting.
1205 C
1206 C     IDID = 4, reset INFO(11) = 0 and call the code again to begin
1207 C                  the integration.  (If you leave INFO(11) > 0 and
1208 C                  INFO(14) = 1, you may generate an infinite loop.)
1209 C                  In this situation, the next call to DDASKR is 
1210 C                  considered to be the first call for the problem,
1211 C                  in that all initializations are done.
1212 C
1213 C     IDID = 5, call the code again to continue the integration in the
1214 C                  direction of TOUT.  You may change the functions
1215 C                  Ri defined by RT after a return with IDID = 5, but
1216 C                  the number of constraint functions NRT must remain
1217 C                  the same.  If you wish to change the functions in
1218 C                  RES or in RT, then you must restart the code.
1219 C
1220 C                    *** FOLLOWING AN INTERRUPTED TASK ***
1221 C
1222 C     To show the code that you realize the task was interrupted and
1223 C     that you want to continue, you must take appropriate action and
1224 C     set INFO(1) = 1.
1225 C
1226 C     If..
1227 C     IDID = -1, the code has taken about 500 steps.  If you want to
1228 C                  continue, set INFO(1) = 1 and call the code again.
1229 C                  An additional 500 steps will be allowed.
1230 C
1231 C
1232 C     IDID = -2, the error tolerances RTOL, ATOL have been increased
1233 C                  to values the code estimates appropriate for
1234 C                  continuing.  You may want to change them yourself.
1235 C                  If you are sure you want to continue with relaxed
1236 C                  error tolerances, set INFO(1) = 1 and call the code
1237 C                  again.
1238 C
1239 C     IDID = -3, a solution component is zero and you set the
1240 C                  corresponding component of ATOL to zero.  If you
1241 C                  are sure you want to continue, you must first alter
1242 C                  the error criterion to use positive values of ATOL 
1243 C                  for those components corresponding to zero solution
1244 C                  components, then set INFO(1) = 1 and call the code
1245 C                  again.
1246 C
1247 C     IDID = -4  --- cannot occur with this code.
1248 C
1249 C     IDID = -5, your JAC routine failed with the Krylov method.  Check
1250 C                  for errors in JAC and restart the integration.
1251 C
1252 C     IDID = -6, repeated error test failures occurred on the last
1253 C                  attempted step in DDASKR.  A singularity in the
1254 C                  solution may be present.  If you are absolutely
1255 C                  certain you want to continue, you should restart
1256 C                  the integration.  (Provide initial values of Y and
1257 C                  YPRIME which are consistent.)
1258 C
1259 C     IDID = -7, repeated convergence test failures occurred on the last
1260 C                  attempted step in DDASKR.  An inaccurate or ill-
1261 C                  conditioned Jacobian or preconditioner may be the
1262 C                  problem.  If you are absolutely certain you want
1263 C                  to continue, you should restart the integration.
1264 C
1265 C
1266 C     IDID = -8, the matrix of partial derivatives is singular, with
1267 C                  the use of direct methods.  Some of your equations
1268 C                  may be redundant.  DDASKR cannot solve the problem
1269 C                  as stated.  It is possible that the redundant
1270 C                  equations could be removed, and then DDASKR could
1271 C                  solve the problem.  It is also possible that a
1272 C                  solution to your problem either does not exist
1273 C                  or is not unique.
1274 C
1275 C     IDID = -9, DDASKR had multiple convergence test failures, preceded
1276 C                  by multiple error test failures, on the last
1277 C                  attempted step.  It is possible that your problem is
1278 C                  ill-posed and cannot be solved using this code.  Or,
1279 C                  there may be a discontinuity or a singularity in the
1280 C                  solution.  If you are absolutely certain you want to
1281 C                  continue, you should restart the integration.
1282 C
1283 C     IDID = -10, DDASKR had multiple convergence test failures
1284 C                  because IRES was equal to -1.  If you are
1285 C                  absolutely certain you want to continue, you
1286 C                  should restart the integration.
1287 C
1288 C     IDID = -11, there was an unrecoverable error (IRES = -2) from RES
1289 C                  inside the nonlinear system solver.  Determine the
1290 C                  cause before trying again.
1291 C
1292 C     IDID = -12, DDASKR failed to compute the initial Y and YPRIME
1293 C                  vectors.  This could happen because the initial 
1294 C                  approximation to Y or YPRIME was not very good, or
1295 C                  because no consistent values of these vectors exist.
1296 C                  The problem could also be caused by an inaccurate or
1297 C                  singular iteration matrix, or a poor preconditioner.
1298 C
1299 C     IDID = -13, there was an unrecoverable error encountered inside 
1300 C                  your PSOL routine.  Determine the cause before 
1301 C                  trying again.
1302 C
1303 C     IDID = -14, the Krylov linear system solver failed to achieve
1304 C                  convergence.  This may be due to ill-conditioning
1305 C                  in the iteration matrix, or a singularity in the
1306 C                  preconditioner (if one is being used).
1307 C                  Another possibility is that there is a better
1308 C                  choice of Krylov parameters (see INFO(13)).
1309 C                  Possibly the failure is caused by redundant equations
1310 C                  in the system, or by inconsistent equations.
1311 C                  In that case, reformulate the system to make it
1312 C                  consistent and non-redundant.
1313 C
1314 C     IDID = -15,..,-32 --- Cannot occur with this code.
1315 C
1316 C                       *** FOLLOWING A TERMINATED TASK ***
1317 C
1318 C     If IDID = -33, you cannot continue the solution of this problem.
1319 C                  An attempt to do so will result in your run being
1320 C                  terminated.
1321 C
1322 C  ---------------------------------------------------------------------
1323 C
1324 C***REFERENCES
1325 C  1.  L. R. Petzold, A Description of DASSL: A Differential/Algebraic
1326 C      System Solver, in Scientific Computing, R. S. Stepleman et al.
1327 C      (Eds.), North-Holland, Amsterdam, 1983, pp. 65-68.
1328 C  2.  K. E. Brenan, S. L. Campbell, and L. R. Petzold, Numerical 
1329 C      Solution of Initial-Value Problems in Differential-Algebraic
1330 C      Equations, Elsevier, New York, 1989.
1331 C  3.  P. N. Brown and A. C. Hindmarsh, Reduced Storage Matrix Methods
1332 C      in Stiff ODE Systems, J. Applied Mathematics and Computation,
1333 C      31 (1989), pp. 40-91.
1334 C  4.  P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Using Krylov
1335 C      Methods in the Solution of Large-Scale Differential-Algebraic
1336 C      Systems, SIAM J. Sci. Comp., 15 (1994), pp. 1467-1488.
1337 C  5.  P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Consistent
1338 C      Initial Condition Calculation for Differential-Algebraic
1339 C      Systems, SIAM J. Sci. Comp. 19 (1998), pp. 1495-1512.
1340 C
1341 C***ROUTINES CALLED
1342 C
1343 C   The following are all the subordinate routines used by DDASKR.
1344 C
1345 C   DRCHEK2 does preliminary checking for roots, and serves as an
1346 C          interface between Subroutine DDASKR and Subroutine DROOTS2.
1347 C   DROOTS2 finds the leftmost root of a set of functions.
1348 C   DDASIC computes consistent initial conditions.
1349 C   DYYPNW updates Y and YPRIME in linesearch for initial condition
1350 C          calculation.
1351 C   DDSTP  carries out one step of the integration.
1352 C   DCNSTR/DCNST0 check the current solution for constraint violations.
1353 C   DDAWTS2 sets error weight quantities.
1354 C   DINVWT tests and inverts the error weights.
1355 C   DDATRP2 performs interpolation to get an output solution.
1356 C   DDWNRM computes the weighted root-mean-square norm of a vector.
1357 C   D1MACH2 provides the unit roundoff of the computer.
1358 C   XERRWD/XSETF/XSETUN/IXSAV is a package to handle error messages. 
1359 C   DDASID nonlinear equation driver to initialize Y and YPRIME using
1360 C          direct linear system solver methods.  Interfaces to Newton
1361 C          solver (direct case).
1362 C   DNSID  solves the nonlinear system for unknown initial values by
1363 C          modified Newton iteration and direct linear system methods.
1364 C   DLINSD carries out linesearch algorithm for initial condition
1365 C          calculation (direct case).
1366 C   DFNRMD calculates weighted norm of preconditioned residual in
1367 C          initial condition calculation (direct case).
1368 C   DNEDD  nonlinear equation driver for direct linear system solver
1369 C          methods.  Interfaces to Newton solver (direct case).
1370 C   DMATD  assembles the iteration matrix (direct case).
1371 C   DNSD   solves the associated nonlinear system by modified
1372 C          Newton iteration and direct linear system methods.
1373 C   DSLVD  interfaces to linear system solver (direct case).
1374 C   DDASIK nonlinear equation driver to initialize Y and YPRIME using
1375 C          Krylov iterative linear system methods.  Interfaces to
1376 C          Newton solver (Krylov case).
1377 C   DNSIK  solves the nonlinear system for unknown initial values by
1378 C          Newton iteration and Krylov iterative linear system methods.
1379 C   DLINSK carries out linesearch algorithm for initial condition
1380 C          calculation (Krylov case).
1381 C   DFNRMK calculates weighted norm of preconditioned residual in
1382 C          initial condition calculation (Krylov case).
1383 C   DNEDK  nonlinear equation driver for iterative linear system solver
1384 C          methods.  Interfaces to Newton solver (Krylov case).
1385 C   DNSK   solves the associated nonlinear system by Inexact Newton
1386 C          iteration and (linear) Krylov iteration.
1387 C   DSLVK  interfaces to linear system solver (Krylov case).
1388 C   DSPIGM solves a linear system by SPIGMR algorithm.
1389 C   DATV   computes matrix-vector product in Krylov algorithm.
1390 C   DORTH  performs orthogonalization of Krylov basis vectors.
1391 C   DHEQR  performs QR factorization of Hessenberg matrix.
1392 C   DHELS  finds least-squares solution of Hessenberg linear system.
1393 C   DGEFA, DGESL, DGBFA, DGBSL are LINPACK routines for solving 
1394 C          linear systems (dense or band direct methods).
1395 C   DAXPY, DCOPY, DDOT, DNRM2, DSCAL are Basic Linear Algebra (BLAS)
1396 C          routines.
1397 C
1398 C The routines called directly by DDASKR are:
1399 C   DCNST0, DDAWTS2, DINVWT, D1MACH2, DDWNRM, DDASIC, DDATRP2, DDSTP,
1400 C   DRCHEK2, XERRWD
1401 C
1402 C***END PROLOGUE DDASKR
1403 C
1404 C
1405       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
1406       LOGICAL DONE, LAVL, LCFN, LCFL, LWARN
1407       DIMENSION Y(*),YPRIME(*)
1408       DIMENSION INFO(20)
1409       DIMENSION RWORK(LRW),IWORK(LIW)
1410       DIMENSION RTOL(*),ATOL(*)
1411       DIMENSION RPAR(*),IPAR(*)
1412       CHARACTER MSG*80
1413       EXTERNAL  RES, JAC, PSOL, RT, DDASID, DDASIK, DNEDD, DNEDK
1414 C
1415 C     Set pointers into IWORK.
1416 C
1417       PARAMETER (LML=1, LMU=2, LMTYPE=4, 
1418      *   LIWM=1, LMXORD=3, LJCALC=5, LPHASE=6, LK=7, LKOLD=8,
1419      *   LNS=9, LNSTL=10, LNST=11, LNRE=12, LNJE=13, LETF=14, LNCFN=15,
1420      *   LNCFL=16, LNIW=17, LNRW=18, LNNI=19, LNLI=20, LNPS=21,
1421      *   LNPD=22, LMITER=23, LMAXL=24, LKMP=25, LNRMAX=26, LLNWP=27,
1422      *   LLNIWP=28, LLOCWP=29, LLCIWP=30, LKPRIN=31, LMXNIT=32,
1423      *   LMXNJ=33, LMXNH=34, LLSOFF=35, LNRTE=36, LIRFND=37, LICNS=41)
1424 C
1425 C     Set pointers into RWORK.
1426 C
1427       PARAMETER (LTSTOP=1, LHMAX=2, LH=3, LTN=4, LCJ=5, LCJOLD=6,
1428      *   LHOLD=7, LS=8, LROUND=9, LEPLI=10, LSQRN=11, LRSQRN=12,
1429      *   LEPCON=13, LSTOL=14, LEPIN=15, LALPHA=21, LBETA=27,
1430      *   LGAMMA=33, LPSI=39, LSIGMA=45, LT0=51, LTLAST=52, LDELTA=61)
1431 C
1432       SAVE LID, LENID, NONNEG, NCPHI
1433 C
1434       COMMON /ierode/ierror
1435 C
1436 C
1437 C***FIRST EXECUTABLE STATEMENT  DDASKR
1438 C
1439 C
1440       IF(INFO(1).NE.0) GO TO 100
1441 C
1442 C-----------------------------------------------------------------------
1443 C     This block is executed for the initial call only.
1444 C     It contains checking of inputs and initializations.
1445 C-----------------------------------------------------------------------
1446 C
1447 C     First check INFO array to make sure all elements of INFO
1448 C     Are within the proper range.  (INFO(1) is checked later, because
1449 C     it must be tested on every call.) ITEMP holds the location
1450 C     within INFO which may be out of range.
1451 C
1452       DO 10 I=2,9
1453          ITEMP = I
1454          IF (INFO(I) .NE. 0 .AND. INFO(I) .NE. 1) GO TO 701
1455  10      CONTINUE
1456       ITEMP = 10
1457       IF(INFO(10).LT.0 .OR. INFO(10).GT.3) GO TO 701
1458       ITEMP = 11
1459       IF(INFO(11).LT.0 .OR. INFO(11).GT.2) GO TO 701
1460       DO 15 I=12,17
1461          ITEMP = I
1462          IF (INFO(I) .NE. 0 .AND. INFO(I) .NE. 1) GO TO 701
1463  15      CONTINUE
1464       ITEMP = 18
1465       IF(INFO(18).LT.0 .OR. INFO(18).GT.2) GO TO 701
1466
1467 C
1468 C     Check NEQ to see if it is positive.
1469 C
1470       IF (NEQ .LE. 0) GO TO 702
1471 C
1472 C     Check and compute maximum order.
1473 C
1474       MXORD=5
1475       IF (INFO(9) .NE. 0) THEN
1476          MXORD=IWORK(LMXORD)
1477          IF (MXORD .LT. 1 .OR. MXORD .GT. 5) GO TO 703
1478          ENDIF
1479       IWORK(LMXORD)=MXORD
1480 C
1481 C     Set and/or check inputs for constraint checking (INFO(10) .NE. 0).
1482 C     Set values for ICNFLG, NONNEG, and pointer LID.
1483 C
1484       ICNFLG = 0
1485       NONNEG = 0
1486       LID = LICNS
1487       IF (INFO(10) .EQ. 0) GO TO 20
1488       IF (INFO(10) .EQ. 1) THEN
1489          ICNFLG = 1
1490          NONNEG = 0
1491          LID = LICNS + NEQ
1492       ELSEIF (INFO(10) .EQ. 2) THEN
1493          ICNFLG = 0
1494          NONNEG = 1
1495       ELSE
1496          ICNFLG = 1
1497          NONNEG = 1
1498          LID = LICNS + NEQ
1499       ENDIF
1500 C
1501  20   CONTINUE
1502 C
1503 C     Set and/or check inputs for Krylov solver (INFO(12) .NE. 0).
1504 C     If indicated, set default values for MAXL, KMP, NRMAX, and EPLI.
1505 C     Otherwise, verify inputs required for iterative solver.
1506 C
1507       IF (INFO(12) .EQ. 0) GO TO 25
1508 C
1509       IWORK(LMITER) = INFO(12)
1510       IF (INFO(13) .EQ. 0) THEN
1511          IWORK(LMAXL) = MIN(5,NEQ)
1512          IWORK(LKMP) = IWORK(LMAXL)
1513          IWORK(LNRMAX) = 5
1514          RWORK(LEPLI) = 0.05D0
1515       ELSE
1516          IF(IWORK(LMAXL) .LT. 1 .OR. IWORK(LMAXL) .GT. NEQ) GO TO 720
1517          IF(IWORK(LKMP) .LT. 1 .OR. IWORK(LKMP) .GT. IWORK(LMAXL))
1518      1      GO TO 721
1519          IF(IWORK(LNRMAX) .LT. 0) GO TO 722
1520          IF(RWORK(LEPLI).LE.0.0D0 .OR. RWORK(LEPLI).GE.1.0D0)GO TO 723
1521          ENDIF
1522 C
1523  25   CONTINUE
1524 C
1525 C     Set and/or check controls for the initial condition calculation
1526 C     (INFO(11) .GT. 0).  If indicated, set default values.
1527 C     Otherwise, verify inputs required for iterative solver.
1528 C
1529       IF (INFO(11) .EQ. 0) GO TO 30
1530       IF (INFO(17) .EQ. 0) THEN
1531         IWORK(LMXNIT) = 5
1532         IF (INFO(12) .GT. 0) IWORK(LMXNIT) = 15
1533         IWORK(LMXNJ) = 6
1534         IF (INFO(12) .GT. 0) IWORK(LMXNJ) = 2
1535         IWORK(LMXNH) = 5
1536         IWORK(LLSOFF) = 0
1537         RWORK(LEPIN) = 0.01D0
1538       ELSE
1539         IF (IWORK(LMXNIT) .LE. 0) GO TO 725
1540         IF (IWORK(LMXNJ) .LE. 0) GO TO 725
1541         IF (IWORK(LMXNH) .LE. 0) GO TO 725
1542         LSOFF = IWORK(LLSOFF)
1543         IF (LSOFF .LT. 0 .OR. LSOFF .GT. 1) GO TO 725
1544         IF (RWORK(LEPIN) .LE. 0.0D0) GO TO 725
1545         ENDIF
1546 C
1547  30   CONTINUE
1548 C
1549 C     Below is the computation and checking of the work array lengths
1550 C     LENIW and LENRW, using direct methods (INFO(12) = 0) or
1551 C     the Krylov methods (INFO(12) = 1).
1552 C
1553       LENIC = 0
1554       IF (INFO(10) .EQ. 1 .OR. INFO(10) .EQ. 3) LENIC = NEQ
1555       LENID = 0
1556       IF (INFO(11) .EQ. 1 .OR. INFO(16) .EQ. 1) LENID = NEQ
1557       IF (INFO(12) .EQ. 0) THEN
1558 C
1559 C        Compute MTYPE, etc.  Check ML and MU.
1560 C
1561          NCPHI = MAX(MXORD + 1, 4)
1562          IF(INFO(6).EQ.0) THEN 
1563             LENPD = NEQ**2
1564             LENRW = 60 + 3*NRT + (NCPHI+3)*NEQ + LENPD
1565             IF(INFO(5).EQ.0) THEN
1566                IWORK(LMTYPE)=2
1567             ELSE
1568                IWORK(LMTYPE)=1
1569             ENDIF
1570          ELSE
1571             IF(IWORK(LML).LT.0.OR.IWORK(LML).GE.NEQ)GO TO 717
1572             IF(IWORK(LMU).LT.0.OR.IWORK(LMU).GE.NEQ)GO TO 718
1573             LENPD=(2*IWORK(LML)+IWORK(LMU)+1)*NEQ
1574             IF(INFO(5).EQ.0) THEN
1575                IWORK(LMTYPE)=5
1576                MBAND=IWORK(LML)+IWORK(LMU)+1
1577                MSAVE=(NEQ/MBAND)+1
1578                LENRW = 60 + 3*NRT + (NCPHI+3)*NEQ + LENPD + 2*MSAVE
1579             ELSE
1580                IWORK(LMTYPE)=4
1581                LENRW = 60 + 3*NRT + (NCPHI+3)*NEQ + LENPD
1582             ENDIF
1583          ENDIF
1584 C
1585 C        Compute LENIW, LENWP, LENIWP.
1586 C
1587          LENIW = 40 + LENIC + LENID + NEQ
1588          LENWP = 0
1589          LENIWP = 0
1590 C
1591       ELSE IF (INFO(12) .EQ. 1)  THEN
1592          NCPHI = MXORD + 1
1593          MAXL = IWORK(LMAXL)
1594          LENWP = IWORK(LLNWP)
1595          LENIWP = IWORK(LLNIWP)
1596          LENPD = (MAXL+3+MIN0(1,MAXL-IWORK(LKMP)))*NEQ
1597      1         + (MAXL+3)*MAXL + 1 + LENWP
1598          LENRW = 60 + 3*NRT + (MXORD+5)*NEQ + LENPD
1599          LENIW = 40 + LENIC + LENID + LENIWP
1600 C
1601       ENDIF
1602       IF(INFO(16) .NE. 0) LENRW = LENRW + NEQ
1603 C
1604 C     Check lengths of RWORK and IWORK.
1605 C
1606       IWORK(LNIW)=LENIW
1607       IWORK(LNRW)=LENRW
1608       IWORK(LNPD)=LENPD
1609       IWORK(LLOCWP) = LENPD-LENWP+1
1610       IF(LRW.LT.LENRW)GO TO 704
1611       IF(LIW.LT.LENIW)GO TO 705
1612 C
1613 C     Check ICNSTR for legality.
1614 C
1615       IF (LENIC .GT. 0) THEN
1616         DO 40 I = 1,NEQ
1617           ICI = IWORK(LICNS-1+I)
1618           IF (ICI .LT. -2 .OR. ICI .GT. 2) GO TO 726
1619  40       CONTINUE
1620         ENDIF
1621 C
1622 C     Check Y for consistency with constraints.
1623 C
1624       IF (LENIC .GT. 0) THEN
1625         CALL DCNST0(NEQ,Y,IWORK(LICNS),IRET)
1626         IF (IRET .NE. 0) GO TO 727
1627         ENDIF
1628 C
1629 C     Check ID for legality and set INDEX = 0 or 1.
1630 C
1631       INDEX = 1
1632       IF (LENID .GT. 0) THEN
1633         INDEX = 0
1634         DO 50 I = 1,NEQ
1635           IDI = IWORK(LID-1+I)
1636           IF (IDI .NE. 1 .AND. IDI .NE. -1) GO TO 724
1637           IF (IDI .EQ. -1) INDEX = 1
1638  50       CONTINUE
1639         ENDIF
1640 C
1641 C     Check to see that TOUT is different from T, and NRT .ge. 0.
1642 C
1643       IF(TOUT .EQ. T)GO TO 719
1644       IF(NRT .LT. 0) GO TO 730
1645 C
1646 C     Check HMAX.
1647 C
1648       IF(INFO(7) .NE. 0) THEN
1649          HMAX = RWORK(LHMAX)
1650          IF (HMAX .LE. 0.0D0) GO TO 710
1651          ENDIF
1652 C
1653 C     Initialize counters and other flags.
1654 C
1655       IWORK(LNST)=0
1656       IWORK(LNRE)=0
1657       IWORK(LNJE)=0
1658       IWORK(LETF)=0
1659       IWORK(LNCFN)=0
1660       IWORK(LNNI)=0
1661       IWORK(LNLI)=0
1662       IWORK(LNPS)=0
1663       IWORK(LNCFL)=0
1664       IWORK(LNRTE)=0
1665       IWORK(LKPRIN)=INFO(18)
1666       IDID=1
1667       GO TO 200
1668 C
1669 C-----------------------------------------------------------------------
1670 C     This block is for continuation calls only.
1671 C     Here we check INFO(1), and if the last step was interrupted,
1672 C     we check whether appropriate action was taken.
1673 C-----------------------------------------------------------------------
1674 C
1675 100   CONTINUE
1676       IF(INFO(1).EQ.1)GO TO 110
1677       ITEMP = 1
1678       IF(INFO(1).NE.-1)GO TO 701
1679 C
1680 C     If we are here, the last step was interrupted by an error
1681 C     condition from DDSTP, and appropriate action was not taken.
1682 C     This is a fatal error.
1683 C
1684       MSG = 'DASKR--  THE LAST STEP TERMINATED WITH A NEGATIVE'
1685       CALL XERRWD(MSG,49,201,0,0,0,0,0,0.0D0,0.0D0)
1686       MSG = 'DASKR--  VALUE (=I1) OF IDID AND NO APPROPRIATE'
1687       CALL XERRWD(MSG,47,202,0,1,IDID,0,0,0.0D0,0.0D0)
1688       MSG = 'DASKR--  ACTION WAS TAKEN. RUN TERMINATED'
1689       CALL XERRWD(MSG,41,203,1,0,0,0,0,0.0D0,0.0D0)
1690       RETURN
1691 110   CONTINUE
1692 C
1693 C-----------------------------------------------------------------------
1694 C     This block is executed on all calls.
1695 C
1696 C     Counters are saved for later checks of performance.
1697 C     Then the error tolerance parameters are checked, and the
1698 C     work array pointers are set.
1699 C-----------------------------------------------------------------------
1700 C
1701 200   CONTINUE
1702 C
1703 C     Save counters for use later.
1704 C
1705       IWORK(LNSTL)=IWORK(LNST)
1706       NLI0 = IWORK(LNLI)
1707       NNI0 = IWORK(LNNI)
1708       NCFN0 = IWORK(LNCFN)
1709       NCFL0 = IWORK(LNCFL)
1710       NWARN = 0
1711 C
1712 C     Check RTOL and ATOL.
1713 C
1714       NZFLG = 0
1715       RTOLI = RTOL(1)
1716       ATOLI = ATOL(1)
1717       DO 210 I=1,NEQ
1718          IF (INFO(2) .EQ. 1) RTOLI = RTOL(I)
1719          IF (INFO(2) .EQ. 1) ATOLI = ATOL(I)
1720          IF (RTOLI .GT. 0.0D0 .OR. ATOLI .GT. 0.0D0) NZFLG = 1
1721          IF (RTOLI .LT. 0.0D0) GO TO 706
1722          IF (ATOLI .LT. 0.0D0) GO TO 707
1723 210      CONTINUE
1724       IF (NZFLG .EQ. 0) GO TO 708
1725 C
1726 C     Set pointers to RWORK and IWORK segments.
1727 C     For direct methods, SAVR is not used.
1728 C
1729       IWORK(LLCIWP) = LID + LENID
1730       LSAVR = LDELTA
1731       IF (INFO(12) .NE. 0) LSAVR = LDELTA + NEQ
1732       LE = LSAVR + NEQ
1733       LWT = LE + NEQ
1734       LVT = LWT
1735       IF (INFO(16) .NE. 0) LVT = LWT + NEQ
1736       LPHI = LVT + NEQ
1737       LR0 = LPHI + NCPHI*NEQ
1738       LR1 = LR0 + NRT
1739       LRX = LR1 + NRT
1740       LWM = LRX + NRT
1741       IF (INFO(1) .EQ. 1) GO TO 400
1742 C
1743 C-----------------------------------------------------------------------
1744 C     This block is executed on the initial call only.
1745 C     Set the initial step size, the error weight vector, and PHI.
1746 C     Compute unknown initial components of Y and YPRIME, if requested.
1747 C-----------------------------------------------------------------------
1748 C
1749 300   CONTINUE
1750       TN=T
1751       IDID=1
1752 C
1753 C     Set error weight array WT and altered weight array VT.
1754 C
1755       CALL DDAWTS2(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR)
1756       CALL DINVWT(NEQ,RWORK(LWT),IER)
1757       IF (IER .NE. 0) GO TO 713
1758       IF (INFO(16) .NE. 0) THEN
1759         DO 305 I = 1, NEQ
1760  305      RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1)
1761         ENDIF
1762 C
1763 C     Compute unit roundoff and HMIN.
1764 C
1765       UROUND = D1MACH2(4)
1766       RWORK(LROUND) = UROUND
1767       HMIN = 4.0D0*UROUND*MAX(ABS(T),ABS(TOUT))
1768 C
1769 C     Set/check STPTOL control for initial condition calculation.
1770 C     
1771       IF (INFO(11) .NE. 0) THEN
1772         IF( INFO(17) .EQ. 0) THEN
1773           RWORK(LSTOL) = UROUND**.6667D0
1774         ELSE
1775           IF (RWORK(LSTOL) .LE. 0.0D0) GO TO 725
1776           ENDIF
1777         ENDIF
1778 C
1779 C     Compute EPCON and square root of NEQ and its reciprocal, used
1780 C     inside iterative solver.
1781 C
1782       RWORK(LEPCON) = 0.33D0
1783       FLOATN = NEQ
1784       RWORK(LSQRN) = SQRT(FLOATN)
1785       RWORK(LRSQRN) = 1.D0/RWORK(LSQRN)
1786 C
1787 C     Check initial interval to see that it is long enough.
1788 C
1789       TDIST = ABS(TOUT - T)
1790       IF(TDIST .LT. HMIN) GO TO 714
1791 C
1792 C     Check H0, if this was input.
1793 C
1794       IF (INFO(8) .EQ. 0) GO TO 310
1795          H0 = RWORK(LH)
1796          IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 711
1797          IF (H0 .EQ. 0.0D0) GO TO 712
1798          GO TO 320
1799 310    CONTINUE
1800 C
1801 C     Compute initial stepsize, to be used by either
1802 C     DDSTP or DDASIC, depending on INFO(11).
1803 C
1804       H0 = 0.001D0*TDIST
1805       YPNORM = DDWNRM(NEQ,YPRIME,RWORK(LVT),RPAR,IPAR)
1806       IF (YPNORM .GT. 0.5D0/H0) H0 = 0.5D0/YPNORM
1807       H0 = SIGN(H0,TOUT-T)
1808 C
1809 C     Adjust H0 if necessary to meet HMAX bound.
1810 C
1811 320   IF (INFO(7) .EQ. 0) GO TO 330
1812          RH = ABS(H0)/RWORK(LHMAX)
1813          IF (RH .GT. 1.0D0) H0 = H0/RH
1814 C
1815 C     Check against TSTOP, if applicable.
1816 C
1817 330   IF (INFO(4) .EQ. 0) GO TO 340
1818          TSTOP = RWORK(LTSTOP)
1819          IF ((TSTOP - T)*H0 .LT. 0.0D0) GO TO 715
1820          IF ((T + H0 - TSTOP)*H0 .GT. 0.0D0) H0 = TSTOP - T
1821          IF ((TSTOP - TOUT)*H0 .LT. 0.0D0) GO TO 709
1822 C
1823 340   IF (INFO(11) .EQ. 0) GO TO 370
1824 C
1825 C     Compute unknown components of initial Y and YPRIME, depending
1826 C     on INFO(11) and INFO(12).  INFO(12) represents the nonlinear
1827 C     solver type (direct/Krylov).  Pass the name of the specific 
1828 C     nonlinear solver, depending on INFO(12).  The location of the work
1829 C     arrays SAVR, YIC, YPIC, PWK also differ in the two cases.
1830 C     For use in stopping tests, pass TSCALE = TDIST if INDEX = 0.
1831 C
1832       NWT = 1
1833       EPCONI = RWORK(LEPIN)*RWORK(LEPCON)
1834       TSCALE = 0.0D0
1835       IF (INDEX .EQ. 0) TSCALE = TDIST
1836 350   IF (INFO(12) .EQ. 0) THEN
1837          LYIC = LPHI + 2*NEQ
1838          LYPIC = LYIC + NEQ
1839          LPWK = LYPIC
1840          CALL DDASIC(TN,Y,YPRIME,NEQ,INFO(11),IWORK(LID),
1841      *     RES,JAC,PSOL,H0,TSCALE,RWORK(LWT),NWT,IDID,RPAR,IPAR,
1842      *     RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE),
1843      *     RWORK(LYIC),RWORK(LYPIC),RWORK(LPWK),RWORK(LWM),IWORK(LIWM),
1844      *     RWORK(LROUND),RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN),
1845      *     EPCONI,RWORK(LSTOL),INFO(15),ICNFLG,IWORK(LICNS),DDASID)
1846       ELSE IF (INFO(12) .EQ. 1) THEN
1847          LYIC = LWM
1848          LYPIC = LYIC + NEQ
1849          LPWK = LYPIC + NEQ
1850          CALL DDASIC(TN,Y,YPRIME,NEQ,INFO(11),IWORK(LID),
1851      *     RES,JAC,PSOL,H0,TSCALE,RWORK(LWT),NWT,IDID,RPAR,IPAR,
1852      *     RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE),
1853      *     RWORK(LYIC),RWORK(LYPIC),RWORK(LPWK),RWORK(LWM),IWORK(LIWM),
1854      *     RWORK(LROUND),RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN),
1855      *     EPCONI,RWORK(LSTOL),INFO(15),ICNFLG,IWORK(LICNS),DDASIK)
1856       ENDIF
1857 C
1858       IF (IDID .LT. 0) GO TO 600
1859 C
1860 C     DDASIC was successful.  If this was the first call to DDASIC,
1861 C     update the WT array (with the current Y) and call it again.
1862 C
1863       IF (NWT .EQ. 2) GO TO 355
1864       NWT = 2
1865       CALL DDAWTS2(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR)
1866       CALL DINVWT(NEQ,RWORK(LWT),IER)
1867       IF (IER .NE. 0) GO TO 713
1868       GO TO 350
1869 C
1870 C     If INFO(14) = 1, return now with IDID = 4.
1871 C
1872 355   IF (INFO(14) .EQ. 1) THEN
1873         IDID = 4
1874         H = H0
1875         IF (INFO(11) .EQ. 1) RWORK(LHOLD) = H0
1876         GO TO 590
1877       ENDIF
1878 C
1879 C     Update the WT and VT arrays one more time, with the new Y.
1880 C
1881       CALL DDAWTS2(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR)
1882       CALL DINVWT(NEQ,RWORK(LWT),IER)
1883       IF (IER .NE. 0) GO TO 713
1884       IF (INFO(16) .NE. 0) THEN
1885         DO 357 I = 1, NEQ
1886  357      RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1)
1887         ENDIF
1888 C
1889 C     Reset the initial stepsize to be used by DDSTP.
1890 C     Use H0, if this was input.  Otherwise, recompute H0,
1891 C     and adjust it if necessary to meet HMAX bound.
1892 C
1893       IF (INFO(8) .NE. 0) THEN
1894          H0 = RWORK(LH)
1895          GO TO 360
1896          ENDIF
1897 C
1898       H0 = 0.001D0*TDIST
1899       YPNORM = DDWNRM(NEQ,YPRIME,RWORK(LVT),RPAR,IPAR)
1900       IF (YPNORM .GT. 0.5D0/H0) H0 = 0.5D0/YPNORM
1901       H0 = SIGN(H0,TOUT-T)
1902 C
1903 360   IF (INFO(7) .NE. 0) THEN
1904          RH = ABS(H0)/RWORK(LHMAX)
1905          IF (RH .GT. 1.0D0) H0 = H0/RH
1906          ENDIF
1907 C
1908 C     Check against TSTOP, if applicable.
1909 C
1910       IF (INFO(4) .NE. 0) THEN
1911          TSTOP = RWORK(LTSTOP)
1912          IF ((T + H0 - TSTOP)*H0 .GT. 0.0D0) H0 = TSTOP - T
1913          ENDIF
1914 C
1915 C     Load H and RWORK(LH) with H0.
1916 C
1917 370   H = H0
1918       RWORK(LH) = H
1919 C
1920 C     Load Y and H*YPRIME into PHI(*,1) and PHI(*,2).
1921 C
1922       ITEMP = LPHI + NEQ
1923       DO 380 I = 1,NEQ
1924          RWORK(LPHI + I - 1) = Y(I)
1925 380      RWORK(ITEMP + I - 1) = H*YPRIME(I)
1926 C
1927 C     Initialize T0 in RWORK; check for a zero of R near initial T.
1928 C
1929       RWORK(LT0) = T
1930       IWORK(LIRFND) = 0
1931       RWORK(LPSI)=H
1932       RWORK(LPSI+1)=2.0D0*H
1933       IWORK(LKOLD)=1
1934       IF (NRT .EQ. 0) GO TO 390
1935       CALL DRCHEK2(1,RT,NRT,NEQ,T,TOUT,Y,YPRIME,RWORK(LPHI),
1936      *   RWORK(LPSI),IWORK(LKOLD),RWORK(LR0),RWORK(LR1),
1937      *   RWORK(LRX),JROOT,IRT,RWORK(LROUND),INFO(3),
1938      *   RWORK,IWORK,RPAR,IPAR)
1939       IF (IRT .LT. 0) GO TO 731
1940 C
1941  390  GO TO 500
1942 C
1943 C-----------------------------------------------------------------------
1944 C     This block is for continuation calls only.
1945 C     Its purpose is to check stop conditions before taking a step.
1946 C     Adjust H if necessary to meet HMAX bound.
1947 C-----------------------------------------------------------------------
1948 C
1949 400   CONTINUE
1950       UROUND=RWORK(LROUND)
1951       DONE = .FALSE.
1952       TN=RWORK(LTN)
1953       H=RWORK(LH)
1954       IF(NRT .EQ. 0) GO TO 405
1955 C
1956 C     Check for a zero of R near TN.
1957 C
1958       CALL DRCHEK2(2,RT,NRT,NEQ,TN,TOUT,Y,YPRIME,RWORK(LPHI),
1959      *   RWORK(LPSI),IWORK(LKOLD),RWORK(LR0),RWORK(LR1),
1960      *   RWORK(LRX),JROOT,IRT,RWORK(LROUND),INFO(3),
1961      *   RWORK,IWORK,RPAR,IPAR)
1962       IF (IRT .LT. 0) GO TO 731
1963 c*****SCILAB ENTERPRISES INPUT
1964 c**** IRT = 2 corresponds to a ZERO_DETACH return.
1965       IF (IRT .NE. 1 .AND. IRT .NE. 2) GO TO 405
1966       IWORK(LIRFND) = 1
1967       IF (IRT .EQ. 1) IDID = 5
1968       IF (IRT .EQ. 2) IDID = 6
1969 c*****
1970       T = RWORK(LT0)
1971       DONE = .TRUE.
1972       GO TO 490
1973 405   CONTINUE
1974 C
1975       IF(INFO(7) .EQ. 0) GO TO 410
1976          RH = ABS(H)/RWORK(LHMAX)
1977          IF(RH .GT. 1.0D0) H = H/RH
1978 410   CONTINUE
1979       IF(T .EQ. TOUT) GO TO 719
1980       IF((T - TOUT)*H .GT. 0.0D0) GO TO 711
1981       IF(INFO(4) .EQ. 1) GO TO 430
1982       IF(INFO(3) .EQ. 1) GO TO 420
1983       IF((TN-TOUT)*H.LT.0.0D0)GO TO 490
1984       CALL DDATRP2(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
1985      *  RWORK(LPHI),RWORK(LPSI))
1986       T=TOUT
1987       IDID = 3
1988       DONE = .TRUE.
1989       GO TO 490
1990 420   IF((TN-T)*H .LE. 0.0D0) GO TO 490
1991       IF((TN - TOUT)*H .GE. 0.0D0) GO TO 425
1992       CALL DDATRP2(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD),
1993      *  RWORK(LPHI),RWORK(LPSI))
1994       T = TN
1995       IDID = 1
1996       DONE = .TRUE.
1997       GO TO 490
1998 425   CONTINUE
1999       CALL DDATRP2(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
2000      *  RWORK(LPHI),RWORK(LPSI))
2001       T = TOUT
2002       IDID = 3
2003       DONE = .TRUE.
2004       GO TO 490
2005 430   IF(INFO(3) .EQ. 1) GO TO 440
2006       TSTOP=RWORK(LTSTOP)
2007       IF((TN-TSTOP)*H.GT.0.0D0) GO TO 715
2008       IF((TSTOP-TOUT)*H.LT.0.0D0)GO TO 709
2009       IF((TN-TOUT)*H.LT.0.0D0)GO TO 450
2010       CALL DDATRP2(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
2011      *   RWORK(LPHI),RWORK(LPSI))
2012       T=TOUT
2013       IDID = 3
2014       DONE = .TRUE.
2015       GO TO 490
2016 440   TSTOP = RWORK(LTSTOP)
2017       IF((TN-TSTOP)*H .GT. 0.0D0) GO TO 715
2018       IF((TSTOP-TOUT)*H .LT. 0.0D0) GO TO 709
2019       IF((TN-T)*H .LE. 0.0D0) GO TO 450
2020       IF((TN - TOUT)*H .GE. 0.0D0) GO TO 445
2021       CALL DDATRP2(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD),
2022      *  RWORK(LPHI),RWORK(LPSI))
2023       T = TN
2024       IDID = 1
2025       DONE = .TRUE.
2026       GO TO 490
2027 445   CONTINUE
2028       CALL DDATRP2(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
2029      *  RWORK(LPHI),RWORK(LPSI))
2030       T = TOUT
2031       IDID = 3
2032       DONE = .TRUE.
2033       GO TO 490
2034 450   CONTINUE
2035 C
2036 C     Check whether we are within roundoff of TSTOP.
2037 C
2038       IF(ABS(TN-TSTOP).GT.100.0D0*UROUND*
2039      *   (ABS(TN)+ABS(H)))GO TO 460
2040       CALL DDATRP2(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD),
2041      *  RWORK(LPHI),RWORK(LPSI))
2042       IDID=2
2043       T=TSTOP
2044       DONE = .TRUE.
2045       GO TO 490
2046 460   TNEXT=TN+H
2047       IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 490
2048       H=TSTOP-TN
2049       RWORK(LH)=H
2050 C
2051 490   IF (DONE) GO TO 590
2052 C
2053 C-----------------------------------------------------------------------
2054 C     The next block contains the call to the one-step integrator DDSTP.
2055 C     This is a looping point for the integration steps.
2056 C     Check for too many steps.
2057 C     Check for poor Newton/Krylov performance.
2058 C     Update WT.  Check for too much accuracy requested.
2059 C     Compute minimum stepsize.
2060 C-----------------------------------------------------------------------
2061 C
2062 500   CONTINUE
2063 C
2064 C     Check for too many steps.
2065 C
2066       IF((IWORK(LNST)-IWORK(LNSTL)).LT.500) GO TO 505
2067            IDID=-1
2068            GO TO 527
2069 C
2070 C Check for poor Newton/Krylov performance.
2071 C
2072 505   IF (INFO(12) .EQ. 0) GO TO 510
2073       NSTD = IWORK(LNST) - IWORK(LNSTL)
2074       NNID = IWORK(LNNI) - NNI0
2075       IF (NSTD .LT. 10 .OR. NNID .EQ. 0) GO TO 510
2076       AVLIN = REAL(IWORK(LNLI) - NLI0)/REAL(NNID)
2077       RCFN = REAL(IWORK(LNCFN) - NCFN0)/REAL(NSTD)
2078       RCFL = REAL(IWORK(LNCFL) - NCFL0)/REAL(NNID)
2079       FMAXL = IWORK(LMAXL)
2080       LAVL = AVLIN .GT. FMAXL
2081       LCFN = RCFN .GT. 0.9D0
2082       LCFL = RCFL .GT. 0.9D0
2083       LWARN = LAVL .OR. LCFN .OR. LCFL
2084       IF (.NOT.LWARN) GO TO 510
2085       NWARN = NWARN + 1
2086       IF (NWARN .GT. 10) GO TO 510
2087       IF (LAVL) THEN
2088         MSG = 'DASKR-- Warning. Poor iterative algorithm performance   '
2089         CALL XERRWD (MSG, 56, 501, 0, 0, 0, 0, 0, 0.0D0, 0.0D0)
2090         MSG = '      at T = R1. Average no. of linear iterations = R2  '
2091         CALL XERRWD (MSG, 56, 501, 0, 0, 0, 0, 2, TN, AVLIN)
2092         ENDIF
2093       IF (LCFN) THEN
2094         MSG = 'DASKR-- Warning. Poor iterative algorithm performance   '
2095         CALL XERRWD (MSG, 56, 502, 0, 0, 0, 0, 0, 0.0D0, 0.0D0)
2096         MSG = '      at T = R1. Nonlinear convergence failure rate = R2'
2097         CALL XERRWD (MSG, 56, 502, 0, 0, 0, 0, 2, TN, RCFN)
2098         ENDIF
2099       IF (LCFL) THEN
2100         MSG = 'DASKR-- Warning. Poor iterative algorithm performance   '
2101         CALL XERRWD (MSG, 56, 503, 0, 0, 0, 0, 0, 0.0D0, 0.0D0)
2102         MSG = '      at T = R1. Linear convergence failure rate = R2   '
2103         CALL XERRWD (MSG, 56, 503, 0, 0, 0, 0, 2, TN, RCFL)
2104         ENDIF
2105 C
2106 C     Update WT and VT, if this is not the first call.
2107 C
2108 510   CALL DDAWTS2(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI),RWORK(LWT),
2109      *            RPAR,IPAR)
2110       CALL DINVWT(NEQ,RWORK(LWT),IER)
2111       IF (IER .NE. 0) THEN
2112         IDID = -3
2113         GO TO 527
2114         ENDIF
2115       IF (INFO(16) .NE. 0) THEN
2116         DO 515 I = 1, NEQ
2117  515      RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1)
2118         ENDIF
2119 C
2120 C     Test for too much accuracy requested.
2121 C
2122       R = DDWNRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)*100.0D0*UROUND
2123       IF (R .LE. 1.0D0) GO TO 525
2124 C
2125 C     Multiply RTOL and ATOL by R and return.
2126 C
2127       IF(INFO(2).EQ.1)GO TO 523
2128            RTOL(1)=R*RTOL(1)
2129            ATOL(1)=R*ATOL(1)
2130            IDID=-2
2131            GO TO 527
2132 523   DO 524 I=1,NEQ
2133            RTOL(I)=R*RTOL(I)
2134 524        ATOL(I)=R*ATOL(I)
2135       IDID=-2
2136       GO TO 527
2137 525   CONTINUE
2138 C
2139 C     Compute minimum stepsize.
2140 C
2141       HMIN=4.0D0*UROUND*MAX(ABS(TN),ABS(TOUT))
2142 C
2143 C     Test H vs. HMAX
2144       IF (INFO(7) .NE. 0) THEN
2145          RH = ABS(H)/RWORK(LHMAX)
2146          IF (RH .GT. 1.0D0) H = H/RH
2147          ENDIF
2148 C
2149 C     Call the one-step integrator.
2150 C     Note that INFO(12) represents the nonlinear solver type.
2151 C     Pass the required nonlinear solver, depending upon INFO(12).
2152 C
2153       IF (INFO(12) .EQ. 0) THEN
2154          CALL DDSTP(TN,Y,YPRIME,NEQ,
2155      *      RES,JAC,PSOL,H,RWORK(LWT),RWORK(LVT),INFO(1),IDID,RPAR,IPAR,
2156      *      RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE),
2157      *      RWORK(LWM),IWORK(LIWM),
2158      *      RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA),
2159      *      RWORK(LPSI),RWORK(LSIGMA),
2160      *      RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD),RWORK(LS),HMIN,
2161      *      RWORK(LROUND), RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN),
2162      *      RWORK(LEPCON), IWORK(LPHASE),IWORK(LJCALC),INFO(15),
2163      *      IWORK(LK), IWORK(LKOLD),IWORK(LNS),NONNEG,INFO(12),
2164      *      DNEDD)
2165       ELSE IF (INFO(12) .EQ. 1) THEN
2166          CALL DDSTP(TN,Y,YPRIME,NEQ,
2167      *      RES,JAC,PSOL,H,RWORK(LWT),RWORK(LVT),INFO(1),IDID,RPAR,IPAR,
2168      *      RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE),
2169      *      RWORK(LWM),IWORK(LIWM),
2170      *      RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA),
2171      *      RWORK(LPSI),RWORK(LSIGMA),
2172      *      RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD),RWORK(LS),HMIN,
2173      *      RWORK(LROUND), RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN),
2174      *      RWORK(LEPCON), IWORK(LPHASE),IWORK(LJCALC),INFO(15),
2175      *      IWORK(LK), IWORK(LKOLD),IWORK(LNS),NONNEG,INFO(12),
2176      *      DNEDK)
2177       ENDIF
2178 C
2179 527   IF(IDID.LT.0)GO TO 600
2180 C
2181 C-----------------------------------------------------------------------
2182 C     This block handles the case of a successful return from DDSTP
2183 C     (IDID=1).  Test for stop conditions.
2184 C-----------------------------------------------------------------------
2185 C
2186       IF(NRT .EQ. 0) GO TO 530
2187 C
2188 C     Check for a zero of R near TN.
2189 C
2190       CALL DRCHEK2(3,RT,NRT,NEQ,TN,TOUT,Y,YPRIME,RWORK(LPHI),
2191      *   RWORK(LPSI),IWORK(LKOLD),RWORK(LR0),RWORK(LR1),
2192      *   RWORK(LRX),JROOT,IRT,RWORK(LROUND),INFO(3),
2193      *   RWORK,IWORK,RPAR,IPAR)
2194       IF (IRT .NE. 1 .AND. IRT .NE. 2) GO TO 530
2195       IWORK(LIRFND) = 1
2196 c*****SCILAB ENTERPRISES INPUT
2197 c**** IRT = 2 corresponds to a ZERO_DETACH return.
2198       IF (IRT .EQ. 1) IDID = 5
2199       IF (IRT .EQ. 2) IDID = 6
2200 c*****
2201       T = RWORK(LT0)
2202       GO TO 580
2203 C
2204 530   IF (INFO(4) .EQ. 0) THEN
2205 C        Stopping tests for the case of no TSTOP. ----------------------
2206          IF ( (TN-TOUT)*H .GE. 0.0D0) THEN
2207             CALL DDATRP2(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
2208      *                  RWORK(LPHI),RWORK(LPSI))
2209             T = TOUT
2210             IDID = 3
2211             GO TO 580
2212             ENDIF
2213          IF (INFO(3) .EQ. 0) GO TO 500
2214          T = TN
2215          IDID = 1
2216          GO TO 580
2217          ENDIF
2218 C
2219 540   IF (INFO(3) .NE. 0) GO TO 550
2220 C     Stopping tests for the TSTOP case, interval-output mode. ---------
2221       IF (ABS(TN-TSTOP) .LE. 100.0D0*UROUND*(ABS(TN)+ABS(H))) THEN
2222          CALL DDATRP2(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD),
2223      *               RWORK(LPHI),RWORK(LPSI))
2224          T = TSTOP
2225          IDID = 2
2226          GO TO 580
2227          ENDIF
2228       IF ( (TN-TOUT)*H .GE. 0.0D0) THEN
2229          CALL DDATRP2(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
2230      *               RWORK(LPHI),RWORK(LPSI))
2231          T = TOUT
2232          IDID = 3
2233          GO TO 580
2234          ENDIF
2235       TNEXT = TN + H
2236       IF ((TNEXT-TSTOP)*H .LE. 0.0D0) GO TO 500
2237       H = TSTOP - TN
2238       GO TO 500
2239 C
2240 550   CONTINUE
2241 C     Stopping tests for the TSTOP case, intermediate-output mode. -----
2242       IF (ABS(TN-TSTOP) .LE. 100.0D0*UROUND*(ABS(TN)+ABS(H))) THEN
2243          CALL DDATRP2(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD),
2244      *               RWORK(LPHI),RWORK(LPSI))
2245          T = TSTOP
2246          IDID = 2
2247          GO TO 580
2248          ENDIF
2249       IF ( (TN-TOUT)*H .GE. 0.0D0) THEN
2250          CALL DDATRP2(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
2251      *               RWORK(LPHI),RWORK(LPSI))
2252          T = TOUT
2253          IDID = 3
2254          GO TO 580
2255          ENDIF
2256       T = TN
2257       IDID = 1
2258 C
2259 580   CONTINUE
2260 C
2261 C-----------------------------------------------------------------------
2262 C     All successful returns from DDASKR are made from this block.
2263 C-----------------------------------------------------------------------
2264 C
2265 590   CONTINUE
2266       RWORK(LTN)=TN
2267       RWORK(LTLAST)=T
2268       RWORK(LH)=H
2269       RETURN
2270 C
2271 C-----------------------------------------------------------------------
2272 C     This block handles all unsuccessful returns other than for
2273 C     illegal input.
2274 C-----------------------------------------------------------------------
2275 C
2276 600   CONTINUE
2277       ITEMP = -IDID
2278       GO TO (610,620,630,700,655,640,650,660,670,675,
2279      *  680,685,690,695), ITEMP
2280 C
2281 C     The maximum number of steps was taken before
2282 C     reaching tout.
2283 C
2284 610   MSG = 'DASKR--  AT CURRENT T (=R1)  500 STEPS'
2285       CALL XERRWD(MSG,38,610,0,0,0,0,1,TN,0.0D0)
2286       MSG = 'DASKR--  TAKEN ON THIS CALL BEFORE REACHING TOUT'
2287       CALL XERRWD(MSG,48,611,0,0,0,0,0,0.0D0,0.0D0)
2288       GO TO 700
2289 C
2290 C     Too much accuracy for machine precision.
2291 C
2292 620   MSG = 'DASKR--  AT T (=R1) TOO MUCH ACCURACY REQUESTED'
2293       CALL XERRWD(MSG,47,620,0,0,0,0,1,TN,0.0D0)
2294       MSG = 'DASKR--  FOR PRECISION OF MACHINE. RTOL AND ATOL'
2295       CALL XERRWD(MSG,48,621,0,0,0,0,0,0.0D0,0.0D0)
2296       MSG = 'DASKR--  WERE INCREASED BY A FACTOR R (=R1)'
2297       CALL XERRWD(MSG,43,622,0,0,0,0,1,R,0.0D0)
2298       GO TO 700
2299 C
2300 C     WT(I) .LE. 0.0D0 for some I (not at start of problem).
2301 C
2302 630   MSG = 'DASKR--  AT T (=R1) SOME ELEMENT OF WT'
2303       CALL XERRWD(MSG,38,630,0,0,0,0,1,TN,0.0D0)
2304       MSG = 'DASKR--  HAS BECOME .LE. 0.0'
2305       CALL XERRWD(MSG,28,631,0,0,0,0,0,0.0D0,0.0D0)
2306       GO TO 700
2307 C
2308 C     Error test failed repeatedly or with H=HMIN.
2309 C
2310 640   MSG = 'DASKR--  AT T (=R1) AND STEPSIZE H (=R2) THE'
2311       CALL XERRWD(MSG,44,640,0,0,0,0,2,TN,H)
2312       MSG='DASKR--  ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN'
2313       CALL XERRWD(MSG,57,641,0,0,0,0,0,0.0D0,0.0D0)
2314       GO TO 700
2315 C
2316 C     Nonlinear solver failed to converge repeatedly or with H=HMIN.
2317 C
2318 650   MSG = 'DASKR--  AT T (=R1) AND STEPSIZE H (=R2) THE'
2319       CALL XERRWD(MSG,44,650,0,0,0,0,2,TN,H)
2320       MSG = 'DASKR--  NONLINEAR SOLVER FAILED TO CONVERGE'
2321       CALL XERRWD(MSG,44,651,0,0,0,0,0,0.0D0,0.0D0)
2322       MSG = 'DASKR--  REPEATEDLY OR WITH ABS(H)=HMIN'
2323       CALL XERRWD(MSG,40,652,0,0,0,0,0,0.0D0,0.0D0)
2324       GO TO 700
2325 C
2326 C     The preconditioner had repeated failures.
2327 C
2328 655   MSG = 'DASKR--  AT T (=R1) AND STEPSIZE H (=R2) THE'
2329       CALL XERRWD(MSG,44,655,0,0,0,0,2,TN,H)
2330       MSG = 'DASKR--  PRECONDITIONER HAD REPEATED FAILURES.'
2331       CALL XERRWD(MSG,46,656,0,0,0,0,0,0.0D0,0.0D0)
2332       GO TO 700
2333 C
2334 C     The iteration matrix is singular.
2335 C
2336 660   MSG = 'DASKR--  AT T (=R1) AND STEPSIZE H (=R2) THE'
2337       CALL XERRWD(MSG,44,660,0,0,0,0,2,TN,H)
2338       MSG = 'DASKR--  ITERATION MATRIX IS SINGULAR.'
2339       CALL XERRWD(MSG,38,661,0,0,0,0,0,0.0D0,0.0D0)
2340       GO TO 700
2341 C
2342 C     Nonlinear system failure preceded by error test failures.
2343 C
2344 670   MSG = 'DASKR--  AT T (=R1) AND STEPSIZE H (=R2) THE'
2345       CALL XERRWD(MSG,44,670,0,0,0,0,2,TN,H)
2346       MSG = 'DASKR--  NONLINEAR SOLVER COULD NOT CONVERGE.'
2347       CALL XERRWD(MSG,45,671,0,0,0,0,0,0.0D0,0.0D0)
2348       MSG = 'DASKR--  ALSO, THE ERROR TEST FAILED REPEATEDLY.'
2349       CALL XERRWD(MSG,49,672,0,0,0,0,0,0.0D0,0.0D0)
2350       GO TO 700
2351 C
2352 C     Nonlinear system failure because IRES = -1.
2353 C
2354 675   MSG = 'DASKR--  AT T (=R1) AND STEPSIZE H (=R2) THE'
2355       CALL XERRWD(MSG,44,675,0,0,0,0,2,TN,H)
2356       MSG = 'DASKR--  NONLINEAR SYSTEM SOLVER COULD NOT CONVERGE'
2357       CALL XERRWD(MSG,51,676,0,0,0,0,0,0.0D0,0.0D0)
2358       MSG = 'DASKR--  BECAUSE IRES WAS EQUAL TO MINUS ONE'
2359       CALL XERRWD(MSG,44,677,0,0,0,0,0,0.0D0,0.0D0)
2360       GO TO 700
2361 C
2362 C     Failure because IRES = -2.
2363 C
2364 680   MSG = 'DASKR--  AT T (=R1) AND STEPSIZE H (=R2)'
2365       CALL XERRWD(MSG,40,680,0,0,0,0,2,TN,H)
2366       MSG = 'DASKR--  IRES WAS EQUAL TO MINUS TWO'
2367       CALL XERRWD(MSG,36,681,0,0,0,0,0,0.0D0,0.0D0)
2368       GO TO 700
2369 C
2370 C     Failed to compute initial YPRIME.
2371 C
2372 685   MSG = 'DASKR--  AT T (=R1) AND STEPSIZE H (=R2) THE'
2373       CALL XERRWD(MSG,44,685,0,0,0,0,0,0.0D0,0.0D0)
2374       MSG = 'DASKR--  INITIAL (Y,YPRIME) COULD NOT BE COMPUTED'
2375       CALL XERRWD(MSG,49,686,0,0,0,0,2,TN,H0)
2376       GO TO 700
2377 C
2378 C     Failure because IER was negative from PSOL.
2379 C
2380 690   MSG = 'DASKR--  AT T (=R1) AND STEPSIZE H (=R2)'
2381       CALL XERRWD(MSG,40,690,0,0,0,0,2,TN,H)
2382       MSG = 'DASKR--  IER WAS NEGATIVE FROM PSOL'
2383       CALL XERRWD(MSG,35,691,0,0,0,0,0,0.0D0,0.0D0)
2384       GO TO 700
2385 C
2386 C     Failure because the linear system solver could not converge.
2387 C
2388 695   MSG = 'DASKR--  AT T (=R1) AND STEPSIZE H (=R2) THE'
2389       CALL XERRWD(MSG,44,695,0,0,0,0,2,TN,H)
2390       MSG = 'DASKR--  LINEAR SYSTEM SOLVER COULD NOT CONVERGE.'
2391       CALL XERRWD(MSG,50,696,0,0,0,0,0,0.0D0,0.0D0)
2392       GO TO 700
2393 C
2394 C
2395 700   CONTINUE
2396       INFO(1)=-1
2397       T=TN
2398       RWORK(LTN)=TN
2399       RWORK(LH)=H
2400       RETURN
2401 C
2402 C-----------------------------------------------------------------------
2403 C     This block handles all error returns due to illegal input,
2404 C     as detected before calling DDSTP.
2405 C     First the error message routine is called.  If this happens
2406 C     twice in succession, execution is terminated.
2407 C-----------------------------------------------------------------------
2408 C
2409 701   MSG = 'DASKR--  ELEMENT (=I1) OF INFO VECTOR IS NOT VALID'
2410       CALL XERRWD(MSG,50,1,0,1,ITEMP,0,0,0.0D0,0.0D0)
2411       GO TO 750
2412 702   MSG = 'DASKR--  NEQ (=I1) .LE. 0'
2413       CALL XERRWD(MSG,25,2,0,1,NEQ,0,0,0.0D0,0.0D0)
2414       GO TO 750
2415 703   MSG = 'DASKR--  MAXORD (=I1) NOT IN RANGE'
2416       CALL XERRWD(MSG,34,3,0,1,MXORD,0,0,0.0D0,0.0D0)
2417       GO TO 750
2418 704   MSG='DASKR--  RWORK LENGTH NEEDED, LENRW (=I1), EXCEEDS LRW (=I2)'
2419       CALL XERRWD(MSG,60,4,0,2,LENRW,LRW,0,0.0D0,0.0D0)
2420       GO TO 750
2421 705   MSG='DASKR--  IWORK LENGTH NEEDED, LENIW (=I1), EXCEEDS LIW (=I2)'
2422       CALL XERRWD(MSG,60,5,0,2,LENIW,LIW,0,0.0D0,0.0D0)
2423       GO TO 750
2424 706   MSG = 'DASKR--  SOME ELEMENT OF RTOL IS .LT. 0'
2425       CALL XERRWD(MSG,39,6,0,0,0,0,0,0.0D0,0.0D0)
2426       GO TO 750
2427 707   MSG = 'DASKR--  SOME ELEMENT OF ATOL IS .LT. 0'
2428       CALL XERRWD(MSG,39,7,0,0,0,0,0,0.0D0,0.0D0)
2429       GO TO 750
2430 708   MSG = 'DASKR--  ALL ELEMENTS OF RTOL AND ATOL ARE ZERO'
2431       CALL XERRWD(MSG,47,8,0,0,0,0,0,0.0D0,0.0D0)
2432       GO TO 750
2433 709   MSG='DASKR--  INFO(4) = 1 AND TSTOP (=R1) BEHIND TOUT (=R2)'
2434       CALL XERRWD(MSG,54,9,0,0,0,0,2,TSTOP,TOUT)
2435       GO TO 750
2436 710   MSG = 'DASKR--  HMAX (=R1) .LT. 0.0'
2437       CALL XERRWD(MSG,28,10,0,0,0,0,1,HMAX,0.0D0)
2438       GO TO 750
2439 711   MSG = 'DASKR--  TOUT (=R1) BEHIND T (=R2)'
2440       CALL XERRWD(MSG,34,11,0,0,0,0,2,TOUT,T)
2441       GO TO 750
2442 712   MSG = 'DASKR--  INFO(8)=1 AND H0=0.0'
2443       CALL XERRWD(MSG,29,12,0,0,0,0,0,0.0D0,0.0D0)
2444       GO TO 750
2445 713   MSG = 'DASKR--  SOME ELEMENT OF WT IS .LE. 0.0'
2446       CALL XERRWD(MSG,39,13,0,0,0,0,0,0.0D0,0.0D0)
2447       GO TO 750
2448 714   MSG='DASKR-- TOUT (=R1) TOO CLOSE TO T (=R2) TO START INTEGRATION'
2449       CALL XERRWD(MSG,60,14,0,0,0,0,2,TOUT,T)
2450       GO TO 750
2451 715   MSG = 'DASKR--  INFO(4)=1 AND TSTOP (=R1) BEHIND T (=R2)'
2452       CALL XERRWD(MSG,49,15,0,0,0,0,2,TSTOP,T)
2453       GO TO 750
2454 717   MSG = 'DASKR--  ML (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ'
2455       CALL XERRWD(MSG,52,17,0,1,IWORK(LML),0,0,0.0D0,0.0D0)
2456       GO TO 750
2457 718   MSG = 'DASKR--  MU (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ'
2458       CALL XERRWD(MSG,52,18,0,1,IWORK(LMU),0,0,0.0D0,0.0D0)
2459       GO TO 750
2460 719   MSG = 'DASKR--  TOUT (=R1) IS EQUAL TO T (=R2)'
2461       CALL XERRWD(MSG,39,19,0,0,0,0,2,TOUT,T)
2462       GO TO 750
2463 720   MSG = 'DASKR--  MAXL (=I1) ILLEGAL. EITHER .LT. 1 OR .GT. NEQ'
2464       CALL XERRWD(MSG,54,20,0,1,IWORK(LMAXL),0,0,0.0D0,0.0D0)
2465       GO TO 750
2466 721   MSG = 'DASKR--  KMP (=I1) ILLEGAL. EITHER .LT. 1 OR .GT. MAXL'
2467       CALL XERRWD(MSG,54,21,0,1,IWORK(LKMP),0,0,0.0D0,0.0D0)
2468       GO TO 750
2469 722   MSG = 'DASKR--  NRMAX (=I1) ILLEGAL. .LT. 0'
2470       CALL XERRWD(MSG,36,22,0,1,IWORK(LNRMAX),0,0,0.0D0,0.0D0)
2471       GO TO 750
2472 723   MSG = 'DASKR--  EPLI (=R1) ILLEGAL. EITHER .LE. 0.D0 OR .GE. 1.D0'
2473       CALL XERRWD(MSG,58,23,0,0,0,0,1,RWORK(LEPLI),0.0D0)
2474       GO TO 750
2475 724   MSG = 'DASKR--  ILLEGAL IWORK VALUE FOR INFO(11) .NE. 0'
2476       CALL XERRWD(MSG,48,24,0,0,0,0,0,0.0D0,0.0D0)
2477       GO TO 750
2478 725   MSG = 'DASKR--  ONE OF THE INPUTS FOR INFO(17) = 1 IS ILLEGAL'
2479       CALL XERRWD(MSG,54,25,0,0,0,0,0,0.0D0,0.0D0)
2480       GO TO 750
2481 726   MSG = 'DASKR--  ILLEGAL IWORK VALUE FOR INFO(10) .NE. 0'
2482       CALL XERRWD(MSG,48,26,0,0,0,0,0,0.0D0,0.0D0)
2483       GO TO 750
2484 727   MSG = 'DASKR--  Y(I) AND IWORK(40+I) (I=I1) INCONSISTENT'
2485       CALL XERRWD(MSG,49,27,0,1,IRET,0,0,0.0D0,0.0D0)
2486       GO TO 750
2487 730   MSG = 'DASKR--  NRT (=I1) .LT. 0'
2488       CALL XERRWD(MSG,25,30,1,1,NRT,0,0,0.0D0,0.0D0)
2489       GO TO 750
2490 731   MSG = 'DASKR--  R IS ILL-DEFINED.  ZERO VALUES WERE FOUND AT TWO'
2491       CALL XERRWD(MSG,57,31,1,0,0,0,0,0.0D0,0.0D0)
2492       MSG = '         VERY CLOSE T VALUES, AT T = R1'
2493       CALL XERRWD(MSG,39,31,1,0,0,0,1,RWORK(LT0),0.0D0)
2494 C
2495 750   IF(INFO(1).EQ.-1) GO TO 760
2496       INFO(1)=-1
2497       IDID=-33
2498       RETURN
2499 760   MSG = 'DASKR--  REPEATED OCCURRENCES OF ILLEGAL INPUT'
2500       CALL XERRWD(MSG,46,701,0,0,0,0,0,0.0D0,0.0D0)
2501 770   MSG = 'DASKR--  RUN TERMINATED. APPARENT INFINITE LOOP'
2502       CALL XERRWD(MSG,47,702,1,0,0,0,0,0.0D0,0.0D0)
2503       RETURN
2504 C
2505 C------END OF SUBROUTINE DDASKR-----------------------------------------
2506       END
2507       SUBROUTINE DRCHEK2 (JOB, RT, NRT, NEQ, TN, TOUT, Y, YP, PHI, PSI,
2508      *   KOLD, R0, R1, RX, JROOT, IRT, UROUND, INFO3, RWORK, IWORK,
2509      *   RPAR, IPAR)
2510 C
2511 C***BEGIN PROLOGUE  DRCHEK2
2512 C***REFER TO DDASKR
2513 C***ROUTINES CALLED  DDATRP2, DROOTS2, DCOPY, RT
2514 C***REVISION HISTORY  (YYMMDD)
2515 C   020815  DATE WRITTEN   
2516 C   021217  Added test for roots close when JOB = 2.
2517 C   050510  Changed T increment after 110 so that TEMP1/H .ge. 0.1.
2518 C   071003  Fixed bug in TEMP2 (HMINR) below 110.
2519 C   110608  Fixed bug in setting of T1 at 300.
2520 C***END PROLOGUE  DRCHEK2
2521 C
2522       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
2523 C Pointers into IWORK:
2524       PARAMETER (LNRTE=36, LIRFND=37)
2525 C Pointers into RWORK:
2526       PARAMETER (LT0=51, LTLAST=52)
2527       EXTERNAL RT
2528       INTEGER JOB, NRT, NEQ, KOLD, JROOT, IRT, INFO3, IWORK, IPAR
2529       DOUBLE PRECISION TN, TOUT, Y, YP, PHI, PSI, R0, R1, RX, UROUND,
2530      *  RWORK, RPAR
2531       DIMENSION Y(*), YP(*), PHI(NEQ,*), PSI(*),
2532      *          R0(*), R1(*), RX(*), JROOT(*), RWORK(*), IWORK(*)
2533       INTEGER I, JFLAG
2534       DOUBLE PRECISION H
2535       DOUBLE PRECISION HMINR, T1, TEMP1, TEMP2, X, ZERO
2536       LOGICAL ZROOT
2537       DATA ZERO/0.0D0/
2538 C-----------------------------------------------------------------------
2539 C This routine checks for the presence of a root of R(T,Y,Y') in the
2540 C vicinity of the current T, in a manner depending on the
2541 C input flag JOB.  It calls subroutine DROOTS2 to locate the root
2542 C as precisely as possible.
2543 C
2544 C In addition to variables described previously, DRCHEK2
2545 C uses the following for communication..
2546 C JOB    = integer flag indicating type of call..
2547 C          JOB = 1 means the problem is being initialized, and DRCHEK2
2548 C                  is to look for a root at or very near the initial T.
2549 C          JOB = 2 means a continuation call to the solver was just
2550 C                  made, and DRCHEK2 is to check for a root in the
2551 C                  relevant part of the step last taken.
2552 C          JOB = 3 means a successful step was just taken, and DRCHEK2
2553 C                  is to look for a root in the interval of the step.
2554 C R0     = array of length NRT, containing the value of R at T = T0.
2555 C          R0 is input for JOB .ge. 2 and on output in all cases.
2556 C R1,RX  = arrays of length NRT for work space.
2557 C IRT    = completion flag..
2558 C          IRT = 0  means no root was found.
2559 C          IRT = -1 means JOB = 1 and a zero was found both at T0 and
2560 C                   and very close to T0.
2561 C          IRT = -2 means JOB = 2 and some Ri was found to have a zero
2562 C                   both at T0 and very close to T0.
2563 C          IRT = 1  means a legitimate root was found (JOB = 2 or 3).
2564 C                   On return, T0 is the root location, and Y is the
2565 C                   corresponding solution vector.
2566 C T0     = value of T at one endpoint of interval of interest.  Only
2567 C          roots beyond T0 in the direction of integration are sought.
2568 C          T0 is input if JOB .ge. 2, and output in all cases.
2569 C          T0 is updated by DRCHEK2, whether a root is found or not.
2570 C          Stored in the global array RWORK.
2571 C TLAST  = last value of T returned by the solver (input only).
2572 C          Stored in the global array RWORK.
2573 C TOUT   = final output time for the solver.
2574 C IRFND  = input flag showing whether the last step taken had a root.
2575 C          IRFND = 1 if it did, = 0 if not.
2576 C          Stored in the global array IWORK.
2577 C INFO3  = copy of INFO(3) (input only).
2578 C-----------------------------------------------------------------------
2579 C     
2580       H = PSI(1)
2581       IRT = 0
2582 c*****SCILAB ENTERPRISES INPUT
2583 c**** Do not reset JROOT with every call of DRCHEK2,
2584 c**** because we want to keep the MASKED roots
2585 c      DO 10 I = 1,NRT
2586 c 10     JROOT(I) = 0
2587       MASKED = 55
2588 c*****
2589       HMINR = (ABS(TN) + ABS(H))*UROUND*100.0D0
2590 C
2591       GO TO (100, 200, 300), JOB
2592 C
2593 C Evaluate R at initial T (= RWORK(LT0)); check for zero values.--------
2594  100  CONTINUE
2595 c*****SCILAB ENTERPRISES INPUT
2596 c**** Initialize JROOT just one time,
2597 c**** at the first call of DRCHEK2() (JOB = 1)
2598       DO 101 I = 1,NRT
2599  101     JROOT(I) = 0
2600       RWORK(LT0) = TN
2601 c*****
2602       CALL DDATRP2(TN,RWORK(LT0),Y,YP,NEQ,KOLD,PHI,PSI)
2603       CALL RT (NEQ, RWORK(LT0), Y, NRT, R0, RPAR, IPAR)
2604       IWORK(LNRTE) = 1
2605       ZROOT = .FALSE.
2606       DO 110 I = 1,NRT
2607 c*******SCILAB ENTERPRISES INPUT
2608 c****** On the first call of DRCHEK2(),
2609 c****** just list the zeros and tag them as MASKED
2610         IF (ABS(R0(I)) .EQ. ZERO) THEN
2611 c           ZROOT = .TRUE.
2612            JROOT(I) = MASKED
2613         ENDIF
2614  110  CONTINUE
2615 c      IF (.NOT. ZROOT) GO TO 190
2616 C R has a zero at T.  Look at R at T + (small increment). --------------
2617 c      TEMP2 = MAX(HMINR/ABS(H), 0.1D0)
2618 c      TEMP1 = TEMP2*H
2619 c      RWORK(LT0) = RWORK(LT0) + TEMP1
2620 c      DO 120 I = 1,NEQ
2621 c 120    Y(I) = Y(I) + TEMP2*PHI(I,2)
2622 c      CALL RT (NEQ, RWORK(LT0), Y, NRT, R0, RPAR, IPAR)
2623 c      IWORK(LNRTE) = IWORK(LNRTE) + 1
2624 c      ZROOT = .FALSE.
2625 c      DO 130 I = 1,NRT
2626 c 130    IF (ABS(R0(I)) .EQ. ZERO) ZROOT = .TRUE.
2627 c      IF (.NOT. ZROOT) GO TO 190
2628 C R has a zero at T and also close to T.  Take error return. -----------
2629 c      IRT = -1
2630 c      RETURN
2631 c******
2632 C
2633  190  CONTINUE
2634       RETURN
2635 C
2636  200  CONTINUE
2637       IF (IWORK(LIRFND) .EQ. 0) GO TO 260
2638 C If a root was found on the previous step, evaluate R0 = R(T0). -------
2639       CALL DDATRP2 (TN, RWORK(LT0), Y, YP, NEQ, KOLD, PHI, PSI)
2640       CALL RT (NEQ, RWORK(LT0), Y, NRT, R0, RPAR, IPAR)
2641       IWORK(LNRTE) = IWORK(LNRTE) + 1
2642       ZROOT = .FALSE.
2643       DO 210 I = 1,NRT
2644         IF (ABS(R0(I)) .EQ. ZERO) THEN
2645 c*********SCILAB ENTERPRISES INPUT
2646 c******** Like with JOB = 1, simply initialize JROOT to 0,
2647 c******** mask the ones that are null at the left endpoint
2648 c          ZROOT = .TRUE.
2649           JROOT(I) = MASKED
2650         ELSE
2651           JROOT(I) = 0
2652 c*********
2653         ENDIF
2654  210    CONTINUE
2655 c      IF (.NOT. ZROOT) GO TO 260
2656 C R has a zero at T0.  Look at R at T0+ = T0 + (small increment). ------
2657 c      TEMP1 = SIGN(HMINR,H)
2658 c      RWORK(LT0) = RWORK(LT0) + TEMP1
2659 c      IF ((RWORK(LT0) - TN)*H .LT. ZERO) GO TO 230
2660 c      TEMP2 = TEMP1/H
2661 c      DO 220 I = 1,NEQ
2662 c 220    Y(I) = Y(I) + TEMP2*PHI(I,2)
2663 c      GO TO 240
2664 c 230  CALL DDATRP2 (TN, RWORK(LT0), Y, YP, NEQ, KOLD, PHI, PSI)
2665 c 240  CALL RT (NEQ, RWORK(LT0), Y, NRT, R0, RPAR, IPAR)
2666 c      IWORK(LNRTE) = IWORK(LNRTE) + 1
2667 c      DO 250 I = 1,NRT
2668 c        IF (ABS(R0(I)) .GT. ZERO) GO TO 250
2669 C If Ri has a zero at both T0+ and T0, return an error flag. -----------
2670 c        IF (JROOT(I) .EQ. 1) THEN
2671 c          IRT = -2
2672 c          RETURN
2673 c        ELSE
2674 C If Ri has a zero at T0+, but not at T0, return valid root. -----------
2675 c          JROOT(I) = -SIGN(1.0D0,R0(I))
2676 c          IRT = 1
2677 c        ENDIF
2678 c 250    CONTINUE
2679 c      IF (IRT .EQ. 1) RETURN
2680 C R0 has no zero components.  Proceed to check relevant interval. ------
2681 c 260  IF (TN .EQ. RWORK(LTLAST)) RETURN
2682  260  RETURN
2683 C
2684  300  CONTINUE
2685 C Set T1 to TN or TOUT, whichever comes first, and get R at T1. --------
2686 c*****SCILAB ENTERPRISES INPUT
2687 c**** Here, the calculaltion mode can save some computations
2688       IF (INFO3 .EQ. 0) THEN
2689       IF ((TOUT - TN)*H .GE. ZERO) THEN
2690          T1 = TN
2691          GO TO 330
2692       ENDIF
2693       T1 = TOUT
2694       ELSE
2695       T1 = TN
2696       ENDIF
2697 c*****
2698       IF ((T1 - RWORK(LT0))*H .LE. ZERO) GO TO 390
2699  330  CALL DDATRP2 (TN, T1, Y, YP, NEQ, KOLD, PHI, PSI)
2700       CALL RT (NEQ, T1, Y, NRT, R1, RPAR, IPAR)
2701       IWORK(LNRTE) = IWORK(LNRTE) + 1
2702 C Call DROOTS2 to search for root in interval from T0 to T1. -----------
2703       JFLAG = 0
2704  350  CONTINUE
2705       CALL DROOTS2(NRT, HMINR, JFLAG, RWORK(LT0),T1, R0,R1,RX, X, JROOT)
2706       IF (JFLAG .GT. 1) GO TO 360
2707       CALL DDATRP2 (TN, X, Y, YP, NEQ, KOLD, PHI, PSI)
2708       CALL RT (NEQ, X, Y, NRT, RX, RPAR, IPAR)
2709       IWORK(LNRTE) = IWORK(LNRTE) + 1
2710       GO TO 350
2711  360  RWORK(LT0) = X
2712       CALL DCOPY (NRT, RX, 1, R0, 1)
2713       IF (JFLAG .EQ. 4) GO TO 390
2714 C Found a root.  Interpolate to X and return. --------------------------
2715       CALL DDATRP2 (TN, X, Y, YP, NEQ, KOLD, PHI, PSI)
2716 c*****SCILAB ENTERPRISES INPUT
2717 c**** If DROOTS2 returned JFLAG = 5,
2718 c**** then IRT = 2 will throw the ZERO_DETACH warning
2719       IF (JFLAG .EQ. 5) THEN
2720         IRT = 2
2721         RETURN
2722 c*****
2723       ENDIF
2724       IRT = 1
2725       RETURN
2726 C
2727  390  CONTINUE
2728       RETURN
2729 C---------------------- END OF SUBROUTINE DRCHEK2 -----------------
2730       END
2731       SUBROUTINE DROOTS2(NRT, HMIN, JFLAG, X0, X1, R0, R1, RX, X, JROOT)
2732 C
2733 C***BEGIN PROLOGUE  DROOTS2
2734 C***REFER TO DRCHEK2
2735 C***ROUTINES CALLED DCOPY
2736 C***REVISION HISTORY  (YYMMDD)
2737 C   020815  DATE WRITTEN   
2738 C   021217  Added root direction information in JROOT.
2739 C   040518  Changed adjustment to X2 at 180 to avoid infinite loop.
2740 C***END PROLOGUE  DROOTS2
2741 C
2742       INTEGER NRT, JFLAG, JROOT
2743       DOUBLE PRECISION HMIN, X0, X1, R0, R1, RX, X
2744       DIMENSION R0(NRT), R1(NRT), RX(NRT), JROOT(NRT)
2745 C-----------------------------------------------------------------------
2746 C This subroutine finds the leftmost root of a set of arbitrary
2747 C functions Ri(x) (i = 1,...,NRT) in an interval (X0,X1).  Only roots
2748 C of odd multiplicity (i.e. changes of sign of the Ri) are found.
2749 C Here the sign of X1 - X0 is arbitrary, but is constant for a given
2750 C problem, and -leftmost- means nearest to X0.
2751 C The values of the vector-valued function R(x) = (Ri, i=1...NRT)
2752 C are communicated through the call sequence of DROOTS2.
2753 C The method used is the Illinois algorithm.
2754 C
2755 C Reference:
2756 C Kathie L. Hiebert and Lawrence F. Shampine, Implicitly Defined
2757 C Output Points for Solutions of ODEs, Sandia Report SAND80-0180,
2758 C February 1980.
2759 C
2760 C Description of parameters.
2761 C
2762 C NRT    = number of functions Ri, or the number of components of
2763 C          the vector valued function R(x).  Input only.
2764 C
2765 C HMIN   = resolution parameter in X.  Input only.  When a root is
2766 C          found, it is located only to within an error of HMIN in X.
2767 C          Typically, HMIN should be set to something on the order of
2768 C               100 * UROUND * MAX(ABS(X0),ABS(X1)),
2769 C          where UROUND is the unit roundoff of the machine.
2770 C
2771 C JFLAG  = integer flag for input and output communication.
2772 C
2773 C          On input, set JFLAG = 0 on the first call for the problem,
2774 C          and leave it unchanged until the problem is completed.
2775 C          (The problem is completed when JFLAG .ge. 2 on return.)
2776 C
2777 C          On output, JFLAG has the following values and meanings:
2778 C          JFLAG = 1 means DROOTS2 needs a value of R(x).  Set RX = R(X)
2779 C                    and call DROOTS2 again.
2780 C          JFLAG = 2 means a root has been found.  The root is
2781 C                    at X, and RX contains R(X).  (Actually, X is the
2782 C                    rightmost approximation to the root on an interval
2783 C                    (X0,X1) of size HMIN or less.)
2784 C          JFLAG = 3 means X = X1 is a root, with one or more of the Ri
2785 C                    being zero at X1 and no sign changes in (X0,X1).
2786 C                    RX contains R(X) on output.
2787 C          JFLAG = 4 means no roots (of odd multiplicity) were
2788 C                    found in (X0,X1) (no sign changes).
2789 C
2790 C X0,X1  = endpoints of the interval where roots are sought.
2791 C          X1 and X0 are input when JFLAG = 0 (first call), and
2792 C          must be left unchanged between calls until the problem is
2793 C          completed.  X0 and X1 must be distinct, but X1 - X0 may be
2794 C          of either sign.  However, the notion of -left- and -right-
2795 C          will be used to mean nearer to X0 or X1, respectively.
2796 C          When JFLAG .ge. 2 on return, X0 and X1 are output, and
2797 C          are the endpoints of the relevant interval.
2798 C
2799 C R0,R1  = arrays of length NRT containing the vectors R(X0) and R(X1),
2800 C          respectively.  When JFLAG = 0, R0 and R1 are input and
2801 C          none of the R0(i) should be zero.
2802 C          When JFLAG .ge. 2 on return, R0 and R1 are output.
2803 C
2804 C RX     = array of length NRT containing R(X).  RX is input
2805 C          when JFLAG = 1, and output when JFLAG .ge. 2.
2806 C
2807 C X      = independent variable value.  Output only.
2808 C          When JFLAG = 1 on output, X is the point at which R(x)
2809 C          is to be evaluated and loaded into RX.
2810 C          When JFLAG = 2 or 3, X is the root.
2811 C          When JFLAG = 4, X is the right endpoint of the interval, X1.
2812 C
2813 C JROOT  = integer array of length NRT.  Output only.
2814 C          When JFLAG = 2 or 3, JROOT indicates which components
2815 C          of R(x) have a root at X, and the direction of the sign
2816 C          change across the root in the direction of integration.
2817 C          JROOT(i) =  1 if Ri has a root and changes from - to +.
2818 C          JROOT(i) = -1 if Ri has a root and changes from + to -.
2819 C          Otherwise JROOT(i) = 0.
2820 C-----------------------------------------------------------------------
2821       INTEGER I, IMAX, IMXOLD, LAST, NXLAST
2822       DOUBLE PRECISION ALPHA, T2, TMAX, X2, FRACINT, FRACSUB,
2823      1                 ZERO, TENTH, HALF, FIVE
2824 c*****SCILAB ENTERPRISES INPUT
2825 c**** UMROOT is a boolean to flag a root which gets unmasked.
2826       LOGICAL ZROOT, SGNCHG, XROOT, UMROOT
2827 c*****
2828       SAVE ALPHA, X2, IMAX, LAST
2829       DATA ZERO/0.0D0/, TENTH/0.1D0/, HALF/0.5D0/, FIVE/5.0D0/
2830 C
2831       MASKED = 55
2832       IF (JFLAG .EQ. 1) GO TO 200
2833 C JFLAG .ne. 1.  Check for change in sign of R or zero at X1. ----------
2834 c*****SCILAB ENTERPRISES INPUT
2835 c**** ISTUCK and IUNSTUCK help finding masked / unmasked roots.
2836       ISTUCK = 0
2837       IUNSTUCK = 0
2838       IMAX = 0
2839       TMAX = ZERO
2840       ZROOT = .FALSE.
2841       DO 120 I = 1,NRT
2842         IF (ABS(R1(I)) .GT. ZERO) GO TO 110
2843 c****** If a root function is null at both endpoints, flag it as STUCK.
2844         IF (ABS(R1(I)) .EQ. ZERO .AND. JROOT(I) .NE. MASKED) ISTUCK = I
2845 c        ZROOT = .TRUE.
2846         GO TO 120
2847 C At this point, R0(i) has been checked and cannot be zero. ------------
2848 c******** Here, test if some roots get UNSTUCK.
2849  110    IF (JROOT(I).EQ.MASKED) IUNSTUCK = I
2850         IF (R0(I)*R1(I) .GT. ZERO) GO TO 120
2851         T2 = ABS(R1(I)/(R1(I)-R0(I)))
2852         IF (T2 .LE. TMAX) GO TO 120
2853         TMAX = T2
2854         IMAX = I
2855  120    CONTINUE
2856       IF (IMAX .GT. 0) GO TO 130
2857 c******* STUCK and UNSTUCK root functions count as sign changes.
2858          IF (ISTUCK .GT. 0) THEN
2859             IMAX = ISTUCK
2860             GO TO 130
2861          ELSEIF (IUNSTUCK .GT. 0) THEN
2862             IMAX = IUNSTUCK
2863             GO TO 130
2864          ENDIF
2865       SGNCHG = .FALSE.
2866       GO TO 140
2867  130  SGNCHG = .TRUE.
2868  140  IF (.NOT. SGNCHG) GO TO 400
2869 C There is a sign change.  Find the first root in the interval. --------
2870       XROOT = .FALSE.
2871       NXLAST = 0
2872       LAST = 1
2873 C
2874 C Repeat until the first root in the interval is found.  Loop point. ---
2875  150  CONTINUE
2876       IF (XROOT) GO TO 300
2877       IF (NXLAST .EQ. LAST) GO TO 160
2878       ALPHA = 1.0D0
2879       GO TO 180
2880  160  IF (LAST .EQ. 0) GO TO 170
2881       ALPHA = 0.5D0*ALPHA
2882       GO TO 180
2883  170  ALPHA = 2.0D0*ALPHA
2884  180  X2 = X1 - (X1-X0)*R1(IMAX)/(R1(IMAX) - ALPHA*R0(IMAX))
2885       IF (ABS(X2 - X0) < HALF*HMIN) THEN
2886         FRACINT = ABS(X1 - X0)/HMIN
2887         IF (FRACINT .GT. FIVE) THEN
2888           FRACSUB = TENTH
2889         ELSE
2890           FRACSUB = HALF/FRACINT
2891         ENDIF
2892         X2 = X0 + FRACSUB*(X1 - X0)
2893       ENDIF
2894       IF (ABS(X1 - X2) < HALF*HMIN) THEN
2895         FRACINT = ABS(X1 - X0)/HMIN
2896         IF (FRACINT .GT. FIVE) THEN
2897           FRACSUB = TENTH
2898         ELSE
2899           FRACSUB = HALF/FRACINT
2900         ENDIF
2901         X2 = X1 - FRACSUB*(X1 - X0)
2902       ENDIF
2903       JFLAG = 1
2904       X = X2
2905 C Return to the calling routine to get a value of RX = R(X). -----------
2906       RETURN
2907 C Check to see in which interval R changes sign. -----------------------
2908  200  IMXOLD = IMAX
2909       IMAX = 0
2910       ISTUCK = 0
2911       IUNSTUCK = 0
2912       TMAX = ZERO
2913       ZROOT = .FALSE.
2914       DO 220 I = 1,NRT
2915         IF (ABS(RX(I)) .GT. ZERO) GO TO 210
2916         IF (ABS(RX(I)).EQ.ZERO .AND. JROOT(I).NE.MASKED) ISTUCK = I
2917 c        ZROOT = .TRUE.
2918         GO TO 220
2919 C Neither R0(i) nor RX(i) can be zero at this point. -------------------
2920  210    IF (JROOT(I).EQ.MASKED) IUNSTUCK = I
2921         IF (R0(I)*RX(I) .GT. 0) GO TO 220
2922         T2 = ABS(RX(I)/(RX(I) - R0(I)))
2923         IF (T2 .LE. TMAX) GO TO 220
2924           TMAX = T2
2925           IMAX = I
2926  220    CONTINUE
2927       IF (IMAX .GT. 0) GO TO 230
2928          IF (ISTUCK .GT. 0) THEN
2929             IMAX = ISTUCK
2930             GO TO 230
2931          ELSEIF (IUNSTUCK .GT. 0) THEN
2932             IMAX = IUNSTUCK
2933             GO TO 230
2934          ENDIF
2935       SGNCHG = .FALSE.
2936       IMAX = IMXOLD
2937       GO TO 240
2938  230  SGNCHG = .TRUE.
2939  240  NXLAST = LAST
2940       IF (.NOT. SGNCHG) GO TO 250
2941 C Sign change between X0 and X2, so replace X1 with X2. ----------------
2942       X1 = X2
2943       CALL DCOPY (NRT, RX, 1, R1, 1)
2944       LAST = 1
2945       XROOT = .FALSE.
2946       GO TO 270
2947  250  IF (.NOT. ZROOT) GO TO 260
2948 C Zero value at X2 and no sign change in (X0,X2), so X2 is a root. -----
2949       X1 = X2
2950       CALL DCOPY (NRT, RX, 1, R1, 1)
2951       XROOT = .TRUE.
2952       GO TO 270
2953 C No sign change between X0 and X2.  Replace X0 with X2. ---------------
2954  260  CONTINUE
2955       CALL DCOPY (NRT, RX, 1, R0, 1)
2956       X0 = X2
2957       LAST = 0
2958       XROOT = .FALSE.
2959  270  IF (ABS(X1-X0) .LE. HMIN) XROOT = .TRUE.
2960       GO TO 150
2961 C
2962 C Return with X1 as the root.  Set JROOT.  Set X = X1 and RX = R1. -----
2963  300  JFLAG = 2
2964       X = X1
2965       CALL DCOPY (NRT, R1, 1, RX, 1)
2966 c**** The following part unmasks root functions if needed
2967 c**** and gives final values to JROOT
2968       UMROOT = .FALSE.
2969       DO 320 I = 1,NRT
2970 c        JROOT(I) = 0
2971         IF (JROOT(I) .NE. MASKED) THEN
2972           IF (ABS(R1(I)) .EQ. ZERO) THEN
2973             IF (R0(I).GT.ZERO) THEN
2974                JROOT(I) = -1
2975             ELSE
2976                JROOT(I) = 1
2977             ENDIF
2978             ZROOT = .TRUE.
2979             GO TO 320
2980           ENDIF
2981           IF (R0(I)*R1(I).LT.ZERO) THEN
2982             JROOT(I) = SIGN(1.0D0,R1(I))
2983             ZROOT = .TRUE.
2984           ELSE
2985             JROOT(I) = 0
2986             ZROOT = .FALSE.
2987           ENDIF
2988         ELSE
2989           IF (ABS(R1(I)) .NE. ZERO) THEN
2990             IF (R1(I) .GT. ZERO) THEN
2991               JROOT(I) = 2
2992             ELSE
2993               JROOT(I) = -2
2994             ENDIF
2995             UMROOT = .TRUE.
2996           ELSE
2997             JROOT(I) = 0
2998           ENDIF
2999           ZROOT = .FALSE.
3000         ENDIF
3001  320    CONTINUE
3002       IF (ZROOT) THEN
3003         DO 325 I = 1,NRT
3004  325      IF (JROOT(I) .EQ. 2 .OR. JROOT(I) .EQ. -2) JROOT(I) = 0
3005       ELSEIF (UMROOT) THEN
3006         JFLAG = 5
3007       ENDIF
3008 c*****
3009       RETURN
3010 C
3011 C No sign change in the interval.  Check for zero at right endpoint. ---
3012  400  IF (.NOT. ZROOT) GO TO 420
3013 C
3014 C Zero value at X1 and no sign change in (X0,X1).  Return JFLAG = 3. ---
3015       X = X1
3016       CALL DCOPY (NRT, R1, 1, RX, 1)
3017       DO 410 I = 1,NRT
3018         JROOT(I) = 0
3019         IF (ABS(R1(I)) .EQ. ZERO) JROOT(I) = -SIGN(1.0D0,R0(I))
3020  410  CONTINUE
3021       JFLAG = 3
3022       RETURN
3023 C
3024 C No sign changes in this interval.  Set X = X1, return JFLAG = 4. -----
3025  420  CALL DCOPY (NRT, R1, 1, RX, 1)
3026       X = X1
3027       JFLAG = 4
3028       RETURN
3029 C----------------------- END OF SUBROUTINE DROOTS2 ----------------------
3030       END
3031       SUBROUTINE DDASIC (X, Y, YPRIME, NEQ, ICOPT, ID, RES, JAC, PSOL,
3032      *   H, TSCALE, WT, NIC, IDID, RPAR, IPAR, PHI, SAVR, DELTA, E,
3033      *   YIC, YPIC, PWK, WM, IWM, UROUND, EPLI, SQRTN, RSQRTN,
3034      *   EPCONI, STPTOL, JFLG, ICNFLG, ICNSTR, NLSIC)
3035 C
3036 C***BEGIN PROLOGUE  DDASIC
3037 C***REFER TO  DDASPK
3038 C***DATE WRITTEN   940628   (YYMMDD)
3039 C***REVISION DATE  941206   (YYMMDD)
3040 C***REVISION DATE  950714   (YYMMDD)
3041 C***REVISION DATE  000628   TSCALE argument added.
3042 C
3043 C-----------------------------------------------------------------------
3044 C***DESCRIPTION
3045 C
3046 C     DDASIC is a driver routine to compute consistent initial values
3047 C     for Y and YPRIME.  There are two different options:  
3048 C     Denoting the differential variables in Y by Y_d, and
3049 C     the algebraic variables by Y_a, the problem solved is either:
3050 C     1.  Given Y_d, calculate Y_a and Y_d', or
3051 C     2.  Given Y', calculate Y.
3052 C     In either case, initial values for the given components
3053 C     are input, and initial guesses for the unknown components
3054 C     must also be provided as input.
3055 C
3056 C     The external routine NLSIC solves the resulting nonlinear system.
3057 C
3058 C     The parameters represent
3059 C
3060 C     X  --        Independent variable.
3061 C     Y  --        Solution vector at X.
3062 C     YPRIME --    Derivative of solution vector.
3063 C     NEQ --       Number of equations to be integrated.
3064 C     ICOPT     -- Flag indicating initial condition option chosen.
3065 C                    ICOPT = 1 for option 1 above.
3066 C                    ICOPT = 2 for option 2.
3067 C     ID        -- Array of dimension NEQ, which must be initialized
3068 C                  if option 1 is chosen.
3069 C                    ID(i) = +1 if Y_i is a differential variable,
3070 C                    ID(i) = -1 if Y_i is an algebraic variable. 
3071 C     RES --       External user-supplied subroutine to evaluate the
3072 C                  residual.  See RES description in DDASPK prologue.
3073 C     JAC --       External user-supplied routine to update Jacobian
3074 C                  or preconditioner information in the nonlinear solver
3075 C                  (optional).  See JAC description in DDASPK prologue.
3076 C     PSOL --      External user-supplied routine to solve
3077 C                  a linear system using preconditioning. 
3078 C                  See PSOL in DDASPK prologue.
3079 C     H --         Scaling factor in iteration matrix.  DDASIC may 
3080 C                  reduce H to achieve convergence.
3081 C     TSCALE --    Scale factor in T, used for stopping tests if nonzero.
3082 C     WT --        Vector of weights for error criterion.
3083 C     NIC --       Input number of initial condition calculation call 
3084 C                  (= 1 or 2).
3085 C     IDID --      Completion code.  See IDID in DDASPK prologue.
3086 C     RPAR,IPAR -- Real and integer parameter arrays that
3087 C                  are used for communication between the
3088 C                  calling program and external user routines.
3089 C                  They are not altered by DNSK
3090 C     PHI --       Work space for DDASIC of length at least 2*NEQ.
3091 C     SAVR --      Work vector for DDASIC of length NEQ.
3092 C     DELTA --     Work vector for DDASIC of length NEQ.
3093 C     E --         Work vector for DDASIC of length NEQ.
3094 C     YIC,YPIC --  Work vectors for DDASIC, each of length NEQ.
3095 C     PWK --       Work vector for DDASIC of length NEQ.
3096 C     WM,IWM --    Real and integer arrays storing
3097 C                  information required by the linear solver.
3098 C     EPCONI --    Test constant for Newton iteration convergence.
3099 C     ICNFLG --    Flag showing whether constraints on Y are to apply.
3100 C     ICNSTR --    Integer array of length NEQ with constraint types.
3101 C
3102 C     The other parameters are for use internally by DDASIC.
3103 C
3104 C-----------------------------------------------------------------------
3105 C***ROUTINES CALLED
3106 C   DCOPY, NLSIC
3107 C
3108 C***END PROLOGUE  DDASIC
3109 C
3110 C
3111       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
3112       DIMENSION Y(*),YPRIME(*),ID(*),WT(*),PHI(NEQ,*)
3113       DIMENSION SAVR(*),DELTA(*),E(*),YIC(*),YPIC(*),PWK(*)
3114       DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*), ICNSTR(*)
3115       EXTERNAL RES, JAC, PSOL, NLSIC
3116 C
3117       PARAMETER (LCFN=15)
3118       PARAMETER (LMXNH=34)
3119 C
3120 C The following parameters are data-loaded here:
3121 C     RHCUT  = factor by which H is reduced on retry of Newton solve.
3122 C     RATEMX = maximum convergence rate for which Newton iteration
3123 C              is considered converging.
3124 C
3125       SAVE RHCUT, RATEMX
3126       DATA RHCUT/0.1D0/, RATEMX/0.8D0/
3127 C
3128 C
3129 C-----------------------------------------------------------------------
3130 C     BLOCK 1.
3131 C     Initializations.
3132 C     JSKIP is a flag set to 1 when NIC = 2 and NH = 1, to signal that
3133 C     the initial call to the JAC routine is to be skipped then.
3134 C     Save Y and YPRIME in PHI.  Initialize IDID, NH, and CJ.
3135 C-----------------------------------------------------------------------
3136 C
3137       MXNH = IWM(LMXNH)
3138       IDID = 1
3139       NH = 1
3140       JSKIP = 0
3141       IF (NIC .EQ. 2) JSKIP = 1
3142       CALL DCOPY (NEQ, Y, 1, PHI(1,1), 1)
3143       CALL DCOPY (NEQ, YPRIME, 1, PHI(1,2), 1)
3144 C
3145       IF (ICOPT .EQ. 2) THEN
3146         CJ = 0.0D0 
3147       ELSE
3148         CJ = 1.0D0/H
3149       ENDIF
3150 C
3151 C-----------------------------------------------------------------------
3152 C     BLOCK 2
3153 C     Call the nonlinear system solver to obtain
3154 C     consistent initial values for Y and YPRIME.
3155 C-----------------------------------------------------------------------
3156 C
3157  200  CONTINUE
3158       CALL NLSIC(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JAC,PSOL,H,TSCALE,WT,
3159      *   JSKIP,RPAR,IPAR,SAVR,DELTA,E,YIC,YPIC,PWK,WM,IWM,CJ,UROUND,
3160      *   EPLI,SQRTN,RSQRTN,EPCONI,RATEMX,STPTOL,JFLG,ICNFLG,ICNSTR,
3161      *   IERNLS)
3162 C
3163       IF (IERNLS .EQ. 0) RETURN
3164 C
3165 C-----------------------------------------------------------------------
3166 C     BLOCK 3
3167 C     The nonlinear solver was unsuccessful.  Increment NCFN.
3168 C     Return with IDID = -12 if either
3169 C       IERNLS = -1: error is considered unrecoverable,
3170 C       ICOPT = 2: we are doing initialization problem type 2, or
3171 C       NH = MXNH: the maximum number of H values has been tried.
3172 C     Otherwise (problem 1 with IERNLS .GE. 1), reduce H and try again.
3173 C     If IERNLS > 1, restore Y and YPRIME to their original values.
3174 C-----------------------------------------------------------------------
3175 C
3176       IWM(LCFN) = IWM(LCFN) + 1
3177       JSKIP = 0
3178 C
3179       IF (IERNLS .EQ. -1) GO TO 350
3180       IF (ICOPT .EQ. 2) GO TO 350
3181       IF (NH .EQ. MXNH) GO TO 350
3182 C
3183       NH = NH + 1
3184       H = H*RHCUT
3185       CJ = 1.0D0/H
3186 C
3187       IF (IERNLS .EQ. 1) GO TO 200
3188 C
3189       CALL DCOPY (NEQ, PHI(1,1), 1, Y, 1)
3190       CALL DCOPY (NEQ, PHI(1,2), 1, YPRIME, 1)
3191       GO TO 200
3192 C
3193  350  IDID = -12
3194       RETURN
3195 C
3196 C------END OF SUBROUTINE DDASIC-----------------------------------------
3197       END
3198       SUBROUTINE DYYPNW (NEQ, Y, YPRIME, CJ, RL, P, ICOPT, ID, 
3199      *                   YNEW, YPNEW)
3200 C
3201 C***BEGIN PROLOGUE  DYYPNW
3202 C***REFER TO  DLINSK
3203 C***DATE WRITTEN   940830   (YYMMDD)
3204 C
3205 C
3206 C-----------------------------------------------------------------------
3207 C***DESCRIPTION
3208 C
3209 C     DYYPNW calculates the new (Y,YPRIME) pair needed in the
3210 C     linesearch algorithm based on the current lambda value.  It is
3211 C     called by DLINSK and DLINSD.  Based on the ICOPT and ID values,
3212 C     the corresponding entry in Y or YPRIME is updated.
3213 C
3214 C     In addition to the parameters described in the calling programs,
3215 C     the parameters represent
3216 C
3217 C     P      -- Array of length NEQ that contains the current
3218 C               approximate Newton step.
3219 C     RL     -- Scalar containing the current lambda value.
3220 C     YNEW   -- Array of length NEQ containing the updated Y vector.
3221 C     YPNEW  -- Array of length NEQ containing the updated YPRIME
3222 C               vector.
3223 C-----------------------------------------------------------------------
3224 C
3225 C***ROUTINES CALLED (NONE)
3226 C
3227 C***END PROLOGUE  DYYPNW
3228 C
3229 C
3230       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3231       DIMENSION Y(*), YPRIME(*), YNEW(*), YPNEW(*), ID(*), P(*)
3232 C
3233       IF (ICOPT .EQ. 1) THEN
3234          DO 10 I=1,NEQ
3235             IF(ID(I) .LT. 0) THEN
3236                YNEW(I) = Y(I) - RL*P(I)
3237                YPNEW(I) = YPRIME(I)
3238             ELSE
3239                YNEW(I) = Y(I)
3240                YPNEW(I) = YPRIME(I) - RL*CJ*P(I)
3241             ENDIF
3242  10      CONTINUE
3243       ELSE
3244          DO 20 I = 1,NEQ
3245             YNEW(I) = Y(I) - RL*P(I)
3246             YPNEW(I) = YPRIME(I)
3247  20      CONTINUE
3248       ENDIF
3249       RETURN
3250 C----------------------- END OF SUBROUTINE DYYPNW ----------------------
3251       END
3252       SUBROUTINE DDSTP(X,Y,YPRIME,NEQ,RES,JAC,PSOL,H,WT,VT,
3253      *  JSTART,IDID,RPAR,IPAR,PHI,SAVR,DELTA,E,WM,IWM,
3254      *  ALPHA,BETA,GAMMA,PSI,SIGMA,CJ,CJOLD,HOLD,S,HMIN,UROUND,
3255      *  EPLI,SQRTN,RSQRTN,EPCON,IPHASE,JCALC,JFLG,K,KOLD,NS,NONNEG,
3256      *  NTYPE,NLS)
3257 C
3258 C***BEGIN PROLOGUE  DDSTP
3259 C***REFER TO  DDASPK
3260 C***DATE WRITTEN   890101   (YYMMDD)
3261 C***REVISION DATE  900926   (YYMMDD)
3262 C***REVISION DATE  940909   (YYMMDD) (Reset PSI(1), PHI(*,2) at 690)
3263 C
3264 C
3265 C-----------------------------------------------------------------------
3266 C***DESCRIPTION
3267 C
3268 C     DDSTP solves a system of differential/algebraic equations of 
3269 C     the form G(X,Y,YPRIME) = 0, for one step (normally from X to X+H).
3270 C
3271 C     The methods used are modified divided difference, fixed leading 
3272 C     coefficient forms of backward differentiation formulas.  
3273 C     The code adjusts the stepsize and order to control the local error
3274 C     per step.
3275 C
3276 C
3277 C     The parameters represent
3278 C     X  --        Independent variable.
3279 C     Y  --        Solution vector at X.
3280 C     YPRIME --    Derivative of solution vector
3281 C                  after successful step.
3282 C     NEQ --       Number of equations to be integrated.
3283 C     RES --       External user-supplied subroutine
3284 C                  to evaluate the residual.  See RES description
3285 C                  in DDASPK prologue.
3286 C     JAC --       External user-supplied routine to update
3287 C                  Jacobian or preconditioner information in the
3288 C                  nonlinear solver.  See JAC description in DDASPK
3289 C                  prologue.
3290 C     PSOL --      External user-supplied routine to solve
3291 C                  a linear system using preconditioning. 
3292 C                  (This is optional).  See PSOL in DDASPK prologue.
3293 C     H --         Appropriate step size for next step.
3294 C                  Normally determined by the code.
3295 C     WT --        Vector of weights for error criterion used in Newton test.
3296 C     VT --        Masked vector of weights used in error test.
3297 C     JSTART --    Integer variable set 0 for
3298 C                  first step, 1 otherwise.
3299 C     IDID --      Completion code returned from the nonlinear solver.
3300 C                  See IDID description in DDASPK prologue.
3301 C     RPAR,IPAR -- Real and integer parameter arrays that
3302 C                  are used for communication between the
3303 C                  calling program and external user routines.
3304 C                  They are not altered by DNSK
3305 C     PHI --       Array of divided differences used by
3306 C                  DDSTP. The length is NEQ*(K+1), where
3307 C                  K is the maximum order.
3308 C     SAVR --      Work vector for DDSTP of length NEQ.
3309 C     DELTA,E --   Work vectors for DDSTP of length NEQ.
3310 C     WM,IWM --    Real and integer arrays storing
3311 C                  information required by the linear solver.
3312 C
3313 C     The other parameters are information
3314 C     which is needed internally by DDSTP to
3315 C     continue from step to step.
3316 C
3317 C-----------------------------------------------------------------------
3318 C***ROUTINES CALLED
3319 C   NLS, DDWNRM, DDATRP2
3320 C
3321 C***END PROLOGUE  DDSTP
3322 C
3323 C
3324       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
3325       DIMENSION Y(*),YPRIME(*),WT(*),VT(*)
3326       DIMENSION PHI(NEQ,*),SAVR(*),DELTA(*),E(*)
3327       DIMENSION WM(*),IWM(*)
3328       DIMENSION PSI(*),ALPHA(*),BETA(*),GAMMA(*),SIGMA(*)
3329       DIMENSION RPAR(*),IPAR(*)
3330       EXTERNAL  RES, JAC, PSOL, NLS
3331 C
3332       PARAMETER (LMXORD=3)
3333       PARAMETER (LNST=11, LETF=14, LCFN=15)
3334 C
3335 C
3336 C-----------------------------------------------------------------------
3337 C     BLOCK 1.
3338 C     Initialize.  On the first call, set
3339 C     the order to 1 and initialize
3340 C     other variables.
3341 C-----------------------------------------------------------------------
3342 C
3343 C     Initializations for all calls
3344 C
3345       XOLD=X
3346       NCF=0
3347       NEF=0
3348       IF(JSTART .NE. 0) GO TO 120
3349 C
3350 C     If this is the first step, perform
3351 C     other initializations
3352 C
3353       K=1
3354       KOLD=0
3355       HOLD=0.0D0
3356       PSI(1)=H
3357       CJ = 1.D0/H
3358       IPHASE = 0
3359       NS=0
3360 120   CONTINUE
3361 C
3362 C
3363 C
3364 C
3365 C
3366 C-----------------------------------------------------------------------
3367 C     BLOCK 2
3368 C     Compute coefficients of formulas for
3369 C     this step.
3370 C-----------------------------------------------------------------------
3371 200   CONTINUE
3372       KP1=K+1
3373       KP2=K+2
3374       KM1=K-1
3375       IF(H.NE.HOLD.OR.K .NE. KOLD) NS = 0
3376       NS=MIN0(NS+1,KOLD+2)
3377       NSP1=NS+1
3378       IF(KP1 .LT. NS)GO TO 230
3379 C
3380       BETA(1)=1.0D0
3381       ALPHA(1)=1.0D0
3382       TEMP1=H
3383       GAMMA(1)=0.0D0
3384       SIGMA(1)=1.0D0
3385       DO 210 I=2,KP1
3386          TEMP2=PSI(I-1)
3387          PSI(I-1)=TEMP1
3388          BETA(I)=BETA(I-1)*PSI(I-1)/TEMP2
3389          TEMP1=TEMP2+H
3390          ALPHA(I)=H/TEMP1
3391          SIGMA(I)=(I-1)*SIGMA(I-1)*ALPHA(I)
3392          GAMMA(I)=GAMMA(I-1)+ALPHA(I-1)/H
3393 210      CONTINUE
3394       PSI(KP1)=TEMP1
3395 230   CONTINUE
3396 C
3397 C     Compute ALPHAS, ALPHA0
3398 C
3399       ALPHAS = 0.0D0
3400       ALPHA0 = 0.0D0
3401       DO 240 I = 1,K
3402         ALPHAS = ALPHAS - 1.0D0/I
3403         ALPHA0 = ALPHA0 - ALPHA(I)
3404 240     CONTINUE
3405 C
3406 C     Compute leading coefficient CJ
3407 C
3408       CJLAST = CJ
3409       CJ = -ALPHAS/H
3410 C
3411 C     Compute variable stepsize error coefficient CK
3412 C
3413       CK = ABS(ALPHA(KP1) + ALPHAS - ALPHA0)
3414       CK = MAX(CK,ALPHA(KP1))
3415 C
3416 C     Change PHI to PHI STAR
3417 C
3418       IF(KP1 .LT. NSP1) GO TO 280
3419       DO 270 J=NSP1,KP1
3420          DO 260 I=1,NEQ
3421 260         PHI(I,J)=BETA(J)*PHI(I,J)
3422 270      CONTINUE
3423 280   CONTINUE
3424 C
3425 C     Update time
3426 C
3427       X=X+H
3428 C
3429 C     Initialize IDID to 1
3430 C
3431       IDID = 1
3432 C
3433 C
3434 C
3435 C
3436 C
3437 C-----------------------------------------------------------------------
3438 C     BLOCK 3
3439 C     Call the nonlinear system solver to obtain the solution and
3440 C     derivative.
3441 C-----------------------------------------------------------------------
3442 C
3443       CALL NLS(X,Y,YPRIME,NEQ,
3444      *   RES,JAC,PSOL,H,WT,JSTART,IDID,RPAR,IPAR,PHI,GAMMA,
3445      *   SAVR,DELTA,E,WM,IWM,CJ,CJOLD,CJLAST,S,
3446      *   UROUND,EPLI,SQRTN,RSQRTN,EPCON,JCALC,JFLG,KP1,
3447      *   NONNEG,NTYPE,IERNLS)
3448 C
3449       IF(IERNLS .NE. 0)GO TO 600
3450       IF(IDID.eq.-12) RETURN
3451 C
3452 C
3453 C
3454 C
3455 C
3456 C-----------------------------------------------------------------------
3457 C     BLOCK 4
3458 C     Estimate the errors at orders K,K-1,K-2
3459 C     as if constant stepsize was used. Estimate
3460 C     the local error at order K and test
3461 C     whether the current step is successful.
3462 C-----------------------------------------------------------------------
3463 C
3464 C     Estimate errors at orders K,K-1,K-2
3465 C
3466       ENORM = DDWNRM(NEQ,E,VT,RPAR,IPAR)
3467       ERK = SIGMA(K+1)*ENORM
3468       TERK = (K+1)*ERK
3469       EST = ERK
3470       KNEW=K
3471       IF(K .EQ. 1)GO TO 430
3472       DO 405 I = 1,NEQ
3473 405     DELTA(I) = PHI(I,KP1) + E(I)
3474       ERKM1=SIGMA(K)*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR)
3475       TERKM1 = K*ERKM1
3476       IF(K .GT. 2)GO TO 410
3477       IF(TERKM1 .LE. 0.5*TERK)GO TO 420
3478       GO TO 430
3479 410   CONTINUE
3480       DO 415 I = 1,NEQ
3481 415     DELTA(I) = PHI(I,K) + DELTA(I)
3482       ERKM2=SIGMA(K-1)*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR)
3483       TERKM2 = (K-1)*ERKM2
3484       IF(MAX(TERKM1,TERKM2).GT.TERK)GO TO 430
3485 C
3486 C     Lower the order
3487 C
3488 420   CONTINUE
3489       KNEW=K-1
3490       EST = ERKM1
3491 C
3492 C
3493 C     Calculate the local error for the current step
3494 C     to see if the step was successful
3495 C
3496 430   CONTINUE
3497       ERR = CK * ENORM
3498       IF(ERR .GT. 1.0D0)GO TO 600
3499 C
3500 C
3501 C
3502 C
3503 C
3504 C-----------------------------------------------------------------------
3505 C     BLOCK 5
3506 C     The step is successful. Determine
3507 C     the best order and stepsize for
3508 C     the next step. Update the differences
3509 C     for the next step.
3510 C-----------------------------------------------------------------------
3511       IDID=1
3512       IWM(LNST)=IWM(LNST)+1
3513       KDIFF=K-KOLD
3514       KOLD=K
3515       HOLD=H
3516 C
3517 C
3518 C     Estimate the error at order K+1 unless
3519 C        already decided to lower order, or
3520 C        already using maximum order, or
3521 C        stepsize not constant, or
3522 C        order raised in previous step
3523 C
3524       IF(KNEW.EQ.KM1.OR.K.EQ.IWM(LMXORD))IPHASE=1
3525       IF(IPHASE .EQ. 0)GO TO 545
3526       IF(KNEW.EQ.KM1)GO TO 540
3527       IF(K.EQ.IWM(LMXORD)) GO TO 550
3528       IF(KP1.GE.NS.OR.KDIFF.EQ.1)GO TO 550
3529       DO 510 I=1,NEQ
3530 510      DELTA(I)=E(I)-PHI(I,KP2)
3531       ERKP1 = (1.0D0/(K+2))*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR)
3532       TERKP1 = (K+2)*ERKP1
3533       IF(K.GT.1)GO TO 520
3534       IF(TERKP1.GE.0.5D0*TERK)GO TO 550
3535       GO TO 530
3536 520   IF(TERKM1.LE.MIN(TERK,TERKP1))GO TO 540
3537       IF(TERKP1.GE.TERK.OR.K.EQ.IWM(LMXORD))GO TO 550
3538 C
3539 C     Raise order
3540 C
3541 530   K=KP1
3542       EST = ERKP1
3543       GO TO 550
3544 C
3545 C     Lower order
3546 C
3547 540   K=KM1
3548       EST = ERKM1
3549       GO TO 550
3550 C
3551 C     If IPHASE = 0, increase order by one and multiply stepsize by
3552 C     factor two
3553 C
3554 545   K = KP1
3555       HNEW = H*2.0D0
3556       H = HNEW
3557       GO TO 575
3558 C
3559 C
3560 C     Determine the appropriate stepsize for
3561 C     the next step.
3562 C
3563 550   HNEW=H
3564       TEMP2=K+1
3565       R=(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2)
3566       IF(R .LT. 2.0D0) GO TO 555
3567       HNEW = 2.0D0*H
3568       GO TO 560
3569 555   IF(R .GT. 1.0D0) GO TO 560
3570       R = MAX(0.5D0,MIN(0.9D0,R))
3571       HNEW = H*R
3572 560   H=HNEW
3573 C
3574 C
3575 C     Update differences for next step
3576 C
3577 575   CONTINUE
3578       IF(KOLD.EQ.IWM(LMXORD))GO TO 585
3579       DO 580 I=1,NEQ
3580 580      PHI(I,KP2)=E(I)
3581 585   CONTINUE
3582       DO 590 I=1,NEQ
3583 590      PHI(I,KP1)=PHI(I,KP1)+E(I)
3584       DO 595 J1=2,KP1
3585          J=KP1-J1+1
3586          DO 595 I=1,NEQ
3587 595      PHI(I,J)=PHI(I,J)+PHI(I,J+1)
3588       JSTART = 1
3589       RETURN
3590 C
3591 C
3592 C
3593 C
3594 C
3595 C-----------------------------------------------------------------------
3596 C     BLOCK 6
3597 C     The step is unsuccessful. Restore X,PSI,PHI
3598 C     Determine appropriate stepsize for
3599 C     continuing the integration, or exit with
3600 C     an error flag if there have been many
3601 C     failures.
3602 C-----------------------------------------------------------------------
3603 600   IPHASE = 1
3604 C
3605 C     Restore X,PHI,PSI
3606 C
3607       X=XOLD
3608       IF(KP1.LT.NSP1)GO TO 630
3609       DO 620 J=NSP1,KP1
3610          TEMP1=1.0D0/BETA(J)
3611          DO 610 I=1,NEQ
3612 610         PHI(I,J)=TEMP1*PHI(I,J)
3613 620      CONTINUE
3614 630   CONTINUE
3615       DO 640 I=2,KP1
3616 640      PSI(I-1)=PSI(I)-H
3617 C
3618 C
3619 C     Test whether failure is due to nonlinear solver
3620 C     or error test
3621 C
3622       IF(IERNLS .EQ. 0)GO TO 660
3623       IWM(LCFN)=IWM(LCFN)+1
3624 C
3625 C
3626 C     The nonlinear solver failed to converge.
3627 C     Determine the cause of the failure and take appropriate action.
3628 C     If IERNLS .LT. 0, then return.  Otherwise, reduce the stepsize
3629 C     and try again, unless too many failures have occurred.
3630 C
3631       IF (IERNLS .LT. 0) GO TO 675
3632       NCF = NCF + 1
3633       R = 0.25D0
3634       H = H*R
3635       IF (NCF .LT. 10 .AND. ABS(H) .GE. HMIN) GO TO 690
3636       IF (IDID .EQ. 1) IDID = -7
3637       IF (NEF .GE. 3) IDID = -9
3638       GO TO 675
3639 C
3640 C
3641 C     The nonlinear solver converged, and the cause
3642 C     of the failure was the error estimate
3643 C     exceeding the tolerance.
3644 C
3645 660   NEF=NEF+1
3646       IWM(LETF)=IWM(LETF)+1
3647       IF (NEF .GT. 1) GO TO 665
3648 C
3649 C     On first error test failure, keep current order or lower
3650 C     order by one.  Compute new stepsize based on differences
3651 C     of the solution.
3652 C
3653       K = KNEW
3654       TEMP2 = K + 1
3655       R = 0.90D0*(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2)
3656       R = MAX(0.25D0,MIN(0.9D0,R))
3657       H = H*R
3658       IF (ABS(H) .GE. HMIN) GO TO 690
3659       IDID = -6
3660       GO TO 675
3661 C
3662 C     On second error test failure, use the current order or
3663 C     decrease order by one.  Reduce the stepsize by a factor of
3664 C     one quarter.
3665 C
3666 665   IF (NEF .GT. 2) GO TO 670
3667       K = KNEW
3668       R = 0.25D0
3669       H = R*H
3670       IF (ABS(H) .GE. HMIN) GO TO 690
3671       IDID = -6
3672       GO TO 675
3673 C
3674 C     On third and subsequent error test failures, set the order to
3675 C     one, and reduce the stepsize by a factor of one quarter.
3676 C
3677 670   K = 1
3678       R = 0.25D0
3679       H = R*H
3680       IF (ABS(H) .GE. HMIN) GO TO 690
3681       IDID = -6
3682       GO TO 675
3683 C
3684 C
3685 C
3686 C
3687 C     For all crashes, restore Y to its last value,
3688 C     interpolate to find YPRIME at last X, and return.
3689 C
3690 C     Before returning, verify that the user has not set
3691 C     IDID to a nonnegative value.  If the user has set IDID
3692 C     to a nonnegative value, then reset IDID to be -7, indicating
3693 C     a failure in the nonlinear system solver.
3694 C
3695 675   CONTINUE
3696       CALL DDATRP2(X,X,Y,YPRIME,NEQ,K,PHI,PSI)
3697       JSTART = 1
3698       IF (IDID .GE. 0) IDID = -7
3699       RETURN
3700 C
3701 C
3702 C     Go back and try this step again.  
3703 C     If this is the first step, reset PSI(1) and rescale PHI(*,2).
3704 C
3705 690   IF (KOLD .EQ. 0) THEN
3706         PSI(1) = H
3707         DO 695 I = 1,NEQ
3708 695       PHI(I,2) = R*PHI(I,2)
3709         ENDIF
3710       GO TO 200
3711 C
3712 C------END OF SUBROUTINE DDSTP------------------------------------------
3713       END
3714       SUBROUTINE DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR)
3715 C
3716 C***BEGIN PROLOGUE  DCNSTR
3717 C***DATE WRITTEN   950808   (YYMMDD)
3718 C***REVISION DATE  950814   (YYMMDD)
3719 C
3720 C
3721 C-----------------------------------------------------------------------
3722 C***DESCRIPTION
3723 C
3724 C This subroutine checks for constraint violations in the proposed 
3725 C new approximate solution YNEW.
3726 C If a constraint violation occurs, then a new step length, TAU,
3727 C is calculated, and this value is to be given to the linesearch routine
3728 C to calculate a new approximate solution YNEW.
3729 C
3730 C On entry:
3731 C
3732 C   NEQ    -- size of the nonlinear system, and the length of arrays
3733 C             Y, YNEW and ICNSTR.
3734 C
3735 C   Y      -- real array containing the current approximate y.
3736 C
3737 C   YNEW   -- real array containing the new approximate y.
3738 C
3739 C   ICNSTR -- INTEGER array of length NEQ containing flags indicating
3740 C             which entries in YNEW are to be constrained.
3741 C             if ICNSTR(I) =  2, then YNEW(I) must be .GT. 0,
3742 C             if ICNSTR(I) =  1, then YNEW(I) must be .GE. 0,
3743 C             if ICNSTR(I) = -1, then YNEW(I) must be .LE. 0, while
3744 C             if ICNSTR(I) = -2, then YNEW(I) must be .LT. 0, while
3745 C             if ICNSTR(I) =  0, then YNEW(I) is not constrained.
3746 C
3747 C   RLX    -- real scalar restricting update, if ICNSTR(I) = 2 or -2,
3748 C             to ABS( (YNEW-Y)/Y ) < FAC2*RLX in component I.
3749 C
3750 C   TAU    -- the current size of the step length for the linesearch.
3751 C
3752 C On return
3753 C
3754 C   TAU    -- the adjusted size of the step length if a constraint
3755 C             violation occurred (otherwise, it is unchanged).  it is
3756 C             the step length to give to the linesearch routine.
3757 C
3758 C   IRET   -- output flag.
3759 C             IRET=0 means that YNEW satisfied all constraints.
3760 C             IRET=1 means that YNEW failed to satisfy all the
3761 C                    constraints, and a new linesearch step
3762 C                    must be computed.
3763 C
3764 C   IVAR   -- index of variable causing constraint to be violated.
3765 C
3766 C-----------------------------------------------------------------------
3767       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
3768       DIMENSION Y(NEQ), YNEW(NEQ), ICNSTR(NEQ)
3769       SAVE FAC, FAC2, ZERO
3770       DATA FAC /0.6D0/, FAC2 /0.9D0/, ZERO/0.0D0/
3771 C-----------------------------------------------------------------------
3772 C Check constraints for proposed new step YNEW.  If a constraint has
3773 C been violated, then calculate a new step length, TAU, to be
3774 C used in the linesearch routine.
3775 C-----------------------------------------------------------------------
3776       IRET = 0
3777       RDYMX = ZERO
3778       IVAR = 0
3779       DO 100 I = 1,NEQ
3780 C
3781          IF (ICNSTR(I) .EQ. 2) THEN
3782             RDY = ABS( (YNEW(I)-Y(I))/Y(I) )
3783             IF (RDY .GT. RDYMX) THEN
3784                RDYMX = RDY
3785                IVAR = I
3786             ENDIF
3787             IF (YNEW(I) .LE. ZERO) THEN
3788                TAU = FAC*TAU
3789                IVAR = I
3790                IRET = 1
3791                RETURN
3792             ENDIF
3793 C
3794          ELSEIF (ICNSTR(I) .EQ. 1) THEN
3795             IF (YNEW(I) .LT. ZERO) THEN
3796                TAU = FAC*TAU
3797                IVAR = I
3798                IRET = 1
3799                RETURN
3800             ENDIF
3801 C
3802          ELSEIF (ICNSTR(I) .EQ. -1) THEN
3803             IF (YNEW(I) .GT. ZERO) THEN
3804                TAU = FAC*TAU
3805                IVAR = I
3806                IRET = 1
3807                RETURN
3808             ENDIF
3809 C
3810          ELSEIF (ICNSTR(I) .EQ. -2) THEN
3811             RDY = ABS( (YNEW(I)-Y(I))/Y(I) )
3812             IF (RDY .GT. RDYMX) THEN
3813                RDYMX = RDY
3814                IVAR = I
3815             ENDIF
3816             IF (YNEW(I) .GE. ZERO) THEN
3817                TAU = FAC*TAU
3818                IVAR = I
3819                IRET = 1
3820                RETURN
3821             ENDIF
3822 C
3823          ENDIF
3824  100  CONTINUE
3825
3826       IF(RDYMX .GE. RLX) THEN
3827          TAU = FAC2*TAU*RLX/RDYMX
3828          IRET = 1
3829       ENDIF
3830 C
3831       RETURN
3832 C----------------------- END OF SUBROUTINE DCNSTR ----------------------
3833       END
3834       SUBROUTINE DCNST0 (NEQ, Y, ICNSTR, IRET)
3835 C
3836 C***BEGIN PROLOGUE  DCNST0
3837 C***DATE WRITTEN   950808   (YYMMDD)
3838 C***REVISION DATE  950808   (YYMMDD)
3839 C
3840 C
3841 C-----------------------------------------------------------------------
3842 C***DESCRIPTION
3843 C
3844 C This subroutine checks for constraint violations in the initial 
3845 C approximate solution u.
3846 C
3847 C On entry
3848 C
3849 C   NEQ    -- size of the nonlinear system, and the length of arrays
3850 C             Y and ICNSTR.
3851 C
3852 C   Y      -- real array containing the initial approximate root.
3853 C
3854 C   ICNSTR -- INTEGER array of length NEQ containing flags indicating
3855 C             which entries in Y are to be constrained.
3856 C             if ICNSTR(I) =  2, then Y(I) must be .GT. 0,
3857 C             if ICNSTR(I) =  1, then Y(I) must be .GE. 0,
3858 C             if ICNSTR(I) = -1, then Y(I) must be .LE. 0, while
3859 C             if ICNSTR(I) = -2, then Y(I) must be .LT. 0, while
3860 C             if ICNSTR(I) =  0, then Y(I) is not constrained.
3861 C
3862 C On return
3863 C
3864 C   IRET   -- output flag.
3865 C             IRET=0    means that u satisfied all constraints.
3866 C             IRET.NE.0 means that Y(IRET) failed to satisfy its
3867 C                       constraint.
3868 C
3869 C-----------------------------------------------------------------------
3870       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
3871       DIMENSION Y(NEQ), ICNSTR(NEQ)
3872       SAVE ZERO
3873       DATA ZERO/0.D0/
3874 C-----------------------------------------------------------------------
3875 C Check constraints for initial Y.  If a constraint has been violated,
3876 C set IRET = I to signal an error return to calling routine.
3877 C-----------------------------------------------------------------------
3878       IRET = 0
3879       DO 100 I = 1,NEQ
3880          IF (ICNSTR(I) .EQ. 2) THEN
3881             IF (Y(I) .LE. ZERO) THEN
3882                IRET = I
3883                RETURN
3884             ENDIF
3885          ELSEIF (ICNSTR(I) .EQ. 1) THEN
3886             IF (Y(I) .LT. ZERO) THEN
3887                IRET = I
3888                RETURN
3889             ENDIF 
3890          ELSEIF (ICNSTR(I) .EQ. -1) THEN
3891             IF (Y(I) .GT. ZERO) THEN
3892                IRET = I
3893                RETURN
3894             ENDIF 
3895          ELSEIF (ICNSTR(I) .EQ. -2) THEN
3896             IF (Y(I) .GE. ZERO) THEN
3897                IRET = I
3898                RETURN
3899             ENDIF 
3900         ENDIF
3901  100  CONTINUE
3902       RETURN
3903 C----------------------- END OF SUBROUTINE DCNST0 ----------------------
3904       END
3905       SUBROUTINE DDAWTS2(NEQ,IWT,RTOL,ATOL,Y,WT,RPAR,IPAR)
3906 C
3907 C***BEGIN PROLOGUE  DDAWTS2
3908 C***REFER TO  DDASPK
3909 C***ROUTINES CALLED  (NONE)
3910 C***DATE WRITTEN   890101   (YYMMDD)
3911 C***REVISION DATE  900926   (YYMMDD)
3912 C***END PROLOGUE  DDAWTS2
3913 C-----------------------------------------------------------------------
3914 C     This subroutine sets the error weight vector,
3915 C     WT, according to WT(I)=RTOL(I)*ABS(Y(I))+ATOL(I),
3916 C     I = 1 to NEQ.
3917 C     RTOL and ATOL are scalars if IWT = 0,
3918 C     and vectors if IWT = 1.
3919 C-----------------------------------------------------------------------
3920 C
3921       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
3922       DIMENSION RTOL(*),ATOL(*),Y(*),WT(*)
3923       DIMENSION RPAR(*),IPAR(*)
3924       RTOLI=RTOL(1)
3925       ATOLI=ATOL(1)
3926       DO 20 I=1,NEQ
3927          IF (IWT .EQ.0) GO TO 10
3928            RTOLI=RTOL(I)
3929            ATOLI=ATOL(I)
3930 10         WT(I)=RTOLI*ABS(Y(I))+ATOLI
3931 20         CONTINUE
3932       RETURN
3933 C
3934 C------END OF SUBROUTINE DDAWTS2----------------------------------
3935       END
3936       SUBROUTINE DINVWT(NEQ,WT,IER)
3937 C
3938 C***BEGIN PROLOGUE  DINVWT
3939 C***REFER TO  DDASPK
3940 C***ROUTINES CALLED  (NONE)
3941 C***DATE WRITTEN   950125   (YYMMDD)
3942 C***END PROLOGUE  DINVWT
3943 C-----------------------------------------------------------------------
3944 C     This subroutine checks the error weight vector WT, of length NEQ,
3945 C     for components that are .le. 0, and if none are found, it
3946 C     inverts the WT(I) in place.  This replaces division operations
3947 C     with multiplications in all norm evaluations.
3948 C     IER is returned as 0 if all WT(I) were found positive,
3949 C     and the first I with WT(I) .le. 0.0 otherwise.
3950 C-----------------------------------------------------------------------
3951 C
3952       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
3953       DIMENSION WT(*)
3954 C
3955       DO 10 I = 1,NEQ
3956         IF (WT(I) .LE. 0.0D0) GO TO 30
3957  10     CONTINUE
3958       DO 20 I = 1,NEQ
3959  20     WT(I) = 1.0D0/WT(I)
3960       IER = 0
3961       RETURN
3962 C
3963  30   IER = I
3964       RETURN
3965 C
3966 C------END OF SUBROUTINE DINVWT-----------------------------------------
3967       END
3968       SUBROUTINE DDATRP2(X,XOUT,YOUT,YPOUT,NEQ,KOLD,PHI,PSI)
3969 C
3970 C***BEGIN PROLOGUE  DDATRP2
3971 C***REFER TO  DDASPK
3972 C***ROUTINES CALLED  (NONE)
3973 C***DATE WRITTEN   890101   (YYMMDD)
3974 C***REVISION DATE  900926   (YYMMDD)
3975 C***END PROLOGUE  DDATRP2
3976 C
3977 C-----------------------------------------------------------------------
3978 C     The methods in subroutine DDSTP use polynomials
3979 C     to approximate the solution.  DDATRP2 approximates the
3980 C     solution and its derivative at time XOUT by evaluating
3981 C     one of these polynomials, and its derivative, there.
3982 C     Information defining this polynomial is passed from
3983 C     DDSTP, so DDATRP2 cannot be used alone.
3984 C
3985 C     The parameters are
3986 C
3987 C     X     The current time in the integration.
3988 C     XOUT  The time at which the solution is desired.
3989 C     YOUT  The interpolated approximation to Y at XOUT.
3990 C           (This is output.)
3991 C     YPOUT The interpolated approximation to YPRIME at XOUT.
3992 C           (This is output.)
3993 C     NEQ   Number of equations.
3994 C     KOLD  Order used on last successful step.
3995 C     PHI   Array of scaled divided differences of Y.
3996 C     PSI   Array of past stepsize history.
3997 C-----------------------------------------------------------------------
3998 C
3999       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
4000       DIMENSION YOUT(*),YPOUT(*)
4001       DIMENSION PHI(NEQ,*),PSI(*)
4002       KOLDP1=KOLD+1
4003       TEMP1=XOUT-X
4004       DO 10 I=1,NEQ
4005          YOUT(I)=PHI(I,1)
4006 10       YPOUT(I)=0.0D0
4007       C=1.0D0
4008       D=0.0D0
4009       GAMMA=TEMP1/PSI(1)
4010       DO 30 J=2,KOLDP1
4011          D=D*GAMMA+C/PSI(J-1)
4012          C=C*GAMMA
4013          GAMMA=(TEMP1+PSI(J-1))/PSI(J)
4014          DO 20 I=1,NEQ
4015             YOUT(I)=YOUT(I)+C*PHI(I,J)
4016 20          YPOUT(I)=YPOUT(I)+D*PHI(I,J)
4017 30       CONTINUE
4018       RETURN
4019 C
4020 C------END OF SUBROUTINE DDATRP2---------------------------------
4021       END
4022       DOUBLE PRECISION FUNCTION DDWNRM(NEQ,V,RWT,RPAR,IPAR)
4023 C
4024 C***BEGIN PROLOGUE  DDWNRM
4025 C***ROUTINES CALLED  (NONE)
4026 C***DATE WRITTEN   890101   (YYMMDD)
4027 C***REVISION DATE  900926   (YYMMDD)
4028 C***END PROLOGUE  DDWNRM
4029 C-----------------------------------------------------------------------
4030 C     This function routine computes the weighted
4031 C     root-mean-square norm of the vector of length
4032 C     NEQ contained in the array V, with reciprocal weights
4033 C     contained in the array RWT of length NEQ.
4034 C        DDWNRM=SQRT((1/NEQ)*SUM(V(I)*RWT(I))**2)
4035 C-----------------------------------------------------------------------
4036 C
4037       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
4038       DIMENSION V(*),RWT(*)
4039       DIMENSION RPAR(*),IPAR(*)
4040       DDWNRM = 0.0D0
4041       VMAX = 0.0D0
4042       DO 10 I = 1,NEQ
4043         IF(ABS(V(I)*RWT(I)) .GT. VMAX) VMAX = ABS(V(I)*RWT(I))
4044 10    CONTINUE
4045       IF(VMAX .LE. 0.0D0) GO TO 30
4046       SUM = 0.0D0
4047       DO 20 I = 1,NEQ
4048 20      SUM = SUM + ((V(I)*RWT(I))/VMAX)**2
4049       DDWNRM = VMAX*SQRT(SUM/NEQ)
4050 30    CONTINUE
4051       RETURN
4052 C
4053 C------END OF FUNCTION DDWNRM-------------------------------------------
4054       END
4055       SUBROUTINE DDASID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JACD,PDUM,H,TSCALE,
4056      *  WT,JSDUM,RPAR,IPAR,DUMSVR,DELTA,R,YIC,YPIC,DUMPWK,WM,IWM,CJ,
4057      *  UROUND,DUME,DUMS,DUMR,EPCON,RATEMX,STPTOL,JFDUM,
4058      *  ICNFLG,ICNSTR,IERNLS)
4059 C
4060 C***BEGIN PROLOGUE  DDASID
4061 C***REFER TO  DDASPK
4062 C***DATE WRITTEN   940701   (YYMMDD)
4063 C***REVISION DATE  950808   (YYMMDD)
4064 C***REVISION DATE  951110   Removed unreachable block 390.
4065 C***REVISION DATE  000628   TSCALE argument added.
4066 C
4067 C
4068 C-----------------------------------------------------------------------
4069 C***DESCRIPTION
4070 C
4071 C
4072 C     DDASID solves a nonlinear system of algebraic equations of the
4073 C     form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in
4074 C     the initial conditions.
4075 C
4076 C     The method used is a modified Newton scheme.
4077 C
4078 C     The parameters represent
4079 C
4080 C     X         -- Independent variable.
4081 C     Y         -- Solution vector.
4082 C     YPRIME    -- Derivative of solution vector.
4083 C     NEQ       -- Number of unknowns.
4084 C     ICOPT     -- Initial condition option chosen (1 or 2).
4085 C     ID        -- Array of dimension NEQ, which must be initialized
4086 C                  if ICOPT = 1.  See DDASIC.
4087 C     RES       -- External user-supplied subroutine to evaluate the
4088 C                  residual.  See RES description in DDASPK prologue.
4089 C     JACD      -- External user-supplied routine to evaluate the
4090 C                  Jacobian.  See JAC description for the case
4091 C                  INFO(12) = 0 in the DDASPK prologue.
4092 C     PDUM      -- Dummy argument.
4093 C     H         -- Scaling factor for this initial condition calc.
4094 C     TSCALE    -- Scale factor in T, used for stopping tests if nonzero.
4095 C     WT        -- Vector of weights for error criterion.
4096 C     JSDUM     -- Dummy argument.
4097 C     RPAR,IPAR -- Real and integer arrays used for communication
4098 C                  between the calling program and external user
4099 C                  routines.  They are not altered within DASPK.
4100 C     DUMSVR    -- Dummy argument.
4101 C     DELTA     -- Work vector for NLS of length NEQ.
4102 C     R         -- Work vector for NLS of length NEQ.
4103 C     YIC,YPIC  -- Work vectors for NLS, each of length NEQ.
4104 C     DUMPWK    -- Dummy argument.
4105 C     WM,IWM    -- Real and integer arrays storing matrix information
4106 C                  such as the matrix of partial derivatives,
4107 C                  permutation vector, and various other information.
4108 C     CJ        -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2).
4109 C     UROUND    -- Unit roundoff.
4110 C     DUME      -- Dummy argument.
4111 C     DUMS      -- Dummy argument.
4112 C     DUMR      -- Dummy argument.
4113 C     EPCON     -- Tolerance to test for convergence of the Newton
4114 C                  iteration.
4115 C     RATEMX    -- Maximum convergence rate for which Newton iteration
4116 C                  is considered converging.
4117 C     JFDUM     -- Dummy argument.
4118 C     STPTOL    -- Tolerance used in calculating the minimum lambda
4119 C                  value allowed.
4120 C     ICNFLG    -- Integer scalar.  If nonzero, then constraint
4121 C                  violations in the proposed new approximate solution
4122 C                  will be checked for, and the maximum step length 
4123 C                  will be adjusted accordingly.
4124 C     ICNSTR    -- Integer array of length NEQ containing flags for
4125 C                  checking constraints.
4126 C     IERNLS    -- Error flag for nonlinear solver.
4127 C                   0   ==> nonlinear solver converged.
4128 C                   1,2 ==> recoverable error inside nonlinear solver.
4129 C                           1 => retry with current Y, YPRIME
4130 C                           2 => retry with original Y, YPRIME
4131 C                  -1   ==> unrecoverable error in nonlinear solver.
4132 C
4133 C     All variables with "DUM" in their names are dummy variables
4134 C     which are not used in this routine.
4135 C
4136 C-----------------------------------------------------------------------
4137 C
4138 C***ROUTINES CALLED
4139 C   RES, DMATD, DNSID
4140 C
4141 C***END PROLOGUE  DDASID
4142 C
4143 C
4144       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
4145       DIMENSION Y(*),YPRIME(*),ID(*),WT(*),ICNSTR(*)
4146       DIMENSION DELTA(*),R(*),YIC(*),YPIC(*)
4147       DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*)
4148       EXTERNAL  RES, JACD
4149 C
4150       PARAMETER (LNRE=12, LNJE=13, LMXNIT=32, LMXNJ=33)
4151 C
4152 C
4153 C     Perform initializations.
4154 C
4155       MXNIT = IWM(LMXNIT)
4156       MXNJ = IWM(LMXNJ)
4157       IERNLS = 0
4158       NJ = 0
4159 C
4160 C     Call RES to initialize DELTA.
4161 C
4162       IRES = 0
4163       IWM(LNRE) = IWM(LNRE) + 1
4164       CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
4165       IF (IRES .LT. 0) GO TO 370
4166 C
4167 C     Looping point for updating the Jacobian.
4168 C
4169 300   CONTINUE
4170 C
4171 C     Initialize all error flags to zero.
4172 C
4173       IERJ = 0
4174       IRES = 0
4175       IERNEW = 0
4176 C
4177 C     Reevaluate the iteration matrix, J = dG/dY + CJ*dG/dYPRIME,
4178 C     where G(X,Y,YPRIME) = 0.
4179 C
4180       NJ = NJ + 1
4181       IWM(LNJE)=IWM(LNJE)+1
4182       CALL DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IERJ,WT,R,
4183      *              WM,IWM,RES,IRES,UROUND,JACD,RPAR,IPAR)
4184       IF (IRES .LT. 0 .OR. IERJ .NE. 0) GO TO 370
4185 C
4186 C     Call the nonlinear Newton solver for up to MXNIT iterations.
4187 C
4188       CALL DNSID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,WT,RPAR,IPAR,DELTA,R,
4189      *     YIC,YPIC,WM,IWM,CJ,TSCALE,EPCON,RATEMX,MXNIT,STPTOL,
4190      *     ICNFLG,ICNSTR,IERNEW)
4191 C
4192       IF (IERNEW .EQ. 1 .AND. NJ .LT. MXNJ) THEN
4193 C
4194 C        MXNIT iterations were done, the convergence rate is < 1,
4195 C        and the number of Jacobian evaluations is less than MXNJ.
4196 C        Call RES, reevaluate the Jacobian, and try again.
4197 C
4198          IWM(LNRE)=IWM(LNRE)+1
4199          CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
4200          IF (IRES .LT. 0) GO TO 370
4201          GO TO 300
4202          ENDIF
4203 C
4204       IF (IERNEW .NE. 0) GO TO 380
4205
4206       RETURN
4207 C
4208 C
4209 C     Unsuccessful exits from nonlinear solver.
4210 C     Compute IERNLS accordingly.
4211 C
4212 370   IERNLS = 2
4213       IF (IRES .LE. -2) IERNLS = -1
4214       RETURN
4215 C
4216 380   IERNLS = MIN(IERNEW,2)
4217       RETURN
4218 C
4219 C------END OF SUBROUTINE DDASID-----------------------------------------
4220       END
4221       SUBROUTINE DNSID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,WT,RPAR,IPAR,
4222      *   DELTA,R,YIC,YPIC,WM,IWM,CJ,TSCALE,EPCON,RATEMX,MAXIT,STPTOL,
4223      *   ICNFLG,ICNSTR,IERNEW)
4224 C
4225 C***BEGIN PROLOGUE  DNSID
4226 C***REFER TO  DDASPK
4227 C***DATE WRITTEN   940701   (YYMMDD)
4228 C***REVISION DATE  950713   (YYMMDD)
4229 C***REVISION DATE  000628   TSCALE argument added.
4230 C
4231 C
4232 C-----------------------------------------------------------------------
4233 C***DESCRIPTION
4234 C
4235 C     DNSID solves a nonlinear system of algebraic equations of the
4236 C     form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME
4237 C     in the initial conditions.
4238 C
4239 C     The method used is a modified Newton scheme.
4240 C
4241 C     The parameters represent
4242 C
4243 C     X         -- Independent variable.
4244 C     Y         -- Solution vector.
4245 C     YPRIME    -- Derivative of solution vector.
4246 C     NEQ       -- Number of unknowns.
4247 C     ICOPT     -- Initial condition option chosen (1 or 2).
4248 C     ID        -- Array of dimension NEQ, which must be initialized
4249 C                  if ICOPT = 1.  See DDASIC.
4250 C     RES       -- External user-supplied subroutine to evaluate the
4251 C                  residual.  See RES description in DDASPK prologue.
4252 C     WT        -- Vector of weights for error criterion.
4253 C     RPAR,IPAR -- Real and integer arrays used for communication
4254 C                  between the calling program and external user
4255 C                  routines.  They are not altered within DASPK.
4256 C     DELTA     -- Residual vector on entry, and work vector of
4257 C                  length NEQ for DNSID.
4258 C     WM,IWM    -- Real and integer arrays storing matrix information
4259 C                  such as the matrix of partial derivatives,
4260 C                  permutation vector, and various other information.
4261 C     CJ        -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2).
4262 C     TSCALE    -- Scale factor in T, used for stopping tests if nonzero.
4263 C     R         -- Array of length NEQ used as workspace by the 
4264 C                  linesearch routine DLINSD.
4265 C     YIC,YPIC  -- Work vectors for DLINSD, each of length NEQ.
4266 C     EPCON     -- Tolerance to test for convergence of the Newton
4267 C                  iteration.
4268 C     RATEMX    -- Maximum convergence rate for which Newton iteration
4269 C                  is considered converging.
4270 C     MAXIT     -- Maximum allowed number of Newton iterations.
4271 C     STPTOL    -- Tolerance used in calculating the minimum lambda
4272 C                  value allowed.
4273 C     ICNFLG    -- Integer scalar.  If nonzero, then constraint
4274 C                  violations in the proposed new approximate solution
4275 C                  will be checked for, and the maximum step length 
4276 C                  will be adjusted accordingly.
4277 C     ICNSTR    -- Integer array of length NEQ containing flags for
4278 C                  checking constraints.
4279 C     IERNEW    -- Error flag for Newton iteration.
4280 C                   0  ==> Newton iteration converged.
4281 C                   1  ==> failed to converge, but RATE .le. RATEMX.
4282 C                   2  ==> failed to converge, RATE .gt. RATEMX.
4283 C                   3  ==> other recoverable error (IRES = -1, or
4284 C                          linesearch failed).
4285 C                  -1  ==> unrecoverable error (IRES = -2).
4286 C
4287 C-----------------------------------------------------------------------
4288 C
4289 C***ROUTINES CALLED
4290 C   DSLVD, DDWNRM, DLINSD, DCOPY
4291 C
4292 C***END PROLOGUE  DNSID
4293 C
4294 C
4295       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
4296       DIMENSION Y(*),YPRIME(*),WT(*),R(*)
4297       DIMENSION ID(*),DELTA(*), YIC(*), YPIC(*)
4298       DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*)
4299       DIMENSION ICNSTR(*)
4300       EXTERNAL  RES
4301 C
4302       PARAMETER (LNNI=19, LLSOFF=35)
4303 C
4304 C
4305 C     Initializations.  M is the Newton iteration counter.
4306 C
4307       LSOFF = IWM(LLSOFF)
4308       M = 0
4309       RATE = 1.0D0
4310       RLX = 0.4D0
4311 C
4312 C     Compute a new step vector DELTA by back-substitution.
4313 C
4314       CALL DSLVD (NEQ, DELTA, WM, IWM)
4315 C
4316 C     Get norm of DELTA.  Return now if norm(DELTA) .le. EPCON.
4317 C
4318       DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR)
4319       FNRM = DELNRM
4320       IF (TSCALE .GT. 0.0D0) FNRM = FNRM*TSCALE*ABS(CJ)
4321       IF (FNRM .LE. EPCON) RETURN
4322 C
4323 C     Newton iteration loop.
4324 C
4325  300  CONTINUE
4326       IWM(LNNI) = IWM(LNNI) + 1
4327 C
4328 C     Call linesearch routine for global strategy and set RATE
4329 C
4330       OLDFNM = FNRM
4331 C
4332       CALL DLINSD (NEQ, Y, X, YPRIME, CJ, TSCALE, DELTA, DELNRM, WT,
4333      *             LSOFF, STPTOL, IRET, RES, IRES, WM, IWM, FNRM, ICOPT,
4334      *             ID, R, YIC, YPIC, ICNFLG, ICNSTR, RLX, RPAR, IPAR)
4335 C
4336       RATE = FNRM/OLDFNM
4337 C
4338 C     Check for error condition from linesearch.
4339       IF (IRET .NE. 0) GO TO 390
4340 C
4341 C     Test for convergence of the iteration, and return or loop.
4342 C
4343       IF (FNRM .LE. EPCON) RETURN
4344 C
4345 C     The iteration has not yet converged.  Update M.
4346 C     Test whether the maximum number of iterations have been tried.
4347 C
4348       M = M + 1
4349       IF (M .GE. MAXIT) GO TO 380
4350 C
4351 C     Copy the residual to DELTA and its norm to DELNRM, and loop for
4352 C     another iteration.
4353 C
4354       CALL DCOPY (NEQ, R, 1, DELTA, 1)
4355       DELNRM = FNRM      
4356       GO TO 300
4357 C
4358 C     The maximum number of iterations was done.  Set IERNEW and return.
4359 C
4360  380  IF (RATE .LE. RATEMX) THEN
4361          IERNEW = 1
4362       ELSE
4363          IERNEW = 2
4364       ENDIF
4365       RETURN
4366 C
4367  390  IF (IRES .LE. -2) THEN
4368          IERNEW = -1
4369       ELSE
4370          IERNEW = 3
4371       ENDIF
4372       RETURN
4373 C
4374 C
4375 C------END OF SUBROUTINE DNSID------------------------------------------
4376       END
4377       SUBROUTINE DLINSD (NEQ, Y, T, YPRIME, CJ, TSCALE, P, PNRM, WT,
4378      *                   LSOFF, STPTOL, IRET, RES, IRES, WM, IWM,
4379      *                   FNRM, ICOPT, ID, R, YNEW, YPNEW, ICNFLG,
4380      *                   ICNSTR, RLX, RPAR, IPAR)
4381 C
4382 C***BEGIN PROLOGUE  DLINSD
4383 C***REFER TO  DNSID
4384 C***DATE WRITTEN   941025   (YYMMDD)
4385 C***REVISION DATE  941215   (YYMMDD)
4386 C***REVISION DATE  960129   Moved line RL = ONE to top block.
4387 C***REVISION DATE  000628   TSCALE argument added.
4388 C
4389 C
4390 C-----------------------------------------------------------------------
4391 C***DESCRIPTION
4392 C
4393 C     DLINSD uses a linesearch algorithm to calculate a new (Y,YPRIME)
4394 C     pair (YNEW,YPNEW) such that 
4395 C
4396 C     f(YNEW,YPNEW) .le. (1 - 2*ALPHA*RL)*f(Y,YPRIME) ,
4397 C
4398 C     where 0 < RL <= 1.  Here, f(y,y') is defined as
4399 C
4400 C      f(y,y') = (1/2)*norm( (J-inverse)*G(t,y,y') )**2 ,
4401 C
4402 C     where norm() is the weighted RMS vector norm, G is the DAE
4403 C     system residual function, and J is the system iteration matrix
4404 C     (Jacobian).
4405 C
4406 C     In addition to the parameters defined elsewhere, we have
4407 C
4408 C     TSCALE  --  Scale factor in T, used for stopping tests if nonzero.
4409 C     P       -- Approximate Newton step used in backtracking.
4410 C     PNRM    -- Weighted RMS norm of P.
4411 C     LSOFF   -- Flag showing whether the linesearch algorithm is
4412 C                to be invoked.  0 means do the linesearch, and
4413 C                1 means turn off linesearch.
4414 C     STPTOL  -- Tolerance used in calculating the minimum lambda
4415 C                value allowed.
4416 C     ICNFLG  -- Integer scalar.  If nonzero, then constraint violations
4417 C                in the proposed new approximate solution will be
4418 C                checked for, and the maximum step length will be
4419 C                adjusted accordingly.
4420 C     ICNSTR  -- Integer array of length NEQ containing flags for
4421 C                checking constraints.
4422 C     RLX     -- Real scalar restricting update size in DCNSTR.
4423 C     YNEW    -- Array of length NEQ used to hold the new Y in
4424 C                performing the linesearch.
4425 C     YPNEW   -- Array of length NEQ used to hold the new YPRIME in
4426 C                performing the linesearch.
4427 C     Y       -- Array of length NEQ containing the new Y (i.e.,=YNEW).
4428 C     YPRIME  -- Array of length NEQ containing the new YPRIME 
4429 C                (i.e.,=YPNEW).
4430 C     FNRM    -- Real scalar containing SQRT(2*f(Y,YPRIME)) for the
4431 C                current (Y,YPRIME) on input and output.
4432 C     R       -- Work array of length NEQ, containing the scaled 
4433 C                residual (J-inverse)*G(t,y,y') on return.
4434 C     IRET    -- Return flag.
4435 C                IRET=0 means that a satisfactory (Y,YPRIME) was found.
4436 C                IRET=1 means that the routine failed to find a new
4437 C                       (Y,YPRIME) that was sufficiently distinct from
4438 C                       the current (Y,YPRIME) pair.
4439 C                IRET=2 means IRES .ne. 0 from RES.
4440 C-----------------------------------------------------------------------
4441 C
4442 C***ROUTINES CALLED
4443 C   DFNRMD, DYYPNW, DCNSTR, DCOPY, XERRWD
4444 C
4445 C***END PROLOGUE  DLINSD
4446 C
4447       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
4448       EXTERNAL  RES
4449       DIMENSION Y(*), YPRIME(*), WT(*), R(*), ID(*)
4450       DIMENSION WM(*), IWM(*)
4451       DIMENSION YNEW(*), YPNEW(*), P(*), ICNSTR(*)
4452       DIMENSION RPAR(*), IPAR(*)
4453       CHARACTER MSG*80
4454 C
4455       PARAMETER (LNRE=12, LKPRIN=31)
4456 C
4457       SAVE ALPHA, ONE, TWO
4458       DATA ALPHA/1.0D-4/, ONE/1.0D0/, TWO/2.0D0/
4459 C
4460       KPRIN=IWM(LKPRIN)
4461 C
4462       F1NRM = (FNRM*FNRM)/TWO
4463       RATIO = ONE
4464       IF (KPRIN .GE. 2) THEN
4465         MSG = '------ IN ROUTINE DLINSD-- PNRM = (R1)'
4466         CALL XERRWD(MSG, 38, 901, 0, 0, 0, 0, 1, PNRM, 0.0D0)
4467         ENDIF
4468       TAU = PNRM
4469       RL = ONE
4470 C-----------------------------------------------------------------------
4471 C Check for violations of the constraints, if any are imposed.
4472 C If any violations are found, the step vector P is rescaled, and the 
4473 C constraint check is repeated, until no violations are found.
4474 C-----------------------------------------------------------------------
4475       IF (ICNFLG .NE. 0) THEN
4476  10      CONTINUE
4477          CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW)
4478          CALL DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR)
4479          IF (IRET .EQ. 1) THEN
4480             RATIO1 = TAU/PNRM
4481             RATIO = RATIO*RATIO1
4482             DO 20 I = 1,NEQ
4483  20           P(I) = P(I)*RATIO1
4484             PNRM = TAU
4485             IF (KPRIN .GE. 2) THEN
4486               MSG = '------ CONSTRAINT VIOL., PNRM = (R1), INDEX = (I1)'
4487               CALL XERRWD(MSG, 50, 902, 0, 1, IVAR, 0, 1, PNRM, 0.0D0)
4488               ENDIF
4489             IF (PNRM .LE. STPTOL) THEN
4490               IRET = 1
4491               RETURN
4492               ENDIF
4493             GO TO 10
4494             ENDIF
4495          ENDIF
4496 C
4497       SLPI = (-TWO*F1NRM)*RATIO
4498       RLMIN = STPTOL/PNRM
4499       IF (LSOFF .EQ. 0 .AND. KPRIN .GE. 2) THEN
4500         MSG = '------ MIN. LAMBDA = (R1)'
4501         CALL XERRWD(MSG, 25, 903, 0, 0, 0, 0, 1, RLMIN, 0.0D0)
4502         ENDIF
4503 C-----------------------------------------------------------------------
4504 C Begin iteration to find RL value satisfying alpha-condition.
4505 C If RL becomes less than RLMIN, then terminate with IRET = 1.
4506 C-----------------------------------------------------------------------
4507  100  CONTINUE
4508       CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW)
4509       CALL DFNRMD (NEQ, YNEW, T, YPNEW, R, CJ, TSCALE, WT, RES, IRES,
4510      *              FNRMP, WM, IWM, RPAR, IPAR)
4511       IWM(LNRE) = IWM(LNRE) + 1
4512       IF (IRES .NE. 0) THEN
4513         IRET = 2
4514         RETURN
4515         ENDIF
4516       IF (LSOFF .EQ. 1) GO TO 150
4517 C
4518       F1NRMP = FNRMP*FNRMP/TWO
4519       IF (KPRIN .GE. 2) THEN
4520         MSG = '------ LAMBDA = (R1)'
4521         CALL XERRWD(MSG, 20, 904, 0, 0, 0, 0, 1, RL, 0.0D0)
4522         MSG = '------ NORM(F1) = (R1),  NORM(F1NEW) = (R2)'
4523         CALL XERRWD(MSG, 43, 905, 0, 0, 0, 0, 2, F1NRM, F1NRMP)
4524         ENDIF
4525       IF (F1NRMP .GT. F1NRM + ALPHA*SLPI*RL) GO TO 200
4526 C-----------------------------------------------------------------------
4527 C Alpha-condition is satisfied, or linesearch is turned off.
4528 C Copy YNEW,YPNEW to Y,YPRIME and return.
4529 C-----------------------------------------------------------------------
4530  150  IRET = 0
4531       CALL DCOPY (NEQ, YNEW, 1, Y, 1)
4532       CALL DCOPY (NEQ, YPNEW, 1, YPRIME, 1)
4533       FNRM = FNRMP
4534       IF (KPRIN .GE. 1) THEN
4535         MSG = '------ LEAVING ROUTINE DLINSD, FNRM = (R1)'
4536         CALL XERRWD(MSG, 42, 906, 0, 0, 0, 0, 1, FNRM, 0.0D0)
4537         ENDIF
4538       RETURN
4539 C-----------------------------------------------------------------------
4540 C Alpha-condition not satisfied.  Perform backtrack to compute new RL
4541 C value.  If no satisfactory YNEW,YPNEW can be found sufficiently 
4542 C distinct from Y,YPRIME, then return IRET = 1.
4543 C-----------------------------------------------------------------------
4544  200  CONTINUE
4545       IF (RL .LT. RLMIN) THEN
4546         IRET = 1
4547         RETURN
4548         ENDIF
4549 C
4550       RL = RL/TWO
4551       GO TO 100
4552 C
4553 C----------------------- END OF SUBROUTINE DLINSD ----------------------
4554       END
4555       SUBROUTINE DFNRMD (NEQ, Y, T, YPRIME, R, CJ, TSCALE, WT,
4556      *                   RES, IRES, FNORM, WM, IWM, RPAR, IPAR)
4557 C
4558 C***BEGIN PROLOGUE  DFNRMD
4559 C***REFER TO  DLINSD
4560 C***DATE WRITTEN   941025   (YYMMDD)
4561 C***REVISION DATE  000628   TSCALE argument added.
4562 C
4563 C
4564 C-----------------------------------------------------------------------
4565 C***DESCRIPTION
4566 C
4567 C     DFNRMD calculates the scaled preconditioned norm of the nonlinear
4568 C     function used in the nonlinear iteration for obtaining consistent
4569 C     initial conditions.  Specifically, DFNRMD calculates the weighted
4570 C     root-mean-square norm of the vector (J-inverse)*G(T,Y,YPRIME),
4571 C     where J is the Jacobian matrix.
4572 C
4573 C     In addition to the parameters described in the calling program
4574 C     DLINSD, the parameters represent
4575 C
4576 C     R      -- Array of length NEQ that contains
4577 C               (J-inverse)*G(T,Y,YPRIME) on return.
4578 C     TSCALE -- Scale factor in T, used for stopping tests if nonzero.
4579 C     FNORM  -- Scalar containing the weighted norm of R on return.
4580 C-----------------------------------------------------------------------
4581 C
4582 C***ROUTINES CALLED
4583 C   RES, DSLVD, DDWNRM
4584 C
4585 C***END PROLOGUE  DFNRMD
4586 C
4587 C
4588       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4589       EXTERNAL RES
4590       DIMENSION Y(*), YPRIME(*), WT(*), R(*)
4591       DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*)
4592 C-----------------------------------------------------------------------
4593 C     Call RES routine.
4594 C-----------------------------------------------------------------------
4595       IRES = 0
4596       CALL RES(T,Y,YPRIME,R,IRES,RPAR,IPAR)
4597       IF (IRES .LT. 0) RETURN
4598 C-----------------------------------------------------------------------
4599 C     Apply inverse of Jacobian to vector R.
4600 C-----------------------------------------------------------------------
4601       CALL DSLVD(NEQ,R,WM,IWM)
4602 C-----------------------------------------------------------------------
4603 C     Calculate norm of R.
4604 C-----------------------------------------------------------------------
4605       FNORM = DDWNRM(NEQ,R,WT,RPAR,IPAR)
4606       IF (TSCALE .GT. 0.0D0) FNORM = FNORM*TSCALE*ABS(CJ)
4607 C
4608       RETURN
4609 C----------------------- END OF SUBROUTINE DFNRMD ----------------------
4610       END
4611       SUBROUTINE DNEDD(X,Y,YPRIME,NEQ,RES,JACD,PDUM,H,WT,
4612      *   JSTART,IDID,RPAR,IPAR,PHI,GAMMA,DUMSVR,DELTA,E,
4613      *   WM,IWM,CJ,CJOLD,CJLAST,S,UROUND,DUME,DUMS,DUMR,
4614      *   EPCON,JCALC,JFDUM,KP1,NONNEG,NTYPE,IERNLS)
4615 C
4616 C***BEGIN PROLOGUE  DNEDD
4617 C***REFER TO  DDASPK
4618 C***DATE WRITTEN   891219   (YYMMDD)
4619 C***REVISION DATE  900926   (YYMMDD)
4620 C
4621 C
4622 C-----------------------------------------------------------------------
4623 C***DESCRIPTION
4624 C
4625 C     DNEDD solves a nonlinear system of
4626 C     algebraic equations of the form
4627 C     G(X,Y,YPRIME) = 0 for the unknown Y.
4628 C
4629 C     The method used is a modified Newton scheme.
4630 C
4631 C     The parameters represent
4632 C
4633 C     X         -- Independent variable.
4634 C     Y         -- Solution vector.
4635 C     YPRIME    -- Derivative of solution vector.
4636 C     NEQ       -- Number of unknowns.
4637 C     RES       -- External user-supplied subroutine
4638 C                  to evaluate the residual.  See RES description
4639 C                  in DDASPK prologue.
4640 C     JACD      -- External user-supplied routine to evaluate the
4641 C                  Jacobian.  See JAC description for the case
4642 C                  INFO(12) = 0 in the DDASPK prologue.
4643 C     PDUM      -- Dummy argument.
4644 C     H         -- Appropriate step size for next step.
4645 C     WT        -- Vector of weights for error criterion.
4646 C     JSTART    -- Indicates first call to this routine.
4647 C                  If JSTART = 0, then this is the first call,
4648 C                  otherwise it is not.
4649 C     IDID      -- Completion flag, output by DNEDD.
4650 C                  See IDID description in DDASPK prologue.
4651 C     RPAR,IPAR -- Real and integer arrays used for communication
4652 C                  between the calling program and external user
4653 C                  routines.  They are not altered within DASPK.
4654 C     PHI       -- Array of divided differences used by
4655 C                  DNEDD.  The length is NEQ*(K+1),where
4656 C                  K is the maximum order.
4657 C     GAMMA     -- Array used to predict Y and YPRIME.  The length
4658 C                  is MAXORD+1 where MAXORD is the maximum order.
4659 C     DUMSVR    -- Dummy argument.
4660 C     DELTA     -- Work vector for NLS of length NEQ.
4661 C     E         -- Error accumulation vector for NLS of length NEQ.
4662 C     WM,IWM    -- Real and integer arrays storing
4663 C                  matrix information such as the matrix
4664 C                  of partial derivatives, permutation
4665 C                  vector, and various other information.
4666 C     CJ        -- Parameter always proportional to 1/H.
4667 C     CJOLD     -- Saves the value of CJ as of the last call to DMATD.
4668 C                  Accounts for changes in CJ needed to
4669 C                  decide whether to call DMATD.
4670 C     CJLAST    -- Previous value of CJ.
4671 C     S         -- A scalar determined by the approximate rate
4672 C                  of convergence of the Newton iteration and used
4673 C                  in the convergence test for the Newton iteration.
4674 C
4675 C                  If RATE is defined to be an estimate of the
4676 C                  rate of convergence of the Newton iteration,
4677 C                  then S = RATE/(1.D0-RATE).
4678 C
4679 C                  The closer RATE is to 0., the faster the Newton
4680 C                  iteration is converging; the closer RATE is to 1.,
4681 C                  the slower the Newton iteration is converging.
4682 C
4683 C                  On the first Newton iteration with an up-dated
4684 C                  preconditioner S = 100.D0, Thus the initial
4685 C                  RATE of convergence is approximately 1.
4686 C
4687 C                  S is preserved from call to call so that the rate
4688 C                  estimate from a previous step can be applied to
4689 C                  the current step.
4690 C     UROUND    -- Unit roundoff.
4691 C     DUME      -- Dummy argument.
4692 C     DUMS      -- Dummy argument.
4693 C     DUMR      -- Dummy argument.
4694 C     EPCON     -- Tolerance to test for convergence of the Newton
4695 C                  iteration.
4696 C     JCALC     -- Flag used to determine when to update
4697 C                  the Jacobian matrix.  In general:
4698 C
4699 C                  JCALC = -1 ==> Call the DMATD routine to update
4700 C                                 the Jacobian matrix.
4701 C                  JCALC =  0 ==> Jacobian matrix is up-to-date.
4702 C                  JCALC =  1 ==> Jacobian matrix is out-dated,
4703 C                                 but DMATD will not be called unless
4704 C                                 JCALC is set to -1.
4705 C     JFDUM     -- Dummy argument.
4706 C     KP1       -- The current order(K) + 1;  updated across calls.
4707 C     NONNEG    -- Flag to determine nonnegativity constraints.
4708 C     NTYPE     -- Identification code for the NLS routine.
4709 C                   0  ==> modified Newton; direct solver.
4710 C     IERNLS    -- Error flag for nonlinear solver.
4711 C                   0  ==> nonlinear solver converged.
4712 C                   1  ==> recoverable error inside nonlinear solver.
4713 C                  -1  ==> unrecoverable error inside nonlinear solver.
4714 C
4715 C     All variables with "DUM" in their names are dummy variables
4716 C     which are not used in this routine.
4717 C
4718 C     Following is a list and description of local variables which
4719 C     may not have an obvious usage.  They are listed in roughly the
4720 C     order they occur in this subroutine.
4721 C
4722 C     The following group of variables are passed as arguments to
4723 C     the Newton iteration solver.  They are explained in greater detail
4724 C     in DNSD:
4725 C        TOLNEW, MULDEL, MAXIT, IERNEW
4726 C
4727 C     IERTYP -- Flag which tells whether this subroutine is correct.
4728 C               0 ==> correct subroutine.
4729 C               1 ==> incorrect subroutine.
4730
4731 C-----------------------------------------------------------------------
4732 C***ROUTINES CALLED
4733 C   DDWNRM, RES, DMATD, DNSD
4734 C
4735 C***END PROLOGUE  DNEDD
4736 C
4737 C
4738       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
4739       DIMENSION Y(*),YPRIME(*),WT(*)
4740       DIMENSION DELTA(*),E(*)
4741       DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*)
4742       DIMENSION PHI(NEQ,*),GAMMA(*)
4743       EXTERNAL  RES, JACD
4744 C
4745       PARAMETER (LNRE=12, LNJE=13)
4746 C
4747       SAVE MULDEL, MAXIT, XRATE
4748       DATA MULDEL/1/, MAXIT/4/, XRATE/0.25D0/
4749 C
4750       COMMON /ierode/ierror
4751 C
4752 C
4753 C     Verify that this is the correct subroutine.
4754 C
4755       IERTYP = 0
4756       IF (NTYPE .NE. 0) THEN
4757          IERTYP = 1
4758          GO TO 380
4759          ENDIF
4760 C
4761 C     If this is the first step, perform initializations.
4762 C
4763       IF (JSTART .EQ. 0) THEN
4764          CJOLD = CJ
4765          JCALC = -1
4766          ENDIF
4767 C
4768 C     Perform all other initializations.
4769 C
4770       IERNLS = 0
4771 C
4772 C     Decide whether new Jacobian is needed.
4773 C
4774       TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE)
4775       TEMP2 = 1.0D0/TEMP1
4776       IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1
4777       IF (CJ .NE. CJLAST) S = 100.D0
4778 C
4779 C-----------------------------------------------------------------------
4780 C     Entry point for updating the Jacobian with current
4781 C     stepsize.
4782 C-----------------------------------------------------------------------
4783 300   CONTINUE
4784 C
4785 C     Initialize all error flags to zero.
4786 C
4787       IERJ = 0
4788       IRES = 0
4789       IERNEW = 0
4790 C
4791 C     Predict the solution and derivative and compute the tolerance
4792 C     for the Newton iteration.
4793 C
4794       DO 310 I=1,NEQ
4795          Y(I)=PHI(I,1)
4796 310      YPRIME(I)=0.0D0
4797       DO 330 J=2,KP1
4798          DO 320 I=1,NEQ
4799             Y(I)=Y(I)+PHI(I,J)
4800 320         YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J)
4801 330   CONTINUE
4802       PNORM = DDWNRM (NEQ,Y,WT,RPAR,IPAR)
4803       TOLNEW = 100.D0*UROUND*PNORM
4804 C     
4805 C     Call RES to initialize DELTA.
4806 C
4807       IWM(LNRE)=IWM(LNRE)+1
4808       CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
4809 C     ierror indicates if RES had the right prototype
4810       IF(ierror.ne.0) THEN
4811          IDID=-12
4812          RETURN
4813       ENDIF
4814       IF (IRES .LT. 0) GO TO 380
4815 C
4816 C     If indicated, reevaluate the iteration matrix 
4817 C     J = dG/dY + CJ*dG/dYPRIME (where G(X,Y,YPRIME)=0).
4818 C     Set JCALC to 0 as an indicator that this has been done.
4819 C
4820       IF(JCALC .EQ. -1) THEN
4821          IWM(LNJE)=IWM(LNJE)+1
4822          JCALC=0
4823          CALL DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IERJ,WT,E,WM,IWM,
4824      *              RES,IRES,UROUND,JACD,RPAR,IPAR)
4825          CJOLD=CJ
4826          S = 100.D0
4827          IF (IRES .LT. 0) GO TO 380
4828          IF(IERJ .NE. 0)GO TO 380
4829       ENDIF
4830 C
4831 C     Call the nonlinear Newton solver.
4832 C
4833       TEMP1 = 2.0D0/(1.0D0 + CJ/CJOLD)
4834       CALL DNSD(X,Y,YPRIME,NEQ,RES,PDUM,WT,RPAR,IPAR,DUMSVR,
4835      *          DELTA,E,WM,IWM,CJ,DUMS,DUMR,DUME,EPCON,S,TEMP1,
4836      *          TOLNEW,MULDEL,MAXIT,IRES,IDUM,IERNEW)
4837 C
4838       IF (IERNEW .GT. 0 .AND. JCALC .NE. 0) THEN
4839 C
4840 C        The Newton iteration had a recoverable failure with an old
4841 C        iteration matrix.  Retry the step with a new iteration matrix.
4842 C
4843          JCALC = -1
4844          GO TO 300
4845       ENDIF
4846 C
4847       IF (IERNEW .NE. 0) GO TO 380
4848 C
4849 C     The Newton iteration has converged.  If nonnegativity of
4850 C     solution is required, set the solution nonnegative, if the
4851 C     perturbation to do it is small enough.  If the change is too
4852 C     large, then consider the corrector iteration to have failed.
4853 C
4854 375   IF(NONNEG .EQ. 0) GO TO 390
4855       DO 377 I = 1,NEQ
4856 377      DELTA(I) = MIN(Y(I),0.0D0)
4857       DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR)
4858       IF(DELNRM .GT. EPCON) GO TO 380
4859       DO 378 I = 1,NEQ
4860 378      E(I) = E(I) - DELTA(I)
4861       GO TO 390
4862 C
4863 C
4864 C     Exits from nonlinear solver.
4865 C     No convergence with current iteration
4866 C     matrix, or singular iteration matrix.
4867 C     Compute IERNLS and IDID accordingly.
4868 C
4869 380   CONTINUE
4870       IF (IRES .LE. -2 .OR. IERTYP .NE. 0) THEN
4871          IERNLS = -1
4872          IF (IRES .LE. -2) IDID = -11
4873          IF (IERTYP .NE. 0) IDID = -15
4874       ELSE
4875          IERNLS = 1
4876          IF (IRES .LT. 0) IDID = -10
4877          IF (IERJ .NE. 0) IDID = -8
4878       ENDIF
4879 C
4880 390   JCALC = 1
4881       RETURN
4882 C
4883 C------END OF SUBROUTINE DNEDD------------------------------------------
4884       END
4885       SUBROUTINE DNSD(X,Y,YPRIME,NEQ,RES,PDUM,WT,RPAR,IPAR,
4886      *   DUMSVR,DELTA,E,WM,IWM,CJ,DUMS,DUMR,DUME,EPCON,
4887      *   S,CONFAC,TOLNEW,MULDEL,MAXIT,IRES,IDUM,IERNEW)
4888 C
4889 C***BEGIN PROLOGUE  DNSD
4890 C***REFER TO  DDASPK
4891 C***DATE WRITTEN   891219   (YYMMDD)
4892 C***REVISION DATE  900926   (YYMMDD)
4893 C***REVISION DATE  950126   (YYMMDD)
4894 C***REVISION DATE  000711   (YYMMDD)
4895 C
4896 C
4897 C-----------------------------------------------------------------------
4898 C***DESCRIPTION
4899 C
4900 C     DNSD solves a nonlinear system of
4901 C     algebraic equations of the form
4902 C     G(X,Y,YPRIME) = 0 for the unknown Y.
4903 C
4904 C     The method used is a modified Newton scheme.
4905 C
4906 C     The parameters represent
4907 C
4908 C     X         -- Independent variable.
4909 C     Y         -- Solution vector.
4910 C     YPRIME    -- Derivative of solution vector.
4911 C     NEQ       -- Number of unknowns.
4912 C     RES       -- External user-supplied subroutine
4913 C                  to evaluate the residual.  See RES description
4914 C                  in DDASPK prologue.
4915 C     PDUM      -- Dummy argument.
4916 C     WT        -- Vector of weights for error criterion.
4917 C     RPAR,IPAR -- Real and integer arrays used for communication
4918 C                  between the calling program and external user
4919 C                  routines.  They are not altered within DASPK.
4920 C     DUMSVR    -- Dummy argument.
4921 C     DELTA     -- Work vector for DNSD of length NEQ.
4922 C     E         -- Error accumulation vector for DNSD of length NEQ.
4923 C     WM,IWM    -- Real and integer arrays storing
4924 C                  matrix information such as the matrix
4925 C                  of partial derivatives, permutation
4926 C                  vector, and various other information.
4927 C     CJ        -- Parameter always proportional to 1/H (step size).
4928 C     DUMS      -- Dummy argument.
4929 C     DUMR      -- Dummy argument.
4930 C     DUME      -- Dummy argument.
4931 C     EPCON     -- Tolerance to test for convergence of the Newton
4932 C                  iteration.
4933 C     S         -- Used for error convergence tests.
4934 C                  In the Newton iteration: S = RATE/(1 - RATE),
4935 C                  where RATE is the estimated rate of convergence
4936 C                  of the Newton iteration.
4937 C                  The calling routine passes the initial value
4938 C                  of S to the Newton iteration.
4939 C     CONFAC    -- A residual scale factor to improve convergence.
4940 C     TOLNEW    -- Tolerance on the norm of Newton correction in
4941 C                  alternative Newton convergence test.
4942 C     MULDEL    -- A flag indicating whether or not to multiply
4943 C                  DELTA by CONFAC.
4944 C                  0  ==> do not scale DELTA by CONFAC.
4945 C                  1  ==> scale DELTA by CONFAC.
4946 C     MAXIT     -- Maximum allowed number of Newton iterations.
4947 C     IRES      -- Error flag returned from RES.  See RES description
4948 C                  in DDASPK prologue.  If IRES = -1, then IERNEW
4949 C                  will be set to 1.
4950 C                  If IRES < -1, then IERNEW will be set to -1.
4951 C     IDUM      -- Dummy argument.
4952 C     IERNEW    -- Error flag for Newton iteration.
4953 C                   0  ==> Newton iteration converged.
4954 C                   1  ==> recoverable error inside Newton iteration.
4955 C                  -1  ==> unrecoverable error inside Newton iteration.
4956 C
4957 C     All arguments with "DUM" in their names are dummy arguments
4958 C     which are not used in this routine.
4959 C-----------------------------------------------------------------------
4960 C
4961 C***ROUTINES CALLED
4962 C   DSLVD, DDWNRM, RES
4963 C
4964 C***END PROLOGUE  DNSD
4965 C
4966 C
4967       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
4968       DIMENSION Y(*),YPRIME(*),WT(*),DELTA(*),E(*)
4969       DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*)
4970       EXTERNAL  RES
4971 C
4972       PARAMETER (LNRE=12, LNNI=19)
4973 C
4974 C     Initialize Newton counter M and accumulation vector E. 
4975 C
4976       M = 0
4977       DO 100 I=1,NEQ
4978 100     E(I)=0.0D0
4979 C
4980 C     Corrector loop.
4981 C
4982 300   CONTINUE
4983       IWM(LNNI) = IWM(LNNI) + 1
4984 C
4985 C     If necessary, multiply residual by convergence factor.
4986 C
4987       IF (MULDEL .EQ. 1) THEN
4988          DO 320 I = 1,NEQ
4989 320        DELTA(I) = DELTA(I) * CONFAC
4990         ENDIF
4991 C
4992 C     Compute a new iterate (back-substitution).
4993 C     Store the correction in DELTA.
4994 C
4995       CALL DSLVD(NEQ,DELTA,WM,IWM)
4996 C
4997 C     Update Y, E, and YPRIME.
4998 C
4999       DO 340 I=1,NEQ
5000          Y(I)=Y(I)-DELTA(I)
5001          E(I)=E(I)-DELTA(I)
5002 340      YPRIME(I)=YPRIME(I)-CJ*DELTA(I)
5003 C
5004 C     Test for convergence of the iteration.
5005 C
5006       DELNRM=DDWNRM(NEQ,DELTA,WT,RPAR,IPAR)
5007       IF (M .EQ. 0) THEN
5008         OLDNRM = DELNRM
5009         IF (DELNRM .LE. TOLNEW) GO TO 370
5010       ELSE
5011         RATE = (DELNRM/OLDNRM)**(1.0D0/M)
5012         IF (RATE .GT. 0.9D0) GO TO 380
5013         S = RATE/(1.0D0 - RATE)
5014       ENDIF
5015       IF (S*DELNRM .LE. EPCON) GO TO 370
5016 C
5017 C     The corrector has not yet converged.
5018 C     Update M and test whether the
5019 C     maximum number of iterations have
5020 C     been tried.
5021 C
5022       M=M+1
5023       IF(M.GE.MAXIT) GO TO 380
5024 C
5025 C     Evaluate the residual,
5026 C     and go back to do another iteration.
5027 C
5028       IWM(LNRE)=IWM(LNRE)+1
5029       CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
5030       IF (IRES .LT. 0) GO TO 380
5031       GO TO 300
5032 C
5033 C     The iteration has converged.
5034 C
5035 370   RETURN
5036 C
5037 C     The iteration has not converged.  Set IERNEW appropriately.
5038 C
5039 380   CONTINUE
5040       IF (IRES .LE. -2 ) THEN
5041          IERNEW = -1
5042       ELSE
5043          IERNEW = 1
5044       ENDIF
5045       RETURN
5046 C
5047 C
5048 C------END OF SUBROUTINE DNSD-------------------------------------------
5049       END
5050       SUBROUTINE DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IER,EWT,E,
5051      *                 WM,IWM,RES,IRES,UROUND,JACD,RPAR,IPAR)
5052 C
5053 C***BEGIN PROLOGUE  DMATD
5054 C***REFER TO  DDASPK
5055 C***DATE WRITTEN   890101   (YYMMDD)
5056 C***REVISION DATE  900926   (YYMMDD)
5057 C***REVISION DATE  940701   (new LIPVT)
5058 C***REVISION DATE  060712   (Changed minimum D.Q. increment to 1/EWT(j))
5059 C
5060 C-----------------------------------------------------------------------
5061 C***DESCRIPTION
5062 C
5063 C     This routine computes the iteration matrix
5064 C     J = dG/dY+CJ*dG/dYPRIME (where G(X,Y,YPRIME)=0).
5065 C     Here J is computed by:
5066 C       the user-supplied routine JACD if IWM(MTYPE) is 1 or 4, or
5067 C       by numerical difference quotients if IWM(MTYPE) is 2 or 5.
5068 C
5069 C     The parameters have the following meanings.
5070 C     X        = Independent variable.
5071 C     Y        = Array containing predicted values.
5072 C     YPRIME   = Array containing predicted derivatives.
5073 C     DELTA    = Residual evaluated at (X,Y,YPRIME).
5074 C                (Used only if IWM(MTYPE)=2 or 5).
5075 C     CJ       = Scalar parameter defining iteration matrix.
5076 C     H        = Current stepsize in integration.
5077 C     IER      = Variable which is .NE. 0 if iteration matrix
5078 C                is singular, and 0 otherwise.
5079 C     EWT      = Vector of error weights for computing norms.
5080 C     E        = Work space (temporary) of length NEQ.
5081 C     WM       = Real work space for matrices.  On output
5082 C                it contains the LU decomposition
5083 C                of the iteration matrix.
5084 C     IWM      = Integer work space containing
5085 C                matrix information.
5086 C     RES      = External user-supplied subroutine
5087 C                to evaluate the residual.  See RES description
5088 C                in DDASPK prologue.
5089 C     IRES     = Flag which is equal to zero if no illegal values
5090 C                in RES, and less than zero otherwise.  (If IRES
5091 C                is less than zero, the matrix was not completed).
5092 C                In this case (if IRES .LT. 0), then IER = 0.
5093 C     UROUND   = The unit roundoff error of the machine being used.
5094 C     JACD     = Name of the external user-supplied routine
5095 C                to evaluate the iteration matrix.  (This routine
5096 C                is only used if IWM(MTYPE) is 1 or 4)
5097 C                See JAC description for the case INFO(12) = 0
5098 C                in DDASPK prologue.
5099 C     RPAR,IPAR= Real and integer parameter arrays that
5100 C                are used for communication between the
5101 C                calling program and external user routines.
5102 C                They are not altered by DMATD.
5103 C-----------------------------------------------------------------------
5104 C***ROUTINES CALLED
5105 C   JACD, RES, DGEFA, DGBFA
5106 C
5107 C***END PROLOGUE  DMATD
5108 C
5109 C
5110       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
5111       DIMENSION Y(*),YPRIME(*),DELTA(*),EWT(*),E(*)
5112       DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*)
5113       EXTERNAL  RES, JACD
5114 C
5115       PARAMETER (LML=1, LMU=2, LMTYPE=4, LNRE=12, LNPD=22, LLCIWP=30)
5116 C
5117       LIPVT = IWM(LLCIWP)
5118       IER = 0
5119       MTYPE=IWM(LMTYPE)
5120       GO TO (100,200,300,400,500),MTYPE
5121 C
5122 C
5123 C     Dense user-supplied matrix.
5124 C
5125 100   LENPD=IWM(LNPD)
5126       DO 110 I=1,LENPD
5127 110      WM(I)=0.0D0
5128       CALL JACD(X,Y,YPRIME,WM,CJ,RPAR,IPAR)
5129       GO TO 230
5130 C
5131 C
5132 C     Dense finite-difference-generated matrix.
5133 C
5134 200   IRES=0
5135       NROW=0
5136       SQUR = SQRT(UROUND)
5137       DO 210 I=1,NEQ
5138          DEL=MAX(SQUR*MAX(ABS(Y(I)),ABS(H*YPRIME(I))), 1.0D0/EWT(I))
5139          DEL=SIGN(DEL,H*YPRIME(I))
5140          DEL=(Y(I)+DEL)-Y(I)
5141          YSAVE=Y(I)
5142          YPSAVE=YPRIME(I)
5143          Y(I)=Y(I)+DEL
5144          YPRIME(I)=YPRIME(I)+CJ*DEL
5145          IWM(LNRE)=IWM(LNRE)+1
5146          CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR)
5147          IF (IRES .LT. 0) RETURN
5148          DELINV=1.0D0/DEL
5149          DO 220 L=1,NEQ
5150 220        WM(NROW+L)=(E(L)-DELTA(L))*DELINV
5151       NROW=NROW+NEQ
5152       Y(I)=YSAVE
5153       YPRIME(I)=YPSAVE
5154 210   CONTINUE
5155 C
5156 C
5157 C     Do dense-matrix LU decomposition on J.
5158 C
5159 230      CALL DGEFA(WM,NEQ,NEQ,IWM(LIPVT),IER)
5160       RETURN
5161 C
5162 C
5163 C     Dummy section for IWM(MTYPE)=3.
5164 C
5165 300   RETURN
5166 C
5167 C
5168 C     Banded user-supplied matrix.
5169 C
5170 400   LENPD=IWM(LNPD)
5171       DO 410 I=1,LENPD
5172 410      WM(I)=0.0D0
5173       CALL JACD(X,Y,YPRIME,WM,CJ,RPAR,IPAR)
5174       MEBAND=2*IWM(LML)+IWM(LMU)+1
5175       GO TO 550
5176 C
5177 C
5178 C     Banded finite-difference-generated matrix.
5179 C
5180 500   MBAND=IWM(LML)+IWM(LMU)+1
5181       MBA=MIN0(MBAND,NEQ)
5182       MEBAND=MBAND+IWM(LML)
5183       MEB1=MEBAND-1
5184       MSAVE=(NEQ/MBAND)+1
5185       ISAVE=IWM(LNPD)
5186       IPSAVE=ISAVE+MSAVE
5187       IRES=0
5188       SQUR=SQRT(UROUND)
5189       DO 540 J=1,MBA
5190         DO 510 N=J,NEQ,MBAND
5191           K= (N-J)/MBAND + 1
5192           WM(ISAVE+K)=Y(N)
5193           WM(IPSAVE+K)=YPRIME(N)
5194           DEL=MAX(SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N))), 1.0D0/EWT(N))
5195           DEL=SIGN(DEL,H*YPRIME(N))
5196           DEL=(Y(N)+DEL)-Y(N)
5197           Y(N)=Y(N)+DEL
5198 510       YPRIME(N)=YPRIME(N)+CJ*DEL
5199         IWM(LNRE)=IWM(LNRE)+1
5200         CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR)
5201         IF (IRES .LT. 0) RETURN
5202         DO 530 N=J,NEQ,MBAND
5203           K= (N-J)/MBAND + 1
5204           Y(N)=WM(ISAVE+K)
5205           YPRIME(N)=WM(IPSAVE+K)
5206           DEL=MAX(SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N))), 1.0D0/EWT(N))
5207           DEL=SIGN(DEL,H*YPRIME(N))
5208           DEL=(Y(N)+DEL)-Y(N)
5209           DELINV=1.0D0/DEL
5210           I1=MAX0(1,(N-IWM(LMU)))
5211           I2=MIN0(NEQ,(N+IWM(LML)))
5212           II=N*MEB1-IWM(LML)
5213           DO 520 I=I1,I2
5214 520         WM(II+I)=(E(I)-DELTA(I))*DELINV
5215 530     CONTINUE
5216 540   CONTINUE
5217 C
5218 C
5219 C     Do LU decomposition of banded J.
5220 C
5221 550   CALL DGBFA (WM,MEBAND,NEQ,IWM(LML),IWM(LMU),IWM(LIPVT),IER)
5222       RETURN
5223 C
5224 C------END OF SUBROUTINE DMATD------------------------------------------
5225       END
5226       SUBROUTINE DSLVD(NEQ,DELTA,WM,IWM)
5227 C
5228 C***BEGIN PROLOGUE  DSLVD
5229 C***REFER TO  DDASPK
5230 C***DATE WRITTEN   890101   (YYMMDD)
5231 C***REVISION DATE  900926   (YYMMDD)
5232 C***REVISION DATE  940701   (YYMMDD) (new LIPVT)
5233 C
5234 C-----------------------------------------------------------------------
5235 C***DESCRIPTION
5236 C
5237 C     This routine manages the solution of the linear
5238 C     system arising in the Newton iteration.
5239 C     Real matrix information and real temporary storage
5240 C     is stored in the array WM.
5241 C     Integer matrix information is stored in the array IWM.
5242 C     For a dense matrix, the LINPACK routine DGESL is called.
5243 C     For a banded matrix, the LINPACK routine DGBSL is called.
5244 C-----------------------------------------------------------------------
5245 C***ROUTINES CALLED
5246 C   DGESL, DGBSL
5247 C
5248 C***END PROLOGUE  DSLVD
5249 C
5250 C
5251       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
5252       DIMENSION DELTA(*),WM(*),IWM(*)
5253 C
5254       PARAMETER (LML=1, LMU=2, LMTYPE=4, LLCIWP=30)
5255 C
5256       LIPVT = IWM(LLCIWP)
5257       MTYPE=IWM(LMTYPE)
5258       GO TO(100,100,300,400,400),MTYPE
5259 C
5260 C     Dense matrix.
5261 C
5262 100   CALL DGESL(WM,NEQ,NEQ,IWM(LIPVT),DELTA,0)
5263       RETURN
5264 C
5265 C     Dummy section for MTYPE=3.
5266 C
5267 300   CONTINUE
5268       RETURN
5269 C
5270 C     Banded matrix.
5271 C
5272 400   MEBAND=2*IWM(LML)+IWM(LMU)+1
5273       CALL DGBSL(WM,MEBAND,NEQ,IWM(LML),
5274      *  IWM(LMU),IWM(LIPVT),DELTA,0)
5275       RETURN
5276 C
5277 C------END OF SUBROUTINE DSLVD------------------------------------------
5278       END
5279       SUBROUTINE DDASIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JACK,PSOL,H,TSCALE,
5280      *   WT,JSKIP,RPAR,IPAR,SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,UROUND,
5281      *   EPLI,SQRTN,RSQRTN,EPCON,RATEMX,STPTOL,JFLG,
5282      *   ICNFLG,ICNSTR,IERNLS)
5283 C
5284 C***BEGIN PROLOGUE  DDASIK
5285 C***REFER TO  DDASPK
5286 C***DATE WRITTEN   941026   (YYMMDD)
5287 C***REVISION DATE  950808   (YYMMDD)
5288 C***REVISION DATE  951110   Removed unreachable block 390.
5289 C***REVISION DATE  000628   TSCALE argument added.
5290 C
5291 C
5292 C-----------------------------------------------------------------------
5293 C***DESCRIPTION
5294 C
5295 C
5296 C     DDASIK solves a nonlinear system of algebraic equations of the
5297 C     form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in
5298 C     the initial conditions.
5299 C
5300 C     An initial value for Y and initial guess for YPRIME are input.
5301 C
5302 C     The method used is a Newton scheme with Krylov iteration and a
5303 C     linesearch algorithm.
5304 C
5305 C     The parameters represent
5306 C
5307 C     X         -- Independent variable.
5308 C     Y         -- Solution vector at x.
5309 C     YPRIME    -- Derivative of solution vector.
5310 C     NEQ       -- Number of equations to be integrated.
5311 C     ICOPT     -- Initial condition option chosen (1 or 2).
5312 C     ID        -- Array of dimension NEQ, which must be initialized
5313 C                  if ICOPT = 1.  See DDASIC.
5314 C     RES       -- External user-supplied subroutine
5315 C                  to evaluate the residual.  See RES description
5316 C                  in DDASPK prologue.
5317 C     JACK     --  External user-supplied routine to update
5318 C                  the preconditioner.  (This is optional).
5319 C                  See JAC description for the case
5320 C                  INFO(12) = 1 in the DDASPK prologue.
5321 C     PSOL      -- External user-supplied routine to solve
5322 C                  a linear system using preconditioning.
5323 C                  (This is optional).  See explanation inside DDASPK.
5324 C     H         -- Scaling factor for this initial condition calc.
5325 C     TSCALE    -- Scale factor in T, used for stopping tests if nonzero.
5326 C     WT        -- Vector of weights for error criterion.
5327 C     JSKIP     -- input flag to signal if initial JAC call is to be
5328 C                  skipped.  1 => skip the call, 0 => do not skip call.
5329 C     RPAR,IPAR -- Real and integer arrays used for communication
5330 C                  between the calling program and external user
5331 C                  routines.  They are not altered within DASPK.
5332 C     SAVR      -- Work vector for DDASIK of length NEQ.
5333 C     DELTA     -- Work vector for DDASIK of length NEQ.
5334 C     R         -- Work vector for DDASIK of length NEQ.
5335 C     YIC,YPIC  -- Work vectors for DDASIK, each of length NEQ.
5336 C     PWK       -- Work vector for DDASIK of length NEQ.
5337 C     WM,IWM    -- Real and integer arrays storing
5338 C                  matrix information for linear system
5339 C                  solvers, and various other information.
5340 C     CJ        -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2).
5341 C     UROUND    -- Unit roundoff.  Not used here.
5342 C     EPLI      -- convergence test constant.
5343 C                  See DDASPK prologue for more details.
5344 C     SQRTN     -- Square root of NEQ.
5345 C     RSQRTN    -- reciprical of square root of NEQ.
5346 C     EPCON     -- Tolerance to test for convergence of the Newton
5347 C                  iteration.
5348 C     RATEMX    -- Maximum convergence rate for which Newton iteration
5349 C                  is considered converging.
5350 C     JFLG      -- Flag showing whether a Jacobian routine is supplied.
5351 C     ICNFLG    -- Integer scalar.  If nonzero, then constraint
5352 C                  violations in the proposed new approximate solution
5353 C                  will be checked for, and the maximum step length 
5354 C                  will be adjusted accordingly.
5355 C     ICNSTR    -- Integer array of length NEQ containing flags for
5356 C                  checking constraints.
5357 C     IERNLS    -- Error flag for nonlinear solver.
5358 C                   0   ==> nonlinear solver converged.
5359 C                   1,2 ==> recoverable error inside nonlinear solver.
5360 C                           1 => retry with current Y, YPRIME
5361 C                           2 => retry with original Y, YPRIME
5362 C                  -1   ==> unrecoverable error in nonlinear solver.
5363 C
5364 C-----------------------------------------------------------------------
5365 C
5366 C***ROUTINES CALLED
5367 C   RES, JACK, DNSIK, DCOPY
5368 C
5369 C***END PROLOGUE  DDASIK
5370 C
5371 C
5372       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
5373       DIMENSION Y(*),YPRIME(*),ID(*),WT(*),ICNSTR(*)
5374       DIMENSION SAVR(*),DELTA(*),R(*),YIC(*),YPIC(*),PWK(*)
5375       DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*)
5376       EXTERNAL RES, JACK, PSOL
5377 C
5378       PARAMETER (LNRE=12, LNJE=13, LLOCWP=29, LLCIWP=30)
5379       PARAMETER (LMXNIT=32, LMXNJ=33)
5380 C
5381 C
5382 C     Perform initializations.
5383 C
5384       LWP = IWM(LLOCWP)
5385       LIWP = IWM(LLCIWP)
5386       MXNIT = IWM(LMXNIT)
5387       MXNJ = IWM(LMXNJ)
5388       IERNLS = 0
5389       NJ = 0
5390       EPLIN = EPLI*EPCON
5391 C
5392 C     Call RES to initialize DELTA.
5393 C
5394       IRES = 0
5395       IWM(LNRE) = IWM(LNRE) + 1
5396       CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
5397       IF (IRES .LT. 0) GO TO 370
5398 C
5399 C     Looping point for updating the preconditioner.
5400 C
5401  300  CONTINUE
5402 C
5403 C     Initialize all error flags to zero.
5404 C
5405       IERPJ = 0
5406       IRES = 0
5407       IERNEW = 0
5408 C
5409 C     If a Jacobian routine was supplied, call it.
5410 C
5411       IF (JFLG .EQ. 1 .AND. JSKIP .EQ. 0) THEN
5412         NJ = NJ + 1
5413         IWM(LNJE)=IWM(LNJE)+1
5414         CALL JACK (RES, IRES, NEQ, X, Y, YPRIME, WT, DELTA, R, H, CJ,
5415      *     WM(LWP), IWM(LIWP), IERPJ, RPAR, IPAR)
5416         IF (IRES .LT. 0 .OR. IERPJ .NE. 0) GO TO 370
5417         ENDIF
5418       JSKIP = 0
5419 C
5420 C     Call the nonlinear Newton solver for up to MXNIT iterations.
5421 C
5422       CALL DNSIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,PSOL,WT,RPAR,IPAR,
5423      *   SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,TSCALE,SQRTN,RSQRTN,
5424      *   EPLIN,EPCON,RATEMX,MXNIT,STPTOL,ICNFLG,ICNSTR,IERNEW)
5425 C
5426       IF (IERNEW .EQ. 1 .AND. NJ .LT. MXNJ .AND. JFLG .EQ. 1) THEN
5427 C
5428 C       Up to MXNIT iterations were done, the convergence rate is < 1,
5429 C       a Jacobian routine is supplied, and the number of JACK calls
5430 C       is less than MXNJ.  
5431 C       Copy the residual SAVR to DELTA, call JACK, and try again.
5432 C
5433         CALL DCOPY (NEQ,  SAVR, 1, DELTA, 1)
5434         GO TO 300
5435         ENDIF
5436 C
5437       IF (IERNEW .NE. 0) GO TO 380
5438       RETURN
5439 C
5440 C
5441 C     Unsuccessful exits from nonlinear solver.
5442 C     Set IERNLS accordingly.
5443 C
5444  370  IERNLS = 2
5445       IF (IRES .LE. -2) IERNLS = -1
5446       RETURN
5447 C
5448  380  IERNLS = MIN(IERNEW,2)
5449       RETURN
5450 C
5451 C----------------------- END OF SUBROUTINE DDASIK-----------------------
5452       END
5453       SUBROUTINE DNSIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,PSOL,WT,RPAR,IPAR,
5454      *   SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,TSCALE,SQRTN,RSQRTN,EPLIN,
5455      *   EPCON,RATEMX,MAXIT,STPTOL,ICNFLG,ICNSTR,IERNEW)
5456 C
5457 C***BEGIN PROLOGUE  DNSIK
5458 C***REFER TO  DDASPK
5459 C***DATE WRITTEN   940701   (YYMMDD)
5460 C***REVISION DATE  950714   (YYMMDD)
5461 C***REVISION DATE  000628   TSCALE argument added.
5462 C***REVISION DATE  000628   Added criterion for IERNEW = 1 return.
5463 C
5464 C
5465 C-----------------------------------------------------------------------
5466 C***DESCRIPTION
5467 C
5468 C     DNSIK solves a nonlinear system of algebraic equations of the
5469 C     form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in
5470 C     the initial conditions.
5471 C
5472 C     The method used is a Newton scheme combined with a linesearch
5473 C     algorithm, using Krylov iterative linear system methods.
5474 C
5475 C     The parameters represent
5476 C
5477 C     X         -- Independent variable.
5478 C     Y         -- Solution vector.
5479 C     YPRIME    -- Derivative of solution vector.
5480 C     NEQ       -- Number of unknowns.
5481 C     ICOPT     -- Initial condition option chosen (1 or 2).
5482 C     ID        -- Array of dimension NEQ, which must be initialized
5483 C                  if ICOPT = 1.  See DDASIC.
5484 C     RES       -- External user-supplied subroutine
5485 C                  to evaluate the residual.  See RES description
5486 C                  in DDASPK prologue.
5487 C     PSOL      -- External user-supplied routine to solve
5488 C                  a linear system using preconditioning. 
5489 C                  See explanation inside DDASPK.
5490 C     WT        -- Vector of weights for error criterion.
5491 C     RPAR,IPAR -- Real and integer arrays used for communication
5492 C                  between the calling program and external user
5493 C                  routines.  They are not altered within DASPK.
5494 C     SAVR      -- Work vector for DNSIK of length NEQ.
5495 C     DELTA     -- Residual vector on entry, and work vector of
5496 C                  length NEQ for DNSIK.
5497 C     R         -- Work vector for DNSIK of length NEQ.
5498 C     YIC,YPIC  -- Work vectors for DNSIK, each of length NEQ.
5499 C     PWK       -- Work vector for DNSIK of length NEQ.
5500 C     WM,IWM    -- Real and integer arrays storing
5501 C                  matrix information such as the matrix
5502 C                  of partial derivatives, permutation
5503 C                  vector, and various other information.
5504 C     CJ        -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2).
5505 C     TSCALE    -- Scale factor in T, used for stopping tests if nonzero.
5506 C     SQRTN     -- Square root of NEQ.
5507 C     RSQRTN    -- reciprical of square root of NEQ.
5508 C     EPLIN     -- Tolerance for linear system solver.
5509 C     EPCON     -- Tolerance to test for convergence of the Newton
5510 C                  iteration.
5511 C     RATEMX    -- Maximum convergence rate for which Newton iteration
5512 C                  is considered converging.
5513 C     MAXIT     -- Maximum allowed number of Newton iterations.
5514 C     STPTOL    -- Tolerance used in calculating the minimum lambda
5515 C                  value allowed.
5516 C     ICNFLG    -- Integer scalar.  If nonzero, then constraint
5517 C                  violations in the proposed new approximate solution
5518 C                  will be checked for, and the maximum step length
5519 C                  will be adjusted accordingly.
5520 C     ICNSTR    -- Integer array of length NEQ containing flags for
5521 C                  checking constraints.
5522 C     IERNEW    -- Error flag for Newton iteration.
5523 C                   0  ==> Newton iteration converged.
5524 C                   1  ==> failed to converge, but RATE .lt. 1, or the
5525 C                          residual norm was reduced by a factor of .1.
5526 C                   2  ==> failed to converge, RATE .gt. RATEMX.
5527 C                   3  ==> other recoverable error.
5528 C                  -1  ==> unrecoverable error inside Newton iteration.
5529 C-----------------------------------------------------------------------
5530 C
5531 C***ROUTINES CALLED
5532 C   DFNRMK, DSLVK, DDWNRM, DLINSK, DCOPY
5533 C
5534 C***END PROLOGUE  DNSIK
5535 C
5536 C
5537       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
5538       DIMENSION Y(*),YPRIME(*),WT(*),ID(*),DELTA(*),R(*),SAVR(*)
5539       DIMENSION YIC(*),YPIC(*),PWK(*),WM(*),IWM(*), RPAR(*),IPAR(*)
5540       DIMENSION ICNSTR(*)
5541       EXTERNAL RES, PSOL
5542 C
5543       PARAMETER (LNNI=19, LNPS=21, LLOCWP=29, LLCIWP=30)
5544       PARAMETER (LLSOFF=35, LSTOL=14)
5545 C
5546 C
5547 C     Initializations.  M is the Newton iteration counter.
5548 C
5549       LSOFF = IWM(LLSOFF)
5550       M = 0
5551       RATE = 1.0D0
5552       LWP = IWM(LLOCWP)
5553       LIWP = IWM(LLCIWP)
5554       RLX = 0.4D0
5555 C
5556 C     Save residual in SAVR.
5557 C
5558       CALL DCOPY (NEQ, DELTA, 1, SAVR, 1)
5559 C
5560 C     Compute norm of (P-inverse)*(residual).
5561 C
5562       CALL DFNRMK (NEQ, Y, X, YPRIME, SAVR, R, CJ, TSCALE, WT,
5563      *   SQRTN, RSQRTN, RES, IRES, PSOL, 1, IER, FNRM, EPLIN,
5564      *   WM(LWP), IWM(LIWP), PWK, RPAR, IPAR)
5565       IWM(LNPS) = IWM(LNPS) + 1
5566       IF (IER .NE. 0) THEN
5567         IERNEW = 3
5568         RETURN
5569       ENDIF
5570 C
5571 C     Return now if residual norm is .le. EPCON.
5572 C
5573       IF (FNRM .LE. EPCON) RETURN
5574 C
5575 C     Newton iteration loop.
5576 C
5577       FNRM0 = FNRM
5578 300   CONTINUE
5579       IWM(LNNI) = IWM(LNNI) + 1
5580 C
5581 C     Compute a new step vector DELTA.
5582 C
5583       CALL DSLVK (NEQ, Y, X, YPRIME, SAVR, DELTA, WT, WM, IWM,
5584      *   RES, IRES, PSOL, IERSL, CJ, EPLIN, SQRTN, RSQRTN, RHOK,
5585      *   RPAR, IPAR)
5586       IF (IRES .NE. 0 .OR. IERSL .NE. 0) GO TO 390
5587 C
5588 C     Get norm of DELTA.  Return now if DELTA is zero.
5589 C
5590       DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR)
5591       IF (DELNRM .EQ. 0.0D0) RETURN
5592 C
5593 C     Call linesearch routine for global strategy and set RATE.
5594 C
5595       OLDFNM = FNRM
5596 C
5597       CALL DLINSK (NEQ, Y, X, YPRIME, SAVR, CJ, TSCALE, DELTA, DELNRM,
5598      *   WT, SQRTN, RSQRTN, LSOFF, STPTOL, IRET, RES, IRES, PSOL,
5599      *   WM, IWM, RHOK, FNRM, ICOPT, ID, WM(LWP), IWM(LIWP), R, EPLIN,
5600      *   YIC, YPIC, PWK, ICNFLG, ICNSTR, RLX, RPAR, IPAR)
5601 C
5602       RATE = FNRM/OLDFNM
5603 C
5604 C     Check for error condition from linesearch.
5605       IF (IRET .NE. 0) GO TO 390
5606 C
5607 C     Test for convergence of the iteration, and return or loop.
5608 C
5609       IF (FNRM .LE. EPCON) RETURN
5610 C
5611 C     The iteration has not yet converged.  Update M.
5612 C     Test whether the maximum number of iterations have been tried.
5613 C
5614       M = M + 1
5615       IF(M .GE. MAXIT) GO TO 380
5616 C
5617 C     Copy the residual SAVR to DELTA and loop for another iteration.
5618 C
5619       CALL DCOPY (NEQ,  SAVR, 1, DELTA, 1)
5620       GO TO 300
5621 C
5622 C     The maximum number of iterations was done.  Set IERNEW and return.
5623 C
5624 380   IF (RATE .LE. RATEMX .OR. FNRM .LE. 0.1D0*FNRM0) THEN
5625          IERNEW = 1
5626       ELSE
5627          IERNEW = 2
5628       ENDIF
5629       RETURN
5630 C
5631 390   IF (IRES .LE. -2 .OR. IERSL .LT. 0) THEN
5632          IERNEW = -1
5633       ELSE
5634          IERNEW = 3
5635          IF (IRES .EQ. 0 .AND. IERSL .EQ. 1 .AND. M .GE. 2 
5636      1       .AND. RATE .LT. 1.0D0) IERNEW = 1
5637       ENDIF
5638       RETURN
5639 C
5640 C
5641 C----------------------- END OF SUBROUTINE DNSIK------------------------
5642       END
5643       SUBROUTINE DLINSK (NEQ, Y, T, YPRIME, SAVR, CJ, TSCALE, P, PNRM,
5644      *   WT, SQRTN, RSQRTN, LSOFF, STPTOL, IRET, RES, IRES, PSOL,
5645      *   WM, IWM, RHOK, FNRM, ICOPT, ID, WP, IWP, R, EPLIN, YNEW, YPNEW,
5646      *   PWK, ICNFLG, ICNSTR, RLX, RPAR, IPAR)
5647 C
5648 C***BEGIN PROLOGUE  DLINSK
5649 C***REFER TO  DNSIK
5650 C***DATE WRITTEN   940830   (YYMMDD)
5651 C***REVISION DATE  951006   (Arguments SQRTN, RSQRTN added.)
5652 C***REVISION DATE  960129   Moved line RL = ONE to top block.
5653 C***REVISION DATE  000628   TSCALE argument added.
5654 C***REVISION DATE  000628   RHOK*RHOK term removed in alpha test.
5655 C
5656 C
5657 C-----------------------------------------------------------------------
5658 C***DESCRIPTION
5659 C
5660 C     DLINSK uses a linesearch algorithm to calculate a new (Y,YPRIME)
5661 C     pair (YNEW,YPNEW) such that 
5662 C
5663 C     f(YNEW,YPNEW) .le. (1 - 2*ALPHA*RL)*f(Y,YPRIME)
5664 C
5665 C     where 0 < RL <= 1, and RHOK is the scaled preconditioned norm of
5666 C     the final residual vector in the Krylov iteration.  
5667 C     Here, f(y,y') is defined as
5668 C
5669 C      f(y,y') = (1/2)*norm( (P-inverse)*G(t,y,y') )**2 ,
5670 C
5671 C     where norm() is the weighted RMS vector norm, G is the DAE
5672 C     system residual function, and P is the preconditioner used
5673 C     in the Krylov iteration.
5674 C
5675 C     In addition to the parameters defined elsewhere, we have
5676 C
5677 C     SAVR    -- Work array of length NEQ, containing the residual
5678 C                vector G(t,y,y') on return.
5679 C     TSCALE  -- Scale factor in T, used for stopping tests if nonzero.
5680 C     P       -- Approximate Newton step used in backtracking.
5681 C     PNRM    -- Weighted RMS norm of P.
5682 C     LSOFF   -- Flag showing whether the linesearch algorithm is
5683 C                to be invoked.  0 means do the linesearch, 
5684 C                1 means turn off linesearch.
5685 C     STPTOL  -- Tolerance used in calculating the minimum lambda
5686 C                value allowed.
5687 C     ICNFLG  -- Integer scalar.  If nonzero, then constraint violations
5688 C                in the proposed new approximate solution will be
5689 C                checked for, and the maximum step length will be
5690 C                adjusted accordingly.
5691 C     ICNSTR  -- Integer array of length NEQ containing flags for
5692 C                checking constraints.
5693 C     RHOK    -- Weighted norm of preconditioned Krylov residual.
5694 C     RLX     -- Real scalar restricting update size in DCNSTR.
5695 C     YNEW    -- Array of length NEQ used to hold the new Y in
5696 C                performing the linesearch.
5697 C     YPNEW   -- Array of length NEQ used to hold the new YPRIME in
5698 C                performing the linesearch.
5699 C     PWK     -- Work vector of length NEQ for use in PSOL.
5700 C     Y       -- Array of length NEQ containing the new Y (i.e.,=YNEW).
5701 C     YPRIME  -- Array of length NEQ containing the new YPRIME 
5702 C                (i.e.,=YPNEW).
5703 C     FNRM    -- Real scalar containing SQRT(2*f(Y,YPRIME)) for the
5704 C                current (Y,YPRIME) on input and output.
5705 C     R       -- Work space length NEQ for residual vector.
5706 C     IRET    -- Return flag.
5707 C                IRET=0 means that a satisfactory (Y,YPRIME) was found.
5708 C                IRET=1 means that the routine failed to find a new
5709 C                       (Y,YPRIME) that was sufficiently distinct from
5710 C                       the current (Y,YPRIME) pair.
5711 C                IRET=2 means a failure in RES or PSOL.
5712 C-----------------------------------------------------------------------
5713 C
5714 C***ROUTINES CALLED
5715 C   DFNRMK, DYYPNW, DCNSTR, DCOPY, XERRWD
5716 C
5717 C***END PROLOGUE  DLINSK
5718 C
5719       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
5720       EXTERNAL  RES, PSOL
5721       DIMENSION Y(*), YPRIME(*), P(*), WT(*), SAVR(*), R(*), ID(*)
5722       DIMENSION WM(*), IWM(*), YNEW(*), YPNEW(*), PWK(*), ICNSTR(*)
5723       DIMENSION WP(*), IWP(*), RPAR(*), IPAR(*)
5724       CHARACTER MSG*80
5725 C
5726       PARAMETER (LNRE=12, LNPS=21, LKPRIN=31)
5727 C
5728       SAVE ALPHA, ONE, TWO
5729       DATA ALPHA/1.0D-4/, ONE/1.0D0/, TWO/2.0D0/
5730 C
5731       KPRIN=IWM(LKPRIN)
5732       F1NRM = (FNRM*FNRM)/TWO
5733       RATIO = ONE
5734 C
5735       IF (KPRIN .GE. 2) THEN
5736         MSG = '------ IN ROUTINE DLINSK-- PNRM = (R1)'
5737         CALL XERRWD(MSG, 38, 921, 0, 0, 0, 0, 1, PNRM, 0.0D0)
5738         ENDIF
5739       TAU = PNRM
5740       RL = ONE
5741 C-----------------------------------------------------------------------
5742 C Check for violations of the constraints, if any are imposed.
5743 C If any violations are found, the step vector P is rescaled, and the 
5744 C constraint check is repeated, until no violations are found.
5745 C-----------------------------------------------------------------------
5746       IF (ICNFLG .NE. 0) THEN
5747  10      CONTINUE
5748          CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW)
5749          CALL DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR)
5750          IF (IRET .EQ. 1) THEN
5751             RATIO1 = TAU/PNRM
5752             RATIO = RATIO*RATIO1
5753             DO 20 I = 1,NEQ
5754  20           P(I) = P(I)*RATIO1
5755             PNRM = TAU
5756             IF (KPRIN .GE. 2) THEN
5757               MSG = '------ CONSTRAINT VIOL., PNRM = (R1), INDEX = (I1)'
5758               CALL XERRWD(MSG, 50, 922, 0, 1, IVAR, 0, 1, PNRM, 0.0D0)
5759               ENDIF
5760             IF (PNRM .LE. STPTOL) THEN
5761               IRET = 1
5762               RETURN
5763               ENDIF
5764             GO TO 10
5765             ENDIF
5766          ENDIF
5767 C
5768       SLPI = -TWO*F1NRM*RATIO
5769       RLMIN = STPTOL/PNRM
5770       IF (LSOFF .EQ. 0 .AND. KPRIN .GE. 2) THEN
5771         MSG = '------ MIN. LAMBDA = (R1)'
5772         CALL XERRWD(MSG, 25, 923, 0, 0, 0, 0, 1, RLMIN, 0.0D0)
5773         ENDIF
5774 C-----------------------------------------------------------------------
5775 C Begin iteration to find RL value satisfying alpha-condition.
5776 C Update YNEW and YPNEW, then compute norm of new scaled residual and
5777 C perform alpha condition test.
5778 C-----------------------------------------------------------------------
5779  100  CONTINUE
5780       CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW)
5781       CALL DFNRMK (NEQ, YNEW, T, YPNEW, SAVR, R, CJ, TSCALE, WT,
5782      *   SQRTN, RSQRTN, RES, IRES, PSOL, 0, IER, FNRMP, EPLIN,
5783      *   WP, IWP, PWK, RPAR, IPAR)
5784       IWM(LNRE) = IWM(LNRE) + 1
5785       IF (IRES .GE. 0) IWM(LNPS) = IWM(LNPS) + 1
5786       IF (IRES .NE. 0 .OR. IER .NE. 0) THEN
5787         IRET = 2
5788         RETURN
5789         ENDIF
5790       IF (LSOFF .EQ. 1) GO TO 150
5791 C
5792       F1NRMP = FNRMP*FNRMP/TWO
5793       IF (KPRIN .GE. 2) THEN
5794         MSG = '------ LAMBDA = (R1)'
5795         CALL XERRWD(MSG, 20, 924, 0, 0, 0, 0, 1, RL, 0.0D0)
5796         MSG = '------ NORM(F1) = (R1),  NORM(F1NEW) = (R2)'
5797         CALL XERRWD(MSG, 43, 925, 0, 0, 0, 0, 2, F1NRM, F1NRMP)
5798         ENDIF
5799       IF (F1NRMP .GT. F1NRM + ALPHA*SLPI*RL) GO TO 200
5800 C-----------------------------------------------------------------------
5801 C Alpha-condition is satisfied, or linesearch is turned off.
5802 C Copy YNEW,YPNEW to Y,YPRIME and return.
5803 C-----------------------------------------------------------------------
5804  150  IRET = 0
5805       CALL DCOPY(NEQ, YNEW, 1, Y, 1)
5806       CALL DCOPY(NEQ, YPNEW, 1, YPRIME, 1)
5807       FNRM = FNRMP
5808       IF (KPRIN .GE. 1) THEN
5809         MSG = '------ LEAVING ROUTINE DLINSK, FNRM = (R1)'
5810         CALL XERRWD(MSG, 42, 926, 0, 0, 0, 0, 1, FNRM, 0.0D0)
5811         ENDIF
5812       RETURN
5813 C-----------------------------------------------------------------------
5814 C Alpha-condition not satisfied.  Perform backtrack to compute new RL
5815 C value.  If RL is less than RLMIN, i.e. no satisfactory YNEW,YPNEW can
5816 C be found sufficiently distinct from Y,YPRIME, then return IRET = 1.
5817 C-----------------------------------------------------------------------
5818  200  CONTINUE
5819       IF (RL .LT. RLMIN) THEN
5820         IRET = 1
5821         RETURN
5822         ENDIF
5823 C
5824       RL = RL/TWO
5825       GO TO 100
5826 C
5827 C----------------------- END OF SUBROUTINE DLINSK ----------------------
5828       END
5829       SUBROUTINE DFNRMK (NEQ, Y, T, YPRIME, SAVR, R, CJ, TSCALE, WT,
5830      *                   SQRTN, RSQRTN, RES, IRES, PSOL, IRIN, IER,
5831      *                   FNORM, EPLIN, WP, IWP, PWK, RPAR, IPAR)
5832 C
5833 C***BEGIN PROLOGUE  DFNRMK
5834 C***REFER TO  DLINSK
5835 C***DATE WRITTEN   940830   (YYMMDD)
5836 C***REVISION DATE  951006   (SQRTN, RSQRTN, and scaling of WT added.)
5837 C***REVISION DATE  000628   TSCALE argument added.
5838 C
5839 C
5840 C-----------------------------------------------------------------------
5841 C***DESCRIPTION
5842 C
5843 C     DFNRMK calculates the scaled preconditioned norm of the nonlinear
5844 C     function used in the nonlinear iteration for obtaining consistent
5845 C     initial conditions.  Specifically, DFNRMK calculates the weighted
5846 C     root-mean-square norm of the vector (P-inverse)*G(T,Y,YPRIME),
5847 C     where P is the preconditioner matrix.
5848 C
5849 C     In addition to the parameters described in the calling program
5850 C     DLINSK, the parameters represent
5851 C
5852 C     TSCALE -- Scale factor in T, used for stopping tests if nonzero.
5853 C     IRIN   -- Flag showing whether the current residual vector is
5854 C               input in SAVR.  1 means it is, 0 means it is not.
5855 C     R      -- Array of length NEQ that contains
5856 C               (P-inverse)*G(T,Y,YPRIME) on return.
5857 C     FNORM  -- Scalar containing the weighted norm of R on return.
5858 C-----------------------------------------------------------------------
5859 C
5860 C***ROUTINES CALLED
5861 C   RES, DCOPY, DSCAL, PSOL, DDWNRM
5862 C
5863 C***END PROLOGUE  DFNRMK
5864 C
5865 C
5866       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5867       EXTERNAL RES, PSOL
5868       DIMENSION Y(*), YPRIME(*), WT(*), SAVR(*), R(*), PWK(*)
5869       DIMENSION WP(*), IWP(*), RPAR(*), IPAR(*)
5870 C-----------------------------------------------------------------------
5871 C     Call RES routine if IRIN = 0.
5872 C-----------------------------------------------------------------------
5873       IF (IRIN .EQ. 0) THEN
5874         IRES = 0
5875         CALL RES (T, Y, YPRIME, SAVR, IRES, RPAR, IPAR)
5876         IF (IRES .LT. 0) RETURN
5877         ENDIF
5878 C-----------------------------------------------------------------------
5879 C     Apply inverse of left preconditioner to vector R.
5880 C     First scale WT array by 1/sqrt(N), and undo scaling afterward.
5881 C-----------------------------------------------------------------------
5882       CALL DCOPY(NEQ, SAVR, 1, R, 1)
5883       CALL DSCAL (NEQ, RSQRTN, WT, 1)
5884       IER = 0
5885       CALL PSOL (NEQ, T, Y, YPRIME, SAVR, PWK, CJ, WT, WP, IWP,
5886      *           R, EPLIN, IER, RPAR, IPAR)
5887       CALL DSCAL (NEQ, SQRTN, WT, 1)
5888       IF (IER .NE. 0) RETURN
5889 C-----------------------------------------------------------------------
5890 C     Calculate norm of R.
5891 C-----------------------------------------------------------------------
5892       FNORM = DDWNRM (NEQ, R, WT, RPAR, IPAR)
5893       IF (TSCALE .GT. 0.0D0) FNORM = FNORM*TSCALE*ABS(CJ)
5894 C
5895       RETURN
5896 C----------------------- END OF SUBROUTINE DFNRMK ----------------------
5897       END
5898       SUBROUTINE DNEDK(X,Y,YPRIME,NEQ,RES,JACK,PSOL,
5899      *   H,WT,JSTART,IDID,RPAR,IPAR,PHI,GAMMA,SAVR,DELTA,E,
5900      *   WM,IWM,CJ,CJOLD,CJLAST,S,UROUND,EPLI,SQRTN,RSQRTN,
5901      *   EPCON,JCALC,JFLG,KP1,NONNEG,NTYPE,IERNLS)
5902 C
5903 C***BEGIN PROLOGUE  DNEDK
5904 C***REFER TO  DDASPK
5905 C***DATE WRITTEN   891219   (YYMMDD)
5906 C***REVISION DATE  900926   (YYMMDD)
5907 C***REVISION DATE  940701   (YYMMDD)
5908 C
5909 C
5910 C-----------------------------------------------------------------------
5911 C***DESCRIPTION
5912 C
5913 C     DNEDK solves a nonlinear system of
5914 C     algebraic equations of the form
5915 C     G(X,Y,YPRIME) = 0 for the unknown Y.
5916 C
5917 C     The method used is a matrix-free Newton scheme.
5918 C
5919 C     The parameters represent
5920 C     X         -- Independent variable.
5921 C     Y         -- Solution vector at x.
5922 C     YPRIME    -- Derivative of solution vector
5923 C                  after successful step.
5924 C     NEQ       -- Number of equations to be integrated.
5925 C     RES       -- External user-supplied subroutine
5926 C                  to evaluate the residual.  See RES description
5927 C                  in DDASPK prologue.
5928 C     JACK     --  External user-supplied routine to update
5929 C                  the preconditioner.  (This is optional).
5930 C                  See JAC description for the case
5931 C                  INFO(12) = 1 in the DDASPK prologue.
5932 C     PSOL      -- External user-supplied routine to solve
5933 C                  a linear system using preconditioning. 
5934 C                  (This is optional).  See explanation inside DDASPK.
5935 C     H         -- Appropriate step size for this step.
5936 C     WT        -- Vector of weights for error criterion.
5937 C     JSTART    -- Indicates first call to this routine.
5938 C                  If JSTART = 0, then this is the first call,
5939 C                  otherwise it is not.
5940 C     IDID      -- Completion flag, output by DNEDK.
5941 C                  See IDID description in DDASPK prologue.
5942 C     RPAR,IPAR -- Real and integer arrays used for communication
5943 C                  between the calling program and external user
5944 C                  routines.  They are not altered within DASPK.
5945 C     PHI       -- Array of divided differences used by
5946 C                  DNEDK.  The length is NEQ*(K+1), where
5947 C                  K is the maximum order.
5948 C     GAMMA     -- Array used to predict Y and YPRIME.  The length
5949 C                  is K+1, where K is the maximum order.
5950 C     SAVR      -- Work vector for DNEDK of length NEQ.
5951 C     DELTA     -- Work vector for DNEDK of length NEQ.
5952 C     E         -- Error accumulation vector for DNEDK of length NEQ.
5953 C     WM,IWM    -- Real and integer arrays storing
5954 C                  matrix information for linear system
5955 C                  solvers, and various other information.
5956 C     CJ        -- Parameter always proportional to 1/H.
5957 C     CJOLD     -- Saves the value of CJ as of the last call to DITMD.
5958 C                  Accounts for changes in CJ needed to
5959 C                  decide whether to call DITMD.
5960 C     CJLAST    -- Previous value of CJ.
5961 C     S         -- A scalar determined by the approximate rate
5962 C                  of convergence of the Newton iteration and used
5963 C                  in the convergence test for the Newton iteration.
5964 C
5965 C                  If RATE is defined to be an estimate of the
5966 C                  rate of convergence of the Newton iteration,
5967 C                  then S = RATE/(1.D0-RATE).
5968 C
5969 C                  The closer RATE is to 0., the faster the Newton
5970 C                  iteration is converging; the closer RATE is to 1.,
5971 C                  the slower the Newton iteration is converging.
5972 C
5973 C                  On the first Newton iteration with an up-dated
5974 C                  preconditioner S = 100.D0, Thus the initial
5975 C                  RATE of convergence is approximately 1.
5976 C
5977 C                  S is preserved from call to call so that the rate
5978 C                  estimate from a previous step can be applied to
5979 C                  the current step.
5980 C     UROUND    -- Unit roundoff.  Not used here.
5981 C     EPLI      -- convergence test constant.
5982 C                  See DDASPK prologue for more details.
5983 C     SQRTN     -- Square root of NEQ.
5984 C     RSQRTN    -- reciprical of square root of NEQ.
5985 C     EPCON     -- Tolerance to test for convergence of the Newton
5986 C                  iteration.
5987 C     JCALC     -- Flag used to determine when to update
5988 C                  the Jacobian matrix.  In general:
5989 C
5990 C                  JCALC = -1 ==> Call the DITMD routine to update
5991 C                                 the Jacobian matrix.
5992 C                  JCALC =  0 ==> Jacobian matrix is up-to-date.
5993 C                  JCALC =  1 ==> Jacobian matrix is out-dated,
5994 C                                 but DITMD will not be called unless
5995 C                                 JCALC is set to -1.
5996 C     JFLG      -- Flag showing whether a Jacobian routine is supplied.
5997 C     KP1       -- The current order + 1;  updated across calls.
5998 C     NONNEG    -- Flag to determine nonnegativity constraints.
5999 C     NTYPE     -- Identification code for the DNEDK routine.
6000 C                   1 ==> modified Newton; iterative linear solver.
6001 C                   2 ==> modified Newton; user-supplied linear solver.
6002 C     IERNLS    -- Error flag for nonlinear solver.
6003 C                   0 ==> nonlinear solver converged.
6004 C                   1 ==> recoverable error inside non-linear solver.
6005 C                  -1 ==> unrecoverable error inside non-linear solver.
6006 C
6007 C     The following group of variables are passed as arguments to
6008 C     the Newton iteration solver.  They are explained in greater detail
6009 C     in DNSK:
6010 C        TOLNEW, MULDEL, MAXIT, IERNEW
6011 C
6012 C     IERTYP -- Flag which tells whether this subroutine is correct.
6013 C               0 ==> correct subroutine.
6014 C               1 ==> incorrect subroutine.
6015 C
6016 C-----------------------------------------------------------------------
6017 C***ROUTINES CALLED
6018 C   RES, JACK, DDWNRM, DNSK
6019 C
6020 C***END PROLOGUE  DNEDK
6021 C
6022 C
6023       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
6024       DIMENSION Y(*),YPRIME(*),WT(*)
6025       DIMENSION PHI(NEQ,*),SAVR(*),DELTA(*),E(*)
6026       DIMENSION WM(*),IWM(*)
6027       DIMENSION GAMMA(*),RPAR(*),IPAR(*)
6028       EXTERNAL  RES, JACK, PSOL
6029 C
6030       PARAMETER (LNRE=12, LNJE=13, LLOCWP=29, LLCIWP=30)
6031 C
6032       SAVE MULDEL, MAXIT, XRATE
6033       DATA MULDEL/0/, MAXIT/4/, XRATE/0.25D0/
6034 C
6035       COMMON /ierode/ierror
6036 C
6037 C
6038 C     Verify that this is the correct subroutine.
6039 C
6040       IERTYP = 0
6041       IF (NTYPE .NE. 1) THEN
6042          IERTYP = 1
6043          GO TO 380
6044          ENDIF
6045 C
6046 C     If this is the first step, perform initializations.
6047 C
6048       IF (JSTART .EQ. 0) THEN
6049          CJOLD = CJ
6050          JCALC = -1
6051          S = 100.D0
6052          ENDIF
6053 C
6054 C     Perform all other initializations.
6055 C
6056       IERNLS = 0
6057       LWP = IWM(LLOCWP)
6058       LIWP = IWM(LLCIWP)
6059 C
6060 C     Decide whether to update the preconditioner.
6061 C
6062       IF (JFLG .NE. 0) THEN
6063          TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE)
6064          TEMP2 = 1.0D0/TEMP1
6065          IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1
6066          IF (CJ .NE. CJLAST) S = 100.D0
6067       ELSE
6068          JCALC = 0
6069          ENDIF
6070 C
6071 C     Looping point for updating preconditioner with current stepsize.
6072 C
6073 300   CONTINUE
6074 C
6075 C     Initialize all error flags to zero.
6076 C
6077       IERPJ = 0
6078       IRES = 0
6079       IERSL = 0
6080       IERNEW = 0
6081 C
6082 C     Predict the solution and derivative and compute the tolerance
6083 C     for the Newton iteration.
6084 C
6085       DO 310 I=1,NEQ
6086          Y(I)=PHI(I,1)
6087 310      YPRIME(I)=0.0D0
6088       DO 330 J=2,KP1
6089          DO 320 I=1,NEQ
6090             Y(I)=Y(I)+PHI(I,J)
6091 320         YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J)
6092 330   CONTINUE
6093       EPLIN = EPLI*EPCON
6094       TOLNEW = EPLIN
6095 C
6096 C     Call RES to initialize DELTA.
6097 C
6098       IWM(LNRE)=IWM(LNRE)+1
6099       CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
6100 C     ierror indicates if RES had the right prototype
6101       IF(ierror.ne.0) THEN
6102          IDID=-12
6103          RETURN
6104       ENDIF
6105
6106       IF (IRES .LT. 0) GO TO 380
6107 C
6108 C
6109 C     If indicated, update the preconditioner.
6110 C     Set JCALC to 0 as an indicator that this has been done.
6111 C
6112       IF(JCALC .EQ. -1)THEN
6113          IWM(LNJE) = IWM(LNJE) + 1
6114          JCALC=0
6115          CALL JACK (RES, IRES, NEQ, X, Y, YPRIME, WT, DELTA, E, H, CJ,
6116      *      WM(LWP), IWM(LIWP), IERPJ, RPAR, IPAR)
6117          CJOLD=CJ
6118          S = 100.D0
6119          IF (IRES .LT. 0)  GO TO 380
6120          IF (IERPJ .NE. 0) GO TO 380
6121       ENDIF
6122 C
6123 C     Call the nonlinear Newton solver.
6124 C
6125       CALL DNSK(X,Y,YPRIME,NEQ,RES,PSOL,WT,RPAR,IPAR,SAVR,
6126      *   DELTA,E,WM,IWM,CJ,SQRTN,RSQRTN,EPLIN,EPCON,
6127      *   S,TEMP1,TOLNEW,MULDEL,MAXIT,IRES,IERSL,IERNEW)
6128 C
6129       IF (IERNEW .GT. 0 .AND. JCALC .NE. 0) THEN
6130 C
6131 C     The Newton iteration had a recoverable failure with an old
6132 C     preconditioner.  Retry the step with a new preconditioner.
6133 C
6134          JCALC = -1
6135          GO TO 300
6136       ENDIF
6137 C
6138       IF (IERNEW .NE. 0) GO TO 380
6139 C
6140 C     The Newton iteration has converged.  If nonnegativity of
6141 C     solution is required, set the solution nonnegative, if the
6142 C     perturbation to do it is small enough.  If the change is too
6143 C     large, then consider the corrector iteration to have failed.
6144 C
6145       IF(NONNEG .EQ. 0) GO TO 390
6146       DO 360 I = 1,NEQ
6147  360    DELTA(I) = MIN(Y(I),0.0D0)
6148       DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR)
6149       IF(DELNRM .GT. EPCON) GO TO 380
6150       DO 370 I = 1,NEQ
6151  370    E(I) = E(I) - DELTA(I)
6152       GO TO 390
6153 C
6154 C
6155 C     Exits from nonlinear solver.
6156 C     No convergence with current preconditioner.
6157 C     Compute IERNLS and IDID accordingly.
6158 C
6159 380   CONTINUE
6160       IF (IRES .LE. -2 .OR. IERSL .LT. 0 .OR. IERTYP .NE. 0) THEN
6161          IERNLS = -1
6162          IF (IRES .LE. -2) IDID = -11
6163          IF (IERSL .LT. 0) IDID = -13
6164          IF (IERTYP .NE. 0) IDID = -15
6165       ELSE
6166          IERNLS =  1
6167          IF (IRES .EQ. -1) IDID = -10
6168          IF (IERPJ .NE. 0) IDID = -5
6169          IF (IERSL .GT. 0) IDID = -14
6170       ENDIF
6171 C
6172 C
6173 390   JCALC = 1
6174       RETURN
6175 C
6176 C------END OF SUBROUTINE DNEDK------------------------------------------
6177       END
6178       SUBROUTINE DNSK(X,Y,YPRIME,NEQ,RES,PSOL,WT,RPAR,IPAR,
6179      *   SAVR,DELTA,E,WM,IWM,CJ,SQRTN,RSQRTN,EPLIN,EPCON,
6180      *   S,CONFAC,TOLNEW,MULDEL,MAXIT,IRES,IERSL,IERNEW)
6181 C
6182 C***BEGIN PROLOGUE  DNSK
6183 C***REFER TO  DDASPK
6184 C***DATE WRITTEN   891219   (YYMMDD)
6185 C***REVISION DATE  900926   (YYMMDD)
6186 C***REVISION DATE  950126   (YYMMDD)
6187 C***REVISION DATE  000711   (YYMMDD)
6188 C
6189 C
6190 C-----------------------------------------------------------------------
6191 C***DESCRIPTION
6192 C
6193 C     DNSK solves a nonlinear system of
6194 C     algebraic equations of the form
6195 C     G(X,Y,YPRIME) = 0 for the unknown Y.
6196 C
6197 C     The method used is a modified Newton scheme.
6198 C
6199 C     The parameters represent
6200 C
6201 C     X         -- Independent variable.
6202 C     Y         -- Solution vector.
6203 C     YPRIME    -- Derivative of solution vector.
6204 C     NEQ       -- Number of unknowns.
6205 C     RES       -- External user-supplied subroutine
6206 C                  to evaluate the residual.  See RES description
6207 C                  in DDASPK prologue.
6208 C     PSOL      -- External user-supplied routine to solve
6209 C                  a linear system using preconditioning. 
6210 C                  See explanation inside DDASPK.
6211 C     WT        -- Vector of weights for error criterion.
6212 C     RPAR,IPAR -- Real and integer arrays used for communication
6213 C                  between the calling program and external user
6214 C                  routines.  They are not altered within DASPK.
6215 C     SAVR      -- Work vector for DNSK of length NEQ.
6216 C     DELTA     -- Work vector for DNSK of length NEQ.
6217 C     E         -- Error accumulation vector for DNSK of length NEQ.
6218 C     WM,IWM    -- Real and integer arrays storing
6219 C