04c10ae116c688b4319a584033b9ba25e3b1694d
[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 C
1435 C***FIRST EXECUTABLE STATEMENT  DDASKR
1436 C
1437 C
1438       IF(INFO(1).NE.0) GO TO 100
1439 C
1440 C-----------------------------------------------------------------------
1441 C     This block is executed for the initial call only.
1442 C     It contains checking of inputs and initializations.
1443 C-----------------------------------------------------------------------
1444 C
1445 C     First check INFO array to make sure all elements of INFO
1446 C     Are within the proper range.  (INFO(1) is checked later, because
1447 C     it must be tested on every call.) ITEMP holds the location
1448 C     within INFO which may be out of range.
1449 C
1450       DO 10 I=2,9
1451          ITEMP = I
1452          IF (INFO(I) .NE. 0 .AND. INFO(I) .NE. 1) GO TO 701
1453  10      CONTINUE
1454       ITEMP = 10
1455       IF(INFO(10).LT.0 .OR. INFO(10).GT.3) GO TO 701
1456       ITEMP = 11
1457       IF(INFO(11).LT.0 .OR. INFO(11).GT.2) GO TO 701
1458       DO 15 I=12,17
1459          ITEMP = I
1460          IF (INFO(I) .NE. 0 .AND. INFO(I) .NE. 1) GO TO 701
1461  15      CONTINUE
1462       ITEMP = 18
1463       IF(INFO(18).LT.0 .OR. INFO(18).GT.2) GO TO 701
1464
1465 C
1466 C     Check NEQ to see if it is positive.
1467 C
1468       IF (NEQ .LE. 0) GO TO 702
1469 C
1470 C     Check and compute maximum order.
1471 C
1472       MXORD=5
1473       IF (INFO(9) .NE. 0) THEN
1474          MXORD=IWORK(LMXORD)
1475          IF (MXORD .LT. 1 .OR. MXORD .GT. 5) GO TO 703
1476          ENDIF
1477       IWORK(LMXORD)=MXORD
1478 C
1479 C     Set and/or check inputs for constraint checking (INFO(10) .NE. 0).
1480 C     Set values for ICNFLG, NONNEG, and pointer LID.
1481 C
1482       ICNFLG = 0
1483       NONNEG = 0
1484       LID = LICNS
1485       IF (INFO(10) .EQ. 0) GO TO 20
1486       IF (INFO(10) .EQ. 1) THEN
1487          ICNFLG = 1
1488          NONNEG = 0
1489          LID = LICNS + NEQ
1490       ELSEIF (INFO(10) .EQ. 2) THEN
1491          ICNFLG = 0
1492          NONNEG = 1
1493       ELSE
1494          ICNFLG = 1
1495          NONNEG = 1
1496          LID = LICNS + NEQ
1497       ENDIF
1498 C
1499  20   CONTINUE
1500 C
1501 C     Set and/or check inputs for Krylov solver (INFO(12) .NE. 0).
1502 C     If indicated, set default values for MAXL, KMP, NRMAX, and EPLI.
1503 C     Otherwise, verify inputs required for iterative solver.
1504 C
1505       IF (INFO(12) .EQ. 0) GO TO 25
1506 C
1507       IWORK(LMITER) = INFO(12)
1508       IF (INFO(13) .EQ. 0) THEN
1509          IWORK(LMAXL) = MIN(5,NEQ)
1510          IWORK(LKMP) = IWORK(LMAXL)
1511          IWORK(LNRMAX) = 5
1512          RWORK(LEPLI) = 0.05D0
1513       ELSE
1514          IF(IWORK(LMAXL) .LT. 1 .OR. IWORK(LMAXL) .GT. NEQ) GO TO 720
1515          IF(IWORK(LKMP) .LT. 1 .OR. IWORK(LKMP) .GT. IWORK(LMAXL))
1516      1      GO TO 721
1517          IF(IWORK(LNRMAX) .LT. 0) GO TO 722
1518          IF(RWORK(LEPLI).LE.0.0D0 .OR. RWORK(LEPLI).GE.1.0D0)GO TO 723
1519          ENDIF
1520 C
1521  25   CONTINUE
1522 C
1523 C     Set and/or check controls for the initial condition calculation
1524 C     (INFO(11) .GT. 0).  If indicated, set default values.
1525 C     Otherwise, verify inputs required for iterative solver.
1526 C
1527       IF (INFO(11) .EQ. 0) GO TO 30
1528       IF (INFO(17) .EQ. 0) THEN
1529         IWORK(LMXNIT) = 5
1530         IF (INFO(12) .GT. 0) IWORK(LMXNIT) = 15
1531         IWORK(LMXNJ) = 6
1532         IF (INFO(12) .GT. 0) IWORK(LMXNJ) = 2
1533         IWORK(LMXNH) = 5
1534         IWORK(LLSOFF) = 0
1535         RWORK(LEPIN) = 0.01D0
1536       ELSE
1537         IF (IWORK(LMXNIT) .LE. 0) GO TO 725
1538         IF (IWORK(LMXNJ) .LE. 0) GO TO 725
1539         IF (IWORK(LMXNH) .LE. 0) GO TO 725
1540         LSOFF = IWORK(LLSOFF)
1541         IF (LSOFF .LT. 0 .OR. LSOFF .GT. 1) GO TO 725
1542         IF (RWORK(LEPIN) .LE. 0.0D0) GO TO 725
1543         ENDIF
1544 C
1545  30   CONTINUE
1546 C
1547 C     Below is the computation and checking of the work array lengths
1548 C     LENIW and LENRW, using direct methods (INFO(12) = 0) or
1549 C     the Krylov methods (INFO(12) = 1).
1550 C
1551       LENIC = 0
1552       IF (INFO(10) .EQ. 1 .OR. INFO(10) .EQ. 3) LENIC = NEQ
1553       LENID = 0
1554       IF (INFO(11) .EQ. 1 .OR. INFO(16) .EQ. 1) LENID = NEQ
1555       IF (INFO(12) .EQ. 0) THEN
1556 C
1557 C        Compute MTYPE, etc.  Check ML and MU.
1558 C
1559          NCPHI = MAX(MXORD + 1, 4)
1560          IF(INFO(6).EQ.0) THEN 
1561             LENPD = NEQ**2
1562             LENRW = 60 + 3*NRT + (NCPHI+3)*NEQ + LENPD
1563             IF(INFO(5).EQ.0) THEN
1564                IWORK(LMTYPE)=2
1565             ELSE
1566                IWORK(LMTYPE)=1
1567             ENDIF
1568          ELSE
1569             IF(IWORK(LML).LT.0.OR.IWORK(LML).GE.NEQ)GO TO 717
1570             IF(IWORK(LMU).LT.0.OR.IWORK(LMU).GE.NEQ)GO TO 718
1571             LENPD=(2*IWORK(LML)+IWORK(LMU)+1)*NEQ
1572             IF(INFO(5).EQ.0) THEN
1573                IWORK(LMTYPE)=5
1574                MBAND=IWORK(LML)+IWORK(LMU)+1
1575                MSAVE=(NEQ/MBAND)+1
1576                LENRW = 60 + 3*NRT + (NCPHI+3)*NEQ + LENPD + 2*MSAVE
1577             ELSE
1578                IWORK(LMTYPE)=4
1579                LENRW = 60 + 3*NRT + (NCPHI+3)*NEQ + LENPD
1580             ENDIF
1581          ENDIF
1582 C
1583 C        Compute LENIW, LENWP, LENIWP.
1584 C
1585          LENIW = 40 + LENIC + LENID + NEQ
1586          LENWP = 0
1587          LENIWP = 0
1588 C
1589       ELSE IF (INFO(12) .EQ. 1)  THEN
1590          NCPHI = MXORD + 1
1591          MAXL = IWORK(LMAXL)
1592          LENWP = IWORK(LLNWP)
1593          LENIWP = IWORK(LLNIWP)
1594          LENPD = (MAXL+3+MIN0(1,MAXL-IWORK(LKMP)))*NEQ
1595      1         + (MAXL+3)*MAXL + 1 + LENWP
1596          LENRW = 60 + 3*NRT + (MXORD+5)*NEQ + LENPD
1597          LENIW = 40 + LENIC + LENID + LENIWP
1598 C
1599       ENDIF
1600       IF(INFO(16) .NE. 0) LENRW = LENRW + NEQ
1601 C
1602 C     Check lengths of RWORK and IWORK.
1603 C
1604       IWORK(LNIW)=LENIW
1605       IWORK(LNRW)=LENRW
1606       IWORK(LNPD)=LENPD
1607       IWORK(LLOCWP) = LENPD-LENWP+1
1608       IF(LRW.LT.LENRW)GO TO 704
1609       IF(LIW.LT.LENIW)GO TO 705
1610 C
1611 C     Check ICNSTR for legality.
1612 C
1613       IF (LENIC .GT. 0) THEN
1614         DO 40 I = 1,NEQ
1615           ICI = IWORK(LICNS-1+I)
1616           IF (ICI .LT. -2 .OR. ICI .GT. 2) GO TO 726
1617  40       CONTINUE
1618         ENDIF
1619 C
1620 C     Check Y for consistency with constraints.
1621 C
1622       IF (LENIC .GT. 0) THEN
1623         CALL DCNST0(NEQ,Y,IWORK(LICNS),IRET)
1624         IF (IRET .NE. 0) GO TO 727
1625         ENDIF
1626 C
1627 C     Check ID for legality and set INDEX = 0 or 1.
1628 C
1629       INDEX = 1
1630       IF (LENID .GT. 0) THEN
1631         INDEX = 0
1632         DO 50 I = 1,NEQ
1633           IDI = IWORK(LID-1+I)
1634           IF (IDI .NE. 1 .AND. IDI .NE. -1) GO TO 724
1635           IF (IDI .EQ. -1) INDEX = 1
1636  50       CONTINUE
1637         ENDIF
1638 C
1639 C     Check to see that TOUT is different from T, and NRT .ge. 0.
1640 C
1641       IF(TOUT .EQ. T)GO TO 719
1642       IF(NRT .LT. 0) GO TO 730
1643 C
1644 C     Check HMAX.
1645 C
1646       IF(INFO(7) .NE. 0) THEN
1647          HMAX = RWORK(LHMAX)
1648          IF (HMAX .LE. 0.0D0) GO TO 710
1649          ENDIF
1650 C
1651 C     Initialize counters and other flags.
1652 C
1653       IWORK(LNST)=0
1654       IWORK(LNRE)=0
1655       IWORK(LNJE)=0
1656       IWORK(LETF)=0
1657       IWORK(LNCFN)=0
1658       IWORK(LNNI)=0
1659       IWORK(LNLI)=0
1660       IWORK(LNPS)=0
1661       IWORK(LNCFL)=0
1662       IWORK(LNRTE)=0
1663       IWORK(LKPRIN)=INFO(18)
1664       IDID=1
1665       GO TO 200
1666 C
1667 C-----------------------------------------------------------------------
1668 C     This block is for continuation calls only.
1669 C     Here we check INFO(1), and if the last step was interrupted,
1670 C     we check whether appropriate action was taken.
1671 C-----------------------------------------------------------------------
1672 C
1673 100   CONTINUE
1674       IF(INFO(1).EQ.1)GO TO 110
1675       ITEMP = 1
1676       IF(INFO(1).NE.-1)GO TO 701
1677 C
1678 C     If we are here, the last step was interrupted by an error
1679 C     condition from DDSTP, and appropriate action was not taken.
1680 C     This is a fatal error.
1681 C
1682       MSG = 'DASKR--  THE LAST STEP TERMINATED WITH A NEGATIVE'
1683       CALL XERRWD(MSG,49,201,0,0,0,0,0,0.0D0,0.0D0)
1684       MSG = 'DASKR--  VALUE (=I1) OF IDID AND NO APPROPRIATE'
1685       CALL XERRWD(MSG,47,202,0,1,IDID,0,0,0.0D0,0.0D0)
1686       MSG = 'DASKR--  ACTION WAS TAKEN. RUN TERMINATED'
1687       CALL XERRWD(MSG,41,203,1,0,0,0,0,0.0D0,0.0D0)
1688       RETURN
1689 110   CONTINUE
1690 C
1691 C-----------------------------------------------------------------------
1692 C     This block is executed on all calls.
1693 C
1694 C     Counters are saved for later checks of performance.
1695 C     Then the error tolerance parameters are checked, and the
1696 C     work array pointers are set.
1697 C-----------------------------------------------------------------------
1698 C
1699 200   CONTINUE
1700 C
1701 C     Save counters for use later.
1702 C
1703       IWORK(LNSTL)=IWORK(LNST)
1704       NLI0 = IWORK(LNLI)
1705       NNI0 = IWORK(LNNI)
1706       NCFN0 = IWORK(LNCFN)
1707       NCFL0 = IWORK(LNCFL)
1708       NWARN = 0
1709 C
1710 C     Check RTOL and ATOL.
1711 C
1712       NZFLG = 0
1713       RTOLI = RTOL(1)
1714       ATOLI = ATOL(1)
1715       DO 210 I=1,NEQ
1716          IF (INFO(2) .EQ. 1) RTOLI = RTOL(I)
1717          IF (INFO(2) .EQ. 1) ATOLI = ATOL(I)
1718          IF (RTOLI .GT. 0.0D0 .OR. ATOLI .GT. 0.0D0) NZFLG = 1
1719          IF (RTOLI .LT. 0.0D0) GO TO 706
1720          IF (ATOLI .LT. 0.0D0) GO TO 707
1721 210      CONTINUE
1722       IF (NZFLG .EQ. 0) GO TO 708
1723 C
1724 C     Set pointers to RWORK and IWORK segments.
1725 C     For direct methods, SAVR is not used.
1726 C
1727       IWORK(LLCIWP) = LID + LENID
1728       LSAVR = LDELTA
1729       IF (INFO(12) .NE. 0) LSAVR = LDELTA + NEQ
1730       LE = LSAVR + NEQ
1731       LWT = LE + NEQ
1732       LVT = LWT
1733       IF (INFO(16) .NE. 0) LVT = LWT + NEQ
1734       LPHI = LVT + NEQ
1735       LR0 = LPHI + NCPHI*NEQ
1736       LR1 = LR0 + NRT
1737       LRX = LR1 + NRT
1738       LWM = LRX + NRT
1739       IF (INFO(1) .EQ. 1) GO TO 400
1740 C
1741 C-----------------------------------------------------------------------
1742 C     This block is executed on the initial call only.
1743 C     Set the initial step size, the error weight vector, and PHI.
1744 C     Compute unknown initial components of Y and YPRIME, if requested.
1745 C-----------------------------------------------------------------------
1746 C
1747 300   CONTINUE
1748       TN=T
1749       IDID=1
1750 C
1751 C     Set error weight array WT and altered weight array VT.
1752 C
1753       CALL DDAWTS2(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR)
1754       CALL DINVWT(NEQ,RWORK(LWT),IER)
1755       IF (IER .NE. 0) GO TO 713
1756       IF (INFO(16) .NE. 0) THEN
1757         DO 305 I = 1, NEQ
1758  305      RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1)
1759         ENDIF
1760 C
1761 C     Compute unit roundoff and HMIN.
1762 C
1763       UROUND = D1MACH2(4)
1764       RWORK(LROUND) = UROUND
1765       HMIN = 4.0D0*UROUND*MAX(ABS(T),ABS(TOUT))
1766 C
1767 C     Set/check STPTOL control for initial condition calculation.
1768 C     
1769       IF (INFO(11) .NE. 0) THEN
1770         IF( INFO(17) .EQ. 0) THEN
1771           RWORK(LSTOL) = UROUND**.6667D0
1772         ELSE
1773           IF (RWORK(LSTOL) .LE. 0.0D0) GO TO 725
1774           ENDIF
1775         ENDIF
1776 C
1777 C     Compute EPCON and square root of NEQ and its reciprocal, used
1778 C     inside iterative solver.
1779 C
1780       RWORK(LEPCON) = 0.33D0
1781       FLOATN = NEQ
1782       RWORK(LSQRN) = SQRT(FLOATN)
1783       RWORK(LRSQRN) = 1.D0/RWORK(LSQRN)
1784 C
1785 C     Check initial interval to see that it is long enough.
1786 C
1787       TDIST = ABS(TOUT - T)
1788       IF(TDIST .LT. HMIN) GO TO 714
1789 C
1790 C     Check H0, if this was input.
1791 C
1792       IF (INFO(8) .EQ. 0) GO TO 310
1793          H0 = RWORK(LH)
1794          IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 711
1795          IF (H0 .EQ. 0.0D0) GO TO 712
1796          GO TO 320
1797 310    CONTINUE
1798 C
1799 C     Compute initial stepsize, to be used by either
1800 C     DDSTP or DDASIC, depending on INFO(11).
1801 C
1802       H0 = 0.001D0*TDIST
1803       YPNORM = DDWNRM(NEQ,YPRIME,RWORK(LVT),RPAR,IPAR)
1804       IF (YPNORM .GT. 0.5D0/H0) H0 = 0.5D0/YPNORM
1805       H0 = SIGN(H0,TOUT-T)
1806 C
1807 C     Adjust H0 if necessary to meet HMAX bound.
1808 C
1809 320   IF (INFO(7) .EQ. 0) GO TO 330
1810          RH = ABS(H0)/RWORK(LHMAX)
1811          IF (RH .GT. 1.0D0) H0 = H0/RH
1812 C
1813 C     Check against TSTOP, if applicable.
1814 C
1815 330   IF (INFO(4) .EQ. 0) GO TO 340
1816          TSTOP = RWORK(LTSTOP)
1817          IF ((TSTOP - T)*H0 .LT. 0.0D0) GO TO 715
1818          IF ((T + H0 - TSTOP)*H0 .GT. 0.0D0) H0 = TSTOP - T
1819          IF ((TSTOP - TOUT)*H0 .LT. 0.0D0) GO TO 709
1820 C
1821 340   IF (INFO(11) .EQ. 0) GO TO 370
1822 C
1823 C     Compute unknown components of initial Y and YPRIME, depending
1824 C     on INFO(11) and INFO(12).  INFO(12) represents the nonlinear
1825 C     solver type (direct/Krylov).  Pass the name of the specific 
1826 C     nonlinear solver, depending on INFO(12).  The location of the work
1827 C     arrays SAVR, YIC, YPIC, PWK also differ in the two cases.
1828 C     For use in stopping tests, pass TSCALE = TDIST if INDEX = 0.
1829 C
1830       NWT = 1
1831       EPCONI = RWORK(LEPIN)*RWORK(LEPCON)
1832       TSCALE = 0.0D0
1833       IF (INDEX .EQ. 0) TSCALE = TDIST
1834 350   IF (INFO(12) .EQ. 0) THEN
1835          LYIC = LPHI + 2*NEQ
1836          LYPIC = LYIC + NEQ
1837          LPWK = LYPIC
1838          CALL DDASIC(TN,Y,YPRIME,NEQ,INFO(11),IWORK(LID),
1839      *     RES,JAC,PSOL,H0,TSCALE,RWORK(LWT),NWT,IDID,RPAR,IPAR,
1840      *     RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE),
1841      *     RWORK(LYIC),RWORK(LYPIC),RWORK(LPWK),RWORK(LWM),IWORK(LIWM),
1842      *     RWORK(LROUND),RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN),
1843      *     EPCONI,RWORK(LSTOL),INFO(15),ICNFLG,IWORK(LICNS),DDASID)
1844       ELSE IF (INFO(12) .EQ. 1) THEN
1845          LYIC = LWM
1846          LYPIC = LYIC + NEQ
1847          LPWK = LYPIC + NEQ
1848          CALL DDASIC(TN,Y,YPRIME,NEQ,INFO(11),IWORK(LID),
1849      *     RES,JAC,PSOL,H0,TSCALE,RWORK(LWT),NWT,IDID,RPAR,IPAR,
1850      *     RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE),
1851      *     RWORK(LYIC),RWORK(LYPIC),RWORK(LPWK),RWORK(LWM),IWORK(LIWM),
1852      *     RWORK(LROUND),RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN),
1853      *     EPCONI,RWORK(LSTOL),INFO(15),ICNFLG,IWORK(LICNS),DDASIK)
1854       ENDIF
1855 C
1856       IF (IDID .LT. 0) GO TO 600
1857 C
1858 C     DDASIC was successful.  If this was the first call to DDASIC,
1859 C     update the WT array (with the current Y) and call it again.
1860 C
1861       IF (NWT .EQ. 2) GO TO 355
1862       NWT = 2
1863       CALL DDAWTS2(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR)
1864       CALL DINVWT(NEQ,RWORK(LWT),IER)
1865       IF (IER .NE. 0) GO TO 713
1866       GO TO 350
1867 C
1868 C     If INFO(14) = 1, return now with IDID = 4.
1869 C
1870 355   IF (INFO(14) .EQ. 1) THEN
1871         IDID = 4
1872         H = H0
1873         IF (INFO(11) .EQ. 1) RWORK(LHOLD) = H0
1874         GO TO 590
1875       ENDIF
1876 C
1877 C     Update the WT and VT arrays one more time, with the new Y.
1878 C
1879       CALL DDAWTS2(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR)
1880       CALL DINVWT(NEQ,RWORK(LWT),IER)
1881       IF (IER .NE. 0) GO TO 713
1882       IF (INFO(16) .NE. 0) THEN
1883         DO 357 I = 1, NEQ
1884  357      RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1)
1885         ENDIF
1886 C
1887 C     Reset the initial stepsize to be used by DDSTP.
1888 C     Use H0, if this was input.  Otherwise, recompute H0,
1889 C     and adjust it if necessary to meet HMAX bound.
1890 C
1891       IF (INFO(8) .NE. 0) THEN
1892          H0 = RWORK(LH)
1893          GO TO 360
1894          ENDIF
1895 C
1896       H0 = 0.001D0*TDIST
1897       YPNORM = DDWNRM(NEQ,YPRIME,RWORK(LVT),RPAR,IPAR)
1898       IF (YPNORM .GT. 0.5D0/H0) H0 = 0.5D0/YPNORM
1899       H0 = SIGN(H0,TOUT-T)
1900 C
1901 360   IF (INFO(7) .NE. 0) THEN
1902          RH = ABS(H0)/RWORK(LHMAX)
1903          IF (RH .GT. 1.0D0) H0 = H0/RH
1904          ENDIF
1905 C
1906 C     Check against TSTOP, if applicable.
1907 C
1908       IF (INFO(4) .NE. 0) THEN
1909          TSTOP = RWORK(LTSTOP)
1910          IF ((T + H0 - TSTOP)*H0 .GT. 0.0D0) H0 = TSTOP - T
1911          ENDIF
1912 C
1913 C     Load H and RWORK(LH) with H0.
1914 C
1915 370   H = H0
1916       RWORK(LH) = H
1917 C
1918 C     Load Y and H*YPRIME into PHI(*,1) and PHI(*,2).
1919 C
1920       ITEMP = LPHI + NEQ
1921       DO 380 I = 1,NEQ
1922          RWORK(LPHI + I - 1) = Y(I)
1923 380      RWORK(ITEMP + I - 1) = H*YPRIME(I)
1924 C
1925 C     Initialize T0 in RWORK; check for a zero of R near initial T.
1926 C
1927       RWORK(LT0) = T
1928       IWORK(LIRFND) = 0
1929       RWORK(LPSI)=H
1930       RWORK(LPSI+1)=2.0D0*H
1931       IWORK(LKOLD)=1
1932       IF (NRT .EQ. 0) GO TO 390
1933       CALL DRCHEK2(1,RT,NRT,NEQ,T,TOUT,Y,YPRIME,RWORK(LPHI),
1934      *   RWORK(LPSI),IWORK(LKOLD),RWORK(LR0),RWORK(LR1),
1935      *   RWORK(LRX),JROOT,IRT,RWORK(LROUND),INFO(3),
1936      *   RWORK,IWORK,RPAR,IPAR)
1937       IF (IRT .LT. 0) GO TO 731
1938 C
1939  390  GO TO 500
1940 C
1941 C-----------------------------------------------------------------------
1942 C     This block is for continuation calls only.
1943 C     Its purpose is to check stop conditions before taking a step.
1944 C     Adjust H if necessary to meet HMAX bound.
1945 C-----------------------------------------------------------------------
1946 C
1947 400   CONTINUE
1948       UROUND=RWORK(LROUND)
1949       DONE = .FALSE.
1950       TN=RWORK(LTN)
1951       H=RWORK(LH)
1952       IF(NRT .EQ. 0) GO TO 405
1953 C
1954 C     Check for a zero of R near TN.
1955 C
1956       CALL DRCHEK2(2,RT,NRT,NEQ,TN,TOUT,Y,YPRIME,RWORK(LPHI),
1957      *   RWORK(LPSI),IWORK(LKOLD),RWORK(LR0),RWORK(LR1),
1958      *   RWORK(LRX),JROOT,IRT,RWORK(LROUND),INFO(3),
1959      *   RWORK,IWORK,RPAR,IPAR)
1960       IF (IRT .LT. 0) GO TO 731
1961 c*****SCILAB ENTERPRISES INPUT
1962 c**** IRT = 2 corresponds to a ZERO_DETACH return.
1963       IF (IRT .NE. 1 .AND. IRT .NE. 2) GO TO 405
1964       IWORK(LIRFND) = 1
1965       IF (IRT .EQ. 1) IDID = 5
1966       IF (IRT .EQ. 2) IDID = 6
1967 c*****
1968       T = RWORK(LT0)
1969       DONE = .TRUE.
1970       GO TO 490
1971 405   CONTINUE
1972 C
1973       IF(INFO(7) .EQ. 0) GO TO 410
1974          RH = ABS(H)/RWORK(LHMAX)
1975          IF(RH .GT. 1.0D0) H = H/RH
1976 410   CONTINUE
1977       IF(T .EQ. TOUT) GO TO 719
1978       IF((T - TOUT)*H .GT. 0.0D0) GO TO 711
1979       IF(INFO(4) .EQ. 1) GO TO 430
1980       IF(INFO(3) .EQ. 1) GO TO 420
1981       IF((TN-TOUT)*H.LT.0.0D0)GO TO 490
1982       CALL DDATRP2(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
1983      *  RWORK(LPHI),RWORK(LPSI))
1984       T=TOUT
1985       IDID = 3
1986       DONE = .TRUE.
1987       GO TO 490
1988 420   IF((TN-T)*H .LE. 0.0D0) GO TO 490
1989       IF((TN - TOUT)*H .GE. 0.0D0) GO TO 425
1990       CALL DDATRP2(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD),
1991      *  RWORK(LPHI),RWORK(LPSI))
1992       T = TN
1993       IDID = 1
1994       DONE = .TRUE.
1995       GO TO 490
1996 425   CONTINUE
1997       CALL DDATRP2(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
1998      *  RWORK(LPHI),RWORK(LPSI))
1999       T = TOUT
2000       IDID = 3
2001       DONE = .TRUE.
2002       GO TO 490
2003 430   IF(INFO(3) .EQ. 1) GO TO 440
2004       TSTOP=RWORK(LTSTOP)
2005       IF((TN-TSTOP)*H.GT.0.0D0) GO TO 715
2006       IF((TSTOP-TOUT)*H.LT.0.0D0)GO TO 709
2007       IF((TN-TOUT)*H.LT.0.0D0)GO TO 450
2008       CALL DDATRP2(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
2009      *   RWORK(LPHI),RWORK(LPSI))
2010       T=TOUT
2011       IDID = 3
2012       DONE = .TRUE.
2013       GO TO 490
2014 440   TSTOP = RWORK(LTSTOP)
2015       IF((TN-TSTOP)*H .GT. 0.0D0) GO TO 715
2016       IF((TSTOP-TOUT)*H .LT. 0.0D0) GO TO 709
2017       IF((TN-T)*H .LE. 0.0D0) GO TO 450
2018       IF((TN - TOUT)*H .GE. 0.0D0) GO TO 445
2019       CALL DDATRP2(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD),
2020      *  RWORK(LPHI),RWORK(LPSI))
2021       T = TN
2022       IDID = 1
2023       DONE = .TRUE.
2024       GO TO 490
2025 445   CONTINUE
2026       CALL DDATRP2(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
2027      *  RWORK(LPHI),RWORK(LPSI))
2028       T = TOUT
2029       IDID = 3
2030       DONE = .TRUE.
2031       GO TO 490
2032 450   CONTINUE
2033 C
2034 C     Check whether we are within roundoff of TSTOP.
2035 C
2036       IF(ABS(TN-TSTOP).GT.100.0D0*UROUND*
2037      *   (ABS(TN)+ABS(H)))GO TO 460
2038       CALL DDATRP2(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD),
2039      *  RWORK(LPHI),RWORK(LPSI))
2040       IDID=2
2041       T=TSTOP
2042       DONE = .TRUE.
2043       GO TO 490
2044 460   TNEXT=TN+H
2045       IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 490
2046       H=TSTOP-TN
2047       RWORK(LH)=H
2048 C
2049 490   IF (DONE) GO TO 590
2050 C
2051 C-----------------------------------------------------------------------
2052 C     The next block contains the call to the one-step integrator DDSTP.
2053 C     This is a looping point for the integration steps.
2054 C     Check for too many steps.
2055 C     Check for poor Newton/Krylov performance.
2056 C     Update WT.  Check for too much accuracy requested.
2057 C     Compute minimum stepsize.
2058 C-----------------------------------------------------------------------
2059 C
2060 500   CONTINUE
2061 C
2062 C     Check for too many steps.
2063 C
2064       IF((IWORK(LNST)-IWORK(LNSTL)).LT.500) GO TO 505
2065            IDID=-1
2066            GO TO 527
2067 C
2068 C Check for poor Newton/Krylov performance.
2069 C
2070 505   IF (INFO(12) .EQ. 0) GO TO 510
2071       NSTD = IWORK(LNST) - IWORK(LNSTL)
2072       NNID = IWORK(LNNI) - NNI0
2073       IF (NSTD .LT. 10 .OR. NNID .EQ. 0) GO TO 510
2074       AVLIN = REAL(IWORK(LNLI) - NLI0)/REAL(NNID)
2075       RCFN = REAL(IWORK(LNCFN) - NCFN0)/REAL(NSTD)
2076       RCFL = REAL(IWORK(LNCFL) - NCFL0)/REAL(NNID)
2077       FMAXL = IWORK(LMAXL)
2078       LAVL = AVLIN .GT. FMAXL
2079       LCFN = RCFN .GT. 0.9D0
2080       LCFL = RCFL .GT. 0.9D0
2081       LWARN = LAVL .OR. LCFN .OR. LCFL
2082       IF (.NOT.LWARN) GO TO 510
2083       NWARN = NWARN + 1
2084       IF (NWARN .GT. 10) GO TO 510
2085       IF (LAVL) THEN
2086         MSG = 'DASKR-- Warning. Poor iterative algorithm performance   '
2087         CALL XERRWD (MSG, 56, 501, 0, 0, 0, 0, 0, 0.0D0, 0.0D0)
2088         MSG = '      at T = R1. Average no. of linear iterations = R2  '
2089         CALL XERRWD (MSG, 56, 501, 0, 0, 0, 0, 2, TN, AVLIN)
2090         ENDIF
2091       IF (LCFN) THEN
2092         MSG = 'DASKR-- Warning. Poor iterative algorithm performance   '
2093         CALL XERRWD (MSG, 56, 502, 0, 0, 0, 0, 0, 0.0D0, 0.0D0)
2094         MSG = '      at T = R1. Nonlinear convergence failure rate = R2'
2095         CALL XERRWD (MSG, 56, 502, 0, 0, 0, 0, 2, TN, RCFN)
2096         ENDIF
2097       IF (LCFL) THEN
2098         MSG = 'DASKR-- Warning. Poor iterative algorithm performance   '
2099         CALL XERRWD (MSG, 56, 503, 0, 0, 0, 0, 0, 0.0D0, 0.0D0)
2100         MSG = '      at T = R1. Linear convergence failure rate = R2   '
2101         CALL XERRWD (MSG, 56, 503, 0, 0, 0, 0, 2, TN, RCFL)
2102         ENDIF
2103 C
2104 C     Update WT and VT, if this is not the first call.
2105 C
2106 510   CALL DDAWTS2(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI),RWORK(LWT),
2107      *            RPAR,IPAR)
2108       CALL DINVWT(NEQ,RWORK(LWT),IER)
2109       IF (IER .NE. 0) THEN
2110         IDID = -3
2111         GO TO 527
2112         ENDIF
2113       IF (INFO(16) .NE. 0) THEN
2114         DO 515 I = 1, NEQ
2115  515      RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1)
2116         ENDIF
2117 C
2118 C     Test for too much accuracy requested.
2119 C
2120       R = DDWNRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)*100.0D0*UROUND
2121       IF (R .LE. 1.0D0) GO TO 525
2122 C
2123 C     Multiply RTOL and ATOL by R and return.
2124 C
2125       IF(INFO(2).EQ.1)GO TO 523
2126            RTOL(1)=R*RTOL(1)
2127            ATOL(1)=R*ATOL(1)
2128            IDID=-2
2129            GO TO 527
2130 523   DO 524 I=1,NEQ
2131            RTOL(I)=R*RTOL(I)
2132 524        ATOL(I)=R*ATOL(I)
2133       IDID=-2
2134       GO TO 527
2135 525   CONTINUE
2136 C
2137 C     Compute minimum stepsize.
2138 C
2139       HMIN=4.0D0*UROUND*MAX(ABS(TN),ABS(TOUT))
2140 C
2141 C     Test H vs. HMAX
2142       IF (INFO(7) .NE. 0) THEN
2143          RH = ABS(H)/RWORK(LHMAX)
2144          IF (RH .GT. 1.0D0) H = H/RH
2145          ENDIF
2146 C
2147 C     Call the one-step integrator.
2148 C     Note that INFO(12) represents the nonlinear solver type.
2149 C     Pass the required nonlinear solver, depending upon INFO(12).
2150 C
2151       IF (INFO(12) .EQ. 0) THEN
2152          CALL DDSTP(TN,Y,YPRIME,NEQ,
2153      *      RES,JAC,PSOL,H,RWORK(LWT),RWORK(LVT),INFO(1),IDID,RPAR,IPAR,
2154      *      RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE),
2155      *      RWORK(LWM),IWORK(LIWM),
2156      *      RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA),
2157      *      RWORK(LPSI),RWORK(LSIGMA),
2158      *      RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD),RWORK(LS),HMIN,
2159      *      RWORK(LROUND), RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN),
2160      *      RWORK(LEPCON), IWORK(LPHASE),IWORK(LJCALC),INFO(15),
2161      *      IWORK(LK), IWORK(LKOLD),IWORK(LNS),NONNEG,INFO(12),
2162      *      DNEDD)
2163       ELSE IF (INFO(12) .EQ. 1) THEN
2164          CALL DDSTP(TN,Y,YPRIME,NEQ,
2165      *      RES,JAC,PSOL,H,RWORK(LWT),RWORK(LVT),INFO(1),IDID,RPAR,IPAR,
2166      *      RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE),
2167      *      RWORK(LWM),IWORK(LIWM),
2168      *      RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA),
2169      *      RWORK(LPSI),RWORK(LSIGMA),
2170      *      RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD),RWORK(LS),HMIN,
2171      *      RWORK(LROUND), RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN),
2172      *      RWORK(LEPCON), IWORK(LPHASE),IWORK(LJCALC),INFO(15),
2173      *      IWORK(LK), IWORK(LKOLD),IWORK(LNS),NONNEG,INFO(12),
2174      *      DNEDK)
2175       ENDIF
2176 C
2177 527   IF(IDID.LT.0)GO TO 600
2178 C
2179 C-----------------------------------------------------------------------
2180 C     This block handles the case of a successful return from DDSTP
2181 C     (IDID=1).  Test for stop conditions.
2182 C-----------------------------------------------------------------------
2183 C
2184       IF(NRT .EQ. 0) GO TO 530
2185 C
2186 C     Check for a zero of R near TN.
2187 C
2188       CALL DRCHEK2(3,RT,NRT,NEQ,TN,TOUT,Y,YPRIME,RWORK(LPHI),
2189      *   RWORK(LPSI),IWORK(LKOLD),RWORK(LR0),RWORK(LR1),
2190      *   RWORK(LRX),JROOT,IRT,RWORK(LROUND),INFO(3),
2191      *   RWORK,IWORK,RPAR,IPAR)
2192       IF (IRT .NE. 1 .AND. IRT .NE. 2) GO TO 530
2193       IWORK(LIRFND) = 1
2194 c*****SCILAB ENTERPRISES INPUT
2195 c**** IRT = 2 corresponds to a ZERO_DETACH return.
2196       IF (IRT .EQ. 1) IDID = 5
2197       IF (IRT .EQ. 2) IDID = 6
2198 c*****
2199       T = RWORK(LT0)
2200       GO TO 580
2201 C
2202 530   IF (INFO(4) .EQ. 0) THEN
2203 C        Stopping tests for the case of no TSTOP. ----------------------
2204          IF ( (TN-TOUT)*H .GE. 0.0D0) THEN
2205             CALL DDATRP2(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
2206      *                  RWORK(LPHI),RWORK(LPSI))
2207             T = TOUT
2208             IDID = 3
2209             GO TO 580
2210             ENDIF
2211          IF (INFO(3) .EQ. 0) GO TO 500
2212          T = TN
2213          IDID = 1
2214          GO TO 580
2215          ENDIF
2216 C
2217 540   IF (INFO(3) .NE. 0) GO TO 550
2218 C     Stopping tests for the TSTOP case, interval-output mode. ---------
2219       IF (ABS(TN-TSTOP) .LE. 100.0D0*UROUND*(ABS(TN)+ABS(H))) THEN
2220          CALL DDATRP2(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD),
2221      *               RWORK(LPHI),RWORK(LPSI))
2222          T = TSTOP
2223          IDID = 2
2224          GO TO 580
2225          ENDIF
2226       IF ( (TN-TOUT)*H .GE. 0.0D0) THEN
2227          CALL DDATRP2(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
2228      *               RWORK(LPHI),RWORK(LPSI))
2229          T = TOUT
2230          IDID = 3
2231          GO TO 580
2232          ENDIF
2233       TNEXT = TN + H
2234       IF ((TNEXT-TSTOP)*H .LE. 0.0D0) GO TO 500
2235       H = TSTOP - TN
2236       GO TO 500
2237 C
2238 550   CONTINUE
2239 C     Stopping tests for the TSTOP case, intermediate-output mode. -----
2240       IF (ABS(TN-TSTOP) .LE. 100.0D0*UROUND*(ABS(TN)+ABS(H))) THEN
2241          CALL DDATRP2(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD),
2242      *               RWORK(LPHI),RWORK(LPSI))
2243          T = TSTOP
2244          IDID = 2
2245          GO TO 580
2246          ENDIF
2247       IF ( (TN-TOUT)*H .GE. 0.0D0) THEN
2248          CALL DDATRP2(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
2249      *               RWORK(LPHI),RWORK(LPSI))
2250          T = TOUT
2251          IDID = 3
2252          GO TO 580
2253          ENDIF
2254       T = TN
2255       IDID = 1
2256 C
2257 580   CONTINUE
2258 C
2259 C-----------------------------------------------------------------------
2260 C     All successful returns from DDASKR are made from this block.
2261 C-----------------------------------------------------------------------
2262 C
2263 590   CONTINUE
2264       RWORK(LTN)=TN
2265       RWORK(LTLAST)=T
2266       RWORK(LH)=H
2267       RETURN
2268 C
2269 C-----------------------------------------------------------------------
2270 C     This block handles all unsuccessful returns other than for
2271 C     illegal input.
2272 C-----------------------------------------------------------------------
2273 C
2274 600   CONTINUE
2275       ITEMP = -IDID
2276       GO TO (610,620,630,700,655,640,650,660,670,675,
2277      *  680,685,690,695), ITEMP
2278 C
2279 C     The maximum number of steps was taken before
2280 C     reaching tout.
2281 C
2282 610   MSG = 'DASKR--  AT CURRENT T (=R1)  500 STEPS'
2283       CALL XERRWD(MSG,38,610,0,0,0,0,1,TN,0.0D0)
2284       MSG = 'DASKR--  TAKEN ON THIS CALL BEFORE REACHING TOUT'
2285       CALL XERRWD(MSG,48,611,0,0,0,0,0,0.0D0,0.0D0)
2286       GO TO 700
2287 C
2288 C     Too much accuracy for machine precision.
2289 C
2290 620   MSG = 'DASKR--  AT T (=R1) TOO MUCH ACCURACY REQUESTED'
2291       CALL XERRWD(MSG,47,620,0,0,0,0,1,TN,0.0D0)
2292       MSG = 'DASKR--  FOR PRECISION OF MACHINE. RTOL AND ATOL'
2293       CALL XERRWD(MSG,48,621,0,0,0,0,0,0.0D0,0.0D0)
2294       MSG = 'DASKR--  WERE INCREASED BY A FACTOR R (=R1)'
2295       CALL XERRWD(MSG,43,622,0,0,0,0,1,R,0.0D0)
2296       GO TO 700
2297 C
2298 C     WT(I) .LE. 0.0D0 for some I (not at start of problem).
2299 C
2300 630   MSG = 'DASKR--  AT T (=R1) SOME ELEMENT OF WT'
2301       CALL XERRWD(MSG,38,630,0,0,0,0,1,TN,0.0D0)
2302       MSG = 'DASKR--  HAS BECOME .LE. 0.0'
2303       CALL XERRWD(MSG,28,631,0,0,0,0,0,0.0D0,0.0D0)
2304       GO TO 700
2305 C
2306 C     Error test failed repeatedly or with H=HMIN.
2307 C
2308 640   MSG = 'DASKR--  AT T (=R1) AND STEPSIZE H (=R2) THE'
2309       CALL XERRWD(MSG,44,640,0,0,0,0,2,TN,H)
2310       MSG='DASKR--  ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN'
2311       CALL XERRWD(MSG,57,641,0,0,0,0,0,0.0D0,0.0D0)
2312       GO TO 700
2313 C
2314 C     Nonlinear solver failed to converge repeatedly or with H=HMIN.
2315 C
2316 650   MSG = 'DASKR--  AT T (=R1) AND STEPSIZE H (=R2) THE'
2317       CALL XERRWD(MSG,44,650,0,0,0,0,2,TN,H)
2318       MSG = 'DASKR--  NONLINEAR SOLVER FAILED TO CONVERGE'
2319       CALL XERRWD(MSG,44,651,0,0,0,0,0,0.0D0,0.0D0)
2320       MSG = 'DASKR--  REPEATEDLY OR WITH ABS(H)=HMIN'
2321       CALL XERRWD(MSG,40,652,0,0,0,0,0,0.0D0,0.0D0)
2322       GO TO 700
2323 C
2324 C     The preconditioner had repeated failures.
2325 C
2326 655   MSG = 'DASKR--  AT T (=R1) AND STEPSIZE H (=R2) THE'
2327       CALL XERRWD(MSG,44,655,0,0,0,0,2,TN,H)
2328       MSG = 'DASKR--  PRECONDITIONER HAD REPEATED FAILURES.'
2329       CALL XERRWD(MSG,46,656,0,0,0,0,0,0.0D0,0.0D0)
2330       GO TO 700
2331 C
2332 C     The iteration matrix is singular.
2333 C
2334 660   MSG = 'DASKR--  AT T (=R1) AND STEPSIZE H (=R2) THE'
2335       CALL XERRWD(MSG,44,660,0,0,0,0,2,TN,H)
2336       MSG = 'DASKR--  ITERATION MATRIX IS SINGULAR.'
2337       CALL XERRWD(MSG,38,661,0,0,0,0,0,0.0D0,0.0D0)
2338       GO TO 700
2339 C
2340 C     Nonlinear system failure preceded by error test failures.
2341 C
2342 670   MSG = 'DASKR--  AT T (=R1) AND STEPSIZE H (=R2) THE'
2343       CALL XERRWD(MSG,44,670,0,0,0,0,2,TN,H)
2344       MSG = 'DASKR--  NONLINEAR SOLVER COULD NOT CONVERGE.'
2345       CALL XERRWD(MSG,45,671,0,0,0,0,0,0.0D0,0.0D0)
2346       MSG = 'DASKR--  ALSO, THE ERROR TEST FAILED REPEATEDLY.'
2347       CALL XERRWD(MSG,49,672,0,0,0,0,0,0.0D0,0.0D0)
2348       GO TO 700
2349 C
2350 C     Nonlinear system failure because IRES = -1.
2351 C
2352 675   MSG = 'DASKR--  AT T (=R1) AND STEPSIZE H (=R2) THE'
2353       CALL XERRWD(MSG,44,675,0,0,0,0,2,TN,H)
2354       MSG = 'DASKR--  NONLINEAR SYSTEM SOLVER COULD NOT CONVERGE'
2355       CALL XERRWD(MSG,51,676,0,0,0,0,0,0.0D0,0.0D0)
2356       MSG = 'DASKR--  BECAUSE IRES WAS EQUAL TO MINUS ONE'
2357       CALL XERRWD(MSG,44,677,0,0,0,0,0,0.0D0,0.0D0)
2358       GO TO 700
2359 C
2360 C     Failure because IRES = -2.
2361 C
2362 680   MSG = 'DASKR--  AT T (=R1) AND STEPSIZE H (=R2)'
2363       CALL XERRWD(MSG,40,680,0,0,0,0,2,TN,H)
2364       MSG = 'DASKR--  IRES WAS EQUAL TO MINUS TWO'
2365       CALL XERRWD(MSG,36,681,0,0,0,0,0,0.0D0,0.0D0)
2366       GO TO 700
2367 C
2368 C     Failed to compute initial YPRIME.
2369 C
2370 685   MSG = 'DASKR--  AT T (=R1) AND STEPSIZE H (=R2) THE'
2371       CALL XERRWD(MSG,44,685,0,0,0,0,0,0.0D0,0.0D0)
2372       MSG = 'DASKR--  INITIAL (Y,YPRIME) COULD NOT BE COMPUTED'
2373       CALL XERRWD(MSG,49,686,0,0,0,0,2,TN,H0)
2374       GO TO 700
2375 C
2376 C     Failure because IER was negative from PSOL.
2377 C
2378 690   MSG = 'DASKR--  AT T (=R1) AND STEPSIZE H (=R2)'
2379       CALL XERRWD(MSG,40,690,0,0,0,0,2,TN,H)
2380       MSG = 'DASKR--  IER WAS NEGATIVE FROM PSOL'
2381       CALL XERRWD(MSG,35,691,0,0,0,0,0,0.0D0,0.0D0)
2382       GO TO 700
2383 C
2384 C     Failure because the linear system solver could not converge.
2385 C
2386 695   MSG = 'DASKR--  AT T (=R1) AND STEPSIZE H (=R2) THE'
2387       CALL XERRWD(MSG,44,695,0,0,0,0,2,TN,H)
2388       MSG = 'DASKR--  LINEAR SYSTEM SOLVER COULD NOT CONVERGE.'
2389       CALL XERRWD(MSG,50,696,0,0,0,0,0,0.0D0,0.0D0)
2390       GO TO 700
2391 C
2392 C
2393 700   CONTINUE
2394       INFO(1)=-1
2395       T=TN
2396       RWORK(LTN)=TN
2397       RWORK(LH)=H
2398       RETURN
2399 C
2400 C-----------------------------------------------------------------------
2401 C     This block handles all error returns due to illegal input,
2402 C     as detected before calling DDSTP.
2403 C     First the error message routine is called.  If this happens
2404 C     twice in succession, execution is terminated.
2405 C-----------------------------------------------------------------------
2406 C
2407 701   MSG = 'DASKR--  ELEMENT (=I1) OF INFO VECTOR IS NOT VALID'
2408       CALL XERRWD(MSG,50,1,0,1,ITEMP,0,0,0.0D0,0.0D0)
2409       GO TO 750
2410 702   MSG = 'DASKR--  NEQ (=I1) .LE. 0'
2411       CALL XERRWD(MSG,25,2,0,1,NEQ,0,0,0.0D0,0.0D0)
2412       GO TO 750
2413 703   MSG = 'DASKR--  MAXORD (=I1) NOT IN RANGE'
2414       CALL XERRWD(MSG,34,3,0,1,MXORD,0,0,0.0D0,0.0D0)
2415       GO TO 750
2416 704   MSG='DASKR--  RWORK LENGTH NEEDED, LENRW (=I1), EXCEEDS LRW (=I2)'
2417       CALL XERRWD(MSG,60,4,0,2,LENRW,LRW,0,0.0D0,0.0D0)
2418       GO TO 750
2419 705   MSG='DASKR--  IWORK LENGTH NEEDED, LENIW (=I1), EXCEEDS LIW (=I2)'
2420       CALL XERRWD(MSG,60,5,0,2,LENIW,LIW,0,0.0D0,0.0D0)
2421       GO TO 750
2422 706   MSG = 'DASKR--  SOME ELEMENT OF RTOL IS .LT. 0'
2423       CALL XERRWD(MSG,39,6,0,0,0,0,0,0.0D0,0.0D0)
2424       GO TO 750
2425 707   MSG = 'DASKR--  SOME ELEMENT OF ATOL IS .LT. 0'
2426       CALL XERRWD(MSG,39,7,0,0,0,0,0,0.0D0,0.0D0)
2427       GO TO 750
2428 708   MSG = 'DASKR--  ALL ELEMENTS OF RTOL AND ATOL ARE ZERO'
2429       CALL XERRWD(MSG,47,8,0,0,0,0,0,0.0D0,0.0D0)
2430       GO TO 750
2431 709   MSG='DASKR--  INFO(4) = 1 AND TSTOP (=R1) BEHIND TOUT (=R2)'
2432       CALL XERRWD(MSG,54,9,0,0,0,0,2,TSTOP,TOUT)
2433       GO TO 750
2434 710   MSG = 'DASKR--  HMAX (=R1) .LT. 0.0'
2435       CALL XERRWD(MSG,28,10,0,0,0,0,1,HMAX,0.0D0)
2436       GO TO 750
2437 711   MSG = 'DASKR--  TOUT (=R1) BEHIND T (=R2)'
2438       CALL XERRWD(MSG,34,11,0,0,0,0,2,TOUT,T)
2439       GO TO 750
2440 712   MSG = 'DASKR--  INFO(8)=1 AND H0=0.0'
2441       CALL XERRWD(MSG,29,12,0,0,0,0,0,0.0D0,0.0D0)
2442       GO TO 750
2443 713   MSG = 'DASKR--  SOME ELEMENT OF WT IS .LE. 0.0'
2444       CALL XERRWD(MSG,39,13,0,0,0,0,0,0.0D0,0.0D0)
2445       GO TO 750
2446 714   MSG='DASKR-- TOUT (=R1) TOO CLOSE TO T (=R2) TO START INTEGRATION'
2447       CALL XERRWD(MSG,60,14,0,0,0,0,2,TOUT,T)
2448       GO TO 750
2449 715   MSG = 'DASKR--  INFO(4)=1 AND TSTOP (=R1) BEHIND T (=R2)'
2450       CALL XERRWD(MSG,49,15,0,0,0,0,2,TSTOP,T)
2451       GO TO 750
2452 717   MSG = 'DASKR--  ML (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ'
2453       CALL XERRWD(MSG,52,17,0,1,IWORK(LML),0,0,0.0D0,0.0D0)
2454       GO TO 750
2455 718   MSG = 'DASKR--  MU (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ'
2456       CALL XERRWD(MSG,52,18,0,1,IWORK(LMU),0,0,0.0D0,0.0D0)
2457       GO TO 750
2458 719   MSG = 'DASKR--  TOUT (=R1) IS EQUAL TO T (=R2)'
2459       CALL XERRWD(MSG,39,19,0,0,0,0,2,TOUT,T)
2460       GO TO 750
2461 720   MSG = 'DASKR--  MAXL (=I1) ILLEGAL. EITHER .LT. 1 OR .GT. NEQ'
2462       CALL XERRWD(MSG,54,20,0,1,IWORK(LMAXL),0,0,0.0D0,0.0D0)
2463       GO TO 750
2464 721   MSG = 'DASKR--  KMP (=I1) ILLEGAL. EITHER .LT. 1 OR .GT. MAXL'
2465       CALL XERRWD(MSG,54,21,0,1,IWORK(LKMP),0,0,0.0D0,0.0D0)
2466       GO TO 750
2467 722   MSG = 'DASKR--  NRMAX (=I1) ILLEGAL. .LT. 0'
2468       CALL XERRWD(MSG,36,22,0,1,IWORK(LNRMAX),0,0,0.0D0,0.0D0)
2469       GO TO 750
2470 723   MSG = 'DASKR--  EPLI (=R1) ILLEGAL. EITHER .LE. 0.D0 OR .GE. 1.D0'
2471       CALL XERRWD(MSG,58,23,0,0,0,0,1,RWORK(LEPLI),0.0D0)
2472       GO TO 750
2473 724   MSG = 'DASKR--  ILLEGAL IWORK VALUE FOR INFO(11) .NE. 0'
2474       CALL XERRWD(MSG,48,24,0,0,0,0,0,0.0D0,0.0D0)
2475       GO TO 750
2476 725   MSG = 'DASKR--  ONE OF THE INPUTS FOR INFO(17) = 1 IS ILLEGAL'
2477       CALL XERRWD(MSG,54,25,0,0,0,0,0,0.0D0,0.0D0)
2478       GO TO 750
2479 726   MSG = 'DASKR--  ILLEGAL IWORK VALUE FOR INFO(10) .NE. 0'
2480       CALL XERRWD(MSG,48,26,0,0,0,0,0,0.0D0,0.0D0)
2481       GO TO 750
2482 727   MSG = 'DASKR--  Y(I) AND IWORK(40+I) (I=I1) INCONSISTENT'
2483       CALL XERRWD(MSG,49,27,0,1,IRET,0,0,0.0D0,0.0D0)
2484       GO TO 750
2485 730   MSG = 'DASKR--  NRT (=I1) .LT. 0'
2486       CALL XERRWD(MSG,25,30,1,1,NRT,0,0,0.0D0,0.0D0)
2487       GO TO 750
2488 731   MSG = 'DASKR--  R IS ILL-DEFINED.  ZERO VALUES WERE FOUND AT TWO'
2489       CALL XERRWD(MSG,57,31,1,0,0,0,0,0.0D0,0.0D0)
2490       MSG = '         VERY CLOSE T VALUES, AT T = R1'
2491       CALL XERRWD(MSG,39,31,1,0,0,0,1,RWORK(LT0),0.0D0)
2492 C
2493 750   IF(INFO(1).EQ.-1) GO TO 760
2494       INFO(1)=-1
2495       IDID=-33
2496       RETURN
2497 760   MSG = 'DASKR--  REPEATED OCCURRENCES OF ILLEGAL INPUT'
2498       CALL XERRWD(MSG,46,701,0,0,0,0,0,0.0D0,0.0D0)
2499 770   MSG = 'DASKR--  RUN TERMINATED. APPARENT INFINITE LOOP'
2500       CALL XERRWD(MSG,47,702,1,0,0,0,0,0.0D0,0.0D0)
2501       RETURN
2502 C
2503 C------END OF SUBROUTINE DDASKR-----------------------------------------
2504       END
2505       SUBROUTINE DRCHEK2 (JOB, RT, NRT, NEQ, TN, TOUT, Y, YP, PHI, PSI,
2506      *   KOLD, R0, R1, RX, JROOT, IRT, UROUND, INFO3, RWORK, IWORK,
2507      *   RPAR, IPAR)
2508 C
2509 C***BEGIN PROLOGUE  DRCHEK2
2510 C***REFER TO DDASKR
2511 C***ROUTINES CALLED  DDATRP2, DROOTS2, DCOPY, RT
2512 C***REVISION HISTORY  (YYMMDD)
2513 C   020815  DATE WRITTEN   
2514 C   021217  Added test for roots close when JOB = 2.
2515 C   050510  Changed T increment after 110 so that TEMP1/H .ge. 0.1.
2516 C   071003  Fixed bug in TEMP2 (HMINR) below 110.
2517 C   110608  Fixed bug in setting of T1 at 300.
2518 C***END PROLOGUE  DRCHEK2
2519 C
2520       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
2521 C Pointers into IWORK:
2522       PARAMETER (LNRTE=36, LIRFND=37)
2523 C Pointers into RWORK:
2524       PARAMETER (LT0=51, LTLAST=52)
2525       EXTERNAL RT
2526       INTEGER JOB, NRT, NEQ, KOLD, JROOT, IRT, INFO3, IWORK, IPAR
2527       DOUBLE PRECISION TN, TOUT, Y, YP, PHI, PSI, R0, R1, RX, UROUND,
2528      *  RWORK, RPAR
2529       DIMENSION Y(*), YP(*), PHI(NEQ,*), PSI(*),
2530      *          R0(*), R1(*), RX(*), JROOT(*), RWORK(*), IWORK(*)
2531       INTEGER I, JFLAG
2532       DOUBLE PRECISION H
2533       DOUBLE PRECISION HMINR, T1, TEMP1, TEMP2, X, ZERO
2534       LOGICAL ZROOT
2535       DATA ZERO/0.0D0/
2536 C-----------------------------------------------------------------------
2537 C This routine checks for the presence of a root of R(T,Y,Y') in the
2538 C vicinity of the current T, in a manner depending on the
2539 C input flag JOB.  It calls subroutine DROOTS2 to locate the root
2540 C as precisely as possible.
2541 C
2542 C In addition to variables described previously, DRCHEK2
2543 C uses the following for communication..
2544 C JOB    = integer flag indicating type of call..
2545 C          JOB = 1 means the problem is being initialized, and DRCHEK2
2546 C                  is to look for a root at or very near the initial T.
2547 C          JOB = 2 means a continuation call to the solver was just
2548 C                  made, and DRCHEK2 is to check for a root in the
2549 C                  relevant part of the step last taken.
2550 C          JOB = 3 means a successful step was just taken, and DRCHEK2
2551 C                  is to look for a root in the interval of the step.
2552 C R0     = array of length NRT, containing the value of R at T = T0.
2553 C          R0 is input for JOB .ge. 2 and on output in all cases.
2554 C R1,RX  = arrays of length NRT for work space.
2555 C IRT    = completion flag..
2556 C          IRT = 0  means no root was found.
2557 C          IRT = -1 means JOB = 1 and a zero was found both at T0 and
2558 C                   and very close to T0.
2559 C          IRT = -2 means JOB = 2 and some Ri was found to have a zero
2560 C                   both at T0 and very close to T0.
2561 C          IRT = 1  means a legitimate root was found (JOB = 2 or 3).
2562 C                   On return, T0 is the root location, and Y is the
2563 C                   corresponding solution vector.
2564 C T0     = value of T at one endpoint of interval of interest.  Only
2565 C          roots beyond T0 in the direction of integration are sought.
2566 C          T0 is input if JOB .ge. 2, and output in all cases.
2567 C          T0 is updated by DRCHEK2, whether a root is found or not.
2568 C          Stored in the global array RWORK.
2569 C TLAST  = last value of T returned by the solver (input only).
2570 C          Stored in the global array RWORK.
2571 C TOUT   = final output time for the solver.
2572 C IRFND  = input flag showing whether the last step taken had a root.
2573 C          IRFND = 1 if it did, = 0 if not.
2574 C          Stored in the global array IWORK.
2575 C INFO3  = copy of INFO(3) (input only).
2576 C-----------------------------------------------------------------------
2577 C     
2578       H = PSI(1)
2579       IRT = 0
2580 c*****SCILAB ENTERPRISES INPUT
2581 c**** Do not reset JROOT with every call of DRCHEK2,
2582 c**** because we want to keep the MASKED roots
2583 c      DO 10 I = 1,NRT
2584 c 10     JROOT(I) = 0
2585       MASKED = 55
2586 c*****
2587       HMINR = (ABS(TN) + ABS(H))*UROUND*100.0D0
2588 C
2589       GO TO (100, 200, 300), JOB
2590 C
2591 C Evaluate R at initial T (= RWORK(LT0)); check for zero values.--------
2592  100  CONTINUE
2593 c*****SCILAB ENTERPRISES INPUT
2594 c**** Initialize JROOT just one time,
2595 c**** at the first call of DRCHEK2() (JOB = 1)
2596       DO 101 I = 1,NRT
2597  101     JROOT(I) = 0
2598       RWORK(LT0) = TN
2599 c*****
2600       CALL DDATRP2(TN,RWORK(LT0),Y,YP,NEQ,KOLD,PHI,PSI)
2601       CALL RT (NEQ, RWORK(LT0), Y, NRT, R0, RPAR, IPAR)
2602       IWORK(LNRTE) = 1
2603       ZROOT = .FALSE.
2604       DO 110 I = 1,NRT
2605 c*******SCILAB ENTERPRISES INPUT
2606 c****** On the first call of DRCHEK2(),
2607 c****** just list the zeros and tag them as MASKED
2608         IF (ABS(R0(I)) .EQ. ZERO) THEN
2609 c           ZROOT = .TRUE.
2610            JROOT(I) = MASKED
2611         ENDIF
2612  110  CONTINUE
2613 c      IF (.NOT. ZROOT) GO TO 190
2614 C R has a zero at T.  Look at R at T + (small increment). --------------
2615 c      TEMP2 = MAX(HMINR/ABS(H), 0.1D0)
2616 c      TEMP1 = TEMP2*H
2617 c      RWORK(LT0) = RWORK(LT0) + TEMP1
2618 c      DO 120 I = 1,NEQ
2619 c 120    Y(I) = Y(I) + TEMP2*PHI(I,2)
2620 c      CALL RT (NEQ, RWORK(LT0), Y, NRT, R0, RPAR, IPAR)
2621 c      IWORK(LNRTE) = IWORK(LNRTE) + 1
2622 c      ZROOT = .FALSE.
2623 c      DO 130 I = 1,NRT
2624 c 130    IF (ABS(R0(I)) .EQ. ZERO) ZROOT = .TRUE.
2625 c      IF (.NOT. ZROOT) GO TO 190
2626 C R has a zero at T and also close to T.  Take error return. -----------
2627 c      IRT = -1
2628 c      RETURN
2629 c******
2630 C
2631  190  CONTINUE
2632       RETURN
2633 C
2634  200  CONTINUE
2635       IF (IWORK(LIRFND) .EQ. 0) GO TO 260
2636 C If a root was found on the previous step, evaluate R0 = R(T0). -------
2637       CALL DDATRP2 (TN, RWORK(LT0), Y, YP, NEQ, KOLD, PHI, PSI)
2638       CALL RT (NEQ, RWORK(LT0), Y, NRT, R0, RPAR, IPAR)
2639       IWORK(LNRTE) = IWORK(LNRTE) + 1
2640       ZROOT = .FALSE.
2641       DO 210 I = 1,NRT
2642         IF (ABS(R0(I)) .EQ. ZERO) THEN
2643 c*********SCILAB ENTERPRISES INPUT
2644 c******** Like with JOB = 1, simply initialize JROOT to 0,
2645 c******** mask the ones that are null at the left endpoint
2646 c          ZROOT = .TRUE.
2647           JROOT(I) = MASKED
2648         ELSE
2649           JROOT(I) = 0
2650 c*********
2651         ENDIF
2652  210    CONTINUE
2653 c      IF (.NOT. ZROOT) GO TO 260
2654 C R has a zero at T0.  Look at R at T0+ = T0 + (small increment). ------
2655 c      TEMP1 = SIGN(HMINR,H)
2656 c      RWORK(LT0) = RWORK(LT0) + TEMP1
2657 c      IF ((RWORK(LT0) - TN)*H .LT. ZERO) GO TO 230
2658 c      TEMP2 = TEMP1/H
2659 c      DO 220 I = 1,NEQ
2660 c 220    Y(I) = Y(I) + TEMP2*PHI(I,2)
2661 c      GO TO 240
2662 c 230  CALL DDATRP2 (TN, RWORK(LT0), Y, YP, NEQ, KOLD, PHI, PSI)
2663 c 240  CALL RT (NEQ, RWORK(LT0), Y, NRT, R0, RPAR, IPAR)
2664 c      IWORK(LNRTE) = IWORK(LNRTE) + 1
2665 c      DO 250 I = 1,NRT
2666 c        IF (ABS(R0(I)) .GT. ZERO) GO TO 250
2667 C If Ri has a zero at both T0+ and T0, return an error flag. -----------
2668 c        IF (JROOT(I) .EQ. 1) THEN
2669 c          IRT = -2
2670 c          RETURN
2671 c        ELSE
2672 C If Ri has a zero at T0+, but not at T0, return valid root. -----------
2673 c          JROOT(I) = -SIGN(1.0D0,R0(I))
2674 c          IRT = 1
2675 c        ENDIF
2676 c 250    CONTINUE
2677 c      IF (IRT .EQ. 1) RETURN
2678 C R0 has no zero components.  Proceed to check relevant interval. ------
2679 c 260  IF (TN .EQ. RWORK(LTLAST)) RETURN
2680  260  RETURN
2681 C
2682  300  CONTINUE
2683 C Set T1 to TN or TOUT, whichever comes first, and get R at T1. --------
2684 c*****SCILAB ENTERPRISES INPUT
2685 c**** Here, the calculaltion mode can save some computations
2686       IF (INFO3 .EQ. 0) THEN
2687       IF ((TOUT - TN)*H .GE. ZERO) THEN
2688          T1 = TN
2689          GO TO 330
2690       ENDIF
2691       T1 = TOUT
2692       ELSE
2693       T1 = TN
2694       ENDIF
2695 c*****
2696       IF ((T1 - RWORK(LT0))*H .LE. ZERO) GO TO 390
2697  330  CALL DDATRP2 (TN, T1, Y, YP, NEQ, KOLD, PHI, PSI)
2698       CALL RT (NEQ, T1, Y, NRT, R1, RPAR, IPAR)
2699       IWORK(LNRTE) = IWORK(LNRTE) + 1
2700 C Call DROOTS2 to search for root in interval from T0 to T1. -----------
2701       JFLAG = 0
2702  350  CONTINUE
2703       CALL DROOTS2(NRT, HMINR, JFLAG, RWORK(LT0),T1, R0,R1,RX, X, JROOT)
2704       IF (JFLAG .GT. 1) GO TO 360
2705       CALL DDATRP2 (TN, X, Y, YP, NEQ, KOLD, PHI, PSI)
2706       CALL RT (NEQ, X, Y, NRT, RX, RPAR, IPAR)
2707       IWORK(LNRTE) = IWORK(LNRTE) + 1
2708       GO TO 350
2709  360  RWORK(LT0) = X
2710       CALL DCOPY (NRT, RX, 1, R0, 1)
2711       IF (JFLAG .EQ. 4) GO TO 390
2712 C Found a root.  Interpolate to X and return. --------------------------
2713       CALL DDATRP2 (TN, X, Y, YP, NEQ, KOLD, PHI, PSI)
2714 c*****SCILAB ENTERPRISES INPUT
2715 c**** If DROOTS2 returned JFLAG = 5,
2716 c**** then IRT = 2 will throw the ZERO_DETACH warning
2717       IF (JFLAG .EQ. 5) THEN
2718         IRT = 2
2719         RETURN
2720 c*****
2721       ENDIF
2722       IRT = 1
2723       RETURN
2724 C
2725  390  CONTINUE
2726       RETURN
2727 C---------------------- END OF SUBROUTINE DRCHEK2 -----------------
2728       END
2729       SUBROUTINE DROOTS2(NRT, HMIN, JFLAG, X0, X1, R0, R1, RX, X, JROOT)
2730 C
2731 C***BEGIN PROLOGUE  DROOTS2
2732 C***REFER TO DRCHEK2
2733 C***ROUTINES CALLED DCOPY
2734 C***REVISION HISTORY  (YYMMDD)
2735 C   020815  DATE WRITTEN   
2736 C   021217  Added root direction information in JROOT.
2737 C   040518  Changed adjustment to X2 at 180 to avoid infinite loop.
2738 C***END PROLOGUE  DROOTS2
2739 C
2740       INTEGER NRT, JFLAG, JROOT
2741       DOUBLE PRECISION HMIN, X0, X1, R0, R1, RX, X
2742       DIMENSION R0(NRT), R1(NRT), RX(NRT), JROOT(NRT)
2743 C-----------------------------------------------------------------------
2744 C This subroutine finds the leftmost root of a set of arbitrary
2745 C functions Ri(x) (i = 1,...,NRT) in an interval (X0,X1).  Only roots
2746 C of odd multiplicity (i.e. changes of sign of the Ri) are found.
2747 C Here the sign of X1 - X0 is arbitrary, but is constant for a given
2748 C problem, and -leftmost- means nearest to X0.
2749 C The values of the vector-valued function R(x) = (Ri, i=1...NRT)
2750 C are communicated through the call sequence of DROOTS2.
2751 C The method used is the Illinois algorithm.
2752 C
2753 C Reference:
2754 C Kathie L. Hiebert and Lawrence F. Shampine, Implicitly Defined
2755 C Output Points for Solutions of ODEs, Sandia Report SAND80-0180,
2756 C February 1980.
2757 C
2758 C Description of parameters.
2759 C
2760 C NRT    = number of functions Ri, or the number of components of
2761 C          the vector valued function R(x).  Input only.
2762 C
2763 C HMIN   = resolution parameter in X.  Input only.  When a root is
2764 C          found, it is located only to within an error of HMIN in X.
2765 C          Typically, HMIN should be set to something on the order of
2766 C               100 * UROUND * MAX(ABS(X0),ABS(X1)),
2767 C          where UROUND is the unit roundoff of the machine.
2768 C
2769 C JFLAG  = integer flag for input and output communication.
2770 C
2771 C          On input, set JFLAG = 0 on the first call for the problem,
2772 C          and leave it unchanged until the problem is completed.
2773 C          (The problem is completed when JFLAG .ge. 2 on return.)
2774 C
2775 C          On output, JFLAG has the following values and meanings:
2776 C          JFLAG = 1 means DROOTS2 needs a value of R(x).  Set RX = R(X)
2777 C                    and call DROOTS2 again.
2778 C          JFLAG = 2 means a root has been found.  The root is
2779 C                    at X, and RX contains R(X).  (Actually, X is the
2780 C                    rightmost approximation to the root on an interval
2781 C                    (X0,X1) of size HMIN or less.)
2782 C          JFLAG = 3 means X = X1 is a root, with one or more of the Ri
2783 C                    being zero at X1 and no sign changes in (X0,X1).
2784 C                    RX contains R(X) on output.
2785 C          JFLAG = 4 means no roots (of odd multiplicity) were
2786 C                    found in (X0,X1) (no sign changes).
2787 C
2788 C X0,X1  = endpoints of the interval where roots are sought.
2789 C          X1 and X0 are input when JFLAG = 0 (first call), and
2790 C          must be left unchanged between calls until the problem is
2791 C          completed.  X0 and X1 must be distinct, but X1 - X0 may be
2792 C          of either sign.  However, the notion of -left- and -right-
2793 C          will be used to mean nearer to X0 or X1, respectively.
2794 C          When JFLAG .ge. 2 on return, X0 and X1 are output, and
2795 C          are the endpoints of the relevant interval.
2796 C
2797 C R0,R1  = arrays of length NRT containing the vectors R(X0) and R(X1),
2798 C          respectively.  When JFLAG = 0, R0 and R1 are input and
2799 C          none of the R0(i) should be zero.
2800 C          When JFLAG .ge. 2 on return, R0 and R1 are output.
2801 C
2802 C RX     = array of length NRT containing R(X).  RX is input
2803 C          when JFLAG = 1, and output when JFLAG .ge. 2.
2804 C
2805 C X      = independent variable value.  Output only.
2806 C          When JFLAG = 1 on output, X is the point at which R(x)
2807 C          is to be evaluated and loaded into RX.
2808 C          When JFLAG = 2 or 3, X is the root.
2809 C          When JFLAG = 4, X is the right endpoint of the interval, X1.
2810 C
2811 C JROOT  = integer array of length NRT.  Output only.
2812 C          When JFLAG = 2 or 3, JROOT indicates which components
2813 C          of R(x) have a root at X, and the direction of the sign
2814 C          change across the root in the direction of integration.
2815 C          JROOT(i) =  1 if Ri has a root and changes from - to +.
2816 C          JROOT(i) = -1 if Ri has a root and changes from + to -.
2817 C          Otherwise JROOT(i) = 0.
2818 C-----------------------------------------------------------------------
2819       INTEGER I, IMAX, IMXOLD, LAST, NXLAST
2820       DOUBLE PRECISION ALPHA, T2, TMAX, X2, FRACINT, FRACSUB,
2821      1                 ZERO, TENTH, HALF, FIVE
2822 c*****SCILAB ENTERPRISES INPUT
2823 c**** UMROOT is a boolean to flag a root which gets unmasked.
2824       LOGICAL ZROOT, SGNCHG, XROOT, UMROOT
2825 c*****
2826       SAVE ALPHA, X2, IMAX, LAST
2827       DATA ZERO/0.0D0/, TENTH/0.1D0/, HALF/0.5D0/, FIVE/5.0D0/
2828 C
2829       MASKED = 55
2830       IF (JFLAG .EQ. 1) GO TO 200
2831 C JFLAG .ne. 1.  Check for change in sign of R or zero at X1. ----------
2832 c*****SCILAB ENTERPRISES INPUT
2833 c**** ISTUCK and IUNSTUCK help finding masked / unmasked roots.
2834       ISTUCK = 0
2835       IUNSTUCK = 0
2836       IMAX = 0
2837       TMAX = ZERO
2838       ZROOT = .FALSE.
2839       DO 120 I = 1,NRT
2840         IF (ABS(R1(I)) .GT. ZERO) GO TO 110
2841 c****** If a root function is null at both endpoints, flag it as STUCK.
2842         IF (ABS(R1(I)) .EQ. ZERO .AND. JROOT(I) .NE. MASKED) ISTUCK = I
2843 c        ZROOT = .TRUE.
2844         GO TO 120
2845 C At this point, R0(i) has been checked and cannot be zero. ------------
2846 c******** Here, test if some roots get UNSTUCK.
2847  110    IF (JROOT(I).EQ.MASKED) IUNSTUCK = I
2848         IF (R0(I)*R1(I) .GT. ZERO) GO TO 120
2849         T2 = ABS(R1(I)/(R1(I)-R0(I)))
2850         IF (T2 .LE. TMAX) GO TO 120
2851         TMAX = T2
2852         IMAX = I
2853  120    CONTINUE
2854       IF (IMAX .GT. 0) GO TO 130
2855 c******* STUCK and UNSTUCK root functions count as sign changes.
2856          IF (ISTUCK .GT. 0) THEN
2857             IMAX = ISTUCK
2858             GO TO 130
2859          ELSEIF (IUNSTUCK .GT. 0) THEN
2860             IMAX = IUNSTUCK
2861             GO TO 130
2862          ENDIF
2863       SGNCHG = .FALSE.
2864       GO TO 140
2865  130  SGNCHG = .TRUE.
2866  140  IF (.NOT. SGNCHG) GO TO 400
2867 C There is a sign change.  Find the first root in the interval. --------
2868       XROOT = .FALSE.
2869       NXLAST = 0
2870       LAST = 1
2871 C
2872 C Repeat until the first root in the interval is found.  Loop point. ---
2873  150  CONTINUE
2874       IF (XROOT) GO TO 300
2875       IF (NXLAST .EQ. LAST) GO TO 160
2876       ALPHA = 1.0D0
2877       GO TO 180
2878  160  IF (LAST .EQ. 0) GO TO 170
2879       ALPHA = 0.5D0*ALPHA
2880       GO TO 180
2881  170  ALPHA = 2.0D0*ALPHA
2882  180  X2 = X1 - (X1-X0)*R1(IMAX)/(R1(IMAX) - ALPHA*R0(IMAX))
2883       IF (ABS(X2 - X0) < HALF*HMIN) THEN
2884         FRACINT = ABS(X1 - X0)/HMIN
2885         IF (FRACINT .GT. FIVE) THEN
2886           FRACSUB = TENTH
2887         ELSE
2888           FRACSUB = HALF/FRACINT
2889         ENDIF
2890         X2 = X0 + FRACSUB*(X1 - X0)
2891       ENDIF
2892       IF (ABS(X1 - X2) < HALF*HMIN) THEN
2893         FRACINT = ABS(X1 - X0)/HMIN
2894         IF (FRACINT .GT. FIVE) THEN
2895           FRACSUB = TENTH
2896         ELSE
2897           FRACSUB = HALF/FRACINT
2898         ENDIF
2899         X2 = X1 - FRACSUB*(X1 - X0)
2900       ENDIF
2901       JFLAG = 1
2902       X = X2
2903 C Return to the calling routine to get a value of RX = R(X). -----------
2904       RETURN
2905 C Check to see in which interval R changes sign. -----------------------
2906  200  IMXOLD = IMAX
2907       IMAX = 0
2908       ISTUCK = 0
2909       IUNSTUCK = 0
2910       TMAX = ZERO
2911       ZROOT = .FALSE.
2912       DO 220 I = 1,NRT
2913         IF (ABS(RX(I)) .GT. ZERO) GO TO 210
2914         IF (ABS(RX(I)).EQ.ZERO .AND. JROOT(I).NE.MASKED) ISTUCK = I
2915 c        ZROOT = .TRUE.
2916         GO TO 220
2917 C Neither R0(i) nor RX(i) can be zero at this point. -------------------
2918  210    IF (JROOT(I).EQ.MASKED) IUNSTUCK = I
2919         IF (R0(I)*RX(I) .GT. 0) GO TO 220
2920         T2 = ABS(RX(I)/(RX(I) - R0(I)))
2921         IF (T2 .LE. TMAX) GO TO 220
2922           TMAX = T2
2923           IMAX = I
2924  220    CONTINUE
2925       IF (IMAX .GT. 0) GO TO 230
2926          IF (ISTUCK .GT. 0) THEN
2927             IMAX = ISTUCK
2928             GO TO 230
2929          ELSEIF (IUNSTUCK .GT. 0) THEN
2930             IMAX = IUNSTUCK
2931             GO TO 230
2932          ENDIF
2933       SGNCHG = .FALSE.
2934       IMAX = IMXOLD
2935       GO TO 240
2936  230  SGNCHG = .TRUE.
2937  240  NXLAST = LAST
2938       IF (.NOT. SGNCHG) GO TO 250
2939 C Sign change between X0 and X2, so replace X1 with X2. ----------------
2940       X1 = X2
2941       CALL DCOPY (NRT, RX, 1, R1, 1)
2942       LAST = 1
2943       XROOT = .FALSE.
2944       GO TO 270
2945  250  IF (.NOT. ZROOT) GO TO 260
2946 C Zero value at X2 and no sign change in (X0,X2), so X2 is a root. -----
2947       X1 = X2
2948       CALL DCOPY (NRT, RX, 1, R1, 1)
2949       XROOT = .TRUE.
2950       GO TO 270
2951 C No sign change between X0 and X2.  Replace X0 with X2. ---------------
2952  260  CONTINUE
2953       CALL DCOPY (NRT, RX, 1, R0, 1)
2954       X0 = X2
2955       LAST = 0
2956       XROOT = .FALSE.
2957  270  IF (ABS(X1-X0) .LE. HMIN) XROOT = .TRUE.
2958       GO TO 150
2959 C
2960 C Return with X1 as the root.  Set JROOT.  Set X = X1 and RX = R1. -----
2961  300  JFLAG = 2
2962       X = X1
2963       CALL DCOPY (NRT, R1, 1, RX, 1)
2964 c**** The following part unmasks root functions if needed
2965 c**** and gives final values to JROOT
2966       UMROOT = .FALSE.
2967       DO 320 I = 1,NRT
2968 c        JROOT(I) = 0
2969         IF (JROOT(I) .NE. MASKED) THEN
2970           IF (ABS(R1(I)) .EQ. ZERO) THEN
2971             IF (R0(I).GT.ZERO) THEN
2972                JROOT(I) = -1
2973             ELSE
2974                JROOT(I) = 1
2975             ENDIF
2976             ZROOT = .TRUE.
2977             GO TO 320
2978           ENDIF
2979           IF (R0(I)*R1(I).LT.ZERO) THEN
2980             JROOT(I) = SIGN(1.0D0,R1(I))
2981             ZROOT = .TRUE.
2982           ELSE
2983             JROOT(I) = 0
2984             ZROOT = .FALSE.
2985           ENDIF
2986         ELSE
2987           IF (ABS(R1(I)) .NE. ZERO) THEN
2988             IF (R1(I) .GT. ZERO) THEN
2989               JROOT(I) = 2
2990             ELSE
2991               JROOT(I) = -2
2992             ENDIF
2993             UMROOT = .TRUE.
2994           ELSE
2995             JROOT(I) = 0
2996           ENDIF
2997           ZROOT = .FALSE.
2998         ENDIF
2999  320    CONTINUE
3000       IF (ZROOT) THEN
3001         DO 325 I = 1,NRT
3002  325      IF (JROOT(I) .EQ. 2 .OR. JROOT(I) .EQ. -2) JROOT(I) = 0
3003       ELSEIF (UMROOT) THEN
3004         JFLAG = 5
3005       ENDIF
3006 c*****
3007       RETURN
3008 C
3009 C No sign change in the interval.  Check for zero at right endpoint. ---
3010  400  IF (.NOT. ZROOT) GO TO 420
3011 C
3012 C Zero value at X1 and no sign change in (X0,X1).  Return JFLAG = 3. ---
3013       X = X1
3014       CALL DCOPY (NRT, R1, 1, RX, 1)
3015       DO 410 I = 1,NRT
3016         JROOT(I) = 0
3017         IF (ABS(R1(I)) .EQ. ZERO) JROOT(I) = -SIGN(1.0D0,R0(I))
3018  410  CONTINUE
3019       JFLAG = 3
3020       RETURN
3021 C
3022 C No sign changes in this interval.  Set X = X1, return JFLAG = 4. -----
3023  420  CALL DCOPY (NRT, R1, 1, RX, 1)
3024       X = X1
3025       JFLAG = 4
3026       RETURN
3027 C----------------------- END OF SUBROUTINE DROOTS2 ----------------------
3028       END
3029       SUBROUTINE DDASIC (X, Y, YPRIME, NEQ, ICOPT, ID, RES, JAC, PSOL,
3030      *   H, TSCALE, WT, NIC, IDID, RPAR, IPAR, PHI, SAVR, DELTA, E,
3031      *   YIC, YPIC, PWK, WM, IWM, UROUND, EPLI, SQRTN, RSQRTN,
3032      *   EPCONI, STPTOL, JFLG, ICNFLG, ICNSTR, NLSIC)
3033 C
3034 C***BEGIN PROLOGUE  DDASIC
3035 C***REFER TO  DDASPK
3036 C***DATE WRITTEN   940628   (YYMMDD)
3037 C***REVISION DATE  941206   (YYMMDD)
3038 C***REVISION DATE  950714   (YYMMDD)
3039 C***REVISION DATE  000628   TSCALE argument added.
3040 C
3041 C-----------------------------------------------------------------------
3042 C***DESCRIPTION
3043 C
3044 C     DDASIC is a driver routine to compute consistent initial values
3045 C     for Y and YPRIME.  There are two different options:  
3046 C     Denoting the differential variables in Y by Y_d, and
3047 C     the algebraic variables by Y_a, the problem solved is either:
3048 C     1.  Given Y_d, calculate Y_a and Y_d', or
3049 C     2.  Given Y', calculate Y.
3050 C     In either case, initial values for the given components
3051 C     are input, and initial guesses for the unknown components
3052 C     must also be provided as input.
3053 C
3054 C     The external routine NLSIC solves the resulting nonlinear system.
3055 C
3056 C     The parameters represent
3057 C
3058 C     X  --        Independent variable.
3059 C     Y  --        Solution vector at X.
3060 C     YPRIME --    Derivative of solution vector.
3061 C     NEQ --       Number of equations to be integrated.
3062 C     ICOPT     -- Flag indicating initial condition option chosen.
3063 C                    ICOPT = 1 for option 1 above.
3064 C                    ICOPT = 2 for option 2.
3065 C     ID        -- Array of dimension NEQ, which must be initialized
3066 C                  if option 1 is chosen.
3067 C                    ID(i) = +1 if Y_i is a differential variable,
3068 C                    ID(i) = -1 if Y_i is an algebraic variable. 
3069 C     RES --       External user-supplied subroutine to evaluate the
3070 C                  residual.  See RES description in DDASPK prologue.
3071 C     JAC --       External user-supplied routine to update Jacobian
3072 C                  or preconditioner information in the nonlinear solver
3073 C                  (optional).  See JAC description in DDASPK prologue.
3074 C     PSOL --      External user-supplied routine to solve
3075 C                  a linear system using preconditioning. 
3076 C                  See PSOL in DDASPK prologue.
3077 C     H --         Scaling factor in iteration matrix.  DDASIC may 
3078 C                  reduce H to achieve convergence.
3079 C     TSCALE --    Scale factor in T, used for stopping tests if nonzero.
3080 C     WT --        Vector of weights for error criterion.
3081 C     NIC --       Input number of initial condition calculation call 
3082 C                  (= 1 or 2).
3083 C     IDID --      Completion code.  See IDID in DDASPK prologue.
3084 C     RPAR,IPAR -- Real and integer parameter arrays that
3085 C                  are used for communication between the
3086 C                  calling program and external user routines.
3087 C                  They are not altered by DNSK
3088 C     PHI --       Work space for DDASIC of length at least 2*NEQ.
3089 C     SAVR --      Work vector for DDASIC of length NEQ.
3090 C     DELTA --     Work vector for DDASIC of length NEQ.
3091 C     E --         Work vector for DDASIC of length NEQ.
3092 C     YIC,YPIC --  Work vectors for DDASIC, each of length NEQ.
3093 C     PWK --       Work vector for DDASIC of length NEQ.
3094 C     WM,IWM --    Real and integer arrays storing
3095 C                  information required by the linear solver.
3096 C     EPCONI --    Test constant for Newton iteration convergence.
3097 C     ICNFLG --    Flag showing whether constraints on Y are to apply.
3098 C     ICNSTR --    Integer array of length NEQ with constraint types.
3099 C
3100 C     The other parameters are for use internally by DDASIC.
3101 C
3102 C-----------------------------------------------------------------------
3103 C***ROUTINES CALLED
3104 C   DCOPY, NLSIC
3105 C
3106 C***END PROLOGUE  DDASIC
3107 C
3108 C
3109       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
3110       DIMENSION Y(*),YPRIME(*),ID(*),WT(*),PHI(NEQ,*)
3111       DIMENSION SAVR(*),DELTA(*),E(*),YIC(*),YPIC(*),PWK(*)
3112       DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*), ICNSTR(*)
3113       EXTERNAL RES, JAC, PSOL, NLSIC
3114 C
3115       PARAMETER (LCFN=15)
3116       PARAMETER (LMXNH=34)
3117 C
3118 C The following parameters are data-loaded here:
3119 C     RHCUT  = factor by which H is reduced on retry of Newton solve.
3120 C     RATEMX = maximum convergence rate for which Newton iteration
3121 C              is considered converging.
3122 C
3123       SAVE RHCUT, RATEMX
3124       DATA RHCUT/0.1D0/, RATEMX/0.8D0/
3125 C
3126 C
3127 C-----------------------------------------------------------------------
3128 C     BLOCK 1.
3129 C     Initializations.
3130 C     JSKIP is a flag set to 1 when NIC = 2 and NH = 1, to signal that
3131 C     the initial call to the JAC routine is to be skipped then.
3132 C     Save Y and YPRIME in PHI.  Initialize IDID, NH, and CJ.
3133 C-----------------------------------------------------------------------
3134 C
3135       MXNH = IWM(LMXNH)
3136       IDID = 1
3137       NH = 1
3138       JSKIP = 0
3139       IF (NIC .EQ. 2) JSKIP = 1
3140       CALL DCOPY (NEQ, Y, 1, PHI(1,1), 1)
3141       CALL DCOPY (NEQ, YPRIME, 1, PHI(1,2), 1)
3142 C
3143       IF (ICOPT .EQ. 2) THEN
3144         CJ = 0.0D0 
3145       ELSE
3146         CJ = 1.0D0/H
3147       ENDIF
3148 C
3149 C-----------------------------------------------------------------------
3150 C     BLOCK 2
3151 C     Call the nonlinear system solver to obtain
3152 C     consistent initial values for Y and YPRIME.
3153 C-----------------------------------------------------------------------
3154 C
3155  200  CONTINUE
3156       CALL NLSIC(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JAC,PSOL,H,TSCALE,WT,
3157      *   JSKIP,RPAR,IPAR,SAVR,DELTA,E,YIC,YPIC,PWK,WM,IWM,CJ,UROUND,
3158      *   EPLI,SQRTN,RSQRTN,EPCONI,RATEMX,STPTOL,JFLG,ICNFLG,ICNSTR,
3159      *   IERNLS)
3160 C
3161       IF (IERNLS .EQ. 0) RETURN
3162 C
3163 C-----------------------------------------------------------------------
3164 C     BLOCK 3
3165 C     The nonlinear solver was unsuccessful.  Increment NCFN.
3166 C     Return with IDID = -12 if either
3167 C       IERNLS = -1: error is considered unrecoverable,
3168 C       ICOPT = 2: we are doing initialization problem type 2, or
3169 C       NH = MXNH: the maximum number of H values has been tried.
3170 C     Otherwise (problem 1 with IERNLS .GE. 1), reduce H and try again.
3171 C     If IERNLS > 1, restore Y and YPRIME to their original values.
3172 C-----------------------------------------------------------------------
3173 C
3174       IWM(LCFN) = IWM(LCFN) + 1
3175       JSKIP = 0
3176 C
3177       IF (IERNLS .EQ. -1) GO TO 350
3178       IF (ICOPT .EQ. 2) GO TO 350
3179       IF (NH .EQ. MXNH) GO TO 350
3180 C
3181       NH = NH + 1
3182       H = H*RHCUT
3183       CJ = 1.0D0/H
3184 C
3185       IF (IERNLS .EQ. 1) GO TO 200
3186 C
3187       CALL DCOPY (NEQ, PHI(1,1), 1, Y, 1)
3188       CALL DCOPY (NEQ, PHI(1,2), 1, YPRIME, 1)
3189       GO TO 200
3190 C
3191  350  IDID = -12
3192       RETURN
3193 C
3194 C------END OF SUBROUTINE DDASIC-----------------------------------------
3195       END
3196       SUBROUTINE DYYPNW (NEQ, Y, YPRIME, CJ, RL, P, ICOPT, ID, 
3197      *                   YNEW, YPNEW)
3198 C
3199 C***BEGIN PROLOGUE  DYYPNW
3200 C***REFER TO  DLINSK
3201 C***DATE WRITTEN   940830   (YYMMDD)
3202 C
3203 C
3204 C-----------------------------------------------------------------------
3205 C***DESCRIPTION
3206 C
3207 C     DYYPNW calculates the new (Y,YPRIME) pair needed in the
3208 C     linesearch algorithm based on the current lambda value.  It is
3209 C     called by DLINSK and DLINSD.  Based on the ICOPT and ID values,
3210 C     the corresponding entry in Y or YPRIME is updated.
3211 C
3212 C     In addition to the parameters described in the calling programs,
3213 C     the parameters represent
3214 C
3215 C     P      -- Array of length NEQ that contains the current
3216 C               approximate Newton step.
3217 C     RL     -- Scalar containing the current lambda value.
3218 C     YNEW   -- Array of length NEQ containing the updated Y vector.
3219 C     YPNEW  -- Array of length NEQ containing the updated YPRIME
3220 C               vector.
3221 C-----------------------------------------------------------------------
3222 C
3223 C***ROUTINES CALLED (NONE)
3224 C
3225 C***END PROLOGUE  DYYPNW
3226 C
3227 C
3228       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3229       DIMENSION Y(*), YPRIME(*), YNEW(*), YPNEW(*), ID(*), P(*)
3230 C
3231       IF (ICOPT .EQ. 1) THEN
3232          DO 10 I=1,NEQ
3233             IF(ID(I) .LT. 0) THEN
3234                YNEW(I) = Y(I) - RL*P(I)
3235                YPNEW(I) = YPRIME(I)
3236             ELSE
3237                YNEW(I) = Y(I)
3238                YPNEW(I) = YPRIME(I) - RL*CJ*P(I)
3239             ENDIF
3240  10      CONTINUE
3241       ELSE
3242          DO 20 I = 1,NEQ
3243             YNEW(I) = Y(I) - RL*P(I)
3244             YPNEW(I) = YPRIME(I)
3245  20      CONTINUE
3246       ENDIF
3247       RETURN
3248 C----------------------- END OF SUBROUTINE DYYPNW ----------------------
3249       END
3250       SUBROUTINE DDSTP(X,Y,YPRIME,NEQ,RES,JAC,PSOL,H,WT,VT,
3251      *  JSTART,IDID,RPAR,IPAR,PHI,SAVR,DELTA,E,WM,IWM,
3252      *  ALPHA,BETA,GAMMA,PSI,SIGMA,CJ,CJOLD,HOLD,S,HMIN,UROUND,
3253      *  EPLI,SQRTN,RSQRTN,EPCON,IPHASE,JCALC,JFLG,K,KOLD,NS,NONNEG,
3254      *  NTYPE,NLS)
3255 C
3256 C***BEGIN PROLOGUE  DDSTP
3257 C***REFER TO  DDASPK
3258 C***DATE WRITTEN   890101   (YYMMDD)
3259 C***REVISION DATE  900926   (YYMMDD)
3260 C***REVISION DATE  940909   (YYMMDD) (Reset PSI(1), PHI(*,2) at 690)
3261 C
3262 C
3263 C-----------------------------------------------------------------------
3264 C***DESCRIPTION
3265 C
3266 C     DDSTP solves a system of differential/algebraic equations of 
3267 C     the form G(X,Y,YPRIME) = 0, for one step (normally from X to X+H).
3268 C
3269 C     The methods used are modified divided difference, fixed leading 
3270 C     coefficient forms of backward differentiation formulas.  
3271 C     The code adjusts the stepsize and order to control the local error
3272 C     per step.
3273 C
3274 C
3275 C     The parameters represent
3276 C     X  --        Independent variable.
3277 C     Y  --        Solution vector at X.
3278 C     YPRIME --    Derivative of solution vector
3279 C                  after successful step.
3280 C     NEQ --       Number of equations to be integrated.
3281 C     RES --       External user-supplied subroutine
3282 C                  to evaluate the residual.  See RES description
3283 C                  in DDASPK prologue.
3284 C     JAC --       External user-supplied routine to update
3285 C                  Jacobian or preconditioner information in the
3286 C                  nonlinear solver.  See JAC description in DDASPK
3287 C                  prologue.
3288 C     PSOL --      External user-supplied routine to solve
3289 C                  a linear system using preconditioning. 
3290 C                  (This is optional).  See PSOL in DDASPK prologue.
3291 C     H --         Appropriate step size for next step.
3292 C                  Normally determined by the code.
3293 C     WT --        Vector of weights for error criterion used in Newton test.
3294 C     VT --        Masked vector of weights used in error test.
3295 C     JSTART --    Integer variable set 0 for
3296 C                  first step, 1 otherwise.
3297 C     IDID --      Completion code returned from the nonlinear solver.
3298 C                  See IDID description in DDASPK prologue.
3299 C     RPAR,IPAR -- Real and integer parameter arrays that
3300 C                  are used for communication between the
3301 C                  calling program and external user routines.
3302 C                  They are not altered by DNSK
3303 C     PHI --       Array of divided differences used by
3304 C                  DDSTP. The length is NEQ*(K+1), where
3305 C                  K is the maximum order.
3306 C     SAVR --      Work vector for DDSTP of length NEQ.
3307 C     DELTA,E --   Work vectors for DDSTP of length NEQ.
3308 C     WM,IWM --    Real and integer arrays storing
3309 C                  information required by the linear solver.
3310 C
3311 C     The other parameters are information
3312 C     which is needed internally by DDSTP to
3313 C     continue from step to step.
3314 C
3315 C-----------------------------------------------------------------------
3316 C***ROUTINES CALLED
3317 C   NLS, DDWNRM, DDATRP2
3318 C
3319 C***END PROLOGUE  DDSTP
3320 C
3321 C
3322       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
3323       DIMENSION Y(*),YPRIME(*),WT(*),VT(*)
3324       DIMENSION PHI(NEQ,*),SAVR(*),DELTA(*),E(*)
3325       DIMENSION WM(*),IWM(*)
3326       DIMENSION PSI(*),ALPHA(*),BETA(*),GAMMA(*),SIGMA(*)
3327       DIMENSION RPAR(*),IPAR(*)
3328       EXTERNAL  RES, JAC, PSOL, NLS
3329 C
3330       PARAMETER (LMXORD=3)
3331       PARAMETER (LNST=11, LETF=14, LCFN=15)
3332 C
3333 C
3334 C-----------------------------------------------------------------------
3335 C     BLOCK 1.
3336 C     Initialize.  On the first call, set
3337 C     the order to 1 and initialize
3338 C     other variables.
3339 C-----------------------------------------------------------------------
3340 C
3341 C     Initializations for all calls
3342 C
3343       XOLD=X
3344       NCF=0
3345       NEF=0
3346       IF(JSTART .NE. 0) GO TO 120
3347 C
3348 C     If this is the first step, perform
3349 C     other initializations
3350 C
3351       K=1
3352       KOLD=0
3353       HOLD=0.0D0
3354       PSI(1)=H
3355       CJ = 1.D0/H
3356       IPHASE = 0
3357       NS=0
3358 120   CONTINUE
3359 C
3360 C
3361 C
3362 C
3363 C
3364 C-----------------------------------------------------------------------
3365 C     BLOCK 2
3366 C     Compute coefficients of formulas for
3367 C     this step.
3368 C-----------------------------------------------------------------------
3369 200   CONTINUE
3370       KP1=K+1
3371       KP2=K+2
3372       KM1=K-1
3373       IF(H.NE.HOLD.OR.K .NE. KOLD) NS = 0
3374       NS=MIN0(NS+1,KOLD+2)
3375       NSP1=NS+1
3376       IF(KP1 .LT. NS)GO TO 230
3377 C
3378       BETA(1)=1.0D0
3379       ALPHA(1)=1.0D0
3380       TEMP1=H
3381       GAMMA(1)=0.0D0
3382       SIGMA(1)=1.0D0
3383       DO 210 I=2,KP1
3384          TEMP2=PSI(I-1)
3385          PSI(I-1)=TEMP1
3386          BETA(I)=BETA(I-1)*PSI(I-1)/TEMP2
3387          TEMP1=TEMP2+H
3388          ALPHA(I)=H/TEMP1
3389          SIGMA(I)=(I-1)*SIGMA(I-1)*ALPHA(I)
3390          GAMMA(I)=GAMMA(I-1)+ALPHA(I-1)/H
3391 210      CONTINUE
3392       PSI(KP1)=TEMP1
3393 230   CONTINUE
3394 C
3395 C     Compute ALPHAS, ALPHA0
3396 C
3397       ALPHAS = 0.0D0
3398       ALPHA0 = 0.0D0
3399       DO 240 I = 1,K
3400         ALPHAS = ALPHAS - 1.0D0/I
3401         ALPHA0 = ALPHA0 - ALPHA(I)
3402 240     CONTINUE
3403 C
3404 C     Compute leading coefficient CJ
3405 C
3406       CJLAST = CJ
3407       CJ = -ALPHAS/H
3408 C
3409 C     Compute variable stepsize error coefficient CK
3410 C
3411       CK = ABS(ALPHA(KP1) + ALPHAS - ALPHA0)
3412       CK = MAX(CK,ALPHA(KP1))
3413 C
3414 C     Change PHI to PHI STAR
3415 C
3416       IF(KP1 .LT. NSP1) GO TO 280
3417       DO 270 J=NSP1,KP1
3418          DO 260 I=1,NEQ
3419 260         PHI(I,J)=BETA(J)*PHI(I,J)
3420 270      CONTINUE
3421 280   CONTINUE
3422 C
3423 C     Update time
3424 C
3425       X=X+H
3426 C
3427 C     Initialize IDID to 1
3428 C
3429       IDID = 1
3430 C
3431 C
3432 C
3433 C
3434 C
3435 C-----------------------------------------------------------------------
3436 C     BLOCK 3
3437 C     Call the nonlinear system solver to obtain the solution and
3438 C     derivative.
3439 C-----------------------------------------------------------------------
3440 C
3441       CALL NLS(X,Y,YPRIME,NEQ,
3442      *   RES,JAC,PSOL,H,WT,JSTART,IDID,RPAR,IPAR,PHI,GAMMA,
3443      *   SAVR,DELTA,E,WM,IWM,CJ,CJOLD,CJLAST,S,
3444      *   UROUND,EPLI,SQRTN,RSQRTN,EPCON,JCALC,JFLG,KP1,
3445      *   NONNEG,NTYPE,IERNLS)
3446 C
3447       IF(IERNLS .NE. 0)GO TO 600
3448 C
3449 C
3450 C
3451 C
3452 C
3453 C-----------------------------------------------------------------------
3454 C     BLOCK 4
3455 C     Estimate the errors at orders K,K-1,K-2
3456 C     as if constant stepsize was used. Estimate
3457 C     the local error at order K and test
3458 C     whether the current step is successful.
3459 C-----------------------------------------------------------------------
3460 C
3461 C     Estimate errors at orders K,K-1,K-2
3462 C
3463       ENORM = DDWNRM(NEQ,E,VT,RPAR,IPAR)
3464       ERK = SIGMA(K+1)*ENORM
3465       TERK = (K+1)*ERK
3466       EST = ERK
3467       KNEW=K
3468       IF(K .EQ. 1)GO TO 430
3469       DO 405 I = 1,NEQ
3470 405     DELTA(I) = PHI(I,KP1) + E(I)
3471       ERKM1=SIGMA(K)*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR)
3472       TERKM1 = K*ERKM1
3473       IF(K .GT. 2)GO TO 410
3474       IF(TERKM1 .LE. 0.5*TERK)GO TO 420
3475       GO TO 430
3476 410   CONTINUE
3477       DO 415 I = 1,NEQ
3478 415     DELTA(I) = PHI(I,K) + DELTA(I)
3479       ERKM2=SIGMA(K-1)*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR)
3480       TERKM2 = (K-1)*ERKM2
3481       IF(MAX(TERKM1,TERKM2).GT.TERK)GO TO 430
3482 C
3483 C     Lower the order
3484 C
3485 420   CONTINUE
3486       KNEW=K-1
3487       EST = ERKM1
3488 C
3489 C
3490 C     Calculate the local error for the current step
3491 C     to see if the step was successful
3492 C
3493 430   CONTINUE
3494       ERR = CK * ENORM
3495       IF(ERR .GT. 1.0D0)GO TO 600
3496 C
3497 C
3498 C
3499 C
3500 C
3501 C-----------------------------------------------------------------------
3502 C     BLOCK 5
3503 C     The step is successful. Determine
3504 C     the best order and stepsize for
3505 C     the next step. Update the differences
3506 C     for the next step.
3507 C-----------------------------------------------------------------------
3508       IDID=1
3509       IWM(LNST)=IWM(LNST)+1
3510       KDIFF=K-KOLD
3511       KOLD=K
3512       HOLD=H
3513 C
3514 C
3515 C     Estimate the error at order K+1 unless
3516 C        already decided to lower order, or
3517 C        already using maximum order, or
3518 C        stepsize not constant, or
3519 C        order raised in previous step
3520 C
3521       IF(KNEW.EQ.KM1.OR.K.EQ.IWM(LMXORD))IPHASE=1
3522       IF(IPHASE .EQ. 0)GO TO 545
3523       IF(KNEW.EQ.KM1)GO TO 540
3524       IF(K.EQ.IWM(LMXORD)) GO TO 550
3525       IF(KP1.GE.NS.OR.KDIFF.EQ.1)GO TO 550
3526       DO 510 I=1,NEQ
3527 510      DELTA(I)=E(I)-PHI(I,KP2)
3528       ERKP1 = (1.0D0/(K+2))*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR)
3529       TERKP1 = (K+2)*ERKP1
3530       IF(K.GT.1)GO TO 520
3531       IF(TERKP1.GE.0.5D0*TERK)GO TO 550
3532       GO TO 530
3533 520   IF(TERKM1.LE.MIN(TERK,TERKP1))GO TO 540
3534       IF(TERKP1.GE.TERK.OR.K.EQ.IWM(LMXORD))GO TO 550
3535 C
3536 C     Raise order
3537 C
3538 530   K=KP1
3539       EST = ERKP1
3540       GO TO 550
3541 C
3542 C     Lower order
3543 C
3544 540   K=KM1
3545       EST = ERKM1
3546       GO TO 550
3547 C
3548 C     If IPHASE = 0, increase order by one and multiply stepsize by
3549 C     factor two
3550 C
3551 545   K = KP1
3552       HNEW = H*2.0D0
3553       H = HNEW
3554       GO TO 575
3555 C
3556 C
3557 C     Determine the appropriate stepsize for
3558 C     the next step.
3559 C
3560 550   HNEW=H
3561       TEMP2=K+1
3562       R=(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2)
3563       IF(R .LT. 2.0D0) GO TO 555
3564       HNEW = 2.0D0*H
3565       GO TO 560
3566 555   IF(R .GT. 1.0D0) GO TO 560
3567       R = MAX(0.5D0,MIN(0.9D0,R))
3568       HNEW = H*R
3569 560   H=HNEW
3570 C
3571 C
3572 C     Update differences for next step
3573 C
3574 575   CONTINUE
3575       IF(KOLD.EQ.IWM(LMXORD))GO TO 585
3576       DO 580 I=1,NEQ
3577 580      PHI(I,KP2)=E(I)
3578 585   CONTINUE
3579       DO 590 I=1,NEQ
3580 590      PHI(I,KP1)=PHI(I,KP1)+E(I)
3581       DO 595 J1=2,KP1
3582          J=KP1-J1+1
3583          DO 595 I=1,NEQ
3584 595      PHI(I,J)=PHI(I,J)+PHI(I,J+1)
3585       JSTART = 1
3586       RETURN
3587 C
3588 C
3589 C
3590 C
3591 C
3592 C-----------------------------------------------------------------------
3593 C     BLOCK 6
3594 C     The step is unsuccessful. Restore X,PSI,PHI
3595 C     Determine appropriate stepsize for
3596 C     continuing the integration, or exit with
3597 C     an error flag if there have been many
3598 C     failures.
3599 C-----------------------------------------------------------------------
3600 600   IPHASE = 1
3601 C
3602 C     Restore X,PHI,PSI
3603 C
3604       X=XOLD
3605       IF(KP1.LT.NSP1)GO TO 630
3606       DO 620 J=NSP1,KP1
3607          TEMP1=1.0D0/BETA(J)
3608          DO 610 I=1,NEQ
3609 610         PHI(I,J)=TEMP1*PHI(I,J)
3610 620      CONTINUE
3611 630   CONTINUE
3612       DO 640 I=2,KP1
3613 640      PSI(I-1)=PSI(I)-H
3614 C
3615 C
3616 C     Test whether failure is due to nonlinear solver
3617 C     or error test
3618 C
3619       IF(IERNLS .EQ. 0)GO TO 660
3620       IWM(LCFN)=IWM(LCFN)+1
3621 C
3622 C
3623 C     The nonlinear solver failed to converge.
3624 C     Determine the cause of the failure and take appropriate action.
3625 C     If IERNLS .LT. 0, then return.  Otherwise, reduce the stepsize
3626 C     and try again, unless too many failures have occurred.
3627 C
3628       IF (IERNLS .LT. 0) GO TO 675
3629       NCF = NCF + 1
3630       R = 0.25D0
3631       H = H*R
3632       IF (NCF .LT. 10 .AND. ABS(H) .GE. HMIN) GO TO 690
3633       IF (IDID .EQ. 1) IDID = -7
3634       IF (NEF .GE. 3) IDID = -9
3635       GO TO 675
3636 C
3637 C
3638 C     The nonlinear solver converged, and the cause
3639 C     of the failure was the error estimate
3640 C     exceeding the tolerance.
3641 C
3642 660   NEF=NEF+1
3643       IWM(LETF)=IWM(LETF)+1
3644       IF (NEF .GT. 1) GO TO 665
3645 C
3646 C     On first error test failure, keep current order or lower
3647 C     order by one.  Compute new stepsize based on differences
3648 C     of the solution.
3649 C
3650       K = KNEW
3651       TEMP2 = K + 1
3652       R = 0.90D0*(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2)
3653       R = MAX(0.25D0,MIN(0.9D0,R))
3654       H = H*R
3655       IF (ABS(H) .GE. HMIN) GO TO 690
3656       IDID = -6
3657       GO TO 675
3658 C
3659 C     On second error test failure, use the current order or
3660 C     decrease order by one.  Reduce the stepsize by a factor of
3661 C     one quarter.
3662 C
3663 665   IF (NEF .GT. 2) GO TO 670
3664       K = KNEW
3665       R = 0.25D0
3666       H = R*H
3667       IF (ABS(H) .GE. HMIN) GO TO 690
3668       IDID = -6
3669       GO TO 675
3670 C
3671 C     On third and subsequent error test failures, set the order to
3672 C     one, and reduce the stepsize by a factor of one quarter.
3673 C
3674 670   K = 1
3675       R = 0.25D0
3676       H = R*H
3677       IF (ABS(H) .GE. HMIN) GO TO 690
3678       IDID = -6
3679       GO TO 675
3680 C
3681 C
3682 C
3683 C
3684 C     For all crashes, restore Y to its last value,
3685 C     interpolate to find YPRIME at last X, and return.
3686 C
3687 C     Before returning, verify that the user has not set
3688 C     IDID to a nonnegative value.  If the user has set IDID
3689 C     to a nonnegative value, then reset IDID to be -7, indicating
3690 C     a failure in the nonlinear system solver.
3691 C
3692 675   CONTINUE
3693       CALL DDATRP2(X,X,Y,YPRIME,NEQ,K,PHI,PSI)
3694       JSTART = 1
3695       IF (IDID .GE. 0) IDID = -7
3696       RETURN
3697 C
3698 C
3699 C     Go back and try this step again.  
3700 C     If this is the first step, reset PSI(1) and rescale PHI(*,2).
3701 C
3702 690   IF (KOLD .EQ. 0) THEN
3703         PSI(1) = H
3704         DO 695 I = 1,NEQ
3705 695       PHI(I,2) = R*PHI(I,2)
3706         ENDIF
3707       GO TO 200
3708 C
3709 C------END OF SUBROUTINE DDSTP------------------------------------------
3710       END
3711       SUBROUTINE DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR)
3712 C
3713 C***BEGIN PROLOGUE  DCNSTR
3714 C***DATE WRITTEN   950808   (YYMMDD)
3715 C***REVISION DATE  950814   (YYMMDD)
3716 C
3717 C
3718 C-----------------------------------------------------------------------
3719 C***DESCRIPTION
3720 C
3721 C This subroutine checks for constraint violations in the proposed 
3722 C new approximate solution YNEW.
3723 C If a constraint violation occurs, then a new step length, TAU,
3724 C is calculated, and this value is to be given to the linesearch routine
3725 C to calculate a new approximate solution YNEW.
3726 C
3727 C On entry:
3728 C
3729 C   NEQ    -- size of the nonlinear system, and the length of arrays
3730 C             Y, YNEW and ICNSTR.
3731 C
3732 C   Y      -- real array containing the current approximate y.
3733 C
3734 C   YNEW   -- real array containing the new approximate y.
3735 C
3736 C   ICNSTR -- INTEGER array of length NEQ containing flags indicating
3737 C             which entries in YNEW are to be constrained.
3738 C             if ICNSTR(I) =  2, then YNEW(I) must be .GT. 0,
3739 C             if ICNSTR(I) =  1, then YNEW(I) must be .GE. 0,
3740 C             if ICNSTR(I) = -1, then YNEW(I) must be .LE. 0, while
3741 C             if ICNSTR(I) = -2, then YNEW(I) must be .LT. 0, while
3742 C             if ICNSTR(I) =  0, then YNEW(I) is not constrained.
3743 C
3744 C   RLX    -- real scalar restricting update, if ICNSTR(I) = 2 or -2,
3745 C             to ABS( (YNEW-Y)/Y ) < FAC2*RLX in component I.
3746 C
3747 C   TAU    -- the current size of the step length for the linesearch.
3748 C
3749 C On return
3750 C
3751 C   TAU    -- the adjusted size of the step length if a constraint
3752 C             violation occurred (otherwise, it is unchanged).  it is
3753 C             the step length to give to the linesearch routine.
3754 C
3755 C   IRET   -- output flag.
3756 C             IRET=0 means that YNEW satisfied all constraints.
3757 C             IRET=1 means that YNEW failed to satisfy all the
3758 C                    constraints, and a new linesearch step
3759 C                    must be computed.
3760 C
3761 C   IVAR   -- index of variable causing constraint to be violated.
3762 C
3763 C-----------------------------------------------------------------------
3764       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
3765       DIMENSION Y(NEQ), YNEW(NEQ), ICNSTR(NEQ)
3766       SAVE FAC, FAC2, ZERO
3767       DATA FAC /0.6D0/, FAC2 /0.9D0/, ZERO/0.0D0/
3768 C-----------------------------------------------------------------------
3769 C Check constraints for proposed new step YNEW.  If a constraint has
3770 C been violated, then calculate a new step length, TAU, to be
3771 C used in the linesearch routine.
3772 C-----------------------------------------------------------------------
3773       IRET = 0
3774       RDYMX = ZERO
3775       IVAR = 0
3776       DO 100 I = 1,NEQ
3777 C
3778          IF (ICNSTR(I) .EQ. 2) THEN
3779             RDY = ABS( (YNEW(I)-Y(I))/Y(I) )
3780             IF (RDY .GT. RDYMX) THEN
3781                RDYMX = RDY
3782                IVAR = I
3783             ENDIF
3784             IF (YNEW(I) .LE. ZERO) THEN
3785                TAU = FAC*TAU
3786                IVAR = I
3787                IRET = 1
3788                RETURN
3789             ENDIF
3790 C
3791          ELSEIF (ICNSTR(I) .EQ. 1) THEN
3792             IF (YNEW(I) .LT. ZERO) THEN
3793                TAU = FAC*TAU
3794                IVAR = I
3795                IRET = 1
3796                RETURN
3797             ENDIF
3798 C
3799          ELSEIF (ICNSTR(I) .EQ. -1) THEN
3800             IF (YNEW(I) .GT. ZERO) THEN
3801                TAU = FAC*TAU
3802                IVAR = I
3803                IRET = 1
3804                RETURN
3805             ENDIF
3806 C
3807          ELSEIF (ICNSTR(I) .EQ. -2) THEN
3808             RDY = ABS( (YNEW(I)-Y(I))/Y(I) )
3809             IF (RDY .GT. RDYMX) THEN
3810                RDYMX = RDY
3811                IVAR = I
3812             ENDIF
3813             IF (YNEW(I) .GE. ZERO) THEN
3814                TAU = FAC*TAU
3815                IVAR = I
3816                IRET = 1
3817                RETURN
3818             ENDIF
3819 C
3820          ENDIF
3821  100  CONTINUE
3822
3823       IF(RDYMX .GE. RLX) THEN
3824          TAU = FAC2*TAU*RLX/RDYMX
3825          IRET = 1
3826       ENDIF
3827 C
3828       RETURN
3829 C----------------------- END OF SUBROUTINE DCNSTR ----------------------
3830       END
3831       SUBROUTINE DCNST0 (NEQ, Y, ICNSTR, IRET)
3832 C
3833 C***BEGIN PROLOGUE  DCNST0
3834 C***DATE WRITTEN   950808   (YYMMDD)
3835 C***REVISION DATE  950808   (YYMMDD)
3836 C
3837 C
3838 C-----------------------------------------------------------------------
3839 C***DESCRIPTION
3840 C
3841 C This subroutine checks for constraint violations in the initial 
3842 C approximate solution u.
3843 C
3844 C On entry
3845 C
3846 C   NEQ    -- size of the nonlinear system, and the length of arrays
3847 C             Y and ICNSTR.
3848 C
3849 C   Y      -- real array containing the initial approximate root.
3850 C
3851 C   ICNSTR -- INTEGER array of length NEQ containing flags indicating
3852 C             which entries in Y are to be constrained.
3853 C             if ICNSTR(I) =  2, then Y(I) must be .GT. 0,
3854 C             if ICNSTR(I) =  1, then Y(I) must be .GE. 0,
3855 C             if ICNSTR(I) = -1, then Y(I) must be .LE. 0, while
3856 C             if ICNSTR(I) = -2, then Y(I) must be .LT. 0, while
3857 C             if ICNSTR(I) =  0, then Y(I) is not constrained.
3858 C
3859 C On return
3860 C
3861 C   IRET   -- output flag.
3862 C             IRET=0    means that u satisfied all constraints.
3863 C             IRET.NE.0 means that Y(IRET) failed to satisfy its
3864 C                       constraint.
3865 C
3866 C-----------------------------------------------------------------------
3867       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
3868       DIMENSION Y(NEQ), ICNSTR(NEQ)
3869       SAVE ZERO
3870       DATA ZERO/0.D0/
3871 C-----------------------------------------------------------------------
3872 C Check constraints for initial Y.  If a constraint has been violated,
3873 C set IRET = I to signal an error return to calling routine.
3874 C-----------------------------------------------------------------------
3875       IRET = 0
3876       DO 100 I = 1,NEQ
3877          IF (ICNSTR(I) .EQ. 2) THEN
3878             IF (Y(I) .LE. ZERO) THEN
3879                IRET = I
3880                RETURN
3881             ENDIF
3882          ELSEIF (ICNSTR(I) .EQ. 1) THEN
3883             IF (Y(I) .LT. ZERO) THEN
3884                IRET = I
3885                RETURN
3886             ENDIF 
3887          ELSEIF (ICNSTR(I) .EQ. -1) THEN
3888             IF (Y(I) .GT. ZERO) THEN
3889                IRET = I
3890                RETURN
3891             ENDIF 
3892          ELSEIF (ICNSTR(I) .EQ. -2) THEN
3893             IF (Y(I) .GE. ZERO) THEN
3894                IRET = I
3895                RETURN
3896             ENDIF 
3897         ENDIF
3898  100  CONTINUE
3899       RETURN
3900 C----------------------- END OF SUBROUTINE DCNST0 ----------------------
3901       END
3902       SUBROUTINE DDAWTS2(NEQ,IWT,RTOL,ATOL,Y,WT,RPAR,IPAR)
3903 C
3904 C***BEGIN PROLOGUE  DDAWTS2
3905 C***REFER TO  DDASPK
3906 C***ROUTINES CALLED  (NONE)
3907 C***DATE WRITTEN   890101   (YYMMDD)
3908 C***REVISION DATE  900926   (YYMMDD)
3909 C***END PROLOGUE  DDAWTS2
3910 C-----------------------------------------------------------------------
3911 C     This subroutine sets the error weight vector,
3912 C     WT, according to WT(I)=RTOL(I)*ABS(Y(I))+ATOL(I),
3913 C     I = 1 to NEQ.
3914 C     RTOL and ATOL are scalars if IWT = 0,
3915 C     and vectors if IWT = 1.
3916 C-----------------------------------------------------------------------
3917 C
3918       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
3919       DIMENSION RTOL(*),ATOL(*),Y(*),WT(*)
3920       DIMENSION RPAR(*),IPAR(*)
3921       RTOLI=RTOL(1)
3922       ATOLI=ATOL(1)
3923       DO 20 I=1,NEQ
3924          IF (IWT .EQ.0) GO TO 10
3925            RTOLI=RTOL(I)
3926            ATOLI=ATOL(I)
3927 10         WT(I)=RTOLI*ABS(Y(I))+ATOLI
3928 20         CONTINUE
3929       RETURN
3930 C
3931 C------END OF SUBROUTINE DDAWTS2----------------------------------
3932       END
3933       SUBROUTINE DINVWT(NEQ,WT,IER)
3934 C
3935 C***BEGIN PROLOGUE  DINVWT
3936 C***REFER TO  DDASPK
3937 C***ROUTINES CALLED  (NONE)
3938 C***DATE WRITTEN   950125   (YYMMDD)
3939 C***END PROLOGUE  DINVWT
3940 C-----------------------------------------------------------------------
3941 C     This subroutine checks the error weight vector WT, of length NEQ,
3942 C     for components that are .le. 0, and if none are found, it
3943 C     inverts the WT(I) in place.  This replaces division operations
3944 C     with multiplications in all norm evaluations.
3945 C     IER is returned as 0 if all WT(I) were found positive,
3946 C     and the first I with WT(I) .le. 0.0 otherwise.
3947 C-----------------------------------------------------------------------
3948 C
3949       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
3950       DIMENSION WT(*)
3951 C
3952       DO 10 I = 1,NEQ
3953         IF (WT(I) .LE. 0.0D0) GO TO 30
3954  10     CONTINUE
3955       DO 20 I = 1,NEQ
3956  20     WT(I) = 1.0D0/WT(I)
3957       IER = 0
3958       RETURN
3959 C
3960  30   IER = I
3961       RETURN
3962 C
3963 C------END OF SUBROUTINE DINVWT-----------------------------------------
3964       END
3965       SUBROUTINE DDATRP2(X,XOUT,YOUT,YPOUT,NEQ,KOLD,PHI,PSI)
3966 C
3967 C***BEGIN PROLOGUE  DDATRP2
3968 C***REFER TO  DDASPK
3969 C***ROUTINES CALLED  (NONE)
3970 C***DATE WRITTEN   890101   (YYMMDD)
3971 C***REVISION DATE  900926   (YYMMDD)
3972 C***END PROLOGUE  DDATRP2
3973 C
3974 C-----------------------------------------------------------------------
3975 C     The methods in subroutine DDSTP use polynomials
3976 C     to approximate the solution.  DDATRP2 approximates the
3977 C     solution and its derivative at time XOUT by evaluating
3978 C     one of these polynomials, and its derivative, there.
3979 C     Information defining this polynomial is passed from
3980 C     DDSTP, so DDATRP2 cannot be used alone.
3981 C
3982 C     The parameters are
3983 C
3984 C     X     The current time in the integration.
3985 C     XOUT  The time at which the solution is desired.
3986 C     YOUT  The interpolated approximation to Y at XOUT.
3987 C           (This is output.)
3988 C     YPOUT The interpolated approximation to YPRIME at XOUT.
3989 C           (This is output.)
3990 C     NEQ   Number of equations.
3991 C     KOLD  Order used on last successful step.
3992 C     PHI   Array of scaled divided differences of Y.
3993 C     PSI   Array of past stepsize history.
3994 C-----------------------------------------------------------------------
3995 C
3996       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
3997       DIMENSION YOUT(*),YPOUT(*)
3998       DIMENSION PHI(NEQ,*),PSI(*)
3999       KOLDP1=KOLD+1
4000       TEMP1=XOUT-X
4001       DO 10 I=1,NEQ
4002          YOUT(I)=PHI(I,1)
4003 10       YPOUT(I)=0.0D0
4004       C=1.0D0
4005       D=0.0D0
4006       GAMMA=TEMP1/PSI(1)
4007       DO 30 J=2,KOLDP1
4008          D=D*GAMMA+C/PSI(J-1)
4009          C=C*GAMMA
4010          GAMMA=(TEMP1+PSI(J-1))/PSI(J)
4011          DO 20 I=1,NEQ
4012             YOUT(I)=YOUT(I)+C*PHI(I,J)
4013 20          YPOUT(I)=YPOUT(I)+D*PHI(I,J)
4014 30       CONTINUE
4015       RETURN
4016 C
4017 C------END OF SUBROUTINE DDATRP2---------------------------------
4018       END
4019       DOUBLE PRECISION FUNCTION DDWNRM(NEQ,V,RWT,RPAR,IPAR)
4020 C
4021 C***BEGIN PROLOGUE  DDWNRM
4022 C***ROUTINES CALLED  (NONE)
4023 C***DATE WRITTEN   890101   (YYMMDD)
4024 C***REVISION DATE  900926   (YYMMDD)
4025 C***END PROLOGUE  DDWNRM
4026 C-----------------------------------------------------------------------
4027 C     This function routine computes the weighted
4028 C     root-mean-square norm of the vector of length
4029 C     NEQ contained in the array V, with reciprocal weights
4030 C     contained in the array RWT of length NEQ.
4031 C        DDWNRM=SQRT((1/NEQ)*SUM(V(I)*RWT(I))**2)
4032 C-----------------------------------------------------------------------
4033 C
4034       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
4035       DIMENSION V(*),RWT(*)
4036       DIMENSION RPAR(*),IPAR(*)
4037       DDWNRM = 0.0D0
4038       VMAX = 0.0D0
4039       DO 10 I = 1,NEQ
4040         IF(ABS(V(I)*RWT(I)) .GT. VMAX) VMAX = ABS(V(I)*RWT(I))
4041 10    CONTINUE
4042       IF(VMAX .LE. 0.0D0) GO TO 30
4043       SUM = 0.0D0
4044       DO 20 I = 1,NEQ
4045 20      SUM = SUM + ((V(I)*RWT(I))/VMAX)**2
4046       DDWNRM = VMAX*SQRT(SUM/NEQ)
4047 30    CONTINUE
4048       RETURN
4049 C
4050 C------END OF FUNCTION DDWNRM-------------------------------------------
4051       END
4052       SUBROUTINE DDASID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JACD,PDUM,H,TSCALE,
4053      *  WT,JSDUM,RPAR,IPAR,DUMSVR,DELTA,R,YIC,YPIC,DUMPWK,WM,IWM,CJ,
4054      *  UROUND,DUME,DUMS,DUMR,EPCON,RATEMX,STPTOL,JFDUM,
4055      *  ICNFLG,ICNSTR,IERNLS)
4056 C
4057 C***BEGIN PROLOGUE  DDASID
4058 C***REFER TO  DDASPK
4059 C***DATE WRITTEN   940701   (YYMMDD)
4060 C***REVISION DATE  950808   (YYMMDD)
4061 C***REVISION DATE  951110   Removed unreachable block 390.
4062 C***REVISION DATE  000628   TSCALE argument added.
4063 C
4064 C
4065 C-----------------------------------------------------------------------
4066 C***DESCRIPTION
4067 C
4068 C
4069 C     DDASID solves a nonlinear system of algebraic equations of the
4070 C     form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in
4071 C     the initial conditions.
4072 C
4073 C     The method used is a modified Newton scheme.
4074 C
4075 C     The parameters represent
4076 C
4077 C     X         -- Independent variable.
4078 C     Y         -- Solution vector.
4079 C     YPRIME    -- Derivative of solution vector.
4080 C     NEQ       -- Number of unknowns.
4081 C     ICOPT     -- Initial condition option chosen (1 or 2).
4082 C     ID        -- Array of dimension NEQ, which must be initialized
4083 C                  if ICOPT = 1.  See DDASIC.
4084 C     RES       -- External user-supplied subroutine to evaluate the
4085 C                  residual.  See RES description in DDASPK prologue.
4086 C     JACD      -- External user-supplied routine to evaluate the
4087 C                  Jacobian.  See JAC description for the case
4088 C                  INFO(12) = 0 in the DDASPK prologue.
4089 C     PDUM      -- Dummy argument.
4090 C     H         -- Scaling factor for this initial condition calc.
4091 C     TSCALE    -- Scale factor in T, used for stopping tests if nonzero.
4092 C     WT        -- Vector of weights for error criterion.
4093 C     JSDUM     -- Dummy argument.
4094 C     RPAR,IPAR -- Real and integer arrays used for communication
4095 C                  between the calling program and external user
4096 C                  routines.  They are not altered within DASPK.
4097 C     DUMSVR    -- Dummy argument.
4098 C     DELTA     -- Work vector for NLS of length NEQ.
4099 C     R         -- Work vector for NLS of length NEQ.
4100 C     YIC,YPIC  -- Work vectors for NLS, each of length NEQ.
4101 C     DUMPWK    -- Dummy argument.
4102 C     WM,IWM    -- Real and integer arrays storing matrix information
4103 C                  such as the matrix of partial derivatives,
4104 C                  permutation vector, and various other information.
4105 C     CJ        -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2).
4106 C     UROUND    -- Unit roundoff.
4107 C     DUME      -- Dummy argument.
4108 C     DUMS      -- Dummy argument.
4109 C     DUMR      -- Dummy argument.
4110 C     EPCON     -- Tolerance to test for convergence of the Newton
4111 C                  iteration.
4112 C     RATEMX    -- Maximum convergence rate for which Newton iteration
4113 C                  is considered converging.
4114 C     JFDUM     -- Dummy argument.
4115 C     STPTOL    -- Tolerance used in calculating the minimum lambda
4116 C                  value allowed.
4117 C     ICNFLG    -- Integer scalar.  If nonzero, then constraint
4118 C                  violations in the proposed new approximate solution
4119 C                  will be checked for, and the maximum step length 
4120 C                  will be adjusted accordingly.
4121 C     ICNSTR    -- Integer array of length NEQ containing flags for
4122 C                  checking constraints.
4123 C     IERNLS    -- Error flag for nonlinear solver.
4124 C                   0   ==> nonlinear solver converged.
4125 C                   1,2 ==> recoverable error inside nonlinear solver.
4126 C                           1 => retry with current Y, YPRIME
4127 C                           2 => retry with original Y, YPRIME
4128 C                  -1   ==> unrecoverable error in nonlinear solver.
4129 C
4130 C     All variables with "DUM" in their names are dummy variables
4131 C     which are not used in this routine.
4132 C
4133 C-----------------------------------------------------------------------
4134 C
4135 C***ROUTINES CALLED
4136 C   RES, DMATD, DNSID
4137 C
4138 C***END PROLOGUE  DDASID
4139 C
4140 C
4141       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
4142       DIMENSION Y(*),YPRIME(*),ID(*),WT(*),ICNSTR(*)
4143       DIMENSION DELTA(*),R(*),YIC(*),YPIC(*)
4144       DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*)
4145       EXTERNAL  RES, JACD
4146 C
4147       PARAMETER (LNRE=12, LNJE=13, LMXNIT=32, LMXNJ=33)
4148 C
4149 C
4150 C     Perform initializations.
4151 C
4152       MXNIT = IWM(LMXNIT)
4153       MXNJ = IWM(LMXNJ)
4154       IERNLS = 0
4155       NJ = 0
4156 C
4157 C     Call RES to initialize DELTA.
4158 C
4159       IRES = 0
4160       IWM(LNRE) = IWM(LNRE) + 1
4161       CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
4162       IF (IRES .LT. 0) GO TO 370
4163 C
4164 C     Looping point for updating the Jacobian.
4165 C
4166 300   CONTINUE
4167 C
4168 C     Initialize all error flags to zero.
4169 C
4170       IERJ = 0
4171       IRES = 0
4172       IERNEW = 0
4173 C
4174 C     Reevaluate the iteration matrix, J = dG/dY + CJ*dG/dYPRIME,
4175 C     where G(X,Y,YPRIME) = 0.
4176 C
4177       NJ = NJ + 1
4178       IWM(LNJE)=IWM(LNJE)+1
4179       CALL DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IERJ,WT,R,
4180      *              WM,IWM,RES,IRES,UROUND,JACD,RPAR,IPAR)
4181       IF (IRES .LT. 0 .OR. IERJ .NE. 0) GO TO 370
4182 C
4183 C     Call the nonlinear Newton solver for up to MXNIT iterations.
4184 C
4185       CALL DNSID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,WT,RPAR,IPAR,DELTA,R,
4186      *     YIC,YPIC,WM,IWM,CJ,TSCALE,EPCON,RATEMX,MXNIT,STPTOL,
4187      *     ICNFLG,ICNSTR,IERNEW)
4188 C
4189       IF (IERNEW .EQ. 1 .AND. NJ .LT. MXNJ) THEN
4190 C
4191 C        MXNIT iterations were done, the convergence rate is < 1,
4192 C        and the number of Jacobian evaluations is less than MXNJ.
4193 C        Call RES, reevaluate the Jacobian, and try again.
4194 C
4195          IWM(LNRE)=IWM(LNRE)+1
4196          CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
4197          IF (IRES .LT. 0) GO TO 370
4198          GO TO 300
4199          ENDIF
4200 C
4201       IF (IERNEW .NE. 0) GO TO 380
4202
4203       RETURN
4204 C
4205 C
4206 C     Unsuccessful exits from nonlinear solver.
4207 C     Compute IERNLS accordingly.
4208 C
4209 370   IERNLS = 2
4210       IF (IRES .LE. -2) IERNLS = -1
4211       RETURN
4212 C
4213 380   IERNLS = MIN(IERNEW,2)
4214       RETURN
4215 C
4216 C------END OF SUBROUTINE DDASID-----------------------------------------
4217       END
4218       SUBROUTINE DNSID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,WT,RPAR,IPAR,
4219      *   DELTA,R,YIC,YPIC,WM,IWM,CJ,TSCALE,EPCON,RATEMX,MAXIT,STPTOL,
4220      *   ICNFLG,ICNSTR,IERNEW)
4221 C
4222 C***BEGIN PROLOGUE  DNSID
4223 C***REFER TO  DDASPK
4224 C***DATE WRITTEN   940701   (YYMMDD)
4225 C***REVISION DATE  950713   (YYMMDD)
4226 C***REVISION DATE  000628   TSCALE argument added.
4227 C
4228 C
4229 C-----------------------------------------------------------------------
4230 C***DESCRIPTION
4231 C
4232 C     DNSID solves a nonlinear system of algebraic equations of the
4233 C     form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME
4234 C     in the initial conditions.
4235 C
4236 C     The method used is a modified Newton scheme.
4237 C
4238 C     The parameters represent
4239 C
4240 C     X         -- Independent variable.
4241 C     Y         -- Solution vector.
4242 C     YPRIME    -- Derivative of solution vector.
4243 C     NEQ       -- Number of unknowns.
4244 C     ICOPT     -- Initial condition option chosen (1 or 2).
4245 C     ID        -- Array of dimension NEQ, which must be initialized
4246 C                  if ICOPT = 1.  See DDASIC.
4247 C     RES       -- External user-supplied subroutine to evaluate the
4248 C                  residual.  See RES description in DDASPK prologue.
4249 C     WT        -- Vector of weights for error criterion.
4250 C     RPAR,IPAR -- Real and integer arrays used for communication
4251 C                  between the calling program and external user
4252 C                  routines.  They are not altered within DASPK.
4253 C     DELTA     -- Residual vector on entry, and work vector of
4254 C                  length NEQ for DNSID.
4255 C     WM,IWM    -- Real and integer arrays storing matrix information
4256 C                  such as the matrix of partial derivatives,
4257 C                  permutation vector, and various other information.
4258 C     CJ        -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2).
4259 C     TSCALE    -- Scale factor in T, used for stopping tests if nonzero.
4260 C     R         -- Array of length NEQ used as workspace by the 
4261 C                  linesearch routine DLINSD.
4262 C     YIC,YPIC  -- Work vectors for DLINSD, each of length NEQ.
4263 C     EPCON     -- Tolerance to test for convergence of the Newton
4264 C                  iteration.
4265 C     RATEMX    -- Maximum convergence rate for which Newton iteration
4266 C                  is considered converging.
4267 C     MAXIT     -- Maximum allowed number of Newton iterations.
4268 C     STPTOL    -- Tolerance used in calculating the minimum lambda
4269 C                  value allowed.
4270 C     ICNFLG    -- Integer scalar.  If nonzero, then constraint
4271 C                  violations in the proposed new approximate solution
4272 C                  will be checked for, and the maximum step length 
4273 C                  will be adjusted accordingly.
4274 C     ICNSTR    -- Integer array of length NEQ containing flags for
4275 C                  checking constraints.
4276 C     IERNEW    -- Error flag for Newton iteration.
4277 C                   0  ==> Newton iteration converged.
4278 C                   1  ==> failed to converge, but RATE .le. RATEMX.
4279 C                   2  ==> failed to converge, RATE .gt. RATEMX.
4280 C                   3  ==> other recoverable error (IRES = -1, or
4281 C                          linesearch failed).
4282 C                  -1  ==> unrecoverable error (IRES = -2).
4283 C
4284 C-----------------------------------------------------------------------
4285 C
4286 C***ROUTINES CALLED
4287 C   DSLVD, DDWNRM, DLINSD, DCOPY
4288 C
4289 C***END PROLOGUE  DNSID
4290 C
4291 C
4292       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
4293       DIMENSION Y(*),YPRIME(*),WT(*),R(*)
4294       DIMENSION ID(*),DELTA(*), YIC(*), YPIC(*)
4295       DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*)
4296       DIMENSION ICNSTR(*)
4297       EXTERNAL  RES
4298 C
4299       PARAMETER (LNNI=19, LLSOFF=35)
4300 C
4301 C
4302 C     Initializations.  M is the Newton iteration counter.
4303 C
4304       LSOFF = IWM(LLSOFF)
4305       M = 0
4306       RATE = 1.0D0
4307       RLX = 0.4D0
4308 C
4309 C     Compute a new step vector DELTA by back-substitution.
4310 C
4311       CALL DSLVD (NEQ, DELTA, WM, IWM)
4312 C
4313 C     Get norm of DELTA.  Return now if norm(DELTA) .le. EPCON.
4314 C
4315       DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR)
4316       FNRM = DELNRM
4317       IF (TSCALE .GT. 0.0D0) FNRM = FNRM*TSCALE*ABS(CJ)
4318       IF (FNRM .LE. EPCON) RETURN
4319 C
4320 C     Newton iteration loop.
4321 C
4322  300  CONTINUE
4323       IWM(LNNI) = IWM(LNNI) + 1
4324 C
4325 C     Call linesearch routine for global strategy and set RATE
4326 C
4327       OLDFNM = FNRM
4328 C
4329       CALL DLINSD (NEQ, Y, X, YPRIME, CJ, TSCALE, DELTA, DELNRM, WT,
4330      *             LSOFF, STPTOL, IRET, RES, IRES, WM, IWM, FNRM, ICOPT,
4331      *             ID, R, YIC, YPIC, ICNFLG, ICNSTR, RLX, RPAR, IPAR)
4332 C
4333       RATE = FNRM/OLDFNM
4334 C
4335 C     Check for error condition from linesearch.
4336       IF (IRET .NE. 0) GO TO 390
4337 C
4338 C     Test for convergence of the iteration, and return or loop.
4339 C
4340       IF (FNRM .LE. EPCON) RETURN
4341 C
4342 C     The iteration has not yet converged.  Update M.
4343 C     Test whether the maximum number of iterations have been tried.
4344 C
4345       M = M + 1
4346       IF (M .GE. MAXIT) GO TO 380
4347 C
4348 C     Copy the residual to DELTA and its norm to DELNRM, and loop for
4349 C     another iteration.
4350 C
4351       CALL DCOPY (NEQ, R, 1, DELTA, 1)
4352       DELNRM = FNRM      
4353       GO TO 300
4354 C
4355 C     The maximum number of iterations was done.  Set IERNEW and return.
4356 C
4357  380  IF (RATE .LE. RATEMX) THEN
4358          IERNEW = 1
4359       ELSE
4360          IERNEW = 2
4361       ENDIF
4362       RETURN
4363 C
4364  390  IF (IRES .LE. -2) THEN
4365          IERNEW = -1
4366       ELSE
4367          IERNEW = 3
4368       ENDIF
4369       RETURN
4370 C
4371 C
4372 C------END OF SUBROUTINE DNSID------------------------------------------
4373       END
4374       SUBROUTINE DLINSD (NEQ, Y, T, YPRIME, CJ, TSCALE, P, PNRM, WT,
4375      *                   LSOFF, STPTOL, IRET, RES, IRES, WM, IWM,
4376      *                   FNRM, ICOPT, ID, R, YNEW, YPNEW, ICNFLG,
4377      *                   ICNSTR, RLX, RPAR, IPAR)
4378 C
4379 C***BEGIN PROLOGUE  DLINSD
4380 C***REFER TO  DNSID
4381 C***DATE WRITTEN   941025   (YYMMDD)
4382 C***REVISION DATE  941215   (YYMMDD)
4383 C***REVISION DATE  960129   Moved line RL = ONE to top block.
4384 C***REVISION DATE  000628   TSCALE argument added.
4385 C
4386 C
4387 C-----------------------------------------------------------------------
4388 C***DESCRIPTION
4389 C
4390 C     DLINSD uses a linesearch algorithm to calculate a new (Y,YPRIME)
4391 C     pair (YNEW,YPNEW) such that 
4392 C
4393 C     f(YNEW,YPNEW) .le. (1 - 2*ALPHA*RL)*f(Y,YPRIME) ,
4394 C
4395 C     where 0 < RL <= 1.  Here, f(y,y') is defined as
4396 C
4397 C      f(y,y') = (1/2)*norm( (J-inverse)*G(t,y,y') )**2 ,
4398 C
4399 C     where norm() is the weighted RMS vector norm, G is the DAE
4400 C     system residual function, and J is the system iteration matrix
4401 C     (Jacobian).
4402 C
4403 C     In addition to the parameters defined elsewhere, we have
4404 C
4405 C     TSCALE  --  Scale factor in T, used for stopping tests if nonzero.
4406 C     P       -- Approximate Newton step used in backtracking.
4407 C     PNRM    -- Weighted RMS norm of P.
4408 C     LSOFF   -- Flag showing whether the linesearch algorithm is
4409 C                to be invoked.  0 means do the linesearch, and
4410 C                1 means turn off linesearch.
4411 C     STPTOL  -- Tolerance used in calculating the minimum lambda
4412 C                value allowed.
4413 C     ICNFLG  -- Integer scalar.  If nonzero, then constraint violations
4414 C                in the proposed new approximate solution will be
4415 C                checked for, and the maximum step length will be
4416 C                adjusted accordingly.
4417 C     ICNSTR  -- Integer array of length NEQ containing flags for
4418 C                checking constraints.
4419 C     RLX     -- Real scalar restricting update size in DCNSTR.
4420 C     YNEW    -- Array of length NEQ used to hold the new Y in
4421 C                performing the linesearch.
4422 C     YPNEW   -- Array of length NEQ used to hold the new YPRIME in
4423 C                performing the linesearch.
4424 C     Y       -- Array of length NEQ containing the new Y (i.e.,=YNEW).
4425 C     YPRIME  -- Array of length NEQ containing the new YPRIME 
4426 C                (i.e.,=YPNEW).
4427 C     FNRM    -- Real scalar containing SQRT(2*f(Y,YPRIME)) for the
4428 C                current (Y,YPRIME) on input and output.
4429 C     R       -- Work array of length NEQ, containing the scaled 
4430 C                residual (J-inverse)*G(t,y,y') on return.
4431 C     IRET    -- Return flag.
4432 C                IRET=0 means that a satisfactory (Y,YPRIME) was found.
4433 C                IRET=1 means that the routine failed to find a new
4434 C                       (Y,YPRIME) that was sufficiently distinct from
4435 C                       the current (Y,YPRIME) pair.
4436 C                IRET=2 means IRES .ne. 0 from RES.
4437 C-----------------------------------------------------------------------
4438 C
4439 C***ROUTINES CALLED
4440 C   DFNRMD, DYYPNW, DCNSTR, DCOPY, XERRWD
4441 C
4442 C***END PROLOGUE  DLINSD
4443 C
4444       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
4445       EXTERNAL  RES
4446       DIMENSION Y(*), YPRIME(*), WT(*), R(*), ID(*)
4447       DIMENSION WM(*), IWM(*)
4448       DIMENSION YNEW(*), YPNEW(*), P(*), ICNSTR(*)
4449       DIMENSION RPAR(*), IPAR(*)
4450       CHARACTER MSG*80
4451 C
4452       PARAMETER (LNRE=12, LKPRIN=31)
4453 C
4454       SAVE ALPHA, ONE, TWO
4455       DATA ALPHA/1.0D-4/, ONE/1.0D0/, TWO/2.0D0/
4456 C
4457       KPRIN=IWM(LKPRIN)
4458 C
4459       F1NRM = (FNRM*FNRM)/TWO
4460       RATIO = ONE
4461       IF (KPRIN .GE. 2) THEN
4462         MSG = '------ IN ROUTINE DLINSD-- PNRM = (R1)'
4463         CALL XERRWD(MSG, 38, 901, 0, 0, 0, 0, 1, PNRM, 0.0D0)
4464         ENDIF
4465       TAU = PNRM
4466       RL = ONE
4467 C-----------------------------------------------------------------------
4468 C Check for violations of the constraints, if any are imposed.
4469 C If any violations are found, the step vector P is rescaled, and the 
4470 C constraint check is repeated, until no violations are found.
4471 C-----------------------------------------------------------------------
4472       IF (ICNFLG .NE. 0) THEN
4473  10      CONTINUE
4474          CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW)
4475          CALL DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR)
4476          IF (IRET .EQ. 1) THEN
4477             RATIO1 = TAU/PNRM
4478             RATIO = RATIO*RATIO1
4479             DO 20 I = 1,NEQ
4480  20           P(I) = P(I)*RATIO1
4481             PNRM = TAU
4482             IF (KPRIN .GE. 2) THEN
4483               MSG = '------ CONSTRAINT VIOL., PNRM = (R1), INDEX = (I1)'
4484               CALL XERRWD(MSG, 50, 902, 0, 1, IVAR, 0, 1, PNRM, 0.0D0)
4485               ENDIF
4486             IF (PNRM .LE. STPTOL) THEN
4487               IRET = 1
4488               RETURN
4489               ENDIF
4490             GO TO 10
4491             ENDIF
4492          ENDIF
4493 C
4494       SLPI = (-TWO*F1NRM)*RATIO
4495       RLMIN = STPTOL/PNRM
4496       IF (LSOFF .EQ. 0 .AND. KPRIN .GE. 2) THEN
4497         MSG = '------ MIN. LAMBDA = (R1)'
4498         CALL XERRWD(MSG, 25, 903, 0, 0, 0, 0, 1, RLMIN, 0.0D0)
4499         ENDIF
4500 C-----------------------------------------------------------------------
4501 C Begin iteration to find RL value satisfying alpha-condition.
4502 C If RL becomes less than RLMIN, then terminate with IRET = 1.
4503 C-----------------------------------------------------------------------
4504  100  CONTINUE
4505       CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW)
4506       CALL DFNRMD (NEQ, YNEW, T, YPNEW, R, CJ, TSCALE, WT, RES, IRES,
4507      *              FNRMP, WM, IWM, RPAR, IPAR)
4508       IWM(LNRE) = IWM(LNRE) + 1
4509       IF (IRES .NE. 0) THEN
4510         IRET = 2
4511         RETURN
4512         ENDIF
4513       IF (LSOFF .EQ. 1) GO TO 150
4514 C
4515       F1NRMP = FNRMP*FNRMP/TWO
4516       IF (KPRIN .GE. 2) THEN
4517         MSG = '------ LAMBDA = (R1)'
4518         CALL XERRWD(MSG, 20, 904, 0, 0, 0, 0, 1, RL, 0.0D0)
4519         MSG = '------ NORM(F1) = (R1),  NORM(F1NEW) = (R2)'
4520         CALL XERRWD(MSG, 43, 905, 0, 0, 0, 0, 2, F1NRM, F1NRMP)
4521         ENDIF
4522       IF (F1NRMP .GT. F1NRM + ALPHA*SLPI*RL) GO TO 200
4523 C-----------------------------------------------------------------------
4524 C Alpha-condition is satisfied, or linesearch is turned off.
4525 C Copy YNEW,YPNEW to Y,YPRIME and return.
4526 C-----------------------------------------------------------------------
4527  150  IRET = 0
4528       CALL DCOPY (NEQ, YNEW, 1, Y, 1)
4529       CALL DCOPY (NEQ, YPNEW, 1, YPRIME, 1)
4530       FNRM = FNRMP
4531       IF (KPRIN .GE. 1) THEN
4532         MSG = '------ LEAVING ROUTINE DLINSD, FNRM = (R1)'
4533         CALL XERRWD(MSG, 42, 906, 0, 0, 0, 0, 1, FNRM, 0.0D0)
4534         ENDIF
4535       RETURN
4536 C-----------------------------------------------------------------------
4537 C Alpha-condition not satisfied.  Perform backtrack to compute new RL
4538 C value.  If no satisfactory YNEW,YPNEW can be found sufficiently 
4539 C distinct from Y,YPRIME, then return IRET = 1.
4540 C-----------------------------------------------------------------------
4541  200  CONTINUE
4542       IF (RL .LT. RLMIN) THEN
4543         IRET = 1
4544         RETURN
4545         ENDIF
4546 C
4547       RL = RL/TWO
4548       GO TO 100
4549 C
4550 C----------------------- END OF SUBROUTINE DLINSD ----------------------
4551       END
4552       SUBROUTINE DFNRMD (NEQ, Y, T, YPRIME, R, CJ, TSCALE, WT,
4553      *                   RES, IRES, FNORM, WM, IWM, RPAR, IPAR)
4554 C
4555 C***BEGIN PROLOGUE  DFNRMD
4556 C***REFER TO  DLINSD
4557 C***DATE WRITTEN   941025   (YYMMDD)
4558 C***REVISION DATE  000628   TSCALE argument added.
4559 C
4560 C
4561 C-----------------------------------------------------------------------
4562 C***DESCRIPTION
4563 C
4564 C     DFNRMD calculates the scaled preconditioned norm of the nonlinear
4565 C     function used in the nonlinear iteration for obtaining consistent
4566 C     initial conditions.  Specifically, DFNRMD calculates the weighted
4567 C     root-mean-square norm of the vector (J-inverse)*G(T,Y,YPRIME),
4568 C     where J is the Jacobian matrix.
4569 C
4570 C     In addition to the parameters described in the calling program
4571 C     DLINSD, the parameters represent
4572 C
4573 C     R      -- Array of length NEQ that contains
4574 C               (J-inverse)*G(T,Y,YPRIME) on return.
4575 C     TSCALE -- Scale factor in T, used for stopping tests if nonzero.
4576 C     FNORM  -- Scalar containing the weighted norm of R on return.
4577 C-----------------------------------------------------------------------
4578 C
4579 C***ROUTINES CALLED
4580 C   RES, DSLVD, DDWNRM
4581 C
4582 C***END PROLOGUE  DFNRMD
4583 C
4584 C
4585       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4586       EXTERNAL RES
4587       DIMENSION Y(*), YPRIME(*), WT(*), R(*)
4588       DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*)
4589 C-----------------------------------------------------------------------
4590 C     Call RES routine.
4591 C-----------------------------------------------------------------------
4592       IRES = 0
4593       CALL RES(T,Y,YPRIME,R,IRES,RPAR,IPAR)
4594       IF (IRES .LT. 0) RETURN
4595 C-----------------------------------------------------------------------
4596 C     Apply inverse of Jacobian to vector R.
4597 C-----------------------------------------------------------------------
4598       CALL DSLVD(NEQ,R,WM,IWM)
4599 C-----------------------------------------------------------------------
4600 C     Calculate norm of R.
4601 C-----------------------------------------------------------------------
4602       FNORM = DDWNRM(NEQ,R,WT,RPAR,IPAR)
4603       IF (TSCALE .GT. 0.0D0) FNORM = FNORM*TSCALE*ABS(CJ)
4604 C
4605       RETURN
4606 C----------------------- END OF SUBROUTINE DFNRMD ----------------------
4607       END
4608       SUBROUTINE DNEDD(X,Y,YPRIME,NEQ,RES,JACD,PDUM,H,WT,
4609      *   JSTART,IDID,RPAR,IPAR,PHI,GAMMA,DUMSVR,DELTA,E,
4610      *   WM,IWM,CJ,CJOLD,CJLAST,S,UROUND,DUME,DUMS,DUMR,
4611      *   EPCON,JCALC,JFDUM,KP1,NONNEG,NTYPE,IERNLS)
4612 C
4613 C***BEGIN PROLOGUE  DNEDD
4614 C***REFER TO  DDASPK
4615 C***DATE WRITTEN   891219   (YYMMDD)
4616 C***REVISION DATE  900926   (YYMMDD)
4617 C
4618 C
4619 C-----------------------------------------------------------------------
4620 C***DESCRIPTION
4621 C
4622 C     DNEDD solves a nonlinear system of
4623 C     algebraic equations of the form
4624 C     G(X,Y,YPRIME) = 0 for the unknown Y.
4625 C
4626 C     The method used is a modified Newton scheme.
4627 C
4628 C     The parameters represent
4629 C
4630 C     X         -- Independent variable.
4631 C     Y         -- Solution vector.
4632 C     YPRIME    -- Derivative of solution vector.
4633 C     NEQ       -- Number of unknowns.
4634 C     RES       -- External user-supplied subroutine
4635 C                  to evaluate the residual.  See RES description
4636 C                  in DDASPK prologue.
4637 C     JACD      -- External user-supplied routine to evaluate the
4638 C                  Jacobian.  See JAC description for the case
4639 C                  INFO(12) = 0 in the DDASPK prologue.
4640 C     PDUM      -- Dummy argument.
4641 C     H         -- Appropriate step size for next step.
4642 C     WT        -- Vector of weights for error criterion.
4643 C     JSTART    -- Indicates first call to this routine.
4644 C                  If JSTART = 0, then this is the first call,
4645 C                  otherwise it is not.
4646 C     IDID      -- Completion flag, output by DNEDD.
4647 C                  See IDID description in DDASPK prologue.
4648 C     RPAR,IPAR -- Real and integer arrays used for communication
4649 C                  between the calling program and external user
4650 C                  routines.  They are not altered within DASPK.
4651 C     PHI       -- Array of divided differences used by
4652 C                  DNEDD.  The length is NEQ*(K+1),where
4653 C                  K is the maximum order.
4654 C     GAMMA     -- Array used to predict Y and YPRIME.  The length
4655 C                  is MAXORD+1 where MAXORD is the maximum order.
4656 C     DUMSVR    -- Dummy argument.
4657 C     DELTA     -- Work vector for NLS of length NEQ.
4658 C     E         -- Error accumulation vector for NLS of length NEQ.
4659 C     WM,IWM    -- Real and integer arrays storing
4660 C                  matrix information such as the matrix
4661 C                  of partial derivatives, permutation
4662 C                  vector, and various other information.
4663 C     CJ        -- Parameter always proportional to 1/H.
4664 C     CJOLD     -- Saves the value of CJ as of the last call to DMATD.
4665 C                  Accounts for changes in CJ needed to
4666 C                  decide whether to call DMATD.
4667 C     CJLAST    -- Previous value of CJ.
4668 C     S         -- A scalar determined by the approximate rate
4669 C                  of convergence of the Newton iteration and used
4670 C                  in the convergence test for the Newton iteration.
4671 C
4672 C                  If RATE is defined to be an estimate of the
4673 C                  rate of convergence of the Newton iteration,
4674 C                  then S = RATE/(1.D0-RATE).
4675 C
4676 C                  The closer RATE is to 0., the faster the Newton
4677 C                  iteration is converging; the closer RATE is to 1.,
4678 C                  the slower the Newton iteration is converging.
4679 C
4680 C                  On the first Newton iteration with an up-dated
4681 C                  preconditioner S = 100.D0, Thus the initial
4682 C                  RATE of convergence is approximately 1.
4683 C
4684 C                  S is preserved from call to call so that the rate
4685 C                  estimate from a previous step can be applied to
4686 C                  the current step.
4687 C     UROUND    -- Unit roundoff.
4688 C     DUME      -- Dummy argument.
4689 C     DUMS      -- Dummy argument.
4690 C     DUMR      -- Dummy argument.
4691 C     EPCON     -- Tolerance to test for convergence of the Newton
4692 C                  iteration.
4693 C     JCALC     -- Flag used to determine when to update
4694 C                  the Jacobian matrix.  In general:
4695 C
4696 C                  JCALC = -1 ==> Call the DMATD routine to update
4697 C                                 the Jacobian matrix.
4698 C                  JCALC =  0 ==> Jacobian matrix is up-to-date.
4699 C                  JCALC =  1 ==> Jacobian matrix is out-dated,
4700 C                                 but DMATD will not be called unless
4701 C                                 JCALC is set to -1.
4702 C     JFDUM     -- Dummy argument.
4703 C     KP1       -- The current order(K) + 1;  updated across calls.
4704 C     NONNEG    -- Flag to determine nonnegativity constraints.
4705 C     NTYPE     -- Identification code for the NLS routine.
4706 C                   0  ==> modified Newton; direct solver.
4707 C     IERNLS    -- Error flag for nonlinear solver.
4708 C                   0  ==> nonlinear solver converged.
4709 C                   1  ==> recoverable error inside nonlinear solver.
4710 C                  -1  ==> unrecoverable error inside nonlinear solver.
4711 C
4712 C     All variables with "DUM" in their names are dummy variables
4713 C     which are not used in this routine.
4714 C
4715 C     Following is a list and description of local variables which
4716 C     may not have an obvious usage.  They are listed in roughly the
4717 C     order they occur in this subroutine.
4718 C
4719 C     The following group of variables are passed as arguments to
4720 C     the Newton iteration solver.  They are explained in greater detail
4721 C     in DNSD:
4722 C        TOLNEW, MULDEL, MAXIT, IERNEW
4723 C
4724 C     IERTYP -- Flag which tells whether this subroutine is correct.
4725 C               0 ==> correct subroutine.
4726 C               1 ==> incorrect subroutine.
4727
4728 C-----------------------------------------------------------------------
4729 C***ROUTINES CALLED
4730 C   DDWNRM, RES, DMATD, DNSD
4731 C
4732 C***END PROLOGUE  DNEDD
4733 C
4734 C
4735       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
4736       DIMENSION Y(*),YPRIME(*),WT(*)
4737       DIMENSION DELTA(*),E(*)
4738       DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*)
4739       DIMENSION PHI(NEQ,*),GAMMA(*)
4740       EXTERNAL  RES, JACD
4741 C
4742       PARAMETER (LNRE=12, LNJE=13)
4743 C
4744       SAVE MULDEL, MAXIT, XRATE
4745       DATA MULDEL/1/, MAXIT/4/, XRATE/0.25D0/
4746 C
4747 C     Verify that this is the correct subroutine.
4748 C
4749       IERTYP = 0
4750       IF (NTYPE .NE. 0) THEN
4751          IERTYP = 1
4752          GO TO 380
4753          ENDIF
4754 C
4755 C     If this is the first step, perform initializations.
4756 C
4757       IF (JSTART .EQ. 0) THEN
4758          CJOLD = CJ
4759          JCALC = -1
4760          ENDIF
4761 C
4762 C     Perform all other initializations.
4763 C
4764       IERNLS = 0
4765 C
4766 C     Decide whether new Jacobian is needed.
4767 C
4768       TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE)
4769       TEMP2 = 1.0D0/TEMP1
4770       IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1
4771       IF (CJ .NE. CJLAST) S = 100.D0
4772 C
4773 C-----------------------------------------------------------------------
4774 C     Entry point for updating the Jacobian with current
4775 C     stepsize.
4776 C-----------------------------------------------------------------------
4777 300   CONTINUE
4778 C
4779 C     Initialize all error flags to zero.
4780 C
4781       IERJ = 0
4782       IRES = 0
4783       IERNEW = 0
4784 C
4785 C     Predict the solution and derivative and compute the tolerance
4786 C     for the Newton iteration.
4787 C
4788       DO 310 I=1,NEQ
4789          Y(I)=PHI(I,1)
4790 310      YPRIME(I)=0.0D0
4791       DO 330 J=2,KP1
4792          DO 320 I=1,NEQ
4793             Y(I)=Y(I)+PHI(I,J)
4794 320         YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J)
4795 330   CONTINUE
4796       PNORM = DDWNRM (NEQ,Y,WT,RPAR,IPAR)
4797       TOLNEW = 100.D0*UROUND*PNORM
4798 C     
4799 C     Call RES to initialize DELTA.
4800 C
4801       IWM(LNRE)=IWM(LNRE)+1
4802       CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
4803       IF (IRES .LT. 0) GO TO 380
4804 C
4805 C     If indicated, reevaluate the iteration matrix 
4806 C     J = dG/dY + CJ*dG/dYPRIME (where G(X,Y,YPRIME)=0).
4807 C     Set JCALC to 0 as an indicator that this has been done.
4808 C
4809       IF(JCALC .EQ. -1) THEN
4810          IWM(LNJE)=IWM(LNJE)+1
4811          JCALC=0
4812          CALL DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IERJ,WT,E,WM,IWM,
4813      *              RES,IRES,UROUND,JACD,RPAR,IPAR)
4814          CJOLD=CJ
4815          S = 100.D0
4816          IF (IRES .LT. 0) GO TO 380
4817          IF(IERJ .NE. 0)GO TO 380
4818       ENDIF
4819 C
4820 C     Call the nonlinear Newton solver.
4821 C
4822       TEMP1 = 2.0D0/(1.0D0 + CJ/CJOLD)
4823       CALL DNSD(X,Y,YPRIME,NEQ,RES,PDUM,WT,RPAR,IPAR,DUMSVR,
4824      *          DELTA,E,WM,IWM,CJ,DUMS,DUMR,DUME,EPCON,S,TEMP1,
4825      *          TOLNEW,MULDEL,MAXIT,IRES,IDUM,IERNEW)
4826 C
4827       IF (IERNEW .GT. 0 .AND. JCALC .NE. 0) THEN
4828 C
4829 C        The Newton iteration had a recoverable failure with an old
4830 C        iteration matrix.  Retry the step with a new iteration matrix.
4831 C
4832          JCALC = -1
4833          GO TO 300
4834       ENDIF
4835 C
4836       IF (IERNEW .NE. 0) GO TO 380
4837 C
4838 C     The Newton iteration has converged.  If nonnegativity of
4839 C     solution is required, set the solution nonnegative, if the
4840 C     perturbation to do it is small enough.  If the change is too
4841 C     large, then consider the corrector iteration to have failed.
4842 C
4843 375   IF(NONNEG .EQ. 0) GO TO 390
4844       DO 377 I = 1,NEQ
4845 377      DELTA(I) = MIN(Y(I),0.0D0)
4846       DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR)
4847       IF(DELNRM .GT. EPCON) GO TO 380
4848       DO 378 I = 1,NEQ
4849 378      E(I) = E(I) - DELTA(I)
4850       GO TO 390
4851 C
4852 C
4853 C     Exits from nonlinear solver.
4854 C     No convergence with current iteration
4855 C     matrix, or singular iteration matrix.
4856 C     Compute IERNLS and IDID accordingly.
4857 C
4858 380   CONTINUE
4859       IF (IRES .LE. -2 .OR. IERTYP .NE. 0) THEN
4860          IERNLS = -1
4861          IF (IRES .LE. -2) IDID = -11
4862          IF (IERTYP .NE. 0) IDID = -15
4863       ELSE
4864          IERNLS = 1
4865          IF (IRES .LT. 0) IDID = -10
4866          IF (IERJ .NE. 0) IDID = -8
4867       ENDIF
4868 C
4869 390   JCALC = 1
4870       RETURN
4871 C
4872 C------END OF SUBROUTINE DNEDD------------------------------------------
4873       END
4874       SUBROUTINE DNSD(X,Y,YPRIME,NEQ,RES,PDUM,WT,RPAR,IPAR,
4875      *   DUMSVR,DELTA,E,WM,IWM,CJ,DUMS,DUMR,DUME,EPCON,
4876      *   S,CONFAC,TOLNEW,MULDEL,MAXIT,IRES,IDUM,IERNEW)
4877 C
4878 C***BEGIN PROLOGUE  DNSD
4879 C***REFER TO  DDASPK
4880 C***DATE WRITTEN   891219   (YYMMDD)
4881 C***REVISION DATE  900926   (YYMMDD)
4882 C***REVISION DATE  950126   (YYMMDD)
4883 C***REVISION DATE  000711   (YYMMDD)
4884 C
4885 C
4886 C-----------------------------------------------------------------------
4887 C***DESCRIPTION
4888 C
4889 C     DNSD solves a nonlinear system of
4890 C     algebraic equations of the form
4891 C     G(X,Y,YPRIME) = 0 for the unknown Y.
4892 C
4893 C     The method used is a modified Newton scheme.
4894 C
4895 C     The parameters represent
4896 C
4897 C     X         -- Independent variable.
4898 C     Y         -- Solution vector.
4899 C     YPRIME    -- Derivative of solution vector.
4900 C     NEQ       -- Number of unknowns.
4901 C     RES       -- External user-supplied subroutine
4902 C                  to evaluate the residual.  See RES description
4903 C                  in DDASPK prologue.
4904 C     PDUM      -- Dummy argument.
4905 C     WT        -- Vector of weights for error criterion.
4906 C     RPAR,IPAR -- Real and integer arrays used for communication
4907 C                  between the calling program and external user
4908 C                  routines.  They are not altered within DASPK.
4909 C     DUMSVR    -- Dummy argument.
4910 C     DELTA     -- Work vector for DNSD of length NEQ.
4911 C     E         -- Error accumulation vector for DNSD of length NEQ.
4912 C     WM,IWM    -- Real and integer arrays storing
4913 C                  matrix information such as the matrix
4914 C                  of partial derivatives, permutation
4915 C                  vector, and various other information.
4916 C     CJ        -- Parameter always proportional to 1/H (step size).
4917 C     DUMS      -- Dummy argument.
4918 C     DUMR      -- Dummy argument.
4919 C     DUME      -- Dummy argument.
4920 C     EPCON     -- Tolerance to test for convergence of the Newton
4921 C                  iteration.
4922 C     S         -- Used for error convergence tests.
4923 C                  In the Newton iteration: S = RATE/(1 - RATE),
4924 C                  where RATE is the estimated rate of convergence
4925 C                  of the Newton iteration.
4926 C                  The calling routine passes the initial value
4927 C                  of S to the Newton iteration.
4928 C     CONFAC    -- A residual scale factor to improve convergence.
4929 C     TOLNEW    -- Tolerance on the norm of Newton correction in
4930 C                  alternative Newton convergence test.
4931 C     MULDEL    -- A flag indicating whether or not to multiply
4932 C                  DELTA by CONFAC.
4933 C                  0  ==> do not scale DELTA by CONFAC.
4934 C                  1  ==> scale DELTA by CONFAC.
4935 C     MAXIT     -- Maximum allowed number of Newton iterations.
4936 C     IRES      -- Error flag returned from RES.  See RES description
4937 C                  in DDASPK prologue.  If IRES = -1, then IERNEW
4938 C                  will be set to 1.
4939 C                  If IRES < -1, then IERNEW will be set to -1.
4940 C     IDUM      -- Dummy argument.
4941 C     IERNEW    -- Error flag for Newton iteration.
4942 C                   0  ==> Newton iteration converged.
4943 C                   1  ==> recoverable error inside Newton iteration.
4944 C                  -1  ==> unrecoverable error inside Newton iteration.
4945 C
4946 C     All arguments with "DUM" in their names are dummy arguments
4947 C     which are not used in this routine.
4948 C-----------------------------------------------------------------------
4949 C
4950 C***ROUTINES CALLED
4951 C   DSLVD, DDWNRM, RES
4952 C
4953 C***END PROLOGUE  DNSD
4954 C
4955 C
4956       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
4957       DIMENSION Y(*),YPRIME(*),WT(*),DELTA(*),E(*)
4958       DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*)
4959       EXTERNAL  RES
4960 C
4961       PARAMETER (LNRE=12, LNNI=19)
4962 C
4963 C     Initialize Newton counter M and accumulation vector E. 
4964 C
4965       M = 0
4966       DO 100 I=1,NEQ
4967 100     E(I)=0.0D0
4968 C
4969 C     Corrector loop.
4970 C
4971 300   CONTINUE
4972       IWM(LNNI) = IWM(LNNI) + 1
4973 C
4974 C     If necessary, multiply residual by convergence factor.
4975 C
4976       IF (MULDEL .EQ. 1) THEN
4977          DO 320 I = 1,NEQ
4978 320        DELTA(I) = DELTA(I) * CONFAC
4979         ENDIF
4980 C
4981 C     Compute a new iterate (back-substitution).
4982 C     Store the correction in DELTA.
4983 C
4984       CALL DSLVD(NEQ,DELTA,WM,IWM)
4985 C
4986 C     Update Y, E, and YPRIME.
4987 C
4988       DO 340 I=1,NEQ
4989          Y(I)=Y(I)-DELTA(I)
4990          E(I)=E(I)-DELTA(I)
4991 340      YPRIME(I)=YPRIME(I)-CJ*DELTA(I)
4992 C
4993 C     Test for convergence of the iteration.
4994 C
4995       DELNRM=DDWNRM(NEQ,DELTA,WT,RPAR,IPAR)
4996       IF (M .EQ. 0) THEN
4997         OLDNRM = DELNRM
4998         IF (DELNRM .LE. TOLNEW) GO TO 370
4999       ELSE
5000         RATE = (DELNRM/OLDNRM)**(1.0D0/M)
5001         IF (RATE .GT. 0.9D0) GO TO 380
5002         S = RATE/(1.0D0 - RATE)
5003       ENDIF
5004       IF (S*DELNRM .LE. EPCON) GO TO 370
5005 C
5006 C     The corrector has not yet converged.
5007 C     Update M and test whether the
5008 C     maximum number of iterations have
5009 C     been tried.
5010 C
5011       M=M+1
5012       IF(M.GE.MAXIT) GO TO 380
5013 C
5014 C     Evaluate the residual,
5015 C     and go back to do another iteration.
5016 C
5017       IWM(LNRE)=IWM(LNRE)+1
5018       CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
5019       IF (IRES .LT. 0) GO TO 380
5020       GO TO 300
5021 C
5022 C     The iteration has converged.
5023 C
5024 370   RETURN
5025 C
5026 C     The iteration has not converged.  Set IERNEW appropriately.
5027 C
5028 380   CONTINUE
5029       IF (IRES .LE. -2 ) THEN
5030          IERNEW = -1
5031       ELSE
5032          IERNEW = 1
5033       ENDIF
5034       RETURN
5035 C
5036 C
5037 C------END OF SUBROUTINE DNSD-------------------------------------------
5038       END
5039       SUBROUTINE DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IER,EWT,E,
5040      *                 WM,IWM,RES,IRES,UROUND,JACD,RPAR,IPAR)
5041 C
5042 C***BEGIN PROLOGUE  DMATD
5043 C***REFER TO  DDASPK
5044 C***DATE WRITTEN   890101   (YYMMDD)
5045 C***REVISION DATE  900926   (YYMMDD)
5046 C***REVISION DATE  940701   (new LIPVT)
5047 C***REVISION DATE  060712   (Changed minimum D.Q. increment to 1/EWT(j))
5048 C
5049 C-----------------------------------------------------------------------
5050 C***DESCRIPTION
5051 C
5052 C     This routine computes the iteration matrix
5053 C     J = dG/dY+CJ*dG/dYPRIME (where G(X,Y,YPRIME)=0).
5054 C     Here J is computed by:
5055 C       the user-supplied routine JACD if IWM(MTYPE) is 1 or 4, or
5056 C       by numerical difference quotients if IWM(MTYPE) is 2 or 5.
5057 C
5058 C     The parameters have the following meanings.
5059 C     X        = Independent variable.
5060 C     Y        = Array containing predicted values.
5061 C     YPRIME   = Array containing predicted derivatives.
5062 C     DELTA    = Residual evaluated at (X,Y,YPRIME).
5063 C                (Used only if IWM(MTYPE)=2 or 5).
5064 C     CJ       = Scalar parameter defining iteration matrix.
5065 C     H        = Current stepsize in integration.
5066 C     IER      = Variable which is .NE. 0 if iteration matrix
5067 C                is singular, and 0 otherwise.
5068 C     EWT      = Vector of error weights for computing norms.
5069 C     E        = Work space (temporary) of length NEQ.
5070 C     WM       = Real work space for matrices.  On output
5071 C                it contains the LU decomposition
5072 C                of the iteration matrix.
5073 C     IWM      = Integer work space containing
5074 C                matrix information.
5075 C     RES      = External user-supplied subroutine
5076 C                to evaluate the residual.  See RES description
5077 C                in DDASPK prologue.
5078 C     IRES     = Flag which is equal to zero if no illegal values
5079 C                in RES, and less than zero otherwise.  (If IRES
5080 C                is less than zero, the matrix was not completed).
5081 C                In this case (if IRES .LT. 0), then IER = 0.
5082 C     UROUND   = The unit roundoff error of the machine being used.
5083 C     JACD     = Name of the external user-supplied routine
5084 C                to evaluate the iteration matrix.  (This routine
5085 C                is only used if IWM(MTYPE) is 1 or 4)
5086 C                See JAC description for the case INFO(12) = 0
5087 C                in DDASPK prologue.
5088 C     RPAR,IPAR= Real and integer parameter arrays that
5089 C                are used for communication between the
5090 C                calling program and external user routines.
5091 C                They are not altered by DMATD.
5092 C-----------------------------------------------------------------------
5093 C***ROUTINES CALLED
5094 C   JACD, RES, DGEFA, DGBFA
5095 C
5096 C***END PROLOGUE  DMATD
5097 C
5098 C
5099       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
5100       DIMENSION Y(*),YPRIME(*),DELTA(*),EWT(*),E(*)
5101       DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*)
5102       EXTERNAL  RES, JACD
5103 C
5104       PARAMETER (LML=1, LMU=2, LMTYPE=4, LNRE=12, LNPD=22, LLCIWP=30)
5105 C
5106       LIPVT = IWM(LLCIWP)
5107       IER = 0
5108       MTYPE=IWM(LMTYPE)
5109       GO TO (100,200,300,400,500),MTYPE
5110 C
5111 C
5112 C     Dense user-supplied matrix.
5113 C
5114 100   LENPD=IWM(LNPD)
5115       DO 110 I=1,LENPD
5116 110      WM(I)=0.0D0
5117       CALL JACD(X,Y,YPRIME,WM,CJ,RPAR,IPAR)
5118       GO TO 230
5119 C
5120 C
5121 C     Dense finite-difference-generated matrix.
5122 C
5123 200   IRES=0
5124       NROW=0
5125       SQUR = SQRT(UROUND)
5126       DO 210 I=1,NEQ
5127          DEL=MAX(SQUR*MAX(ABS(Y(I)),ABS(H*YPRIME(I))), 1.0D0/EWT(I))
5128          DEL=SIGN(DEL,H*YPRIME(I))
5129          DEL=(Y(I)+DEL)-Y(I)
5130          YSAVE=Y(I)
5131          YPSAVE=YPRIME(I)
5132          Y(I)=Y(I)+DEL
5133          YPRIME(I)=YPRIME(I)+CJ*DEL
5134          IWM(LNRE)=IWM(LNRE)+1
5135          CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR)
5136          IF (IRES .LT. 0) RETURN
5137          DELINV=1.0D0/DEL
5138          DO 220 L=1,NEQ
5139 220        WM(NROW+L)=(E(L)-DELTA(L))*DELINV
5140       NROW=NROW+NEQ
5141       Y(I)=YSAVE
5142       YPRIME(I)=YPSAVE
5143 210   CONTINUE
5144 C
5145 C
5146 C     Do dense-matrix LU decomposition on J.
5147 C
5148 230      CALL DGEFA(WM,NEQ,NEQ,IWM(LIPVT),IER)
5149       RETURN
5150 C
5151 C
5152 C     Dummy section for IWM(MTYPE)=3.
5153 C
5154 300   RETURN
5155 C
5156 C
5157 C     Banded user-supplied matrix.
5158 C
5159 400   LENPD=IWM(LNPD)
5160       DO 410 I=1,LENPD
5161 410      WM(I)=0.0D0
5162       CALL JACD(X,Y,YPRIME,WM,CJ,RPAR,IPAR)
5163       MEBAND=2*IWM(LML)+IWM(LMU)+1
5164       GO TO 550
5165 C
5166 C
5167 C     Banded finite-difference-generated matrix.
5168 C
5169 500   MBAND=IWM(LML)+IWM(LMU)+1
5170       MBA=MIN0(MBAND,NEQ)
5171       MEBAND=MBAND+IWM(LML)
5172       MEB1=MEBAND-1
5173       MSAVE=(NEQ/MBAND)+1
5174       ISAVE=IWM(LNPD)
5175       IPSAVE=ISAVE+MSAVE
5176       IRES=0
5177       SQUR=SQRT(UROUND)
5178       DO 540 J=1,MBA
5179         DO 510 N=J,NEQ,MBAND
5180           K= (N-J)/MBAND + 1
5181           WM(ISAVE+K)=Y(N)
5182           WM(IPSAVE+K)=YPRIME(N)
5183           DEL=MAX(SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N))), 1.0D0/EWT(N))
5184           DEL=SIGN(DEL,H*YPRIME(N))
5185           DEL=(Y(N)+DEL)-Y(N)
5186           Y(N)=Y(N)+DEL
5187 510       YPRIME(N)=YPRIME(N)+CJ*DEL
5188         IWM(LNRE)=IWM(LNRE)+1
5189         CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR)
5190         IF (IRES .LT. 0) RETURN
5191         DO 530 N=J,NEQ,MBAND
5192           K= (N-J)/MBAND + 1
5193           Y(N)=WM(ISAVE+K)
5194           YPRIME(N)=WM(IPSAVE+K)
5195           DEL=MAX(SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N))), 1.0D0/EWT(N))
5196           DEL=SIGN(DEL,H*YPRIME(N))
5197           DEL=(Y(N)+DEL)-Y(N)
5198           DELINV=1.0D0/DEL
5199           I1=MAX0(1,(N-IWM(LMU)))
5200           I2=MIN0(NEQ,(N+IWM(LML)))
5201           II=N*MEB1-IWM(LML)
5202           DO 520 I=I1,I2
5203 520         WM(II+I)=(E(I)-DELTA(I))*DELINV
5204 530     CONTINUE
5205 540   CONTINUE
5206 C
5207 C
5208 C     Do LU decomposition of banded J.
5209 C
5210 550   CALL DGBFA (WM,MEBAND,NEQ,IWM(LML),IWM(LMU),IWM(LIPVT),IER)
5211       RETURN
5212 C
5213 C------END OF SUBROUTINE DMATD------------------------------------------
5214       END
5215       SUBROUTINE DSLVD(NEQ,DELTA,WM,IWM)
5216 C
5217 C***BEGIN PROLOGUE  DSLVD
5218 C***REFER TO  DDASPK
5219 C***DATE WRITTEN   890101   (YYMMDD)
5220 C***REVISION DATE  900926   (YYMMDD)
5221 C***REVISION DATE  940701   (YYMMDD) (new LIPVT)
5222 C
5223 C-----------------------------------------------------------------------
5224 C***DESCRIPTION
5225 C
5226 C     This routine manages the solution of the linear
5227 C     system arising in the Newton iteration.
5228 C     Real matrix information and real temporary storage
5229 C     is stored in the array WM.
5230 C     Integer matrix information is stored in the array IWM.
5231 C     For a dense matrix, the LINPACK routine DGESL is called.
5232 C     For a banded matrix, the LINPACK routine DGBSL is called.
5233 C-----------------------------------------------------------------------
5234 C***ROUTINES CALLED
5235 C   DGESL, DGBSL
5236 C
5237 C***END PROLOGUE  DSLVD
5238 C
5239 C
5240       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
5241       DIMENSION DELTA(*),WM(*),IWM(*)
5242 C
5243       PARAMETER (LML=1, LMU=2, LMTYPE=4, LLCIWP=30)
5244 C
5245       LIPVT = IWM(LLCIWP)
5246       MTYPE=IWM(LMTYPE)
5247       GO TO(100,100,300,400,400),MTYPE
5248 C
5249 C     Dense matrix.
5250 C
5251 100   CALL DGESL(WM,NEQ,NEQ,IWM(LIPVT),DELTA,0)
5252       RETURN
5253 C
5254 C     Dummy section for MTYPE=3.
5255 C
5256 300   CONTINUE
5257       RETURN
5258 C
5259 C     Banded matrix.
5260 C
5261 400   MEBAND=2*IWM(LML)+IWM(LMU)+1
5262       CALL DGBSL(WM,MEBAND,NEQ,IWM(LML),
5263      *  IWM(LMU),IWM(LIPVT),DELTA,0)
5264       RETURN
5265 C
5266 C------END OF SUBROUTINE DSLVD------------------------------------------
5267       END
5268       SUBROUTINE DDASIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JACK,PSOL,H,TSCALE,
5269      *   WT,JSKIP,RPAR,IPAR,SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,UROUND,
5270      *   EPLI,SQRTN,RSQRTN,EPCON,RATEMX,STPTOL,JFLG,
5271      *   ICNFLG,ICNSTR,IERNLS)
5272 C
5273 C***BEGIN PROLOGUE  DDASIK
5274 C***REFER TO  DDASPK
5275 C***DATE WRITTEN   941026   (YYMMDD)
5276 C***REVISION DATE  950808   (YYMMDD)
5277 C***REVISION DATE  951110   Removed unreachable block 390.
5278 C***REVISION DATE  000628   TSCALE argument added.
5279 C
5280 C
5281 C-----------------------------------------------------------------------
5282 C***DESCRIPTION
5283 C
5284 C
5285 C     DDASIK solves a nonlinear system of algebraic equations of the
5286 C     form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in
5287 C     the initial conditions.
5288 C
5289 C     An initial value for Y and initial guess for YPRIME are input.
5290 C
5291 C     The method used is a Newton scheme with Krylov iteration and a
5292 C     linesearch algorithm.
5293 C
5294 C     The parameters represent
5295 C
5296 C     X         -- Independent variable.
5297 C     Y         -- Solution vector at x.
5298 C     YPRIME    -- Derivative of solution vector.
5299 C     NEQ       -- Number of equations to be integrated.
5300 C     ICOPT     -- Initial condition option chosen (1 or 2).
5301 C     ID        -- Array of dimension NEQ, which must be initialized
5302 C                  if ICOPT = 1.  See DDASIC.
5303 C     RES       -- External user-supplied subroutine
5304 C                  to evaluate the residual.  See RES description
5305 C                  in DDASPK prologue.
5306 C     JACK     --  External user-supplied routine to update
5307 C                  the preconditioner.  (This is optional).
5308 C                  See JAC description for the case
5309 C                  INFO(12) = 1 in the DDASPK prologue.
5310 C     PSOL      -- External user-supplied routine to solve
5311 C                  a linear system using preconditioning.
5312 C                  (This is optional).  See explanation inside DDASPK.
5313 C     H         -- Scaling factor for this initial condition calc.
5314 C     TSCALE    -- Scale factor in T, used for stopping tests if nonzero.
5315 C     WT        -- Vector of weights for error criterion.
5316 C     JSKIP     -- input flag to signal if initial JAC call is to be
5317 C                  skipped.  1 => skip the call, 0 => do not skip call.
5318 C     RPAR,IPAR -- Real and integer arrays used for communication
5319 C                  between the calling program and external user
5320 C                  routines.  They are not altered within DASPK.
5321 C     SAVR      -- Work vector for DDASIK of length NEQ.
5322 C     DELTA     -- Work vector for DDASIK of length NEQ.
5323 C     R         -- Work vector for DDASIK of length NEQ.
5324 C     YIC,YPIC  -- Work vectors for DDASIK, each of length NEQ.
5325 C     PWK       -- Work vector for DDASIK of length NEQ.
5326 C     WM,IWM    -- Real and integer arrays storing
5327 C                  matrix information for linear system
5328 C                  solvers, and various other information.
5329 C     CJ        -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2).
5330 C     UROUND    -- Unit roundoff.  Not used here.
5331 C     EPLI      -- convergence test constant.
5332 C                  See DDASPK prologue for more details.
5333 C     SQRTN     -- Square root of NEQ.
5334 C     RSQRTN    -- reciprical of square root of NEQ.
5335 C     EPCON     -- Tolerance to test for convergence of the Newton
5336 C                  iteration.
5337 C     RATEMX    -- Maximum convergence rate for which Newton iteration
5338 C                  is considered converging.
5339 C     JFLG      -- Flag showing whether a Jacobian routine is supplied.
5340 C     ICNFLG    -- Integer scalar.  If nonzero, then constraint
5341 C                  violations in the proposed new approximate solution
5342 C                  will be checked for, and the maximum step length 
5343 C                  will be adjusted accordingly.
5344 C     ICNSTR    -- Integer array of length NEQ containing flags for
5345 C                  checking constraints.
5346 C     IERNLS    -- Error flag for nonlinear solver.
5347 C                   0   ==> nonlinear solver converged.
5348 C                   1,2 ==> recoverable error inside nonlinear solver.
5349 C                           1 => retry with current Y, YPRIME
5350 C                           2 => retry with original Y, YPRIME
5351 C                  -1   ==> unrecoverable error in nonlinear solver.
5352 C
5353 C-----------------------------------------------------------------------
5354 C
5355 C***ROUTINES CALLED
5356 C   RES, JACK, DNSIK, DCOPY
5357 C
5358 C***END PROLOGUE  DDASIK
5359 C
5360 C
5361       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
5362       DIMENSION Y(*),YPRIME(*),ID(*),WT(*),ICNSTR(*)
5363       DIMENSION SAVR(*),DELTA(*),R(*),YIC(*),YPIC(*),PWK(*)
5364       DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*)
5365       EXTERNAL RES, JACK, PSOL
5366 C
5367       PARAMETER (LNRE=12, LNJE=13, LLOCWP=29, LLCIWP=30)
5368       PARAMETER (LMXNIT=32, LMXNJ=33)
5369 C
5370 C
5371 C     Perform initializations.
5372 C
5373       LWP = IWM(LLOCWP)
5374       LIWP = IWM(LLCIWP)
5375       MXNIT = IWM(LMXNIT)
5376       MXNJ = IWM(LMXNJ)
5377       IERNLS = 0
5378       NJ = 0
5379       EPLIN = EPLI*EPCON
5380 C
5381 C     Call RES to initialize DELTA.
5382 C
5383       IRES = 0
5384       IWM(LNRE) = IWM(LNRE) + 1
5385       CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
5386       IF (IRES .LT. 0) GO TO 370
5387 C
5388 C     Looping point for updating the preconditioner.
5389 C
5390  300  CONTINUE
5391 C
5392 C     Initialize all error flags to zero.
5393 C
5394       IERPJ = 0
5395       IRES = 0
5396       IERNEW = 0
5397 C
5398 C     If a Jacobian routine was supplied, call it.
5399 C
5400       IF (JFLG .EQ. 1 .AND. JSKIP .EQ. 0) THEN
5401         NJ = NJ + 1
5402         IWM(LNJE)=IWM(LNJE)+1
5403         CALL JACK (RES, IRES, NEQ, X, Y, YPRIME, WT, DELTA, R, H, CJ,
5404      *     WM(LWP), IWM(LIWP), IERPJ, RPAR, IPAR)
5405         IF (IRES .LT. 0 .OR. IERPJ .NE. 0) GO TO 370
5406         ENDIF
5407       JSKIP = 0
5408 C
5409 C     Call the nonlinear Newton solver for up to MXNIT iterations.
5410 C
5411       CALL DNSIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,PSOL,WT,RPAR,IPAR,
5412      *   SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,TSCALE,SQRTN,RSQRTN,
5413      *   EPLIN,EPCON,RATEMX,MXNIT,STPTOL,ICNFLG,ICNSTR,IERNEW)
5414 C
5415       IF (IERNEW .EQ. 1 .AND. NJ .LT. MXNJ .AND. JFLG .EQ. 1) THEN
5416 C
5417 C       Up to MXNIT iterations were done, the convergence rate is < 1,
5418 C       a Jacobian routine is supplied, and the number of JACK calls
5419 C       is less than MXNJ.  
5420 C       Copy the residual SAVR to DELTA, call JACK, and try again.
5421 C
5422         CALL DCOPY (NEQ,  SAVR, 1, DELTA, 1)
5423         GO TO 300
5424         ENDIF
5425 C
5426       IF (IERNEW .NE. 0) GO TO 380
5427       RETURN
5428 C
5429 C
5430 C     Unsuccessful exits from nonlinear solver.
5431 C     Set IERNLS accordingly.
5432 C
5433  370  IERNLS = 2
5434       IF (IRES .LE. -2) IERNLS = -1
5435       RETURN
5436 C
5437  380  IERNLS = MIN(IERNEW,2)
5438       RETURN
5439 C
5440 C----------------------- END OF SUBROUTINE DDASIK-----------------------
5441       END
5442       SUBROUTINE DNSIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,PSOL,WT,RPAR,IPAR,
5443      *   SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,TSCALE,SQRTN,RSQRTN,EPLIN,
5444      *   EPCON,RATEMX,MAXIT,STPTOL,ICNFLG,ICNSTR,IERNEW)
5445 C
5446 C***BEGIN PROLOGUE  DNSIK
5447 C***REFER TO  DDASPK
5448 C***DATE WRITTEN   940701   (YYMMDD)
5449 C***REVISION DATE  950714   (YYMMDD)
5450 C***REVISION DATE  000628   TSCALE argument added.
5451 C***REVISION DATE  000628   Added criterion for IERNEW = 1 return.
5452 C
5453 C
5454 C-----------------------------------------------------------------------
5455 C***DESCRIPTION
5456 C
5457 C     DNSIK solves a nonlinear system of algebraic equations of the
5458 C     form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in
5459 C     the initial conditions.
5460 C
5461 C     The method used is a Newton scheme combined with a linesearch
5462 C     algorithm, using Krylov iterative linear system methods.
5463 C
5464 C     The parameters represent
5465 C
5466 C     X         -- Independent variable.
5467 C     Y         -- Solution vector.
5468 C     YPRIME    -- Derivative of solution vector.
5469 C     NEQ       -- Number of unknowns.
5470 C     ICOPT     -- Initial condition option chosen (1 or 2).
5471 C     ID        -- Array of dimension NEQ, which must be initialized
5472 C                  if ICOPT = 1.  See DDASIC.
5473 C     RES       -- External user-supplied subroutine
5474 C                  to evaluate the residual.  See RES description
5475 C                  in DDASPK prologue.
5476 C     PSOL      -- External user-supplied routine to solve
5477 C                  a linear system using preconditioning. 
5478 C                  See explanation inside DDASPK.
5479 C     WT        -- Vector of weights for error criterion.
5480 C     RPAR,IPAR -- Real and integer arrays used for communication
5481 C                  between the calling program and external user
5482 C                  routines.  They are not altered within DASPK.
5483 C     SAVR      -- Work vector for DNSIK of length NEQ.
5484 C     DELTA     -- Residual vector on entry, and work vector of
5485 C                  length NEQ for DNSIK.
5486 C     R         -- Work vector for DNSIK of length NEQ.
5487 C     YIC,YPIC  -- Work vectors for DNSIK, each of length NEQ.
5488 C     PWK       -- Work vector for DNSIK of length NEQ.
5489 C     WM,IWM    -- Real and integer arrays storing
5490 C                  matrix information such as the matrix
5491 C                  of partial derivatives, permutation
5492 C                  vector, and various other information.
5493 C     CJ        -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2).
5494 C     TSCALE    -- Scale factor in T, used for stopping tests if nonzero.
5495 C     SQRTN     -- Square root of NEQ.
5496 C     RSQRTN    -- reciprical of square root of NEQ.
5497 C     EPLIN     -- Tolerance for linear system solver.
5498 C     EPCON     -- Tolerance to test for convergence of the Newton
5499 C                  iteration.
5500 C     RATEMX    -- Maximum convergence rate for which Newton iteration
5501 C                  is considered converging.
5502 C     MAXIT     -- Maximum allowed number of Newton iterations.
5503 C     STPTOL    -- Tolerance used in calculating the minimum lambda
5504 C                  value allowed.
5505 C     ICNFLG    -- Integer scalar.  If nonzero, then constraint
5506 C                  violations in the proposed new approximate solution
5507 C                  will be checked for, and the maximum step length
5508 C                  will be adjusted accordingly.
5509 C     ICNSTR    -- Integer array of length NEQ containing flags for
5510 C                  checking constraints.
5511 C     IERNEW    -- Error flag for Newton iteration.
5512 C                   0  ==> Newton iteration converged.
5513 C                   1  ==> failed to converge, but RATE .lt. 1, or the
5514 C                          residual norm was reduced by a factor of .1.
5515 C                   2  ==> failed to converge, RATE .gt. RATEMX.
5516 C                   3  ==> other recoverable error.
5517 C                  -1  ==> unrecoverable error inside Newton iteration.
5518 C-----------------------------------------------------------------------
5519 C
5520 C***ROUTINES CALLED
5521 C   DFNRMK, DSLVK, DDWNRM, DLINSK, DCOPY
5522 C
5523 C***END PROLOGUE  DNSIK
5524 C
5525 C
5526       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
5527       DIMENSION Y(*),YPRIME(*),WT(*),ID(*),DELTA(*),R(*),SAVR(*)
5528       DIMENSION YIC(*),YPIC(*),PWK(*),WM(*),IWM(*), RPAR(*),IPAR(*)
5529       DIMENSION ICNSTR(*)
5530       EXTERNAL RES, PSOL
5531 C
5532       PARAMETER (LNNI=19, LNPS=21, LLOCWP=29, LLCIWP=30)
5533       PARAMETER (LLSOFF=35, LSTOL=14)
5534 C
5535 C
5536 C     Initializations.  M is the Newton iteration counter.
5537 C
5538       LSOFF = IWM(LLSOFF)
5539       M = 0
5540       RATE = 1.0D0
5541       LWP = IWM(LLOCWP)
5542       LIWP = IWM(LLCIWP)
5543       RLX = 0.4D0
5544 C
5545 C     Save residual in SAVR.
5546 C
5547       CALL DCOPY (NEQ, DELTA, 1, SAVR, 1)
5548 C
5549 C     Compute norm of (P-inverse)*(residual).
5550 C
5551       CALL DFNRMK (NEQ, Y, X, YPRIME, SAVR, R, CJ, TSCALE, WT,
5552      *   SQRTN, RSQRTN, RES, IRES, PSOL, 1, IER, FNRM, EPLIN,
5553      *   WM(LWP), IWM(LIWP), PWK, RPAR, IPAR)
5554       IWM(LNPS) = IWM(LNPS) + 1
5555       IF (IER .NE. 0) THEN
5556         IERNEW = 3
5557         RETURN
5558       ENDIF
5559 C
5560 C     Return now if residual norm is .le. EPCON.
5561 C
5562       IF (FNRM .LE. EPCON) RETURN
5563 C
5564 C     Newton iteration loop.
5565 C
5566       FNRM0 = FNRM
5567 300   CONTINUE
5568       IWM(LNNI) = IWM(LNNI) + 1
5569 C
5570 C     Compute a new step vector DELTA.
5571 C
5572       CALL DSLVK (NEQ, Y, X, YPRIME, SAVR, DELTA, WT, WM, IWM,
5573      *   RES, IRES, PSOL, IERSL, CJ, EPLIN, SQRTN, RSQRTN, RHOK,
5574      *   RPAR, IPAR)
5575       IF (IRES .NE. 0 .OR. IERSL .NE. 0) GO TO 390
5576 C
5577 C     Get norm of DELTA.  Return now if DELTA is zero.
5578 C
5579       DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR)
5580       IF (DELNRM .EQ. 0.0D0) RETURN
5581 C
5582 C     Call linesearch routine for global strategy and set RATE.
5583 C
5584       OLDFNM = FNRM
5585 C
5586       CALL DLINSK (NEQ, Y, X, YPRIME, SAVR, CJ, TSCALE, DELTA, DELNRM,
5587      *   WT, SQRTN, RSQRTN, LSOFF, STPTOL, IRET, RES, IRES, PSOL,
5588      *   WM, IWM, RHOK, FNRM, ICOPT, ID, WM(LWP), IWM(LIWP), R, EPLIN,
5589      *   YIC, YPIC, PWK, ICNFLG, ICNSTR, RLX, RPAR, IPAR)
5590 C
5591       RATE = FNRM/OLDFNM
5592 C
5593 C     Check for error condition from linesearch.
5594       IF (IRET .NE. 0) GO TO 390
5595 C
5596 C     Test for convergence of the iteration, and return or loop.
5597 C
5598       IF (FNRM .LE. EPCON) RETURN
5599 C
5600 C     The iteration has not yet converged.  Update M.
5601 C     Test whether the maximum number of iterations have been tried.
5602 C
5603       M = M + 1
5604       IF(M .GE. MAXIT) GO TO 380
5605 C
5606 C     Copy the residual SAVR to DELTA and loop for another iteration.
5607 C
5608       CALL DCOPY (NEQ,  SAVR, 1, DELTA, 1)
5609       GO TO 300
5610 C
5611 C     The maximum number of iterations was done.  Set IERNEW and return.
5612 C
5613 380   IF (RATE .LE. RATEMX .OR. FNRM .LE. 0.1D0*FNRM0) THEN
5614          IERNEW = 1
5615       ELSE
5616          IERNEW = 2
5617       ENDIF
5618       RETURN
5619 C
5620 390   IF (IRES .LE. -2 .OR. IERSL .LT. 0) THEN
5621          IERNEW = -1
5622       ELSE
5623          IERNEW = 3
5624          IF (IRES .EQ. 0 .AND. IERSL .EQ. 1 .AND. M .GE. 2 
5625      1       .AND. RATE .LT. 1.0D0) IERNEW = 1
5626       ENDIF
5627       RETURN
5628 C
5629 C
5630 C----------------------- END OF SUBROUTINE DNSIK------------------------
5631       END
5632       SUBROUTINE DLINSK (NEQ, Y, T, YPRIME, SAVR, CJ, TSCALE, P, PNRM,
5633      *   WT, SQRTN, RSQRTN, LSOFF, STPTOL, IRET, RES, IRES, PSOL,
5634      *   WM, IWM, RHOK, FNRM, ICOPT, ID, WP, IWP, R, EPLIN, YNEW, YPNEW,
5635      *   PWK, ICNFLG, ICNSTR, RLX, RPAR, IPAR)
5636 C
5637 C***BEGIN PROLOGUE  DLINSK
5638 C***REFER TO  DNSIK
5639 C***DATE WRITTEN   940830   (YYMMDD)
5640 C***REVISION DATE  951006   (Arguments SQRTN, RSQRTN added.)
5641 C***REVISION DATE  960129   Moved line RL = ONE to top block.
5642 C***REVISION DATE  000628   TSCALE argument added.
5643 C***REVISION DATE  000628   RHOK*RHOK term removed in alpha test.
5644 C
5645 C
5646 C-----------------------------------------------------------------------
5647 C***DESCRIPTION
5648 C
5649 C     DLINSK uses a linesearch algorithm to calculate a new (Y,YPRIME)
5650 C     pair (YNEW,YPNEW) such that 
5651 C
5652 C     f(YNEW,YPNEW) .le. (1 - 2*ALPHA*RL)*f(Y,YPRIME)
5653 C
5654 C     where 0 < RL <= 1, and RHOK is the scaled preconditioned norm of
5655 C     the final residual vector in the Krylov iteration.  
5656 C     Here, f(y,y') is defined as
5657 C
5658 C      f(y,y') = (1/2)*norm( (P-inverse)*G(t,y,y') )**2 ,
5659 C
5660 C     where norm() is the weighted RMS vector norm, G is the DAE
5661 C     system residual function, and P is the preconditioner used
5662 C     in the Krylov iteration.
5663 C
5664 C     In addition to the parameters defined elsewhere, we have
5665 C
5666 C     SAVR    -- Work array of length NEQ, containing the residual
5667 C                vector G(t,y,y') on return.
5668 C     TSCALE  -- Scale factor in T, used for stopping tests if nonzero.
5669 C     P       -- Approximate Newton step used in backtracking.
5670 C     PNRM    -- Weighted RMS norm of P.
5671 C     LSOFF   -- Flag showing whether the linesearch algorithm is
5672 C                to be invoked.  0 means do the linesearch, 
5673 C                1 means turn off linesearch.
5674 C     STPTOL  -- Tolerance used in calculating the minimum lambda
5675 C                value allowed.
5676 C     ICNFLG  -- Integer scalar.  If nonzero, then constraint violations
5677 C                in the proposed new approximate solution will be
5678 C                checked for, and the maximum step length will be
5679 C                adjusted accordingly.
5680 C     ICNSTR  -- Integer array of length NEQ containing flags for
5681 C                checking constraints.
5682 C     RHOK    -- Weighted norm of preconditioned Krylov residual.
5683 C     RLX     -- Real scalar restricting update size in DCNSTR.
5684 C     YNEW    -- Array of length NEQ used to hold the new Y in
5685 C                performing the linesearch.
5686 C     YPNEW   -- Array of length NEQ used to hold the new YPRIME in
5687 C                performing the linesearch.
5688 C     PWK     -- Work vector of length NEQ for use in PSOL.
5689 C     Y       -- Array of length NEQ containing the new Y (i.e.,=YNEW).
5690 C     YPRIME  -- Array of length NEQ containing the new YPRIME 
5691 C                (i.e.,=YPNEW).
5692 C     FNRM    -- Real scalar containing SQRT(2*f(Y,YPRIME)) for the
5693 C                current (Y,YPRIME) on input and output.
5694 C     R       -- Work space length NEQ for residual vector.
5695 C     IRET    -- Return flag.
5696 C                IRET=0 means that a satisfactory (Y,YPRIME) was found.
5697 C                IRET=1 means that the routine failed to find a new
5698 C                       (Y,YPRIME) that was sufficiently distinct from
5699 C                       the current (Y,YPRIME) pair.
5700 C                IRET=2 means a failure in RES or PSOL.
5701 C-----------------------------------------------------------------------
5702 C
5703 C***ROUTINES CALLED
5704 C   DFNRMK, DYYPNW, DCNSTR, DCOPY, XERRWD
5705 C
5706 C***END PROLOGUE  DLINSK
5707 C
5708       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
5709       EXTERNAL  RES, PSOL
5710       DIMENSION Y(*), YPRIME(*), P(*), WT(*), SAVR(*), R(*), ID(*)
5711       DIMENSION WM(*), IWM(*), YNEW(*), YPNEW(*), PWK(*), ICNSTR(*)
5712       DIMENSION WP(*), IWP(*), RPAR(*), IPAR(*)
5713       CHARACTER MSG*80
5714 C
5715       PARAMETER (LNRE=12, LNPS=21, LKPRIN=31)
5716 C
5717       SAVE ALPHA, ONE, TWO
5718       DATA ALPHA/1.0D-4/, ONE/1.0D0/, TWO/2.0D0/
5719 C
5720       KPRIN=IWM(LKPRIN)
5721       F1NRM = (FNRM*FNRM)/TWO
5722       RATIO = ONE
5723 C
5724       IF (KPRIN .GE. 2) THEN
5725         MSG = '------ IN ROUTINE DLINSK-- PNRM = (R1)'
5726         CALL XERRWD(MSG, 38, 921, 0, 0, 0, 0, 1, PNRM, 0.0D0)
5727         ENDIF
5728       TAU = PNRM
5729       RL = ONE
5730 C-----------------------------------------------------------------------
5731 C Check for violations of the constraints, if any are imposed.
5732 C If any violations are found, the step vector P is rescaled, and the 
5733 C constraint check is repeated, until no violations are found.
5734 C-----------------------------------------------------------------------
5735       IF (ICNFLG .NE. 0) THEN
5736  10      CONTINUE
5737          CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW)
5738          CALL DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR)
5739          IF (IRET .EQ. 1) THEN
5740             RATIO1 = TAU/PNRM
5741             RATIO = RATIO*RATIO1
5742             DO 20 I = 1,NEQ
5743  20           P(I) = P(I)*RATIO1
5744             PNRM = TAU
5745             IF (KPRIN .GE. 2) THEN
5746               MSG = '------ CONSTRAINT VIOL., PNRM = (R1), INDEX = (I1)'
5747               CALL XERRWD(MSG, 50, 922, 0, 1, IVAR, 0, 1, PNRM, 0.0D0)
5748               ENDIF
5749             IF (PNRM .LE. STPTOL) THEN
5750               IRET = 1
5751               RETURN
5752               ENDIF
5753             GO TO 10
5754             ENDIF
5755          ENDIF
5756 C
5757       SLPI = -TWO*F1NRM*RATIO
5758       RLMIN = STPTOL/PNRM
5759       IF (LSOFF .EQ. 0 .AND. KPRIN .GE. 2) THEN
5760         MSG = '------ MIN. LAMBDA = (R1)'
5761         CALL XERRWD(MSG, 25, 923, 0, 0, 0, 0, 1, RLMIN, 0.0D0)
5762         ENDIF
5763 C-----------------------------------------------------------------------
5764 C Begin iteration to find RL value satisfying alpha-condition.
5765 C Update YNEW and YPNEW, then compute norm of new scaled residual and
5766 C perform alpha condition test.
5767 C-----------------------------------------------------------------------
5768  100  CONTINUE
5769       CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW)
5770       CALL DFNRMK (NEQ, YNEW, T, YPNEW, SAVR, R, CJ, TSCALE, WT,
5771      *   SQRTN, RSQRTN, RES, IRES, PSOL, 0, IER, FNRMP, EPLIN,
5772      *   WP, IWP, PWK, RPAR, IPAR)
5773       IWM(LNRE) = IWM(LNRE) + 1
5774       IF (IRES .GE. 0) IWM(LNPS) = IWM(LNPS) + 1
5775       IF (IRES .NE. 0 .OR. IER .NE. 0) THEN
5776         IRET = 2
5777         RETURN
5778         ENDIF
5779       IF (LSOFF .EQ. 1) GO TO 150
5780 C
5781       F1NRMP = FNRMP*FNRMP/TWO
5782       IF (KPRIN .GE. 2) THEN
5783         MSG = '------ LAMBDA = (R1)'
5784         CALL XERRWD(MSG, 20, 924, 0, 0, 0, 0, 1, RL, 0.0D0)
5785         MSG = '------ NORM(F1) = (R1),  NORM(F1NEW) = (R2)'
5786         CALL XERRWD(MSG, 43, 925, 0, 0, 0, 0, 2, F1NRM, F1NRMP)
5787         ENDIF
5788       IF (F1NRMP .GT. F1NRM + ALPHA*SLPI*RL) GO TO 200
5789 C-----------------------------------------------------------------------
5790 C Alpha-condition is satisfied, or linesearch is turned off.
5791 C Copy YNEW,YPNEW to Y,YPRIME and return.
5792 C-----------------------------------------------------------------------
5793  150  IRET = 0
5794       CALL DCOPY(NEQ, YNEW, 1, Y, 1)
5795       CALL DCOPY(NEQ, YPNEW, 1, YPRIME, 1)
5796       FNRM = FNRMP
5797       IF (KPRIN .GE. 1) THEN
5798         MSG = '------ LEAVING ROUTINE DLINSK, FNRM = (R1)'
5799         CALL XERRWD(MSG, 42, 926, 0, 0, 0, 0, 1, FNRM, 0.0D0)
5800         ENDIF
5801       RETURN
5802 C-----------------------------------------------------------------------
5803 C Alpha-condition not satisfied.  Perform backtrack to compute new RL
5804 C value.  If RL is less than RLMIN, i.e. no satisfactory YNEW,YPNEW can
5805 C be found sufficiently distinct from Y,YPRIME, then return IRET = 1.
5806 C-----------------------------------------------------------------------
5807  200  CONTINUE
5808       IF (RL .LT. RLMIN) THEN
5809         IRET = 1
5810         RETURN
5811         ENDIF
5812 C
5813       RL = RL/TWO
5814       GO TO 100
5815 C
5816 C----------------------- END OF SUBROUTINE DLINSK ----------------------
5817       END
5818       SUBROUTINE DFNRMK (NEQ, Y, T, YPRIME, SAVR, R, CJ, TSCALE, WT,
5819      *                   SQRTN, RSQRTN, RES, IRES, PSOL, IRIN, IER,
5820      *                   FNORM, EPLIN, WP, IWP, PWK, RPAR, IPAR)
5821 C
5822 C***BEGIN PROLOGUE  DFNRMK
5823 C***REFER TO  DLINSK
5824 C***DATE WRITTEN   940830   (YYMMDD)
5825 C***REVISION DATE  951006   (SQRTN, RSQRTN, and scaling of WT added.)
5826 C***REVISION DATE  000628   TSCALE argument added.
5827 C
5828 C
5829 C-----------------------------------------------------------------------
5830 C***DESCRIPTION
5831 C
5832 C     DFNRMK calculates the scaled preconditioned norm of the nonlinear
5833 C     function used in the nonlinear iteration for obtaining consistent
5834 C     initial conditions.  Specifically, DFNRMK calculates the weighted
5835 C     root-mean-square norm of the vector (P-inverse)*G(T,Y,YPRIME),
5836 C     where P is the preconditioner matrix.
5837 C
5838 C     In addition to the parameters described in the calling program
5839 C     DLINSK, the parameters represent
5840 C
5841 C     TSCALE -- Scale factor in T, used for stopping tests if nonzero.
5842 C     IRIN   -- Flag showing whether the current residual vector is
5843 C               input in SAVR.  1 means it is, 0 means it is not.
5844 C     R      -- Array of length NEQ that contains
5845 C               (P-inverse)*G(T,Y,YPRIME) on return.
5846 C     FNORM  -- Scalar containing the weighted norm of R on return.
5847 C-----------------------------------------------------------------------
5848 C
5849 C***ROUTINES CALLED
5850 C   RES, DCOPY, DSCAL, PSOL, DDWNRM
5851 C
5852 C***END PROLOGUE  DFNRMK
5853 C
5854 C
5855       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5856       EXTERNAL RES, PSOL
5857       DIMENSION Y(*), YPRIME(*), WT(*), SAVR(*), R(*), PWK(*)
5858       DIMENSION WP(*), IWP(*), RPAR(*), IPAR(*)
5859 C-----------------------------------------------------------------------
5860 C     Call RES routine if IRIN = 0.
5861 C-----------------------------------------------------------------------
5862       IF (IRIN .EQ. 0) THEN
5863         IRES = 0
5864         CALL RES (T, Y, YPRIME, SAVR, IRES, RPAR, IPAR)
5865         IF (IRES .LT. 0) RETURN
5866         ENDIF
5867 C-----------------------------------------------------------------------
5868 C     Apply inverse of left preconditioner to vector R.
5869 C     First scale WT array by 1/sqrt(N), and undo scaling afterward.
5870 C-----------------------------------------------------------------------
5871       CALL DCOPY(NEQ, SAVR, 1, R, 1)
5872       CALL DSCAL (NEQ, RSQRTN, WT, 1)
5873       IER = 0
5874       CALL PSOL (NEQ, T, Y, YPRIME, SAVR, PWK, CJ, WT, WP, IWP,
5875      *           R, EPLIN, IER, RPAR, IPAR)
5876       CALL DSCAL (NEQ, SQRTN, WT, 1)
5877       IF (IER .NE. 0) RETURN
5878 C-----------------------------------------------------------------------
5879 C     Calculate norm of R.
5880 C-----------------------------------------------------------------------
5881       FNORM = DDWNRM (NEQ, R, WT, RPAR, IPAR)
5882       IF (TSCALE .GT. 0.0D0) FNORM = FNORM*TSCALE*ABS(CJ)
5883 C
5884       RETURN
5885 C----------------------- END OF SUBROUTINE DFNRMK ----------------------
5886       END
5887       SUBROUTINE DNEDK(X,Y,YPRIME,NEQ,RES,JACK,PSOL,
5888      *   H,WT,JSTART,IDID,RPAR,IPAR,PHI,GAMMA,SAVR,DELTA,E,
5889      *   WM,IWM,CJ,CJOLD,CJLAST,S,UROUND,EPLI,SQRTN,RSQRTN,
5890      *   EPCON,JCALC,JFLG,KP1,NONNEG,NTYPE,IERNLS)
5891 C
5892 C***BEGIN PROLOGUE  DNEDK
5893 C***REFER TO  DDASPK
5894 C***DATE WRITTEN   891219   (YYMMDD)
5895 C***REVISION DATE  900926   (YYMMDD)
5896 C***REVISION DATE  940701   (YYMMDD)
5897 C
5898 C
5899 C-----------------------------------------------------------------------
5900 C***DESCRIPTION
5901 C
5902 C     DNEDK solves a nonlinear system of
5903 C     algebraic equations of the form
5904 C     G(X,Y,YPRIME) = 0 for the unknown Y.
5905 C
5906 C     The method used is a matrix-free Newton scheme.
5907 C
5908 C     The parameters represent
5909 C     X         -- Independent variable.
5910 C     Y         -- Solution vector at x.
5911 C     YPRIME    -- Derivative of solution vector
5912 C                  after successful step.
5913 C     NEQ       -- Number of equations to be integrated.
5914 C     RES       -- External user-supplied subroutine
5915 C                  to evaluate the residual.  See RES description
5916 C                  in DDASPK prologue.
5917 C     JACK     --  External user-supplied routine to update
5918 C                  the preconditioner.  (This is optional).
5919 C                  See JAC description for the case
5920 C                  INFO(12) = 1 in the DDASPK prologue.
5921 C     PSOL      -- External user-supplied routine to solve
5922 C                  a linear system using preconditioning. 
5923 C                  (This is optional).  See explanation inside DDASPK.
5924 C     H         -- Appropriate step size for this step.
5925 C     WT        -- Vector of weights for error criterion.
5926 C     JSTART    -- Indicates first call to this routine.
5927 C                  If JSTART = 0, then this is the first call,
5928 C                  otherwise it is not.
5929 C     IDID      -- Completion flag, output by DNEDK.
5930 C                  See IDID description in DDASPK prologue.
5931 C     RPAR,IPAR -- Real and integer arrays used for communication
5932 C                  between the calling program and external user
5933 C                  routines.  They are not altered within DASPK.
5934 C     PHI       -- Array of divided differences used by
5935 C                  DNEDK.  The length is NEQ*(K+1), where
5936 C                  K is the maximum order.
5937 C     GAMMA     -- Array used to predict Y and YPRIME.  The length
5938 C                  is K+1, where K is the maximum order.
5939 C     SAVR      -- Work vector for DNEDK of length NEQ.
5940 C     DELTA     -- Work vector for DNEDK of length NEQ.
5941 C     E         -- Error accumulation vector for DNEDK of length NEQ.
5942 C     WM,IWM    -- Real and integer arrays storing
5943 C                  matrix information for linear system
5944 C                  solvers, and various other information.
5945 C     CJ        -- Parameter always proportional to 1/H.
5946 C     CJOLD     -- Saves the value of CJ as of the last call to DITMD.
5947 C                  Accounts for changes in CJ needed to
5948 C                  decide whether to call DITMD.
5949 C     CJLAST    -- Previous value of CJ.
5950 C     S         -- A scalar determined by the approximate rate
5951 C                  of convergence of the Newton iteration and used
5952 C                  in the convergence test for the Newton iteration.
5953 C
5954 C                  If RATE is defined to be an estimate of the
5955 C                  rate of convergence of the Newton iteration,
5956 C                  then S = RATE/(1.D0-RATE).
5957 C
5958 C                  The closer RATE is to 0., the faster the Newton
5959 C                  iteration is converging; the closer RATE is to 1.,
5960 C                  the slower the Newton iteration is converging.
5961 C
5962 C                  On the first Newton iteration with an up-dated
5963 C                  preconditioner S = 100.D0, Thus the initial
5964 C                  RATE of convergence is approximately 1.
5965 C
5966 C                  S is preserved from call to call so that the rate
5967 C                  estimate from a previous step can be applied to
5968 C                  the current step.
5969 C     UROUND    -- Unit roundoff.  Not used here.
5970 C     EPLI      -- convergence test constant.
5971 C                  See DDASPK prologue for more details.
5972 C     SQRTN     -- Square root of NEQ.
5973 C     RSQRTN    -- reciprical of square root of NEQ.
5974 C     EPCON     -- Tolerance to test for convergence of the Newton
5975 C                  iteration.
5976 C     JCALC     -- Flag used to determine when to update
5977 C                  the Jacobian matrix.  In general:
5978 C
5979 C                  JCALC = -1 ==> Call the DITMD routine to update
5980 C                                 the Jacobian matrix.
5981 C                  JCALC =  0 ==> Jacobian matrix is up-to-date.
5982 C                  JCALC =  1 ==> Jacobian matrix is out-dated,
5983 C                                 but DITMD will not be called unless
5984 C                                 JCALC is set to -1.
5985 C     JFLG      -- Flag showing whether a Jacobian routine is supplied.
5986 C     KP1       -- The current order + 1;  updated across calls.
5987 C     NONNEG    -- Flag to determine nonnegativity constraints.
5988 C     NTYPE     -- Identification code for the DNEDK routine.
5989 C                   1 ==> modified Newton; iterative linear solver.
5990 C                   2 ==> modified Newton; user-supplied linear solver.
5991 C     IERNLS    -- Error flag for nonlinear solver.
5992 C                   0 ==> nonlinear solver converged.
5993 C                   1 ==> recoverable error inside non-linear solver.
5994 C                  -1 ==> unrecoverable error inside non-linear solver.
5995 C
5996 C     The following group of variables are passed as arguments to
5997 C     the Newton iteration solver.  They are explained in greater detail
5998 C     in DNSK:
5999 C        TOLNEW, MULDEL, MAXIT, IERNEW
6000 C
6001 C     IERTYP -- Flag which tells whether this subroutine is correct.
6002 C               0 ==> correct subroutine.
6003 C               1 ==> incorrect subroutine.
6004 C
6005 C-----------------------------------------------------------------------
6006 C***ROUTINES CALLED
6007 C   RES, JACK, DDWNRM, DNSK
6008 C
6009 C***END PROLOGUE  DNEDK
6010 C
6011 C
6012       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
6013       DIMENSION Y(*),YPRIME(*),WT(*)
6014       DIMENSION PHI(NEQ,*),SAVR(*),DELTA(*),E(*)
6015       DIMENSION WM(*),IWM(*)
6016       DIMENSION GAMMA(*),RPAR(*),IPAR(*)
6017       EXTERNAL  RES, JACK, PSOL
6018 C
6019       PARAMETER (LNRE=12, LNJE=13, LLOCWP=29, LLCIWP=30)
6020 C
6021       SAVE MULDEL, MAXIT, XRATE
6022       DATA MULDEL/0/, MAXIT/4/, XRATE/0.25D0/
6023 C
6024 C     Verify that this is the correct subroutine.
6025 C
6026       IERTYP = 0
6027       IF (NTYPE .NE. 1) THEN
6028          IERTYP = 1
6029          GO TO 380
6030          ENDIF
6031 C
6032 C     If this is the first step, perform initializations.
6033 C
6034       IF (JSTART .EQ. 0) THEN
6035          CJOLD = CJ
6036          JCALC = -1
6037          S = 100.D0
6038          ENDIF
6039 C
6040 C     Perform all other initializations.
6041 C
6042       IERNLS = 0
6043       LWP = IWM(LLOCWP)
6044       LIWP = IWM(LLCIWP)
6045 C
6046 C     Decide whether to update the preconditioner.
6047 C
6048       IF (JFLG .NE. 0) THEN
6049          TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE)
6050          TEMP2 = 1.0D0/TEMP1
6051          IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1
6052          IF (CJ .NE. CJLAST) S = 100.D0
6053       ELSE
6054          JCALC = 0
6055          ENDIF
6056 C
6057 C     Looping point for updating preconditioner with current stepsize.
6058 C
6059 300   CONTINUE
6060 C
6061 C     Initialize all error flags to zero.
6062 C
6063       IERPJ = 0
6064       IRES = 0
6065       IERSL = 0
6066       IERNEW = 0
6067 C
6068 C     Predict the solution and derivative and compute the tolerance
6069 C     for the Newton iteration.
6070 C
6071       DO 310 I=1,NEQ
6072          Y(I)=PHI(I,1)
6073 310      YPRIME(I)=0.0D0
6074       DO 330 J=2,KP1
6075          DO 320 I=1,NEQ
6076             Y(I)=Y(I)+PHI(I,J)
6077 320         YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J)
6078 330   CONTINUE
6079       EPLIN = EPLI*EPCON
6080       TOLNEW = EPLIN
6081 C
6082 C     Call RES to initialize DELTA.
6083 C
6084       IWM(LNRE)=IWM(LNRE)+1
6085       CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
6086       IF (IRES .LT. 0) GO TO 380
6087 C
6088 C
6089 C     If indicated, update the preconditioner.
6090 C     Set JCALC to 0 as an indicator that this has been done.
6091 C
6092       IF(JCALC .EQ. -1)THEN
6093          IWM(LNJE) = IWM(LNJE) + 1
6094          JCALC=0
6095          CALL JACK (RES, IRES, NEQ, X, Y, YPRIME, WT, DELTA, E, H, CJ,
6096      *      WM(LWP), IWM(LIWP), IERPJ, RPAR, IPAR)
6097          CJOLD=CJ
6098          S = 100.D0
6099          IF (IRES .LT. 0)  GO TO 380
6100          IF (IERPJ .NE. 0) GO TO 380
6101       ENDIF
6102 C
6103 C     Call the nonlinear Newton solver.
6104 C
6105       CALL DNSK(X,Y,YPRIME,NEQ,RES,PSOL,WT,RPAR,IPAR,SAVR,
6106      *   DELTA,E,WM,IWM,CJ,SQRTN,RSQRTN,EPLIN,EPCON,
6107      *   S,TEMP1,TOLNEW,MULDEL,MAXIT,IRES,IERSL,IERNEW)
6108 C
6109       IF (IERNEW .GT. 0 .AND. JCALC .NE. 0) THEN
6110 C
6111 C     The Newton iteration had a recoverable failure with an old
6112 C     preconditioner.  Retry the step with a new preconditioner.
6113 C
6114          JCALC = -1
6115          GO TO 300
6116       ENDIF
6117 C
6118       IF (IERNEW .NE. 0) GO TO 380
6119 C
6120 C     The Newton iteration has converged.  If nonnegativity of
6121 C     solution is required, set the solution nonnegative, if the
6122 C     perturbation to do it is small enough.  If the change is too
6123 C     large, then consider the corrector iteration to have failed.
6124 C
6125       IF(NONNEG .EQ. 0) GO TO 390
6126       DO 360 I = 1,NEQ
6127  360    DELTA(I) = MIN(Y(I),0.0D0)
6128       DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR)
6129       IF(DELNRM .GT. EPCON) GO TO 380
6130       DO 370 I = 1,NEQ
6131  370    E(I) = E(I) - DELTA(I)
6132       GO TO 390
6133 C
6134 C
6135 C     Exits from nonlinear solver.
6136 C     No convergence with current preconditioner.
6137 C     Compute IERNLS and IDID accordingly.
6138 C
6139 380   CONTINUE
6140       IF (IRES .LE. -2 .OR. IERSL .LT. 0 .OR. IERTYP .NE. 0) THEN
6141          IERNLS = -1
6142          IF (IRES .LE. -2) IDID = -11
6143          IF (IERSL .LT. 0) IDID = -13
6144          IF (IERTYP .NE. 0) IDID = -15
6145       ELSE
6146          IERNLS =  1
6147          IF (IRES .EQ. -1) IDID = -10
6148          IF (IERPJ .NE. 0) IDID = -5
6149          IF (IERSL .GT. 0) IDID = -14
6150       ENDIF
6151 C
6152 C
6153 390   JCALC = 1
6154       RETURN
6155 C
6156 C------END OF SUBROUTINE DNEDK------------------------------------------
6157       END
6158       SUBROUTINE DNSK(X,Y,YPRIME,NEQ,RES,PSOL,WT,RPAR,IPAR,
6159      *   SAVR,DELTA,E,WM,IWM,CJ,SQRTN,RSQRTN,EPLIN,EPCON,
6160      *   S,CONFAC,TOLNEW,MULDEL,MAXIT,IRES,IERSL,IERNEW)
6161 C
6162 C***BEGIN PROLOGUE  DNSK
6163 C***REFER TO  DDASPK
6164 C***DATE WRITTEN   891219   (YYMMDD)
6165 C***REVISION DATE  900926   (YYMMDD)
6166 C***REVISION DATE  950126   (YYMMDD)
6167 C***REVISION DATE  000711   (YYMMDD)
6168 C
6169 C
6170 C-----------------------------------------------------------------------
6171 C***DESCRIPTION
6172 C
6173 C     DNSK solves a nonlinear system of
6174 C     algebraic equations of the form
6175 C     G(X,Y,YPRIME) = 0 for the unknown Y.
6176 C
6177 C     The method used is a modified Newton scheme.
6178 C
6179 C     The parameters represent
6180 C
6181 C     X         -- Independent variable.
6182 C     Y         -- Solution vector.
6183 C     YPRIME    -- Derivative of solution vector.
6184 C     NEQ       -- Number of unknowns.
6185 C     RES       -- External user-supplied subroutine
6186 C                  to evaluate the residual.  See RES description
6187 C                  in DDASPK prologue.
6188 C     PSOL      -- External user-supplied routine to solve
6189 C                  a linear system using preconditioning. 
6190 C                  See explanation inside DDASPK.
6191 C     WT        -- Vector of weights for error criterion.
6192 C     RPAR,IPAR -- Real and integer arrays used for communication
6193 C                  between the calling program and external user
6194 C                  routines.  They are not altered within DASPK.
6195 C     SAVR      -- Work vector for DNSK of length NEQ.
6196 C     DELTA     -- Work vector for DNSK of length NEQ.
6197 C     E         -- Error accumulation vector for DNSK of length NEQ.
6198 C     WM,IWM    -- Real and integer arrays storing
6199 C                  matrix information such as the matrix
6200 C                  of partial derivatives, permutation
6201 C                  vector, and various other information.
6202 C     CJ        -- Parameter always proportional to 1/H (step size).
6203 C     SQRTN     -- Square root of NEQ.
6204 C     RSQRTN    -- reciprical of square root of NEQ.
6205 C     EPLIN     -- Tolerance for linear system solver.
6206 C     EPCON     -- Tolerance to test for convergence of the Newton
6207 C                  iteration.
6208 C     S         -- Used for error convergence tests.
6209 C                  In the Newton iteration: S = RATE/(1.D0-RATE),
6210 C                  where RATE is the estimated rate of convergence
6211 C                  of the Newton iteration.
6212 C
6213 C                  The closer RATE is to 0., the faster the Newton
6214 C                  iteration is converging; the closer RATE is to 1.,
6215 C                  the slower the Newton iteration is converging.
6216 C