MoDeNa  1.0
Software framework facilitating sequential multi-scale modelling
odepack.f
1 *DECK DLSODE
2  SUBROUTINE dlsode (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK,
3  1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF)
4  EXTERNAL f, jac
5  INTEGER neq, itol, itask, istate, iopt, lrw, iwork, liw, mf
6  DOUBLE PRECISION y, t, tout, rtol, atol, rwork
7  dimension neq(*), y(*), rtol(*), atol(*), rwork(lrw), iwork(liw)
8 C***BEGIN PROLOGUE DLSODE
9 C***PURPOSE Livermore Solver for Ordinary Differential Equations.
10 C DLSODE solves the initial-value problem for stiff or
11 C nonstiff systems of first-order ODE's,
12 C dy/dt = f(t,y), or, in component form,
13 C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(N)), i=1,...,N.
14 C***CATEGORY I1A
15 C***TYPE DOUBLE PRECISION (SLSODE-S, DLSODE-D)
16 C***KEYWORDS ORDINARY DIFFERENTIAL EQUATIONS, INITIAL VALUE PROBLEM,
17 C STIFF, NONSTIFF
18 C***AUTHOR Hindmarsh, Alan C., (LLNL)
19 C Center for Applied Scientific Computing, L-561
20 C Lawrence Livermore National Laboratory
21 C Livermore, CA 94551.
22 C***DESCRIPTION
23 C
24 C NOTE: The "Usage" and "Arguments" sections treat only a subset of
25 C available options, in condensed fashion. The options
26 C covered and the information supplied will support most
27 C standard uses of DLSODE.
28 C
29 C For more sophisticated uses, full details on all options are
30 C given in the concluding section, headed "Long Description."
31 C A synopsis of the DLSODE Long Description is provided at the
32 C beginning of that section; general topics covered are:
33 C - Elements of the call sequence; optional input and output
34 C - Optional supplemental routines in the DLSODE package
35 C - internal COMMON block
36 C
37 C *Usage:
38 C Communication between the user and the DLSODE package, for normal
39 C situations, is summarized here. This summary describes a subset
40 C of the available options. See "Long Description" for complete
41 C details, including optional communication, nonstandard options,
42 C and instructions for special situations.
43 C
44 C A sample program is given in the "Examples" section.
45 C
46 C Refer to the argument descriptions for the definitions of the
47 C quantities that appear in the following sample declarations.
48 C
49 C For MF = 10,
50 C PARAMETER (LRW = 20 + 16*NEQ, LIW = 20)
51 C For MF = 21 or 22,
52 C PARAMETER (LRW = 22 + 9*NEQ + NEQ**2, LIW = 20 + NEQ)
53 C For MF = 24 or 25,
54 C PARAMETER (LRW = 22 + 10*NEQ + (2*ML+MU)*NEQ,
55 C * LIW = 20 + NEQ)
56 C
57 C EXTERNAL F, JAC
58 C INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK(LIW),
59 C * LIW, MF
60 C DOUBLE PRECISION Y(NEQ), T, TOUT, RTOL, ATOL(ntol), RWORK(LRW)
61 C
62 C CALL DLSODE (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK,
63 C * ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF)
64 C
65 C *Arguments:
66 C F :EXT Name of subroutine for right-hand-side vector f.
67 C This name must be declared EXTERNAL in calling
68 C program. The form of F must be:
69 C
70 C SUBROUTINE F (NEQ, T, Y, YDOT)
71 C INTEGER NEQ
72 C DOUBLE PRECISION T, Y(*), YDOT(*)
73 C
74 C The inputs are NEQ, T, Y. F is to set
75 C
76 C YDOT(i) = f(i,T,Y(1),Y(2),...,Y(NEQ)),
77 C i = 1, ..., NEQ .
78 C
79 C NEQ :IN Number of first-order ODE's.
80 C
81 C Y :INOUT Array of values of the y(t) vector, of length NEQ.
82 C Input: For the first call, Y should contain the
83 C values of y(t) at t = T. (Y is an input
84 C variable only if ISTATE = 1.)
85 C Output: On return, Y will contain the values at the
86 C new t-value.
87 C
88 C T :INOUT Value of the independent variable. On return it
89 C will be the current value of t (normally TOUT).
90 C
91 C TOUT :IN Next point where output is desired (.NE. T).
92 C
93 C ITOL :IN 1 or 2 according as ATOL (below) is a scalar or
94 C an array.
95 C
96 C RTOL :IN Relative tolerance parameter (scalar).
97 C
98 C ATOL :IN Absolute tolerance parameter (scalar or array).
99 C If ITOL = 1, ATOL need not be dimensioned.
100 C If ITOL = 2, ATOL must be dimensioned at least NEQ.
101 C
102 C The estimated local error in Y(i) will be controlled
103 C so as to be roughly less (in magnitude) than
104 C
105 C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or
106 C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2.
107 C
108 C Thus the local error test passes if, in each
109 C component, either the absolute error is less than
110 C ATOL (or ATOL(i)), or the relative error is less
111 C than RTOL.
112 C
113 C Use RTOL = 0.0 for pure absolute error control, and
114 C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative
115 C error control. Caution: Actual (global) errors may
116 C exceed these local tolerances, so choose them
117 C conservatively.
118 C
119 C ITASK :IN Flag indicating the task DLSODE is to perform.
120 C Use ITASK = 1 for normal computation of output
121 C values of y at t = TOUT.
122 C
123 C ISTATE:INOUT Index used for input and output to specify the state
124 C of the calculation.
125 C Input:
126 C 1 This is the first call for a problem.
127 C 2 This is a subsequent call.
128 C Output:
129 C 1 Nothing was done, because TOUT was equal to T.
130 C 2 DLSODE was successful (otherwise, negative).
131 C Note that ISTATE need not be modified after a
132 C successful return.
133 C -1 Excess work done on this call (perhaps wrong
134 C MF).
135 C -2 Excess accuracy requested (tolerances too
136 C small).
137 C -3 Illegal input detected (see printed message).
138 C -4 Repeated error test failures (check all
139 C inputs).
140 C -5 Repeated convergence failures (perhaps bad
141 C Jacobian supplied or wrong choice of MF or
142 C tolerances).
143 C -6 Error weight became zero during problem
144 C (solution component i vanished, and ATOL or
145 C ATOL(i) = 0.).
146 C
147 C IOPT :IN Flag indicating whether optional inputs are used:
148 C 0 No.
149 C 1 Yes. (See "Optional inputs" under "Long
150 C Description," Part 1.)
151 C
152 C RWORK :WORK Real work array of length at least:
153 C 20 + 16*NEQ for MF = 10,
154 C 22 + 9*NEQ + NEQ**2 for MF = 21 or 22,
155 C 22 + 10*NEQ + (2*ML + MU)*NEQ for MF = 24 or 25.
156 C
157 C LRW :IN Declared length of RWORK (in user's DIMENSION
158 C statement).
159 C
160 C IWORK :WORK Integer work array of length at least:
161 C 20 for MF = 10,
162 C 20 + NEQ for MF = 21, 22, 24, or 25.
163 C
164 C If MF = 24 or 25, input in IWORK(1),IWORK(2) the
165 C lower and upper Jacobian half-bandwidths ML,MU.
166 C
167 C On return, IWORK contains information that may be
168 C of interest to the user:
169 C
170 C Name Location Meaning
171 C ----- --------- -----------------------------------------
172 C NST IWORK(11) Number of steps taken for the problem so
173 C far.
174 C NFE IWORK(12) Number of f evaluations for the problem
175 C so far.
176 C NJE IWORK(13) Number of Jacobian evaluations (and of
177 C matrix LU decompositions) for the problem
178 C so far.
179 C NQU IWORK(14) Method order last used (successfully).
180 C LENRW IWORK(17) Length of RWORK actually required. This
181 C is defined on normal returns and on an
182 C illegal input return for insufficient
183 C storage.
184 C LENIW IWORK(18) Length of IWORK actually required. This
185 C is defined on normal returns and on an
186 C illegal input return for insufficient
187 C storage.
188 C
189 C LIW :IN Declared length of IWORK (in user's DIMENSION
190 C statement).
191 C
192 C JAC :EXT Name of subroutine for Jacobian matrix (MF =
193 C 21 or 24). If used, this name must be declared
194 C EXTERNAL in calling program. If not used, pass a
195 C dummy name. The form of JAC must be:
196 C
197 C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD)
198 C INTEGER NEQ, ML, MU, NROWPD
199 C DOUBLE PRECISION T, Y(*), PD(NROWPD,*)
200 C
201 C See item c, under "Description" below for more
202 C information about JAC.
203 C
204 C MF :IN Method flag. Standard values are:
205 C 10 Nonstiff (Adams) method, no Jacobian used.
206 C 21 Stiff (BDF) method, user-supplied full Jacobian.
207 C 22 Stiff method, internally generated full
208 C Jacobian.
209 C 24 Stiff method, user-supplied banded Jacobian.
210 C 25 Stiff method, internally generated banded
211 C Jacobian.
212 C
213 C *Description:
214 C DLSODE solves the initial value problem for stiff or nonstiff
215 C systems of first-order ODE's,
216 C
217 C dy/dt = f(t,y) ,
218 C
219 C or, in component form,
220 C
221 C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ))
222 C (i = 1, ..., NEQ) .
223 C
224 C DLSODE is a package based on the GEAR and GEARB packages, and on
225 C the October 23, 1978, version of the tentative ODEPACK user
226 C interface standard, with minor modifications.
227 C
228 C The steps in solving such a problem are as follows.
229 C
230 C a. First write a subroutine of the form
231 C
232 C SUBROUTINE F (NEQ, T, Y, YDOT)
233 C INTEGER NEQ
234 C DOUBLE PRECISION T, Y(*), YDOT(*)
235 C
236 C which supplies the vector function f by loading YDOT(i) with
237 C f(i).
238 C
239 C b. Next determine (or guess) whether or not the problem is stiff.
240 C Stiffness occurs when the Jacobian matrix df/dy has an
241 C eigenvalue whose real part is negative and large in magnitude
242 C compared to the reciprocal of the t span of interest. If the
243 C problem is nonstiff, use method flag MF = 10. If it is stiff,
244 C there are four standard choices for MF, and DLSODE requires the
245 C Jacobian matrix in some form. This matrix is regarded either
246 C as full (MF = 21 or 22), or banded (MF = 24 or 25). In the
247 C banded case, DLSODE requires two half-bandwidth parameters ML
248 C and MU. These are, respectively, the widths of the lower and
249 C upper parts of the band, excluding the main diagonal. Thus the
250 C band consists of the locations (i,j) with
251 C
252 C i - ML <= j <= i + MU ,
253 C
254 C and the full bandwidth is ML + MU + 1 .
255 C
256 C c. If the problem is stiff, you are encouraged to supply the
257 C Jacobian directly (MF = 21 or 24), but if this is not feasible,
258 C DLSODE will compute it internally by difference quotients (MF =
259 C 22 or 25). If you are supplying the Jacobian, write a
260 C subroutine of the form
261 C
262 C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD)
263 C INTEGER NEQ, ML, MU, NRWOPD
264 C DOUBLE PRECISION T, Y(*), PD(NROWPD,*)
265 C
266 C which provides df/dy by loading PD as follows:
267 C - For a full Jacobian (MF = 21), load PD(i,j) with df(i)/dy(j),
268 C the partial derivative of f(i) with respect to y(j). (Ignore
269 C the ML and MU arguments in this case.)
270 C - For a banded Jacobian (MF = 24), load PD(i-j+MU+1,j) with
271 C df(i)/dy(j); i.e., load the diagonal lines of df/dy into the
272 C rows of PD from the top down.
273 C - In either case, only nonzero elements need be loaded.
274 C
275 C d. Write a main program that calls subroutine DLSODE once for each
276 C point at which answers are desired. This should also provide
277 C for possible use of logical unit 6 for output of error messages
278 C by DLSODE.
279 C
280 C Before the first call to DLSODE, set ISTATE = 1, set Y and T to
281 C the initial values, and set TOUT to the first output point. To
282 C continue the integration after a successful return, simply
283 C reset TOUT and call DLSODE again. No other parameters need be
284 C reset.
285 C
286 C *Examples:
287 C The following is a simple example problem, with the coding needed
288 C for its solution by DLSODE. The problem is from chemical kinetics,
289 C and consists of the following three rate equations:
290 C
291 C dy1/dt = -.04*y1 + 1.E4*y2*y3
292 C dy2/dt = .04*y1 - 1.E4*y2*y3 - 3.E7*y2**2
293 C dy3/dt = 3.E7*y2**2
294 C
295 C on the interval from t = 0.0 to t = 4.E10, with initial conditions
296 C y1 = 1.0, y2 = y3 = 0. The problem is stiff.
297 C
298 C The following coding solves this problem with DLSODE, using
299 C MF = 21 and printing results at t = .4, 4., ..., 4.E10. It uses
300 C ITOL = 2 and ATOL much smaller for y2 than for y1 or y3 because y2
301 C has much smaller values. At the end of the run, statistical
302 C quantities of interest are printed.
303 C
304 C EXTERNAL FEX, JEX
305 C INTEGER IOPT, IOUT, ISTATE, ITASK, ITOL, IWORK(23), LIW, LRW,
306 C * MF, NEQ
307 C DOUBLE PRECISION ATOL(3), RTOL, RWORK(58), T, TOUT, Y(3)
308 C NEQ = 3
309 C Y(1) = 1.D0
310 C Y(2) = 0.D0
311 C Y(3) = 0.D0
312 C T = 0.D0
313 C TOUT = .4D0
314 C ITOL = 2
315 C RTOL = 1.D-4
316 C ATOL(1) = 1.D-6
317 C ATOL(2) = 1.D-10
318 C ATOL(3) = 1.D-6
319 C ITASK = 1
320 C ISTATE = 1
321 C IOPT = 0
322 C LRW = 58
323 C LIW = 23
324 C MF = 21
325 C DO 40 IOUT = 1,12
326 C CALL DLSODE (FEX, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK,
327 C * ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JEX, MF)
328 C WRITE(6,20) T, Y(1), Y(2), Y(3)
329 C 20 FORMAT(' At t =',D12.4,' y =',3D14.6)
330 C IF (ISTATE .LT. 0) GO TO 80
331 C 40 TOUT = TOUT*10.D0
332 C WRITE(6,60) IWORK(11), IWORK(12), IWORK(13)
333 C 60 FORMAT(/' No. steps =',i4,', No. f-s =',i4,', No. J-s =',i4)
334 C STOP
335 C 80 WRITE(6,90) ISTATE
336 C 90 FORMAT(///' Error halt.. ISTATE =',I3)
337 C STOP
338 C END
339 C
340 C SUBROUTINE FEX (NEQ, T, Y, YDOT)
341 C INTEGER NEQ
342 C DOUBLE PRECISION T, Y(3), YDOT(3)
343 C YDOT(1) = -.04D0*Y(1) + 1.D4*Y(2)*Y(3)
344 C YDOT(3) = 3.D7*Y(2)*Y(2)
345 C YDOT(2) = -YDOT(1) - YDOT(3)
346 C RETURN
347 C END
348 C
349 C SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD)
350 C INTEGER NEQ, ML, MU, NRPD
351 C DOUBLE PRECISION T, Y(3), PD(NRPD,3)
352 C PD(1,1) = -.04D0
353 C PD(1,2) = 1.D4*Y(3)
354 C PD(1,3) = 1.D4*Y(2)
355 C PD(2,1) = .04D0
356 C PD(2,3) = -PD(1,3)
357 C PD(3,2) = 6.D7*Y(2)
358 C PD(2,2) = -PD(1,2) - PD(3,2)
359 C RETURN
360 C END
361 C
362 C The output from this program (on a Cray-1 in single precision)
363 C is as follows.
364 C
365 C At t = 4.0000e-01 y = 9.851726e-01 3.386406e-05 1.479357e-02
366 C At t = 4.0000e+00 y = 9.055142e-01 2.240418e-05 9.446344e-02
367 C At t = 4.0000e+01 y = 7.158050e-01 9.184616e-06 2.841858e-01
368 C At t = 4.0000e+02 y = 4.504846e-01 3.222434e-06 5.495122e-01
369 C At t = 4.0000e+03 y = 1.831701e-01 8.940379e-07 8.168290e-01
370 C At t = 4.0000e+04 y = 3.897016e-02 1.621193e-07 9.610297e-01
371 C At t = 4.0000e+05 y = 4.935213e-03 1.983756e-08 9.950648e-01
372 C At t = 4.0000e+06 y = 5.159269e-04 2.064759e-09 9.994841e-01
373 C At t = 4.0000e+07 y = 5.306413e-05 2.122677e-10 9.999469e-01
374 C At t = 4.0000e+08 y = 5.494530e-06 2.197825e-11 9.999945e-01
375 C At t = 4.0000e+09 y = 5.129458e-07 2.051784e-12 9.999995e-01
376 C At t = 4.0000e+10 y = -7.170603e-08 -2.868241e-13 1.000000e+00
377 C
378 C No. steps = 330, No. f-s = 405, No. J-s = 69
379 C
380 C *Accuracy:
381 C The accuracy of the solution depends on the choice of tolerances
382 C RTOL and ATOL. Actual (global) errors may exceed these local
383 C tolerances, so choose them conservatively.
384 C
385 C *Cautions:
386 C The work arrays should not be altered between calls to DLSODE for
387 C the same problem, except possibly for the conditional and optional
388 C inputs.
389 C
390 C *Portability:
391 C Since NEQ is dimensioned inside DLSODE, some compilers may object
392 C to a call to DLSODE with NEQ a scalar variable. In this event,
393 C use DIMENSION NEQ(1). Similar remarks apply to RTOL and ATOL.
394 C
395 C Note to Cray users:
396 C For maximum efficiency, use the CFT77 compiler. Appropriate
397 C compiler optimization directives have been inserted for CFT77.
398 C
399 C *Reference:
400 C Alan C. Hindmarsh, "ODEPACK, A Systematized Collection of ODE
401 C Solvers," in Scientific Computing, R. S. Stepleman, et al., Eds.
402 C (North-Holland, Amsterdam, 1983), pp. 55-64.
403 C
404 C *Long Description:
405 C The following complete description of the user interface to
406 C DLSODE consists of four parts:
407 C
408 C 1. The call sequence to subroutine DLSODE, which is a driver
409 C routine for the solver. This includes descriptions of both
410 C the call sequence arguments and user-supplied routines.
411 C Following these descriptions is a description of optional
412 C inputs available through the call sequence, and then a
413 C description of optional outputs in the work arrays.
414 C
415 C 2. Descriptions of other routines in the DLSODE package that may
416 C be (optionally) called by the user. These provide the ability
417 C to alter error message handling, save and restore the internal
418 C COMMON, and obtain specified derivatives of the solution y(t).
419 C
420 C 3. Descriptions of COMMON block to be declared in overlay or
421 C similar environments, or to be saved when doing an interrupt
422 C of the problem and continued solution later.
423 C
424 C 4. Description of two routines in the DLSODE package, either of
425 C which the user may replace with his own version, if desired.
426 C These relate to the measurement of errors.
427 C
428 C
429 C Part 1. Call Sequence
430 C ----------------------
431 C
432 C Arguments
433 C ---------
434 C The call sequence parameters used for input only are
435 C
436 C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, MF,
437 C
438 C and those used for both input and output are
439 C
440 C Y, T, ISTATE.
441 C
442 C The work arrays RWORK and IWORK are also used for conditional and
443 C optional inputs and optional outputs. (The term output here
444 C refers to the return from subroutine DLSODE to the user's calling
445 C program.)
446 C
447 C The legality of input parameters will be thoroughly checked on the
448 C initial call for the problem, but not checked thereafter unless a
449 C change in input parameters is flagged by ISTATE = 3 on input.
450 C
451 C The descriptions of the call arguments are as follows.
452 C
453 C F The name of the user-supplied subroutine defining the ODE
454 C system. The system must be put in the first-order form
455 C dy/dt = f(t,y), where f is a vector-valued function of
456 C the scalar t and the vector y. Subroutine F is to compute
457 C the function f. It is to have the form
458 C
459 C SUBROUTINE F (NEQ, T, Y, YDOT)
460 C DOUBLE PRECISION T, Y(*), YDOT(*)
461 C
462 C where NEQ, T, and Y are input, and the array YDOT =
463 C f(T,Y) is output. Y and YDOT are arrays of length NEQ.
464 C Subroutine F should not alter Y(1),...,Y(NEQ). F must be
465 C declared EXTERNAL in the calling program.
466 C
467 C Subroutine F may access user-defined quantities in
468 C NEQ(2),... and/or in Y(NEQ(1)+1),..., if NEQ is an array
469 C (dimensioned in F) and/or Y has length exceeding NEQ(1).
470 C See the descriptions of NEQ and Y below.
471 C
472 C If quantities computed in the F routine are needed
473 C externally to DLSODE, an extra call to F should be made
474 C for this purpose, for consistent and accurate results.
475 C If only the derivative dy/dt is needed, use DINTDY
476 C instead.
477 C
478 C NEQ The size of the ODE system (number of first-order
479 C ordinary differential equations). Used only for input.
480 C NEQ may be decreased, but not increased, during the
481 C problem. If NEQ is decreased (with ISTATE = 3 on input),
482 C the remaining components of Y should be left undisturbed,
483 C if these are to be accessed in F and/or JAC.
484 C
485 C Normally, NEQ is a scalar, and it is generally referred
486 C to as a scalar in this user interface description.
487 C However, NEQ may be an array, with NEQ(1) set to the
488 C system size. (The DLSODE package accesses only NEQ(1).)
489 C In either case, this parameter is passed as the NEQ
490 C argument in all calls to F and JAC. Hence, if it is an
491 C array, locations NEQ(2),... may be used to store other
492 C integer data and pass it to F and/or JAC. Subroutines
493 C F and/or JAC must include NEQ in a DIMENSION statement
494 C in that case.
495 C
496 C Y A real array for the vector of dependent variables, of
497 C length NEQ or more. Used for both input and output on
498 C the first call (ISTATE = 1), and only for output on
499 C other calls. On the first call, Y must contain the
500 C vector of initial values. On output, Y contains the
501 C computed solution vector, evaluated at T. If desired,
502 C the Y array may be used for other purposes between
503 C calls to the solver.
504 C
505 C This array is passed as the Y argument in all calls to F
506 C and JAC. Hence its length may exceed NEQ, and locations
507 C Y(NEQ+1),... may be used to store other real data and
508 C pass it to F and/or JAC. (The DLSODE package accesses
509 C only Y(1),...,Y(NEQ).)
510 C
511 C T The independent variable. On input, T is used only on
512 C the first call, as the initial point of the integration.
513 C On output, after each call, T is the value at which a
514 C computed solution Y is evaluated (usually the same as
515 C TOUT). On an error return, T is the farthest point
516 C reached.
517 C
518 C TOUT The next value of T at which a computed solution is
519 C desired. Used only for input.
520 C
521 C When starting the problem (ISTATE = 1), TOUT may be equal
522 C to T for one call, then should not equal T for the next
523 C call. For the initial T, an input value of TOUT .NE. T
524 C is used in order to determine the direction of the
525 C integration (i.e., the algebraic sign of the step sizes)
526 C and the rough scale of the problem. Integration in
527 C either direction (forward or backward in T) is permitted.
528 C
529 C If ITASK = 2 or 5 (one-step modes), TOUT is ignored
530 C after the first call (i.e., the first call with
531 C TOUT .NE. T). Otherwise, TOUT is required on every call.
532 C
533 C If ITASK = 1, 3, or 4, the values of TOUT need not be
534 C monotone, but a value of TOUT which backs up is limited
535 C to the current internal T interval, whose endpoints are
536 C TCUR - HU and TCUR. (See "Optional Outputs" below for
537 C TCUR and HU.)
538 C
539 C
540 C ITOL An indicator for the type of error control. See
541 C description below under ATOL. Used only for input.
542 C
543 C RTOL A relative error tolerance parameter, either a scalar or
544 C an array of length NEQ. See description below under
545 C ATOL. Input only.
546 C
547 C ATOL An absolute error tolerance parameter, either a scalar or
548 C an array of length NEQ. Input only.
549 C
550 C The input parameters ITOL, RTOL, and ATOL determine the
551 C error control performed by the solver. The solver will
552 C control the vector e = (e(i)) of estimated local errors
553 C in Y, according to an inequality of the form
554 C
555 C rms-norm of ( e(i)/EWT(i) ) <= 1,
556 C
557 C where
558 C
559 C EWT(i) = RTOL(i)*ABS(Y(i)) + ATOL(i),
560 C
561 C and the rms-norm (root-mean-square norm) here is
562 C
563 C rms-norm(v) = SQRT(sum v(i)**2 / NEQ).
564 C
565 C Here EWT = (EWT(i)) is a vector of weights which must
566 C always be positive, and the values of RTOL and ATOL
567 C should all be nonnegative. The following table gives the
568 C types (scalar/array) of RTOL and ATOL, and the
569 C corresponding form of EWT(i).
570 C
571 C ITOL RTOL ATOL EWT(i)
572 C ---- ------ ------ -----------------------------
573 C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL
574 C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i)
575 C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL
576 C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i)
577 C
578 C When either of these parameters is a scalar, it need not
579 C be dimensioned in the user's calling program.
580 C
581 C If none of the above choices (with ITOL, RTOL, and ATOL
582 C fixed throughout the problem) is suitable, more general
583 C error controls can be obtained by substituting
584 C user-supplied routines for the setting of EWT and/or for
585 C the norm calculation. See Part 4 below.
586 C
587 C If global errors are to be estimated by making a repeated
588 C run on the same problem with smaller tolerances, then all
589 C components of RTOL and ATOL (i.e., of EWT) should be
590 C scaled down uniformly.
591 C
592 C ITASK An index specifying the task to be performed. Input
593 C only. ITASK has the following values and meanings:
594 C 1 Normal computation of output values of y(t) at
595 C t = TOUT (by overshooting and interpolating).
596 C 2 Take one step only and return.
597 C 3 Stop at the first internal mesh point at or beyond
598 C t = TOUT and return.
599 C 4 Normal computation of output values of y(t) at
600 C t = TOUT but without overshooting t = TCRIT. TCRIT
601 C must be input as RWORK(1). TCRIT may be equal to or
602 C beyond TOUT, but not behind it in the direction of
603 C integration. This option is useful if the problem
604 C has a singularity at or beyond t = TCRIT.
605 C 5 Take one step, without passing TCRIT, and return.
606 C TCRIT must be input as RWORK(1).
607 C
608 C Note: If ITASK = 4 or 5 and the solver reaches TCRIT
609 C (within roundoff), it will return T = TCRIT (exactly) to
610 C indicate this (unless ITASK = 4 and TOUT comes before
611 C TCRIT, in which case answers at T = TOUT are returned
612 C first).
613 C
614 C ISTATE An index used for input and output to specify the state
615 C of the calculation.
616 C
617 C On input, the values of ISTATE are as follows:
618 C 1 This is the first call for the problem
619 C (initializations will be done). See "Note" below.
620 C 2 This is not the first call, and the calculation is to
621 C continue normally, with no change in any input
622 C parameters except possibly TOUT and ITASK. (If ITOL,
623 C RTOL, and/or ATOL are changed between calls with
624 C ISTATE = 2, the new values will be used but not
625 C tested for legality.)
626 C 3 This is not the first call, and the calculation is to
627 C continue normally, but with a change in input
628 C parameters other than TOUT and ITASK. Changes are
629 C allowed in NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF,
630 C ML, MU, and any of the optional inputs except H0.
631 C (See IWORK description for ML and MU.)
632 C
633 C Note: A preliminary call with TOUT = T is not counted as
634 C a first call here, as no initialization or checking of
635 C input is done. (Such a call is sometimes useful for the
636 C purpose of outputting the initial conditions.) Thus the
637 C first call for which TOUT .NE. T requires ISTATE = 1 on
638 C input.
639 C
640 C On output, ISTATE has the following values and meanings:
641 C 1 Nothing was done, as TOUT was equal to T with
642 C ISTATE = 1 on input.
643 C 2 The integration was performed successfully.
644 C -1 An excessive amount of work (more than MXSTEP steps)
645 C was done on this call, before completing the
646 C requested task, but the integration was otherwise
647 C successful as far as T. (MXSTEP is an optional input
648 C and is normally 500.) To continue, the user may
649 C simply reset ISTATE to a value >1 and call again (the
650 C excess work step counter will be reset to 0). In
651 C addition, the user may increase MXSTEP to avoid this
652 C error return; see "Optional Inputs" below.
653 C -2 Too much accuracy was requested for the precision of
654 C the machine being used. This was detected before
655 C completing the requested task, but the integration
656 C was successful as far as T. To continue, the
657 C tolerance parameters must be reset, and ISTATE must
658 C be set to 3. The optional output TOLSF may be used
659 C for this purpose. (Note: If this condition is
660 C detected before taking any steps, then an illegal
661 C input return (ISTATE = -3) occurs instead.)
662 C -3 Illegal input was detected, before taking any
663 C integration steps. See written message for details.
664 C (Note: If the solver detects an infinite loop of
665 C calls to the solver with illegal input, it will cause
666 C the run to stop.)
667 C -4 There were repeated error-test failures on one
668 C attempted step, before completing the requested task,
669 C but the integration was successful as far as T. The
670 C problem may have a singularity, or the input may be
671 C inappropriate.
672 C -5 There were repeated convergence-test failures on one
673 C attempted step, before completing the requested task,
674 C but the integration was successful as far as T. This
675 C may be caused by an inaccurate Jacobian matrix, if
676 C one is being used.
677 C -6 EWT(i) became zero for some i during the integration.
678 C Pure relative error control (ATOL(i)=0.0) was
679 C requested on a variable which has now vanished. The
680 C integration was successful as far as T.
681 C
682 C Note: Since the normal output value of ISTATE is 2, it
683 C does not need to be reset for normal continuation. Also,
684 C since a negative input value of ISTATE will be regarded
685 C as illegal, a negative output value requires the user to
686 C change it, and possibly other inputs, before calling the
687 C solver again.
688 C
689 C IOPT An integer flag to specify whether any optional inputs
690 C are being used on this call. Input only. The optional
691 C inputs are listed under a separate heading below.
692 C 0 No optional inputs are being used. Default values
693 C will be used in all cases.
694 C 1 One or more optional inputs are being used.
695 C
696 C RWORK A real working array (double precision). The length of
697 C RWORK must be at least
698 C
699 C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM
700 C
701 C where
702 C NYH = the initial value of NEQ,
703 C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a
704 C smaller value is given as an optional input),
705 C LWM = 0 if MITER = 0,
706 C LWM = NEQ**2 + 2 if MITER = 1 or 2,
707 C LWM = NEQ + 2 if MITER = 3, and
708 C LWM = (2*ML + MU + 1)*NEQ + 2
709 C if MITER = 4 or 5.
710 C (See the MF description below for METH and MITER.)
711 C
712 C Thus if MAXORD has its default value and NEQ is constant,
713 C this length is:
714 C 20 + 16*NEQ for MF = 10,
715 C 22 + 16*NEQ + NEQ**2 for MF = 11 or 12,
716 C 22 + 17*NEQ for MF = 13,
717 C 22 + 17*NEQ + (2*ML + MU)*NEQ for MF = 14 or 15,
718 C 20 + 9*NEQ for MF = 20,
719 C 22 + 9*NEQ + NEQ**2 for MF = 21 or 22,
720 C 22 + 10*NEQ for MF = 23,
721 C 22 + 10*NEQ + (2*ML + MU)*NEQ for MF = 24 or 25.
722 C
723 C The first 20 words of RWORK are reserved for conditional
724 C and optional inputs and optional outputs.
725 C
726 C The following word in RWORK is a conditional input:
727 C RWORK(1) = TCRIT, the critical value of t which the
728 C solver is not to overshoot. Required if ITASK
729 C is 4 or 5, and ignored otherwise. See ITASK.
730 C
731 C LRW The length of the array RWORK, as declared by the user.
732 C (This will be checked by the solver.)
733 C
734 C IWORK An integer work array. Its length must be at least
735 C 20 if MITER = 0 or 3 (MF = 10, 13, 20, 23), or
736 C 20 + NEQ otherwise (MF = 11, 12, 14, 15, 21, 22, 24, 25).
737 C (See the MF description below for MITER.) The first few
738 C words of IWORK are used for conditional and optional
739 C inputs and optional outputs.
740 C
741 C The following two words in IWORK are conditional inputs:
742 C IWORK(1) = ML These are the lower and upper half-
743 C IWORK(2) = MU bandwidths, respectively, of the banded
744 C Jacobian, excluding the main diagonal.
745 C The band is defined by the matrix locations
746 C (i,j) with i - ML <= j <= i + MU. ML and MU
747 C must satisfy 0 <= ML,MU <= NEQ - 1. These are
748 C required if MITER is 4 or 5, and ignored
749 C otherwise. ML and MU may in fact be the band
750 C parameters for a matrix to which df/dy is only
751 C approximately equal.
752 C
753 C LIW The length of the array IWORK, as declared by the user.
754 C (This will be checked by the solver.)
755 C
756 C Note: The work arrays must not be altered between calls to DLSODE
757 C for the same problem, except possibly for the conditional and
758 C optional inputs, and except for the last 3*NEQ words of RWORK.
759 C The latter space is used for internal scratch space, and so is
760 C available for use by the user outside DLSODE between calls, if
761 C desired (but not for use by F or JAC).
762 C
763 C JAC The name of the user-supplied routine (MITER = 1 or 4) to
764 C compute the Jacobian matrix, df/dy, as a function of the
765 C scalar t and the vector y. (See the MF description below
766 C for MITER.) It is to have the form
767 C
768 C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD)
769 C DOUBLE PRECISION T, Y(*), PD(NROWPD,*)
770 C
771 C where NEQ, T, Y, ML, MU, and NROWPD are input and the
772 C array PD is to be loaded with partial derivatives
773 C (elements of the Jacobian matrix) on output. PD must be
774 C given a first dimension of NROWPD. T and Y have the same
775 C meaning as in subroutine F.
776 C
777 C In the full matrix case (MITER = 1), ML and MU are
778 C ignored, and the Jacobian is to be loaded into PD in
779 C columnwise manner, with df(i)/dy(j) loaded into PD(i,j).
780 C
781 C In the band matrix case (MITER = 4), the elements within
782 C the band are to be loaded into PD in columnwise manner,
783 C with diagonal lines of df/dy loaded into the rows of PD.
784 C Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j). ML
785 C and MU are the half-bandwidth parameters (see IWORK).
786 C The locations in PD in the two triangular areas which
787 C correspond to nonexistent matrix elements can be ignored
788 C or loaded arbitrarily, as they are overwritten by DLSODE.
789 C
790 C JAC need not provide df/dy exactly. A crude approximation
791 C (possibly with a smaller bandwidth) will do.
792 C
793 C In either case, PD is preset to zero by the solver, so
794 C that only the nonzero elements need be loaded by JAC.
795 C Each call to JAC is preceded by a call to F with the same
796 C arguments NEQ, T, and Y. Thus to gain some efficiency,
797 C intermediate quantities shared by both calculations may
798 C be saved in a user COMMON block by F and not recomputed
799 C by JAC, if desired. Also, JAC may alter the Y array, if
800 C desired. JAC must be declared EXTERNAL in the calling
801 C program.
802 C
803 C Subroutine JAC may access user-defined quantities in
804 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array
805 C (dimensioned in JAC) and/or Y has length exceeding
806 C NEQ(1). See the descriptions of NEQ and Y above.
807 C
808 C MF The method flag. Used only for input. The legal values
809 C of MF are 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24,
810 C and 25. MF has decimal digits METH and MITER:
811 C MF = 10*METH + MITER .
812 C
813 C METH indicates the basic linear multistep method:
814 C 1 Implicit Adams method.
815 C 2 Method based on backward differentiation formulas
816 C (BDF's).
817 C
818 C MITER indicates the corrector iteration method:
819 C 0 Functional iteration (no Jacobian matrix is
820 C involved).
821 C 1 Chord iteration with a user-supplied full (NEQ by
822 C NEQ) Jacobian.
823 C 2 Chord iteration with an internally generated
824 C (difference quotient) full Jacobian (using NEQ
825 C extra calls to F per df/dy value).
826 C 3 Chord iteration with an internally generated
827 C diagonal Jacobian approximation (using one extra call
828 C to F per df/dy evaluation).
829 C 4 Chord iteration with a user-supplied banded Jacobian.
830 C 5 Chord iteration with an internally generated banded
831 C Jacobian (using ML + MU + 1 extra calls to F per
832 C df/dy evaluation).
833 C
834 C If MITER = 1 or 4, the user must supply a subroutine JAC
835 C (the name is arbitrary) as described above under JAC.
836 C For other values of MITER, a dummy argument can be used.
837 C
838 C Optional Inputs
839 C ---------------
840 C The following is a list of the optional inputs provided for in the
841 C call sequence. (See also Part 2.) For each such input variable,
842 C this table lists its name as used in this documentation, its
843 C location in the call sequence, its meaning, and the default value.
844 C The use of any of these inputs requires IOPT = 1, and in that case
845 C all of these inputs are examined. A value of zero for any of
846 C these optional inputs will cause the default value to be used.
847 C Thus to use a subset of the optional inputs, simply preload
848 C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively,
849 C and then set those of interest to nonzero values.
850 C
851 C Name Location Meaning and default value
852 C ------ --------- -----------------------------------------------
853 C H0 RWORK(5) Step size to be attempted on the first step.
854 C The default value is determined by the solver.
855 C HMAX RWORK(6) Maximum absolute step size allowed. The
856 C default value is infinite.
857 C HMIN RWORK(7) Minimum absolute step size allowed. The
858 C default value is 0. (This lower bound is not
859 C enforced on the final step before reaching
860 C TCRIT when ITASK = 4 or 5.)
861 C MAXORD IWORK(5) Maximum order to be allowed. The default value
862 C is 12 if METH = 1, and 5 if METH = 2. (See the
863 C MF description above for METH.) If MAXORD
864 C exceeds the default value, it will be reduced
865 C to the default value. If MAXORD is changed
866 C during the problem, it may cause the current
867 C order to be reduced.
868 C MXSTEP IWORK(6) Maximum number of (internally defined) steps
869 C allowed during one call to the solver. The
870 C default value is 500.
871 C MXHNIL IWORK(7) Maximum number of messages printed (per
872 C problem) warning that T + H = T on a step
873 C (H = step size). This must be positive to
874 C result in a nondefault value. The default
875 C value is 10.
876 C
877 C Optional Outputs
878 C ----------------
879 C As optional additional output from DLSODE, the variables listed
880 C below are quantities related to the performance of DLSODE which
881 C are available to the user. These are communicated by way of the
882 C work arrays, but also have internal mnemonic names as shown.
883 C Except where stated otherwise, all of these outputs are defined on
884 C any successful return from DLSODE, and on any return with ISTATE =
885 C -1, -2, -4, -5, or -6. On an illegal input return (ISTATE = -3),
886 C they will be unchanged from their existing values (if any), except
887 C possibly for TOLSF, LENRW, and LENIW. On any error return,
888 C outputs relevant to the error will be defined, as noted below.
889 C
890 C Name Location Meaning
891 C ----- --------- ------------------------------------------------
892 C HU RWORK(11) Step size in t last used (successfully).
893 C HCUR RWORK(12) Step size to be attempted on the next step.
894 C TCUR RWORK(13) Current value of the independent variable which
895 C the solver has actually reached, i.e., the
896 C current internal mesh point in t. On output,
897 C TCUR will always be at least as far as the
898 C argument T, but may be farther (if interpolation
899 C was done).
900 C TOLSF RWORK(14) Tolerance scale factor, greater than 1.0,
901 C computed when a request for too much accuracy
902 C was detected (ISTATE = -3 if detected at the
903 C start of the problem, ISTATE = -2 otherwise).
904 C If ITOL is left unaltered but RTOL and ATOL are
905 C uniformly scaled up by a factor of TOLSF for the
906 C next call, then the solver is deemed likely to
907 C succeed. (The user may also ignore TOLSF and
908 C alter the tolerance parameters in any other way
909 C appropriate.)
910 C NST IWORK(11) Number of steps taken for the problem so far.
911 C NFE IWORK(12) Number of F evaluations for the problem so far.
912 C NJE IWORK(13) Number of Jacobian evaluations (and of matrix LU
913 C decompositions) for the problem so far.
914 C NQU IWORK(14) Method order last used (successfully).
915 C NQCUR IWORK(15) Order to be attempted on the next step.
916 C IMXER IWORK(16) Index of the component of largest magnitude in
917 C the weighted local error vector ( e(i)/EWT(i) ),
918 C on an error return with ISTATE = -4 or -5.
919 C LENRW IWORK(17) Length of RWORK actually required. This is
920 C defined on normal returns and on an illegal
921 C input return for insufficient storage.
922 C LENIW IWORK(18) Length of IWORK actually required. This is
923 C defined on normal returns and on an illegal
924 C input return for insufficient storage.
925 C
926 C The following two arrays are segments of the RWORK array which may
927 C also be of interest to the user as optional outputs. For each
928 C array, the table below gives its internal name, its base address
929 C in RWORK, and its description.
930 C
931 C Name Base address Description
932 C ---- ------------ ----------------------------------------------
933 C YH 21 The Nordsieck history array, of size NYH by
934 C (NQCUR + 1), where NYH is the initial value of
935 C NEQ. For j = 0,1,...,NQCUR, column j + 1 of
936 C YH contains HCUR**j/factorial(j) times the jth
937 C derivative of the interpolating polynomial
938 C currently representing the solution, evaluated
939 C at t = TCUR.
940 C ACOR LENRW-NEQ+1 Array of size NEQ used for the accumulated
941 C corrections on each step, scaled on output to
942 C represent the estimated local error in Y on
943 C the last step. This is the vector e in the
944 C description of the error control. It is
945 C defined only on successful return from DLSODE.
946 C
947 C
948 C Part 2. Other Callable Routines
949 C --------------------------------
950 C
951 C The following are optional calls which the user may make to gain
952 C additional capabilities in conjunction with DLSODE.
953 C
954 C Form of call Function
955 C ------------------------ ----------------------------------------
956 C CALL XSETUN(LUN) Set the logical unit number, LUN, for
957 C output of messages from DLSODE, if the
958 C default is not desired. The default
959 C value of LUN is 6. This call may be made
960 C at any time and will take effect
961 C immediately.
962 C CALL XSETF(MFLAG) Set a flag to control the printing of
963 C messages by DLSODE. MFLAG = 0 means do
964 C not print. (Danger: this risks losing
965 C valuable information.) MFLAG = 1 means
966 C print (the default). This call may be
967 C made at any time and will take effect
968 C immediately.
969 C CALL DSRCOM(RSAV,ISAV,JOB) Saves and restores the contents of the
970 C internal COMMON blocks used by DLSODE
971 C (see Part 3 below). RSAV must be a
972 C real array of length 218 or more, and
973 C ISAV must be an integer array of length
974 C 37 or more. JOB = 1 means save COMMON
975 C into RSAV/ISAV. JOB = 2 means restore
976 C COMMON from same. DSRCOM is useful if
977 C one is interrupting a run and restarting
978 C later, or alternating between two or
979 C more problems solved with DLSODE.
980 C CALL DINTDY(,,,,,) Provide derivatives of y, of various
981 C (see below) orders, at a specified point t, if
982 C desired. It may be called only after a
983 C successful return from DLSODE. Detailed
984 C instructions follow.
985 C
986 C Detailed instructions for using DINTDY
987 C --------------------------------------
988 C The form of the CALL is:
989 C
990 C CALL DINTDY (T, K, RWORK(21), NYH, DKY, IFLAG)
991 C
992 C The input parameters are:
993 C
994 C T Value of independent variable where answers are
995 C desired (normally the same as the T last returned by
996 C DLSODE). For valid results, T must lie between
997 C TCUR - HU and TCUR. (See "Optional Outputs" above
998 C for TCUR and HU.)
999 C K Integer order of the derivative desired. K must
1000 C satisfy 0 <= K <= NQCUR, where NQCUR is the current
1001 C order (see "Optional Outputs"). The capability
1002 C corresponding to K = 0, i.e., computing y(t), is
1003 C already provided by DLSODE directly. Since
1004 C NQCUR >= 1, the first derivative dy/dt is always
1005 C available with DINTDY.
1006 C RWORK(21) The base address of the history array YH.
1007 C NYH Column length of YH, equal to the initial value of NEQ.
1008 C
1009 C The output parameters are:
1010 C
1011 C DKY Real array of length NEQ containing the computed value
1012 C of the Kth derivative of y(t).
1013 C IFLAG Integer flag, returned as 0 if K and T were legal,
1014 C -1 if K was illegal, and -2 if T was illegal.
1015 C On an error return, a message is also written.
1016 C
1017 C
1018 C Part 3. Common Blocks
1019 C ----------------------
1020 C
1021 C If DLSODE is to be used in an overlay situation, the user must
1022 C declare, in the primary overlay, the variables in:
1023 C (1) the call sequence to DLSODE,
1024 C (2) the internal COMMON block /DLS001/, of length 255
1025 C (218 double precision words followed by 37 integer words).
1026 C
1027 C If DLSODE is used on a system in which the contents of internal
1028 C COMMON blocks are not preserved between calls, the user should
1029 C declare the above COMMON block in his main program to insure that
1030 C its contents are preserved.
1031 C
1032 C If the solution of a given problem by DLSODE is to be interrupted
1033 C and then later continued, as when restarting an interrupted run or
1034 C alternating between two or more problems, the user should save,
1035 C following the return from the last DLSODE call prior to the
1036 C interruption, the contents of the call sequence variables and the
1037 C internal COMMON block, and later restore these values before the
1038 C next DLSODE call for that problem. In addition, if XSETUN and/or
1039 C XSETF was called for non-default handling of error messages, then
1040 C these calls must be repeated. To save and restore the COMMON
1041 C block, use subroutine DSRCOM (see Part 2 above).
1042 C
1043 C
1044 C Part 4. Optionally Replaceable Solver Routines
1045 C -----------------------------------------------
1046 C
1047 C Below are descriptions of two routines in the DLSODE package which
1048 C relate to the measurement of errors. Either routine can be
1049 C replaced by a user-supplied version, if desired. However, since
1050 C such a replacement may have a major impact on performance, it
1051 C should be done only when absolutely necessary, and only with great
1052 C caution. (Note: The means by which the package version of a
1053 C routine is superseded by the user's version may be system-
1054 C dependent.)
1055 C
1056 C DEWSET
1057 C ------
1058 C The following subroutine is called just before each internal
1059 C integration step, and sets the array of error weights, EWT, as
1060 C described under ITOL/RTOL/ATOL above:
1061 C
1062 C SUBROUTINE DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT)
1063 C
1064 C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODE call
1065 C sequence, YCUR contains the current dependent variable vector,
1066 C and EWT is the array of weights set by DEWSET.
1067 C
1068 C If the user supplies this subroutine, it must return in EWT(i)
1069 C (i = 1,...,NEQ) a positive quantity suitable for comparing errors
1070 C in Y(i) to. The EWT array returned by DEWSET is passed to the
1071 C DVNORM routine (see below), and also used by DLSODE in the
1072 C computation of the optional output IMXER, the diagonal Jacobian
1073 C approximation, and the increments for difference quotient
1074 C Jacobians.
1075 C
1076 C In the user-supplied version of DEWSET, it may be desirable to use
1077 C the current values of derivatives of y. Derivatives up to order NQ
1078 C are available from the history array YH, described above under
1079 C optional outputs. In DEWSET, YH is identical to the YCUR array,
1080 C extended to NQ + 1 columns with a column length of NYH and scale
1081 C factors of H**j/factorial(j). On the first call for the problem,
1082 C given by NST = 0, NQ is 1 and H is temporarily set to 1.0.
1083 C NYH is the initial value of NEQ. The quantities NQ, H, and NST
1084 C can be obtained by including in SEWSET the statements:
1085 C DOUBLE PRECISION RLS
1086 C COMMON /DLS001/ RLS(218),ILS(37)
1087 C NQ = ILS(33)
1088 C NST = ILS(34)
1089 C H = RLS(212)
1090 C Thus, for example, the current value of dy/dt can be obtained as
1091 C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is unnecessary
1092 C when NST = 0).
1093 C
1094 C DVNORM
1095 C ------
1096 C DVNORM is a real function routine which computes the weighted
1097 C root-mean-square norm of a vector v:
1098 C
1099 C d = DVNORM (n, v, w)
1100 C
1101 C where:
1102 C n = the length of the vector,
1103 C v = real array of length n containing the vector,
1104 C w = real array of length n containing weights,
1105 C d = SQRT( (1/n) * sum(v(i)*w(i))**2 ).
1106 C
1107 C DVNORM is called with n = NEQ and with w(i) = 1.0/EWT(i), where
1108 C EWT is as set by subroutine DEWSET.
1109 C
1110 C If the user supplies this function, it should return a nonnegative
1111 C value of DVNORM suitable for use in the error control in DLSODE.
1112 C None of the arguments should be altered by DVNORM. For example, a
1113 C user-supplied DVNORM routine might:
1114 C - Substitute a max-norm of (v(i)*w(i)) for the rms-norm, or
1115 C - Ignore some components of v in the norm, with the effect of
1116 C suppressing the error control on those components of Y.
1117 C ---------------------------------------------------------------------
1118 C***ROUTINES CALLED DEWSET, DINTDY, DUMACH, DSTODE, DVNORM, XERRWD
1119 C***COMMON BLOCKS DLS001
1120 C***REVISION HISTORY (YYYYMMDD)
1121 C 19791129 DATE WRITTEN
1122 C 19791213 Minor changes to declarations; DELP init. in STODE.
1123 C 19800118 Treat NEQ as array; integer declarations added throughout;
1124 C minor changes to prologue.
1125 C 19800306 Corrected TESCO(1,NQP1) setting in CFODE.
1126 C 19800519 Corrected access of YH on forced order reduction;
1127 C numerous corrections to prologues and other comments.
1128 C 19800617 In main driver, added loading of SQRT(UROUND) in RWORK;
1129 C minor corrections to main prologue.
1130 C 19800923 Added zero initialization of HU and NQU.
1131 C 19801218 Revised XERRWD routine; minor corrections to main prologue.
1132 C 19810401 Minor changes to comments and an error message.
1133 C 19810814 Numerous revisions: replaced EWT by 1/EWT; used flags
1134 C JCUR, ICF, IERPJ, IERSL between STODE and subordinates;
1135 C added tuning parameters CCMAX, MAXCOR, MSBP, MXNCF;
1136 C reorganized returns from STODE; reorganized type decls.;
1137 C fixed message length in XERRWD; changed default LUNIT to 6;
1138 C changed Common lengths; changed comments throughout.
1139 C 19870330 Major update by ACH: corrected comments throughout;
1140 C removed TRET from Common; rewrote EWSET with 4 loops;
1141 C fixed t test in INTDY; added Cray directives in STODE;
1142 C in STODE, fixed DELP init. and logic around PJAC call;
1143 C combined routines to save/restore Common;
1144 C passed LEVEL = 0 in error message calls (except run abort).
1145 C 19890426 Modified prologue to SLATEC/LDOC format. (FNF)
1146 C 19890501 Many improvements to prologue. (FNF)
1147 C 19890503 A few final corrections to prologue. (FNF)
1148 C 19890504 Minor cosmetic changes. (FNF)
1149 C 19890510 Corrected description of Y in Arguments section. (FNF)
1150 C 19890517 Minor corrections to prologue. (FNF)
1151 C 19920514 Updated with prologue edited 891025 by G. Shaw for manual.
1152 C 19920515 Converted source lines to upper case. (FNF)
1153 C 19920603 Revised XERRWD calls using mixed upper-lower case. (ACH)
1154 C 19920616 Revised prologue comment regarding CFT. (ACH)
1155 C 19921116 Revised prologue comments regarding Common. (ACH).
1156 C 19930326 Added comment about non-reentrancy. (FNF)
1157 C 19930723 Changed D1MACH to DUMACH. (FNF)
1158 C 19930801 Removed ILLIN and NTREP from Common (affects driver logic);
1159 C minor changes to prologue and internal comments;
1160 C changed Hollerith strings to quoted strings;
1161 C changed internal comments to mixed case;
1162 C replaced XERRWD with new version using character type;
1163 C changed dummy dimensions from 1 to *. (ACH)
1164 C 19930809 Changed to generic intrinsic names; changed names of
1165 C subprograms and Common blocks to DLSODE etc. (ACH)
1166 C 19930929 Eliminated use of REAL intrinsic; other minor changes. (ACH)
1167 C 20010412 Removed all 'own' variables from Common block /DLS001/
1168 C (affects declarations in 6 routines). (ACH)
1169 C 20010509 Minor corrections to prologue. (ACH)
1170 C 20031105 Restored 'own' variables to Common block /DLS001/, to
1171 C enable interrupt/restart feature. (ACH)
1172 C 20031112 Added SAVE statements for data-loaded constants.
1173 C
1174 C***END PROLOGUE DLSODE
1175 C
1176 C*Internal Notes:
1177 C
1178 C Other Routines in the DLSODE Package.
1179 C
1180 C In addition to Subroutine DLSODE, the DLSODE package includes the
1181 C following subroutines and function routines:
1182 C DINTDY computes an interpolated value of the y vector at t = TOUT.
1183 C DSTODE is the core integrator, which does one step of the
1184 C integration and the associated error control.
1185 C DCFODE sets all method coefficients and test constants.
1186 C DPREPJ computes and preprocesses the Jacobian matrix J = df/dy
1187 C and the Newton iteration matrix P = I - h*l0*J.
1188 C DSOLSY manages solution of linear system in chord iteration.
1189 C DEWSET sets the error weight vector EWT before each step.
1190 C DVNORM computes the weighted R.M.S. norm of a vector.
1191 C DSRCOM is a user-callable routine to save and restore
1192 C the contents of the internal Common block.
1193 C DGEFA and DGESL are routines from LINPACK for solving full
1194 C systems of linear algebraic equations.
1195 C DGBFA and DGBSL are routines from LINPACK for solving banded
1196 C linear systems.
1197 C DUMACH computes the unit roundoff in a machine-independent manner.
1198 C XERRWD, XSETUN, XSETF, IXSAV, IUMACH handle the printing of all
1199 C error messages and warnings. XERRWD is machine-dependent.
1200 C Note: DVNORM, DUMACH, IXSAV, and IUMACH are function routines.
1201 C All the others are subroutines.
1202 C
1203 C**End
1204 C
1205 C Declare externals.
1206  EXTERNAL dprerworkpj, dsolsy
1207  DOUBLE PRECISION dumach, dvnorm
1208 C
1209 C Declare all other variables.
1210  INTEGER init, mxstep, mxhnil, nhnil, nslast, nyh, iowns,
1211  1 icf, ierpj, iersl, jcur, jstart, kflag, l,
1212  2 lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
1213  3 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
1214  INTEGER i, i1, i2, iflag, imxer, kgo, lf0,
1215  1 leniw, lenrw, lenwm, ml, mord, mu, mxhnl0, mxstp0
1216  DOUBLE PRECISION rowns,
1217  1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
1218  DOUBLE PRECISION atoli, ayi, big, ewti, h0, hmax, hmx, rh, rtoli,
1219  1 tcrit, tdist, tnext, tol, tolsf, tp, SIZE, sum, w0
1220  dimension mord(2)
1221  LOGICAL ihit
1222  CHARACTER*80 msg
1223  SAVE mord, mxstp0, mxhnl0
1224 C-----------------------------------------------------------------------
1225 C The following internal Common block contains
1226 C (a) variables which are local to any subroutine but whose values must
1227 C be preserved between calls to the routine ("own" variables), and
1228 C (b) variables which are communicated between subroutines.
1229 C The block DLS001 is declared in subroutines DLSODE, DINTDY, DSTODE,
1230 C DPREPJ, and DSOLSY.
1231 C Groups of variables are replaced by dummy arrays in the Common
1232 C declarations in routines where those variables are not used.
1233 C-----------------------------------------------------------------------
1234  COMMON /dls001/ rowns(209),
1235  1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
1236  2 init, mxstep, mxhnil, nhnil, nslast, nyh, iowns(6),
1237  3 icf, ierpj, iersl, jcur, jstart, kflag, l,
1238  4 lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
1239  5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
1240 C
1241  DATA mord(1),mord(2)/12,5/, mxstp0/500/, mxhnl0/10/
1242 C-----------------------------------------------------------------------
1243 C Block A.
1244 C This code block is executed on every call.
1245 C It tests ISTATE and ITASK for legality and branches appropriately.
1246 C If ISTATE .GT. 1 but the flag INIT shows that initialization has
1247 C not yet been done, an error return occurs.
1248 C If ISTATE = 1 and TOUT = T, return immediately.
1249 C-----------------------------------------------------------------------
1250 C
1251 C***FIRST EXECUTABLE STATEMENT DLSODE
1252  IF (istate .LT. 1 .OR. istate .GT. 3) GO TO 601
1253  IF (itask .LT. 1 .OR. itask .GT. 5) GO TO 602
1254  IF (istate .EQ. 1) GO TO 10
1255  IF (init .EQ. 0) GO TO 603
1256  IF (istate .EQ. 2) GO TO 200
1257  GO TO 20
1258  10 init = 0
1259  IF (tout .EQ. t) RETURN
1260 C-----------------------------------------------------------------------
1261 C Block B.
1262 C The next code block is executed for the initial call (ISTATE = 1),
1263 C or for a continuation call with parameter changes (ISTATE = 3).
1264 C It contains checking of all inputs and various initializations.
1265 C
1266 C First check legality of the non-optional inputs NEQ, ITOL, IOPT,
1267 C MF, ML, and MU.
1268 C-----------------------------------------------------------------------
1269  20 IF (neq(1) .LE. 0) GO TO 604
1270  IF (istate .EQ. 1) GO TO 25
1271  IF (neq(1) .GT. n) GO TO 605
1272  25 n = neq(1)
1273  IF (itol .LT. 1 .OR. itol .GT. 4) GO TO 606
1274  IF (iopt .LT. 0 .OR. iopt .GT. 1) GO TO 607
1275  meth = mf/10
1276  miter = mf - 10*meth
1277  IF (meth .LT. 1 .OR. meth .GT. 2) GO TO 608
1278  IF (miter .LT. 0 .OR. miter .GT. 5) GO TO 608
1279  IF (miter .LE. 3) GO TO 30
1280  ml = iwork(1)
1281  mu = iwork(2)
1282  IF (ml .LT. 0 .OR. ml .GE. n) GO TO 609
1283  IF (mu .LT. 0 .OR. mu .GE. n) GO TO 610
1284  30 CONTINUE
1285 C Next process and check the optional inputs. --------------------------
1286  IF (iopt .EQ. 1) GO TO 40
1287  maxord = mord(meth)
1288  mxstep = mxstp0
1289  mxhnil = mxhnl0
1290  IF (istate .EQ. 1) h0 = 0.0d0
1291  hmxi = 0.0d0
1292  hmin = 0.0d0
1293  GO TO 60
1294  40 maxord = iwork(5)
1295  IF (maxord .LT. 0) GO TO 611
1296  IF (maxord .EQ. 0) maxord = 100
1297  maxord = min(maxord,mord(meth))
1298  mxstep = iwork(6)
1299  IF (mxstep .LT. 0) GO TO 612
1300  IF (mxstep .EQ. 0) mxstep = mxstp0
1301  mxhnil = iwork(7)
1302  IF (mxhnil .LT. 0) GO TO 613
1303  IF (mxhnil .EQ. 0) mxhnil = mxhnl0
1304  IF (istate .NE. 1) GO TO 50
1305  h0 = rwork(5)
1306  IF ((tout - t)*h0 .LT. 0.0d0) GO TO 614
1307  50 hmax = rwork(6)
1308  IF (hmax .LT. 0.0d0) GO TO 615
1309  hmxi = 0.0d0
1310  IF (hmax .GT. 0.0d0) hmxi = 1.0d0/hmax
1311  hmin = rwork(7)
1312  IF (hmin .LT. 0.0d0) GO TO 616
1313 C-----------------------------------------------------------------------
1314 C Set work array pointers and check lengths LRW and LIW.
1315 C Pointers to segments of RWORK and IWORK are named by prefixing L to
1316 C the name of the segment. E.g., the segment YH starts at RWORK(LYH).
1317 C Segments of RWORK (in order) are denoted YH, WM, EWT, SAVF, ACOR.
1318 C-----------------------------------------------------------------------
1319  60 lyh = 21
1320  IF (istate .EQ. 1) nyh = n
1321  lwm = lyh + (maxord + 1)*nyh
1322  IF (miter .EQ. 0) lenwm = 0
1323  IF (miter .EQ. 1 .OR. miter .EQ. 2) lenwm = n*n + 2
1324  IF (miter .EQ. 3) lenwm = n + 2
1325  IF (miter .GE. 4) lenwm = (2*ml + mu + 1)*n + 2
1326  lewt = lwm + lenwm
1327  lsavf = lewt + n
1328  lacor = lsavf + n
1329  lenrw = lacor + n - 1
1330  iwork(17) = lenrw
1331  liwm = 1
1332  leniw = 20 + n
1333  IF (miter .EQ. 0 .OR. miter .EQ. 3) leniw = 20
1334  iwork(18) = leniw
1335  IF (lenrw .GT. lrw) GO TO 617
1336  IF (leniw .GT. liw) GO TO 618
1337 C Check RTOL and ATOL for legality. ------------------------------------
1338  rtoli = rtol(1)
1339  atoli = atol(1)
1340  DO 70 i = 1,n
1341  IF (itol .GE. 3) rtoli = rtol(i)
1342  IF (itol .EQ. 2 .OR. itol .EQ. 4) atoli = atol(i)
1343  IF (rtoli .LT. 0.0d0) GO TO 619
1344  IF (atoli .LT. 0.0d0) GO TO 620
1345  70 CONTINUE
1346  IF (istate .EQ. 1) GO TO 100
1347 C If ISTATE = 3, set flag to signal parameter changes to DSTODE. -------
1348  jstart = -1
1349  IF (nq .LE. maxord) GO TO 90
1350 C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. ---------
1351  DO 80 i = 1,n
1352  80 rwork(i+lsavf-1) = rwork(i+lwm-1)
1353 C Reload WM(1) = RWORK(LWM), since LWM may have changed. ---------------
1354  90 IF (miter .GT. 0) rwork(lwm) = sqrt(uround)
1355  IF (n .EQ. nyh) GO TO 200
1356 C NEQ was reduced. Zero part of YH to avoid undefined references. -----
1357  i1 = lyh + l*nyh
1358  i2 = lyh + (maxord + 1)*nyh - 1
1359  IF (i1 .GT. i2) GO TO 200
1360  DO 95 i = i1,i2
1361  95 rwork(i) = 0.0d0
1362  GO TO 200
1363 C-----------------------------------------------------------------------
1364 C Block C.
1365 C The next block is for the initial call only (ISTATE = 1).
1366 C It contains all remaining initializations, the initial call to F,
1367 C and the calculation of the initial step size.
1368 C The error weights in EWT are inverted after being loaded.
1369 C-----------------------------------------------------------------------
1370  100 uround = dumach()
1371  tn = t
1372  IF (itask .NE. 4 .AND. itask .NE. 5) GO TO 110
1373  tcrit = rwork(1)
1374  IF ((tcrit - tout)*(tout - t) .LT. 0.0d0) GO TO 625
1375  IF (h0 .NE. 0.0d0 .AND. (t + h0 - tcrit)*h0 .GT. 0.0d0)
1376  1 h0 = tcrit - t
1377  110 jstart = 0
1378  IF (miter .GT. 0) rwork(lwm) = sqrt(uround)
1379  nhnil = 0
1380  nst = 0
1381  nje = 0
1382  nslast = 0
1383  hu = 0.0d0
1384  nqu = 0
1385  ccmax = 0.3d0
1386  maxcor = 3
1387  msbp = 20
1388  mxncf = 10
1389 C Initial call to F. (LF0 points to YH(*,2).) -------------------------
1390  lf0 = lyh + nyh
1391  CALL f (neq, t, y, rwork(lf0))
1392  nfe = 1
1393 C Load the initial value vector in YH. ---------------------------------
1394  DO 115 i = 1,n
1395  115 rwork(i+lyh-1) = y(i)
1396 C Load and invert the EWT array. (H is temporarily set to 1.0.) -------
1397  nq = 1
1398  h = 1.0d0
1399  CALL dewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt))
1400  DO 120 i = 1,n
1401  IF (rwork(i+lewt-1) .LE. 0.0d0) GO TO 621
1402  120 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1)
1403 C-----------------------------------------------------------------------
1404 C The coding below computes the step size, H0, to be attempted on the
1405 C first step, unless the user has supplied a value for this.
1406 C First check that TOUT - T differs significantly from zero.
1407 C A scalar tolerance quantity TOL is computed, as MAX(RTOL(I))
1408 C if this is positive, or MAX(ATOL(I)/ABS(Y(I))) otherwise, adjusted
1409 C so as to be between 100*UROUND and 1.0E-3.
1410 C Then the computed value H0 is given by..
1411 C NEQ
1412 C H0**2 = TOL / ( w0**-2 + (1/NEQ) * SUM ( f(i)/ywt(i) )**2 )
1413 C 1
1414 C where w0 = MAX ( ABS(T), ABS(TOUT) ),
1415 C f(i) = i-th component of initial value of f,
1416 C ywt(i) = EWT(i)/TOL (a weight for y(i)).
1417 C The sign of H0 is inferred from the initial values of TOUT and T.
1418 C-----------------------------------------------------------------------
1419  IF (h0 .NE. 0.0d0) GO TO 180
1420  tdist = abs(tout - t)
1421  w0 = max(abs(t),abs(tout))
1422  IF (tdist .LT. 2.0d0*uround*w0) GO TO 622
1423  tol = rtol(1)
1424  IF (itol .LE. 2) GO TO 140
1425  DO 130 i = 1,n
1426  130 tol = max(tol,rtol(i))
1427  140 IF (tol .GT. 0.0d0) GO TO 160
1428  atoli = atol(1)
1429  DO 150 i = 1,n
1430  IF (itol .EQ. 2 .OR. itol .EQ. 4) atoli = atol(i)
1431  ayi = abs(y(i))
1432  IF (ayi .NE. 0.0d0) tol = max(tol,atoli/ayi)
1433  150 CONTINUE
1434  160 tol = max(tol,100.0d0*uround)
1435  tol = min(tol,0.001d0)
1436  sum = dvnorm(n, rwork(lf0), rwork(lewt))
1437  sum = 1.0d0/(tol*w0*w0) + tol*sum**2
1438  h0 = 1.0d0/sqrt(sum)
1439  h0 = min(h0,tdist)
1440  h0 = sign(h0,tout-t)
1441 C Adjust H0 if necessary to meet HMAX bound. ---------------------------
1442  180 rh = abs(h0)*hmxi
1443  IF (rh .GT. 1.0d0) h0 = h0/rh
1444 C Load H with H0 and scale YH(*,2) by H0. ------------------------------
1445  h = h0
1446  DO 190 i = 1,n
1447  190 rwork(i+lf0-1) = h0*rwork(i+lf0-1)
1448  GO TO 270
1449 C-----------------------------------------------------------------------
1450 C Block D.
1451 C The next code block is for continuation calls only (ISTATE = 2 or 3)
1452 C and is to check stop conditions before taking a step.
1453 C-----------------------------------------------------------------------
1454  200 nslast = nst
1455  GO TO (210, 250, 220, 230, 240), itask
1456  210 IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
1457  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
1458  IF (iflag .NE. 0) GO TO 627
1459  t = tout
1460  GO TO 420
1461  220 tp = tn - hu*(1.0d0 + 100.0d0*uround)
1462  IF ((tp - tout)*h .GT. 0.0d0) GO TO 623
1463  IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
1464  GO TO 400
1465  230 tcrit = rwork(1)
1466  IF ((tn - tcrit)*h .GT. 0.0d0) GO TO 624
1467  IF ((tcrit - tout)*h .LT. 0.0d0) GO TO 625
1468  IF ((tn - tout)*h .LT. 0.0d0) GO TO 245
1469  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
1470  IF (iflag .NE. 0) GO TO 627
1471  t = tout
1472  GO TO 420
1473  240 tcrit = rwork(1)
1474  IF ((tn - tcrit)*h .GT. 0.0d0) GO TO 624
1475  245 hmx = abs(tn) + abs(h)
1476  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
1477  IF (ihit) GO TO 400
1478  tnext = tn + h*(1.0d0 + 4.0d0*uround)
1479  IF ((tnext - tcrit)*h .LE. 0.0d0) GO TO 250
1480  h = (tcrit - tn)*(1.0d0 - 4.0d0*uround)
1481  IF (istate .EQ. 2) jstart = -2
1482 C-----------------------------------------------------------------------
1483 C Block E.
1484 C The next block is normally executed for all calls and contains
1485 C the call to the one-step core integrator DSTODE.
1486 C
1487 C This is a looping point for the integration steps.
1488 C
1489 C First check for too many steps being taken, update EWT (if not at
1490 C start of problem), check for too much accuracy being requested, and
1491 C check for H below the roundoff level in T.
1492 C-----------------------------------------------------------------------
1493  250 CONTINUE
1494  IF ((nst-nslast) .GE. mxstep) GO TO 500
1495  CALL dewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt))
1496  DO 260 i = 1,n
1497  IF (rwork(i+lewt-1) .LE. 0.0d0) GO TO 510
1498  260 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1)
1499  270 tolsf = uround*dvnorm(n, rwork(lyh), rwork(lewt))
1500  IF (tolsf .LE. 1.0d0) GO TO 280
1501  tolsf = tolsf*2.0d0
1502  IF (nst .EQ. 0) GO TO 626
1503  GO TO 520
1504  280 IF ((tn + h) .NE. tn) GO TO 290
1505  nhnil = nhnil + 1
1506  IF (nhnil .GT. mxhnil) GO TO 290
1507  msg = 'DLSODE- Warning..internal T (=R1) and H (=R2) are'
1508  CALL xerrwd (msg, 50, 101, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
1509  msg=' such that in the machine, T + H = T on the next step '
1510  CALL xerrwd (msg, 60, 101, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
1511  msg = ' (H = step size). Solver will continue anyway'
1512  CALL xerrwd (msg, 50, 101, 0, 0, 0, 0, 2, tn, h)
1513  IF (nhnil .LT. mxhnil) GO TO 290
1514  msg = 'DLSODE- Above warning has been issued I1 times. '
1515  CALL xerrwd (msg, 50, 102, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
1516  msg = ' It will not be issued again for this problem'
1517  CALL xerrwd (msg, 50, 102, 0, 1, mxhnil, 0, 0, 0.0d0, 0.0d0)
1518  290 CONTINUE
1519 C-----------------------------------------------------------------------
1520 C CALL DSTODE(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,IWM,F,JAC,DPREPJ,DSOLSY)
1521 C-----------------------------------------------------------------------
1522  CALL dstode (neq, y, rwork(lyh), nyh, rwork(lyh), rwork(lewt),
1523  1 rwork(lsavf), rwork(lacor), rwork(lwm), iwork(liwm),
1524  2 f, jac, dprepj, dsolsy)
1525  kgo = 1 - kflag
1526  GO TO (300, 530, 540), kgo
1527 C-----------------------------------------------------------------------
1528 C Block F.
1529 C The following block handles the case of a successful return from the
1530 C core integrator (KFLAG = 0). Test for stop conditions.
1531 C-----------------------------------------------------------------------
1532  300 init = 1
1533  GO TO (310, 400, 330, 340, 350), itask
1534 C ITASK = 1. If TOUT has been reached, interpolate. -------------------
1535  310 IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
1536  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
1537  t = tout
1538  GO TO 420
1539 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------
1540  330 IF ((tn - tout)*h .GE. 0.0d0) GO TO 400
1541  GO TO 250
1542 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary.
1543  340 IF ((tn - tout)*h .LT. 0.0d0) GO TO 345
1544  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
1545  t = tout
1546  GO TO 420
1547  345 hmx = abs(tn) + abs(h)
1548  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
1549  IF (ihit) GO TO 400
1550  tnext = tn + h*(1.0d0 + 4.0d0*uround)
1551  IF ((tnext - tcrit)*h .LE. 0.0d0) GO TO 250
1552  h = (tcrit - tn)*(1.0d0 - 4.0d0*uround)
1553  jstart = -2
1554  GO TO 250
1555 C ITASK = 5. See if TCRIT was reached and jump to exit. ---------------
1556  350 hmx = abs(tn) + abs(h)
1557  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
1558 C-----------------------------------------------------------------------
1559 C Block G.
1560 C The following block handles all successful returns from DLSODE.
1561 C If ITASK .NE. 1, Y is loaded from YH and T is set accordingly.
1562 C ISTATE is set to 2, and the optional outputs are loaded into the
1563 C work arrays before returning.
1564 C-----------------------------------------------------------------------
1565  400 DO 410 i = 1,n
1566  410 y(i) = rwork(i+lyh-1)
1567  t = tn
1568  IF (itask .NE. 4 .AND. itask .NE. 5) GO TO 420
1569  IF (ihit) t = tcrit
1570  420 istate = 2
1571  rwork(11) = hu
1572  rwork(12) = h
1573  rwork(13) = tn
1574  iwork(11) = nst
1575  iwork(12) = nfe
1576  iwork(13) = nje
1577  iwork(14) = nqu
1578  iwork(15) = nq
1579  RETURN
1580 C-----------------------------------------------------------------------
1581 C Block H.
1582 C The following block handles all unsuccessful returns other than
1583 C those for illegal input. First the error message routine is called.
1584 C If there was an error test or convergence test failure, IMXER is set.
1585 C Then Y is loaded from YH and T is set to TN. The optional outputs
1586 C are loaded into the work arrays before returning.
1587 C-----------------------------------------------------------------------
1588 C The maximum number of steps was taken before reaching TOUT. ----------
1589  500 msg = 'DLSODE- At current T (=R1), MXSTEP (=I1) steps '
1590  CALL xerrwd (msg, 50, 201, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
1591  msg = ' taken on this call before reaching TOUT '
1592  CALL xerrwd (msg, 50, 201, 0, 1, mxstep, 0, 1, tn, 0.0d0)
1593  istate = -1
1594  GO TO 580
1595 C EWT(I) .LE. 0.0 for some I (not at start of problem). ----------------
1596  510 ewti = rwork(lewt+i-1)
1597  msg = .LE.'DLSODE- At T (=R1), EWT(I1) has become R2 0.'
1598  CALL xerrwd (msg, 50, 202, 0, 1, i, 0, 2, tn, ewti)
1599  istate = -6
1600  GO TO 580
1601 C Too much accuracy requested for machine precision. -------------------
1602  520 msg = 'DLSODE- At T (=R1), too much accuracy requested '
1603  CALL xerrwd (msg, 50, 203, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
1604  msg = ' for precision of machine.. see TOLSF (=R2) '
1605  CALL xerrwd (msg, 50, 203, 0, 0, 0, 0, 2, tn, tolsf)
1606  rwork(14) = tolsf
1607  istate = -2
1608  GO TO 580
1609 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. -----
1610  530 msg = 'DLSODE- At T(=R1) and step size H(=R2), the error'
1611  CALL xerrwd (msg, 50, 204, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
1612  msg = ' test failed repeatedly or with ABS(H) = HMIN'
1613  CALL xerrwd (msg, 50, 204, 0, 0, 0, 0, 2, tn, h)
1614  istate = -4
1615  GO TO 560
1616 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ----
1617  540 msg = 'DLSODE- At T (=R1) and step size H (=R2), the '
1618  CALL xerrwd (msg, 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
1619  msg = ' corrector convergence failed repeatedly '
1620  CALL xerrwd (msg, 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
1621  msg = ' or with ABS(H) = HMIN '
1622  CALL xerrwd (msg, 30, 205, 0, 0, 0, 0, 2, tn, h)
1623  istate = -5
1624 C Compute IMXER if relevant. -------------------------------------------
1625  560 big = 0.0d0
1626  imxer = 1
1627  DO 570 i = 1,n
1628  SIZE = abs(rwork(i+lacor-1)*rwork(i+lewt-1))
1629  IF (big .GE. size) GO TO 570
1630  big = SIZE
1631  imxer = i
1632  570 CONTINUE
1633  iwork(16) = imxer
1634 C Set Y vector, T, and optional outputs. -------------------------------
1635  580 DO 590 i = 1,n
1636  590 y(i) = rwork(i+lyh-1)
1637  t = tn
1638  rwork(11) = hu
1639  rwork(12) = h
1640  rwork(13) = tn
1641  iwork(11) = nst
1642  iwork(12) = nfe
1643  iwork(13) = nje
1644  iwork(14) = nqu
1645  iwork(15) = nq
1646  RETURN
1647 C-----------------------------------------------------------------------
1648 C Block I.
1649 C The following block handles all error returns due to illegal input
1650 C (ISTATE = -3), as detected before calling the core integrator.
1651 C First the error message routine is called. If the illegal input
1652 C is a negative ISTATE, the run is aborted (apparent infinite loop).
1653 C-----------------------------------------------------------------------
1654  601 msg = 'DLSODE- ISTATE (=I1) illegal '
1655  CALL xerrwd (msg, 30, 1, 0, 1, istate, 0, 0, 0.0d0, 0.0d0)
1656  IF (istate .LT. 0) GO TO 800
1657  GO TO 700
1658  602 msg = 'DLSODE- ITASK (=I1) illegal '
1659  CALL xerrwd (msg, 30, 2, 0, 1, itask, 0, 0, 0.0d0, 0.0d0)
1660  GO TO 700
1661  603 msg = .GT.'DLSODE- ISTATE 1 but DLSODE not initialized '
1662  CALL xerrwd (msg, 50, 3, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
1663  GO TO 700
1664  604 msg = .LT.'DLSODE- NEQ (=I1) 1 '
1665  CALL xerrwd (msg, 30, 4, 0, 1, neq(1), 0, 0, 0.0d0, 0.0d0)
1666  GO TO 700
1667  605 msg = 'DLSODE- ISTATE = 3 and NEQ increased (I1 to I2) '
1668  CALL xerrwd (msg, 50, 5, 0, 2, n, neq(1), 0, 0.0d0, 0.0d0)
1669  GO TO 700
1670  606 msg = 'DLSODE- ITOL (=I1) illegal '
1671  CALL xerrwd (msg, 30, 6, 0, 1, itol, 0, 0, 0.0d0, 0.0d0)
1672  GO TO 700
1673  607 msg = 'DLSODE- IOPT (=I1) illegal '
1674  CALL xerrwd (msg, 30, 7, 0, 1, iopt, 0, 0, 0.0d0, 0.0d0)
1675  GO TO 700
1676  608 msg = 'DLSODE- MF (=I1) illegal '
1677  CALL xerrwd (msg, 30, 8, 0, 1, mf, 0, 0, 0.0d0, 0.0d0)
1678  GO TO 700
1679  609 msg = .LT..GE.'DLSODE- ML (=I1) illegal.. 0 or NEQ (=I2)'
1680  CALL xerrwd (msg, 50, 9, 0, 2, ml, neq(1), 0, 0.0d0, 0.0d0)
1681  GO TO 700
1682  610 msg = .LT..GE.'DLSODE- MU (=I1) illegal.. 0 or NEQ (=I2)'
1683  CALL xerrwd (msg, 50, 10, 0, 2, mu, neq(1), 0, 0.0d0, 0.0d0)
1684  GO TO 700
1685  611 msg = .LT.'DLSODE- MAXORD (=I1) 0 '
1686  CALL xerrwd (msg, 30, 11, 0, 1, maxord, 0, 0, 0.0d0, 0.0d0)
1687  GO TO 700
1688  612 msg = .LT.'DLSODE- MXSTEP (=I1) 0 '
1689  CALL xerrwd (msg, 30, 12, 0, 1, mxstep, 0, 0, 0.0d0, 0.0d0)
1690  GO TO 700
1691  613 msg = .LT.'DLSODE- MXHNIL (=I1) 0 '
1692  CALL xerrwd (msg, 30, 13, 0, 1, mxhnil, 0, 0, 0.0d0, 0.0d0)
1693  GO TO 700
1694  614 msg = 'DLSODE- TOUT (=R1) behind T (=R2) '
1695  CALL xerrwd (msg, 40, 14, 0, 0, 0, 0, 2, tout, t)
1696  msg = ' Integration direction is given by H0 (=R1) '
1697  CALL xerrwd (msg, 50, 14, 0, 0, 0, 0, 1, h0, 0.0d0)
1698  GO TO 700
1699  615 msg = .LT.'DLSODE- HMAX (=R1) 0.0 '
1700  CALL xerrwd (msg, 30, 15, 0, 0, 0, 0, 1, hmax, 0.0d0)
1701  GO TO 700
1702  616 msg = .LT.'DLSODE- HMIN (=R1) 0.0 '
1703  CALL xerrwd (msg, 30, 16, 0, 0, 0, 0, 1, hmin, 0.0d0)
1704  GO TO 700
1705  617 CONTINUE
1706  msg='DLSODE- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)'
1707  CALL xerrwd (msg, 60, 17, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0)
1708  GO TO 700
1709  618 CONTINUE
1710  msg='DLSODE- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)'
1711  CALL xerrwd (msg, 60, 18, 0, 2, leniw, liw, 0, 0.0d0, 0.0d0)
1712  GO TO 700
1713  619 msg = .LT.'DLSODE- RTOL(I1) is R1 0.0 '
1714  CALL xerrwd (msg, 40, 19, 0, 1, i, 0, 1, rtoli, 0.0d0)
1715  GO TO 700
1716  620 msg = .LT.'DLSODE- ATOL(I1) is R1 0.0 '
1717  CALL xerrwd (msg, 40, 20, 0, 1, i, 0, 1, atoli, 0.0d0)
1718  GO TO 700
1719  621 ewti = rwork(lewt+i-1)
1720  msg = .LE.'DLSODE- EWT(I1) is R1 0.0 '
1721  CALL xerrwd (msg, 40, 21, 0, 1, i, 0, 1, ewti, 0.0d0)
1722  GO TO 700
1723  622 CONTINUE
1724  msg='DLSODE- TOUT (=R1) too close to T(=R2) to start integration'
1725  CALL xerrwd (msg, 60, 22, 0, 0, 0, 0, 2, tout, t)
1726  GO TO 700
1727  623 CONTINUE
1728  msg='DLSODE- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) '
1729  CALL xerrwd (msg, 60, 23, 0, 1, itask, 0, 2, tout, tp)
1730  GO TO 700
1731  624 CONTINUE
1732  msg='DLSODE- ITASK = 4 OR 5 and TCRIT (=R1) behind TCUR (=R2) '
1733  CALL xerrwd (msg, 60, 24, 0, 0, 0, 0, 2, tcrit, tn)
1734  GO TO 700
1735  625 CONTINUE
1736  msg='DLSODE- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) '
1737  CALL xerrwd (msg, 60, 25, 0, 0, 0, 0, 2, tcrit, tout)
1738  GO TO 700
1739  626 msg = 'DLSODE- At start of problem, too much accuracy '
1740  CALL xerrwd (msg, 50, 26, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
1741  msg=' requested for precision of machine.. See TOLSF (=R1) '
1742  CALL xerrwd (msg, 60, 26, 0, 0, 0, 0, 1, tolsf, 0.0d0)
1743  rwork(14) = tolsf
1744  GO TO 700
1745  627 msg = 'DLSODE- Trouble in DINTDY. ITASK = I1, TOUT = R1'
1746  CALL xerrwd (msg, 50, 27, 0, 1, itask, 0, 1, tout, 0.0d0)
1747 C
1748  700 istate = -3
1749  RETURN
1750 C
1751  800 msg = 'DLSODE- Run aborted.. apparent infinite loop '
1752  CALL xerrwd (msg, 50, 303, 2, 0, 0, 0, 0, 0.0d0, 0.0d0)
1753  RETURN
1754 C----------------------- END OF SUBROUTINE DLSODE ----------------------
1755  END
1756 *DECK DLSODES
1757  SUBROUTINE dlsodes (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK,
1758  1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF)
1759  EXTERNAL f, jac
1760  INTEGER neq, itol, itask, istate, iopt, lrw, iwork, liw, mf
1761  DOUBLE PRECISION y, t, tout, rtol, atol, rwork
1762  dimension neq(*), y(*), rtol(*), atol(*), rwork(lrw), iwork(liw)
1763 C-----------------------------------------------------------------------
1764 C This is the 12 November 2003 version of
1765 C DLSODES: Livermore Solver for Ordinary Differential Equations
1766 C with general Sparse Jacobian matrix.
1767 C
1768 C This version is in double precision.
1769 C
1770 C DLSODES solves the initial value problem for stiff or nonstiff
1771 C systems of first order ODEs,
1772 C dy/dt = f(t,y) , or, in component form,
1773 C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ).
1774 C DLSODES is a variant of the DLSODE package, and is intended for
1775 C problems in which the Jacobian matrix df/dy has an arbitrary
1776 C sparse structure (when the problem is stiff).
1777 C
1778 C Authors: Alan C. Hindmarsh
1779 C Center for Applied Scientific Computing, L-561
1780 C Lawrence Livermore National Laboratory
1781 C Livermore, CA 94551
1782 C and
1783 C Andrew H. Sherman
1784 C J. S. Nolen and Associates
1785 C Houston, TX 77084
1786 C-----------------------------------------------------------------------
1787 C References:
1788 C 1. Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE
1789 C Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.),
1790 C North-Holland, Amsterdam, 1983, pp. 55-64.
1791 C
1792 C 2. S. C. Eisenstat, M. C. Gursky, M. H. Schultz, and A. H. Sherman,
1793 C Yale Sparse Matrix Package: I. The Symmetric Codes,
1794 C Int. J. Num. Meth. Eng., 18 (1982), pp. 1145-1151.
1795 C
1796 C 3. S. C. Eisenstat, M. C. Gursky, M. H. Schultz, and A. H. Sherman,
1797 C Yale Sparse Matrix Package: II. The Nonsymmetric Codes,
1798 C Research Report No. 114, Dept. of Computer Sciences, Yale
1799 C University, 1977.
1800 C-----------------------------------------------------------------------
1801 C Summary of Usage.
1802 C
1803 C Communication between the user and the DLSODES package, for normal
1804 C situations, is summarized here. This summary describes only a subset
1805 C of the full set of options available. See the full description for
1806 C details, including optional communication, nonstandard options,
1807 C and instructions for special situations. See also the example
1808 C problem (with program and output) following this summary.
1809 C
1810 C A. First provide a subroutine of the form:
1811 C SUBROUTINE F (NEQ, T, Y, YDOT)
1812 C DOUBLE PRECISION T, Y(*), YDOT(*)
1813 C which supplies the vector function f by loading YDOT(i) with f(i).
1814 C
1815 C B. Next determine (or guess) whether or not the problem is stiff.
1816 C Stiffness occurs when the Jacobian matrix df/dy has an eigenvalue
1817 C whose real part is negative and large in magnitude, compared to the
1818 C reciprocal of the t span of interest. If the problem is nonstiff,
1819 C use a method flag MF = 10. If it is stiff, there are two standard
1820 C choices for the method flag, MF = 121 and MF = 222. In both cases,
1821 C DLSODES requires the Jacobian matrix in some form, and it treats this
1822 C matrix in general sparse form, with sparsity structure determined
1823 C internally. (For options where the user supplies the sparsity
1824 C structure, see the full description of MF below.)
1825 C
1826 C C. If the problem is stiff, you are encouraged to supply the Jacobian
1827 C directly (MF = 121), but if this is not feasible, DLSODES will
1828 C compute it internally by difference quotients (MF = 222).
1829 C If you are supplying the Jacobian, provide a subroutine of the form:
1830 C SUBROUTINE JAC (NEQ, T, Y, J, IAN, JAN, PDJ)
1831 C DOUBLE PRECISION T, Y(*), IAN(*), JAN(*), PDJ(*)
1832 C Here NEQ, T, Y, and J are input arguments, and the JAC routine is to
1833 C load the array PDJ (of length NEQ) with the J-th column of df/dy.
1834 C I.e., load PDJ(i) with df(i)/dy(J) for all relevant values of i.
1835 C The arguments IAN and JAN should be ignored for normal situations.
1836 C DLSODES will call the JAC routine with J = 1,2,...,NEQ.
1837 C Only nonzero elements need be loaded. Usually, a crude approximation
1838 C to df/dy, possibly with fewer nonzero elements, will suffice.
1839 C
1840 C D. Write a main program which calls Subroutine DLSODES once for
1841 C each point at which answers are desired. This should also provide
1842 C for possible use of logical unit 6 for output of error messages by
1843 C DLSODES. On the first call to DLSODES, supply arguments as follows:
1844 C F = name of subroutine for right-hand side vector f.
1845 C This name must be declared External in calling program.
1846 C NEQ = number of first order ODEs.
1847 C Y = array of initial values, of length NEQ.
1848 C T = the initial value of the independent variable t.
1849 C TOUT = first point where output is desired (.ne. T).
1850 C ITOL = 1 or 2 according as ATOL (below) is a scalar or array.
1851 C RTOL = relative tolerance parameter (scalar).
1852 C ATOL = absolute tolerance parameter (scalar or array).
1853 C The estimated local error in Y(i) will be controlled so as
1854 C to be roughly less (in magnitude) than
1855 C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or
1856 C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2.
1857 C Thus the local error test passes if, in each component,
1858 C either the absolute error is less than ATOL (or ATOL(i)),
1859 C or the relative error is less than RTOL.
1860 C Use RTOL = 0.0 for pure absolute error control, and
1861 C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error
1862 C control. Caution: actual (global) errors may exceed these
1863 C local tolerances, so choose them conservatively.
1864 C ITASK = 1 for normal computation of output values of Y at t = TOUT.
1865 C ISTATE = integer flag (input and output). Set ISTATE = 1.
1866 C IOPT = 0 to indicate no optional inputs used.
1867 C RWORK = real work array of length at least:
1868 C 20 + 16*NEQ for MF = 10,
1869 C 20 + (2 + 1./LENRAT)*NNZ + (11 + 9./LENRAT)*NEQ
1870 C for MF = 121 or 222,
1871 C where:
1872 C NNZ = the number of nonzero elements in the sparse
1873 C Jacobian (if this is unknown, use an estimate), and
1874 C LENRAT = the real to integer wordlength ratio (usually 1 in
1875 C single precision and 2 in double precision).
1876 C In any case, the required size of RWORK cannot generally
1877 C be predicted in advance if MF = 121 or 222, and the value
1878 C above is a rough estimate of a crude lower bound. Some
1879 C experimentation with this size may be necessary.
1880 C (When known, the correct required length is an optional
1881 C output, available in IWORK(17).)
1882 C LRW = declared length of RWORK (in user dimension).
1883 C IWORK = integer work array of length at least 30.
1884 C LIW = declared length of IWORK (in user dimension).
1885 C JAC = name of subroutine for Jacobian matrix (MF = 121).
1886 C If used, this name must be declared External in calling
1887 C program. If not used, pass a dummy name.
1888 C MF = method flag. Standard values are:
1889 C 10 for nonstiff (Adams) method, no Jacobian used
1890 C 121 for stiff (BDF) method, user-supplied sparse Jacobian
1891 C 222 for stiff method, internally generated sparse Jacobian
1892 C Note that the main program must declare arrays Y, RWORK, IWORK,
1893 C and possibly ATOL.
1894 C
1895 C E. The output from the first call (or any call) is:
1896 C Y = array of computed values of y(t) vector.
1897 C T = corresponding value of independent variable (normally TOUT).
1898 C ISTATE = 2 if DLSODES was successful, negative otherwise.
1899 C -1 means excess work done on this call (perhaps wrong MF).
1900 C -2 means excess accuracy requested (tolerances too small).
1901 C -3 means illegal input detected (see printed message).
1902 C -4 means repeated error test failures (check all inputs).
1903 C -5 means repeated convergence failures (perhaps bad Jacobian
1904 C supplied or wrong choice of MF or tolerances).
1905 C -6 means error weight became zero during problem. (Solution
1906 C component i vanished, and ATOL or ATOL(i) = 0.)
1907 C -7 means a fatal error return flag came from sparse solver
1908 C CDRV by way of DPRJS or DSOLSS. Should never happen.
1909 C A return with ISTATE = -1, -4, or -5 may result from using
1910 C an inappropriate sparsity structure, one that is quite
1911 C different from the initial structure. Consider calling
1912 C DLSODES again with ISTATE = 3 to force the structure to be
1913 C reevaluated. See the full description of ISTATE below.
1914 C
1915 C F. To continue the integration after a successful return, simply
1916 C reset TOUT and call DLSODES again. No other parameters need be reset.
1917 C
1918 C-----------------------------------------------------------------------
1919 C Example Problem.
1920 C
1921 C The following is a simple example problem, with the coding
1922 C needed for its solution by DLSODES. The problem is from chemical
1923 C kinetics, and consists of the following 12 rate equations:
1924 C dy1/dt = -rk1*y1
1925 C dy2/dt = rk1*y1 + rk11*rk14*y4 + rk19*rk14*y5
1926 C - rk3*y2*y3 - rk15*y2*y12 - rk2*y2
1927 C dy3/dt = rk2*y2 - rk5*y3 - rk3*y2*y3 - rk7*y10*y3
1928 C + rk11*rk14*y4 + rk12*rk14*y6
1929 C dy4/dt = rk3*y2*y3 - rk11*rk14*y4 - rk4*y4
1930 C dy5/dt = rk15*y2*y12 - rk19*rk14*y5 - rk16*y5
1931 C dy6/dt = rk7*y10*y3 - rk12*rk14*y6 - rk8*y6
1932 C dy7/dt = rk17*y10*y12 - rk20*rk14*y7 - rk18*y7
1933 C dy8/dt = rk9*y10 - rk13*rk14*y8 - rk10*y8
1934 C dy9/dt = rk4*y4 + rk16*y5 + rk8*y6 + rk18*y7
1935 C dy10/dt = rk5*y3 + rk12*rk14*y6 + rk20*rk14*y7
1936 C + rk13*rk14*y8 - rk7*y10*y3 - rk17*y10*y12
1937 C - rk6*y10 - rk9*y10
1938 C dy11/dt = rk10*y8
1939 C dy12/dt = rk6*y10 + rk19*rk14*y5 + rk20*rk14*y7
1940 C - rk15*y2*y12 - rk17*y10*y12
1941 C
1942 C with rk1 = rk5 = 0.1, rk4 = rk8 = rk16 = rk18 = 2.5,
1943 C rk10 = 5.0, rk2 = rk6 = 10.0, rk14 = 30.0,
1944 C rk3 = rk7 = rk9 = rk11 = rk12 = rk13 = rk19 = rk20 = 50.0,
1945 C rk15 = rk17 = 100.0.
1946 C
1947 C The t interval is from 0 to 1000, and the initial conditions
1948 C are y1 = 1, y2 = y3 = ... = y12 = 0. The problem is stiff.
1949 C
1950 C The following coding solves this problem with DLSODES, using MF = 121
1951 C and printing results at t = .1, 1., 10., 100., 1000. It uses
1952 C ITOL = 1 and mixed relative/absolute tolerance controls.
1953 C During the run and at the end, statistical quantities of interest
1954 C are printed (see optional outputs in the full description below).
1955 C
1956 C EXTERNAL FEX, JEX
1957 C DOUBLE PRECISION ATOL, RTOL, RWORK, T, TOUT, Y
1958 C DIMENSION Y(12), RWORK(500), IWORK(30)
1959 C DATA LRW/500/, LIW/30/
1960 C NEQ = 12
1961 C DO 10 I = 1,NEQ
1962 C 10 Y(I) = 0.0D0
1963 C Y(1) = 1.0D0
1964 C T = 0.0D0
1965 C TOUT = 0.1D0
1966 C ITOL = 1
1967 C RTOL = 1.0D-4
1968 C ATOL = 1.0D-6
1969 C ITASK = 1
1970 C ISTATE = 1
1971 C IOPT = 0
1972 C MF = 121
1973 C DO 40 IOUT = 1,5
1974 C CALL DLSODES (FEX, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL,
1975 C 1 ITASK, ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JEX, MF)
1976 C WRITE(6,30)T,IWORK(11),RWORK(11),(Y(I),I=1,NEQ)
1977 C 30 FORMAT(//' At t =',D11.3,4X,
1978 C 1 ' No. steps =',I5,4X,' Last step =',D11.3/
1979 C 2 ' Y array = ',4D14.5/13X,4D14.5/13X,4D14.5)
1980 C IF (ISTATE .LT. 0) GO TO 80
1981 C TOUT = TOUT*10.0D0
1982 C 40 CONTINUE
1983 C LENRW = IWORK(17)
1984 C LENIW = IWORK(18)
1985 C NST = IWORK(11)
1986 C NFE = IWORK(12)
1987 C NJE = IWORK(13)
1988 C NLU = IWORK(21)
1989 C NNZ = IWORK(19)
1990 C NNZLU = IWORK(25) + IWORK(26) + NEQ
1991 C WRITE (6,70) LENRW,LENIW,NST,NFE,NJE,NLU,NNZ,NNZLU
1992 C 70 FORMAT(//' Required RWORK size =',I4,' IWORK size =',I4/
1993 C 1 ' No. steps =',I4,' No. f-s =',I4,' No. J-s =',I4,
1994 C 2 ' No. LU-s =',I4/' No. of nonzeros in J =',I5,
1995 C 3 ' No. of nonzeros in LU =',I5)
1996 C STOP
1997 C 80 WRITE(6,90)ISTATE
1998 C 90 FORMAT(///' Error halt.. ISTATE =',I3)
1999 C STOP
2000 C END
2001 C
2002 C SUBROUTINE FEX (NEQ, T, Y, YDOT)
2003 C DOUBLE PRECISION T, Y, YDOT
2004 C DOUBLE PRECISION RK1, RK2, RK3, RK4, RK5, RK6, RK7, RK8, RK9,
2005 C 1 RK10, RK11, RK12, RK13, RK14, RK15, RK16, RK17
2006 C DIMENSION Y(12), YDOT(12)
2007 C DATA RK1/0.1D0/, RK2/10.0D0/, RK3/50.0D0/, RK4/2.5D0/, RK5/0.1D0/,
2008 C 1 RK6/10.0D0/, RK7/50.0D0/, RK8/2.5D0/, RK9/50.0D0/, RK10/5.0D0/,
2009 C 2 RK11/50.0D0/, RK12/50.0D0/, RK13/50.0D0/, RK14/30.0D0/,
2010 C 3 RK15/100.0D0/, RK16/2.5D0/, RK17/100.0D0/, RK18/2.5D0/,
2011 C 4 RK19/50.0D0/, RK20/50.0D0/
2012 C YDOT(1) = -RK1*Y(1)
2013 C YDOT(2) = RK1*Y(1) + RK11*RK14*Y(4) + RK19*RK14*Y(5)
2014 C 1 - RK3*Y(2)*Y(3) - RK15*Y(2)*Y(12) - RK2*Y(2)
2015 C YDOT(3) = RK2*Y(2) - RK5*Y(3) - RK3*Y(2)*Y(3) - RK7*Y(10)*Y(3)
2016 C 1 + RK11*RK14*Y(4) + RK12*RK14*Y(6)
2017 C YDOT(4) = RK3*Y(2)*Y(3) - RK11*RK14*Y(4) - RK4*Y(4)
2018 C YDOT(5) = RK15*Y(2)*Y(12) - RK19*RK14*Y(5) - RK16*Y(5)
2019 C YDOT(6) = RK7*Y(10)*Y(3) - RK12*RK14*Y(6) - RK8*Y(6)
2020 C YDOT(7) = RK17*Y(10)*Y(12) - RK20*RK14*Y(7) - RK18*Y(7)
2021 C YDOT(8) = RK9*Y(10) - RK13*RK14*Y(8) - RK10*Y(8)
2022 C YDOT(9) = RK4*Y(4) + RK16*Y(5) + RK8*Y(6) + RK18*Y(7)
2023 C YDOT(10) = RK5*Y(3) + RK12*RK14*Y(6) + RK20*RK14*Y(7)
2024 C 1 + RK13*RK14*Y(8) - RK7*Y(10)*Y(3) - RK17*Y(10)*Y(12)
2025 C 2 - RK6*Y(10) - RK9*Y(10)
2026 C YDOT(11) = RK10*Y(8)
2027 C YDOT(12) = RK6*Y(10) + RK19*RK14*Y(5) + RK20*RK14*Y(7)
2028 C 1 - RK15*Y(2)*Y(12) - RK17*Y(10)*Y(12)
2029 C RETURN
2030 C END
2031 C
2032 C SUBROUTINE JEX (NEQ, T, Y, J, IA, JA, PDJ)
2033 C DOUBLE PRECISION T, Y, PDJ
2034 C DOUBLE PRECISION RK1, RK2, RK3, RK4, RK5, RK6, RK7, RK8, RK9,
2035 C 1 RK10, RK11, RK12, RK13, RK14, RK15, RK16, RK17
2036 C DIMENSION Y(12), IA(*), JA(*), PDJ(12)
2037 C DATA RK1/0.1D0/, RK2/10.0D0/, RK3/50.0D0/, RK4/2.5D0/, RK5/0.1D0/,
2038 C 1 RK6/10.0D0/, RK7/50.0D0/, RK8/2.5D0/, RK9/50.0D0/, RK10/5.0D0/,
2039 C 2 RK11/50.0D0/, RK12/50.0D0/, RK13/50.0D0/, RK14/30.0D0/,
2040 C 3 RK15/100.0D0/, RK16/2.5D0/, RK17/100.0D0/, RK18/2.5D0/,
2041 C 4 RK19/50.0D0/, RK20/50.0D0/
2042 C GO TO (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12), J
2043 C 1 PDJ(1) = -RK1
2044 C PDJ(2) = RK1
2045 C RETURN
2046 C 2 PDJ(2) = -RK3*Y(3) - RK15*Y(12) - RK2
2047 C PDJ(3) = RK2 - RK3*Y(3)
2048 C PDJ(4) = RK3*Y(3)
2049 C PDJ(5) = RK15*Y(12)
2050 C PDJ(12) = -RK15*Y(12)
2051 C RETURN
2052 C 3 PDJ(2) = -RK3*Y(2)
2053 C PDJ(3) = -RK5 - RK3*Y(2) - RK7*Y(10)
2054 C PDJ(4) = RK3*Y(2)
2055 C PDJ(6) = RK7*Y(10)
2056 C PDJ(10) = RK5 - RK7*Y(10)
2057 C RETURN
2058 C 4 PDJ(2) = RK11*RK14
2059 C PDJ(3) = RK11*RK14
2060 C PDJ(4) = -RK11*RK14 - RK4
2061 C PDJ(9) = RK4
2062 C RETURN
2063 C 5 PDJ(2) = RK19*RK14
2064 C PDJ(5) = -RK19*RK14 - RK16
2065 C PDJ(9) = RK16
2066 C PDJ(12) = RK19*RK14
2067 C RETURN
2068 C 6 PDJ(3) = RK12*RK14
2069 C PDJ(6) = -RK12*RK14 - RK8
2070 C PDJ(9) = RK8
2071 C PDJ(10) = RK12*RK14
2072 C RETURN
2073 C 7 PDJ(7) = -RK20*RK14 - RK18
2074 C PDJ(9) = RK18
2075 C PDJ(10) = RK20*RK14
2076 C PDJ(12) = RK20*RK14
2077 C RETURN
2078 C 8 PDJ(8) = -RK13*RK14 - RK10
2079 C PDJ(10) = RK13*RK14
2080 C PDJ(11) = RK10
2081 C 9 RETURN
2082 C 10 PDJ(3) = -RK7*Y(3)
2083 C PDJ(6) = RK7*Y(3)
2084 C PDJ(7) = RK17*Y(12)
2085 C PDJ(8) = RK9
2086 C PDJ(10) = -RK7*Y(3) - RK17*Y(12) - RK6 - RK9
2087 C PDJ(12) = RK6 - RK17*Y(12)
2088 C 11 RETURN
2089 C 12 PDJ(2) = -RK15*Y(2)
2090 C PDJ(5) = RK15*Y(2)
2091 C PDJ(7) = RK17*Y(10)
2092 C PDJ(10) = -RK17*Y(10)
2093 C PDJ(12) = -RK15*Y(2) - RK17*Y(10)
2094 C RETURN
2095 C END
2096 C
2097 C The output of this program (on a Cray-1 in single precision)
2098 C is as follows:
2099 C
2100 C
2101 C At t = 1.000e-01 No. steps = 12 Last step = 1.515e-02
2102 C Y array = 9.90050e-01 6.28228e-03 3.65313e-03 7.51934e-07
2103 C 1.12167e-09 1.18458e-09 1.77291e-12 3.26476e-07
2104 C 5.46720e-08 9.99500e-06 4.48483e-08 2.76398e-06
2105 C
2106 C
2107 C At t = 1.000e+00 No. steps = 33 Last step = 7.880e-02
2108 C Y array = 9.04837e-01 9.13105e-03 8.20622e-02 2.49177e-05
2109 C 1.85055e-06 1.96797e-06 1.46157e-07 2.39557e-05
2110 C 3.26306e-05 7.21621e-04 5.06433e-05 3.05010e-03
2111 C
2112 C
2113 C At t = 1.000e+01 No. steps = 48 Last step = 1.239e+00
2114 C Y array = 3.67876e-01 3.68958e-03 3.65133e-01 4.48325e-05
2115 C 6.10798e-05 4.33148e-05 5.90211e-05 1.18449e-04
2116 C 3.15235e-03 3.56531e-03 4.15520e-03 2.48741e-01
2117 C
2118 C
2119 C At t = 1.000e+02 No. steps = 91 Last step = 3.764e+00
2120 C Y array = 4.44981e-05 4.42666e-07 4.47273e-04 -3.53257e-11
2121 C 2.81577e-08 -9.67741e-11 2.77615e-07 1.45322e-07
2122 C 1.56230e-02 4.37394e-06 1.60104e-02 9.52246e-01
2123 C
2124 C
2125 C At t = 1.000e+03 No. steps = 111 Last step = 4.156e+02
2126 C Y array = -2.65492e-13 2.60539e-14 -8.59563e-12 6.29355e-14
2127 C -1.78066e-13 5.71471e-13 -1.47561e-12 4.58078e-15
2128 C 1.56314e-02 1.37878e-13 1.60184e-02 9.52719e-01
2129 C
2130 C
2131 C Required RWORK size = 442 IWORK size = 30
2132 C No. steps = 111 No. f-s = 142 No. J-s = 2 No. LU-s = 20
2133 C No. of nonzeros in J = 44 No. of nonzeros in LU = 50
2134 C
2135 C-----------------------------------------------------------------------
2136 C Full Description of User Interface to DLSODES.
2137 C
2138 C The user interface to DLSODES consists of the following parts.
2139 C
2140 C 1. The call sequence to Subroutine DLSODES, which is a driver
2141 C routine for the solver. This includes descriptions of both
2142 C the call sequence arguments and of user-supplied routines.
2143 C Following these descriptions is a description of
2144 C optional inputs available through the call sequence, and then
2145 C a description of optional outputs (in the work arrays).
2146 C
2147 C 2. Descriptions of other routines in the DLSODES package that may be
2148 C (optionally) called by the user. These provide the ability to
2149 C alter error message handling, save and restore the internal
2150 C Common, and obtain specified derivatives of the solution y(t).
2151 C
2152 C 3. Descriptions of Common blocks to be declared in overlay
2153 C or similar environments, or to be saved when doing an interrupt
2154 C of the problem and continued solution later.
2155 C
2156 C 4. Description of two routines in the DLSODES package, either of
2157 C which the user may replace with his/her own version, if desired.
2158 C These relate to the measurement of errors.
2159 C
2160 C-----------------------------------------------------------------------
2161 C Part 1. Call Sequence.
2162 C
2163 C The call sequence parameters used for input only are
2164 C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, MF,
2165 C and those used for both input and output are
2166 C Y, T, ISTATE.
2167 C The work arrays RWORK and IWORK are also used for conditional and
2168 C optional inputs and optional outputs. (The term output here refers
2169 C to the return from Subroutine DLSODES to the user's calling program.)
2170 C
2171 C The legality of input parameters will be thoroughly checked on the
2172 C initial call for the problem, but not checked thereafter unless a
2173 C change in input parameters is flagged by ISTATE = 3 on input.
2174 C
2175 C The descriptions of the call arguments are as follows.
2176 C
2177 C F = the name of the user-supplied subroutine defining the
2178 C ODE system. The system must be put in the first-order
2179 C form dy/dt = f(t,y), where f is a vector-valued function
2180 C of the scalar t and the vector y. Subroutine F is to
2181 C compute the function f. It is to have the form
2182 C SUBROUTINE F (NEQ, T, Y, YDOT)
2183 C DOUBLE PRECISION T, Y(*), YDOT(*)
2184 C where NEQ, T, and Y are input, and the array YDOT = f(t,y)
2185 C is output. Y and YDOT are arrays of length NEQ.
2186 C Subroutine F should not alter y(1),...,y(NEQ).
2187 C F must be declared External in the calling program.
2188 C
2189 C Subroutine F may access user-defined quantities in
2190 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array
2191 C (dimensioned in F) and/or Y has length exceeding NEQ(1).
2192 C See the descriptions of NEQ and Y below.
2193 C
2194 C If quantities computed in the F routine are needed
2195 C externally to DLSODES, an extra call to F should be made
2196 C for this purpose, for consistent and accurate results.
2197 C If only the derivative dy/dt is needed, use DINTDY instead.
2198 C
2199 C NEQ = the size of the ODE system (number of first order
2200 C ordinary differential equations). Used only for input.
2201 C NEQ may be decreased, but not increased, during the problem.
2202 C If NEQ is decreased (with ISTATE = 3 on input), the
2203 C remaining components of Y should be left undisturbed, if
2204 C these are to be accessed in F and/or JAC.
2205 C
2206 C Normally, NEQ is a scalar, and it is generally referred to
2207 C as a scalar in this user interface description. However,
2208 C NEQ may be an array, with NEQ(1) set to the system size.
2209 C (The DLSODES package accesses only NEQ(1).) In either case,
2210 C this parameter is passed as the NEQ argument in all calls
2211 C to F and JAC. Hence, if it is an array, locations
2212 C NEQ(2),... may be used to store other integer data and pass
2213 C it to F and/or JAC. Subroutines F and/or JAC must include
2214 C NEQ in a Dimension statement in that case.
2215 C
2216 C Y = a real array for the vector of dependent variables, of
2217 C length NEQ or more. Used for both input and output on the
2218 C first call (ISTATE = 1), and only for output on other calls.
2219 C on the first call, Y must contain the vector of initial
2220 C values. On output, Y contains the computed solution vector,
2221 C evaluated at T. If desired, the Y array may be used
2222 C for other purposes between calls to the solver.
2223 C
2224 C This array is passed as the Y argument in all calls to
2225 C F and JAC. Hence its length may exceed NEQ, and locations
2226 C Y(NEQ+1),... may be used to store other real data and
2227 C pass it to F and/or JAC. (The DLSODES package accesses only
2228 C Y(1),...,Y(NEQ).)
2229 C
2230 C T = the independent variable. On input, T is used only on the
2231 C first call, as the initial point of the integration.
2232 C on output, after each call, T is the value at which a
2233 C computed solution Y is evaluated (usually the same as TOUT).
2234 C On an error return, T is the farthest point reached.
2235 C
2236 C TOUT = the next value of t at which a computed solution is desired.
2237 C Used only for input.
2238 C
2239 C When starting the problem (ISTATE = 1), TOUT may be equal
2240 C to T for one call, then should .ne. T for the next call.
2241 C For the initial T, an input value of TOUT .ne. T is used
2242 C in order to determine the direction of the integration
2243 C (i.e. the algebraic sign of the step sizes) and the rough
2244 C scale of the problem. Integration in either direction
2245 C (forward or backward in t) is permitted.
2246 C
2247 C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after
2248 C the first call (i.e. the first call with TOUT .ne. T).
2249 C Otherwise, TOUT is required on every call.
2250 C
2251 C If ITASK = 1, 3, or 4, the values of TOUT need not be
2252 C monotone, but a value of TOUT which backs up is limited
2253 C to the current internal T interval, whose endpoints are
2254 C TCUR - HU and TCUR (see optional outputs, below, for
2255 C TCUR and HU).
2256 C
2257 C ITOL = an indicator for the type of error control. See
2258 C description below under ATOL. Used only for input.
2259 C
2260 C RTOL = a relative error tolerance parameter, either a scalar or
2261 C an array of length NEQ. See description below under ATOL.
2262 C Input only.
2263 C
2264 C ATOL = an absolute error tolerance parameter, either a scalar or
2265 C an array of length NEQ. Input only.
2266 C
2267 C The input parameters ITOL, RTOL, and ATOL determine
2268 C the error control performed by the solver. The solver will
2269 C control the vector E = (E(i)) of estimated local errors
2270 C in y, according to an inequality of the form
2271 C RMS-norm of ( E(i)/EWT(i) ) .le. 1,
2272 C where EWT(i) = RTOL(i)*ABS(Y(i)) + ATOL(i),
2273 C and the RMS-norm (root-mean-square norm) here is
2274 C RMS-norm(v) = SQRT(sum v(i)**2 / NEQ). Here EWT = (EWT(i))
2275 C is a vector of weights which must always be positive, and
2276 C the values of RTOL and ATOL should all be non-negative.
2277 C The following table gives the types (scalar/array) of
2278 C RTOL and ATOL, and the corresponding form of EWT(i).
2279 C
2280 C ITOL RTOL ATOL EWT(i)
2281 C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL
2282 C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i)
2283 C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL
2284 C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i)
2285 C
2286 C When either of these parameters is a scalar, it need not
2287 C be dimensioned in the user's calling program.
2288 C
2289 C If none of the above choices (with ITOL, RTOL, and ATOL
2290 C fixed throughout the problem) is suitable, more general
2291 C error controls can be obtained by substituting
2292 C user-supplied routines for the setting of EWT and/or for
2293 C the norm calculation. See Part 4 below.
2294 C
2295 C If global errors are to be estimated by making a repeated
2296 C run on the same problem with smaller tolerances, then all
2297 C components of RTOL and ATOL (i.e. of EWT) should be scaled
2298 C down uniformly.
2299 C
2300 C ITASK = an index specifying the task to be performed.
2301 C Input only. ITASK has the following values and meanings.
2302 C 1 means normal computation of output values of y(t) at
2303 C t = TOUT (by overshooting and interpolating).
2304 C 2 means take one step only and return.
2305 C 3 means stop at the first internal mesh point at or
2306 C beyond t = TOUT and return.
2307 C 4 means normal computation of output values of y(t) at
2308 C t = TOUT but without overshooting t = TCRIT.
2309 C TCRIT must be input as RWORK(1). TCRIT may be equal to
2310 C or beyond TOUT, but not behind it in the direction of
2311 C integration. This option is useful if the problem
2312 C has a singularity at or beyond t = TCRIT.
2313 C 5 means take one step, without passing TCRIT, and return.
2314 C TCRIT must be input as RWORK(1).
2315 C
2316 C Note: If ITASK = 4 or 5 and the solver reaches TCRIT
2317 C (within roundoff), it will return T = TCRIT (exactly) to
2318 C indicate this (unless ITASK = 4 and TOUT comes before TCRIT,
2319 C in which case answers at t = TOUT are returned first).
2320 C
2321 C ISTATE = an index used for input and output to specify the
2322 C the state of the calculation.
2323 C
2324 C On input, the values of ISTATE are as follows.
2325 C 1 means this is the first call for the problem
2326 C (initializations will be done). See note below.
2327 C 2 means this is not the first call, and the calculation
2328 C is to continue normally, with no change in any input
2329 C parameters except possibly TOUT and ITASK.
2330 C (If ITOL, RTOL, and/or ATOL are changed between calls
2331 C with ISTATE = 2, the new values will be used but not
2332 C tested for legality.)
2333 C 3 means this is not the first call, and the
2334 C calculation is to continue normally, but with
2335 C a change in input parameters other than
2336 C TOUT and ITASK. Changes are allowed in
2337 C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF,
2338 C the conditional inputs IA and JA,
2339 C and any of the optional inputs except H0.
2340 C In particular, if MITER = 1 or 2, a call with ISTATE = 3
2341 C will cause the sparsity structure of the problem to be
2342 C recomputed (or reread from IA and JA if MOSS = 0).
2343 C Note: a preliminary call with TOUT = T is not counted
2344 C as a first call here, as no initialization or checking of
2345 C input is done. (Such a call is sometimes useful for the
2346 C purpose of outputting the initial conditions.)
2347 C Thus the first call for which TOUT .ne. T requires
2348 C ISTATE = 1 on input.
2349 C
2350 C On output, ISTATE has the following values and meanings.
2351 C 1 means nothing was done; TOUT = T and ISTATE = 1 on input.
2352 C 2 means the integration was performed successfully.
2353 C -1 means an excessive amount of work (more than MXSTEP
2354 C steps) was done on this call, before completing the
2355 C requested task, but the integration was otherwise
2356 C successful as far as T. (MXSTEP is an optional input
2357 C and is normally 500.) To continue, the user may
2358 C simply reset ISTATE to a value .gt. 1 and call again
2359 C (the excess work step counter will be reset to 0).
2360 C In addition, the user may increase MXSTEP to avoid
2361 C this error return (see below on optional inputs).
2362 C -2 means too much accuracy was requested for the precision
2363 C of the machine being used. This was detected before
2364 C completing the requested task, but the integration
2365 C was successful as far as T. To continue, the tolerance
2366 C parameters must be reset, and ISTATE must be set
2367 C to 3. The optional output TOLSF may be used for this
2368 C purpose. (Note: If this condition is detected before
2369 C taking any steps, then an illegal input return
2370 C (ISTATE = -3) occurs instead.)
2371 C -3 means illegal input was detected, before taking any
2372 C integration steps. See written message for details.
2373 C Note: If the solver detects an infinite loop of calls
2374 C to the solver with illegal input, it will cause
2375 C the run to stop.
2376 C -4 means there were repeated error test failures on
2377 C one attempted step, before completing the requested
2378 C task, but the integration was successful as far as T.
2379 C The problem may have a singularity, or the input
2380 C may be inappropriate.
2381 C -5 means there were repeated convergence test failures on
2382 C one attempted step, before completing the requested
2383 C task, but the integration was successful as far as T.
2384 C This may be caused by an inaccurate Jacobian matrix,
2385 C if one is being used.
2386 C -6 means EWT(i) became zero for some i during the
2387 C integration. Pure relative error control (ATOL(i)=0.0)
2388 C was requested on a variable which has now vanished.
2389 C The integration was successful as far as T.
2390 C -7 means a fatal error return flag came from the sparse
2391 C solver CDRV by way of DPRJS or DSOLSS (numerical
2392 C factorization or backsolve). This should never happen.
2393 C The integration was successful as far as T.
2394 C
2395 C Note: an error return with ISTATE = -1, -4, or -5 and with
2396 C MITER = 1 or 2 may mean that the sparsity structure of the
2397 C problem has changed significantly since it was last
2398 C determined (or input). In that case, one can attempt to
2399 C complete the integration by setting ISTATE = 3 on the next
2400 C call, so that a new structure determination is done.
2401 C
2402 C Note: since the normal output value of ISTATE is 2,
2403 C it does not need to be reset for normal continuation.
2404 C Also, since a negative input value of ISTATE will be
2405 C regarded as illegal, a negative output value requires the
2406 C user to change it, and possibly other inputs, before
2407 C calling the solver again.
2408 C
2409 C IOPT = an integer flag to specify whether or not any optional
2410 C inputs are being used on this call. Input only.
2411 C The optional inputs are listed separately below.
2412 C IOPT = 0 means no optional inputs are being used.
2413 C Default values will be used in all cases.
2414 C IOPT = 1 means one or more optional inputs are being used.
2415 C
2416 C RWORK = a work array used for a mixture of real (double precision)
2417 C and integer work space.
2418 C The length of RWORK (in real words) must be at least
2419 C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM where
2420 C NYH = the initial value of NEQ,
2421 C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a
2422 C smaller value is given as an optional input),
2423 C LWM = 0 if MITER = 0,
2424 C LWM = 2*NNZ + 2*NEQ + (NNZ+9*NEQ)/LENRAT if MITER = 1,
2425 C LWM = 2*NNZ + 2*NEQ + (NNZ+10*NEQ)/LENRAT if MITER = 2,
2426 C LWM = NEQ + 2 if MITER = 3.
2427 C In the above formulas,
2428 C NNZ = number of nonzero elements in the Jacobian matrix.
2429 C LENRAT = the real to integer wordlength ratio (usually 1 in
2430 C single precision and 2 in double precision).
2431 C (See the MF description for METH and MITER.)
2432 C Thus if MAXORD has its default value and NEQ is constant,
2433 C the minimum length of RWORK is:
2434 C 20 + 16*NEQ for MF = 10,
2435 C 20 + 16*NEQ + LWM for MF = 11, 111, 211, 12, 112, 212,
2436 C 22 + 17*NEQ for MF = 13,
2437 C 20 + 9*NEQ for MF = 20,
2438 C 20 + 9*NEQ + LWM for MF = 21, 121, 221, 22, 122, 222,
2439 C 22 + 10*NEQ for MF = 23.
2440 C If MITER = 1 or 2, the above formula for LWM is only a
2441 C crude lower bound. The required length of RWORK cannot
2442 C be readily predicted in general, as it depends on the
2443 C sparsity structure of the problem. Some experimentation
2444 C may be necessary.
2445 C
2446 C The first 20 words of RWORK are reserved for conditional
2447 C and optional inputs and optional outputs.
2448 C
2449 C The following word in RWORK is a conditional input:
2450 C RWORK(1) = TCRIT = critical value of t which the solver
2451 C is not to overshoot. Required if ITASK is
2452 C 4 or 5, and ignored otherwise. (See ITASK.)
2453 C
2454 C LRW = the length of the array RWORK, as declared by the user.
2455 C (This will be checked by the solver.)
2456 C
2457 C IWORK = an integer work array. The length of IWORK must be at least
2458 C 31 + NEQ + NNZ if MOSS = 0 and MITER = 1 or 2, or
2459 C 30 otherwise.
2460 C (NNZ is the number of nonzero elements in df/dy.)
2461 C
2462 C In DLSODES, IWORK is used only for conditional and
2463 C optional inputs and optional outputs.
2464 C
2465 C The following two blocks of words in IWORK are conditional
2466 C inputs, required if MOSS = 0 and MITER = 1 or 2, but not
2467 C otherwise (see the description of MF for MOSS).
2468 C IWORK(30+j) = IA(j) (j=1,...,NEQ+1)
2469 C IWORK(31+NEQ+k) = JA(k) (k=1,...,NNZ)
2470 C The two arrays IA and JA describe the sparsity structure
2471 C to be assumed for the Jacobian matrix. JA contains the row
2472 C indices where nonzero elements occur, reading in columnwise
2473 C order, and IA contains the starting locations in JA of the
2474 C descriptions of columns 1,...,NEQ, in that order, with
2475 C IA(1) = 1. Thus, for each column index j = 1,...,NEQ, the
2476 C values of the row index i in column j where a nonzero
2477 C element may occur are given by
2478 C i = JA(k), where IA(j) .le. k .lt. IA(j+1).
2479 C If NNZ is the total number of nonzero locations assumed,
2480 C then the length of the JA array is NNZ, and IA(NEQ+1) must
2481 C be NNZ + 1. Duplicate entries are not allowed.
2482 C
2483 C LIW = the length of the array IWORK, as declared by the user.
2484 C (This will be checked by the solver.)
2485 C
2486 C Note: The work arrays must not be altered between calls to DLSODES
2487 C for the same problem, except possibly for the conditional and
2488 C optional inputs, and except for the last 3*NEQ words of RWORK.
2489 C The latter space is used for internal scratch space, and so is
2490 C available for use by the user outside DLSODES between calls, if
2491 C desired (but not for use by F or JAC).
2492 C
2493 C JAC = name of user-supplied routine (MITER = 1 or MOSS = 1) to
2494 C compute the Jacobian matrix, df/dy, as a function of
2495 C the scalar t and the vector y. It is to have the form
2496 C SUBROUTINE JAC (NEQ, T, Y, J, IAN, JAN, PDJ)
2497 C DOUBLE PRECISION T, Y(*), IAN(*), JAN(*), PDJ(*)
2498 C where NEQ, T, Y, J, IAN, and JAN are input, and the array
2499 C PDJ, of length NEQ, is to be loaded with column J
2500 C of the Jacobian on output. Thus df(i)/dy(J) is to be
2501 C loaded into PDJ(i) for all relevant values of i.
2502 C Here T and Y have the same meaning as in Subroutine F,
2503 C and J is a column index (1 to NEQ). IAN and JAN are
2504 C undefined in calls to JAC for structure determination
2505 C (MOSS = 1). otherwise, IAN and JAN are structure
2506 C descriptors, as defined under optional outputs below, and
2507 C so can be used to determine the relevant row indices i, if
2508 C desired.
2509 C JAC need not provide df/dy exactly. A crude
2510 C approximation (possibly with greater sparsity) will do.
2511 C In any case, PDJ is preset to zero by the solver,
2512 C so that only the nonzero elements need be loaded by JAC.
2513 C Calls to JAC are made with J = 1,...,NEQ, in that order, and
2514 C each such set of calls is preceded by a call to F with the
2515 C same arguments NEQ, T, and Y. Thus to gain some efficiency,
2516 C intermediate quantities shared by both calculations may be
2517 C saved in a user Common block by F and not recomputed by JAC,
2518 C if desired. JAC must not alter its input arguments.
2519 C JAC must be declared External in the calling program.
2520 C Subroutine JAC may access user-defined quantities in
2521 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array
2522 C (dimensioned in JAC) and/or Y has length exceeding NEQ(1).
2523 C See the descriptions of NEQ and Y above.
2524 C
2525 C MF = the method flag. Used only for input.
2526 C MF has three decimal digits-- MOSS, METH, MITER--
2527 C MF = 100*MOSS + 10*METH + MITER.
2528 C MOSS indicates the method to be used to obtain the sparsity
2529 C structure of the Jacobian matrix if MITER = 1 or 2:
2530 C MOSS = 0 means the user has supplied IA and JA
2531 C (see descriptions under IWORK above).
2532 C MOSS = 1 means the user has supplied JAC (see below)
2533 C and the structure will be obtained from NEQ
2534 C initial calls to JAC.
2535 C MOSS = 2 means the structure will be obtained from NEQ+1
2536 C initial calls to F.
2537 C METH indicates the basic linear multistep method:
2538 C METH = 1 means the implicit Adams method.
2539 C METH = 2 means the method based on Backward
2540 C Differentiation Formulas (BDFs).
2541 C MITER indicates the corrector iteration method:
2542 C MITER = 0 means functional iteration (no Jacobian matrix
2543 C is involved).
2544 C MITER = 1 means chord iteration with a user-supplied
2545 C sparse Jacobian, given by Subroutine JAC.
2546 C MITER = 2 means chord iteration with an internally
2547 C generated (difference quotient) sparse Jacobian
2548 C (using NGP extra calls to F per df/dy value,
2549 C where NGP is an optional output described below.)
2550 C MITER = 3 means chord iteration with an internally
2551 C generated diagonal Jacobian approximation
2552 C (using 1 extra call to F per df/dy evaluation).
2553 C If MITER = 1 or MOSS = 1, the user must supply a Subroutine
2554 C JAC (the name is arbitrary) as described above under JAC.
2555 C Otherwise, a dummy argument can be used.
2556 C
2557 C The standard choices for MF are:
2558 C MF = 10 for a nonstiff problem,
2559 C MF = 21 or 22 for a stiff problem with IA/JA supplied
2560 C (21 if JAC is supplied, 22 if not),
2561 C MF = 121 for a stiff problem with JAC supplied,
2562 C but not IA/JA,
2563 C MF = 222 for a stiff problem with neither IA/JA nor
2564 C JAC supplied.
2565 C The sparseness structure can be changed during the
2566 C problem by making a call to DLSODES with ISTATE = 3.
2567 C-----------------------------------------------------------------------
2568 C Optional Inputs.
2569 C
2570 C The following is a list of the optional inputs provided for in the
2571 C call sequence. (See also Part 2.) For each such input variable,
2572 C this table lists its name as used in this documentation, its
2573 C location in the call sequence, its meaning, and the default value.
2574 C The use of any of these inputs requires IOPT = 1, and in that
2575 C case all of these inputs are examined. A value of zero for any
2576 C of these optional inputs will cause the default value to be used.
2577 C Thus to use a subset of the optional inputs, simply preload
2578 C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and
2579 C then set those of interest to nonzero values.
2580 C
2581 C Name Location Meaning and Default Value
2582 C
2583 C H0 RWORK(5) the step size to be attempted on the first step.
2584 C The default value is determined by the solver.
2585 C
2586 C HMAX RWORK(6) the maximum absolute step size allowed.
2587 C The default value is infinite.
2588 C
2589 C HMIN RWORK(7) the minimum absolute step size allowed.
2590 C The default value is 0. (This lower bound is not
2591 C enforced on the final step before reaching TCRIT
2592 C when ITASK = 4 or 5.)
2593 C
2594 C SETH RWORK(8) the element threshhold for sparsity determination
2595 C when MOSS = 1 or 2. If the absolute value of
2596 C an estimated Jacobian element is .le. SETH, it
2597 C will be assumed to be absent in the structure.
2598 C The default value of SETH is 0.
2599 C
2600 C MAXORD IWORK(5) the maximum order to be allowed. The default
2601 C value is 12 if METH = 1, and 5 if METH = 2.
2602 C If MAXORD exceeds the default value, it will
2603 C be reduced to the default value.
2604 C If MAXORD is changed during the problem, it may
2605 C cause the current order to be reduced.
2606 C
2607 C MXSTEP IWORK(6) maximum number of (internally defined) steps
2608 C allowed during one call to the solver.
2609 C The default value is 500.
2610 C
2611 C MXHNIL IWORK(7) maximum number of messages printed (per problem)
2612 C warning that T + H = T on a step (H = step size).
2613 C This must be positive to result in a non-default
2614 C value. The default value is 10.
2615 C-----------------------------------------------------------------------
2616 C Optional Outputs.
2617 C
2618 C As optional additional output from DLSODES, the variables listed
2619 C below are quantities related to the performance of DLSODES
2620 C which are available to the user. These are communicated by way of
2621 C the work arrays, but also have internal mnemonic names as shown.
2622 C Except where stated otherwise, all of these outputs are defined
2623 C on any successful return from DLSODES, and on any return with
2624 C ISTATE = -1, -2, -4, -5, or -6. On an illegal input return
2625 C (ISTATE = -3), they will be unchanged from their existing values
2626 C (if any), except possibly for TOLSF, LENRW, and LENIW.
2627 C On any error return, outputs relevant to the error will be defined,
2628 C as noted below.
2629 C
2630 C Name Location Meaning
2631 C
2632 C HU RWORK(11) the step size in t last used (successfully).
2633 C
2634 C HCUR RWORK(12) the step size to be attempted on the next step.
2635 C
2636 C TCUR RWORK(13) the current value of the independent variable
2637 C which the solver has actually reached, i.e. the
2638 C current internal mesh point in t. On output, TCUR
2639 C will always be at least as far as the argument
2640 C T, but may be farther (if interpolation was done).
2641 C
2642 C TOLSF RWORK(14) a tolerance scale factor, greater than 1.0,
2643 C computed when a request for too much accuracy was
2644 C detected (ISTATE = -3 if detected at the start of
2645 C the problem, ISTATE = -2 otherwise). If ITOL is
2646 C left unaltered but RTOL and ATOL are uniformly
2647 C scaled up by a factor of TOLSF for the next call,
2648 C then the solver is deemed likely to succeed.
2649 C (The user may also ignore TOLSF and alter the
2650 C tolerance parameters in any other way appropriate.)
2651 C
2652 C NST IWORK(11) the number of steps taken for the problem so far.
2653 C
2654 C NFE IWORK(12) the number of f evaluations for the problem so far,
2655 C excluding those for structure determination
2656 C (MOSS = 2).
2657 C
2658 C NJE IWORK(13) the number of Jacobian evaluations for the problem
2659 C so far, excluding those for structure determination
2660 C (MOSS = 1).
2661 C
2662 C NQU IWORK(14) the method order last used (successfully).
2663 C
2664 C NQCUR IWORK(15) the order to be attempted on the next step.
2665 C
2666 C IMXER IWORK(16) the index of the component of largest magnitude in
2667 C the weighted local error vector ( E(i)/EWT(i) ),
2668 C on an error return with ISTATE = -4 or -5.
2669 C
2670 C LENRW IWORK(17) the length of RWORK actually required.
2671 C This is defined on normal returns and on an illegal
2672 C input return for insufficient storage.
2673 C
2674 C LENIW IWORK(18) the length of IWORK actually required.
2675 C This is defined on normal returns and on an illegal
2676 C input return for insufficient storage.
2677 C
2678 C NNZ IWORK(19) the number of nonzero elements in the Jacobian
2679 C matrix, including the diagonal (MITER = 1 or 2).
2680 C (This may differ from that given by IA(NEQ+1)-1
2681 C if MOSS = 0, because of added diagonal entries.)
2682 C
2683 C NGP IWORK(20) the number of groups of column indices, used in
2684 C difference quotient Jacobian aproximations if
2685 C MITER = 2. This is also the number of extra f
2686 C evaluations needed for each Jacobian evaluation.
2687 C
2688 C NLU IWORK(21) the number of sparse LU decompositions for the
2689 C problem so far.
2690 C
2691 C LYH IWORK(22) the base address in RWORK of the history array YH,
2692 C described below in this list.
2693 C
2694 C IPIAN IWORK(23) the base address of the structure descriptor array
2695 C IAN, described below in this list.
2696 C
2697 C IPJAN IWORK(24) the base address of the structure descriptor array
2698 C JAN, described below in this list.
2699 C
2700 C NZL IWORK(25) the number of nonzero elements in the strict lower
2701 C triangle of the LU factorization used in the chord
2702 C iteration (MITER = 1 or 2).
2703 C
2704 C NZU IWORK(26) the number of nonzero elements in the strict upper
2705 C triangle of the LU factorization used in the chord
2706 C iteration (MITER = 1 or 2).
2707 C The total number of nonzeros in the factorization
2708 C is therefore NZL + NZU + NEQ.
2709 C
2710 C The following four arrays are segments of the RWORK array which
2711 C may also be of interest to the user as optional outputs.
2712 C For each array, the table below gives its internal name,
2713 C its base address, and its description.
2714 C For YH and ACOR, the base addresses are in RWORK (a real array).
2715 C The integer arrays IAN and JAN are to be obtained by declaring an
2716 C integer array IWK and identifying IWK(1) with RWORK(21), using either
2717 C an equivalence statement or a subroutine call. Then the base
2718 C addresses IPIAN (of IAN) and IPJAN (of JAN) in IWK are to be obtained
2719 C as optional outputs IWORK(23) and IWORK(24), respectively.
2720 C Thus IAN(1) is IWK(IPIAN), etc.
2721 C
2722 C Name Base Address Description
2723 C
2724 C IAN IPIAN (in IWK) structure descriptor array of size NEQ + 1.
2725 C JAN IPJAN (in IWK) structure descriptor array of size NNZ.
2726 C (see above) IAN and JAN together describe the sparsity
2727 C structure of the Jacobian matrix, as used by
2728 C DLSODES when MITER = 1 or 2.
2729 C JAN contains the row indices of the nonzero
2730 C locations, reading in columnwise order, and
2731 C IAN contains the starting locations in JAN of
2732 C the descriptions of columns 1,...,NEQ, in
2733 C that order, with IAN(1) = 1. Thus for each
2734 C j = 1,...,NEQ, the row indices i of the
2735 C nonzero locations in column j are
2736 C i = JAN(k), IAN(j) .le. k .lt. IAN(j+1).
2737 C Note that IAN(NEQ+1) = NNZ + 1.
2738 C (If MOSS = 0, IAN/JAN may differ from the
2739 C input IA/JA because of a different ordering
2740 C in each column, and added diagonal entries.)
2741 C
2742 C YH LYH the Nordsieck history array, of size NYH by
2743 C (optional (NQCUR + 1), where NYH is the initial value
2744 C output) of NEQ. For j = 0,1,...,NQCUR, column j+1
2745 C of YH contains HCUR**j/factorial(j) times
2746 C the j-th derivative of the interpolating
2747 C polynomial currently representing the solution,
2748 C evaluated at t = TCUR. The base address LYH
2749 C is another optional output, listed above.
2750 C
2751 C ACOR LENRW-NEQ+1 array of size NEQ used for the accumulated
2752 C corrections on each step, scaled on output
2753 C to represent the estimated local error in y
2754 C on the last step. This is the vector E in
2755 C the description of the error control. It is
2756 C defined only on a successful return from
2757 C DLSODES.
2758 C
2759 C-----------------------------------------------------------------------
2760 C Part 2. Other Routines Callable.
2761 C
2762 C The following are optional calls which the user may make to
2763 C gain additional capabilities in conjunction with DLSODES.
2764 C (The rouMETHtines XSETUN and XSETF are designed to conform to the
2765 C SLATEC error handling package.)
2766 C
2767 C Form of Call Function
2768 C CALL XSETUN(LUN) Set the logical unit number, LUN, for
2769 C output of messages from DLSODES, if
2770 C the default is not desired.
2771 C The default value of LUN is 6.
2772 C
2773 C CALL XSETF(MFLAG) Set a flag to control the printing of
2774 C messages by DLSODES.
2775 C MFLAG = 0 means do not print. (Danger:
2776 C This risks losing valuable information.)
2777 C MFLAG = 1 means print (the default).
2778 C
2779 C Either of the above calls may be made at
2780 C any time and will take effect immediately.
2781 C
2782 C CALL DSRCMS(RSAV,ISAV,JOB) saves and restores the contents of
2783 C the internal Common blocks used by
2784 C DLSODES (see Part 3 below).
2785 C RSAV must be a real array of length 224
2786 C or more, and ISAV must be an integer
2787 C array of length 71 or more.
2788 C JOB=1 means save Common into RSAV/ISAV.
2789 C JOB=2 means restore Common from RSAV/ISAV.
2790 C DSRCMS is useful if one is
2791 C interrupting a run and restarting
2792 C later, or alternating between two or
2793 C more problems solved with DLSODES.
2794 C
2795 C CALL DINTDY(,,,,,) Provide derivatives of y, of various
2796 C (see below) orders, at a specified point t, if
2797 C desired. It may be called only after
2798 C a successful return from DLSODES.
2799 C
2800 C The detailed instructions for using DINTDY are as follows.
2801 C The form of the call is:
2802 C
2803 C LYH = IWORK(22)
2804 C CALL DINTDY (T, K, RWORK(LYH), NYH, DKY, IFLAG)
2805 C
2806 C The input parameters are:
2807 C
2808 C T = value of independent variable where answers are desired
2809 C (normally the same as the T last returned by DLSODES).
2810 C For valid results, T must lie between TCUR - HU and TCUR.
2811 C (See optional outputs for TCUR and HU.)
2812 C K = integer order of the derivative desired. K must satisfy
2813 C 0 .le. K .le. NQCUR, where NQCUR is the current order
2814 C (See optional outputs). The capability corresponding
2815 C to K = 0, i.e. computing y(T), is already provided
2816 C by DLSODES directly. Since NQCUR .ge. 1, the first
2817 C derivative dy/dt is always available with DINTDY.
2818 C LYH = the base address of the history array YH, obtained
2819 C as an optional output as shown above.
2820 C NYH = column length of YH, equal to the initial value of NEQ.
2821 C
2822 C The output parameters are:
2823 C
2824 C DKY = a real array of length NEQ containing the computed value
2825 C of the K-th derivative of y(t).
2826 C IFLAG = integer flag, returned as 0 if K and T were legal,
2827 C -1 if K was illegal, and -2 if T was illegal.
2828 C On an error return, a message is also written.
2829 C-----------------------------------------------------------------------
2830 C Part 3. Common Blocks.
2831 C
2832 C If DLSODES is to be used in an overlay situation, the user
2833 C must declare, in the primary overlay, the variables in:
2834 C (1) the call sequence to DLSODES, and
2835 C (2) the two internal Common blocks
2836 C /DLS001/ of length 255 (218 double precision words
2837 C followed by 37 integer words),
2838 C /DLSS01/ of length 40 (6 double precision words
2839 C followed by 34 integer words),
2840 C
2841 C If DLSODES is used on a system in which the contents of internal
2842 C Common blocks are not preserved between calls, the user should
2843 C declare the above Common blocks in the calling program to insure
2844 C that their contents are preserved.
2845 C
2846 C If the solution of a given problem by DLSODES is to be interrupted
2847 C and then later continued, such as when restarting an interrupted run
2848 C or alternating between two or more problems, the user should save,
2849 C following the return from the last DLSODES call prior to the
2850 C interruption, the contents of the call sequence variables and the
2851 C internal Common blocks, and later restore these values before the
2852 C next DLSODES call for that problem. To save and restore the Common
2853 C blocks, use Subroutine DSRCMS (see Part 2 above).
2854 C
2855 C-----------------------------------------------------------------------
2856 C Part 4. Optionally Replaceable Solver Routines.
2857 C
2858 C Below are descriptions of two routines in the DLSODES package which
2859 C relate to the measurement of errors. Either routine can be
2860 C replaced by a user-supplied version, if desired. However, since such
2861 C a replacement may have a major impact on performance, it should be
2862 C done only when absolutely necessary, and only with great caution.
2863 C (Note: The means by which the package version of a routine is
2864 C superseded by the user's version may be system-dependent.)
2865 C
2866 C (a) DEWSET.
2867 C The following subroutine is called just before each internal
2868 C integration step, and sets the array of error weights, EWT, as
2869 C described under ITOL/RTOL/ATOL above:
2870 C Subroutine DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT)
2871 C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODES call sequence,
2872 C YCUR contains the current dependent variable vector, and
2873 C EWT is the array of weights set by DEWSET.
2874 C
2875 C If the user supplies this subroutine, it must return in EWT(i)
2876 C (i = 1,...,NEQ) a positive quantity suitable for comparing errors
2877 C in y(i) to. The EWT array returned by DEWSET is passed to the DVNORM
2878 C routine (see below), and also used by DLSODES in the computation
2879 C of the optional output IMXER, the diagonal Jacobian approximation,
2880 C and the increments for difference quotient Jacobians.
2881 C
2882 C In the user-supplied version of DEWSET, it may be desirable to use
2883 C the current values of derivatives of y. Derivatives up to order NQ
2884 C are available from the history array YH, described above under
2885 C optional outputs. In DEWSET, YH is identical to the YCUR array,
2886 C extended to NQ + 1 columns with a column length of NYH and scale
2887 C factors of H**j/factorial(j). On the first call for the problem,
2888 C given by NST = 0, NQ is 1 and H is temporarily set to 1.0.
2889 C NYH is the initial value of NEQ. The quantities NQ, H, and NST
2890 C can be obtained by including in DEWSET the statements:
2891 C DOUBLE PRECISION RLS
2892 C COMMON /DLS001/ RLS(218),ILS(37)
2893 C NQ = ILS(33)
2894 C NST = ILS(34)
2895 C H = RLS(212)
2896 C Thus, for example, the current value of dy/dt can be obtained as
2897 C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is
2898 C unnecessary when NST = 0).
2899 C
2900 C (b) DVNORM.
2901 C The following is a real function routine which computes the weighted
2902 C root-mean-square norm of a vector v:
2903 C D = DVNORM (N, V, W)
2904 C where
2905 C N = the length of the vector,
2906 C V = real array of length N containing the vector,
2907 C W = real array of length N containing weights,
2908 C D = SQRT( (1/N) * sum(V(i)*W(i))**2 ).
2909 C DVNORM is called with N = NEQ and with W(i) = 1.0/EWT(i), where
2910 C EWT is as set by Subroutine DEWSET.
2911 C
2912 C If the user supplies this function, it should return a non-negative
2913 C value of DVNORM suitable for use in the error control in DLSODES.
2914 C None of the arguments should be altered by DVNORM.
2915 C For example, a user-supplied DVNORM routine might:
2916 C -substitute a max-norm of (V(i)*W(i)) for the RMS-norm, or
2917 C -ignore some components of V in the norm, with the effect of
2918 C suppressing the error control on those components of y.
2919 C-----------------------------------------------------------------------
2920 C
2921 C***REVISION HISTORY (YYYYMMDD)
2922 C 19810120 DATE WRITTEN
2923 C 19820315 Upgraded MDI in ODRV package: operates on M + M-transpose.
2924 C 19820426 Numerous revisions in use of work arrays;
2925 C use wordlength ratio LENRAT; added IPISP & LRAT to Common;
2926 C added optional outputs IPIAN/IPJAN;
2927 C numerous corrections to comments.
2928 C 19830503 Added routine CNTNZU; added NZL and NZU to /LSS001/;
2929 C changed ADJLR call logic; added optional outputs NZL & NZU;
2930 C revised counter initializations; revised PREP stmt. numbers;
2931 C corrections to comments throughout.
2932 C 19870320 Corrected jump on test of umax in CDRV routine;
2933 C added ISTATE = -7 return.
2934 C 19870330 Major update: corrected comments throughout;
2935 C removed TRET from Common; rewrote EWSET with 4 loops;
2936 C fixed t test in INTDY; added Cray directives in STODE;
2937 C in STODE, fixed DELP init. and logic around PJAC call;
2938 C combined routines to save/restore Common;
2939 C passed LEVEL = 0 in error message calls (except run abort).
2940 C 20010425 Major update: convert source lines to upper case;
2941 C added *DECK lines; changed from 1 to * in dummy dimensions;
2942 C changed names R1MACH/D1MACH to RUMACH/DUMACH;
2943 C renamed routines for uniqueness across single/double prec.;
2944 C converted intrinsic names to generic form;
2945 C removed ILLIN and NTREP (data loaded) from Common;
2946 C removed all 'own' variables from Common;
2947 C changed error messages to quoted strings;
2948 C replaced XERRWV/XERRWD with 1993 revised version;
2949 C converted prologues, comments, error messages to mixed case;
2950 C converted arithmetic IF statements to logical IF statements;
2951 C numerous corrections to prologues and internal comments.
2952 C 20010507 Converted single precision source to double precision.
2953 C 20020502 Corrected declarations in descriptions of user routines.
2954 C 20031105 Restored 'own' variables to Common blocks, to enable
2955 C interrupt/restart feature.
2956 C 20031112 Added SAVE statements for data-loaded constants.
2957 C
2958 C-----------------------------------------------------------------------
2959 C Other routines in the DLSODES package.
2960 C
2961 C In addition to Subroutine DLSODES, the DLSODES package includes the
2962 C following subroutines and function routines:
2963 C DIPREP acts as an iterface between DLSODES and DPREP, and also does
2964 C adjusting of work space pointers and work arrays.
2965 C DPREP is called by DIPREP to compute sparsity and do sparse matrix
2966 C preprocessing if MITER = 1 or 2.
2967 C JGROUP is called by DPREP to compute groups of Jacobian column
2968 C indices for use when MITER = 2.
2969 C ADJLR adjusts the length of required sparse matrix work space.
2970 C It is called by DPREP.
2971 C CNTNZU is called by DPREP and counts the nonzero elements in the
2972 C strict upper triangle of J + J-transpose, where J = df/dy.
2973 C DINTDY computes an interpolated value of the y vector at t = TOUT.
2974 C DSTODE is the core integrator, which does one step of the
2975 C integration and the associated error control.
2976 C DCFODE sets all method coefficients and test constants.
2977 C DPRJS computes and preprocesses the Jacobian matrix J = df/dy
2978 C and the Newton iteration matrix P = I - h*l0*J.
2979 C DSOLSS manages solution of linear system in chord iteration.
2980 C DEWSET sets the error weight vector EWT before each step.
2981 C DVNORM computes the weighted RMS-norm of a vector.
2982 C DSRCMS is a user-callable routine to save and restore
2983 C the contents of the internal Common blocks.
2984 C ODRV constructs a reordering of the rows and columns of
2985 C a matrix by the minimum degree algorithm. ODRV is a
2986 C driver routine which calls Subroutines MD, MDI, MDM,
2987 C MDP, MDU, and SRO. See Ref. 2 for details. (The ODRV
2988 C module has been modified since Ref. 2, however.)
2989 C CDRV performs reordering, symbolic factorization, numerical
2990 C factorization, or linear system solution operations,
2991 C depending on a path argument ipath. CDRV is a
2992 C driver routine which calls Subroutines NROC, NSFC,
2993 C NNFC, NNSC, and NNTC. See Ref. 3 for details.
2994 C DLSODES uses CDRV to solve linear systems in which the
2995 C coefficient matrix is P = I - con*J, where I is the
2996 C identity, con is a scalar, and J is an approximation to
2997 C the Jacobian df/dy. Because CDRV deals with rowwise
2998 C sparsity descriptions, CDRV works with P-transpose, not P.
2999 C DUMACH computes the unit roundoff in a machine-independent manner.
3000 C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all
3001 C error messages and warnings. XERRWD is machine-dependent.
3002 C Note: DVNORM, DUMACH, IXSAV, and IUMACH are function routines.
3003 C All the others are subroutines.
3004 C
3005 C-----------------------------------------------------------------------
3006  EXTERNAL dprjs, dsolss
3007  DOUBLE PRECISION dumach, dvnorm
3008  INTEGER init, mxstep, mxhnil, nhnil, nslast, nyh, iowns,
3009  1 icf, ierpj, iersl, jcur, jstart, kflag, l,
3010  2 lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
3011  3 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
3012  INTEGER iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp,
3013  1 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa,
3014  2 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj,
3015  3 nslj, ngp, nlu, nnz, nsp, nzl, nzu
3016  INTEGER i, i1, i2, iflag, imax, imul, imxer, ipflag, ipgo, irem,
3017  1 j, kgo, lenrat, lenyht, leniw, lenrw, lf0, lia, lja,
3018  2 lrtem, lwtem, lyhd, lyhn, mf1, mord, mxhnl0, mxstp0, ncolm
3019  DOUBLE PRECISION rowns,
3020  1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
3021  DOUBLE PRECISION con0, conmin, ccmxj, psmall, rbig, seth
3022  DOUBLE PRECISION atoli, ayi, big, ewti, h0, hmax, hmx, rh, rtoli,
3023  1 tcrit, tdist, tnext, tol, tolsf, tp, SIZE, sum, w0
3024  dimension mord(2)
3025  LOGICAL ihit
3026  CHARACTER*60 msg
3027  SAVE lenrat, mord, mxstp0, mxhnl0
3028 C-----------------------------------------------------------------------
3029 C The following two internal Common blocks contain
3030 C (a) variables which are local to any subroutine but whose values must
3031 C be preserved between calls to the routine ("own" variables), and
3032 C (b) variables which are communicated between subroutines.
3033 C The block DLS001 is declared in subroutines DLSODES, DIPREP, DPREP,
3034 C DINTDY, DSTODE, DPRJS, and DSOLSS.
3035 C The block DLSS01 is declared in subroutines DLSODES, DIPREP, DPREP,
3036 C DPRJS, and DSOLSS.
3037 C Groups of variables are replaced by dummy arrays in the Common
3038 C declarations in routines where those variables are not used.
3039 C-----------------------------------------------------------------------
3040  COMMON /dls001/ rowns(209),
3041  1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
3042  2 init, mxstep, mxhnil, nhnil, nslast, nyh, iowns(6),
3043  3 icf, ierpj, iersl, jcur, jstart, kflag, l,
3044  4 lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
3045  5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
3046 C
3047  COMMON /dlss01/ con0, conmin, ccmxj, psmall, rbig, seth,
3048  1 iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp,
3049  2 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa,
3050  3 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj,
3051  4 nslj, ngp, nlu, nnz, nsp, nzl, nzu
3052 C
3053  DATA mord(1),mord(2)/12,5/, mxstp0/500/, mxhnl0/10/
3054 C-----------------------------------------------------------------------
3055 C In the Data statement below, set LENRAT equal to the ratio of
3056 C the wordlength for a real number to that for an integer. Usually,
3057 C LENRAT = 1 for single precision and 2 for double precision. If the
3058 C true ratio is not an integer, use the next smaller integer (.ge. 1).
3059 C-----------------------------------------------------------------------
3060  DATA lenrat/2/
3061 C-----------------------------------------------------------------------
3062 C Block A.
3063 C This code block is executed on every call.
3064 C It tests ISTATE and ITASK for legality and branches appropriately.
3065 C If ISTATE .gt. 1 but the flag INIT shows that initialization has
3066 C not yet been done, an error return occurs.
3067 C If ISTATE = 1 and TOUT = T, return immediately.
3068 C-----------------------------------------------------------------------
3069  IF (istate .LT. 1 .OR. istate .GT. 3) GO TO 601
3070  IF (itask .LT. 1 .OR. itask .GT. 5) GO TO 602
3071  IF (istate .EQ. 1) GO TO 10
3072  IF (init .EQ. 0) GO TO 603
3073  IF (istate .EQ. 2) GO TO 200
3074  GO TO 20
3075  10 init = 0
3076  IF (tout .EQ. t) RETURN
3077 C-----------------------------------------------------------------------
3078 C Block B.
3079 C The next code block is executed for the initial call (ISTATE = 1),
3080 C or for a continuation call with parameter changes (ISTATE = 3).
3081 C It contains checking of all inputs and various initializations.
3082 C If ISTATE = 1, the final setting of work space pointers, the matrix
3083 C preprocessing, and other initializations are done in Block C.
3084 C
3085 C First check legality of the non-optional inputs NEQ, ITOL, IOPT,
3086 C MF, ML, and MU.
3087 C-----------------------------------------------------------------------
3088  20 IF (neq(1) .LE. 0) GO TO 604
3089  IF (istate .EQ. 1) GO TO 25
3090  IF (neq(1) .GT. n) GO TO 605
3091  25 n = neq(1)
3092  IF (itol .LT. 1 .OR. itol .GT. 4) GO TO 606
3093  IF (iopt .LT. 0 .OR. iopt .GT. 1) GO TO 607
3094  moss = mf/100
3095  mf1 = mf - 100*moss
3096  meth = mf1/10
3097  miter = mf1 - 10*meth
3098  IF (moss .LT. 0 .OR. moss .GT. 2) GO TO 608
3099  IF (meth .LT. 1 .OR. meth .GT. 2) GO TO 608
3100  IF (miter .LT. 0 .OR. miter .GT. 3) GO TO 608
3101  IF (miter .EQ. 0 .OR. miter .EQ. 3) moss = 0
3102 C Next process and check the optional inputs. --------------------------
3103  IF (iopt .EQ. 1) GO TO 40
3104  maxord = mord(meth)
3105  mxstep = mxstp0
3106  mxhnil = mxhnl0
3107  IF (istate .EQ. 1) h0 = 0.0d0
3108  hmxi = 0.0d0
3109  hmin = 0.0d0
3110  seth = 0.0d0
3111  GO TO 60
3112  40 maxord = iwork(5)
3113  IF (maxord .LT. 0) GO TO 611
3114  IF (maxord .EQ. 0) maxord = 100
3115  maxord = min(maxord,mord(meth))
3116  mxstep = iwork(6)
3117  IF (mxstep .LT. 0) GO TO 612
3118  IF (mxstep .EQ. 0) mxstep = mxstp0
3119  mxhnil = iwork(7)
3120  IF (mxhnil .LT. 0) GO TO 613
3121  IF (mxhnil .EQ. 0) mxhnil = mxhnl0
3122  IF (istate .NE. 1) GO TO 50
3123  h0 = rwork(5)
3124  IF ((tout - t)*h0 .LT. 0.0d0) GO TO 614
3125  50 hmax = rwork(6)
3126  IF (hmax .LT. 0.0d0) GO TO 615
3127  hmxi = 0.0d0
3128  IF (hmax .GT. 0.0d0) hmxi = 1.0d0/hmax
3129  hmin = rwork(7)
3130  IF (hmin .LT. 0.0d0) GO TO 616
3131  seth = rwork(8)
3132  IF (seth .LT. 0.0d0) GO TO 609
3133 C Check RTOL and ATOL for legality. ------------------------------------
3134  60 rtoli = rtol(1)
3135  atoli = atol(1)
3136  DO 65 i = 1,n
3137  IF (itol .GE. 3) rtoli = rtol(i)
3138  IF (itol .EQ. 2 .OR. itol .EQ. 4) atoli = atol(i)
3139  IF (rtoli .LT. 0.0d0) GO TO 619
3140  IF (atoli .LT. 0.0d0) GO TO 620
3141  65 CONTINUE
3142 C-----------------------------------------------------------------------
3143 C Compute required work array lengths, as far as possible, and test
3144 C these against LRW and LIW. Then set tentative pointers for work
3145 C arrays. Pointers to RWORK/IWORK segments are named by prefixing L to
3146 C the name of the segment. E.g., the segment YH starts at RWORK(LYH).
3147 C Segments of RWORK (in order) are denoted WM, YH, SAVF, EWT, ACOR.
3148 C If MITER = 1 or 2, the required length of the matrix work space WM
3149 C is not yet known, and so a crude minimum value is used for the
3150 C initial tests of LRW and LIW, and YH is temporarily stored as far
3151 C to the right in RWORK as possible, to leave the maximum amount
3152 C of space for WM for matrix preprocessing. Thus if MITER = 1 or 2
3153 C and MOSS .ne. 2, some of the segments of RWORK are temporarily
3154 C omitted, as they are not needed in the preprocessing. These
3155 C omitted segments are: ACOR if ISTATE = 1, EWT and ACOR if ISTATE = 3
3156 C and MOSS = 1, and SAVF, EWT, and ACOR if ISTATE = 3 and MOSS = 0.
3157 C-----------------------------------------------------------------------
3158  lrat = lenrat
3159  IF (istate .EQ. 1) nyh = n
3160  lwmin = 0
3161  IF (miter .EQ. 1) lwmin = 4*n + 10*n/lrat
3162  IF (miter .EQ. 2) lwmin = 4*n + 11*n/lrat
3163  IF (miter .EQ. 3) lwmin = n + 2
3164  lenyh = (maxord+1)*nyh
3165  lrest = lenyh + 3*n
3166  lenrw = 20 + lwmin + lrest
3167  iwork(17) = lenrw
3168  leniw = 30
3169  IF (moss .EQ. 0 .AND. miter .NE. 0 .AND. miter .NE. 3)
3170  1 leniw = leniw + n + 1
3171  iwork(18) = leniw
3172  IF (lenrw .GT. lrw) GO TO 617
3173  IF (leniw .GT. liw) GO TO 618
3174  lia = 31
3175  IF (moss .EQ. 0 .AND. miter .NE. 0 .AND. miter .NE. 3)
3176  1 leniw = leniw + iwork(lia+n) - 1
3177  iwork(18) = leniw
3178  IF (leniw .GT. liw) GO TO 618
3179  lja = lia + n + 1
3180  lia = min(lia,liw)
3181  lja = min(lja,liw)
3182  lwm = 21
3183  IF (istate .EQ. 1) nq = 1
3184  ncolm = min(nq+1,maxord+2)
3185  lenyhm = ncolm*nyh
3186  lenyht = lenyh
3187  IF (miter .EQ. 1 .OR. miter .EQ. 2) lenyht = lenyhm
3188  imul = 2
3189  IF (istate .EQ. 3) imul = moss
3190  IF (moss .EQ. 2) imul = 3
3191  lrtem = lenyht + imul*n
3192  lwtem = lwmin
3193  IF (miter .EQ. 1 .OR. miter .EQ. 2) lwtem = lrw - 20 - lrtem
3194  lenwk = lwtem
3195  lyhn = lwm + lwtem
3196  lsavf = lyhn + lenyht
3197  lewt = lsavf + n
3198  lacor = lewt + n
3199  istatc = istate
3200  IF (istate .EQ. 1) GO TO 100
3201 C-----------------------------------------------------------------------
3202 C ISTATE = 3. Move YH to its new location.
3203 C Note that only the part of YH needed for the next step, namely
3204 C MIN(NQ+1,MAXORD+2) columns, is actually moved.
3205 C A temporary error weight array EWT is loaded if MOSS = 2.
3206 C Sparse matrix processing is done in DIPREP/DPREP if MITER = 1 or 2.
3207 C If MAXORD was reduced below NQ, then the pointers are finally set
3208 C so that SAVF is identical to YH(*,MAXORD+2).
3209 C-----------------------------------------------------------------------
3210  lyhd = lyh - lyhn
3211  imax = lyhn - 1 + lenyhm
3212 C Move YH. Move right if LYHD < 0; move left if LYHD > 0. -------------
3213  IF (lyhd .LT. 0) THEN
3214  DO 72 i = lyhn,imax
3215  j = imax + lyhn - i
3216  72 rwork(j) = rwork(j+lyhd)
3217  ENDIF
3218  IF (lyhd .GT. 0) THEN
3219  DO 76 i = lyhn,imax
3220  76 rwork(i) = rwork(i+lyhd)
3221  ENDIF
3222  80 lyh = lyhn
3223  iwork(22) = lyh
3224  IF (miter .EQ. 0 .OR. miter .EQ. 3) GO TO 92
3225  IF (moss .NE. 2) GO TO 85
3226 C Temporarily load EWT if MITER = 1 or 2 and MOSS = 2. -----------------
3227  CALL dewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt))
3228  DO 82 i = 1,n
3229  IF (rwork(i+lewt-1) .LE. 0.0d0) GO TO 621
3230  82 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1)
3231  85 CONTINUE
3232 C DIPREP and DPREP do sparse matrix preprocessing if MITER = 1 or 2. ---
3233  lsavf = min(lsavf,lrw)
3234  lewt = min(lewt,lrw)
3235  lacor = min(lacor,lrw)
3236  CALL diprep (neq, y, rwork, iwork(lia),iwork(lja), ipflag, f, jac)
3237  lenrw = lwm - 1 + lenwk + lrest
3238  iwork(17) = lenrw
3239  IF (ipflag .NE. -1) iwork(23) = ipian
3240  IF (ipflag .NE. -1) iwork(24) = ipjan
3241  ipgo = -ipflag + 1
3242  GO TO (90, 628, 629, 630, 631, 632, 633), ipgo
3243  90 iwork(22) = lyh
3244  IF (lenrw .GT. lrw) GO TO 617
3245 C Set flag to signal parameter changes to DSTODE. ----------------------
3246  92 jstart = -1
3247  IF (n .EQ. nyh) GO TO 200
3248 C NEQ was reduced. Zero part of YH to avoid undefined references. -----
3249  i1 = lyh + l*nyh
3250  i2 = lyh + (maxord + 1)*nyh - 1
3251  IF (i1 .GT. i2) GO TO 200
3252  DO 95 i = i1,i2
3253  95 rwork(i) = 0.0d0
3254  GO TO 200
3255 C-----------------------------------------------------------------------
3256 C Block C.
3257 C The next block is for the initial call only (ISTATE = 1).
3258 C It contains all remaining initializations, the initial call to F,
3259 C the sparse matrix preprocessing (MITER = 1 or 2), and the
3260 C calculation of the initial step size.
3261 C The error weights in EWT are inverted after being loaded.
3262 C-----------------------------------------------------------------------
3263  100 CONTINUE
3264  lyh = lyhn
3265  iwork(22) = lyh
3266  tn = t
3267  nst = 0
3268  h = 1.0d0
3269  nnz = 0
3270  ngp = 0
3271  nzl = 0
3272  nzu = 0
3273 C Load the initial value vector in YH. ---------------------------------
3274  DO 105 i = 1,n
3275  105 rwork(i+lyh-1) = y(i)
3276 C Initial call to F. (LF0 points to YH(*,2).) -------------------------
3277  lf0 = lyh + nyh
3278  CALL f (neq, t, y, rwork(lf0))
3279  nfe = 1
3280 C Load and invert the EWT array. (H is temporarily set to 1.0.) -------
3281  CALL dewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt))
3282  DO 110 i = 1,n
3283  IF (rwork(i+lewt-1) .LE. 0.0d0) GO TO 621
3284  110 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1)
3285  IF (miter .EQ. 0 .OR. miter .EQ. 3) GO TO 120
3286 C DIPREP and DPREP do sparse matrix preprocessing if MITER = 1 or 2. ---
3287  lacor = min(lacor,lrw)
3288  CALL diprep (neq, y, rwork, iwork(lia),iwork(lja), ipflag, f, jac)
3289  lenrw = lwm - 1 + lenwk + lrest
3290  iwork(17) = lenrw
3291  IF (ipflag .NE. -1) iwork(23) = ipian
3292  IF (ipflag .NE. -1) iwork(24) = ipjan
3293  ipgo = -ipflag + 1
3294  GO TO (115, 628, 629, 630, 631, 632, 633), ipgo
3295  115 iwork(22) = lyh
3296  IF (lenrw .GT. lrw) GO TO 617
3297 C Check TCRIT for legality (ITASK = 4 or 5). ---------------------------
3298  120 CONTINUE
3299  IF (itask .NE. 4 .AND. itask .NE. 5) GO TO 125
3300  tcrit = rwork(1)
3301  IF ((tcrit - tout)*(tout - t) .LT. 0.0d0) GO TO 625
3302  IF (h0 .NE. 0.0d0 .AND. (t + h0 - tcrit)*h0 .GT. 0.0d0)
3303  1 h0 = tcrit - t
3304 C Initialize all remaining parameters. ---------------------------------
3305  125 uround = dumach()
3306  jstart = 0
3307  IF (miter .NE. 0) rwork(lwm) = sqrt(uround)
3308  msbj = 50
3309  nslj = 0
3310  ccmxj = 0.2d0
3311  psmall = 1000.0d0*uround
3312  rbig = 0.01d0/psmall
3313  nhnil = 0
3314  nje = 0
3315  nlu = 0
3316  nslast = 0
3317  hu = 0.0d0
3318  nqu = 0
3319  ccmax = 0.3d0
3320  maxcor = 3
3321  msbp = 20
3322  mxncf = 10
3323 C-----------------------------------------------------------------------
3324 C The coding below computes the step size, H0, to be attempted on the
3325 C first step, unless the user has supplied a value for this.
3326 C First check that TOUT - T differs significantly from zero.
3327 C A scalar tolerance quantity TOL is computed, as MAX(RTOL(i))
3328 C if this is positive, or MAX(ATOL(i)/ABS(Y(i))) otherwise, adjusted
3329 C so as to be between 100*UROUND and 1.0E-3.
3330 C Then the computed value H0 is given by..
3331 C NEQ
3332 C H0**2 = TOL / ( w0**-2 + (1/NEQ) * Sum ( f(i)/ywt(i) )**2 )
3333 C 1
3334 C where w0 = MAX ( ABS(T), ABS(TOUT) ),
3335 C f(i) = i-th component of initial value of f,
3336 C ywt(i) = EWT(i)/TOL (a weight for y(i)).
3337 C The sign of H0 is inferred from the initial values of TOUT and T.
3338 C ABS(H0) is made .le. ABS(TOUT-T) in any case.
3339 C-----------------------------------------------------------------------
3340  lf0 = lyh + nyh
3341  IF (h0 .NE. 0.0d0) GO TO 180
3342  tdist = abs(tout - t)
3343  w0 = max(abs(t),abs(tout))
3344  IF (tdist .LT. 2.0d0*uround*w0) GO TO 622
3345  tol = rtol(1)
3346  IF (itol .LE. 2) GO TO 140
3347  DO 130 i = 1,n
3348  130 tol = max(tol,rtol(i))
3349  140 IF (tol .GT. 0.0d0) GO TO 160
3350  atoli = atol(1)
3351  DO 150 i = 1,n
3352  IF (itol .EQ. 2 .OR. itol .EQ. 4) atoli = atol(i)
3353  ayi = abs(y(i))
3354  IF (ayi .NE. 0.0d0) tol = max(tol,atoli/ayi)
3355  150 CONTINUE
3356  160 tol = max(tol,100.0d0*uround)
3357  tol = min(tol,0.001d0)
3358  sum = dvnorm(n, rwork(lf0), rwork(lewt))
3359  sum = 1.0d0/(tol*w0*w0) + tol*sum**2
3360  h0 = 1.0d0/sqrt(sum)
3361  h0 = min(h0,tdist)
3362  h0 = sign(h0,tout-t)
3363 C Adjust H0 if necessary to meet HMAX bound. ---------------------------
3364  180 rh = abs(h0)*hmxi
3365  IF (rh .GT. 1.0d0) h0 = h0/rh
3366 C Load H with H0 and scale YH(*,2) by H0. ------------------------------
3367  h = h0
3368  DO 190 i = 1,n
3369  190 rwork(i+lf0-1) = h0*rwork(i+lf0-1)
3370  GO TO 270
3371 C-----------------------------------------------------------------------
3372 C Block D.
3373 C The next code block is for continuation calls only (ISTATE = 2 or 3)
3374 C and is to check stop conditions before taking a step.
3375 C-----------------------------------------------------------------------
3376  200 nslast = nst
3377  GO TO (210, 250, 220, 230, 240), itask
3378  210 IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
3379  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
3380  IF (iflag .NE. 0) GO TO 627
3381  t = tout
3382  GO TO 420
3383  220 tp = tn - hu*(1.0d0 + 100.0d0*uround)
3384  IF ((tp - tout)*h .GT. 0.0d0) GO TO 623
3385  IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
3386  GO TO 400
3387  230 tcrit = rwork(1)
3388  IF ((tn - tcrit)*h .GT. 0.0d0) GO TO 624
3389  IF ((tcrit - tout)*h .LT. 0.0d0) GO TO 625
3390  IF ((tn - tout)*h .LT. 0.0d0) GO TO 245
3391  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
3392  IF (iflag .NE. 0) GO TO 627
3393  t = tout
3394  GO TO 420
3395  240 tcrit = rwork(1)
3396  IF ((tn - tcrit)*h .GT. 0.0d0) GO TO 624
3397  245 hmx = abs(tn) + abs(h)
3398  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
3399  IF (ihit) GO TO 400
3400  tnext = tn + h*(1.0d0 + 4.0d0*uround)
3401  IF ((tnext - tcrit)*h .LE. 0.0d0) GO TO 250
3402  h = (tcrit - tn)*(1.0d0 - 4.0d0*uround)
3403  IF (istate .EQ. 2) jstart = -2
3404 C-----------------------------------------------------------------------
3405 C Block E.
3406 C The next block is normally executed for all calls and contains
3407 C the call to the one-step core integrator DSTODE.
3408 C
3409 C This is a looping point for the integration steps.
3410 C
3411 C First check for too many steps being taken, update EWT (if not at
3412 C start of problem), check for too much accuracy being requested, and
3413 C check for H below the roundoff level in T.
3414 C-----------------------------------------------------------------------
3415  250 CONTINUE
3416  IF ((nst-nslast) .GE. mxstep) GO TO 500
3417  CALL dewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt))
3418  DO 260 i = 1,n
3419  IF (rwork(i+lewt-1) .LE. 0.0d0) GO TO 510
3420  260 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1)
3421  270 tolsf = uround*dvnorm(n, rwork(lyh), rwork(lewt))
3422  IF (tolsf .LE. 1.0d0) GO TO 280
3423  tolsf = tolsf*2.0d0
3424  IF (nst .EQ. 0) GO TO 626
3425  GO TO 520
3426  280 IF ((tn + h) .NE. tn) GO TO 290
3427  nhnil = nhnil + 1
3428  IF (nhnil .GT. mxhnil) GO TO 290
3429  msg = 'DLSODES- Warning..Internal T (=R1) and H (=R2) are'
3430  CALL xerrwd (msg, 50, 101, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
3431  msg=' such that in the machine, T + H = T on the next step '
3432  CALL xerrwd (msg, 60, 101, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
3433  msg = ' (H = step size). Solver will continue anyway.'
3434  CALL xerrwd (msg, 50, 101, 0, 0, 0, 0, 2, tn, h)
3435  IF (nhnil .LT. mxhnil) GO TO 290
3436  msg = 'DLSODES- Above warning has been issued I1 times. '
3437  CALL xerrwd (msg, 50, 102, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
3438  msg = ' It will not be issued again for this problem.'
3439  CALL xerrwd (msg, 50, 102, 0, 1, mxhnil, 0, 0, 0.0d0, 0.0d0)
3440  290 CONTINUE
3441 C-----------------------------------------------------------------------
3442 C CALL DSTODE(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,WM,F,JAC,DPRJS,DSOLSS)
3443 C-----------------------------------------------------------------------
3444  CALL dstode (neq, y, rwork(lyh), nyh, rwork(lyh), rwork(lewt),
3445  1 rwork(lsavf), rwork(lacor), rwork(lwm), rwork(lwm),
3446  2 f, jac, dprjs, dsolss)
3447  kgo = 1 - kflag
3448  GO TO (300, 530, 540, 550), kgo
3449 C-----------------------------------------------------------------------
3450 C Block F.
3451 C The following block handles the case of a successful return from the
3452 C core integrator (KFLAG = 0). Test for stop conditions.
3453 C-----------------------------------------------------------------------
3454  300 init = 1
3455  GO TO (310, 400, 330, 340, 350), itask
3456 C ITASK = 1. if TOUT has been reached, interpolate. -------------------
3457  310 IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
3458  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
3459  t = tout
3460  GO TO 420
3461 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------
3462  330 IF ((tn - tout)*h .GE. 0.0d0) GO TO 400
3463  GO TO 250
3464 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary.
3465  340 IF ((tn - tout)*h .LT. 0.0d0) GO TO 345
3466  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
3467  t = tout
3468  GO TO 420
3469  345 hmx = abs(tn) + abs(h)
3470  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
3471  IF (ihit) GO TO 400
3472  tnext = tn + h*(1.0d0 + 4.0d0*uround)
3473  IF ((tnext - tcrit)*h .LE. 0.0d0) GO TO 250
3474  h = (tcrit - tn)*(1.0d0 - 4.0d0*uround)
3475  jstart = -2
3476  GO TO 250
3477 C ITASK = 5. See if TCRIT was reached and jump to exit. ---------------
3478  350 hmx = abs(tn) + abs(h)
3479  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
3480 C-----------------------------------------------------------------------
3481 C Block G.
3482 C The following block handles all successful returns from DLSODES.
3483 C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly.
3484 C ISTATE is set to 2, and the optional outputs are loaded into the
3485 C work arrays before returning.
3486 C-----------------------------------------------------------------------
3487  400 DO 410 i = 1,n
3488  410 y(i) = rwork(i+lyh-1)
3489  t = tn
3490  IF (itask .NE. 4 .AND. itask .NE. 5) GO TO 420
3491  IF (ihit) t = tcrit
3492  420 istate = 2
3493  rwork(11) = hu
3494  rwork(12) = h
3495  rwork(13) = tn
3496  iwork(11) = nst
3497  iwork(12) = nfe
3498  iwork(13) = nje
3499  iwork(14) = nqu
3500  iwork(15) = nq
3501  iwork(19) = nnz
3502  iwork(20) = ngp
3503  iwork(21) = nlu
3504  iwork(25) = nzl
3505  iwork(26) = nzu
3506  RETURN
3507 C-----------------------------------------------------------------------
3508 C Block H.
3509 C The following block handles all unsuccessful returns other than
3510 C those for illegal input. First the error message routine is called.
3511 C If there was an error test or convergence test failure, IMXER is set.
3512 C Then Y is loaded from YH and T is set to TN.
3513 C The optional outputs are loaded into the work arrays before returning.
3514 C-----------------------------------------------------------------------
3515 C The maximum number of steps was taken before reaching TOUT. ----------
3516  500 msg = 'DLSODES- At current T (=R1), MXSTEP (=I1) steps '
3517  CALL xerrwd (msg, 50, 201, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
3518  msg = ' taken on this call before reaching TOUT '
3519  CALL xerrwd (msg, 50, 201, 0, 1, mxstep, 0, 1, tn, 0.0d0)
3520  istate = -1
3521  GO TO 580
3522 C EWT(i) .le. 0.0 for some i (not at start of problem). ----------------
3523  510 ewti = rwork(lewt+i-1)
3524  msg = .le.'DLSODES- At T (=R1), EWT(I1) has become R2 0.'
3525  CALL xerrwd (msg, 50, 202, 0, 1, i, 0, 2, tn, ewti)
3526  istate = -6
3527  GO TO 580
3528 C Too much accuracy requested for machine precision. -------------------
3529  520 msg = 'DLSODES- At T (=R1), too much accuracy requested '
3530  CALL xerrwd (msg, 50, 203, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
3531  msg = ' for precision of machine.. See TOLSF (=R2) '
3532  CALL xerrwd (msg, 50, 203, 0, 0, 0, 0, 2, tn, tolsf)
3533  rwork(14) = tolsf
3534  istate = -2
3535  GO TO 580
3536 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. -----
3537  530 msg = 'DLSODES- At T(=R1) and step size H(=R2), the error'
3538  CALL xerrwd (msg, 50, 204, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
3539  msg = ' test failed repeatedly or with ABS(H) = HMIN'
3540  CALL xerrwd (msg, 50, 204, 0, 0, 0, 0, 2, tn, h)
3541  istate = -4
3542  GO TO 560
3543 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ----
3544  540 msg = 'DLSODES- At T (=R1) and step size H (=R2), the '
3545  CALL xerrwd (msg, 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
3546  msg = ' corrector convergence failed repeatedly '
3547  CALL xerrwd (msg, 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
3548  msg = ' or with ABS(H) = HMIN '
3549  CALL xerrwd (msg, 30, 205, 0, 0, 0, 0, 2, tn, h)
3550  istate = -5
3551  GO TO 560
3552 C KFLAG = -3. Fatal error flag returned by DPRJS or DSOLSS (CDRV). ----
3553  550 msg = 'DLSODES- At T (=R1) and step size H (=R2), a fatal'
3554  CALL xerrwd (msg, 50, 207, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
3555  msg = ' error flag was returned by CDRV (by way of '
3556  CALL xerrwd (msg, 50, 207, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
3557  msg = ' Subroutine DPRJS or DSOLSS) '
3558  CALL xerrwd (msg, 40, 207, 0, 0, 0, 0, 2, tn, h)
3559  istate = -7
3560  GO TO 580
3561 C Compute IMXER if relevant. -------------------------------------------
3562  560 big = 0.0d0
3563  imxer = 1
3564  DO 570 i = 1,n
3565  SIZE = abs(rwork(i+lacor-1)*rwork(i+lewt-1))
3566  IF (big .GE. size) GO TO 570
3567  big = SIZE
3568  imxer = i
3569  570 CONTINUE
3570  iwork(16) = imxer
3571 C Set Y vector, T, and optional outputs. -------------------------------
3572  580 DO 590 i = 1,n
3573  590 y(i) = rwork(i+lyh-1)
3574  t = tn
3575  rwork(11) = hu
3576  rwork(12) = h
3577  rwork(13) = tn
3578  iwork(11) = nst
3579  iwork(12) = nfe
3580  iwork(13) = nje
3581  iwork(14) = nqu
3582  iwork(15) = nq
3583  iwork(19) = nnz
3584  iwork(20) = ngp
3585  iwork(21) = nlu
3586  iwork(25) = nzl
3587  iwork(26) = nzu
3588  RETURN
3589 C-----------------------------------------------------------------------
3590 C Block I.
3591 C The following block handles all error returns due to illegal input
3592 C (ISTATE = -3), as detected before calling the core integrator.
3593 C First the error message routine is called. If the illegal input
3594 C is a negative ISTATE, the run is aborted (apparent infinite loop).
3595 C-----------------------------------------------------------------------
3596  601 msg = 'DLSODES- ISTATE (=I1) illegal.'
3597  CALL xerrwd (msg, 30, 1, 0, 1, istate, 0, 0, 0.0d0, 0.0d0)
3598  IF (istate .LT. 0) GO TO 800
3599  GO TO 700
3600  602 msg = 'DLSODES- ITASK (=I1) illegal. '
3601  CALL xerrwd (msg, 30, 2, 0, 1, itask, 0, 0, 0.0d0, 0.0d0)
3602  GO TO 700
3603  603 msg = .gt.'DLSODES- ISTATE1 but DLSODES not initialized. '
3604  CALL xerrwd (msg, 50, 3, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
3605  GO TO 700
3606  604 msg = .lt.'DLSODES- NEQ (=I1) 1 '
3607  CALL xerrwd (msg, 30, 4, 0, 1, neq(1), 0, 0, 0.0d0, 0.0d0)
3608  GO TO 700
3609  605 msg = 'DLSODES- ISTATE = 3 and NEQ increased (I1 to I2). '
3610  CALL xerrwd (msg, 50, 5, 0, 2, n, neq(1), 0, 0.0d0, 0.0d0)
3611  GO TO 700
3612  606 msg = 'DLSODES- ITOL (=I1) illegal. '
3613  CALL xerrwd (msg, 30, 6, 0, 1, itol, 0, 0, 0.0d0, 0.0d0)
3614  GO TO 700
3615  607 msg = 'DLSODES- IOPT (=I1) illegal. '
3616  CALL xerrwd (msg, 30, 7, 0, 1, iopt, 0, 0, 0.0d0, 0.0d0)
3617  GO TO 700
3618  608 msg = 'DLSODES- MF (=I1) illegal. '
3619  CALL xerrwd (msg, 30, 8, 0, 1, mf, 0, 0, 0.0d0, 0.0d0)
3620  GO TO 700
3621  609 msg = .lt.'DLSODES- SETH (=R1) 0.0 '
3622  CALL xerrwd (msg, 30, 9, 0, 0, 0, 0, 1, seth, 0.0d0)
3623  GO TO 700
3624  611 msg = .lt.'DLSODES- MAXORD (=I1) 0 '
3625  CALL xerrwd (msg, 30, 11, 0, 1, maxord, 0, 0, 0.0d0, 0.0d0)
3626  GO TO 700
3627  612 msg = .lt.'DLSODES- MXSTEP (=I1) 0 '
3628  CALL xerrwd (msg, 30, 12, 0, 1, mxstep, 0, 0, 0.0d0, 0.0d0)
3629  GO TO 700
3630  613 msg = .lt.'DLSODES- MXHNIL (=I1) 0 '
3631  CALL xerrwd (msg, 30, 13, 0, 1, mxhnil, 0, 0, 0.0d0, 0.0d0)
3632  GO TO 700
3633  614 msg = 'DLSODES- TOUT (=R1) behind T (=R2) '
3634  CALL xerrwd (msg, 40, 14, 0, 0, 0, 0, 2, tout, t)
3635  msg = ' Integration direction is given by H0 (=R1) '
3636  CALL xerrwd (msg, 50, 14, 0, 0, 0, 0, 1, h0, 0.0d0)
3637  GO TO 700
3638  615 msg = .lt.'DLSODES- HMAX (=R1) 0.0 '
3639  CALL xerrwd (msg, 30, 15, 0, 0, 0, 0, 1, hmax, 0.0d0)
3640  GO TO 700
3641  616 msg = .lt.'DLSODES- HMIN (=R1) 0.0 '
3642  CALL xerrwd (msg, 30, 16, 0, 0, 0, 0, 1, hmin, 0.0d0)
3643  GO TO 700
3644  617 msg = 'DLSODES- RWORK length is insufficient to proceed. '
3645  CALL xerrwd (msg, 50, 17, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
3646  msg=.ge.' Length needed is LENRW (=I1), exceeds LRW (=I2)'
3647  CALL xerrwd (msg, 60, 17, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0)
3648  GO TO 700
3649  618 msg = 'DLSODES- IWORK length is insufficient to proceed. '
3650  CALL xerrwd (msg, 50, 18, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
3651  msg=.ge.' Length needed is LENIW (=I1), exceeds LIW (=I2)'
3652  CALL xerrwd (msg, 60, 18, 0, 2, leniw, liw, 0, 0.0d0, 0.0d0)
3653  GO TO 700
3654  619 msg = .lt.'DLSODES- RTOL(I1) is R1 0.0 '
3655  CALL xerrwd (msg, 40, 19, 0, 1, i, 0, 1, rtoli, 0.0d0)
3656  GO TO 700
3657  620 msg = .lt.'DLSODES- ATOL(I1) is R1 0.0 '
3658  CALL xerrwd (msg, 40, 20, 0, 1, i, 0, 1, atoli, 0.0d0)
3659  GO TO 700
3660  621 ewti = rwork(lewt+i-1)
3661  msg = .le.'DLSODES- EWT(I1) is R1 0.0 '
3662  CALL xerrwd (msg, 40, 21, 0, 1, i, 0, 1, ewti, 0.0d0)
3663  GO TO 700
3664  622 msg='DLSODES- TOUT(=R1) too close to T(=R2) to start integration.'
3665  CALL xerrwd (msg, 60, 22, 0, 0, 0, 0, 2, tout, t)
3666  GO TO 700
3667  623 msg='DLSODES- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) '
3668  CALL xerrwd (msg, 60, 23, 0, 1, itask, 0, 2, tout, tp)
3669  GO TO 700
3670  624 msg='DLSODES- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) '
3671  CALL xerrwd (msg, 60, 24, 0, 0, 0, 0, 2, tcrit, tn)
3672  GO TO 700
3673  625 msg='DLSODES- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) '
3674  CALL xerrwd (msg, 60, 25, 0, 0, 0, 0, 2, tcrit, tout)
3675  GO TO 700
3676  626 msg = 'DLSODES- At start of problem, too much accuracy '
3677  CALL xerrwd (msg, 50, 26, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
3678  msg=' requested for precision of machine.. See TOLSF (=R1) '
3679  CALL xerrwd (msg, 60, 26, 0, 0, 0, 0, 1, tolsf, 0.0d0)
3680  rwork(14) = tolsf
3681  GO TO 700
3682  627 msg = 'DLSODES- Trouble in DINTDY. ITASK = I1, TOUT = R1'
3683  CALL xerrwd (msg, 50, 27, 0, 1, itask, 0, 1, tout, 0.0d0)
3684  GO TO 700
3685  628 msg='DLSODES- RWORK length insufficient (for Subroutine DPREP). '
3686  CALL xerrwd (msg, 60, 28, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
3687  msg=.ge.' Length needed is LENRW (=I1), exceeds LRW (=I2)'
3688  CALL xerrwd (msg, 60, 28, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0)
3689  GO TO 700
3690  629 msg='DLSODES- RWORK length insufficient (for Subroutine JGROUP). '
3691  CALL xerrwd (msg, 60, 29, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
3692  msg=.ge.' Length needed is LENRW (=I1), exceeds LRW (=I2)'
3693  CALL xerrwd (msg, 60, 29, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0)
3694  GO TO 700
3695  630 msg='DLSODES- RWORK length insufficient (for Subroutine ODRV). '
3696  CALL xerrwd (msg, 60, 30, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
3697  msg=.ge.' Length needed is LENRW (=I1), exceeds LRW (=I2)'
3698  CALL xerrwd (msg, 60, 30, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0)
3699  GO TO 700
3700  631 msg='DLSODES- Error from ODRV in Yale Sparse Matrix Package. '
3701  CALL xerrwd (msg, 60, 31, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
3702  imul = (iys - 1)/n
3703  irem = iys - imul*n
3704  msg=' At T (=R1), ODRV returned error flag = I1*NEQ + I2. '
3705  CALL xerrwd (msg, 60, 31, 0, 2, imul, irem, 1, tn, 0.0d0)
3706  GO TO 700
3707  632 msg='DLSODES- RWORK length insufficient (for Subroutine CDRV). '
3708  CALL xerrwd (msg, 60, 32, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
3709  msg=.ge.' Length needed is LENRW (=I1), exceeds LRW (=I2)'
3710  CALL xerrwd (msg, 60, 32, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0)
3711  GO TO 700
3712  633 msg='DLSODES- Error from CDRV in Yale Sparse Matrix Package. '
3713  CALL xerrwd (msg, 60, 33, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
3714  imul = (iys - 1)/n
3715  irem = iys - imul*n
3716  msg=' At T (=R1), CDRV returned error flag = I1*NEQ + I2. '
3717  CALL xerrwd (msg, 60, 33, 0, 2, imul, irem, 1, tn, 0.0d0)
3718  IF (imul .EQ. 2) THEN
3719  msg=' Duplicate entry in sparsity structure descriptors. '
3720  CALL xerrwd (msg, 60, 33, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
3721  ENDIF
3722  IF (imul .EQ. 3 .OR. imul .EQ. 6) THEN
3723  msg=' Insufficient storage for NSFC (called by CDRV). '
3724  CALL xerrwd (msg, 60, 33, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
3725  ENDIF
3726 C
3727  700 istate = -3
3728  RETURN
3729 C
3730  800 msg = 'DLSODES- Run aborted.. apparent infinite loop. '
3731  CALL xerrwd (msg, 50, 303, 2, 0, 0, 0, 0, 0.0d0, 0.0d0)
3732  RETURN
3733 C----------------------- End of Subroutine DLSODES ---------------------
3734  END
3735 *DECK DLSODA
3736  SUBROUTINE dlsoda (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK,
3737  1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, JT)
3738  EXTERNAL f, jac
3739  INTEGER neq, itol, itask, istate, iopt, lrw, iwork, liw, jt
3740  DOUBLE PRECISION y, t, tout, rtol, atol, rwork
3741  dimension neq(*), y(*), rtol(*), atol(*), rwork(lrw), iwork(liw)
3742 C-----------------------------------------------------------------------
3743 C This is the 12 November 2003 version of
3744 C DLSODA: Livermore Solver for Ordinary Differential Equations, with
3745 C Automatic method switching for stiff and nonstiff problems.
3746 C
3747 C This version is in double precision.
3748 C
3749 C DLSODA solves the initial value problem for stiff or nonstiff
3750 C systems of first order ODEs,
3751 C dy/dt = f(t,y) , or, in component form,
3752 C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ).
3753 C
3754 C This a variant version of the DLSODE package.
3755 C It switches automatically between stiff and nonstiff methods.
3756 C This means that the user does not have to determine whether the
3757 C problem is stiff or not, and the solver will automatically choose the
3758 C appropriate method. It always starts with the nonstiff method.
3759 C
3760 C Authors: Alan C. Hindmarsh
3761 C Center for Applied Scientific Computing, L-561
3762 C Lawrence Livermore National Laboratory
3763 C Livermore, CA 94551
3764 C and
3765 C Linda R. Petzold
3766 C Univ. of California at Santa Barbara
3767 C Dept. of Computer Science
3768 C Santa Barbara, CA 93106
3769 C
3770 C References:
3771 C 1. Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE
3772 C Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.),
3773 C North-Holland, Amsterdam, 1983, pp. 55-64.
3774 C 2. Linda R. Petzold, Automatic Selection of Methods for Solving
3775 C Stiff and Nonstiff Systems of Ordinary Differential Equations,
3776 C Siam J. Sci. Stat. Comput. 4 (1983), pp. 136-148.
3777 C-----------------------------------------------------------------------
3778 C Summary of Usage.
3779 C
3780 C Communication between the user and the DLSODA package, for normal
3781 C situations, is summarized here. This summary describes only a subset
3782 C of the full set of options available. See the full description for
3783 C details, including alternative treatment of the Jacobian matrix,
3784 C optional inputs and outputs, nonstandard options, and
3785 C instructions for special situations. See also the example
3786 C problem (with program and output) following this summary.
3787 C
3788 C A. First provide a subroutine of the form:
3789 C SUBROUTINE F (NEQ, T, Y, YDOT)
3790 C DOUBLE PRECISION T, Y(*), YDOT(*)
3791 C which supplies the vector function f by loading YDOT(i) with f(i).
3792 C
3793 C B. Write a main program which calls Subroutine DLSODA once for
3794 C each point at which answers are desired. This should also provide
3795 C for possible use of logical unit 6 for output of error messages
3796 C by DLSODA. On the first call to DLSODA, supply arguments as follows:
3797 C F = name of subroutine for right-hand side vector f.
3798 C This name must be declared External in calling program.
3799 C NEQ = number of first order ODEs.
3800 C Y = array of initial values, of length NEQ.
3801 C T = the initial value of the independent variable.
3802 C TOUT = first point where output is desired (.ne. T).
3803 C ITOL = 1 or 2 according as ATOL (below) is a scalar or array.
3804 C RTOL = relative tolerance parameter (scalar).
3805 C ATOL = absolute tolerance parameter (scalar or array).
3806 C the estimated local error in y(i) will be controlled so as
3807 C to be less than
3808 C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or
3809 C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2.
3810 C Thus the local error test passes if, in each component,
3811 C either the absolute error is less than ATOL (or ATOL(i)),
3812 C or the relative error is less than RTOL.
3813 C Use RTOL = 0.0 for pure absolute error control, and
3814 C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error
3815 C control. Caution: actual (global) errors may exceed these
3816 C local tolerances, so choose them conservatively.
3817 C ITASK = 1 for normal computation of output values of y at t = TOUT.
3818 C ISTATE = integer flag (input and output). Set ISTATE = 1.
3819 C IOPT = 0 to indicate no optional inputs used.
3820 C RWORK = real work array of length at least:
3821 C 22 + NEQ * MAX(16, NEQ + 9).
3822 C See also Paragraph E below.
3823 C LRW = declared length of RWORK (in user's dimension).
3824 C IWORK = integer work array of length at least 20 + NEQ.
3825 C LIW = declared length of IWORK (in user's dimension).
3826 C JAC = name of subroutine for Jacobian matrix.
3827 C Use a dummy name. See also Paragraph E below.
3828 C JT = Jacobian type indicator. Set JT = 2.
3829 C See also Paragraph E below.
3830 C Note that the main program must declare arrays Y, RWORK, IWORK,
3831 C and possibly ATOL.
3832 C
3833 C C. The output from the first call (or any call) is:
3834 C Y = array of computed values of y(t) vector.
3835 C T = corresponding value of independent variable (normally TOUT).
3836 C ISTATE = 2 if DLSODA was successful, negative otherwise.
3837 C -1 means excess work done on this call (perhaps wrong JT).
3838 C -2 means excess accuracy requested (tolerances too small).
3839 C -3 means illegal input detected (see printed message).
3840 C -4 means repeated error test failures (check all inputs).
3841 C -5 means repeated convergence failures (perhaps bad Jacobian
3842 C supplied or wrong choice of JT or tolerances).
3843 C -6 means error weight became zero during problem. (Solution
3844 C component i vanished, and ATOL or ATOL(i) = 0.)
3845 C -7 means work space insufficient to finish (see messages).
3846 C
3847 C D. To continue the integration after a successful return, simply
3848 C reset TOUT and call DLSODA again. No other parameters need be reset.
3849 C
3850 C E. Note: If and when DLSODA regards the problem as stiff, and
3851 C switches methods accordingly, it must make use of the NEQ by NEQ
3852 C Jacobian matrix, J = df/dy. For the sake of simplicity, the
3853 C inputs to DLSODA recommended in Paragraph B above cause DLSODA to
3854 C treat J as a full matrix, and to approximate it internally by
3855 C difference quotients. Alternatively, J can be treated as a band
3856 C matrix (with great potential reduction in the size of the RWORK
3857 C array). Also, in either the full or banded case, the user can supply
3858 C J in closed form, with a routine whose name is passed as the JAC
3859 C argument. These alternatives are described in the paragraphs on
3860 C RWORK, JAC, and JT in the full description of the call sequence below.
3861 C
3862 C-----------------------------------------------------------------------
3863 C Example Problem.
3864 C
3865 C The following is a simple example problem, with the coding
3866 C needed for its solution by DLSODA. The problem is from chemical
3867 C kinetics, and consists of the following three rate equations:
3868 C dy1/dt = -.04*y1 + 1.e4*y2*y3
3869 C dy2/dt = .04*y1 - 1.e4*y2*y3 - 3.e7*y2**2
3870 C dy3/dt = 3.e7*y2**2
3871 C on the interval from t = 0.0 to t = 4.e10, with initial conditions
3872 C y1 = 1.0, y2 = y3 = 0. The problem is stiff.
3873 C
3874 C The following coding solves this problem with DLSODA,
3875 C printing results at t = .4, 4., ..., 4.e10. It uses
3876 C ITOL = 2 and ATOL much smaller for y2 than y1 or y3 because
3877 C y2 has much smaller values.
3878 C At the end of the run, statistical quantities of interest are
3879 C printed (see optional outputs in the full description below).
3880 C
3881 C EXTERNAL FEX
3882 C DOUBLE PRECISION ATOL, RTOL, RWORK, T, TOUT, Y
3883 C DIMENSION Y(3), ATOL(3), RWORK(70), IWORK(23)
3884 C NEQ = 3
3885 C Y(1) = 1.
3886 C Y(2) = 0.
3887 C Y(3) = 0.
3888 C T = 0.
3889 C TOUT = .4
3890 C ITOL = 2
3891 C RTOL = 1.D-4
3892 C ATOL(1) = 1.D-6
3893 C ATOL(2) = 1.D-10
3894 C ATOL(3) = 1.D-6
3895 C ITASK = 1
3896 C ISTATE = 1
3897 C IOPT = 0
3898 C LRW = 70
3899 C LIW = 23
3900 C JT = 2
3901 C DO 40 IOUT = 1,12
3902 C CALL DLSODA(FEX,NEQ,Y,T,TOUT,ITOL,RTOL,ATOL,ITASK,ISTATE,
3903 C 1 IOPT,RWORK,LRW,IWORK,LIW,JDUM,JT)
3904 C WRITE(6,20)T,Y(1),Y(2),Y(3)
3905 C 20 FORMAT(' At t =',D12.4,' Y =',3D14.6)
3906 C IF (ISTATE .LT. 0) GO TO 80
3907 C 40 TOUT = TOUT*10.
3908 C WRITE(6,60)IWORK(11),IWORK(12),IWORK(13),IWORK(19),RWORK(15)
3909 C 60 FORMAT(/' No. steps =',I4,' No. f-s =',I4,' No. J-s =',I4/
3910 C 1 ' Method last used =',I2,' Last switch was at t =',D12.4)
3911 C STOP
3912 C 80 WRITE(6,90)ISTATE
3913 C 90 FORMAT(///' Error halt.. ISTATE =',I3)
3914 C STOP
3915 C END
3916 C
3917 C SUBROUTINE FEX (NEQ, T, Y, YDOT)
3918 C DOUBLE PRECISION T, Y, YDOT
3919 C DIMENSION Y(3), YDOT(3)
3920 C YDOT(1) = -.04*Y(1) + 1.D4*Y(2)*Y(3)
3921 C YDOT(3) = 3.D7*Y(2)*Y(2)
3922 C YDOT(2) = -YDOT(1) - YDOT(3)
3923 C RETURN
3924 C END
3925 C
3926 C The output of this program (on a CDC-7600 in single precision)
3927 C is as follows:
3928 C
3929 C At t = 4.0000e-01 y = 9.851712e-01 3.386380e-05 1.479493e-02
3930 C At t = 4.0000e+00 Y = 9.055333e-01 2.240655e-05 9.444430e-02
3931 C At t = 4.0000e+01 Y = 7.158403e-01 9.186334e-06 2.841505e-01
3932 C At t = 4.0000e+02 Y = 4.505250e-01 3.222964e-06 5.494717e-01
3933 C At t = 4.0000e+03 Y = 1.831975e-01 8.941774e-07 8.168016e-01
3934 C At t = 4.0000e+04 Y = 3.898730e-02 1.621940e-07 9.610125e-01
3935 C At t = 4.0000e+05 Y = 4.936363e-03 1.984221e-08 9.950636e-01
3936 C At t = 4.0000e+06 Y = 5.161831e-04 2.065786e-09 9.994838e-01
3937 C At t = 4.0000e+07 Y = 5.179817e-05 2.072032e-10 9.999482e-01
3938 C At t = 4.0000e+08 Y = 5.283401e-06 2.113371e-11 9.999947e-01
3939 C At t = 4.0000e+09 Y = 4.659031e-07 1.863613e-12 9.999995e-01
3940 C At t = 4.0000e+10 Y = 1.404280e-08 5.617126e-14 1.000000e+00
3941 C
3942 C No. steps = 361 No. f-s = 693 No. J-s = 64
3943 C Method last used = 2 Last switch was at t = 6.0092e-03
3944 C-----------------------------------------------------------------------
3945 C Full description of user interface to DLSODA.
3946 C
3947 C The user interface to DLSODA consists of the following parts.
3948 C
3949 C 1. The call sequence to Subroutine DLSODA, which is a driver
3950 C routine for the solver. This includes descriptions of both
3951 C the call sequence arguments and of user-supplied routines.
3952 C following these descriptions is a description of
3953 C optional inputs available through the call sequence, and then
3954 C a description of optional outputs (in the work arrays).
3955 C
3956 C 2. Descriptions of other routines in the DLSODA package that may be
3957 C (optionally) called by the user. These provide the ability to
3958 C alter error message handling, save and restore the internal
3959 C Common, and obtain specified derivatives of the solution y(t).
3960 C
3961 C 3. Descriptions of Common blocks to be declared in overlay
3962 C or similar environments, or to be saved when doing an interrupt
3963 C of the problem and continued solution later.
3964 C
3965 C 4. Description of a subroutine in the DLSODA package,
3966 C which the user may replace with his/her own version, if desired.
3967 C this relates to the measurement of errors.
3968 C
3969 C-----------------------------------------------------------------------
3970 C Part 1. Call Sequence.
3971 C
3972 C The call sequence parameters used for input only are
3973 C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, JT,
3974 C and those used for both input and output are
3975 C Y, T, ISTATE.
3976 C The work arrays RWORK and IWORK are also used for conditional and
3977 C optional inputs and optional outputs. (The term output here refers
3978 C to the return from Subroutine DLSODA to the user's calling program.)
3979 C
3980 C The legality of input parameters will be thoroughly checked on the
3981 C initial call for the problem, but not checked thereafter unless a
3982 C change in input parameters is flagged by ISTATE = 3 on input.
3983 C
3984 C The descriptions of the call arguments are as follows.
3985 C
3986 C F = the name of the user-supplied subroutine defining the
3987 C ODE system. The system must be put in the first-order
3988 C form dy/dt = f(t,y), where f is a vector-valued function
3989 C of the scalar t and the vector y. Subroutine F is to
3990 C compute the function f. It is to have the form
3991 C SUBROUTINE F (NEQ, T, Y, YDOT)
3992 C DOUBLE PRECISION T, Y(*), YDOT(*)
3993 C where NEQ, T, and Y are input, and the array YDOT = f(t,y)
3994 C is output. Y and YDOT are arrays of length NEQ.
3995 C Subroutine F should not alter Y(1),...,Y(NEQ).
3996 C F must be declared External in the calling program.
3997 C
3998 C Subroutine F may access user-defined quantities in
3999 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array
4000 C (dimensioned in F) and/or Y has length exceeding NEQ(1).
4001 C See the descriptions of NEQ and Y below.
4002 C
4003 C If quantities computed in the F routine are needed
4004 C externally to DLSODA, an extra call to F should be made
4005 C for this purpose, for consistent and accurate results.
4006 C If only the derivative dy/dt is needed, use DINTDY instead.
4007 C
4008 C NEQ = the size of the ODE system (number of first order
4009 C ordinary differential equations). Used only for input.
4010 C NEQ may be decreased, but not increased, during the problem.
4011 C If NEQ is decreased (with ISTATE = 3 on input), the
4012 C remaining components of Y should be left undisturbed, if
4013 C these are to be accessed in F and/or JAC.
4014 C
4015 C Normally, NEQ is a scalar, and it is generally referred to
4016 C as a scalar in this user interface description. However,
4017 C NEQ may be an array, with NEQ(1) set to the system size.
4018 C (The DLSODA package accesses only NEQ(1).) In either case,
4019 C this parameter is passed as the NEQ argument in all calls
4020 C to F and JAC. Hence, if it is an array, locations
4021 C NEQ(2),... may be used to store other integer data and pass
4022 C it to F and/or JAC. Subroutines F and/or JAC must include
4023 C NEQ in a Dimension statement in that case.
4024 C
4025 C Y = a real array for the vector of dependent variables, of
4026 C length NEQ or more. Used for both input and output on the
4027 C first call (ISTATE = 1), and only for output on other calls.
4028 C On the first call, Y must contain the vector of initial
4029 C values. On output, Y contains the computed solution vector,
4030 C evaluated at T. If desired, the Y array may be used
4031 C for other purposes between calls to the solver.
4032 C
4033 C This array is passed as the Y argument in all calls to
4034 C F and JAC. Hence its length may exceed NEQ, and locations
4035 C Y(NEQ+1),... may be used to store other real data and
4036 C pass it to F and/or JAC. (The DLSODA package accesses only
4037 C Y(1),...,Y(NEQ).)
4038 C
4039 C T = the independent variable. On input, T is used only on the
4040 C first call, as the initial point of the integration.
4041 C on output, after each call, T is the value at which a
4042 C computed solution Y is evaluated (usually the same as TOUT).
4043 C on an error return, T is the farthest point reached.
4044 C
4045 C TOUT = the next value of t at which a computed solution is desired.
4046 C Used only for input.
4047 C
4048 C When starting the problem (ISTATE = 1), TOUT may be equal
4049 C to T for one call, then should .ne. T for the next call.
4050 C For the initial t, an input value of TOUT .ne. T is used
4051 C in order to determine the direction of the integration
4052 C (i.e. the algebraic sign of the step sizes) and the rough
4053 C scale of the problem. Integration in either direction
4054 C (forward or backward in t) is permitted.
4055 C
4056 C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after
4057 C the first call (i.e. the first call with TOUT .ne. T).
4058 C Otherwise, TOUT is required on every call.
4059 C
4060 C If ITASK = 1, 3, or 4, the values of TOUT need not be
4061 C monotone, but a value of TOUT which backs up is limited
4062 C to the current internal T interval, whose endpoints are
4063 C TCUR - HU and TCUR (see optional outputs, below, for
4064 C TCUR and HU).
4065 C
4066 C ITOL = an indicator for the type of error control. See
4067 C description below under ATOL. Used only for input.
4068 C
4069 C RTOL = a relative error tolerance parameter, either a scalar or
4070 C an array of length NEQ. See description below under ATOL.
4071 C Input only.
4072 C
4073 C ATOL = an absolute error tolerance parameter, either a scalar or
4074 C an array of length NEQ. Input only.
4075 C
4076 C The input parameters ITOL, RTOL, and ATOL determine
4077 C the error control performed by the solver. The solver will
4078 C control the vector E = (E(i)) of estimated local errors
4079 C in y, according to an inequality of the form
4080 C max-norm of ( E(i)/EWT(i) ) .le. 1,
4081 C where EWT = (EWT(i)) is a vector of positive error weights.
4082 C The values of RTOL and ATOL should all be non-negative.
4083 C The following table gives the types (scalar/array) of
4084 C RTOL and ATOL, and the corresponding form of EWT(i).
4085 C
4086 C ITOL RTOL ATOL EWT(i)
4087 C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL
4088 C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i)
4089 C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL
4090 C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i)
4091 C
4092 C When either of these parameters is a scalar, it need not
4093 C be dimensioned in the user's calling program.
4094 C
4095 C If none of the above choices (with ITOL, RTOL, and ATOL
4096 C fixed throughout the problem) is suitable, more general
4097 C error controls can be obtained by substituting a
4098 C user-supplied routine for the setting of EWT.
4099 C See Part 4 below.
4100 C
4101 C If global errors are to be estimated by making a repeated
4102 C run on the same problem with smaller tolerances, then all
4103 C components of RTOL and ATOL (i.e. of EWT) should be scaled
4104 C down uniformly.
4105 C
4106 C ITASK = an index specifying the task to be performed.
4107 C Input only. ITASK has the following values and meanings.
4108 C 1 means normal computation of output values of y(t) at
4109 C t = TOUT (by overshooting and interpolating).
4110 C 2 means take one step only and return.
4111 C 3 means stop at the first internal mesh point at or
4112 C beyond t = TOUT and return.
4113 C 4 means normal computation of output values of y(t) at
4114 C t = TOUT but without overshooting t = TCRIT.
4115 C TCRIT must be input as RWORK(1). TCRIT may be equal to
4116 C or beyond TOUT, but not behind it in the direction of
4117 C integration. This option is useful if the problem
4118 C has a singularity at or beyond t = TCRIT.
4119 C 5 means take one step, without passing TCRIT, and return.
4120 C TCRIT must be input as RWORK(1).
4121 C
4122 C Note: If ITASK = 4 or 5 and the solver reaches TCRIT
4123 C (within roundoff), it will return T = TCRIT (exactly) to
4124 C indicate this (unless ITASK = 4 and TOUT comes before TCRIT,
4125 C in which case answers at t = TOUT are returned first).
4126 C
4127 C ISTATE = an index used for input and output to specify the
4128 C the state of the calculation.
4129 C
4130 C On input, the values of ISTATE are as follows.
4131 C 1 means this is the first call for the problem
4132 C (initializations will be done). See note below.
4133 C 2 means this is not the first call, and the calculation
4134 C is to continue normally, with no change in any input
4135 C parameters except possibly TOUT and ITASK.
4136 C (If ITOL, RTOL, and/or ATOL are changed between calls
4137 C with ISTATE = 2, the new values will be used but not
4138 C tested for legality.)
4139 C 3 means this is not the first call, and the
4140 C calculation is to continue normally, but with
4141 C a change in input parameters other than
4142 C TOUT and ITASK. Changes are allowed in
4143 C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, JT, ML, MU,
4144 C and any optional inputs except H0, MXORDN, and MXORDS.
4145 C (See IWORK description for ML and MU.)
4146 C Note: A preliminary call with TOUT = T is not counted
4147 C as a first call here, as no initialization or checking of
4148 C input is done. (Such a call is sometimes useful for the
4149 C purpose of outputting the initial conditions.)
4150 C Thus the first call for which TOUT .ne. T requires
4151 C ISTATE = 1 on input.
4152 C
4153 C On output, ISTATE has the following values and meanings.
4154 C 1 means nothing was done; TOUT = T and ISTATE = 1 on input.
4155 C 2 means the integration was performed successfully.
4156 C -1 means an excessive amount of work (more than MXSTEP
4157 C steps) was done on this call, before completing the
4158 C requested task, but the integration was otherwise
4159 C successful as far as T. (MXSTEP is an optional input
4160 C and is normally 500.) To continue, the user may
4161 C simply reset ISTATE to a value .gt. 1 and call again
4162 C (the excess work step counter will be reset to 0).
4163 C In addition, the user may increase MXSTEP to avoid
4164 C this error return (see below on optional inputs).
4165 C -2 means too much accuracy was requested for the precision
4166 C of the machine being used. This was detected before
4167 C completing the requested task, but the integration
4168 C was successful as far as T. To continue, the tolerance
4169 C parameters must be reset, and ISTATE must be set
4170 C to 3. The optional output TOLSF may be used for this
4171 C purpose. (Note: If this condition is detected before
4172 C taking any steps, then an illegal input return
4173 C (ISTATE = -3) occurs instead.)
4174 C -3 means illegal input was detected, before taking any
4175 C integration steps. See written message for details.
4176 C Note: If the solver detects an infinite loop of calls
4177 C to the solver with illegal input, it will cause
4178 C the run to stop.
4179 C -4 means there were repeated error test failures on
4180 C one attempted step, before completing the requested
4181 C task, but the integration was successful as far as T.
4182 C The problem may have a singularity, or the input
4183 C may be inappropriate.
4184 C -5 means there were repeated convergence test failures on
4185 C one attempted step, before completing the requested
4186 C task, but the integration was successful as far as T.
4187 C This may be caused by an inaccurate Jacobian matrix,
4188 C if one is being used.
4189 C -6 means EWT(i) became zero for some i during the
4190 C integration. Pure relative error control (ATOL(i)=0.0)
4191 C was requested on a variable which has now vanished.
4192 C The integration was successful as far as T.
4193 C -7 means the length of RWORK and/or IWORK was too small to
4194 C proceed, but the integration was successful as far as T.
4195 C This happens when DLSODA chooses to switch methods
4196 C but LRW and/or LIW is too small for the new method.
4197 C
4198 C Note: Since the normal output value of ISTATE is 2,
4199 C it does not need to be reset for normal continuation.
4200 C Also, since a negative input value of ISTATE will be
4201 C regarded as illegal, a negative output value requires the
4202 C user to change it, and possibly other inputs, before
4203 C calling the solver again.
4204 C
4205 C IOPT = an integer flag to specify whether or not any optional
4206 C inputs are being used on this call. Input only.
4207 C The optional inputs are listed separately below.
4208 C IOPT = 0 means no optional inputs are being used.
4209 C default values will be used in all cases.
4210 C IOPT = 1 means one or more optional inputs are being used.
4211 C
4212 C RWORK = a real array (double precision) for work space, and (in the
4213 C first 20 words) for conditional and optional inputs and
4214 C optional outputs.
4215 C As DLSODA switches automatically between stiff and nonstiff
4216 C methods, the required length of RWORK can change during the
4217 C problem. Thus the RWORK array passed to DLSODA can either
4218 C have a static (fixed) length large enough for both methods,
4219 C or have a dynamic (changing) length altered by the calling
4220 C program in response to output from DLSODA.
4221 C
4222 C --- Fixed Length Case ---
4223 C If the RWORK length is to be fixed, it should be at least
4224 C MAX (LRN, LRS),
4225 C where LRN and LRS are the RWORK lengths required when the
4226 C current method is nonstiff or stiff, respectively.
4227 C
4228 C The separate RWORK length requirements LRN and LRS are
4229 C as follows:
4230 C IF NEQ is constant and the maximum method orders have
4231 C their default values, then
4232 C LRN = 20 + 16*NEQ,
4233 C LRS = 22 + 9*NEQ + NEQ**2 if JT = 1 or 2,
4234 C LRS = 22 + 10*NEQ + (2*ML+MU)*NEQ if JT = 4 or 5.
4235 C Under any other conditions, LRN and LRS are given by:
4236 C LRN = 20 + NYH*(MXORDN+1) + 3*NEQ,
4237 C LRS = 20 + NYH*(MXORDS+1) + 3*NEQ + LMAT,
4238 C where
4239 C NYH = the initial value of NEQ,
4240 C MXORDN = 12, unless a smaller value is given as an
4241 C optional input,
4242 C MXORDS = 5, unless a smaller value is given as an
4243 C optional input,
4244 C LMAT = length of matrix work space:
4245 C LMAT = NEQ**2 + 2 if JT = 1 or 2,
4246 C LMAT = (2*ML + MU + 1)*NEQ + 2 if JT = 4 or 5.
4247 C
4248 C --- Dynamic Length Case ---
4249 C If the length of RWORK is to be dynamic, then it should
4250 C be at least LRN or LRS, as defined above, depending on the
4251 C current method. Initially, it must be at least LRN (since
4252 C DLSODA starts with the nonstiff method). On any return
4253 C from DLSODA, the optional output MCUR indicates the current
4254 C method. If MCUR differs from the value it had on the
4255 C previous return, or if there has only been one call to
4256 C DLSODA and MCUR is now 2, then DLSODA has switched
4257 C methods during the last call, and the length of RWORK
4258 C should be reset (to LRN if MCUR = 1, or to LRS if
4259 C MCUR = 2). (An increase in the RWORK length is required
4260 C if DLSODA returned ISTATE = -7, but not otherwise.)
4261 C After resetting the length, call DLSODA with ISTATE = 3
4262 C to signal that change.
4263 C
4264 C LRW = the length of the array RWORK, as declared by the user.
4265 C (This will be checked by the solver.)
4266 C
4267 C IWORK = an integer array for work space.
4268 C As DLSODA switches automatically between stiff and nonstiff
4269 C methods, the required length of IWORK can change during
4270 C problem, between
4271 C LIS = 20 + NEQ and LIN = 20,
4272 C respectively. Thus the IWORK array passed to DLSODA can
4273 C either have a fixed length of at least 20 + NEQ, or have a
4274 C dynamic length of at least LIN or LIS, depending on the
4275 C current method. The comments on dynamic length under
4276 C RWORK above apply here. Initially, this length need
4277 C only be at least LIN = 20.
4278 C
4279 C The first few words of IWORK are used for conditional and
4280 C optional inputs and optional outputs.
4281 C
4282 C The following 2 words in IWORK are conditional inputs:
4283 C IWORK(1) = ML these are the lower and upper
4284 C IWORK(2) = MU half-bandwidths, respectively, of the
4285 C banded Jacobian, excluding the main diagonal.
4286 C The band is defined by the matrix locations
4287 C (i,j) with i-ML .le. j .le. i+MU. ML and MU
4288 C must satisfy 0 .le. ML,MU .le. NEQ-1.
4289 C These are required if JT is 4 or 5, and
4290 C ignored otherwise. ML and MU may in fact be
4291 C the band parameters for a matrix to which
4292 C df/dy is only approximately equal.
4293 C
4294 C LIW = the length of the array IWORK, as declared by the user.
4295 C (This will be checked by the solver.)
4296 C
4297 C Note: The base addresses of the work arrays must not be
4298 C altered between calls to DLSODA for the same problem.
4299 C The contents of the work arrays must not be altered
4300 C between calls, except possibly for the conditional and
4301 C optional inputs, and except for the last 3*NEQ words of RWORK.
4302 C The latter space is used for internal scratch space, and so is
4303 C available for use by the user outside DLSODA between calls, if
4304 C desired (but not for use by F or JAC).
4305 C
4306 C JAC = the name of the user-supplied routine to compute the
4307 C Jacobian matrix, df/dy, if JT = 1 or 4. The JAC routine
4308 C is optional, but if the problem is expected to be stiff much
4309 C of the time, you are encouraged to supply JAC, for the sake
4310 C of efficiency. (Alternatively, set JT = 2 or 5 to have
4311 C DLSODA compute df/dy internally by difference quotients.)
4312 C If and when DLSODA uses df/dy, it treats this NEQ by NEQ
4313 C matrix either as full (JT = 1 or 2), or as banded (JT =
4314 C 4 or 5) with half-bandwidths ML and MU (discussed under
4315 C IWORK above). In either case, if JT = 1 or 4, the JAC
4316 C routine must compute df/dy as a function of the scalar t
4317 C and the vector y. It is to have the form
4318 C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD)
4319 C DOUBLE PRECISION T, Y(*), PD(NROWPD,*)
4320 C where NEQ, T, Y, ML, MU, and NROWPD are input and the array
4321 C PD is to be loaded with partial derivatives (elements of
4322 C the Jacobian matrix) on output. PD must be given a first
4323 C dimension of NROWPD. T and Y have the same meaning as in
4324 C Subroutine F.
4325 C In the full matrix case (JT = 1), ML and MU are
4326 C ignored, and the Jacobian is to be loaded into PD in
4327 C columnwise manner, with df(i)/dy(j) loaded into PD(i,j).
4328 C In the band matrix case (JT = 4), the elements
4329 C within the band are to be loaded into PD in columnwise
4330 C manner, with diagonal lines of df/dy loaded into the rows
4331 C of PD. Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j).
4332 C ML and MU are the half-bandwidth parameters (see IWORK).
4333 C The locations in PD in the two triangular areas which
4334 C correspond to nonexistent matrix elements can be ignored
4335 C or loaded arbitrarily, as they are overwritten by DLSODA.
4336 C JAC need not provide df/dy exactly. A crude
4337 C approximation (possibly with a smaller bandwidth) will do.
4338 C In either case, PD is preset to zero by the solver,
4339 C so that only the nonzero elements need be loaded by JAC.
4340 C Each call to JAC is preceded by a call to F with the same
4341 C arguments NEQ, T, and Y. Thus to gain some efficiency,
4342 C intermediate quantities shared by both calculations may be
4343 C saved in a user Common block by F and not recomputed by JAC,
4344 C if desired. Also, JAC may alter the Y array, if desired.
4345 C JAC must be declared External in the calling program.
4346 C Subroutine JAC may access user-defined quantities in
4347 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array
4348 C (dimensioned in JAC) and/or Y has length exceeding NEQ(1).
4349 C See the descriptions of NEQ and Y above.
4350 C
4351 C JT = Jacobian type indicator. Used only for input.
4352 C JT specifies how the Jacobian matrix df/dy will be
4353 C treated, if and when DLSODA requires this matrix.
4354 C JT has the following values and meanings:
4355 C 1 means a user-supplied full (NEQ by NEQ) Jacobian.
4356 C 2 means an internally generated (difference quotient) full
4357 C Jacobian (using NEQ extra calls to F per df/dy value).
4358 C 4 means a user-supplied banded Jacobian.
4359 C 5 means an internally generated banded Jacobian (using
4360 C ML+MU+1 extra calls to F per df/dy evaluation).
4361 C If JT = 1 or 4, the user must supply a Subroutine JAC
4362 C (the name is arbitrary) as described above under JAC.
4363 C If JT = 2 or 5, a dummy argument can be used.
4364 C-----------------------------------------------------------------------
4365 C Optional Inputs.
4366 C
4367 C The following is a list of the optional inputs provided for in the
4368 C call sequence. (See also Part 2.) For each such input variable,
4369 C this table lists its name as used in this documentation, its
4370 C location in the call sequence, its meaning, and the default value.
4371 C The use of any of these inputs requires IOPT = 1, and in that
4372 C case all of these inputs are examined. A value of zero for any
4373 C of these optional inputs will cause the default value to be used.
4374 C Thus to use a subset of the optional inputs, simply preload
4375 C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and
4376 C then set those of interest to nonzero values.
4377 C
4378 C Name Location Meaning and Default Value
4379 C
4380 C H0 RWORK(5) the step size to be attempted on the first step.
4381 C The default value is determined by the solver.
4382 C
4383 C HMAX RWORK(6) the maximum absolute step size allowed.
4384 C The default value is infinite.
4385 C
4386 C HMIN RWORK(7) the minimum absolute step size allowed.
4387 C The default value is 0. (This lower bound is not
4388 C enforced on the final step before reaching TCRIT
4389 C when ITASK = 4 or 5.)
4390 C
4391 C IXPR IWORK(5) flag to generate extra printing at method switches.
4392 C IXPR = 0 means no extra printing (the default).
4393 C IXPR = 1 means print data on each switch.
4394 C T, H, and NST will be printed on the same logical
4395 C unit as used for error messages.
4396 C
4397 C MXSTEP IWORK(6) maximum number of (internally defined) steps
4398 C allowed during one call to the solver.
4399 C The default value is 500.
4400 C
4401 C MXHNIL IWORK(7) maximum number of messages printed (per problem)
4402 C warning that T + H = T on a step (H = step size).
4403 C This must be positive to result in a non-default
4404 C value. The default value is 10.
4405 C
4406 C MXORDN IWORK(8) the maximum order to be allowed for the nonstiff
4407 C (Adams) method. the default value is 12.
4408 C if MXORDN exceeds the default value, it will
4409 C be reduced to the default value.
4410 C MXORDN is held constant during the problem.
4411 C
4412 C MXORDS IWORK(9) the maximum order to be allowed for the stiff
4413 C (BDF) method. The default value is 5.
4414 C If MXORDS exceeds the default value, it will
4415 C be reduced to the default value.
4416 C MXORDS is held constant during the problem.
4417 C-----------------------------------------------------------------------
4418 C Optional Outputs.
4419 C
4420 C As optional additional output from DLSODA, the variables listed
4421 C below are quantities related to the performance of DLSODA
4422 C which are available to the user. These are communicated by way of
4423 C the work arrays, but also have internal mnemonic names as shown.
4424 C except where stated otherwise, all of these outputs are defined
4425 C on any successful return from DLSODA, and on any return with
4426 C ISTATE = -1, -2, -4, -5, or -6. On an illegal input return
4427 C (ISTATE = -3), they will be unchanged from their existing values
4428 C (if any), except possibly for TOLSF, LENRW, and LENIW.
4429 C On any error return, outputs relevant to the error will be defined,
4430 C as noted below.
4431 C
4432 C Name Location Meaning
4433 C
4434 C HU RWORK(11) the step size in t last used (successfully).
4435 C
4436 C HCUR RWORK(12) the step size to be attempted on the next step.
4437 C
4438 C TCUR RWORK(13) the current value of the independent variable
4439 C which the solver has actually reached, i.e. the
4440 C current internal mesh point in t. On output, TCUR
4441 C will always be at least as far as the argument
4442 C T, but may be farther (if interpolation was done).
4443 C
4444 C TOLSF RWORK(14) a tolerance scale factor, greater than 1.0,
4445 C computed when a request for too much accuracy was
4446 C detected (ISTATE = -3 if detected at the start of
4447 C the problem, ISTATE = -2 otherwise). If ITOL is
4448 C left unaltered but RTOL and ATOL are uniformly
4449 C scaled up by a factor of TOLSF for the next call,
4450 C then the solver is deemed likely to succeed.
4451 C (The user may also ignore TOLSF and alter the
4452 C tolerance parameters in any other way appropriate.)
4453 C
4454 C TSW RWORK(15) the value of t at the time of the last method
4455 C switch, if any.
4456 C
4457 C NST IWORK(11) the number of steps taken for the problem so far.
4458 C
4459 C NFE IWORK(12) the number of f evaluations for the problem so far.
4460 C
4461 C NJE IWORK(13) the number of Jacobian evaluations (and of matrix
4462 C LU decompositions) for the problem so far.
4463 C
4464 C NQU IWORK(14) the method order last used (successfully).
4465 C
4466 C NQCUR IWORK(15) the order to be attempted on the next step.
4467 C
4468 C IMXER IWORK(16) the index of the component of largest magnitude in
4469 C the weighted local error vector ( E(i)/EWT(i) ),
4470 C on an error return with ISTATE = -4 or -5.
4471 C
4472 C LENRW IWORK(17) the length of RWORK actually required, assuming
4473 C that the length of RWORK is to be fixed for the
4474 C rest of the problem, and that switching may occur.
4475 C This is defined on normal returns and on an illegal
4476 C input return for insufficient storage.
4477 C
4478 C LENIW IWORK(18) the length of IWORK actually required, assuming
4479 C that the length of IWORK is to be fixed for the
4480 C rest of the problem, and that switching may occur.
4481 C This is defined on normal returns and on an illegal
4482 C input return for insufficient storage.
4483 C
4484 C MUSED IWORK(19) the method indicator for the last successful step:
4485 C 1 means Adams (nonstiff), 2 means BDF (stiff).
4486 C
4487 C MCUR IWORK(20) the current method indicator:
4488 C 1 means Adams (nonstiff), 2 means BDF (stiff).
4489 C This is the method to be attempted
4490 C on the next step. Thus it differs from MUSED
4491 C only if a method switch has just been made.
4492 C
4493 C The following two arrays are segments of the RWORK array which
4494 C may also be of interest to the user as optional outputs.
4495 C For each array, the table below gives its internal name,
4496 C its base address in RWORK, and its description.
4497 C
4498 C Name Base Address Description
4499 C
4500 C YH 21 the Nordsieck history array, of size NYH by
4501 C (NQCUR + 1), where NYH is the initial value
4502 C of NEQ. For j = 0,1,...,NQCUR, column j+1
4503 C of YH contains HCUR**j/factorial(j) times
4504 C the j-th derivative of the interpolating
4505 C polynomial currently representing the solution,
4506 C evaluated at T = TCUR.
4507 C
4508 C ACOR LACOR array of size NEQ used for the accumulated
4509 C (from Common corrections on each step, scaled on output
4510 C as noted) to represent the estimated local error in y
4511 C on the last step. This is the vector E in
4512 C the description of the error control. It is
4513 C defined only on a successful return from
4514 C DLSODA. The base address LACOR is obtained by
4515 C including in the user's program the
4516 C following 2 lines:
4517 C COMMON /DLS001/ RLS(218), ILS(37)
4518 C LACOR = ILS(22)
4519 C
4520 C-----------------------------------------------------------------------
4521 C Part 2. Other Routines Callable.
4522 C
4523 C The following are optional calls which the user may make to
4524 C gain additional capabilities in conjunction with DLSODA.
4525 C (The routines XSETUN and XSETF are designed to conform to the
4526 C SLATEC error handling package.)
4527 C
4528 C Form of Call Function
4529 C CALL XSETUN(LUN) set the logical unit number, LUN, for
4530 C output of messages from DLSODA, if
4531 C the default is not desired.
4532 C The default value of LUN is 6.
4533 C
4534 C CALL XSETF(MFLAG) set a flag to control the printing of
4535 C messages by DLSODA.
4536 C MFLAG = 0 means do not print. (Danger:
4537 C This risks losing valuable information.)
4538 C MFLAG = 1 means print (the default).
4539 C
4540 C Either of the above calls may be made at
4541 C any time and will take effect immediately.
4542 C
4543 C CALL DSRCMA(RSAV,ISAV,JOB) saves and restores the contents of
4544 C the internal Common blocks used by
4545 C DLSODA (see Part 3 below).
4546 C RSAV must be a real array of length 240
4547 C or more, and ISAV must be an integer
4548 C array of length 46 or more.
4549 C JOB=1 means save Common into RSAV/ISAV.
4550 C JOB=2 means restore Common from RSAV/ISAV.
4551 C DSRCMA is useful if one is
4552 C interrupting a run and restarting
4553 C later, or alternating between two or
4554 C more problems solved with DLSODA.
4555 C
4556 C CALL DINTDY(,,,,,) provide derivatives of y, of various
4557 C (see below) orders, at a specified point t, if
4558 C desired. It may be called only after
4559 C a successful return from DLSODA.
4560 C
4561 C The detailed instructions for using DINTDY are as follows.
4562 C The form of the call is:
4563 C
4564 C CALL DINTDY (T, K, RWORK(21), NYH, DKY, IFLAG)
4565 C
4566 C The input parameters are:
4567 C
4568 C T = value of independent variable where answers are desired
4569 C (normally the same as the T last returned by DLSODA).
4570 C For valid results, T must lie between TCUR - HU and TCUR.
4571 C (See optional outputs for TCUR and HU.)
4572 C K = integer order of the derivative desired. K must satisfy
4573 C 0 .le. K .le. NQCUR, where NQCUR is the current order
4574 C (see optional outputs). The capability corresponding
4575 C to K = 0, i.e. computing y(T), is already provided
4576 C by DLSODA directly. Since NQCUR .ge. 1, the first
4577 C derivative dy/dt is always available with DINTDY.
4578 C RWORK(21) = the base address of the history array YH.
4579 C NYH = column length of YH, equal to the initial value of NEQ.
4580 C
4581 C The output parameters are:
4582 C
4583 C DKY = a real array of length NEQ containing the computed value
4584 C of the K-th derivative of y(t).
4585 C IFLAG = integer flag, returned as 0 if K and T were legal,
4586 C -1 if K was illegal, and -2 if T was illegal.
4587 C On an error return, a message is also written.
4588 C-----------------------------------------------------------------------
4589 C Part 3. Common Blocks.
4590 C
4591 C If DLSODA is to be used in an overlay situation, the user
4592 C must declare, in the primary overlay, the variables in:
4593 C (1) the call sequence to DLSODA, and
4594 C (2) the two internal Common blocks
4595 C /DLS001/ of length 255 (218 double precision words
4596 C followed by 37 integer words),
4597 C /DLSA01/ of length 31 (22 double precision words
4598 C followed by 9 integer words).
4599 C
4600 C If DLSODA is used on a system in which the contents of internal
4601 C Common blocks are not preserved between calls, the user should
4602 C declare the above Common blocks in the calling program to insure
4603 C that their contents are preserved.
4604 C
4605 C If the solution of a given problem by DLSODA is to be interrupted
4606 C and then later continued, such as when restarting an interrupted run
4607 C or alternating between two or more problems, the user should save,
4608 C following the return from the last DLSODA call prior to the
4609 C interruption, the contents of the call sequence variables and the
4610 C internal Common blocks, and later restore these values before the
4611 C next DLSODA call for that problem. To save and restore the Common
4612 C blocks, use Subroutine DSRCMA (see Part 2 above).
4613 C
4614 C-----------------------------------------------------------------------
4615 C Part 4. Optionally Replaceable Solver Routines.
4616 C
4617 C Below is a description of a routine in the DLSODA package which
4618 C relates to the measurement of errors, and can be
4619 C replaced by a user-supplied version, if desired. However, since such
4620 C a replacement may have a major impact on performance, it should be
4621 C done only when absolutely necessary, and only with great caution.
4622 C (Note: The means by which the package version of a routine is
4623 C superseded by the user's version may be system-dependent.)
4624 C
4625 C (a) DEWSET.
4626 C The following subroutine is called just before each internal
4627 C integration step, and sets the array of error weights, EWT, as
4628 C described under ITOL/RTOL/ATOL above:
4629 C Subroutine DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT)
4630 C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODA call sequence,
4631 C YCUR contains the current dependent variable vector, and
4632 C EWT is the array of weights set by DEWSET.
4633 C
4634 C If the user supplies this subroutine, it must return in EWT(i)
4635 C (i = 1,...,NEQ) a positive quantity suitable for comparing errors
4636 C in y(i) to. The EWT array returned by DEWSET is passed to the
4637 C DMNORM routine, and also used by DLSODA in the computation
4638 C of the optional output IMXER, and the increments for difference
4639 C quotient Jacobians.
4640 C
4641 C In the user-supplied version of DEWSET, it may be desirable to use
4642 C the current values of derivatives of y. Derivatives up to order NQ
4643 C are available from the history array YH, described above under
4644 C optional outputs. In DEWSET, YH is identical to the YCUR array,
4645 C extended to NQ + 1 columns with a column length of NYH and scale
4646 C factors of H**j/factorial(j). On the first call for the problem,
4647 C given by NST = 0, NQ is 1 and H is temporarily set to 1.0.
4648 C NYH is the initial value of NEQ. The quantities NQ, H, and NST
4649 C can be obtained by including in DEWSET the statements:
4650 C DOUBLE PRECISION RLS
4651 C COMMON /DLS001/ RLS(218),ILS(37)
4652 C NQ = ILS(33)
4653 C NST = ILS(34)
4654 C H = RLS(212)
4655 C Thus, for example, the current value of dy/dt can be obtained as
4656 C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is
4657 C unnecessary when NST = 0).
4658 C-----------------------------------------------------------------------
4659 C
4660 C***REVISION HISTORY (YYYYMMDD)
4661 C 19811102 DATE WRITTEN
4662 C 19820126 Fixed bug in tests of work space lengths;
4663 C minor corrections in main prologue and comments.
4664 C 19870330 Major update: corrected comments throughout;
4665 C removed TRET from Common; rewrote EWSET with 4 loops;
4666 C fixed t test in INTDY; added Cray directives in STODA;
4667 C in STODA, fixed DELP init. and logic around PJAC call;
4668 C combined routines to save/restore Common;
4669 C passed LEVEL = 0 in error message calls (except run abort).
4670 C 19970225 Fixed lines setting JSTART = -2 in Subroutine LSODA.
4671 C 20010425 Major update: convert source lines to upper case;
4672 C added *DECK lines; changed from 1 to * in dummy dimensions;
4673 C changed names R1MACH/D1MACH to RUMACH/DUMACH;
4674 C renamed routines for uniqueness across single/double prec.;
4675 C converted intrinsic names to generic form;
4676 C removed ILLIN and NTREP (data loaded) from Common;
4677 C removed all 'own' variables from Common;
4678 C changed error messages to quoted strings;
4679 C replaced XERRWV/XERRWD with 1993 revised version;
4680 C converted prologues, comments, error messages to mixed case;
4681 C numerous corrections to prologues and internal comments.
4682 C 20010507 Converted single precision source to double precision.
4683 C 20010613 Revised excess accuracy test (to match rest of ODEPACK).
4684 C 20010808 Fixed bug in DPRJA (matrix in DBNORM call).
4685 C 20020502 Corrected declarations in descriptions of user routines.
4686 C 20031105 Restored 'own' variables to Common blocks, to enable
4687 C interrupt/restart feature.
4688 C 20031112 Added SAVE statements for data-loaded constants.
4689 C
4690 C-----------------------------------------------------------------------
4691 C Other routines in the DLSODA package.
4692 C
4693 C In addition to Subroutine DLSODA, the DLSODA package includes the
4694 C following subroutines and function routines:
4695 C DINTDY computes an interpolated value of the y vector at t = TOUT.
4696 C DSTODA is the core integrator, which does one step of the
4697 C integration and the associated error control.
4698 C DCFODE sets all method coefficients and test constants.
4699 C DPRJA computes and preprocesses the Jacobian matrix J = df/dy
4700 C and the Newton iteration matrix P = I - h*l0*J.
4701 C DSOLSY manages solution of linear system in chord iteration.
4702 C DEWSET sets the error weight vector EWT before each step.
4703 C DMNORM computes the weighted max-norm of a vector.
4704 C DFNORM computes the norm of a full matrix consistent with the
4705 C weighted max-norm on vectors.
4706 C DBNORM computes the norm of a band matrix consistent with the
4707 C weighted max-norm on vectors.
4708 C DSRCMA is a user-callable routine to save and restore
4709 C the contents of the internal Common blocks.
4710 C DGEFA and DGESL are routines from LINPACK for solving full
4711 C systems of linear algebraic equations.
4712 C DGBFA and DGBSL are routines from LINPACK for solving banded
4713 C linear systems.
4714 C DUMACH computes the unit roundoff in a machine-independent manner.
4715 C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all
4716 C error messages and warnings. XERRWD is machine-dependent.
4717 C Note: DMNORM, DFNORM, DBNORM, DUMACH, IXSAV, and IUMACH are
4718 C function routines. All the others are subroutines.
4719 C
4720 C-----------------------------------------------------------------------
4721  EXTERNAL dprja, dsolsy
4722  DOUBLE PRECISION dumach, dmnorm
4723  INTEGER init, mxstep, mxhnil, nhnil, nslast, nyh, iowns,
4724  1 icf, ierpj, iersl, jcur, jstart, kflag, l,
4725  2 lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
4726  3 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
4727  INTEGER insufr, insufi, ixpr, iowns2, jtyp, mused, mxordn, mxords
4728  INTEGER i, i1, i2, iflag, imxer, kgo, lf0,
4729  1 leniw, lenrw, lenwm, ml, mord, mu, mxhnl0, mxstp0
4730  INTEGER len1, len1c, len1n, len1s, len2, leniwc, lenrwc
4731  DOUBLE PRECISION rowns,
4732  1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
4733  DOUBLE PRECISION tsw, rowns2, pdnorm
4734  DOUBLE PRECISION atoli, ayi, big, ewti, h0, hmax, hmx, rh, rtoli,
4735  1 tcrit, tdist, tnext, tol, tolsf, tp, SIZE, sum, w0
4736  dimension mord(2)
4737  LOGICAL ihit
4738  CHARACTER*60 msg
4739  SAVE mord, mxstp0, mxhnl0
4740 C-----------------------------------------------------------------------
4741 C The following two internal Common blocks contain
4742 C (a) variables which are local to any subroutine but whose values must
4743 C be preserved between calls to the routine ("own" variables), and
4744 C (b) variables which are communicated between subroutines.
4745 C The block DLS001 is declared in subroutines DLSODA, DINTDY, DSTODA,
4746 C DPRJA, and DSOLSY.
4747 C The block DLSA01 is declared in subroutines DLSODA, DSTODA, and DPRJA.
4748 C Groups of variables are replaced by dummy arrays in the Common
4749 C declarations in routines where those variables are not used.
4750 C-----------------------------------------------------------------------
4751  COMMON /dls001/ rowns(209),
4752  1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
4753  2 init, mxstep, mxhnil, nhnil, nslast, nyh, iowns(6),
4754  3 icf, ierpj, iersl, jcur, jstart, kflag, l,
4755  4 lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
4756  5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
4757 C
4758  COMMON /dlsa01/ tsw, rowns2(20), pdnorm,
4759  1 insufr, insufi, ixpr, iowns2(2), jtyp, mused, mxordn, mxords
4760 C
4761  DATA mord(1),mord(2)/12,5/, mxstp0/500/, mxhnl0/10/
4762 C-----------------------------------------------------------------------
4763 C Block A.
4764 C This code block is executed on every call.
4765 C It tests ISTATE and ITASK for legality and branches appropriately.
4766 C If ISTATE .gt. 1 but the flag INIT shows that initialization has
4767 C not yet been done, an error return occurs.
4768 C If ISTATE = 1 and TOUT = T, return immediately.
4769 C-----------------------------------------------------------------------
4770  IF (istate .LT. 1 .OR. istate .GT. 3) GO TO 601
4771  IF (itask .LT. 1 .OR. itask .GT. 5) GO TO 602
4772  IF (istate .EQ. 1) GO TO 10
4773  IF (init .EQ. 0) GO TO 603
4774  IF (istate .EQ. 2) GO TO 200
4775  GO TO 20
4776  10 init = 0
4777  IF (tout .EQ. t) RETURN
4778 C-----------------------------------------------------------------------
4779 C Block B.
4780 C The next code block is executed for the initial call (ISTATE = 1),
4781 C or for a continuation call with parameter changes (ISTATE = 3).
4782 C It contains checking of all inputs and various initializations.
4783 C
4784 C First check legality of the non-optional inputs NEQ, ITOL, IOPT,
4785 C JT, ML, and MU.
4786 C-----------------------------------------------------------------------
4787  20 IF (neq(1) .LE. 0) GO TO 604
4788  IF (istate .EQ. 1) GO TO 25
4789  IF (neq(1) .GT. n) GO TO 605
4790  25 n = neq(1)
4791  IF (itol .LT. 1 .OR. itol .GT. 4) GO TO 606
4792  IF (iopt .LT. 0 .OR. iopt .GT. 1) GO TO 607
4793  IF (jt .EQ. 3 .OR. jt .LT. 1 .OR. jt .GT. 5) GO TO 608
4794  jtyp = jt
4795  IF (jt .LE. 2) GO TO 30
4796  ml = iwork(1)
4797  mu = iwork(2)
4798  IF (ml .LT. 0 .OR. ml .GE. n) GO TO 609
4799  IF (mu .LT. 0 .OR. mu .GE. n) GO TO 610
4800  30 CONTINUE
4801 C Next process and check the optional inputs. --------------------------
4802  IF (iopt .EQ. 1) GO TO 40
4803  ixpr = 0
4804  mxstep = mxstp0
4805  mxhnil = mxhnl0
4806  hmxi = 0.0d0
4807  hmin = 0.0d0
4808  IF (istate .NE. 1) GO TO 60
4809  h0 = 0.0d0
4810  mxordn = mord(1)
4811  mxords = mord(2)
4812  GO TO 60
4813  40 ixpr = iwork(5)
4814  IF (ixpr .LT. 0 .OR. ixpr .GT. 1) GO TO 611
4815  mxstep = iwork(6)
4816  IF (mxstep .LT. 0) GO TO 612
4817  IF (mxstep .EQ. 0) mxstep = mxstp0
4818  mxhnil = iwork(7)
4819  IF (mxhnil .LT. 0) GO TO 613
4820  IF (mxhnil .EQ. 0) mxhnil = mxhnl0
4821  IF (istate .NE. 1) GO TO 50
4822  h0 = rwork(5)
4823  mxordn = iwork(8)
4824  IF (mxordn .LT. 0) GO TO 628
4825  IF (mxordn .EQ. 0) mxordn = 100
4826  mxordn = min(mxordn,mord(1))
4827  mxords = iwork(9)
4828  IF (mxords .LT. 0) GO TO 629
4829  IF (mxords .EQ. 0) mxords = 100
4830  mxords = min(mxords,mord(2))
4831  IF ((tout - t)*h0 .LT. 0.0d0) GO TO 614
4832  50 hmax = rwork(6)
4833  IF (hmax .LT. 0.0d0) GO TO 615
4834  hmxi = 0.0d0
4835  IF (hmax .GT. 0.0d0) hmxi = 1.0d0/hmax
4836  hmin = rwork(7)
4837  IF (hmin .LT. 0.0d0) GO TO 616
4838 C-----------------------------------------------------------------------
4839 C Set work array pointers and check lengths LRW and LIW.
4840 C If ISTATE = 1, METH is initialized to 1 here to facilitate the
4841 C checking of work space lengths.
4842 C Pointers to segments of RWORK and IWORK are named by prefixing L to
4843 C the name of the segment. E.g., the segment YH starts at RWORK(LYH).
4844 C Segments of RWORK (in order) are denoted YH, WM, EWT, SAVF, ACOR.
4845 C If the lengths provided are insufficient for the current method,
4846 C an error return occurs. This is treated as illegal input on the
4847 C first call, but as a problem interruption with ISTATE = -7 on a
4848 C continuation call. If the lengths are sufficient for the current
4849 C method but not for both methods, a warning message is sent.
4850 C-----------------------------------------------------------------------
4851  60 IF (istate .EQ. 1) meth = 1
4852  IF (istate .EQ. 1) nyh = n
4853  lyh = 21
4854  len1n = 20 + (mxordn + 1)*nyh
4855  len1s = 20 + (mxords + 1)*nyh
4856  lwm = len1s + 1
4857  IF (jt .LE. 2) lenwm = n*n + 2
4858  IF (jt .GE. 4) lenwm = (2*ml + mu + 1)*n + 2
4859  len1s = len1s + lenwm
4860  len1c = len1n
4861  IF (meth .EQ. 2) len1c = len1s
4862  len1 = max(len1n,len1s)
4863  len2 = 3*n
4864  lenrw = len1 + len2
4865  lenrwc = len1c + len2
4866  iwork(17) = lenrw
4867  liwm = 1
4868  leniw = 20 + n
4869  leniwc = 20
4870  IF (meth .EQ. 2) leniwc = leniw
4871  iwork(18) = leniw
4872  IF (istate .EQ. 1 .AND. lrw .LT. lenrwc) GO TO 617
4873  IF (istate .EQ. 1 .AND. liw .LT. leniwc) GO TO 618
4874  IF (istate .EQ. 3 .AND. lrw .LT. lenrwc) GO TO 550
4875  IF (istate .EQ. 3 .AND. liw .LT. leniwc) GO TO 555
4876  lewt = len1 + 1
4877  insufr = 0
4878  IF (lrw .GE. lenrw) GO TO 65
4879  insufr = 2
4880  lewt = len1c + 1
4881  msg='DLSODA- Warning.. RWORK length is sufficient for now, but '
4882  CALL xerrwd (msg, 60, 103, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
4883  msg=' may not be later. Integration will proceed anyway. '
4884  CALL xerrwd (msg, 60, 103, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
4885  msg = ' Length needed is LENRW = I1, while LRW = I2.'
4886  CALL xerrwd (msg, 50, 103, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0)
4887  65 lsavf = lewt + n
4888  lacor = lsavf + n
4889  insufi = 0
4890  IF (liw .GE. leniw) GO TO 70
4891  insufi = 2
4892  msg='DLSODA- Warning.. IWORK length is sufficient for now, but '
4893  CALL xerrwd (msg, 60, 104, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
4894  msg=' may not be later. Integration will proceed anyway. '
4895  CALL xerrwd (msg, 60, 104, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
4896  msg = ' Length needed is LENIW = I1, while LIW = I2.'
4897  CALL xerrwd (msg, 50, 104, 0, 2, leniw, liw, 0, 0.0d0, 0.0d0)
4898  70 CONTINUE
4899 C Check RTOL and ATOL for legality. ------------------------------------
4900  rtoli = rtol(1)
4901  atoli = atol(1)
4902  DO 75 i = 1,n
4903  IF (itol .GE. 3) rtoli = rtol(i)
4904  IF (itol .EQ. 2 .OR. itol .EQ. 4) atoli = atol(i)
4905  IF (rtoli .LT. 0.0d0) GO TO 619
4906  IF (atoli .LT. 0.0d0) GO TO 620
4907  75 CONTINUE
4908  IF (istate .EQ. 1) GO TO 100
4909 C If ISTATE = 3, set flag to signal parameter changes to DSTODA. -------
4910  jstart = -1
4911  IF (n .EQ. nyh) GO TO 200
4912 C NEQ was reduced. Zero part of YH to avoid undefined references. -----
4913  i1 = lyh + l*nyh
4914  i2 = lyh + (maxord + 1)*nyh - 1
4915  IF (i1 .GT. i2) GO TO 200
4916  DO 95 i = i1,i2
4917  95 rwork(i) = 0.0d0
4918  GO TO 200
4919 C-----------------------------------------------------------------------
4920 C Block C.
4921 C The next block is for the initial call only (ISTATE = 1).
4922 C It contains all remaining initializations, the initial call to F,
4923 C and the calculation of the initial step size.
4924 C The error weights in EWT are inverted after being loaded.
4925 C-----------------------------------------------------------------------
4926  100 uround = dumach()
4927  tn = t
4928  tsw = t
4929  maxord = mxordn
4930  IF (itask .NE. 4 .AND. itask .NE. 5) GO TO 110
4931  tcrit = rwork(1)
4932  IF ((tcrit - tout)*(tout - t) .LT. 0.0d0) GO TO 625
4933  IF (h0 .NE. 0.0d0 .AND. (t + h0 - tcrit)*h0 .GT. 0.0d0)
4934  1 h0 = tcrit - t
4935  110 jstart = 0
4936  nhnil = 0
4937  nst = 0
4938  nje = 0
4939  nslast = 0
4940  hu = 0.0d0
4941  nqu = 0
4942  mused = 0
4943  miter = 0
4944  ccmax = 0.3d0
4945  maxcor = 3
4946  msbp = 20
4947  mxncf = 10
4948 C Initial call to F. (LF0 points to YH(*,2).) -------------------------
4949  lf0 = lyh + nyh
4950  CALL f (neq, t, y, rwork(lf0))
4951  nfe = 1
4952 C Load the initial value vector in YH. ---------------------------------
4953  DO 115 i = 1,n
4954  115 rwork(i+lyh-1) = y(i)
4955 C Load and invert the EWT array. (H is temporarily set to 1.0.) -------
4956  nq = 1
4957  h = 1.0d0
4958  CALL dewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt))
4959  DO 120 i = 1,n
4960  IF (rwork(i+lewt-1) .LE. 0.0d0) GO TO 621
4961  120 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1)
4962 C-----------------------------------------------------------------------
4963 C The coding below computes the step size, H0, to be attempted on the
4964 C first step, unless the user has supplied a value for this.
4965 C First check that TOUT - T differs significantly from zero.
4966 C A scalar tolerance quantity TOL is computed, as MAX(RTOL(i))
4967 C if this is positive, or MAX(ATOL(i)/ABS(Y(i))) otherwise, adjusted
4968 C so as to be between 100*UROUND and 1.0E-3.
4969 C Then the computed value H0 is given by:
4970 C
4971 C H0**(-2) = 1./(TOL * w0**2) + TOL * (norm(F))**2
4972 C
4973 C where w0 = MAX ( ABS(T), ABS(TOUT) ),
4974 C F = the initial value of the vector f(t,y), and
4975 C norm() = the weighted vector norm used throughout, given by
4976 C the DMNORM function routine, and weighted by the
4977 C tolerances initially loaded into the EWT array.
4978 C The sign of H0 is inferred from the initial values of TOUT and T.
4979 C ABS(H0) is made .le. ABS(TOUT-T) in any case.
4980 C-----------------------------------------------------------------------
4981  IF (h0 .NE. 0.0d0) GO TO 180
4982  tdist = abs(tout - t)
4983  w0 = max(abs(t),abs(tout))
4984  IF (tdist .LT. 2.0d0*uround*w0) GO TO 622
4985  tol = rtol(1)
4986  IF (itol .LE. 2) GO TO 140
4987  DO 130 i = 1,n
4988  130 tol = max(tol,rtol(i))
4989  140 IF (tol .GT. 0.0d0) GO TO 160
4990  atoli = atol(1)
4991  DO 150 i = 1,n
4992  IF (itol .EQ. 2 .OR. itol .EQ. 4) atoli = atol(i)
4993  ayi = abs(y(i))
4994  IF (ayi .NE. 0.0d0) tol = max(tol,atoli/ayi)
4995  150 CONTINUE
4996  160 tol = max(tol,100.0d0*uround)
4997  tol = min(tol,0.001d0)
4998  sum = dmnorm(n, rwork(lf0), rwork(lewt))
4999  sum = 1.0d0/(tol*w0*w0) + tol*sum**2
5000  h0 = 1.0d0/sqrt(sum)
5001  h0 = min(h0,tdist)
5002  h0 = sign(h0,tout-t)
5003 C Adjust H0 if necessary to meet HMAX bound. ---------------------------
5004  180 rh = abs(h0)*hmxi
5005  IF (rh .GT. 1.0d0) h0 = h0/rh
5006 C Load H with H0 and scale YH(*,2) by H0. ------------------------------
5007  h = h0
5008  DO 190 i = 1,n
5009  190 rwork(i+lf0-1) = h0*rwork(i+lf0-1)
5010  GO TO 270
5011 C-----------------------------------------------------------------------
5012 C Block D.
5013 C The next code block is for continuation calls only (ISTATE = 2 or 3)
5014 C and is to check stop conditions before taking a step.
5015 C-----------------------------------------------------------------------
5016  200 nslast = nst
5017  GO TO (210, 250, 220, 230, 240), itask
5018  210 IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
5019  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
5020  IF (iflag .NE. 0) GO TO 627
5021  t = tout
5022  GO TO 420
5023  220 tp = tn - hu*(1.0d0 + 100.0d0*uround)
5024  IF ((tp - tout)*h .GT. 0.0d0) GO TO 623
5025  IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
5026  t = tn
5027  GO TO 400
5028  230 tcrit = rwork(1)
5029  IF ((tn - tcrit)*h .GT. 0.0d0) GO TO 624
5030  IF ((tcrit - tout)*h .LT. 0.0d0) GO TO 625
5031  IF ((tn - tout)*h .LT. 0.0d0) GO TO 245
5032  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
5033  IF (iflag .NE. 0) GO TO 627
5034  t = tout
5035  GO TO 420
5036  240 tcrit = rwork(1)
5037  IF ((tn - tcrit)*h .GT. 0.0d0) GO TO 624
5038  245 hmx = abs(tn) + abs(h)
5039  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
5040  IF (ihit) t = tcrit
5041  IF (ihit) GO TO 400
5042  tnext = tn + h*(1.0d0 + 4.0d0*uround)
5043  IF ((tnext - tcrit)*h .LE. 0.0d0) GO TO 250
5044  h = (tcrit - tn)*(1.0d0 - 4.0d0*uround)
5045  IF (istate .EQ. 2 .AND. jstart .GE. 0) jstart = -2
5046 C-----------------------------------------------------------------------
5047 C Block E.
5048 C The next block is normally executed for all calls and contains
5049 C the call to the one-step core integrator DSTODA.
5050 C
5051 C This is a looping point for the integration steps.
5052 C
5053 C First check for too many steps being taken, update EWT (if not at
5054 C start of problem), check for too much accuracy being requested, and
5055 C check for H below the roundoff level in T.
5056 C-----------------------------------------------------------------------
5057  250 CONTINUE
5058  IF (meth .EQ. mused) GO TO 255
5059  IF (insufr .EQ. 1) GO TO 550
5060  IF (insufi .EQ. 1) GO TO 555
5061  255 IF ((nst-nslast) .GE. mxstep) GO TO 500
5062  CALL dewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt))
5063  DO 260 i = 1,n
5064  IF (rwork(i+lewt-1) .LE. 0.0d0) GO TO 510
5065  260 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1)
5066  270 tolsf = uround*dmnorm(n, rwork(lyh), rwork(lewt))
5067  IF (tolsf .LE. 1.0d0) GO TO 280
5068  tolsf = tolsf*2.0d0
5069  IF (nst .EQ. 0) GO TO 626
5070  GO TO 520
5071  280 IF ((tn + h) .NE. tn) GO TO 290
5072  nhnil = nhnil + 1
5073  IF (nhnil .GT. mxhnil) GO TO 290
5074  msg = 'DLSODA- Warning..Internal T (=R1) and H (=R2) are'
5075  CALL xerrwd (msg, 50, 101, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
5076  msg=' such that in the machine, T + H = T on the next step '
5077  CALL xerrwd (msg, 60, 101, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
5078  msg = ' (H = step size). Solver will continue anyway.'
5079  CALL xerrwd (msg, 50, 101, 0, 0, 0, 0, 2, tn, h)
5080  IF (nhnil .LT. mxhnil) GO TO 290
5081  msg = 'DLSODA- Above warning has been issued I1 times. '
5082  CALL xerrwd (msg, 50, 102, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
5083  msg = ' It will not be issued again for this problem.'
5084  CALL xerrwd (msg, 50, 102, 0, 1, mxhnil, 0, 0, 0.0d0, 0.0d0)
5085  290 CONTINUE
5086 C-----------------------------------------------------------------------
5087 C CALL DSTODA(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,IWM,F,JAC,DPRJA,DSOLSY)
5088 C-----------------------------------------------------------------------
5089  CALL dstoda (neq, y, rwork(lyh), nyh, rwork(lyh), rwork(lewt),
5090  1 rwork(lsavf), rwork(lacor), rwork(lwm), iwork(liwm),
5091  2 f, jac, dprja, dsolsy)
5092  kgo = 1 - kflag
5093  GO TO (300, 530, 540), kgo
5094 C-----------------------------------------------------------------------
5095 C Block F.
5096 C The following block handles the case of a successful return from the
5097 C core integrator (KFLAG = 0).
5098 C If a method switch was just made, record TSW, reset MAXORD,
5099 C set JSTART to -1 to signal DSTODA to complete the switch,
5100 C and do extra printing of data if IXPR = 1.
5101 C Then, in any case, check for stop conditions.
5102 C-----------------------------------------------------------------------
5103  300 init = 1
5104  IF (meth .EQ. mused) GO TO 310
5105  tsw = tn
5106  maxord = mxordn
5107  IF (meth .EQ. 2) maxord = mxords
5108  IF (meth .EQ. 2) rwork(lwm) = sqrt(uround)
5109  insufr = min(insufr,1)
5110  insufi = min(insufi,1)
5111  jstart = -1
5112  IF (ixpr .EQ. 0) GO TO 310
5113  IF (meth .EQ. 2) THEN
5114  msg='DLSODA- A switch to the BDF (stiff) method has occurred '
5115  CALL xerrwd (msg, 60, 105, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
5116  ENDIF
5117  IF (meth .EQ. 1) THEN
5118  msg='DLSODA- A switch to the Adams (nonstiff) method has occurred'
5119  CALL xerrwd (msg, 60, 106, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
5120  ENDIF
5121  msg=' at T = R1, tentative step size H = R2, step NST = I1 '
5122  CALL xerrwd (msg, 60, 107, 0, 1, nst, 0, 2, tn, h)
5123  310 GO TO (320, 400, 330, 340, 350), itask
5124 C ITASK = 1. If TOUT has been reached, interpolate. -------------------
5125  320 IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
5126  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
5127  t = tout
5128  GO TO 420
5129 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------
5130  330 IF ((tn - tout)*h .GE. 0.0d0) GO TO 400
5131  GO TO 250
5132 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary.
5133  340 IF ((tn - tout)*h .LT. 0.0d0) GO TO 345
5134  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
5135  t = tout
5136  GO TO 420
5137  345 hmx = abs(tn) + abs(h)
5138  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
5139  IF (ihit) GO TO 400
5140  tnext = tn + h*(1.0d0 + 4.0d0*uround)
5141  IF ((tnext - tcrit)*h .LE. 0.0d0) GO TO 250
5142  h = (tcrit - tn)*(1.0d0 - 4.0d0*uround)
5143  IF (jstart .GE. 0) jstart = -2
5144  GO TO 250
5145 C ITASK = 5. See if TCRIT was reached and jump to exit. ---------------
5146  350 hmx = abs(tn) + abs(h)
5147  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
5148 C-----------------------------------------------------------------------
5149 C Block G.
5150 C The following block handles all successful returns from DLSODA.
5151 C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly.
5152 C ISTATE is set to 2, and the optional outputs are loaded into the
5153 C work arrays before returning.
5154 C-----------------------------------------------------------------------
5155  400 DO 410 i = 1,n
5156  410 y(i) = rwork(i+lyh-1)
5157  t = tn
5158  IF (itask .NE. 4 .AND. itask .NE. 5) GO TO 420
5159  IF (ihit) t = tcrit
5160  420 istate = 2
5161  rwork(11) = hu
5162  rwork(12) = h
5163  rwork(13) = tn
5164  rwork(15) = tsw
5165  iwork(11) = nst
5166  iwork(12) = nfe
5167  iwork(13) = nje
5168  iwork(14) = nqu
5169  iwork(15) = nq
5170  iwork(19) = mused
5171  iwork(20) = meth
5172  RETURN
5173 C-----------------------------------------------------------------------
5174 C Block H.
5175 C The following block handles all unsuccessful returns other than
5176 C those for illegal input. First the error message routine is called.
5177 C If there was an error test or convergence test failure, IMXER is set.
5178 C Then Y is loaded from YH and T is set to TN.
5179 C The optional outputs are loaded into the work arrays before returning.
5180 C-----------------------------------------------------------------------
5181 C The maximum number of steps was taken before reaching TOUT. ----------
5182  500 msg = 'DLSODA- At current T (=R1), MXSTEP (=I1) steps '
5183  CALL xerrwd (msg, 50, 201, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
5184  msg = ' taken on this call before reaching TOUT '
5185  CALL xerrwd (msg, 50, 201, 0, 1, mxstep, 0, 1, tn, 0.0d0)
5186  istate = -1
5187  GO TO 580
5188 C EWT(i) .le. 0.0 for some i (not at start of problem). ----------------
5189  510 ewti = rwork(lewt+i-1)
5190  msg = .le.'DLSODA- At T (=R1), EWT(I1) has become R2 0.'
5191  CALL xerrwd (msg, 50, 202, 0, 1, i, 0, 2, tn, ewti)
5192  istate = -6
5193  GO TO 580
5194 C Too much accuracy requested for machine precision. -------------------
5195  520 msg = 'DLSODA- At T (=R1), too much accuracy requested '
5196  CALL xerrwd (msg, 50, 203, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
5197  msg = ' for precision of machine.. See TOLSF (=R2) '
5198  CALL xerrwd (msg, 50, 203, 0, 0, 0, 0, 2, tn, tolsf)
5199  rwork(14) = tolsf
5200  istate = -2
5201  GO TO 580
5202 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. -----
5203  530 msg = 'DLSODA- At T(=R1) and step size H(=R2), the error'
5204  CALL xerrwd (msg, 50, 204, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
5205  msg = ' test failed repeatedly or with ABS(H) = HMIN'
5206  CALL xerrwd (msg, 50, 204, 0, 0, 0, 0, 2, tn, h)
5207  istate = -4
5208  GO TO 560
5209 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ----
5210  540 msg = 'DLSODA- At T (=R1) and step size H (=R2), the '
5211  CALL xerrwd (msg, 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
5212  msg = ' corrector convergence failed repeatedly '
5213  CALL xerrwd (msg, 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
5214  msg = ' or with ABS(H) = HMIN '
5215  CALL xerrwd (msg, 30, 205, 0, 0, 0, 0, 2, tn, h)
5216  istate = -5
5217  GO TO 560
5218 C RWORK length too small to proceed. -----------------------------------
5219  550 msg = 'DLSODA- At current T(=R1), RWORK length too small'
5220  CALL xerrwd (msg, 50, 206, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
5221  msg=' to proceed. The integration was otherwise successful.'
5222  CALL xerrwd (msg, 60, 206, 0, 0, 0, 0, 1, tn, 0.0d0)
5223  istate = -7
5224  GO TO 580
5225 C IWORK length too small to proceed. -----------------------------------
5226  555 msg = 'DLSODA- At current T(=R1), IWORK length too small'
5227  CALL xerrwd (msg, 50, 207, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
5228  msg=' to proceed. The integration was otherwise successful.'
5229  CALL xerrwd (msg, 60, 207, 0, 0, 0, 0, 1, tn, 0.0d0)
5230  istate = -7
5231  GO TO 580
5232 C Compute IMXER if relevant. -------------------------------------------
5233  560 big = 0.0d0
5234  imxer = 1
5235  DO 570 i = 1,n
5236  SIZE = abs(rwork(i+lacor-1)*rwork(i+lewt-1))
5237  IF (big .GE. size) GO TO 570
5238  big = SIZE
5239  imxer = i
5240  570 CONTINUE
5241  iwork(16) = imxer
5242 C Set Y vector, T, and optional outputs. -------------------------------
5243  580 DO 590 i = 1,n
5244  590 y(i) = rwork(i+lyh-1)
5245  t = tn
5246  rwork(11) = hu
5247  rwork(12) = h
5248  rwork(13) = tn
5249  rwork(15) = tsw
5250  iwork(11) = nst
5251  iwork(12) = nfe
5252  iwork(13) = nje
5253  iwork(14) = nqu
5254  iwork(15) = nq
5255  iwork(19) = mused
5256  iwork(20) = meth
5257  RETURN
5258 C-----------------------------------------------------------------------
5259 C Block I.
5260 C The following block handles all error returns due to illegal input
5261 C (ISTATE = -3), as detected before calling the core integrator.
5262 C First the error message routine is called. If the illegal input
5263 C is a negative ISTATE, the run is aborted (apparent infinite loop).
5264 C-----------------------------------------------------------------------
5265  601 msg = 'DLSODA- ISTATE (=I1) illegal.'
5266  CALL xerrwd (msg, 30, 1, 0, 1, istate, 0, 0, 0.0d0, 0.0d0)
5267  IF (istate .LT. 0) GO TO 800
5268  GO TO 700
5269  602 msg = 'DLSODA- ITASK (=I1) illegal. '
5270  CALL xerrwd (msg, 30, 2, 0, 1, itask, 0, 0, 0.0d0, 0.0d0)
5271  GO TO 700
5272  603 msg = .gt.'DLSODA- ISTATE 1 but DLSODA not initialized.'
5273  CALL xerrwd (msg, 50, 3, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
5274  GO TO 700
5275  604 msg = .lt.'DLSODA- NEQ (=I1) 1 '
5276  CALL xerrwd (msg, 30, 4, 0, 1, neq(1), 0, 0, 0.0d0, 0.0d0)
5277  GO TO 700
5278  605 msg = 'DLSODA- ISTATE = 3 and NEQ increased (I1 to I2). '
5279  CALL xerrwd (msg, 50, 5, 0, 2, n, neq(1), 0, 0.0d0, 0.0d0)
5280  GO TO 700
5281  606 msg = 'DLSODA- ITOL (=I1) illegal. '
5282  CALL xerrwd (msg, 30, 6, 0, 1, itol, 0, 0, 0.0d0, 0.0d0)
5283  GO TO 700
5284  607 msg = 'DLSODA- IOPT (=I1) illegal. '
5285  CALL xerrwd (msg, 30, 7, 0, 1, iopt, 0, 0, 0.0d0, 0.0d0)
5286  GO TO 700
5287  608 msg = 'DLSODA- JT (=I1) illegal. '
5288  CALL xerrwd (msg, 30, 8, 0, 1, jt, 0, 0, 0.0d0, 0.0d0)
5289  GO TO 700
5290  609 msg = .lt..ge.'DLSODA- ML (=I1) illegal: 0 or NEQ (=I2) '
5291  CALL xerrwd (msg, 50, 9, 0, 2, ml, neq(1), 0, 0.0d0, 0.0d0)
5292  GO TO 700
5293  610 msg = .lt..ge.'DLSODA- MU (=I1) illegal: 0 or NEQ (=I2) '
5294  CALL xerrwd (msg, 50, 10, 0, 2, mu, neq(1), 0, 0.0d0, 0.0d0)
5295  GO TO 700
5296  611 msg = 'DLSODA- IXPR (=I1) illegal. '
5297  CALL xerrwd (msg, 30, 11, 0, 1, ixpr, 0, 0, 0.0d0, 0.0d0)
5298  GO TO 700
5299  612 msg = .lt.'DLSODA- MXSTEP (=I1) 0 '
5300  CALL xerrwd (msg, 30, 12, 0, 1, mxstep, 0, 0, 0.0d0, 0.0d0)
5301  GO TO 700
5302  613 msg = .lt.'DLSODA- MXHNIL (=I1) 0 '
5303  CALL xerrwd (msg, 30, 13, 0, 1, mxhnil, 0, 0, 0.0d0, 0.0d0)
5304  GO TO 700
5305  614 msg = 'DLSODA- TOUT (=R1) behind T (=R2) '
5306  CALL xerrwd (msg, 40, 14, 0, 0, 0, 0, 2, tout, t)
5307  msg = ' Integration direction is given by H0 (=R1) '
5308  CALL xerrwd (msg, 50, 14, 0, 0, 0, 0, 1, h0, 0.0d0)
5309  GO TO 700
5310  615 msg = .lt.'DLSODA- HMAX (=R1) 0.0 '
5311  CALL xerrwd (msg, 30, 15, 0, 0, 0, 0, 1, hmax, 0.0d0)
5312  GO TO 700
5313  616 msg = .lt.'DLSODA- HMIN (=R1) 0.0 '
5314  CALL xerrwd (msg, 30, 16, 0, 0, 0, 0, 1, hmin, 0.0d0)
5315  GO TO 700
5316  617 msg='DLSODA- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)'
5317  CALL xerrwd (msg, 60, 17, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0)
5318  GO TO 700
5319  618 msg='DLSODA- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)'
5320  CALL xerrwd (msg, 60, 18, 0, 2, leniw, liw, 0, 0.0d0, 0.0d0)
5321  GO TO 700
5322  619 msg = .lt.'DLSODA- RTOL(I1) is R1 0.0 '
5323  CALL xerrwd (msg, 40, 19, 0, 1, i, 0, 1, rtoli, 0.0d0)
5324  GO TO 700
5325  620 msg = .lt.'DLSODA- ATOL(I1) is R1 0.0 '
5326  CALL xerrwd (msg, 40, 20, 0, 1, i, 0, 1, atoli, 0.0d0)
5327  GO TO 700
5328  621 ewti = rwork(lewt+i-1)
5329  msg = .le.'DLSODA- EWT(I1) is R1 0.0 '
5330  CALL xerrwd (msg, 40, 21, 0, 1, i, 0, 1, ewti, 0.0d0)
5331  GO TO 700
5332  622 msg='DLSODA- TOUT(=R1) too close to T(=R2) to start integration.'
5333  CALL xerrwd (msg, 60, 22, 0, 0, 0, 0, 2, tout, t)
5334  GO TO 700
5335  623 msg='DLSODA- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) '
5336  CALL xerrwd (msg, 60, 23, 0, 1, itask, 0, 2, tout, tp)
5337  GO TO 700
5338  624 msg='DLSODA- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) '
5339  CALL xerrwd (msg, 60, 24, 0, 0, 0, 0, 2, tcrit, tn)
5340  GO TO 700
5341  625 msg='DLSODA- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) '
5342  CALL xerrwd (msg, 60, 25, 0, 0, 0, 0, 2, tcrit, tout)
5343  GO TO 700
5344  626 msg = 'DLSODA- At start of problem, too much accuracy '
5345  CALL xerrwd (msg, 50, 26, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
5346  msg=' requested for precision of machine.. See TOLSF (=R1) '
5347  CALL xerrwd (msg, 60, 26, 0, 0, 0, 0, 1, tolsf, 0.0d0)
5348  rwork(14) = tolsf
5349  GO TO 700
5350  627 msg = 'DLSODA- Trouble in DINTDY. ITASK = I1, TOUT = R1'
5351  CALL xerrwd (msg, 50, 27, 0, 1, itask, 0, 1, tout, 0.0d0)
5352  GO TO 700
5353  628 msg = .lt.'DLSODA- MXORDN (=I1) 0 '
5354  CALL xerrwd (msg, 30, 28, 0, 1, mxordn, 0, 0, 0.0d0, 0.0d0)
5355  GO TO 700
5356  629 msg = .lt.'DLSODA- MXORDS (=I1) 0 '
5357  CALL xerrwd (msg, 30, 29, 0, 1, mxords, 0, 0, 0.0d0, 0.0d0)
5358 C
5359  700 istate = -3
5360  RETURN
5361 C
5362  800 msg = 'DLSODA- Run aborted.. apparent infinite loop. '
5363  CALL xerrwd (msg, 50, 303, 2, 0, 0, 0, 0, 0.0d0, 0.0d0)
5364  RETURN
5365 C----------------------- End of Subroutine DLSODA ----------------------
5366  END
5367 *DECK DLSODAR
5368  SUBROUTINE dlsodar (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK,
5369  1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, JT,
5370  2 G, NG, JROOT)
5371  EXTERNAL f, jac, g
5372  INTEGER neq, itol, itask, istate, iopt, lrw, iwork, liw, jt,
5373  1 ng, jroot
5374  DOUBLE PRECISION y, t, tout, rtol, atol, rwork
5375  dimension neq(*), y(*), rtol(*), atol(*), rwork(lrw), iwork(liw),
5376  1 jroot(ng)
5377 C-----------------------------------------------------------------------
5378 C This is the 12 November 2003 version of
5379 C DLSODAR: Livermore Solver for Ordinary Differential Equations, with
5380 C Automatic method switching for stiff and nonstiff problems,
5381 C and with Root-finding.
5382 C
5383 C This version is in double precision.
5384 C
5385 C DLSODAR solves the initial value problem for stiff or nonstiff
5386 C systems of first order ODEs,
5387 C dy/dt = f(t,y) , or, in component form,
5388 C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ).
5389 C At the same time, it locates the roots of any of a set of functions
5390 C g(i) = g(i,t,y(1),...,y(NEQ)) (i = 1,...,ng).
5391 C
5392 C This a variant version of the DLSODE package. It differs from it
5393 C in two ways:
5394 C (a) It switches automatically between stiff and nonstiff methods.
5395 C This means that the user does not have to determine whether the
5396 C problem is stiff or not, and the solver will automatically choose the
5397 C appropriate method. It always starts with the nonstiff method.
5398 C (b) It finds the root of at least one of a set of constraint
5399 C functions g(i) of the independent and dependent variables.
5400 C It finds only those roots for which some g(i), as a function
5401 C of t, changes sign in the interval of integration.
5402 C It then returns the solution at the root, if that occurs
5403 C sooner than the specified stop condition, and otherwise returns
5404 C the solution according the specified stop condition.
5405 C
5406 C Authors: Alan C. Hindmarsh,
5407 C Center for Applied Scientific Computing, L-561
5408 C Lawrence Livermore National Laboratory
5409 C Livermore, CA 94551
5410 C and
5411 C Linda R. Petzold
5412 C Univ. of California at Santa Barbara
5413 C Dept. of Computer Science
5414 C Santa Barbara, CA 93106
5415 C
5416 C References:
5417 C 1. Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE
5418 C Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.),
5419 C North-Holland, Amsterdam, 1983, pp. 55-64.
5420 C 2. Linda R. Petzold, Automatic Selection of Methods for Solving
5421 C Stiff and Nonstiff Systems of Ordinary Differential Equations,
5422 C Siam J. Sci. Stat. Comput. 4 (1983), pp. 136-148.
5423 C 3. Kathie L. Hiebert and Lawrence F. Shampine, Implicitly Defined
5424 C Output Points for Solutions of ODEs, Sandia Report SAND80-0180,
5425 C February 1980.
5426 C-----------------------------------------------------------------------
5427 C Summary of Usage.
5428 C
5429 C Communication between the user and the DLSODAR package, for normal
5430 C situations, is summarized here. This summary describes only a subset
5431 C of the full set of options available. See the full description for
5432 C details, including alternative treatment of the Jacobian matrix,
5433 C optional inputs and outputs, nonstandard options, and
5434 C instructions for special situations. See also the example
5435 C problem (with program and output) following this summary.
5436 C
5437 C A. First provide a subroutine of the form:
5438 C SUBROUTINE F (NEQ, T, Y, YDOT)
5439 C DOUBLE PRECISION T, Y(*), YDOT(*)
5440 C which supplies the vector function f by loading YDOT(i) with f(i).
5441 C
5442 C B. Provide a subroutine of the form:
5443 C SUBROUTINE G (NEQ, T, Y, NG, GOUT)
5444 C DOUBLE PRECISION T, Y(*), GOUT(NG)
5445 C which supplies the vector function g by loading GOUT(i) with
5446 C g(i), the i-th constraint function whose root is sought.
5447 C
5448 C C. Write a main program which calls Subroutine DLSODAR once for
5449 C each point at which answers are desired. This should also provide
5450 C for possible use of logical unit 6 for output of error messages by
5451 C DLSODAR. On the first call to DLSODAR, supply arguments as follows:
5452 C F = name of subroutine for right-hand side vector f.
5453 C This name must be declared External in calling program.
5454 C NEQ = number of first order ODEs.
5455 C Y = array of initial values, of length NEQ.
5456 C T = the initial value of the independent variable.
5457 C TOUT = first point where output is desired (.ne. T).
5458 C ITOL = 1 or 2 according as ATOL (below) is a scalar or array.
5459 C RTOL = relative tolerance parameter (scalar).
5460 C ATOL = absolute tolerance parameter (scalar or array).
5461 C the estimated local error in y(i) will be controlled so as
5462 C to be less than
5463 C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or
5464 C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2.
5465 C Thus the local error test passes if, in each component,
5466 C either the absolute error is less than ATOL (or ATOL(i)),
5467 C or the relative error is less than RTOL.
5468 C Use RTOL = 0.0 for pure absolute error control, and
5469 C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error
5470 C control. Caution: actual (global) errors may exceed these
5471 C local tolerances, so choose them conservatively.
5472 C ITASK = 1 for normal computation of output values of y at t = TOUT.
5473 C ISTATE = integer flag (input and output). Set ISTATE = 1.
5474 C IOPT = 0 to indicate no optional inputs used.
5475 C RWORK = real work array of length at least:
5476 C 22 + NEQ * MAX(16, NEQ + 9) + 3*NG.
5477 C See also Paragraph F below.
5478 C LRW = declared length of RWORK (in user's dimension).
5479 C IWORK = integer work array of length at least 20 + NEQ.
5480 C LIW = declared length of IWORK (in user's dimension).
5481 C JAC = name of subroutine for Jacobian matrix.
5482 C Use a dummy name. See also Paragraph F below.
5483 C JT = Jacobian type indicator. Set JT = 2.
5484 C See also Paragraph F below.
5485 C G = name of subroutine for constraint functions, whose
5486 C roots are desired during the integration.
5487 C This name must be declared External in calling program.
5488 C NG = number of constraint functions g(i). If there are none,
5489 C set NG = 0, and pass a dummy name for G.
5490 C JROOT = integer array of length NG for output of root information.
5491 C See next paragraph.
5492 C Note that the main program must declare arrays Y, RWORK, IWORK,
5493 C JROOT, and possibly ATOL.
5494 C
5495 C D. The output from the first call (or any call) is:
5496 C Y = array of computed values of y(t) vector.
5497 C T = corresponding value of independent variable. This is
5498 C TOUT if ISTATE = 2, or the root location if ISTATE = 3,
5499 C or the farthest point reached if DLSODAR was unsuccessful.
5500 C ISTATE = 2 or 3 if DLSODAR was successful, negative otherwise.
5501 C 2 means no root was found, and TOUT was reached as desired.
5502 C 3 means a root was found prior to reaching TOUT.
5503 C -1 means excess work done on this call (perhaps wrong JT).
5504 C -2 means excess accuracy requested (tolerances too small).
5505 C -3 means illegal input detected (see printed message).
5506 C -4 means repeated error test failures (check all inputs).
5507 C -5 means repeated convergence failures (perhaps bad Jacobian
5508 C supplied or wrong choice of JT or tolerances).
5509 C -6 means error weight became zero during problem. (Solution
5510 C component i vanished, and ATOL or ATOL(i) = 0.)
5511 C -7 means work space insufficient to finish (see messages).
5512 C JROOT = array showing roots found if ISTATE = 3 on return.
5513 C JROOT(i) = 1 if g(i) has a root at t, or 0 otherwise.
5514 C
5515 C E. To continue the integration after a successful return, proceed
5516 C as follows:
5517 C (a) If ISTATE = 2 on return, reset TOUT and call DLSODAR again.
5518 C (b) If ISTATE = 3 on return, reset ISTATE to 2, call DLSODAR again.
5519 C In either case, no other parameters need be reset.
5520 C
5521 C F. Note: If and when DLSODAR regards the problem as stiff, and
5522 C switches methods accordingly, it must make use of the NEQ by NEQ
5523 C Jacobian matrix, J = df/dy. For the sake of simplicity, the
5524 C inputs to DLSODAR recommended in Paragraph C above cause DLSODAR to
5525 C treat J as a full matrix, and to approximate it internally by
5526 C difference quotients. Alternatively, J can be treated as a band
5527 C matrix (with great potential reduction in the size of the RWORK
5528 C array). Also, in either the full or banded case, the user can supply
5529 C J in closed form, with a routine whose name is passed as the JAC
5530 C argument. These alternatives are described in the paragraphs on
5531 C RWORK, JAC, and JT in the full description of the call sequence below.
5532 C
5533 C-----------------------------------------------------------------------
5534 C Example Problem.
5535 C
5536 C The following is a simple example problem, with the coding
5537 C needed for its solution by DLSODAR. The problem is from chemical
5538 C kinetics, and consists of the following three rate equations:
5539 C dy1/dt = -.04*y1 + 1.e4*y2*y3
5540 C dy2/dt = .04*y1 - 1.e4*y2*y3 - 3.e7*y2**2
5541 C dy3/dt = 3.e7*y2**2
5542 C on the interval from t = 0.0 to t = 4.e10, with initial conditions
5543 C y1 = 1.0, y2 = y3 = 0. The problem is stiff.
5544 C In addition, we want to find the values of t, y1, y2, and y3 at which
5545 C (1) y1 reaches the value 1.e-4, and
5546 C (2) y3 reaches the value 1.e-2.
5547 C
5548 C The following coding solves this problem with DLSODAR,
5549 C printing results at t = .4, 4., ..., 4.e10, and at the computed
5550 C roots. It uses ITOL = 2 and ATOL much smaller for y2 than y1 or y3
5551 C because y2 has much smaller values.
5552 C At the end of the run, statistical quantities of interest are
5553 C printed (see optional outputs in the full description below).
5554 C
5555 C EXTERNAL FEX, GEX
5556 C DOUBLE PRECISION ATOL, RTOL, RWORK, T, TOUT, Y
5557 C DIMENSION Y(3), ATOL(3), RWORK(76), IWORK(23), JROOT(2)
5558 C NEQ = 3
5559 C Y(1) = 1.
5560 C Y(2) = 0.
5561 C Y(3) = 0.
5562 C T = 0.
5563 C TOUT = .4
5564 C ITOL = 2
5565 C RTOL = 1.D-4
5566 C ATOL(1) = 1.D-6
5567 C ATOL(2) = 1.D-10
5568 C ATOL(3) = 1.D-6
5569 C ITASK = 1
5570 C ISTATE = 1
5571 C IOPT = 0
5572 C LRW = 76
5573 C LIW = 23
5574 C JT = 2
5575 C NG = 2
5576 C DO 40 IOUT = 1,12
5577 C 10 CALL DLSODAR(FEX,NEQ,Y,T,TOUT,ITOL,RTOL,ATOL,ITASK,ISTATE,
5578 C 1 IOPT,RWORK,LRW,IWORK,LIW,JDUM,JT,GEX,NG,JROOT)
5579 C WRITE(6,20)T,Y(1),Y(2),Y(3)
5580 C 20 FORMAT(' At t =',D12.4,' Y =',3D14.6)
5581 C IF (ISTATE .LT. 0) GO TO 80
5582 C IF (ISTATE .EQ. 2) GO TO 40
5583 C WRITE(6,30)JROOT(1),JROOT(2)
5584 C 30 FORMAT(5X,' The above line is a root, JROOT =',2I5)
5585 C ISTATE = 2
5586 C GO TO 10
5587 C 40 TOUT = TOUT*10.
5588 C WRITE(6,60)IWORK(11),IWORK(12),IWORK(13),IWORK(10),
5589 C 1 IWORK(19),RWORK(15)
5590 C 60 FORMAT(/' No. steps =',I4,' No. f-s =',I4,' No. J-s =',I4,
5591 C 1 ' No. g-s =',I4/
5592 C 2 ' Method last used =',I2,' Last switch was at t =',D12.4)
5593 C STOP
5594 C 80 WRITE(6,90)ISTATE
5595 C 90 FORMAT(///' Error halt.. ISTATE =',I3)
5596 C STOP
5597 C END
5598 C
5599 C SUBROUTINE FEX (NEQ, T, Y, YDOT)
5600 C DOUBLE PRECISION T, Y, YDOT
5601 C DIMENSION Y(3), YDOT(3)
5602 C YDOT(1) = -.04*Y(1) + 1.D4*Y(2)*Y(3)
5603 C YDOT(3) = 3.D7*Y(2)*Y(2)
5604 C YDOT(2) = -YDOT(1) - YDOT(3)
5605 C RETURN
5606 C END
5607 C
5608 C SUBROUTINE GEX (NEQ, T, Y, NG, GOUT)
5609 C DOUBLE PRECISION T, Y, GOUT
5610 C DIMENSION Y(3), GOUT(2)
5611 C GOUT(1) = Y(1) - 1.D-4
5612 C GOUT(2) = Y(3) - 1.D-2
5613 C RETURN
5614 C END
5615 C
5616 C The output of this program (on a CDC-7600 in single precision)
5617 C is as follows:
5618 C
5619 C At t = 2.6400e-01 y = 9.899653e-01 3.470563e-05 1.000000e-02
5620 C The above line is a root, JROOT = 0 1
5621 C At t = 4.0000e-01 Y = 9.851712e-01 3.386380e-05 1.479493e-02
5622 C At t = 4.0000e+00 Y = 9.055333e-01 2.240655e-05 9.444430e-02
5623 C At t = 4.0000e+01 Y = 7.158403e-01 9.186334e-06 2.841505e-01
5624 C At t = 4.0000e+02 Y = 4.505250e-01 3.222964e-06 5.494717e-01
5625 C At t = 4.0000e+03 Y = 1.831975e-01 8.941774e-07 8.168016e-01
5626 C At t = 4.0000e+04 Y = 3.898730e-02 1.621940e-07 9.610125e-01
5627 C At t = 4.0000e+05 Y = 4.936363e-03 1.984221e-08 9.950636e-01
5628 C At t = 4.0000e+06 Y = 5.161831e-04 2.065786e-09 9.994838e-01
5629 C At t = 2.0745e+07 Y = 1.000000e-04 4.000395e-10 9.999000e-01
5630 C The above line is a root, JROOT = 1 0
5631 C At t = 4.0000e+07 Y = 5.179817e-05 2.072032e-10 9.999482e-01
5632 C At t = 4.0000e+08 Y = 5.283401e-06 2.113371e-11 9.999947e-01
5633 C At t = 4.0000e+09 Y = 4.659031e-07 1.863613e-12 9.999995e-01
5634 C At t = 4.0000e+10 Y = 1.404280e-08 5.617126e-14 1.000000e+00
5635 C
5636 C No. steps = 361 No. f-s = 693 No. J-s = 64 No. g-s = 390
5637 C Method last used = 2 Last switch was at t = 6.0092e-03
5638 C
5639 C-----------------------------------------------------------------------
5640 C Full Description of User Interface to DLSODAR.
5641 C
5642 C The user interface to DLSODAR consists of the following parts.
5643 C
5644 C 1. The call sequence to Subroutine DLSODAR, which is a driver
5645 C routine for the solver. This includes descriptions of both
5646 C the call sequence arguments and of user-supplied routines.
5647 C Following these descriptions is a description of
5648 C optional inputs available through the call sequence, and then
5649 C a description of optional outputs (in the work arrays).
5650 C
5651 C 2. Descriptions of other routines in the DLSODAR package that may be
5652 C (optionally) called by the user. These provide the ability to
5653 C alter error message handling, save and restore the internal
5654 C Common, and obtain specified derivatives of the solution y(t).
5655 C
5656 C 3. Descriptions of Common blocks to be declared in overlay
5657 C or similar environments, or to be saved when doing an interrupt
5658 C of the problem and continued solution later.
5659 C
5660 C 4. Description of a subroutine in the DLSODAR package,
5661 C which the user may replace with his/her own version, if desired.
5662 C this relates to the measurement of errors.
5663 C
5664 C-----------------------------------------------------------------------
5665 C Part 1. Call Sequence.
5666 C
5667 C The call sequence parameters used for input only are
5668 C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC,
5669 C JT, G, and NG,
5670 C that used only for output is JROOT,
5671 C and those used for both input and output are
5672 C Y, T, ISTATE.
5673 C The work arrays RWORK and IWORK are also used for conditional and
5674 C optional inputs and optional outputs. (The term output here refers
5675 C to the return from Subroutine DLSODAR to the user's calling program.)
5676 C
5677 C The legality of input parameters will be thoroughly checked on the
5678 C initial call for the problem, but not checked thereafter unless a
5679 C change in input parameters is flagged by ISTATE = 3 on input.
5680 C
5681 C The descriptions of the call arguments are as follows.
5682 C
5683 C F = the name of the user-supplied subroutine defining the
5684 C ODE system. The system must be put in the first-order
5685 C form dy/dt = f(t,y), where f is a vector-valued function
5686 C of the scalar t and the vector y. Subroutine F is to
5687 C compute the function f. It is to have the form
5688 C SUBROUTINE F (NEQ, T, Y, YDOT)
5689 C DOUBLE PRECISION T, Y(*), YDOT(*)
5690 C where NEQ, T, and Y are input, and the array YDOT = f(t,y)
5691 C is output. Y and YDOT are arrays of length NEQ.
5692 C Subroutine F should not alter Y(1),...,Y(NEQ).
5693 C F must be declared External in the calling program.
5694 C
5695 C Subroutine F may access user-defined quantities in
5696 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array
5697 C (dimensioned in F) and/or Y has length exceeding NEQ(1).
5698 C See the descriptions of NEQ and Y below.
5699 C
5700 C If quantities computed in the F routine are needed
5701 C externally to DLSODAR, an extra call to F should be made
5702 C for this purpose, for consistent and accurate results.
5703 C If only the derivative dy/dt is needed, use DINTDY instead.
5704 C
5705 C NEQ = the size of the ODE system (number of first order
5706 C ordinary differential equations). Used only for input.
5707 C NEQ may be decreased, but not increased, during the problem.
5708 C If NEQ is decreased (with ISTATE = 3 on input), the
5709 C remaining components of Y should be left undisturbed, if
5710 C these are to be accessed in F and/or JAC.
5711 C
5712 C Normally, NEQ is a scalar, and it is generally referred to
5713 C as a scalar in this user interface description. However,
5714 C NEQ may be an array, with NEQ(1) set to the system size.
5715 C (The DLSODAR package accesses only NEQ(1).) In either case,
5716 C this parameter is passed as the NEQ argument in all calls
5717 C to F, JAC, and G. Hence, if it is an array, locations
5718 C NEQ(2),... may be used to store other integer data and pass
5719 C it to F, JAC, and G. Each such subroutine must include
5720 C NEQ in a Dimension statement in that case.
5721 C
5722 C Y = a real array for the vector of dependent variables, of
5723 C length NEQ or more. Used for both input and output on the
5724 C first call (ISTATE = 1), and only for output on other calls.
5725 C On the first call, Y must contain the vector of initial
5726 C values. On output, Y contains the computed solution vector,
5727 C evaluated at T. If desired, the Y array may be used
5728 C for other purposes between calls to the solver.
5729 C
5730 C This array is passed as the Y argument in all calls to F,
5731 C JAC, and G. Hence its length may exceed NEQ, and locations
5732 C Y(NEQ+1),... may be used to store other real data and
5733 C pass it to F, JAC, and G. (The DLSODAR package accesses only
5734 C Y(1),...,Y(NEQ).)
5735 C
5736 C T = the independent variable. On input, T is used only on the
5737 C first call, as the initial point of the integration.
5738 C On output, after each call, T is the value at which a
5739 C computed solution y is evaluated (usually the same as TOUT).
5740 C If a root was found, T is the computed location of the
5741 C root reached first, on output.
5742 C On an error return, T is the farthest point reached.
5743 C
5744 C TOUT = the next value of t at which a computed solution is desired.
5745 C Used only for input.
5746 C
5747 C When starting the problem (ISTATE = 1), TOUT may be equal
5748 C to T for one call, then should .ne. T for the next call.
5749 C For the initial T, an input value of TOUT .ne. T is used
5750 C in order to determine the direction of the integration
5751 C (i.e. the algebraic sign of the step sizes) and the rough
5752 C scale of the problem. Integration in either direction
5753 C (forward or backward in t) is permitted.
5754 C
5755 C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after
5756 C the first call (i.e. the first call with TOUT .ne. T).
5757 C Otherwise, TOUT is required on every call.
5758 C
5759 C If ITASK = 1, 3, or 4, the values of TOUT need not be
5760 C monotone, but a value of TOUT which backs up is limited
5761 C to the current internal T interval, whose endpoints are
5762 C TCUR - HU and TCUR (see optional outputs, below, for
5763 C TCUR and HU).
5764 C
5765 C ITOL = an indicator for the type of error control. See
5766 C description below under ATOL. Used only for input.
5767 C
5768 C RTOL = a relative error tolerance parameter, either a scalar or
5769 C an array of length NEQ. See description below under ATOL.
5770 C Input only.
5771 C
5772 C ATOL = an absolute error tolerance parameter, either a scalar or
5773 C an array of length NEQ. Input only.
5774 C
5775 C The input parameters ITOL, RTOL, and ATOL determine
5776 C the error control performed by the solver. The solver will
5777 C control the vector E = (E(i)) of estimated local errors
5778 C in y, according to an inequality of the form
5779 C max-norm of ( E(i)/EWT(i) ) .le. 1,
5780 C where EWT = (EWT(i)) is a vector of positive error weights.
5781 C The values of RTOL and ATOL should all be non-negative.
5782 C The following table gives the types (scalar/array) of
5783 C RTOL and ATOL, and the corresponding form of EWT(i).
5784 C
5785 C ITOL RTOL ATOL EWT(i)
5786 C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL
5787 C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i)
5788 C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL
5789 C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i)
5790 C
5791 C When either of these parameters is a scalar, it need not
5792 C be dimensioned in the user's calling program.
5793 C
5794 C If none of the above choices (with ITOL, RTOL, and ATOL
5795 C fixed throughout the problem) is suitable, more general
5796 C error controls can be obtained by substituting a
5797 C user-supplied routine for the setting of EWT.
5798 C See Part 4 below.
5799 C
5800 C If global errors are to be estimated by making a repeated
5801 C run on the same problem with smaller tolerances, then all
5802 C components of RTOL and ATOL (i.e. of EWT) should be scaled
5803 C down uniformly.
5804 C
5805 C ITASK = an index specifying the task to be performed.
5806 C input only. ITASK has the following values and meanings.
5807 C 1 means normal computation of output values of y(t) at
5808 C t = TOUT (by overshooting and interpolating).
5809 C 2 means take one step only and return.
5810 C 3 means stop at the first internal mesh point at or
5811 C beyond t = TOUT and return.
5812 C 4 means normal computation of output values of y(t) at
5813 C t = TOUT but without overshooting t = TCRIT.
5814 C TCRIT must be input as RWORK(1). TCRIT may be equal to
5815 C or beyond TOUT, but not behind it in the direction of
5816 C integration. This option is useful if the problem
5817 C has a singularity at or beyond t = TCRIT.
5818 C 5 means take one step, without passing TCRIT, and return.
5819 C TCRIT must be input as RWORK(1).
5820 C
5821 C Note: If ITASK = 4 or 5 and the solver reaches TCRIT
5822 C (within roundoff), it will return T = TCRIT (exactly) to
5823 C indicate this (unless ITASK = 4 and TOUT comes before TCRIT,
5824 C in which case answers at t = TOUT are returned first).
5825 C
5826 C ISTATE = an index used for input and output to specify the
5827 C the state of the calculation.
5828 C
5829 C On input, the values of ISTATE are as follows.
5830 C 1 means this is the first call for the problem
5831 C (initializations will be done). See note below.
5832 C 2 means this is not the first call, and the calculation
5833 C is to continue normally, with no change in any input
5834 C parameters except possibly TOUT and ITASK.
5835 C (If ITOL, RTOL, and/or ATOL are changed between calls
5836 C with ISTATE = 2, the new values will be used but not
5837 C tested for legality.)
5838 C 3 means this is not the first call, and the
5839 C calculation is to continue normally, but with
5840 C a change in input parameters other than
5841 C TOUT and ITASK. Changes are allowed in
5842 C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, JT, ML, MU,
5843 C and any optional inputs except H0, MXORDN, and MXORDS.
5844 C (See IWORK description for ML and MU.)
5845 C In addition, immediately following a return with
5846 C ISTATE = 3 (root found), NG and G may be changed.
5847 C (But changing NG from 0 to .gt. 0 is not allowed.)
5848 C Note: A preliminary call with TOUT = T is not counted
5849 C as a first call here, as no initialization or checking of
5850 C input is done. (Such a call is sometimes useful for the
5851 C purpose of outputting the initial conditions.)
5852 C Thus the first call for which TOUT .ne. T requires
5853 C ISTATE = 1 on input.
5854 C
5855 C On output, ISTATE has the following values and meanings.
5856 C 1 means nothing was done; TOUT = t and ISTATE = 1 on input.
5857 C 2 means the integration was performed successfully, and
5858 C no roots were found.
5859 C 3 means the integration was successful, and one or more
5860 C roots were found before satisfying the stop condition
5861 C specified by ITASK. See JROOT.
5862 C -1 means an excessive amount of work (more than MXSTEP
5863 C steps) was done on this call, before completing the
5864 C requested task, but the integration was otherwise
5865 C successful as far as T. (MXSTEP is an optional input
5866 C and is normally 500.) To continue, the user may
5867 C simply reset ISTATE to a value .gt. 1 and call again
5868 C (the excess work step counter will be reset to 0).
5869 C In addition, the user may increase MXSTEP to avoid
5870 C this error return (see below on optional inputs).
5871 C -2 means too much accuracy was requested for the precision
5872 C of the machine being used. This was detected before
5873 C completing the requested task, but the integration
5874 C was successful as far as T. To continue, the tolerance
5875 C parameters must be reset, and ISTATE must be set
5876 C to 3. The optional output TOLSF may be used for this
5877 C purpose. (Note: If this condition is detected before
5878 C taking any steps, then an illegal input return
5879 C (ISTATE = -3) occurs instead.)
5880 C -3 means illegal input was detected, before taking any
5881 C integration steps. See written message for details.
5882 C Note: If the solver detects an infinite loop of calls
5883 C to the solver with illegal input, it will cause
5884 C the run to stop.
5885 C -4 means there were repeated error test failures on
5886 C one attempted step, before completing the requested
5887 C task, but the integration was successful as far as T.
5888 C The problem may have a singularity, or the input
5889 C may be inappropriate.
5890 C -5 means there were repeated convergence test failures on
5891 C one attempted step, before completing the requested
5892 C task, but the integration was successful as far as T.
5893 C This may be caused by an inaccurate Jacobian matrix,
5894 C if one is being used.
5895 C -6 means EWT(i) became zero for some i during the
5896 C integration. Pure relative error control (ATOL(i)=0.0)
5897 C was requested on a variable which has now vanished.
5898 C The integration was successful as far as T.
5899 C -7 means the length of RWORK and/or IWORK was too small to
5900 C proceed, but the integration was successful as far as T.
5901 C This happens when DLSODAR chooses to switch methods
5902 C but LRW and/or LIW is too small for the new method.
5903 C
5904 C Note: Since the normal output value of ISTATE is 2,
5905 C it does not need to be reset for normal continuation.
5906 C Also, since a negative input value of ISTATE will be
5907 C regarded as illegal, a negative output value requires the
5908 C user to change it, and possibly other inputs, before
5909 C calling the solver again.
5910 C
5911 C IOPT = an integer flag to specify whether or not any optional
5912 C inputs are being used on this call. Input only.
5913 C The optional inputs are listed separately below.
5914 C IOPT = 0 means no optional inputs are being used.
5915 C Default values will be used in all cases.
5916 C IOPT = 1 means one or more optional inputs are being used.
5917 C
5918 C RWORK = a real array (double precision) for work space, and (in the
5919 C first 20 words) for conditional and optional inputs and
5920 C optional outputs.
5921 C As DLSODAR switches automatically between stiff and nonstiff
5922 C methods, the required length of RWORK can change during the
5923 C problem. Thus the RWORK array passed to DLSODAR can either
5924 C have a static (fixed) length large enough for both methods,
5925 C or have a dynamic (changing) length altered by the calling
5926 C program in response to output from DLSODAR.
5927 C
5928 C --- Fixed Length Case ---
5929 C If the RWORK length is to be fixed, it should be at least
5930 C max (LRN, LRS),
5931 C where LRN and LRS are the RWORK lengths required when the
5932 C current method is nonstiff or stiff, respectively.
5933 C
5934 C The separate RWORK length requirements LRN and LRS are
5935 C as follows:
5936 C If NEQ is constant and the maximum method orders have
5937 C their default values, then
5938 C LRN = 20 + 16*NEQ + 3*NG,
5939 C LRS = 22 + 9*NEQ + NEQ**2 + 3*NG (JT = 1 or 2),
5940 C LRS = 22 + 10*NEQ + (2*ML+MU)*NEQ + 3*NG (JT = 4 or 5).
5941 C Under any other conditions, LRN and LRS are given by:
5942 C LRN = 20 + NYH*(MXORDN+1) + 3*NEQ + 3*NG,
5943 C LRS = 20 + NYH*(MXORDS+1) + 3*NEQ + LMAT + 3*NG,
5944 C where
5945 C NYH = the initial value of NEQ,
5946 C MXORDN = 12, unless a smaller value is given as an
5947 C optional input,
5948 C MXORDS = 5, unless a smaller value is given as an
5949 C optional input,
5950 C LMAT = length of matrix work space:
5951 C LMAT = NEQ**2 + 2 if JT = 1 or 2,
5952 C LMAT = (2*ML + MU + 1)*NEQ + 2 if JT = 4 or 5.
5953 C
5954 C --- Dynamic Length Case ---
5955 C If the length of RWORK is to be dynamic, then it should
5956 C be at least LRN or LRS, as defined above, depending on the
5957 C current method. Initially, it must be at least LRN (since
5958 C DLSODAR starts with the nonstiff method). On any return
5959 C from DLSODAR, the optional output MCUR indicates the current
5960 C method. If MCUR differs from the value it had on the
5961 C previous return, or if there has only been one call to
5962 C DLSODAR and MCUR is now 2, then DLSODAR has switched
5963 C methods during the last call, and the length of RWORK
5964 C should be reset (to LRN if MCUR = 1, or to LRS if
5965 C MCUR = 2). (An increase in the RWORK length is required
5966 C if DLSODAR returned ISTATE = -7, but not otherwise.)
5967 C After resetting the length, call DLSODAR with ISTATE = 3
5968 C to signal that change.
5969 C
5970 C LRW = the length of the array RWORK, as declared by the user.
5971 C (This will be checked by the solver.)
5972 C
5973 C IWORK = an integer array for work space.
5974 C As DLSODAR switches automatically between stiff and nonstiff
5975 C methods, the required length of IWORK can change during
5976 C problem, between
5977 C LIS = 20 + NEQ and LIN = 20,
5978 C respectively. Thus the IWORK array passed to DLSODAR can
5979 C either have a fixed length of at least 20 + NEQ, or have a
5980 C dynamic length of at least LIN or LIS, depending on the
5981 C current method. The comments on dynamic length under
5982 C RWORK above apply here. Initially, this length need
5983 C only be at least LIN = 20.
5984 C
5985 C The first few words of IWORK are used for conditional and
5986 C optional inputs and optional outputs.
5987 C
5988 C The following 2 words in IWORK are conditional inputs:
5989 C IWORK(1) = ML These are the lower and upper
5990 C IWORK(2) = MU half-bandwidths, respectively, of the
5991 C banded Jacobian, excluding the main diagonal.
5992 C The band is defined by the matrix locations
5993 C (i,j) with i-ML .le. j .le. i+MU. ML and MU
5994 C must satisfy 0 .le. ML,MU .le. NEQ-1.
5995 C These are required if JT is 4 or 5, and
5996 C ignored otherwise. ML and MU may in fact be
5997 C the band parameters for a matrix to which
5998 C df/dy is only approximately equal.
5999 C
6000 C LIW = the length of the array IWORK, as declared by the user.
6001 C (This will be checked by the solver.)
6002 C
6003 C Note: The base addresses of the work arrays must not be
6004 C altered between calls to DLSODAR for the same problem.
6005 C The contents of the work arrays must not be altered
6006 C between calls, except possibly for the conditional and
6007 C optional inputs, and except for the last 3*NEQ words of RWORK.
6008 C The latter space is used for internal scratch space, and so is
6009 C available for use by the user outside DLSODAR between calls, if
6010 C desired (but not for use by F, JAC, or G).
6011 C
6012 C JAC = the name of the user-supplied routine to compute the
6013 C Jacobian matrix, df/dy, if JT = 1 or 4. The JAC routine
6014 C is optional, but if the problem is expected to be stiff much
6015 C of the time, you are encouraged to supply JAC, for the sake
6016 C of efficiency. (Alternatively, set JT = 2 or 5 to have
6017 C DLSODAR compute df/dy internally by difference quotients.)
6018 C If and when DLSODAR uses df/dy, it treats this NEQ by NEQ
6019 C matrix either as full (JT = 1 or 2), or as banded (JT =
6020 C 4 or 5) with half-bandwidths ML and MU (discussed under
6021 C IWORK above). In either case, if JT = 1 or 4, the JAC
6022 C routine must compute df/dy as a function of the scalar t
6023 C and the vector y. It is to have the form
6024 C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD)
6025 C DOUBLE PRECISION T, Y(*), PD(NROWPD,*)
6026 C where NEQ, T, Y, ML, MU, and NROWPD are input and the array
6027 C PD is to be loaded with partial derivatives (elements of
6028 C the Jacobian matrix) on output. PD must be given a first
6029 C dimension of NROWPD. T and Y have the same meaning as in
6030 C Subroutine F.
6031 C In the full matrix case (JT = 1), ML and MU are
6032 C ignored, and the Jacobian is to be loaded into PD in
6033 C columnwise manner, with df(i)/dy(j) loaded into pd(i,j).
6034 C In the band matrix case (JT = 4), the elements
6035 C within the band are to be loaded into PD in columnwise
6036 C manner, with diagonal lines of df/dy loaded into the rows
6037 C of PD. Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j).
6038 C ML and MU are the half-bandwidth parameters (see IWORK).
6039 C The locations in PD in the two triangular areas which
6040 C correspond to nonexistent matrix elements can be ignored
6041 C or loaded arbitrarily, as they are overwritten by DLSODAR.
6042 C JAC need not provide df/dy exactly. A crude
6043 C approximation (possibly with a smaller bandwidth) will do.
6044 C In either case, PD is preset to zero by the solver,
6045 C so that only the nonzero elements need be loaded by JAC.
6046 C Each call to JAC is preceded by a call to F with the same
6047 C arguments NEQ, T, and Y. Thus to gain some efficiency,
6048 C intermediate quantities shared by both calculations may be
6049 C saved in a user Common block by F and not recomputed by JAC,
6050 C if desired. Also, JAC may alter the Y array, if desired.
6051 C JAC must be declared External in the calling program.
6052 C Subroutine JAC may access user-defined quantities in
6053 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array
6054 C (dimensioned in JAC) and/or Y has length exceeding NEQ(1).
6055 C See the descriptions of NEQ and Y above.
6056 C
6057 C JT = Jacobian type indicator. Used only for input.
6058 C JT specifies how the Jacobian matrix df/dy will be
6059 C treated, if and when DLSODAR requires this matrix.
6060 C JT has the following values and meanings:
6061 C 1 means a user-supplied full (NEQ by NEQ) Jacobian.
6062 C 2 means an internally generated (difference quotient) full
6063 C Jacobian (using NEQ extra calls to F per df/dy value).
6064 C 4 means a user-supplied banded Jacobian.
6065 C 5 means an internally generated banded Jacobian (using
6066 C ML+MU+1 extra calls to F per df/dy evaluation).
6067 C If JT = 1 or 4, the user must supply a Subroutine JAC
6068 C (the name is arbitrary) as described above under JAC.
6069 C If JT = 2 or 5, a dummy argument can be used.
6070 C
6071 C G = the name of subroutine for constraint functions, whose
6072 C roots are desired during the integration. It is to have
6073 C the form
6074 C SUBROUTINE G (NEQ, T, Y, NG, GOUT)
6075 C DOUBLE PRECISION T, Y(*), GOUT(NG)
6076 C where NEQ, T, Y, and NG are input, and the array GOUT
6077 C is output. NEQ, T, and Y have the same meaning as in
6078 C the F routine, and GOUT is an array of length NG.
6079 C For i = 1,...,NG, this routine is to load into GOUT(i)
6080 C the value at (T,Y) of the i-th constraint function g(i).
6081 C DLSODAR will find roots of the g(i) of odd multiplicity
6082 C (i.e. sign changes) as they occur during the integration.
6083 C G must be declared External in the calling program.
6084 C
6085 C Caution: Because of numerical errors in the functions
6086 C g(i) due to roundoff and integration error, DLSODAR may
6087 C return false roots, or return the same root at two or more
6088 C nearly equal values of t. If such false roots are
6089 C suspected, the user should consider smaller error tolerances
6090 C and/or higher precision in the evaluation of the g(i).
6091 C
6092 C If a root of some g(i) defines the end of the problem,
6093 C the input to DLSODAR should nevertheless allow integration
6094 C to a point slightly past that root, so that DLSODAR can
6095 C locate the root by interpolation.
6096 C
6097 C Subroutine G may access user-defined quantities in
6098 C NEQ(2),... and Y(NEQ(1)+1),... if NEQ is an array
6099 C (dimensioned in G) and/or Y has length exceeding NEQ(1).
6100 C See the descriptions of NEQ and Y above.
6101 C
6102 C NG = number of constraint functions g(i). If there are none,
6103 C set NG = 0, and pass a dummy name for G.
6104 C
6105 C JROOT = integer array of length NG. Used only for output.
6106 C On a return with ISTATE = 3 (one or more roots found),
6107 C JROOT(i) = 1 if g(i) has a root at T, or JROOT(i) = 0 if not.
6108 C-----------------------------------------------------------------------
6109 C Optional Inputs.
6110 C
6111 C The following is a list of the optional inputs provided for in the
6112 C call sequence. (See also Part 2.) For each such input variable,
6113 C this table lists its name as used in this documentation, its
6114 C location in the call sequence, its meaning, and the default value.
6115 C The use of any of these inputs requires IOPT = 1, and in that
6116 C case all of these inputs are examined. A value of zero for any
6117 C of these optional inputs will cause the default value to be used.
6118 C Thus to use a subset of the optional inputs, simply preload
6119 C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and
6120 C then set those of interest to nonzero values.
6121 C
6122 C Name Location Meaning and Default Value
6123 C
6124 C H0 RWORK(5) the step size to be attempted on the first step.
6125 C The default value is determined by the solver.
6126 C
6127 C HMAX RWORK(6) the maximum absolute step size allowed.
6128 C The default value is infinite.
6129 C
6130 C HMIN RWORK(7) the minimum absolute step size allowed.
6131 C The default value is 0. (This lower bound is not
6132 C enforced on the final step before reaching TCRIT
6133 C when ITASK = 4 or 5.)
6134 C
6135 C IXPR IWORK(5) flag to generate extra printing at method switches.
6136 C IXPR = 0 means no extra printing (the default).
6137 C IXPR = 1 means print data on each switch.
6138 C T, H, and NST will be printed on the same logical
6139 C unit as used for error messages.
6140 C
6141 C MXSTEP IWORK(6) maximum number of (internally defined) steps
6142 C allowed during one call to the solver.
6143 C The default value is 500.
6144 C
6145 C MXHNIL IWORK(7) maximum number of messages printed (per problem)
6146 C warning that T + H = T on a step (H = step size).
6147 C This must be positive to result in a non-default
6148 C value. The default value is 10.
6149 C
6150 C MXORDN IWORK(8) the maximum order to be allowed for the nonstiff
6151 C (Adams) method. The default value is 12.
6152 C If MXORDN exceeds the default value, it will
6153 C be reduced to the default value.
6154 C MXORDN is held constant during the problem.
6155 C
6156 C MXORDS IWORK(9) the maximum order to be allowed for the stiff
6157 C (BDF) method. The default value is 5.
6158 C If MXORDS exceeds the default value, it will
6159 C be reduced to the default value.
6160 C MXORDS is held constant during the problem.
6161 C-----------------------------------------------------------------------
6162 C Optional Outputs.
6163 C
6164 C As optional additional output from DLSODAR, the variables listed
6165 C below are quantities related to the performance of DLSODAR
6166 C which are available to the user. These are communicated by way of
6167 C the work arrays, but also have internal mnemonic names as shown.
6168 C Except where stated otherwise, all of these outputs are defined
6169 C on any successful return from DLSODAR, and on any return with
6170 C ISTATE = -1, -2, -4, -5, or -6. On an illegal input return
6171 C (ISTATE = -3), they will be unchanged from their existing values
6172 C (if any), except possibly for TOLSF, LENRW, and LENIW.
6173 C On any error return, outputs relevant to the error will be defined,
6174 C as noted below.
6175 C
6176 C Name Location Meaning
6177 C
6178 C HU RWORK(11) the step size in t last used (successfully).
6179 C
6180 C HCUR RWORK(12) the step size to be attempted on the next step.
6181 C
6182 C TCUR RWORK(13) the current value of the independent variable
6183 C which the solver has actually reached, i.e. the
6184 C current internal mesh point in t. On output, TCUR
6185 C will always be at least as far as the argument
6186 C T, but may be farther (if interpolation was done).
6187 C
6188 C TOLSF RWORK(14) a tolerance scale factor, greater than 1.0,
6189 C computed when a request for too much accuracy was
6190 C detected (ISTATE = -3 if detected at the start of
6191 C the problem, ISTATE = -2 otherwise). If ITOL is
6192 C left unaltered but RTOL and ATOL are uniformly
6193 C scaled up by a factor of TOLSF for the next call,
6194 C then the solver is deemed likely to succeed.
6195 C (The user may also ignore TOLSF and alter the
6196 C tolerance parameters in any other way appropriate.)
6197 C
6198 C TSW RWORK(15) the value of t at the time of the last method
6199 C switch, if any.
6200 C
6201 C NGE IWORK(10) the number of g evaluations for the problem so far.
6202 C
6203 C NST IWORK(11) the number of steps taken for the problem so far.
6204 C
6205 C NFE IWORK(12) the number of f evaluations for the problem so far.
6206 C
6207 C NJE IWORK(13) the number of Jacobian evaluations (and of matrix
6208 C LU decompositions) for the problem so far.
6209 C
6210 C NQU IWORK(14) the method order last used (successfully).
6211 C
6212 C NQCUR IWORK(15) the order to be attempted on the next step.
6213 C
6214 C IMXER IWORK(16) the index of the component of largest magnitude in
6215 C the weighted local error vector ( E(i)/EWT(i) ),
6216 C on an error return with ISTATE = -4 or -5.
6217 C
6218 C LENRW IWORK(17) the length of RWORK actually required, assuming
6219 C that the length of RWORK is to be fixed for the
6220 C rest of the problem, and that switching may occur.
6221 C This is defined on normal returns and on an illegal
6222 C input return for insufficient storage.
6223 C
6224 C LENIW IWORK(18) the length of IWORK actually required, assuming
6225 C that the length of IWORK is to be fixed for the
6226 C rest of the problem, and that switching may occur.
6227 C This is defined on normal returns and on an illegal
6228 C input return for insufficient storage.
6229 C
6230 C MUSED IWORK(19) the method indicator for the last successful step:
6231 C 1 means Adams (nonstiff), 2 means BDF (stiff).
6232 C
6233 C MCUR IWORK(20) the current method indicator:
6234 C 1 means Adams (nonstiff), 2 means BDF (stiff).
6235 C This is the method to be attempted
6236 C on the next step. Thus it differs from MUSED
6237 C only if a method switch has just been made.
6238 C
6239 C The following two arrays are segments of the RWORK array which
6240 C may also be of interest to the user as optional outputs.
6241 C For each array, the table below gives its internal name,
6242 C its base address in RWORK, and its description.
6243 C
6244 C Name Base Address Description
6245 C
6246 C YH 21 + 3*NG the Nordsieck history array, of size NYH by
6247 C (NQCUR + 1), where NYH is the initial value
6248 C of NEQ. For j = 0,1,...,NQCUR, column j+1
6249 C of YH contains HCUR**j/factorial(j) times
6250 C the j-th derivative of the interpolating
6251 C polynomial currently representing the solution,
6252 C evaluated at t = TCUR.
6253 C
6254 C ACOR LACOR array of size NEQ used for the accumulated
6255 C (from Common corrections on each step, scaled on output
6256 C as noted) to represent the estimated local error in y
6257 C on the last step. This is the vector E in
6258 C the description of the error control. It is
6259 C defined only on a successful return from
6260 C DLSODAR. The base address LACOR is obtained by
6261 C including in the user's program the
6262 C following 2 lines:
6263 C COMMON /DLS001/ RLS(218), ILS(37)
6264 C LACOR = ILS(22)
6265 C
6266 C-----------------------------------------------------------------------
6267 C Part 2. Other Routines Callable.
6268 C
6269 C The following are optional calls which the user may make to
6270 C gain additional capabilities in conjunction with DLSODAR.
6271 C (The routines XSETUN and XSETF are designed to conform to the
6272 C SLATEC error handling package.)
6273 C
6274 C Form of Call Function
6275 C CALL XSETUN(LUN) Set the logical unit number, LUN, for
6276 C output of messages from DLSODAR, if
6277 C the default is not desired.
6278 C The default value of LUN is 6.
6279 C
6280 C CALL XSETF(MFLAG) Set a flag to control the printing of
6281 C messages by DLSODAR.
6282 C MFLAG = 0 means do not print. (Danger:
6283 C This risks losing valuable information.)
6284 C MFLAG = 1 means print (the default).
6285 C
6286 C Either of the above calls may be made at
6287 C any time and will take effect immediately.
6288 C
6289 C CALL DSRCAR(RSAV,ISAV,JOB) saves and restores the contents of
6290 C the internal Common blocks used by
6291 C DLSODAR (see Part 3 below).
6292 C RSAV must be a real array of length 245
6293 C or more, and ISAV must be an integer
6294 C array of length 55 or more.
6295 C JOB=1 means save Common into RSAV/ISAV.
6296 C JOB=2 means restore Common from RSAV/ISAV.
6297 C DSRCAR is useful if one is
6298 C interrupting a run and restarting
6299 C later, or alternating between two or
6300 C more problems solved with DLSODAR.
6301 C
6302 C CALL DINTDY(,,,,,) Provide derivatives of y, of various
6303 C (see below) orders, at a specified point t, if
6304 C desired. It may be called only after
6305 C a successful return from DLSODAR.
6306 C
6307 C The detailed instructions for using DINTDY are as follows.
6308 C The form of the call is:
6309 C
6310 C LYH = 21 + 3*NG
6311 C CALL DINTDY (T, K, RWORK(LYH), NYH, DKY, IFLAG)
6312 C
6313 C The input parameters are:
6314 C
6315 C T = value of independent variable where answers are desired
6316 C (normally the same as the T last returned by DLSODAR).
6317 C For valid results, T must lie between TCUR - HU and TCUR.
6318 C (See optional outputs for TCUR and HU.)
6319 C K = integer order of the derivative desired. K must satisfy
6320 C 0 .le. K .le. NQCUR, where NQCUR is the current order
6321 C (see optional outputs). The capability corresponding
6322 C to K = 0, i.e. computing y(t), is already provided
6323 C by DLSODAR directly. Since NQCUR .ge. 1, the first
6324 C derivative dy/dt is always available with DINTDY.
6325 C LYH = 21 + 3*NG = base address in RWORK of the history array YH.
6326 C NYH = column length of YH, equal to the initial value of NEQ.
6327 C
6328 C The output parameters are:
6329 C
6330 C DKY = a real array of length NEQ containing the computed value
6331 C of the K-th derivative of y(t).
6332 C IFLAG = integer flag, returned as 0 if K and T were legal,
6333 C -1 if K was illegal, and -2 if T was illegal.
6334 C On an error return, a message is also written.
6335 C-----------------------------------------------------------------------
6336 C Part 3. Common Blocks.
6337 C
6338 C If DLSODAR is to be used in an overlay situation, the user
6339 C must declare, in the primary overlay, the variables in:
6340 C (1) the call sequence to DLSODAR, and
6341 C (2) the three internal Common blocks
6342 C /DLS001/ of length 255 (218 double precision words
6343 C followed by 37 integer words),
6344 C /DLSA01/ of length 31 (22 double precision words
6345 C followed by 9 integer words).
6346 C /DLSR01/ of length 7 (3 double precision words
6347 C followed by 4 integer words).
6348 C
6349 C If DLSODAR is used on a system in which the contents of internal
6350 C Common blocks are not preserved between calls, the user should
6351 C declare the above Common blocks in the calling program to insure
6352 C that their contents are preserved.
6353 C
6354 C If the solution of a given problem by DLSODAR is to be interrupted
6355 C and then later continued, such as when restarting an interrupted run
6356 C or alternating between two or more problems, the user should save,
6357 C following the return from the last DLSODAR call prior to the
6358 C interruption, the contents of the call sequence variables and the
6359 C internal Common blocks, and later restore these values before the
6360 C next DLSODAR call for that problem. To save and restore the Common
6361 C blocks, use Subroutine DSRCAR (see Part 2 above).
6362 C
6363 C-----------------------------------------------------------------------
6364 C Part 4. Optionally Replaceable Solver Routines.
6365 C
6366 C Below is a description of a routine in the DLSODAR package which
6367 C relates to the measurement of errors, and can be
6368 C replaced by a user-supplied version, if desired. However, since such
6369 C a replacement may have a major impact on performance, it should be
6370 C done only when absolutely necessary, and only with great caution.
6371 C (Note: The means by which the package version of a routine is
6372 C superseded by the user's version may be system-dependent.)
6373 C
6374 C (a) DEWSET.
6375 C The following subroutine is called just before each internal
6376 C integration step, and sets the array of error weights, EWT, as
6377 C described under ITOL/RTOL/ATOL above:
6378 C Subroutine DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT)
6379 C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODAR call sequence,
6380 C YCUR contains the current dependent variable vector, and
6381 C EWT is the array of weights set by DEWSET.
6382 C
6383 C If the user supplies this subroutine, it must return in EWT(i)
6384 C (i = 1,...,NEQ) a positive quantity suitable for comparing errors
6385 C in y(i) to. The EWT array returned by DEWSET is passed to the
6386 C DMNORM routine, and also used by DLSODAR in the computation
6387 C of the optional output IMXER, and the increments for difference
6388 C quotient Jacobians.
6389 C
6390 C In the user-supplied version of DEWSET, it may be desirable to use
6391 C the current values of derivatives of y. Derivatives up to order NQ
6392 C are available from the history array YH, described above under
6393 C optional outputs. In DEWSET, YH is identical to the YCUR array,
6394 C extended to NQ + 1 columns with a column length of NYH and scale
6395 C factors of H**j/factorial(j). On the first call for the problem,
6396 C given by NST = 0, NQ is 1 and H is temporarily set to 1.0.
6397 C NYH is the initial value of NEQ. The quantities NQ, H, and NST
6398 C can be obtained by including in DEWSET the statements:
6399 C DOUBLE PRECISION RLS
6400 C COMMON /DLS001/ RLS(218),ILS(37)
6401 C NQ = ILS(33)
6402 C NST = ILS(34)
6403 C H = RLS(212)
6404 C Thus, for example, the current value of dy/dt can be obtained as
6405 C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is
6406 C unnecessary when NST = 0).
6407 C-----------------------------------------------------------------------
6408 C
6409 C***REVISION HISTORY (YYYYMMDD)
6410 C 19811102 DATE WRITTEN
6411 C 19820126 Fixed bug in tests of work space lengths;
6412 C minor corrections in main prologue and comments.
6413 C 19820507 Fixed bug in RCHEK in setting HMING.
6414 C 19870330 Major update: corrected comments throughout;
6415 C removed TRET from Common; rewrote EWSET with 4 loops;
6416 C fixed t test in INTDY; added Cray directives in STODA;
6417 C in STODA, fixed DELP init. and logic around PJAC call;
6418 C combined routines to save/restore Common;
6419 C passed LEVEL = 0 in error message calls (except run abort).
6420 C 19970225 Fixed lines setting JSTART = -2 in Subroutine LSODAR.
6421 C 20010425 Major update: convert source lines to upper case;
6422 C added *DECK lines; changed from 1 to * in dummy dimensions;
6423 C changed names R1MACH/D1MACH to RUMACH/DUMACH;
6424 C renamed routines for uniqueness across single/double prec.;
6425 C converted intrinsic names to generic form;
6426 C removed ILLIN and NTREP (data loaded) from Common;
6427 C removed all 'own' variables from Common;
6428 C changed error messages to quoted strings;
6429 C replaced XERRWV/XERRWD with 1993 revised version;
6430 C converted prologues, comments, error messages to mixed case;
6431 C numerous corrections to prologues and internal comments.
6432 C 20010507 Converted single precision source to double precision.
6433 C 20010613 Revised excess accuracy test (to match rest of ODEPACK).
6434 C 20010808 Fixed bug in DPRJA (matrix in DBNORM call).
6435 C 20020502 Corrected declarations in descriptions of user routines.
6436 C 20031105 Restored 'own' variables to Common blocks, to enable
6437 C interrupt/restart feature.
6438 C 20031112 Added SAVE statements for data-loaded constants.
6439 C
6440 C-----------------------------------------------------------------------
6441 C Other routines in the DLSODAR package.
6442 C
6443 C In addition to Subroutine DLSODAR, the DLSODAR package includes the
6444 C following subroutines and function routines:
6445 C DRCHEK does preliminary checking for roots, and serves as an
6446 C interface between Subroutine DLSODAR and Subroutine DROOTS.
6447 C DROOTS finds the leftmost root of a set of functions.
6448 C DINTDY computes an interpolated value of the y vector at t = TOUT.
6449 C DSTODA is the core integrator, which does one step of the
6450 C integration and the associated error control.
6451 C DCFODE sets all method coefficients and test constants.
6452 C DPRJA computes and preprocesses the Jacobian matrix J = df/dy
6453 C and the Newton iteration matrix P = I - h*l0*J.
6454 C DSOLSY manages solution of linear system in chord iteration.
6455 C DEWSET sets the error weight vector EWT before each step.
6456 C DMNORM computes the weighted max-norm of a vector.
6457 C DFNORM computes the norm of a full matrix consistent with the
6458 C weighted max-norm on vectors.
6459 C DBNORM computes the norm of a band matrix consistent with the
6460 C weighted max-norm on vectors.
6461 C DSRCAR is a user-callable routine to save and restore
6462 C the contents of the internal Common blocks.
6463 C DGEFA and DGESL are routines from LINPACK for solving full
6464 C systems of linear algebraic equations.
6465 C DGBFA and DGBSL are routines from LINPACK for solving banded
6466 C linear systems.
6467 C DCOPY is one of the basic linear algebra modules (BLAS).
6468 C DUMACH computes the unit roundoff in a machine-independent manner.
6469 C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all
6470 C error messages and warnings. XERRWD is machine-dependent.
6471 C Note: DMNORM, DFNORM, DBNORM, DUMACH, IXSAV, and IUMACH are
6472 C function routines. All the others are subroutines.
6473 C
6474 C-----------------------------------------------------------------------
6475  EXTERNAL dprja, dsolsy
6476  DOUBLE PRECISION dumach, dmnorm
6477  INTEGER init, mxstep, mxhnil, nhnil, nslast, nyh, iowns,
6478  1 icf, ierpj, iersl, jcur, jstart, kflag, l,
6479  2 lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
6480  3 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
6481  INTEGER insufr, insufi, ixpr, iowns2, jtyp, mused, mxordn, mxords
6482  INTEGER lg0, lg1, lgx, iownr3, irfnd, itaskc, ngc, nge
6483  INTEGER i, i1, i2, iflag, imxer, kgo, leniw,
6484  1 lenrw, lenwm, lf0, ml, mord, mu, mxhnl0, mxstp0
6485  INTEGER len1, len1c, len1n, len1s, len2, leniwc, lenrwc
6486  INTEGER irfp, irt, lenyh, lyhnew
6487  DOUBLE PRECISION rowns,
6488  1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
6489  DOUBLE PRECISION tsw, rowns2, pdnorm
6490  DOUBLE PRECISION rownr3, t0, tlast, toutc
6491  DOUBLE PRECISION atoli, ayi, big, ewti, h0, hmax, hmx, rh, rtoli,
6492  1 tcrit, tdist, tnext, tol, tolsf, tp, SIZE, sum, w0
6493  dimension mord(2)
6494  LOGICAL ihit
6495  CHARACTER*60 msg
6496  SAVE mord, mxstp0, mxhnl0
6497 C-----------------------------------------------------------------------
6498 C The following three internal Common blocks contain
6499 C (a) variables which are local to any subroutine but whose values must
6500 C be preserved between calls to the routine ("own" variables), and
6501 C (b) variables which are communicated between subroutines.
6502 C The block DLS001 is declared in subroutines DLSODAR, DINTDY, DSTODA,
6503 C DPRJA, and DSOLSY.
6504 C The block DLSA01 is declared in subroutines DLSODAR, DSTODA, DPRJA.
6505 C The block DLSR01 is declared in subroutines DLSODAR, DRCHEK, DROOTS.
6506 C Groups of variables are replaced by dummy arrays in the Common
6507 C declarations in routines where those variables are not used.
6508 C-----------------------------------------------------------------------
6509  COMMON /dls001/ rowns(209),
6510  1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
6511  2 init, mxstep, mxhnil, nhnil, nslast, nyh, iowns(6),
6512  3 icf, ierpj, iersl, jcur, jstart, kflag, l,
6513  4 lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
6514  5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
6515 C
6516  COMMON /dlsa01/ tsw, rowns2(20), pdnorm,
6517  1 insufr, insufi, ixpr, iowns2(2), jtyp, mused, mxordn, mxords
6518 C
6519  COMMON /dlsr01/ rownr3(2), t0, tlast, toutc,
6520  1 lg0, lg1, lgx, iownr3(2), irfnd, itaskc, ngc, nge
6521 C
6522  DATA mord(1),mord(2)/12,5/, mxstp0/500/, mxhnl0/10/
6523 C-----------------------------------------------------------------------
6524 C Block A.
6525 C This code block is executed on every call.
6526 C It tests ISTATE and ITASK for legality and branches appropriately.
6527 C If ISTATE .gt. 1 but the flag INIT shows that initialization has
6528 C not yet been done, an error return occurs.
6529 C If ISTATE = 1 and TOUT = T, return immediately.
6530 C-----------------------------------------------------------------------
6531  IF (istate .LT. 1 .OR. istate .GT. 3) GO TO 601
6532  IF (itask .LT. 1 .OR. itask .GT. 5) GO TO 602
6533  itaskc = itask
6534  IF (istate .EQ. 1) GO TO 10
6535  IF (init .EQ. 0) GO TO 603
6536  IF (istate .EQ. 2) GO TO 200
6537  GO TO 20
6538  10 init = 0
6539  IF (tout .EQ. t) RETURN
6540 C-----------------------------------------------------------------------
6541 C Block B.
6542 C The next code block is executed for the initial call (ISTATE = 1),
6543 C or for a continuation call with parameter changes (ISTATE = 3).
6544 C It contains checking of all inputs and various initializations.
6545 C
6546 C First check legality of the non-optional inputs NEQ, ITOL, IOPT,
6547 C JT, ML, MU, and NG.
6548 C-----------------------------------------------------------------------
6549  20 IF (neq(1) .LE. 0) GO TO 604
6550  IF (istate .EQ. 1) GO TO 25
6551  IF (neq(1) .GT. n) GO TO 605
6552  25 n = neq(1)
6553  IF (itol .LT. 1 .OR. itol .GT. 4) GO TO 606
6554  IF (iopt .LT. 0 .OR. iopt .GT. 1) GO TO 607
6555  IF (jt .EQ. 3 .OR. jt .LT. 1 .OR. jt .GT. 5) GO TO 608
6556  jtyp = jt
6557  IF (jt .LE. 2) GO TO 30
6558  ml = iwork(1)
6559  mu = iwork(2)
6560  IF (ml .LT. 0 .OR. ml .GE. n) GO TO 609
6561  IF (mu .LT. 0 .OR. mu .GE. n) GO TO 610
6562  30 CONTINUE
6563  IF (ng .LT. 0) GO TO 630
6564  IF (istate .EQ. 1) GO TO 35
6565  IF (irfnd .EQ. 0 .AND. ng .NE. ngc) GO TO 631
6566  35 ngc = ng
6567 C Next process and check the optional inputs. --------------------------
6568  IF (iopt .EQ. 1) GO TO 40
6569  ixpr = 0
6570  mxstep = mxstp0
6571  mxhnil = mxhnl0
6572  hmxi = 0.0d0
6573  hmin = 0.0d0
6574  IF (istate .NE. 1) GO TO 60
6575  h0 = 0.0d0
6576  mxordn = mord(1)
6577  mxords = mord(2)
6578  GO TO 60
6579  40 ixpr = iwork(5)
6580  IF (ixpr .LT. 0 .OR. ixpr .GT. 1) GO TO 611
6581  mxstep = iwork(6)
6582  IF (mxstep .LT. 0) GO TO 612
6583  IF (mxstep .EQ. 0) mxstep = mxstp0
6584  mxhnil = iwork(7)
6585  IF (mxhnil .LT. 0) GO TO 613
6586  IF (mxhnil .EQ. 0) mxhnil = mxhnl0
6587  IF (istate .NE. 1) GO TO 50
6588  h0 = rwork(5)
6589  mxordn = iwork(8)
6590  IF (mxordn .LT. 0) GO TO 628
6591  IF (mxordn .EQ. 0) mxordn = 100
6592  mxordn = min(mxordn,mord(1))
6593  mxords = iwork(9)
6594  IF (mxords .LT. 0) GO TO 629
6595  IF (mxords .EQ. 0) mxords = 100
6596  mxords = min(mxords,mord(2))
6597  IF ((tout - t)*h0 .LT. 0.0d0) GO TO 614
6598  50 hmax = rwork(6)
6599  IF (hmax .LT. 0.0d0) GO TO 615
6600  hmxi = 0.0d0
6601  IF (hmax .GT. 0.0d0) hmxi = 1.0d0/hmax
6602  hmin = rwork(7)
6603  IF (hmin .LT. 0.0d0) GO TO 616
6604 C-----------------------------------------------------------------------
6605 C Set work array pointers and check lengths LRW and LIW.
6606 C If ISTATE = 1, METH is initialized to 1 here to facilitate the
6607 C checking of work space lengths.
6608 C Pointers to segments of RWORK and IWORK are named by prefixing L to
6609 C the name of the segment. E.g., the segment YH starts at RWORK(LYH).
6610 C Segments of RWORK (in order) are denoted G0, G1, GX, YH, WM,
6611 C EWT, SAVF, ACOR.
6612 C If the lengths provided are insufficient for the current method,
6613 C an error return occurs. This is treated as illegal input on the
6614 C first call, but as a problem interruption with ISTATE = -7 on a
6615 C continuation call. If the lengths are sufficient for the current
6616 C method but not for both methods, a warning message is sent.
6617 C-----------------------------------------------------------------------
6618  60 IF (istate .EQ. 1) meth = 1
6619  IF (istate .EQ. 1) nyh = n
6620  lg0 = 21
6621  lg1 = lg0 + ng
6622  lgx = lg1 + ng
6623  lyhnew = lgx + ng
6624  IF (istate .EQ. 1) lyh = lyhnew
6625  IF (lyhnew .EQ. lyh) GO TO 62
6626 C If ISTATE = 3 and NG was changed, shift YH to its new location. ------
6627  lenyh = l*nyh
6628  IF (lrw .LT. lyhnew-1+lenyh) GO TO 62
6629  i1 = 1
6630  IF (lyhnew .GT. lyh) i1 = -1
6631  CALL dcopy (lenyh, rwork(lyh), i1, rwork(lyhnew), i1)
6632  lyh = lyhnew
6633  62 CONTINUE
6634  len1n = lyhnew - 1 + (mxordn + 1)*nyh
6635  len1s = lyhnew - 1 + (mxords + 1)*nyh
6636  lwm = len1s + 1
6637  IF (jt .LE. 2) lenwm = n*n + 2
6638  IF (jt .GE. 4) lenwm = (2*ml + mu + 1)*n + 2
6639  len1s = len1s + lenwm
6640  len1c = len1n
6641  IF (meth .EQ. 2) len1c = len1s
6642  len1 = max(len1n,len1s)
6643  len2 = 3*n
6644  lenrw = len1 + len2
6645  lenrwc = len1c + len2
6646  iwork(17) = lenrw
6647  liwm = 1
6648  leniw = 20 + n
6649  leniwc = 20
6650  IF (meth .EQ. 2) leniwc = leniw
6651  iwork(18) = leniw
6652  IF (istate .EQ. 1 .AND. lrw .LT. lenrwc) GO TO 617
6653  IF (istate .EQ. 1 .AND. liw .LT. leniwc) GO TO 618
6654  IF (istate .EQ. 3 .AND. lrw .LT. lenrwc) GO TO 550
6655  IF (istate .EQ. 3 .AND. liw .LT. leniwc) GO TO 555
6656  lewt = len1 + 1
6657  insufr = 0
6658  IF (lrw .GE. lenrw) GO TO 65
6659  insufr = 2
6660  lewt = len1c + 1
6661  msg='DLSODAR- Warning.. RWORK length is sufficient for now, but '
6662  CALL xerrwd (msg, 60, 103, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
6663  msg=' may not be later. Integration will proceed anyway. '
6664  CALL xerrwd (msg, 60, 103, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
6665  msg = ' Length needed is LENRW = I1, while LRW = I2.'
6666  CALL xerrwd (msg, 50, 103, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0)
6667  65 lsavf = lewt + n
6668  lacor = lsavf + n
6669  insufi = 0
6670  IF (liw .GE. leniw) GO TO 70
6671  insufi = 2
6672  msg='DLSODAR- Warning.. IWORK length is sufficient for now, but '
6673  CALL xerrwd (msg, 60, 104, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
6674  msg=' may not be later. Integration will proceed anyway. '
6675  CALL xerrwd (msg, 60, 104, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
6676  msg = ' Length needed is LENIW = I1, while LIW = I2.'
6677  CALL xerrwd (msg, 50, 104, 0, 2, leniw, liw, 0, 0.0d0, 0.0d0)
6678  70 CONTINUE
6679 C Check RTOL and ATOL for legality. ------------------------------------
6680  rtoli = rtol(1)
6681  atoli = atol(1)
6682  DO 75 i = 1,n
6683  IF (itol .GE. 3) rtoli = rtol(i)
6684  IF (itol .EQ. 2 .OR. itol .EQ. 4) atoli = atol(i)
6685  IF (rtoli .LT. 0.0d0) GO TO 619
6686  IF (atoli .LT. 0.0d0) GO TO 620
6687  75 CONTINUE
6688  IF (istate .EQ. 1) GO TO 100
6689 C if ISTATE = 3, set flag to signal parameter changes to DSTODA. -------
6690  jstart = -1
6691  IF (n .EQ. nyh) GO TO 200
6692 C NEQ was reduced. zero part of yh to avoid undefined references. -----
6693  i1 = lyh + l*nyh
6694  i2 = lyh + (maxord + 1)*nyh - 1
6695  IF (i1 .GT. i2) GO TO 200
6696  DO 95 i = i1,i2
6697  95 rwork(i) = 0.0d0
6698  GO TO 200
6699 C-----------------------------------------------------------------------
6700 C Block C.
6701 C The next block is for the initial call only (ISTATE = 1).
6702 C It contains all remaining initializations, the initial call to F,
6703 C and the calculation of the initial step size.
6704 C The error weights in EWT are inverted after being loaded.
6705 C-----------------------------------------------------------------------
6706  100 uround = dumach()
6707  tn = t
6708  tsw = t
6709  maxord = mxordn
6710  IF (itask .NE. 4 .AND. itask .NE. 5) GO TO 110
6711  tcrit = rwork(1)
6712  IF ((tcrit - tout)*(tout - t) .LT. 0.0d0) GO TO 625
6713  IF (h0 .NE. 0.0d0 .AND. (t + h0 - tcrit)*h0 .GT. 0.0d0)
6714  1 h0 = tcrit - t
6715  110 jstart = 0
6716  nhnil = 0
6717  nst = 0
6718  nje = 0
6719  nslast = 0
6720  hu = 0.0d0
6721  nqu = 0
6722  mused = 0
6723  miter = 0
6724  ccmax = 0.3d0
6725  maxcor = 3
6726  msbp = 20
6727  mxncf = 10
6728 C Initial call to F. (LF0 points to YH(*,2).) -------------------------
6729  lf0 = lyh + nyh
6730  CALL f (neq, t, y, rwork(lf0))
6731  nfe = 1
6732 C Load the initial value vector in YH. ---------------------------------
6733  DO 115 i = 1,n
6734  115 rwork(i+lyh-1) = y(i)
6735 C Load and invert the EWT array. (H is temporarily set to 1.0.) -------
6736  nq = 1
6737  h = 1.0d0
6738  CALL dewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt))
6739  DO 120 i = 1,n
6740  IF (rwork(i+lewt-1) .LE. 0.0d0) GO TO 621
6741  120 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1)
6742 C-----------------------------------------------------------------------
6743 C The coding below computes the step size, H0, to be attempted on the
6744 C first step, unless the user has supplied a value for this.
6745 C First check that TOUT - T differs significantly from zero.
6746 C A scalar tolerance quantity TOL is computed, as MAX(RTOL(i))
6747 C if this is positive, or MAX(ATOL(i)/ABS(Y(i))) otherwise, adjusted
6748 C so as to be between 100*UROUND and 1.0E-3.
6749 C Then the computed value H0 is given by:
6750 C
6751 C H0**(-2) = 1./(TOL * w0**2) + TOL * (norm(F))**2
6752 C
6753 C where w0 = MAX ( ABS(T), ABS(TOUT) ),
6754 C F = the initial value of the vector f(t,y), and
6755 C norm() = the weighted vector norm used throughout, given by
6756 C the DMNORM function routine, and weighted by the
6757 C tolerances initially loaded into the EWT array.
6758 C The sign of H0 is inferred from the initial values of TOUT and T.
6759 C ABS(H0) is made .le. ABS(TOUT-T) in any case.
6760 C-----------------------------------------------------------------------
6761  IF (h0 .NE. 0.0d0) GO TO 180
6762  tdist = abs(tout - t)
6763  w0 = max(abs(t),abs(tout))
6764  IF (tdist .LT. 2.0d0*uround*w0) GO TO 622
6765  tol = rtol(1)
6766  IF (itol .LE. 2) GO TO 140
6767  DO 130 i = 1,n
6768  130 tol = max(tol,rtol(i))
6769  140 IF (tol .GT. 0.0d0) GO TO 160
6770  atoli = atol(1)
6771  DO 150 i = 1,n
6772  IF (itol .EQ. 2 .OR. itol .EQ. 4) atoli = atol(i)
6773  ayi = abs(y(i))
6774  IF (ayi .NE. 0.0d0) tol = max(tol,atoli/ayi)
6775  150 CONTINUE
6776  160 tol = max(tol,100.0d0*uround)
6777  tol = min(tol,0.001d0)
6778  sum = dmnorm(n, rwork(lf0), rwork(lewt))
6779  sum = 1.0d0/(tol*w0*w0) + tol*sum**2
6780  h0 = 1.0d0/sqrt(sum)
6781  h0 = min(h0,tdist)
6782  h0 = sign(h0,tout-t)
6783 C Adjust H0 if necessary to meet HMAX bound. ---------------------------
6784  180 rh = abs(h0)*hmxi
6785  IF (rh .GT. 1.0d0) h0 = h0/rh
6786 C Load H with H0 and scale YH(*,2) by H0. ------------------------------
6787  h = h0
6788  DO 190 i = 1,n
6789  190 rwork(i+lf0-1) = h0*rwork(i+lf0-1)
6790 C
6791 C Check for a zero of g at T. ------------------------------------------
6792  irfnd = 0
6793  toutc = tout
6794  IF (ngc .EQ. 0) GO TO 270
6795  CALL drchek (1, g, neq, y, rwork(lyh), nyh,
6796  1 rwork(lg0), rwork(lg1), rwork(lgx), jroot, irt)
6797  IF (irt .EQ. 0) GO TO 270
6798  GO TO 632
6799 C-----------------------------------------------------------------------
6800 C Block D.
6801 C The next code block is for continuation calls only (ISTATE = 2 or 3)
6802 C and is to check stop conditions before taking a step.
6803 C First, DRCHEK is called to check for a root within the last step
6804 C taken, other than the last root found there, if any.
6805 C If ITASK = 2 or 5, and y(TN) has not yet been returned to the user
6806 C because of an intervening root, return through Block G.
6807 C-----------------------------------------------------------------------
6808  200 nslast = nst
6809 C
6810  irfp = irfnd
6811  IF (ngc .EQ. 0) GO TO 205
6812  IF (itask .EQ. 1 .OR. itask .EQ. 4) toutc = tout
6813  CALL drchek (2, g, neq, y, rwork(lyh), nyh,
6814  1 rwork(lg0), rwork(lg1), rwork(lgx), jroot, irt)
6815  IF (irt .NE. 1) GO TO 205
6816  irfnd = 1
6817  istate = 3
6818  t = t0
6819  GO TO 425
6820  205 CONTINUE
6821  irfnd = 0
6822  IF (irfp .EQ. 1 .AND. tlast .NE. tn .AND. itask .EQ. 2) GO TO 400
6823 C
6824  GO TO (210, 250, 220, 230, 240), itask
6825  210 IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
6826  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
6827  IF (iflag .NE. 0) GO TO 627
6828  t = tout
6829  GO TO 420
6830  220 tp = tn - hu*(1.0d0 + 100.0d0*uround)
6831  IF ((tp - tout)*h .GT. 0.0d0) GO TO 623
6832  IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
6833  t = tn
6834  GO TO 400
6835  230 tcrit = rwork(1)
6836  IF ((tn - tcrit)*h .GT. 0.0d0) GO TO 624
6837  IF ((tcrit - tout)*h .LT. 0.0d0) GO TO 625
6838  IF ((tn - tout)*h .LT. 0.0d0) GO TO 245
6839  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
6840  IF (iflag .NE. 0) GO TO 627
6841  t = tout
6842  GO TO 420
6843  240 tcrit = rwork(1)
6844  IF ((tn - tcrit)*h .GT. 0.0d0) GO TO 624
6845  245 hmx = abs(tn) + abs(h)
6846  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
6847  IF (ihit) t = tcrit
6848  IF (irfp .EQ. 1 .AND. tlast .NE. tn .AND. itask .EQ. 5) GO TO 400
6849  IF (ihit) GO TO 400
6850  tnext = tn + h*(1.0d0 + 4.0d0*uround)
6851  IF ((tnext - tcrit)*h .LE. 0.0d0) GO TO 250
6852  h = (tcrit - tn)*(1.0d0 - 4.0d0*uround)
6853  IF (istate .EQ. 2 .AND. jstart .GE. 0) jstart = -2
6854 C-----------------------------------------------------------------------
6855 C Block E.
6856 C The next block is normally executed for all calls and contains
6857 C the call to the one-step core integrator DSTODA.
6858 C
6859 C This is a looping point for the integration steps.
6860 C
6861 C First check for too many steps being taken, update EWT (if not at
6862 C start of problem), check for too much accuracy being requested, and
6863 C check for H below the roundoff level in T.
6864 C-----------------------------------------------------------------------
6865  250 CONTINUE
6866  IF (meth .EQ. mused) GO TO 255
6867  IF (insufr .EQ. 1) GO TO 550
6868  IF (insufi .EQ. 1) GO TO 555
6869  255 IF ((nst-nslast) .GE. mxstep) GO TO 500
6870  CALL dewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt))
6871  DO 260 i = 1,n
6872  IF (rwork(i+lewt-1) .LE. 0.0d0) GO TO 510
6873  260 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1)
6874  270 tolsf = uround*dmnorm(n, rwork(lyh), rwork(lewt))
6875  IF (tolsf .LE. 1.0d0) GO TO 280
6876  tolsf = tolsf*2.0d0
6877  IF (nst .EQ. 0) GO TO 626
6878  GO TO 520
6879  280 IF ((tn + h) .NE. tn) GO TO 290
6880  nhnil = nhnil + 1
6881  IF (nhnil .GT. mxhnil) GO TO 290
6882  msg = 'DLSODAR- Warning..Internal T(=R1) and H(=R2) are '
6883  CALL xerrwd (msg, 50, 101, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
6884  msg=' such that in the machine, T + H = T on the next step '
6885  CALL xerrwd (msg, 60, 101, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
6886  msg = ' (H = step size). Solver will continue anyway.'
6887  CALL xerrwd (msg, 50, 101, 0, 0, 0, 0, 2, tn, h)
6888  IF (nhnil .LT. mxhnil) GO TO 290
6889  msg = 'DLSODAR- Above warning has been issued I1 times. '
6890  CALL xerrwd (msg, 50, 102, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
6891  msg = ' It will not be issued again for this problem.'
6892  CALL xerrwd (msg, 50, 102, 0, 1, mxhnil, 0, 0, 0.0d0, 0.0d0)
6893  290 CONTINUE
6894 C-----------------------------------------------------------------------
6895 C CALL DSTODA(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,IWM,F,JAC,DPRJA,DSOLSY)
6896 C-----------------------------------------------------------------------
6897  CALL dstoda (neq, y, rwork(lyh), nyh, rwork(lyh), rwork(lewt),
6898  1 rwork(lsavf), rwork(lacor), rwork(lwm), iwork(liwm),
6899  2 f, jac, dprja, dsolsy)
6900  kgo = 1 - kflag
6901  GO TO (300, 530, 540), kgo
6902 C-----------------------------------------------------------------------
6903 C Block F.
6904 C The following block handles the case of a successful return from the
6905 C core integrator (KFLAG = 0).
6906 C If a method switch was just made, record TSW, reset MAXORD,
6907 C set JSTART to -1 to signal DSTODA to complete the switch,
6908 C and do extra printing of data if IXPR = 1.
6909 C Then call DRCHEK to check for a root within the last step.
6910 C Then, if no root was found, check for stop conditions.
6911 C-----------------------------------------------------------------------
6912  300 init = 1
6913  IF (meth .EQ. mused) GO TO 310
6914  tsw = tn
6915  maxord = mxordn
6916  IF (meth .EQ. 2) maxord = mxords
6917  IF (meth .EQ. 2) rwork(lwm) = sqrt(uround)
6918  insufr = min(insufr,1)
6919  insufi = min(insufi,1)
6920  jstart = -1
6921  IF (ixpr .EQ. 0) GO TO 310
6922  IF (meth .EQ. 2) THEN
6923  msg='DLSODAR- A switch to the BDF (stiff) method has occurred '
6924  CALL xerrwd (msg, 60, 105, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
6925  ENDIF
6926  IF (meth .EQ. 1) THEN
6927  msg='DLSODAR- A switch to the Adams (nonstiff) method occurred '
6928  CALL xerrwd (msg, 60, 106, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
6929  ENDIF
6930  msg=' at T = R1, tentative step size H = R2, step NST = I1 '
6931  CALL xerrwd (msg, 60, 107, 0, 1, nst, 0, 2, tn, h)
6932  310 CONTINUE
6933 C
6934  IF (ngc .EQ. 0) GO TO 315
6935  CALL drchek (3, g, neq, y, rwork(lyh), nyh,
6936  1 rwork(lg0), rwork(lg1), rwork(lgx), jroot, irt)
6937  IF (irt .NE. 1) GO TO 315
6938  irfnd = 1
6939  istate = 3
6940  t = t0
6941  GO TO 425
6942  315 CONTINUE
6943 C
6944  GO TO (320, 400, 330, 340, 350), itask
6945 C ITASK = 1. If TOUT has been reached, interpolate. -------------------
6946  320 IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
6947  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
6948  t = tout
6949  GO TO 420
6950 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------
6951  330 IF ((tn - tout)*h .GE. 0.0d0) GO TO 400
6952  GO TO 250
6953 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary.
6954  340 IF ((tn - tout)*h .LT. 0.0d0) GO TO 345
6955  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
6956  t = tout
6957  GO TO 420
6958  345 hmx = abs(tn) + abs(h)
6959  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
6960  IF (ihit) GO TO 400
6961  tnext = tn + h*(1.0d0 + 4.0d0*uround)
6962  IF ((tnext - tcrit)*h .LE. 0.0d0) GO TO 250
6963  h = (tcrit - tn)*(1.0d0 - 4.0d0*uround)
6964  IF (jstart .GE. 0) jstart = -2
6965  GO TO 250
6966 C ITASK = 5. See if TCRIT was reached and jump to exit. ---------------
6967  350 hmx = abs(tn) + abs(h)
6968  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
6969 C-----------------------------------------------------------------------
6970 C Block G.
6971 C The following block handles all successful returns from DLSODAR.
6972 C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly.
6973 C ISTATE is set to 2, and the optional outputs are loaded into the
6974 C work arrays before returning.
6975 C-----------------------------------------------------------------------
6976  400 DO 410 i = 1,n
6977  410 y(i) = rwork(i+lyh-1)
6978  t = tn
6979  IF (itask .NE. 4 .AND. itask .NE. 5) GO TO 420
6980  IF (ihit) t = tcrit
6981  420 istate = 2
6982  425 CONTINUE
6983  rwork(11) = hu
6984  rwork(12) = h
6985  rwork(13) = tn
6986  rwork(15) = tsw
6987  iwork(11) = nst
6988  iwork(12) = nfe
6989  iwork(13) = nje
6990  iwork(14) = nqu
6991  iwork(15) = nq
6992  iwork(19) = mused
6993  iwork(20) = meth
6994  iwork(10) = nge
6995  tlast = t
6996  RETURN
6997 C-----------------------------------------------------------------------
6998 C Block H.
6999 C The following block handles all unsuccessful returns other than
7000 C those for illegal input. First the error message routine is called.
7001 C If there was an error test or convergence test failure, IMXER is set.
7002 C Then Y is loaded from YH and T is set to TN.
7003 C The optional outputs are loaded into the work arrays before returning.
7004 C-----------------------------------------------------------------------
7005 C The maximum number of steps was taken before reaching TOUT. ----------
7006  500 msg = 'DLSODAR- At current T (=R1), MXSTEP (=I1) steps '
7007  CALL xerrwd (msg, 50, 201, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
7008  msg = ' taken on this call before reaching TOUT '
7009  CALL xerrwd (msg, 50, 201, 0, 1, mxstep, 0, 1, tn, 0.0d0)
7010  istate = -1
7011  GO TO 580
7012 C EWT(i) .le. 0.0 for some i (not at start of problem). ----------------
7013  510 ewti = rwork(lewt+i-1)
7014  msg = .le.'DLSODAR- At T(=R1), EWT(I1) has become R2 0.'
7015  CALL xerrwd (msg, 50, 202, 0, 1, i, 0, 2, tn, ewti)
7016  istate = -6
7017  GO TO 580
7018 C Too much accuracy requested for machine precision. -------------------
7019  520 msg = 'DLSODAR- At T (=R1), too much accuracy requested '
7020  CALL xerrwd (msg, 50, 203, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
7021  msg = ' for precision of machine.. See TOLSF (=R2) '
7022  CALL xerrwd (msg, 50, 203, 0, 0, 0, 0, 2, tn, tolsf)
7023  rwork(14) = tolsf
7024  istate = -2
7025  GO TO 580
7026 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. -----
7027  530 msg = 'DLSODAR- At T(=R1), step size H(=R2), the error '
7028  CALL xerrwd (msg, 50, 204, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
7029  msg = ' test failed repeatedly or with ABS(H) = HMIN'
7030  CALL xerrwd (msg, 50, 204, 0, 0, 0, 0, 2, tn, h)
7031  istate = -4
7032  GO TO 560
7033 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ----
7034  540 msg = 'DLSODAR- At T (=R1) and step size H (=R2), the '
7035  CALL xerrwd (msg, 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
7036  msg = ' corrector convergence failed repeatedly '
7037  CALL xerrwd (msg, 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
7038  msg = ' or with ABS(H) = HMIN '
7039  CALL xerrwd (msg, 30, 205, 0, 0, 0, 0, 2, tn, h)
7040  istate = -5
7041  GO TO 560
7042 C RWORK length too small to proceed. -----------------------------------
7043  550 msg = 'DLSODAR- At current T(=R1), RWORK length too small'
7044  CALL xerrwd (msg, 50, 206, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
7045  msg=' to proceed. The integration was otherwise successful.'
7046  CALL xerrwd (msg, 60, 206, 0, 0, 0, 0, 1, tn, 0.0d0)
7047  istate = -7
7048  GO TO 580
7049 C IWORK length too small to proceed. -----------------------------------
7050  555 msg = 'DLSODAR- At current T(=R1), IWORK length too small'
7051  CALL xerrwd (msg, 50, 207, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
7052  msg=' to proceed. The integration was otherwise successful.'
7053  CALL xerrwd (msg, 60, 207, 0, 0, 0, 0, 1, tn, 0.0d0)
7054  istate = -7
7055  GO TO 580
7056 C Compute IMXER if relevant. -------------------------------------------
7057  560 big = 0.0d0
7058  imxer = 1
7059  DO 570 i = 1,n
7060  SIZE = abs(rwork(i+lacor-1)*rwork(i+lewt-1))
7061  IF (big .GE. size) GO TO 570
7062  big = SIZE
7063  imxer = i
7064  570 CONTINUE
7065  iwork(16) = imxer
7066 C Set Y vector, T, and optional outputs. -------------------------------
7067  580 DO 590 i = 1,n
7068  590 y(i) = rwork(i+lyh-1)
7069  t = tn
7070  rwork(11) = hu
7071  rwork(12) = h
7072  rwork(13) = tn
7073  rwork(15) = tsw
7074  iwork(11) = nst
7075  iwork(12) = nfe
7076  iwork(13) = nje
7077  iwork(14) = nqu
7078  iwork(15) = nq
7079  iwork(19) = mused
7080  iwork(20) = meth
7081  iwork(10) = nge
7082  tlast = t
7083  RETURN
7084 C-----------------------------------------------------------------------
7085 C Block I.
7086 C The following block handles all error returns due to illegal input
7087 C (ISTATE = -3), as detected before calling the core integrator.
7088 C First the error message routine is called. If the illegal input
7089 C is a negative ISTATE, the run is aborted (apparent infinite loop).
7090 C-----------------------------------------------------------------------
7091  601 msg = 'DLSODAR- ISTATE(=I1) illegal.'
7092  CALL xerrwd (msg, 30, 1, 0, 1, istate, 0, 0, 0.0d0, 0.0d0)
7093  IF (istate .LT. 0) GO TO 800
7094  GO TO 700
7095  602 msg = 'DLSODAR- ITASK (=I1) illegal.'
7096  CALL xerrwd (msg, 30, 2, 0, 1, itask, 0, 0, 0.0d0, 0.0d0)
7097  GO TO 700
7098  603 msg = .gt.'DLSODAR- ISTATE1 but DLSODAR not initialized.'
7099  CALL xerrwd (msg, 50, 3, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
7100  GO TO 700
7101  604 msg = .lt.'DLSODAR- NEQ (=I1) 1 '
7102  CALL xerrwd (msg, 30, 4, 0, 1, neq(1), 0, 0, 0.0d0, 0.0d0)
7103  GO TO 700
7104  605 msg = 'DLSODAR- ISTATE = 3 and NEQ increased (I1 to I2).'
7105  CALL xerrwd (msg, 50, 5, 0, 2, n, neq(1), 0, 0.0d0, 0.0d0)
7106  GO TO 700
7107  606 msg = 'DLSODAR- ITOL (=I1) illegal. '
7108  CALL xerrwd (msg, 30, 6, 0, 1, itol, 0, 0, 0.0d0, 0.0d0)
7109  GO TO 700
7110  607 msg = 'DLSODAR- IOPT (=I1) illegal. '
7111  CALL xerrwd (msg, 30, 7, 0, 1, iopt, 0, 0, 0.0d0, 0.0d0)
7112  GO TO 700
7113  608 msg = 'DLSODAR- JT (=I1) illegal. '
7114  CALL xerrwd (msg, 30, 8, 0, 1, jt, 0, 0, 0.0d0, 0.0d0)
7115  GO TO 700
7116  609 msg = .lt..ge.'DLSODAR- ML (=I1) illegal: 0 or NEQ (=I2)'
7117  CALL xerrwd (msg, 50, 9, 0, 2, ml, neq(1), 0, 0.0d0, 0.0d0)
7118  GO TO 700
7119  610 msg = .lt..ge.'DLSODAR- MU (=I1) illegal: 0 or NEQ (=I2)'
7120  CALL xerrwd (msg, 50, 10, 0, 2, mu, neq(1), 0, 0.0d0, 0.0d0)
7121  GO TO 700
7122  611 msg = 'DLSODAR- IXPR (=I1) illegal. '
7123  CALL xerrwd (msg, 30, 11, 0, 1, ixpr, 0, 0, 0.0d0, 0.0d0)
7124  GO TO 700
7125  612 msg = .lt.'DLSODAR- MXSTEP (=I1) 0 '
7126  CALL xerrwd (msg, 30, 12, 0, 1, mxstep, 0, 0, 0.0d0, 0.0d0)
7127  GO TO 700
7128  613 msg = .lt.'DLSODAR- MXHNIL (=I1) 0 '
7129  CALL xerrwd (msg, 30, 13, 0, 1, mxhnil, 0, 0, 0.0d0, 0.0d0)
7130  GO TO 700
7131  614 msg = 'DLSODAR- TOUT (=R1) behind T (=R2) '
7132  CALL xerrwd (msg, 40, 14, 0, 0, 0, 0, 2, tout, t)
7133  msg = ' Integration direction is given by H0 (=R1) '
7134  CALL xerrwd (msg, 50, 14, 0, 0, 0, 0, 1, h0, 0.0d0)
7135  GO TO 700
7136  615 msg = .lt.'DLSODAR- HMAX (=R1) 0.0 '
7137  CALL xerrwd (msg, 30, 15, 0, 0, 0, 0, 1, hmax, 0.0d0)
7138  GO TO 700
7139  616 msg = .lt.'DLSODAR- HMIN (=R1) 0.0 '
7140  CALL xerrwd (msg, 30, 16, 0, 0, 0, 0, 1, hmin, 0.0d0)
7141  GO TO 700
7142  617 msg='DLSODAR- RWORK length needed, LENRW(=I1), exceeds LRW(=I2) '
7143  CALL xerrwd (msg, 60, 17, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0)
7144  GO TO 700
7145  618 msg='DLSODAR- IWORK length needed, LENIW(=I1), exceeds LIW(=I2) '
7146  CALL xerrwd (msg, 60, 18, 0, 2, leniw, liw, 0, 0.0d0, 0.0d0)
7147  GO TO 700
7148  619 msg = .lt.'DLSODAR- RTOL(I1) is R1 0.0 '
7149  CALL xerrwd (msg, 40, 19, 0, 1, i, 0, 1, rtoli, 0.0d0)
7150  GO TO 700
7151  620 msg = .lt.'DLSODAR- ATOL(I1) is R1 0.0 '
7152  CALL xerrwd (msg, 40, 20, 0, 1, i, 0, 1, atoli, 0.0d0)
7153  GO TO 700
7154  621 ewti = rwork(lewt+i-1)
7155  msg = .le.'DLSODAR- EWT(I1) is R1 0.0 '
7156  CALL xerrwd (msg, 40, 21, 0, 1, i, 0, 1, ewti, 0.0d0)
7157  GO TO 700
7158  622 msg='DLSODAR- TOUT(=R1) too close to T(=R2) to start integration.'
7159  CALL xerrwd (msg, 60, 22, 0, 0, 0, 0, 2, tout, t)
7160  GO TO 700
7161  623 msg='DLSODAR- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) '
7162  CALL xerrwd (msg, 60, 23, 0, 1, itask, 0, 2, tout, tp)
7163  GO TO 700
7164  624 msg='DLSODAR- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) '
7165  CALL xerrwd (msg, 60, 24, 0, 0, 0, 0, 2, tcrit, tn)
7166  GO TO 700
7167  625 msg='DLSODAR- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) '
7168  CALL xerrwd (msg, 60, 25, 0, 0, 0, 0, 2, tcrit, tout)
7169  GO TO 700
7170  626 msg = 'DLSODAR- At start of problem, too much accuracy '
7171  CALL xerrwd (msg, 50, 26, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
7172  msg=' requested for precision of machine.. See TOLSF (=R1) '
7173  CALL xerrwd (msg, 60, 26, 0, 0, 0, 0, 1, tolsf, 0.0d0)
7174  rwork(14) = tolsf
7175  GO TO 700
7176  627 msg = 'DLSODAR- Trouble in DINTDY. ITASK = I1, TOUT = R1'
7177  CALL xerrwd (msg, 50, 27, 0, 1, itask, 0, 1, tout, 0.0d0)
7178  GO TO 700
7179  628 msg = .lt.'DLSODAR- MXORDN (=I1) 0 '
7180  CALL xerrwd (msg, 30, 28, 0, 1, mxordn, 0, 0, 0.0d0, 0.0d0)
7181  GO TO 700
7182  629 msg = .lt.'DLSODAR- MXORDS (=I1) 0 '
7183  CALL xerrwd (msg, 30, 29, 0, 1, mxords, 0, 0, 0.0d0, 0.0d0)
7184  GO TO 700
7185  630 msg = .lt.'DLSODAR- NG (=I1) 0 '
7186  CALL xerrwd (msg, 30, 30, 0, 1, ng, 0, 0, 0.0d0, 0.0d0)
7187  GO TO 700
7188  631 msg = 'DLSODAR- NG changed (from I1 to I2) illegally, '
7189  CALL xerrwd (msg, 50, 31, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
7190  msg = ' i.e. not immediately after a root was found.'
7191  CALL xerrwd (msg, 50, 31, 0, 2, ngc, ng, 0, 0.0d0, 0.0d0)
7192  GO TO 700
7193  632 msg = 'DLSODAR- One or more components of g has a root '
7194  CALL xerrwd (msg, 50, 32, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
7195  msg = ' too near to the initial point. '
7196  CALL xerrwd (msg, 40, 32, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
7197 C
7198  700 istate = -3
7199  RETURN
7200 C
7201  800 msg = 'DLSODAR- Run aborted.. apparent infinite loop. '
7202  CALL xerrwd (msg, 50, 303, 2, 0, 0, 0, 0, 0.0d0, 0.0d0)
7203  RETURN
7204 C----------------------- End of Subroutine DLSODAR ---------------------
7205  END
7206 *DECK DLSODPK
7207  SUBROUTINE dlsodpk (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK,
7208  1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, PSOL, MF)
7209  EXTERNAL f, jac, psol
7210  INTEGER neq, itol, itask, istate, iopt, lrw, iwork, liw, mf
7211  DOUBLE PRECISION y, t, tout, rtol, atol, rwork
7212  dimension neq(*), y(*), rtol(*), atol(*), rwork(lrw), iwork(liw)
7213 C-----------------------------------------------------------------------
7214 C This is the 18 November 2003 version of
7215 C DLSODPK: Livermore Solver for Ordinary Differential equations,
7216 C with Preconditioned Krylov iteration methods for the
7217 C Newton correction linear systems.
7218 C
7219 C This version is in double precision.
7220 C
7221 C DLSODPK solves the initial value problem for stiff or nonstiff
7222 C systems of first order ODEs,
7223 C dy/dt = f(t,y) , or, in component form,
7224 C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ).
7225 C-----------------------------------------------------------------------
7226 C Introduction.
7227 C
7228 C This is a modification of the DLSODE package which incorporates
7229 C various preconditioned Krylov subspace iteration methods for the
7230 C linear algebraic systems that arise in the case of stiff systems.
7231 C
7232 C The linear systems that must be solved have the form
7233 C A * x = b , where A = identity - hl0 * (df/dy) .
7234 C Here hl0 is a scalar, and df/dy is the Jacobian matrix of partial
7235 C derivatives of f (NEQ by NEQ).
7236 C
7237 C The particular Krylov method is chosen by setting the second digit,
7238 C MITER, in the method flag MF.
7239 C Currently, the values of MITER have the following meanings:
7240 C
7241 C MITER = 1 means the preconditioned Scaled Incomplete
7242 C Orthogonalization Method (SPIOM).
7243 C
7244 C 2 means an incomplete version of the Preconditioned Scaled
7245 C Generalized Minimal Residual method (SPIGMR).
7246 C This is the best choice in general.
7247 C
7248 C 3 means the Preconditioned Conjugate Gradient method (PCG).
7249 C Recommended only when df/dy is symmetric or nearly so.
7250 C
7251 C 4 means the scaled Preconditioned Conjugate Gradient method
7252 C (PCGS). Recommended only when D-inverse * df/dy * D is
7253 C symmetric or nearly so, where D is the diagonal scaling
7254 C matrix with elements 1/EWT(i) (see RTOL/ATOL description).
7255 C
7256 C 9 means that only a user-supplied matrix P (approximating A)
7257 C will be used, with no Krylov iteration done. This option
7258 C allows the user to provide the complete linear system
7259 C solution algorithm, if desired.
7260 C
7261 C The user can apply preconditioning to the linear system A*x = b,
7262 C by means of arbitrary matrices (the preconditioners).
7263 C In the case of SPIOM and SPIGMR, one can apply left and right
7264 C preconditioners P1 and P2, and the basic iterative method is then
7265 C applied to the matrix (P1-inverse)*A*(P2-inverse) instead of to the
7266 C matrix A. The product P1*P2 should be an approximation to matrix A
7267 C such that linear systems with P1 or P2 are easier to solve than with
7268 C A. Preconditioning from the left only or right only means using
7269 C P2 = identity or P1 = identity, respectively.
7270 C In the case of the PCG and PCGS methods, there is only one
7271 C preconditioner matrix P (but it can be the product of more than one).
7272 C It should approximate the matrix A but allow for relatively
7273 C easy solution of linear systems with coefficient matrix P.
7274 C For PCG, P should be positive definite symmetric, or nearly so,
7275 C and for PCGS, the scaled preconditioner D-inverse * P * D
7276 C should be symmetric or nearly so.
7277 C If the Jacobian J = df/dy splits in a natural way into a sum
7278 C J = J1 + J2, then one possible choice of preconditioners is
7279 C P1 = identity - hl0 * J1 and P2 = identity - hl0 * J2
7280 C provided each of these is easy to solve (or approximately solve).
7281 C
7282 C-----------------------------------------------------------------------
7283 C References:
7284 C 1. Peter N. Brown and Alan C. Hindmarsh, Reduced Storage Matrix
7285 C Methods in Stiff ODE Systems, J. Appl. Math. & Comp., 31 (1989),
7286 C pp. 40-91; also L.L.N.L. Report UCRL-95088, Rev. 1, June 1987.
7287 C 2. Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE
7288 C Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.),
7289 C North-Holland, Amsterdam, 1983, pp. 55-64.
7290 C-----------------------------------------------------------------------
7291 C Authors: Alan C. Hindmarsh and Peter N. Brown
7292 C Center for Applied Scientific Computing, L-561
7293 C Lawrence Livermore National Laboratory
7294 C Livermore, CA 94551
7295 C-----------------------------------------------------------------------
7296 C Summary of Usage.
7297 C
7298 C Communication between the user and the DLSODPK package, for normal
7299 C situations, is summarized here. This summary describes only a subset
7300 C of the full set of options available. See the full description for
7301 C details, including optional communication, nonstandard options,
7302 C and instructions for special situations. See also the demonstration
7303 C program distributed with this solver.
7304 C
7305 C A. First provide a subroutine of the form:
7306 C SUBROUTINE F (NEQ, T, Y, YDOT)
7307 C DOUBLE PRECISION T, Y(*), YDOT(*)
7308 C which supplies the vector function f by loading YDOT(i) with f(i).
7309 C
7310 C B. Next determine (or guess) whether or not the problem is stiff.
7311 C Stiffness occurs when the Jacobian matrix df/dy has an eigenvalue
7312 C whose real part is negative and large in magnitude, compared to the
7313 C reciprocal of the t span of interest. If the problem is nonstiff,
7314 C use a method flag MF = 10. If it is stiff, MF should be between 21
7315 C and 24, or possibly 29. MF = 22 is generally the best choice.
7316 C Use 23 or 24 only if symmetry is present. Use MF = 29 if the
7317 C complete linear system solution is to be provided by the user.
7318 C The following four parameters must also be set.
7319 C IWORK(1) = LWP = length of real array WP for preconditioning.
7320 C IWORK(2) = LIWP = length of integer array IWP for preconditioning.
7321 C IWORK(3) = JPRE = preconditioner type flag:
7322 C = 0 for no preconditioning (P1 = P2 = P = identity)
7323 C = 1 for left-only preconditioning (P2 = identity)
7324 C = 2 for right-only preconditioning (P1 = identity)
7325 C = 3 for two-sided preconditioning (and PCG or PCGS)
7326 C IWORK(4) = JACFLG = flag for whether JAC is called.
7327 C = 0 if JAC is not to be called,
7328 C = 1 if JAC is to be called.
7329 C Use JACFLG = 1 if JAC computes any nonconstant data for use in
7330 C preconditioning, such as Jacobian elements.
7331 C The arrays WP and IWP are work arrays under the user's control,
7332 C for use in the routines that perform preconditioning operations.
7333 C
7334 C C. If the problem is stiff, you must supply two routines that deal
7335 C with the preconditioning of the linear systems to be solved.
7336 C These are as follows:
7337 C
7338 C SUBROUTINE JAC (F, NEQ, T, Y, YSV, REWT, FTY, V, HL0, WP,IWP, IER)
7339 C DOUBLE PRECISION T, Y(*),YSV(*), REWT(*), FTY(*), V(*), HL0, WP(*)
7340 C INTEGER IWP(*)
7341 C This routine must evaluate and preprocess any parts of the
7342 C Jacobian matrix df/dy involved in the preconditioners P1, P2, P.
7343 C The Y and FTY arrays contain the current values of y and f(t,y),
7344 C respectively, and YSV also contains the current value of y.
7345 C The array V is work space of length NEQ.
7346 C JAC must multiply all computed Jacobian elements by the scalar
7347 C -HL0, add the identity matrix, and do any factorization
7348 C operations called for, in preparation for solving linear systems
7349 C with a coefficient matrix of P1, P2, or P. The matrix P1*P2 or P
7350 C should be an approximation to identity - HL0 * (df/dy).
7351 C JAC should return IER = 0 if successful, and IER .ne. 0 if not.
7352 C (If IER .ne. 0, a smaller time step will be tried.)
7353 C
7354 C SUBROUTINE PSOL (NEQ, T, Y, FTY, WK, HL0, WP, IWP, B, LR, IER)
7355 C DOUBLE PRECISION T, Y(*), FTY(*), WK(*), HL0, WP(*), B(*)
7356 C INTEGER IWP(*)
7357 C This routine must solve a linear system with B as right-hand
7358 C side and one of the preconditioning matrices, P1, P2, or P, as
7359 C coefficient matrix, and return the solution vector in B.
7360 C LR is a flag concerning left vs right preconditioning, input
7361 C to PSOL. PSOL is to use P1 if LR = 1 and P2 if LR = 2.
7362 C In the case of the PCG or PCGS method, LR will be 3, and PSOL
7363 C should solve the system P*x = B with the preconditioner matrix P.
7364 C In the case MF = 29 (no Krylov iteration), LR will be 0,
7365 C and PSOL is to return in B the desired approximate solution
7366 C to A * x = B, where A = identity - HL0 * (df/dy).
7367 C PSOL can use data generated in the JAC routine and stored in
7368 C WP and IWP. WK is a work array of length NEQ.
7369 C The argument HL0 is the current value of the scalar appearing
7370 C in the linear system. If the old value, at the time of the last
7371 C JAC call, is needed, it must have been saved by JAC in WP.
7372 C On return, PSOL should set the error flag IER as follows:
7373 C IER = 0 if PSOL was successful,
7374 C IER .gt. 0 if a recoverable error occurred, meaning that the
7375 C time step will be retried,
7376 C IER .lt. 0 if an unrecoverable error occurred, meaning that the
7377 C solver is to stop immediately.
7378 C
7379 C D. Write a main program which calls Subroutine DLSODPK once for
7380 C each point at which answers are desired. This should also provide
7381 C for possible use of logical unit 6 for output of error messages by
7382 C DLSODPK. On the first call to DLSODPK, supply arguments as follows:
7383 C F = name of subroutine for right-hand side vector f.
7384 C This name must be declared External in calling program.
7385 C NEQ = number of first order ODEs.
7386 C Y = array of initial values, of length NEQ.
7387 C T = the initial value of the independent variable.
7388 C TOUT = first point where output is desired (.ne. T).
7389 C ITOL = 1 or 2 according as ATOL (below) is a scalar or array.
7390 C RTOL = relative tolerance parameter (scalar).
7391 C ATOL = absolute tolerance parameter (scalar or array).
7392 C the estimated local error in y(i) will be controlled so as
7393 C to be roughly less (in magnitude) than
7394 C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or
7395 C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2.
7396 C Thus the local error test passes if, in each component,
7397 C either the absolute error is less than ATOL (or ATOL(i)),
7398 C or the relative error is less than RTOL.
7399 C Use RTOL = 0.0 for pure absolute error control, and
7400 C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error
7401 C control. Caution: Actual (global) errors may exceed these
7402 C local tolerances, so choose them conservatively.
7403 C ITASK = 1 for normal computation of output values of y at t = TOUT.
7404 C ISTATE = integer flag (input and output). Set ISTATE = 1.
7405 C IOPT = 0 to indicate no optional inputs used.
7406 C RWORK = real work array of length at least:
7407 C 20 + 16*NEQ for MF = 10,
7408 C 45 + 17*NEQ + LWP for MF = 21,
7409 C 61 + 17*NEQ + LWP for MF = 22,
7410 C 20 + 15*NEQ + LWP for MF = 23 or 24,
7411 C 20 + 12*NEQ + LWP for MF = 29.
7412 C LRW = declared length of RWORK (in user's dimension).
7413 C IWORK = integer work array of length at least:
7414 C 30 for MF = 10,
7415 C 35 + LIWP for MF = 21,
7416 C 30 + LIWP for MF = 22, 23, 24, or 29.
7417 C LIW = declared length of IWORK (in user's dimension).
7418 C JAC,PSOL = names of subroutines for preconditioning.
7419 C These names must be declared External in the calling program.
7420 C MF = method flag. Standard values are:
7421 C 10 for nonstiff (Adams) method.
7422 C 21 for stiff (BDF) method, with preconditioned SIOM.
7423 C 22 for stiff method, with preconditioned GMRES method.
7424 C 23 for stiff method, with preconditioned CG method.
7425 C 24 for stiff method, with scaled preconditioned CG method.
7426 C 29 for stiff method, with user's PSOL routine only.
7427 C Note that the main program must declare arrays Y, RWORK, IWORK,
7428 C and possibly ATOL.
7429 C
7430 C E. The output from the first call (or any call) is:
7431 C Y = array of computed values of y(t) vector.
7432 C T = corresponding value of independent variable (normally TOUT).
7433 C ISTATE = 2 if DLSODPK was successful, negative otherwise.
7434 C -1 means excess work done on this call (perhaps wrong MF).
7435 C -2 means excess accuracy requested (tolerances too small).
7436 C -3 means illegal input detected (see printed message).
7437 C -4 means repeated error test failures (check all inputs).
7438 C -5 means repeated convergence failures (perhaps bad JAC
7439 C or PSOL routine supplied or wrong choice of MF or
7440 C tolerances, or this solver is inappropriate).
7441 C -6 means error weight became zero during problem. (Solution
7442 C component i vanished, and ATOL or ATOL(i) = 0.)
7443 C -7 means an unrecoverable error occurred in PSOL.
7444 C
7445 C F. To continue the integration after a successful return, simply
7446 C reset TOUT and call DLSODPK again. No other parameters need be reset.
7447 C
7448 C-----------------------------------------------------------------------
7449 C-----------------------------------------------------------------------
7450 C Full Description of User Interface to DLSODPK.
7451 C
7452 C The user interface to DLSODPK consists of the following parts.
7453 C
7454 C 1. The call sequence to Subroutine DLSODPK, which is a driver
7455 C routine for the solver. This includes descriptions of both
7456 C the call sequence arguments and of user-supplied routines.
7457 C Following these descriptions is a description of
7458 C optional inputs available through the call sequence, and then
7459 C a description of optional outputs (in the work arrays).
7460 C
7461 C 2. Descriptions of other routines in the DLSODPK package that may be
7462 C (optionally) called by the user. These provide the ability to
7463 C alter error message handling, save and restore the internal
7464 C Common, and obtain specified derivatives of the solution y(t).
7465 C
7466 C 3. Descriptions of Common blocks to be declared in overlay
7467 C or similar environments, or to be saved when doing an interrupt
7468 C of the problem and continued solution later.
7469 C
7470 C 4. Description of two routines in the DLSODPK package, either of
7471 C which the user may replace with his/her own version, if desired.
7472 C These relate to the measurement of errors.
7473 C
7474 C-----------------------------------------------------------------------
7475 C Part 1. Call Sequence.
7476 C
7477 C The call sequence parameters used for input only are
7478 C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, PSOL, MF,
7479 C and those used for both input and output are
7480 C Y, T, ISTATE.
7481 C The work arrays RWORK and IWORK are also used for conditional and
7482 C optional inputs and optional outputs. (The term output here refers
7483 C to the return from Subroutine DLSODPK to the user's calling program.)
7484 C
7485 C The legality of input parameters will be thoroughly checked on the
7486 C initial call for the problem, but not checked thereafter unless a
7487 C change in input parameters is flagged by ISTATE = 3 on input.
7488 C
7489 C The descriptions of the call arguments are as follows.
7490 C
7491 C F = the name of the user-supplied subroutine defining the
7492 C ODE system. The system must be put in the first-order
7493 C form dy/dt = f(t,y), where f is a vector-valued function
7494 C of the scalar t and the vector y. Subroutine F is to
7495 C compute the function f. It is to have the form
7496 C SUBROUTINE F (NEQ, T, Y, YDOT)
7497 C DOUBLE PRECISION T, Y(*), YDOT(*)
7498 C where NEQ, T, and Y are input, and the array YDOT = f(t,y)
7499 C is output. Y and YDOT are arrays of length NEQ.
7500 C Subroutine F should not alter Y(1),...,Y(NEQ).
7501 C F must be declared External in the calling program.
7502 C
7503 C Subroutine F may access user-defined quantities in
7504 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array
7505 C (dimensioned in F) and/or Y has length exceeding NEQ(1).
7506 C See the descriptions of NEQ and Y below.
7507 C
7508 C If quantities computed in the F routine are needed
7509 C externally to DLSODPK, an extra call to F should be made
7510 C for this purpose, for consistent and accurate results.
7511 C If only the derivative dy/dt is needed, use DINTDY instead.
7512 C
7513 C NEQ = the size of the ODE system (number of first order
7514 C ordinary differential equations). Used only for input.
7515 C NEQ may be decreased, but not increased, during the problem.
7516 C If NEQ is decreased (with ISTATE = 3 on input), the
7517 C remaining components of Y should be left undisturbed, if
7518 C these are to be accessed in the user-supplied subroutines.
7519 C
7520 C Normally, NEQ is a scalar, and it is generally referred to
7521 C as a scalar in this user interface description. However,
7522 C NEQ may be an array, with NEQ(1) set to the system size.
7523 C (The DLSODPK package accesses only NEQ(1).) In either case,
7524 C this parameter is passed as the NEQ argument in all calls
7525 C to F, JAC, and PSOL. Hence, if it is an array, locations
7526 C NEQ(2),... may be used to store other integer data and pass
7527 C it to the user-supplied subroutines. Each such routine must
7528 C include NEQ in a Dimension statement in that case.
7529 C
7530 C Y = a real array for the vector of dependent variables, of
7531 C length NEQ or more. Used for both input and output on the
7532 C first call (ISTATE = 1), and only for output on other calls.
7533 C On the first call, Y must contain the vector of initial
7534 C values. On output, Y contains the computed solution vector,
7535 C evaluated at T. If desired, the Y array may be used
7536 C for other purposes between calls to the solver.
7537 C
7538 C This array is passed as the Y argument in all calls to F,
7539 C JAC, and PSOL. Hence its length may exceed NEQ, and locations
7540 C Y(NEQ+1),... may be used to store other real data and
7541 C pass it to the user-supplied subroutines. (The DLSODPK
7542 C package accesses only Y(1),...,Y(NEQ).)
7543 C
7544 C T = the independent variable. On input, T is used only on the
7545 C first call, as the initial point of the integration.
7546 C On output, after each call, T is the value at which a
7547 C computed solution y is evaluated (usually the same as TOUT).
7548 C On an error return, T is the farthest point reached.
7549 C
7550 C TOUT = the next value of t at which a computed solution is desired.
7551 C Used only for input.
7552 C
7553 C When starting the problem (ISTATE = 1), TOUT may be equal
7554 C to T for one call, then should .ne. T for the next call.
7555 C For the initial T, an input value of TOUT .ne. T is used
7556 C in order to determine the direction of the integration
7557 C (i.e. the algebraic sign of the step sizes) and the rough
7558 C scale of the problem. Integration in either direction
7559 C (forward or backward in t) is permitted.
7560 C
7561 C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after
7562 C the first call (i.e. the first call with TOUT .ne. T).
7563 C Otherwise, TOUT is required on every call.
7564 C
7565 C If ITASK = 1, 3, or 4, the values of TOUT need not be
7566 C monotone, but a value of TOUT which backs up is limited
7567 C to the current internal T interval, whose endpoints are
7568 C TCUR - HU and TCUR (see optional outputs, below, for
7569 C TCUR and HU).
7570 C
7571 C ITOL = an indicator for the type of error control. See
7572 C description below under ATOL. Used only for input.
7573 C
7574 C RTOL = a relative error tolerance parameter, either a scalar or
7575 C an array of length NEQ. See description below under ATOL.
7576 C Input only.
7577 C
7578 C ATOL = an absolute error tolerance parameter, either a scalar or
7579 C an array of length NEQ. Input only.
7580 C
7581 C The input parameters ITOL, RTOL, and ATOL determine
7582 C the error control performed by the solver. The solver will
7583 C control the vector E = (E(i)) of estimated local errors
7584 C in y, according to an inequality of the form
7585 C RMS-norm of ( E(i)/EWT(i) ) .le. 1,
7586 C where EWT(i) = RTOL(i)*ABS(Y(i)) + ATOL(i),
7587 C and the RMS-norm (root-mean-square norm) here is
7588 C RMS-norm(v) = SQRT(sum v(i)**2 / NEQ). Here EWT = (EWT(i))
7589 C is a vector of weights which must always be positive, and
7590 C the values of RTOL and ATOL should all be non-negative.
7591 C the following table gives the types (scalar/array) of
7592 C RTOL and ATOL, and the corresponding form of EWT(i).
7593 C
7594 C ITOL RTOL ATOL EWT(i)
7595 C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL
7596 C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i)
7597 C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL
7598 C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i)
7599 C
7600 C When either of these parameters is a scalar, it need not
7601 C be dimensioned in the user's calling program.
7602 C
7603 C If none of the above choices (with ITOL, RTOL, and ATOL
7604 C fixed throughout the problem) is suitable, more general
7605 C error controls can be obtained by substituting
7606 C user-supplied routines for the setting of EWT and/or for
7607 C the norm calculation. See Part 4 below.
7608 C
7609 C If global errors are to be estimated by making a repeated
7610 C run on the same problem with smaller tolerances, then all
7611 C components of RTOL and ATOL (i.e. of EWT) should be scaled
7612 C down uniformly.
7613 C
7614 C ITASK = an index specifying the task to be performed.
7615 C Input only. ITASK has the following values and meanings.
7616 C 1 means normal computation of output values of y(t) at
7617 C t = TOUT (by overshooting and interpolating).
7618 C 2 means take one step only and return.
7619 C 3 means stop at the first internal mesh point at or
7620 C beyond t = TOUT and return.
7621 C 4 means normal computation of output values of y(t) at
7622 C t = TOUT but without overshooting t = TCRIT.
7623 C TCRIT must be input as RWORK(1). TCRIT may be equal to
7624 C or beyond TOUT, but not behind it in the direction of
7625 C integration. This option is useful if the problem
7626 C has a singularity at or beyond t = TCRIT.
7627 C 5 means take one step, without passing TCRIT, and return.
7628 C TCRIT must be input as RWORK(1).
7629 C
7630 C Note: If ITASK = 4 or 5 and the solver reaches TCRIT
7631 C (within roundoff), it will return T = TCRIT (exactly) to
7632 C indicate this (unless ITASK = 4 and TOUT comes before TCRIT,
7633 C in which case answers at t = TOUT are returned first).
7634 C
7635 C ISTATE = an index used for input and output to specify the
7636 C the state of the calculation.
7637 C
7638 C On input, the values of ISTATE are as follows.
7639 C 1 means this is the first call for the problem
7640 C (initializations will be done). See note below.
7641 C 2 means this is not the first call, and the calculation
7642 C is to continue normally, with no change in any input
7643 C parameters except possibly TOUT and ITASK.
7644 C (If ITOL, RTOL, and/or ATOL are changed between calls
7645 C with ISTATE = 2, the new values will be used but not
7646 C tested for legality.)
7647 C 3 means this is not the first call, and the
7648 C calculation is to continue normally, but with
7649 C a change in input parameters other than
7650 C TOUT and ITASK. Changes are allowed in
7651 C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF,
7652 C and any of the optional inputs except H0.
7653 C Note: A preliminary call with TOUT = T is not counted
7654 C as a first call here, as no initialization or checking of
7655 C input is done. (Such a call is sometimes useful for the
7656 C purpose of outputting the initial conditions.)
7657 C Thus the first call for which TOUT .ne. T requires
7658 C ISTATE = 1 on input.
7659 C
7660 C On output, ISTATE has the following values and meanings.
7661 C 1 means nothing was done; TOUT = T and ISTATE = 1 on input.
7662 C 2 means the integration was performed successfully.
7663 C -1 means an excessive amount of work (more than MXSTEP
7664 C steps) was done on this call, before completing the
7665 C requested task, but the integration was otherwise
7666 C successful as far as T. (MXSTEP is an optional input
7667 C and is normally 500.) To continue, the user may
7668 C simply reset ISTATE to a value .gt. 1 and call again
7669 C (the excess work step counter will be reset to 0).
7670 C In addition, the user may increase MXSTEP to avoid
7671 C this error return (see below on optional inputs).
7672 C -2 means too much accuracy was requested for the precision
7673 C of the machine being used. This was detected before
7674 C completing the requested task, but the integration
7675 C was successful as far as T. To continue, the tolerance
7676 C parameters must be reset, and ISTATE must be set
7677 C to 3. The optional output TOLSF may be used for this
7678 C purpose. (Note: If this condition is detected before
7679 C taking any steps, then an illegal input return
7680 C (ISTATE = -3) occurs instead.)
7681 C -3 means illegal input was detected, before taking any
7682 C integration steps. See written message for details.
7683 C Note: If the solver detects an infinite loop of calls
7684 C to the solver with illegal input, it will cause
7685 C the run to stop.
7686 C -4 means there were repeated error test failures on
7687 C one attempted step, before completing the requested
7688 C task, but the integration was successful as far as T.
7689 C The problem may have a singularity, or the input
7690 C may be inappropriate.
7691 C -5 means there were repeated convergence test failures on
7692 C one attempted step, before completing the requested
7693 C task, but the integration was successful as far as T.
7694 C -6 means EWT(i) became zero for some i during the
7695 C integration. Pure relative error control (ATOL(i)=0.0)
7696 C was requested on a variable which has now vanished.
7697 C The integration was successful as far as T.
7698 C -7 means the PSOL routine returned an unrecoverable error
7699 C flag (IER .lt. 0). The integration was successful as
7700 C far as T.
7701 C
7702 C Note: since the normal output value of ISTATE is 2,
7703 C it does not need to be reset for normal continuation.
7704 C Also, since a negative input value of ISTATE will be
7705 C regarded as illegal, a negative output value requires the
7706 C user to change it, and possibly other inputs, before
7707 C calling the solver again.
7708 C
7709 C IOPT = an integer flag to specify whether or not any optional
7710 C inputs are being used on this call. Input only.
7711 C The optional inputs are listed separately below.
7712 C IOPT = 0 means no optional inputs are being used.
7713 C Default values will be used in all cases.
7714 C IOPT = 1 means one or more optional inputs are being used.
7715 C
7716 C RWORK = a real working array (double precision).
7717 C The length of RWORK must be at least
7718 C 20 + NYH*(MAXORD + 1) + 3*NEQ + LENLS + LWP where
7719 C NYH = the initial value of NEQ,
7720 C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a
7721 C smaller value is given as an optional input),
7722 C LENLS = length of work space for linear system (Krylov)
7723 C method, excluding preconditioning:
7724 C LENLS = 0 if MITER = 0,
7725 C LENLS = NEQ*(MAXL+3) + MAXL**2 if MITER = 1,
7726 C LENLS = NEQ*(MAXL+3+MIN(1,MAXL-KMP))
7727 C + (MAXL+3)*MAXL + 1 if MITER = 2,
7728 C LENLS = 6*NEQ if MITER = 3 or 4,
7729 C LENLS = 3*NEQ if MITER = 9.
7730 C (See the MF description for METH and MITER, and the
7731 C list of optional inputs for MAXL and KMP.)
7732 C LWP = length of real user work space for preconditioning
7733 C (see JAC/PSOL).
7734 C Thus if default values are used and NEQ is constant,
7735 C this length is:
7736 C 20 + 16*NEQ for MF = 10,
7737 C 45 + 24*NEQ + LWP FOR MF = 11,
7738 C 61 + 24*NEQ + LWP FOR MF = 12,
7739 C 20 + 22*NEQ + LWP FOR MF = 13 OR 14,
7740 C 20 + 19*NEQ + LWP FOR MF = 19,
7741 C 20 + 9*NEQ FOR MF = 20,
7742 C 45 + 17*NEQ + LWP FOR MF = 21,
7743 C 61 + 17*NEQ + LWP FOR MF = 22,
7744 C 20 + 15*NEQ + LWP FOR MF = 23 OR 24,
7745 C 20 + 12*NEQ + LWP for MF = 29.
7746 C The first 20 words of RWORK are reserved for conditional
7747 C and optional inputs and optional outputs.
7748 C
7749 C The following word in RWORK is a conditional input:
7750 C RWORK(1) = TCRIT = critical value of t which the solver
7751 C is not to overshoot. Required if ITASK is
7752 C 4 or 5, and ignored otherwise. (See ITASK.)
7753 C
7754 C LRW = the length of the array RWORK, as declared by the user.
7755 C (This will be checked by the solver.)
7756 C
7757 C IWORK = an integer work array. The length of IWORK must be at least
7758 C 30 if MITER = 0 (MF = 10 or 20),
7759 C 30 + MAXL + LIWP if MITER = 1 (MF = 11, 21),
7760 C 30 + LIWP if MITER = 2, 3, 4, or 9.
7761 C MAXL = 5 unless a different optional input value is given.
7762 C LIWP = length of integer user work space for preconditioning
7763 C (see conditional input list following).
7764 C The first few words of IWORK are used for conditional and
7765 C optional inputs and optional outputs.
7766 C
7767 C The following 4 words in IWORK are conditional inputs,
7768 C required if MITER .ge. 1:
7769 C IWORK(1) = LWP = length of real array WP for use in
7770 C preconditioning (part of RWORK array).
7771 C IWORK(2) = LIWP = length of integer array IWP for use in
7772 C preconditioning (part of IWORK array).
7773 C The arrays WP and IWP are work arrays under the
7774 C user's control, for use in the routines that
7775 C perform preconditioning operations (JAC and PSOL).
7776 C IWORK(3) = JPRE = preconditioner type flag:
7777 C = 0 for no preconditioning (P1 = P2 = P = identity)
7778 C = 1 for left-only preconditioning (P2 = identity)
7779 C = 2 for right-only preconditioning (P1 = identity)
7780 C = 3 for two-sided preconditioning (and PCG or PCGS)
7781 C IWORK(4) = JACFLG = flag for whether JAC is called.
7782 C = 0 if JAC is not to be called,
7783 C = 1 if JAC is to be called.
7784 C Use JACFLG = 1 if JAC computes any nonconstant
7785 C data needed in preconditioning operations,
7786 C such as some of the Jacobian elements.
7787 C
7788 C LIW = the length of the array IWORK, as declared by the user.
7789 C (This will be checked by the solver.)
7790 C
7791 C Note: The work arrays must not be altered between calls to DLSODPK
7792 C for the same problem, except possibly for the conditional and
7793 C optional inputs, and except for the last 3*NEQ words of RWORK.
7794 C The latter space is used for internal scratch space, and so is
7795 C available for use by the user outside DLSODPK between calls, if
7796 C desired (but not for use by any of the user-supplied subroutines).
7797 C
7798 C JAC = the name of the user-supplied routine to compute any
7799 C Jacobian elements (or approximations) involved in the
7800 C matrix preconditioning operations (MITER .ge. 1).
7801 C It is to have the form
7802 C SUBROUTINE JAC (F, NEQ, T, Y, YSV, REWT, FTY, V,
7803 C 1 HL0, WP, IWP, IER)
7804 C DOUBLE PRECISION T, Y(*),YSV(*), REWT(*), FTY(*), V(*),
7805 C 1 HL0, WP(*)
7806 C INTEGER IWP(*)
7807 C This routine must evaluate and preprocess any parts of the
7808 C Jacobian matrix df/dy used in the preconditioners P1, P2, P.
7809 C the Y and FTY arrays contain the current values of y and
7810 C f(t,y), respectively, and YSV also contains the current
7811 C value of y. The array V is work space of length
7812 C NEQ for use by JAC. REWT is the array of reciprocal error
7813 C weights (1/EWT). JAC must multiply all computed Jacobian
7814 C elements by the scalar -HL0, add the identity matrix, and do
7815 C any factorization operations called for, in preparation
7816 C for solving linear systems with a coefficient matrix of
7817 C P1, P2, or P. The matrix P1*P2 or P should be an
7818 C approximation to identity - HL0 * (df/dy). JAC should
7819 C return IER = 0 if successful, and IER .ne. 0 if not.
7820 C (If IER .ne. 0, a smaller time step will be tried.)
7821 C The arrays WP (of length LWP) and IWP (of length LIWP)
7822 C are for use by JAC and PSOL for work space and for storage
7823 C of data needed for the solution of the preconditioner
7824 C linear systems. Their lengths and contents are under the
7825 C user's control.
7826 C The JAC routine may save relevant Jacobian elements (or
7827 C approximations) used in the preconditioners, along with the
7828 C value of HL0, and use these to reconstruct preconditioner
7829 C matrices later without reevaluationg those elements.
7830 C This may be cost-effective if JAC is called with HL0
7831 C considerably different from its earlier value, indicating
7832 C that a corrector convergence failure has occurred because
7833 C of the change in HL0, not because of changes in the
7834 C value of the Jacobian. In doing this, use the saved and
7835 C current values of HL0 to decide whether to use saved
7836 C or reevaluated elements.
7837 C JAC may alter V, but may not alter Y, YSV, REWT, FTY, or HL0.
7838 C JAC must be declared External in the calling program.
7839 C Subroutine JAC may access user-defined quantities in
7840 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array
7841 C (dimensioned in JAC) and/or Y has length exceeding NEQ(1).
7842 C See the descriptions of NEQ and Y above.
7843 C
7844 C PSOL = the name of the user-supplied routine for the
7845 C solution of preconditioner linear systems.
7846 C It is to have the form
7847 C SUBROUTINE PSOL (NEQ, T, Y, FTY, WK,HL0, WP,IWP, B, LR,IER)
7848 C DOUBLE PRECISION T, Y(*), FTY(*), WK(*), HL0, WP(*), B(*)
7849 C INTEGER IWP(*)
7850 C This routine must solve a linear system with B as right-hand
7851 C side and one of the preconditioning matrices, P1, P2, or P,
7852 C as coefficient matrix, and return the solution vector in B.
7853 C LR is a flag concerning left vs right preconditioning, input
7854 C to PSOL. PSOL is to use P1 if LR = 1 and P2 if LR = 2.
7855 C In the case of the PCG or PCGS method, LR will be 3, and PSOL
7856 C should solve the system P*x = B with the preconditioner P.
7857 C In the case MITER = 9 (no Krylov iteration), LR will be 0,
7858 C and PSOL is to return in B the desired approximate solution
7859 C to A * x = B, where A = identity - HL0 * (df/dy).
7860 C PSOL can use data generated in the JAC routine and stored in
7861 C WP and IWP.
7862 C The Y and FTY arrays contain the current values of y and
7863 C f(t,y), respectively. The array WK is work space of length
7864 C NEQ for use by PSOL.
7865 C The argument HL0 is the current value of the scalar appearing
7866 C in the linear system. If the old value, as of the last
7867 C JAC call, is needed, it must have been saved by JAC in WP.
7868 C On return, PSOL should set the error flag IER as follows:
7869 C IER = 0 if PSOL was successful,
7870 C IER .gt. 0 on a recoverable error, meaning that the
7871 C time step will be retried,
7872 C IER .lt. 0 on an unrecoverable error, meaning that the
7873 C solver is to stop immediately.
7874 C PSOL may not alter Y, FTY, or HL0.
7875 C PSOL must be declared External in the calling program.
7876 C Subroutine PSOL may access user-defined quantities in
7877 C NEQ(2),... and Y(NEQ(1)+1),... if NEQ is an array
7878 C (dimensioned in PSOL) and/or Y has length exceeding NEQ(1).
7879 C See the descriptions of NEQ and Y above.
7880 C
7881 C MF = the method flag. Used only for input. The legal values of
7882 C MF are 10, 11, 12, 13, 14, 19, 20, 21, 22, 23, 24, and 29.
7883 C MF has decimal digits METH and MITER: MF = 10*METH + MITER.
7884 C METH indicates the basic linear multistep method:
7885 C METH = 1 means the implicit Adams method.
7886 C METH = 2 means the method based on Backward
7887 C Differentiation Formulas (BDFs).
7888 C MITER indicates the corrector iteration method:
7889 C MITER = 0 means functional iteration (no linear system
7890 C is involved).
7891 C MITER = 1 means Newton iteration with Scaled Preconditioned
7892 C Incomplete Orthogonalization Method (SPIOM)
7893 C for the linear systems.
7894 C MITER = 2 means Newton iteration with Scaled Preconditioned
7895 C Generalized Minimal Residual method (SPIGMR)
7896 C for the linear systems.
7897 C MITER = 3 means Newton iteration with Preconditioned
7898 C Conjugate Gradient method (PCG)
7899 C for the linear systems.
7900 C MITER = 4 means Newton iteration with scaled Preconditioned
7901 C Conjugate Gradient method (PCGS)
7902 C for the linear systems.
7903 C MITER = 9 means Newton iteration with only the
7904 C user-supplied PSOL routine called (no Krylov
7905 C iteration) for the linear systems.
7906 C JPRE is ignored, and PSOL is called with LR = 0.
7907 C See comments in the introduction about the choice of MITER.
7908 C If MITER .ge. 1, the user must supply routines JAC and PSOL
7909 C (the names are arbitrary) as described above.
7910 C For MITER = 0, dummy arguments can be used.
7911 C-----------------------------------------------------------------------
7912 C Optional Inputs.
7913 C
7914 C The following is a list of the optional inputs provided for in the
7915 C call sequence. (See also Part 2.) For each such input variable,
7916 C this table lists its name as used in this documentation, its
7917 C location in the call sequence, its meaning, and the default value.
7918 C The use of any of these inputs requires IOPT = 1, and in that
7919 C case all of these inputs are examined. A value of zero for any
7920 C of these optional inputs will cause the default value to be used.
7921 C Thus to use a subset of the optional inputs, simply preload
7922 C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and
7923 C then set those of interest to nonzero values.
7924 C
7925 C Name Location Meaning and Default Value
7926 C
7927 C H0 RWORK(5) the step size to be attempted on the first step.
7928 C The default value is determined by the solver.
7929 C
7930 C HMAX RWORK(6) the maximum absolute step size allowed.
7931 C The default value is infinite.
7932 C
7933 C HMIN RWORK(7) the minimum absolute step size allowed.
7934 C The default value is 0. (This lower bound is not
7935 C enforced on the final step before reaching TCRIT
7936 C when ITASK = 4 or 5.)
7937 C
7938 C DELT RWORK(8) convergence test constant in Krylov iteration
7939 C algorithm. The default is .05.
7940 C
7941 C MAXORD IWORK(5) the maximum order to be allowed. The default
7942 C value is 12 if METH = 1, and 5 if METH = 2.
7943 C If MAXORD exceeds the default value, it will
7944 C be reduced to the default value.
7945 C If MAXORD is changed during the problem, it may
7946 C cause the current order to be reduced.
7947 C
7948 C MXSTEP IWORK(6) maximum number of (internally defined) steps
7949 C allowed during one call to the solver.
7950 C The default value is 500.
7951 C
7952 C MXHNIL IWORK(7) maximum number of messages printed (per problem)
7953 C warning that T + H = T on a step (H = step size).
7954 C This must be positive to result in a non-default
7955 C value. The default value is 10.
7956 C
7957 C MAXL IWORK(8) maximum number of iterations in the SPIOM, SPIGMR,
7958 C PCG, or PCGS algorithm (.le. NEQ).
7959 C The default is MAXL = MIN(5,NEQ).
7960 C
7961 C KMP IWORK(9) number of vectors on which orthogonalization
7962 C is done in SPIOM or SPIGMR algorithm (.le. MAXL).
7963 C The default is KMP = MAXL.
7964 C Note: When KMP .lt. MAXL and MF = 22, the length
7965 C of RWORK must be defined accordingly. See
7966 C the definition of RWORK above.
7967 C-----------------------------------------------------------------------
7968 C Optional Outputs.
7969 C
7970 C As optional additional output from DLSODPK, the variables listed
7971 C below are quantities related to the performance of DLSODPK
7972 C which are available to the user. These are communicated by way of
7973 C the work arrays, but also have internal mnemonic names as shown.
7974 C Except where stated otherwise, all of these outputs are defined
7975 C on any successful return from DLSODPK, and on any return with
7976 C ISTATE = -1, -2, -4, -5, -6, or -7. On an illegal input return
7977 C (ISTATE = -3), they will be unchanged from their existing values
7978 C (if any), except possibly for TOLSF, LENRW, and LENIW.
7979 C On any error return, outputs relevant to the error will be defined,
7980 C as noted below.
7981 C
7982 C Name Location Meaning
7983 C
7984 C HU RWORK(11) the step size in t last used (successfully).
7985 C
7986 C HCUR RWORK(12) the step size to be attempted on the next step.
7987 C
7988 C TCUR RWORK(13) the current value of the independent variable
7989 C which the solver has actually reached, i.e. the
7990 C current internal mesh point in t. On output, TCUR
7991 C will always be at least as far as the argument
7992 C T, but may be farther (if interpolation was done).
7993 C
7994 C TOLSF RWORK(14) a tolerance scale factor, greater than 1.0,
7995 C computed when a request for too much accuracy was
7996 C detected (ISTATE = -3 if detected at the start of
7997 C the problem, ISTATE = -2 otherwise). If ITOL is
7998 C left unaltered but RTOL and ATOL are uniformly
7999 C scaled up by a factor of TOLSF for the next call,
8000 C then the solver is deemed likely to succeed.
8001 C (The user may also ignore TOLSF and alter the
8002 C tolerance parameters in any other way appropriate.)
8003 C
8004 C NST IWORK(11) the number of steps taken for the problem so far.
8005 C
8006 C NFE IWORK(12) the number of f evaluations for the problem so far.
8007 C
8008 C NPE IWORK(13) the number of calls to JAC so far (for Jacobian
8009 C evaluation associated with preconditioning).
8010 C
8011 C NQU IWORK(14) the method order last used (successfully).
8012 C
8013 C NQCUR IWORK(15) the order to be attempted on the next step.
8014 C
8015 C IMXER IWORK(16) the index of the component of largest magnitude in
8016 C the weighted local error vector ( E(i)/EWT(i) ),
8017 C on an error return with ISTATE = -4 or -5.
8018 C
8019 C LENRW IWORK(17) the length of RWORK actually required.
8020 C This is defined on normal returns and on an illegal
8021 C input return for insufficient storage.
8022 C
8023 C LENIW IWORK(18) the length of IWORK actually required.
8024 C This is defined on normal returns and on an illegal
8025 C input return for insufficient storage.
8026 C
8027 C NNI IWORK(19) number of nonlinear iterations so far (each of
8028 C which calls an iterative linear solver).
8029 C
8030 C NLI IWORK(20) number of linear iterations so far.
8031 C Note: A measure of the success of algorithm is
8032 C the average number of linear iterations per
8033 C nonlinear iteration, given by NLI/NNI.
8034 C If this is close to MAXL, MAXL may be too small.
8035 C
8036 C NPS IWORK(21) number of preconditioning solve operations
8037 C (PSOL calls) so far.
8038 C
8039 C NCFN IWORK(22) number of convergence failures of the nonlinear
8040 C (Newton) iteration so far.
8041 C Note: A measure of success is the overall
8042 C rate of nonlinear convergence failures, NCFN/NST.
8043 C
8044 C NCFL IWORK(23) number of convergence failures of the linear
8045 C iteration so far.
8046 C Note: A measure of success is the overall
8047 C rate of linear convergence failures, NCFL/NNI.
8048 C
8049 C The following two arrays are segments of the RWORK array which
8050 C may also be of interest to the user as optional outputs.
8051 C For each array, the table below gives its internal name,
8052 C its base address in RWORK, and its description.
8053 C
8054 C Name Base Address Description
8055 C
8056 C YH 21 the Nordsieck history array, of size NYH by
8057 C (NQCUR + 1), where NYH is the initial value
8058 C of NEQ. For j = 0,1,...,NQCUR, column j+1
8059 C of YH contains HCUR**j/factorial(j) times
8060 C the j-th derivative of the interpolating
8061 C polynomial currently representing the solution,
8062 C evaluated at t = TCUR.
8063 C
8064 C ACOR LENRW-NEQ+1 array of size NEQ used for the accumulated
8065 C corrections on each step, scaled on output
8066 C to represent the estimated local error in y
8067 C on the last step. This is the vector E in
8068 C the description of the error control. It is
8069 C defined only on a successful return from
8070 C DLSODPK.
8071 C
8072 C-----------------------------------------------------------------------
8073 C Part 2. Other Routines Callable.
8074 C
8075 C The following are optional calls which the user may make to
8076 C gain additional capabilities in conjunction with DLSODPK.
8077 C (The routines XSETUN and XSETF are designed to conform to the
8078 C SLATEC error handling package.)
8079 C
8080 C Form of Call Function
8081 C CALL XSETUN(LUN) Set the logical unit number, LUN, for
8082 C output of messages from DLSODPK, if
8083 C the default is not desired.
8084 C The default value of lun is 6.
8085 C
8086 C CALL XSETF(MFLAG) Set a flag to control the printing of
8087 C messages by DLSODPK.
8088 C MFLAG = 0 means do not print. (Danger:
8089 C This risks losing valuable information.)
8090 C MFLAG = 1 means print (the default).
8091 C
8092 C Either of the above calls may be made at
8093 C any time and will take effect immediately.
8094 C
8095 C CALL DSRCPK(RSAV,ISAV,JOB) saves and restores the contents of
8096 C the internal Common blocks used by
8097 C DLSODPK (see Part 3 below).
8098 C RSAV must be a real array of length 222
8099 C or more, and ISAV must be an integer
8100 C array of length 50 or more.
8101 C JOB=1 means save Common into RSAV/ISAV.
8102 C JOB=2 means restore Common from RSAV/ISAV.
8103 C DSRCPK is useful if one is
8104 C interrupting a run and restarting
8105 C later, or alternating between two or
8106 C more problems solved with DLSODPK.
8107 C
8108 C CALL DINTDY(,,,,,) Provide derivatives of y, of various
8109 C (See below) orders, at a specified point t, if
8110 C desired. It may be called only after
8111 C a successful return from DLSODPK.
8112 C
8113 C The detailed instructions for using DINTDY are as follows.
8114 C The form of the call is:
8115 C
8116 C CALL DINTDY (T, K, RWORK(21), NYH, DKY, IFLAG)
8117 C
8118 C The input parameters are:
8119 C
8120 C T = value of independent variable where answers are desired
8121 C (normally the same as the T last returned by DLSODPK).
8122 C for valid results, T must lie between TCUR - HU and TCUR.
8123 C (See optional outputs for TCUR and HU.)
8124 C K = integer order of the derivative desired. K must satisfy
8125 C 0 .le. K .le. NQCUR, where NQCUR is the current order
8126 C (see optional outputs). The capability corresponding
8127 C to K = 0, i.e. computing y(T), is already provided
8128 C by DLSODPK directly. Since NQCUR .ge. 1, the first
8129 C derivative dy/dt is always available with DINTDY.
8130 C RWORK(21) = the base address of the history array YH.
8131 C NYH = column length of YH, equal to the initial value of NEQ.
8132 C
8133 C The output parameters are:
8134 C
8135 C DKY = a real array of length NEQ containing the computed value
8136 C of the K-th derivative of y(t).
8137 C IFLAG = integer flag, returned as 0 if K and T were legal,
8138 C -1 if K was illegal, and -2 if T was illegal.
8139 C On an error return, a message is also written.
8140 C-----------------------------------------------------------------------
8141 C Part 3. Common Blocks.
8142 C
8143 C If DLSODPK is to be used in an overlay situation, the user
8144 C must declare, in the primary overlay, the variables in:
8145 C (1) the call sequence to DLSODPK, and
8146 C (2) the two internal Common blocks
8147 C /DLS001/ of length 255 (218 double precision words
8148 C followed by 37 integer words),
8149 C /DLPK01/ of length 17 (4 double precision words
8150 C followed by 13 integer words).
8151 C
8152 C If DLSODPK is used on a system in which the contents of internal
8153 C Common blocks are not preserved between calls, the user should
8154 C declare the above Common blocks in the calling program to insure
8155 C that their contents are preserved.
8156 C
8157 C If the solution of a given problem by DLSODPK is to be interrupted
8158 C and then later continued, such as when restarting an interrupted run
8159 C or alternating between two or more problems, the user should save,
8160 C following the return from the last DLSODPK call prior to the
8161 C interruption, the contents of the call sequence variables and the
8162 C internal Common blocks, and later restore these values before the
8163 C next DLSODPK call for that problem. To save and restore the Common
8164 C blocks, use Subroutine DSRCPK (see Part 2 above).
8165 C
8166 C-----------------------------------------------------------------------
8167 C Part 4. Optionally Replaceable Solver Routines.
8168 C
8169 C below are descriptions of two routines in the DLSODPK package which
8170 C relate to the measurement of errors. Either routine can be
8171 C replaced by a user-supplied version, if desired. However, since such
8172 C a replacement may have a major impact on performance, it should be
8173 C done only when absolutely necessary, and only with great caution.
8174 C (Note: The means by which the package version of a routine is
8175 C superseded by the user's version may be system-dependent.)
8176 C
8177 C (a) DEWSET.
8178 C The following subroutine is called just before each internal
8179 C integration step, and sets the array of error weights, EWT, as
8180 C described under ITOL/RTOL/ATOL above:
8181 C SUBROUTINE DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT)
8182 C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODPK call sequence,
8183 C YCUR contains the current dependent variable vector, and
8184 C EWT is the array of weights set by DEWSET.
8185 C
8186 C If the user supplies this subroutine, it must return in EWT(i)
8187 C (i = 1,...,NEQ) a positive quantity suitable for comparing errors
8188 C in y(i) to. The EWT array returned by DEWSET is passed to the DVNORM
8189 C routine (see below), and also used by DLSODPK in the computation
8190 C of the optional output IMXER, the diagonal Jacobian approximation,
8191 C and the increments for difference quotient Jacobians.
8192 C
8193 C In the user-supplied version of DEWSET, it may be desirable to use
8194 C the current values of derivatives of y. Derivatives up to order NQ
8195 C are available from the history array YH, described above under
8196 C optional outputs. In DEWSET, YH is identical to the YCUR array,
8197 C extended to NQ + 1 columns with a column length of NYH and scale
8198 C factors of H**j/factorial(j). On the first call for the problem,
8199 C given by NST = 0, NQ is 1 and H is temporarily set to 1.0.
8200 C NYH is the initial value of NEQ. The quantities NQ, H, and NST
8201 C can be obtained by including in DEWSET the statements:
8202 C DOUBLE PRECISION RLS
8203 C COMMON /DLS001/ RLS(218),ILS(37)
8204 C NQ = ILS(33)
8205 C NST = ILS(34)
8206 C H = RLS(212)
8207 C Thus, for example, the current value of dy/dt can be obtained as
8208 C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is
8209 C unnecessary when NST = 0).
8210 C
8211 C (b) DVNORM.
8212 C The following is a real function routine which computes the weighted
8213 C root-mean-square norm of a vector v:
8214 C D = DVNORM (N, V, W)
8215 C where:
8216 C N = the length of the vector,
8217 C V = real array of length N containing the vector,
8218 C W = real array of length N containing weights,
8219 C D = SQRT( (1/N) * sum(V(i)*W(i))**2 ).
8220 C DVNORM is called with N = NEQ and with W(i) = 1.0/EWT(i), where
8221 C EWT is as set by Subroutine DEWSET.
8222 C
8223 C If the user supplies this function, it should return a non-negative
8224 C value of DVNORM suitable for use in the error control in DLSODPK.
8225 C None of the arguments should be altered by DVNORM.
8226 C For example, a user-supplied DVNORM routine might:
8227 C -substitute a max-norm of (V(i)*W(i)) for the RMS-norm, or
8228 C -ignore some components of V in the norm, with the effect of
8229 C suppressing the error control on those components of y.
8230 C-----------------------------------------------------------------------
8231 C
8232 C***REVISION HISTORY (YYYYMMDD)
8233 C 19860901 DATE WRITTEN
8234 C 19861010 Numerous minor revisions to SPIOM and SPGMR routines;
8235 C minor corrections to prologues and comments.
8236 C 19870114 Changed name SPGMR to SPIGMR; revised residual norm
8237 C calculation in SPIGMR (for incomplete case);
8238 C revised error return logic in SPIGMR;
8239 C 19870330 Major update: corrected comments throughout;
8240 C removed TRET from Common; rewrote EWSET with 4 loops;
8241 C fixed t test in INTDY; added Cray directives in STODPK;
8242 C in STODPK, fixed DELP init. and logic around PJAC call;
8243 C combined routines to save/restore Common;
8244 C passed LEVEL = 0 in error message calls (except run abort).
8245 C 19871130 Added option MITER = 9; shortened WM array by 2;
8246 C revised early return from SPIOM and SPIGMR;
8247 C replaced copy loops with SCOPY/DCOPY calls;
8248 C minor corrections/revisions to SOLPK, SPIGMR, ATV, ATP;
8249 C corrections to main prologue and internal comments.
8250 C 19880304 Corrections to type declarations in SOLPK, SPIOM, USOL.
8251 C 19891025 Added ISTATE = -7 return; minor revisions to USOL;
8252 C added initialization of JACFLG in main driver;
8253 C removed YH and NYH from PKSET call list;
8254 C minor revisions to SPIOM and SPIGMR;
8255 C corrections to main prologue and internal comments.
8256 C 19900803 Added YSV to JAC call list; minor comment corrections.
8257 C 20010425 Major update: convert source lines to upper case;
8258 C added *DECK lines; changed from 1 to * in dummy dimensions;
8259 C changed names R1MACH/D1MACH to RUMACH/DUMACH;
8260 C renamed routines for uniqueness across single/double prec.;
8261 C converted intrinsic names to generic form;
8262 C removed ILLIN and NTREP (data loaded) from Common;
8263 C removed all 'own' variables from Common;
8264 C changed error messages to quoted strings;
8265 C replaced XERRWV/XERRWD with 1993 revised version;
8266 C converted prologues, comments, error messages to mixed case;
8267 C numerous corrections to prologues and internal comments.
8268 C 20010507 Converted single precision source to double precision.
8269 C 20020502 Corrected declarations in descriptions of user routines.
8270 C 20030603 Corrected duplicate type declaration for DUMACH.
8271 C 20031105 Restored 'own' variables to Common blocks, to enable
8272 C interrupt/restart feature.
8273 C 20031112 Added SAVE statements for data-loaded constants.
8274 C 20031117 Changed internal name NPE to NJE.
8275 C
8276 C-----------------------------------------------------------------------
8277 C Other routines in the DLSODPK package.
8278 C
8279 C In addition to Subroutine DLSODPK, the DLSODPK package includes the
8280 C following subroutines and function routines:
8281 C DINTDY computes an interpolated value of the y vector at t = TOUT.
8282 C DEWSET sets the error weight vector EWT before each step.
8283 C DVNORM computes the weighted RMS-norm of a vector.
8284 C DSTODPK is the core integrator, which does one step of the
8285 C integration and the associated error control.
8286 C DCFODE sets all method coefficients and test constants.
8287 C DPKSET interfaces between DSTODPK and the JAC routine.
8288 C DSOLPK manages solution of linear system in Newton iteration.
8289 C DSPIOM performs the SPIOM algorithm.
8290 C DATV computes a scaled, preconditioned product (I-hl0*J)*v.
8291 C DORTHOG orthogonalizes a vector against previous basis vectors.
8292 C DHEFA generates an LU factorization of a Hessenberg matrix.
8293 C DHESL solves a Hessenberg square linear system.
8294 C DSPIGMR performs the SPIGMR algorithm.
8295 C DHEQR generates a QR factorization of a Hessenberg matrix.
8296 C DHELS finds the least squares solution of a Hessenberg system.
8297 C DPCG performs Preconditioned Conjugate Gradient algorithm (PCG).
8298 C DPCGS performs the PCGS algorithm.
8299 C DATP computes the product A*p, where A = I - hl0*df/dy.
8300 C DUSOL interfaces to the user's PSOL routine (MITER = 9).
8301 C DSRCPK is a user-callable routine to save and restore
8302 C the contents of the internal Common blocks.
8303 C DAXPY, DCOPY, DDOT, DNRM2, and DSCAL are basic linear
8304 C algebra modules (from the BLAS collection).
8305 C DUMACH computes the unit roundoff in a machine-independent manner.
8306 C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all
8307 C error messages and warnings. XERRWD is machine-dependent.
8308 C Note: DVNORM, DDOT, DNRM2, DUMACH, IXSAV, and IUMACH are function
8309 C routines. All the others are subroutines.
8310 C
8311 C-----------------------------------------------------------------------
8312  DOUBLE PRECISION dumach, dvnorm
8313  INTEGER init, mxstep, mxhnil, nhnil, nslast, nyh, iowns,
8314  1 icf, ierpj, iersl, jcur, jstart, kflag, l,
8315  2 lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
8316  3 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
8317  INTEGER jpre, jacflg, locwp, lociwp, lsavx, kmp, maxl, mnewt,
8318  1 nni, nli, nps, ncfn, ncfl
8319  INTEGER i, i1, i2, iflag, imxer, kgo, lf0, leniw,
8320  1 leniwk, lenrw, lenwm, lenwk, liwp, lwp, mord, mxhnl0, mxstp0,
8321  2 ncfn0, ncfl0, nli0, nni0, nnid, nstd, nwarn
8322  DOUBLE PRECISION rowns,
8323  1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
8324  DOUBLE PRECISION delt, epcon, sqrtn, rsqrtn
8325  DOUBLE PRECISION atoli, avdim, ayi, big, ewti, h0, hmax, hmx,
8326  1 rcfl, rcfn, rh, rtoli, tcrit,
8327  2 tdist, tnext, tol, tolsf, tp, SIZE, sum, w0
8328  dimension mord(2)
8329  LOGICAL ihit, lavd, lcfn, lcfl, lwarn
8330  CHARACTER*60 msg
8331  SAVE mord, mxstp0, mxhnl0
8332 C-----------------------------------------------------------------------
8333 C The following two internal Common blocks contain
8334 C (a) variables which are local to any subroutine but whose values must
8335 C be preserved between calls to the routine ("own" variables), and
8336 C (b) variables which are communicated between subroutines.
8337 C The block DLS001 is declared in subroutines DLSODPK, DINTDY, DSTODPK,
8338 C DSOLPK, and DATV.
8339 C The block DLPK01 is declared in subroutines DLSODPK, DSTODPK, DPKSET,
8340 C and DSOLPK.
8341 C Groups of variables are replaced by dummy arrays in the Common
8342 C declarations in routines where those variables are not used.
8343 C-----------------------------------------------------------------------
8344  COMMON /dls001/ rowns(209),
8345  1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
8346  2 init, mxstep, mxhnil, nhnil, nslast, nyh, iowns(6),
8347  3 icf, ierpj, iersl, jcur, jstart, kflag, l,
8348  4 lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
8349  5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
8350 C
8351  COMMON /dlpk01/ delt, epcon, sqrtn, rsqrtn,
8352  1 jpre, jacflg, locwp, lociwp, lsavx, kmp, maxl, mnewt,
8353  2 nni, nli, nps, ncfn, ncfl
8354 C
8355  DATA mord(1),mord(2)/12,5/, mxstp0/500/, mxhnl0/10/
8356 C-----------------------------------------------------------------------
8357 C Block A.
8358 C This code block is executed on every call.
8359 C It tests ISTATE and ITASK for legality and branches appropriately.
8360 C If ISTATE .gt. 1 but the flag INIT shows that initialization has
8361 C not yet been done, an error return occurs.
8362 C If ISTATE = 1 and TOUT = T, return immediately.
8363 C-----------------------------------------------------------------------
8364  IF (istate .LT. 1 .OR. istate .GT. 3) GO TO 601
8365  IF (itask .LT. 1 .OR. itask .GT. 5) GO TO 602
8366  IF (istate .EQ. 1) GO TO 10
8367  IF (init .EQ. 0) GO TO 603
8368  IF (istate .EQ. 2) GO TO 200
8369  GO TO 20
8370  10 init = 0
8371  IF (tout .EQ. t) RETURN
8372 C-----------------------------------------------------------------------
8373 C Block B.
8374 C The next code block is executed for the initial call (ISTATE = 1),
8375 C or for a continuation call with parameter changes (ISTATE = 3).
8376 C It contains checking of all inputs and various initializations.
8377 C
8378 C First check legality of the non-optional inputs NEQ, ITOL, IOPT, MF.
8379 C-----------------------------------------------------------------------
8380  20 IF (neq(1) .LE. 0) GO TO 604
8381  IF (istate .EQ. 1) GO TO 25
8382  IF (neq(1) .GT. n) GO TO 605
8383  25 n = neq(1)
8384  IF (itol .LT. 1 .OR. itol .GT. 4) GO TO 606
8385  IF (iopt .LT. 0 .OR. iopt .GT. 1) GO TO 607
8386  meth = mf/10
8387  miter = mf - 10*meth
8388  IF (meth .LT. 1 .OR. meth .GT. 2) GO TO 608
8389  IF (miter .LT. 0) GO TO 608
8390  IF (miter .GT. 4 .AND. miter .LT. 9) GO TO 608
8391  IF (miter .GE. 1) jpre = iwork(3)
8392  jacflg = 0
8393  IF (miter .GE. 1) jacflg = iwork(4)
8394 C Next process and check the optional inputs. --------------------------
8395  IF (iopt .EQ. 1) GO TO 40
8396  maxord = mord(meth)
8397  mxstep = mxstp0
8398  mxhnil = mxhnl0
8399  IF (istate .EQ. 1) h0 = 0.0d0
8400  hmxi = 0.0d0
8401  hmin = 0.0d0
8402  maxl = min(5,n)
8403  kmp = maxl
8404  delt = 0.05d0
8405  GO TO 60
8406  40 maxord = iwork(5)
8407  IF (maxord .LT. 0) GO TO 611
8408  IF (maxord .EQ. 0) maxord = 100
8409  maxord = min(maxord,mord(meth))
8410  mxstep = iwork(6)
8411  IF (mxstep .LT. 0) GO TO 612
8412  IF (mxstep .EQ. 0) mxstep = mxstp0
8413  mxhnil = iwork(7)
8414  IF (mxhnil .LT. 0) GO TO 613
8415  IF (mxhnil .EQ. 0) mxhnil = mxhnl0
8416  IF (istate .NE. 1) GO TO 50
8417  h0 = rwork(5)
8418  IF ((tout - t)*h0 .LT. 0.0d0) GO TO 614
8419  50 hmax = rwork(6)
8420  IF (hmax .LT. 0.0d0) GO TO 615
8421  hmxi = 0.0d0
8422  IF (hmax .GT. 0.0d0) hmxi = 1.0d0/hmax
8423  hmin = rwork(7)
8424  IF (hmin .LT. 0.0d0) GO TO 616
8425  maxl = iwork(8)
8426  IF (maxl .EQ. 0) maxl = 5
8427  maxl = min(maxl,n)
8428  kmp = iwork(9)
8429  IF (kmp .EQ. 0 .OR. kmp .GT. maxl) kmp = maxl
8430  delt = rwork(8)
8431  IF (delt .EQ. 0.0d0) delt = 0.05d0
8432 C-----------------------------------------------------------------------
8433 C Set work array pointers and check lengths LRW and LIW.
8434 C Pointers to segments of RWORK and IWORK are named by prefixing L to
8435 C the name of the segment. E.g., the segment YH starts at RWORK(LYH).
8436 C RWORK segments (in order) are denoted YH, WM, EWT, SAVF, SAVX, ACOR.
8437 C-----------------------------------------------------------------------
8438  60 lyh = 21
8439  IF (istate .EQ. 1) nyh = n
8440  lwm = lyh + (maxord + 1)*nyh
8441  IF (miter .EQ. 0) lenwk = 0
8442  IF (miter .EQ. 1) lenwk = n*(maxl+2) + maxl*maxl
8443  IF (miter .EQ. 2)
8444  1 lenwk = n*(maxl+2+min(1,maxl-kmp)) + (maxl+3)*maxl + 1
8445  IF (miter .EQ. 3 .OR. miter .EQ. 4) lenwk = 5*n
8446  IF (miter .EQ. 9) lenwk = 2*n
8447  lwp = 0
8448  IF (miter .GE. 1) lwp = iwork(1)
8449  lenwm = lenwk + lwp
8450  locwp = lenwk + 1
8451  lewt = lwm + lenwm
8452  lsavf = lewt + n
8453  lsavx = lsavf + n
8454  lacor = lsavx + n
8455  IF (miter .EQ. 0) lacor = lsavf + n
8456  lenrw = lacor + n - 1
8457  iwork(17) = lenrw
8458  liwm = 31
8459  leniwk = 0
8460  IF (miter .EQ. 1) leniwk = maxl
8461  liwp = 0
8462  IF (miter .GE. 1) liwp = iwork(2)
8463  leniw = 30 + leniwk + liwp
8464  lociwp = leniwk + 1
8465  iwork(18) = leniw
8466  IF (lenrw .GT. lrw) GO TO 617
8467  IF (leniw .GT. liw) GO TO 618
8468 C Check RTOL and ATOL for legality. ------------------------------------
8469  rtoli = rtol(1)
8470  atoli = atol(1)
8471  DO 70 i = 1,n
8472  IF (itol .GE. 3) rtoli = rtol(i)
8473  IF (itol .EQ. 2 .OR. itol .EQ. 4) atoli = atol(i)
8474  IF (rtoli .LT. 0.0d0) GO TO 619
8475  IF (atoli .LT. 0.0d0) GO TO 620
8476  70 CONTINUE
8477 C Load SQRT(N) and its reciprocal in Common. ---------------------------
8478  sqrtn = sqrt(REAL(n))
8479  rsqrtn = 1.0d0/sqrtn
8480  IF (istate .EQ. 1) GO TO 100
8481 C If ISTATE = 3, set flag to signal parameter changes to DSTODPK. ------
8482  jstart = -1
8483  IF (nq .LE. maxord) GO TO 90
8484 C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. ---------
8485  DO 80 i = 1,n
8486  80 rwork(i+lsavf-1) = rwork(i+lwm-1)
8487  90 CONTINUE
8488  IF (n .EQ. nyh) GO TO 200
8489 C NEQ was reduced. Zero part of YH to avoid undefined references. -----
8490  i1 = lyh + l*nyh
8491  i2 = lyh + (maxord + 1)*nyh - 1
8492  IF (i1 .GT. i2) GO TO 200
8493  DO 95 i = i1,i2
8494  95 rwork(i) = 0.0d0
8495  GO TO 200
8496 C-----------------------------------------------------------------------
8497 C Block C.
8498 C The next block is for the initial call only (ISTATE = 1).
8499 C It contains all remaining initializations, the initial call to F,
8500 C and the calculation of the initial step size.
8501 C The error weights in EWT are inverted after being loaded.
8502 C-----------------------------------------------------------------------
8503  100 uround = dumach()
8504  tn = t
8505  IF (itask .NE. 4 .AND. itask .NE. 5) GO TO 110
8506  tcrit = rwork(1)
8507  IF ((tcrit - tout)*(tout - t) .LT. 0.0d0) GO TO 625
8508  IF (h0 .NE. 0.0d0 .AND. (t + h0 - tcrit)*h0 .GT. 0.0d0)
8509  1 h0 = tcrit - t
8510  110 jstart = 0
8511  nhnil = 0
8512  nst = 0
8513  nje = 0
8514  nslast = 0
8515  nli0 = 0
8516  nni0 = 0
8517  ncfn0 = 0
8518  ncfl0 = 0
8519  nwarn = 0
8520  hu = 0.0d0
8521  nqu = 0
8522  ccmax = 0.3d0
8523  maxcor = 3
8524  msbp = 20
8525  mxncf = 10
8526  nni = 0
8527  nli = 0
8528  nps = 0
8529  ncfn = 0
8530  ncfl = 0
8531 C Initial call to F. (LF0 points to YH(*,2).) -------------------------
8532  lf0 = lyh + nyh
8533  CALL f (neq, t, y, rwork(lf0))
8534  nfe = 1
8535 C Load the initial value vector in YH. ---------------------------------
8536  DO 115 i = 1,n
8537  115 rwork(i+lyh-1) = y(i)
8538 C Load and invert the EWT array. (H is temporarily set to 1.0.) -------
8539  nq = 1
8540  h = 1.0d0
8541  CALL dewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt))
8542  DO 120 i = 1,n
8543  IF (rwork(i+lewt-1) .LE. 0.0d0) GO TO 621
8544  120 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1)
8545 C-----------------------------------------------------------------------
8546 C The coding below computes the step size, H0, to be attempted on the
8547 C first step, unless the user has supplied a value for this.
8548 C First check that TOUT - T differs significantly from zero.
8549 C A scalar tolerance quantity TOL is computed, as MAX(RTOL(i))
8550 C if this is positive, or MAX(ATOL(i)/ABS(Y(i))) otherwise, adjusted
8551 C so as to be between 100*UROUND and 1.0E-3.
8552 C Then the computed value H0 is given by..
8553 C NEQ
8554 C H0**2 = TOL / ( w0**-2 + (1/NEQ) * Sum ( f(i)/ywt(i) )**2 )
8555 C 1
8556 C where w0 = MAX ( ABS(T), ABS(TOUT) ),
8557 C f(i) = i-th component of initial value of f,
8558 C ywt(i) = EWT(i)/TOL (a weight for y(i)).
8559 C The sign of H0 is inferred from the initial values of TOUT and T.
8560 C-----------------------------------------------------------------------
8561  IF (h0 .NE. 0.0d0) GO TO 180
8562  tdist = abs(tout - t)
8563  w0 = max(abs(t),abs(tout))
8564  IF (tdist .LT. 2.0d0*uround*w0) GO TO 622
8565  tol = rtol(1)
8566  IF (itol .LE. 2) GO TO 140
8567  DO 130 i = 1,n
8568  130 tol = max(tol,rtol(i))
8569  140 IF (tol .GT. 0.0d0) GO TO 160
8570  atoli = atol(1)
8571  DO 150 i = 1,n
8572  IF (itol .EQ. 2 .OR. itol .EQ. 4) atoli = atol(i)
8573  ayi = abs(y(i))
8574  IF (ayi .NE. 0.0d0) tol = max(tol,atoli/ayi)
8575  150 CONTINUE
8576  160 tol = max(tol,100.0d0*uround)
8577  tol = min(tol,0.001d0)
8578  sum = dvnorm(n, rwork(lf0), rwork(lewt))
8579  sum = 1.0d0/(tol*w0*w0) + tol*sum**2
8580  h0 = 1.0d0/sqrt(sum)
8581  h0 = min(h0,tdist)
8582  h0 = sign(h0,tout-t)
8583 C Adjust H0 if necessary to meet HMAX bound. ---------------------------
8584  180 rh = abs(h0)*hmxi
8585  IF (rh .GT. 1.0d0) h0 = h0/rh
8586 C Load H with H0 and scale YH(*,2) by H0. ------------------------------
8587  h = h0
8588  DO 190 i = 1,n
8589  190 rwork(i+lf0-1) = h0*rwork(i+lf0-1)
8590  GO TO 270
8591 C-----------------------------------------------------------------------
8592 C Block D.
8593 C The next code block is for continuation calls only (ISTATE = 2 or 3)
8594 C and is to check stop conditions before taking a step.
8595 C-----------------------------------------------------------------------
8596  200 nslast = nst
8597  nli0 = nli
8598  nni0 = nni
8599  ncfn0 = ncfn
8600  ncfl0 = ncfl
8601  nwarn = 0
8602  GO TO (210, 250, 220, 230, 240), itask
8603  210 IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
8604  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
8605  IF (iflag .NE. 0) GO TO 627
8606  t = tout
8607  GO TO 420
8608  220 tp = tn - hu*(1.0d0 + 100.0d0*uround)
8609  IF ((tp - tout)*h .GT. 0.0d0) GO TO 623
8610  IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
8611  GO TO 400
8612  230 tcrit = rwork(1)
8613  IF ((tn - tcrit)*h .GT. 0.0d0) GO TO 624
8614  IF ((tcrit - tout)*h .LT. 0.0d0) GO TO 625
8615  IF ((tn - tout)*h .LT. 0.0d0) GO TO 245
8616  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
8617  IF (iflag .NE. 0) GO TO 627
8618  t = tout
8619  GO TO 420
8620  240 tcrit = rwork(1)
8621  IF ((tn - tcrit)*h .GT. 0.0d0) GO TO 624
8622  245 hmx = abs(tn) + abs(h)
8623  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
8624  IF (ihit) GO TO 400
8625  tnext = tn + h*(1.0d0 + 4.0d0*uround)
8626  IF ((tnext - tcrit)*h .LE. 0.0d0) GO TO 250
8627  h = (tcrit - tn)*(1.0d0 - 4.0d0*uround)
8628  IF (istate .EQ. 2) jstart = -2
8629 C-----------------------------------------------------------------------
8630 C Block E.
8631 C The next block is normally executed for all calls and contains
8632 C the call to the one-step core integrator DSTODPK.
8633 C
8634 C This is a looping point for the integration steps.
8635 C
8636 C First check for too many steps being taken,
8637 C Check for poor Newton/Krylov method performance, update EWT (if not
8638 C at start of problem), check for too much accuracy being requested,
8639 C and check for H below the roundoff level in T.
8640 C-----------------------------------------------------------------------
8641  250 CONTINUE
8642  IF ((nst-nslast) .GE. mxstep) GO TO 500
8643  nstd = nst - nslast
8644  nnid = nni - nni0
8645  IF (nstd .LT. 10 .OR. nnid .EQ. 0) GO TO 255
8646  avdim = REAL(nli - nli0)/REAL(nnid)
8647  rcfn = REAL(ncfn - ncfn0)/REAL(nstd)
8648  rcfl = REAL(ncfl - ncfl0)/REAL(nnid)
8649  lavd = avdim .GT. (maxl - 0.05d0)
8650  lcfn = rcfn .GT. 0.9d0
8651  lcfl = rcfl .GT. 0.9d0
8652  lwarn = lavd .OR. lcfn .OR. lcfl
8653  IF (.NOT.lwarn) GO TO 255
8654  nwarn = nwarn + 1
8655  IF (nwarn .GT. 10) GO TO 255
8656  IF (lavd) THEN
8657  msg='DLSODPK- Warning. Poor iterative algorithm performance seen '
8658  CALL xerrwd (msg, 60, 111, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
8659  ENDIF
8660  IF (lavd) THEN
8661  msg=' at T = R1 by average no. of linear iterations = R2 '
8662  CALL xerrwd (msg, 60, 111, 0, 0, 0, 0, 2, tn, avdim)
8663  ENDIF
8664  IF (lcfn) THEN
8665  msg='DLSODPK- Warning. Poor iterative algorithm performance seen '
8666  CALL xerrwd (msg, 60, 112, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
8667  ENDIF
8668  IF (lcfn) THEN
8669  msg=' at T = R1 by nonlinear convergence failure rate = R2 '
8670  CALL xerrwd (msg, 60, 112, 0, 0, 0, 0, 2, tn, rcfn)
8671  ENDIF
8672  IF (lcfl) THEN
8673  msg='DLSODPK- Warning. Poor iterative algorithm performance seen '
8674  CALL xerrwd (msg, 60, 113, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
8675  ENDIF
8676  IF (lcfl) THEN
8677  msg=' at T = R1 by linear convergence failure rate = R2 '
8678  CALL xerrwd (msg, 60, 113, 0, 0, 0, 0, 2, tn, rcfl)
8679  ENDIF
8680  255 CONTINUE
8681  CALL dewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt))
8682  DO 260 i = 1,n
8683  IF (rwork(i+lewt-1) .LE. 0.0d0) GO TO 510
8684  260 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1)
8685  270 tolsf = uround*dvnorm(n, rwork(lyh), rwork(lewt))
8686  IF (tolsf .LE. 1.0d0) GO TO 280
8687  tolsf = tolsf*2.0d0
8688  IF (nst .EQ. 0) GO TO 626
8689  GO TO 520
8690  280 IF ((tn + h) .NE. tn) GO TO 290
8691  nhnil = nhnil + 1
8692  IF (nhnil .GT. mxhnil) GO TO 290
8693  msg = 'DLSODPK- Warning..Internal T(=R1) and H(=R2) are '
8694  CALL xerrwd (msg, 50, 101, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
8695  msg=' such that in the machine, T + H = T on the next step '
8696  CALL xerrwd (msg, 60, 101, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
8697  msg = ' (H = step size). Solver will continue anyway.'
8698  CALL xerrwd (msg, 50, 101, 0, 0, 0, 0, 2, tn, h)
8699  IF (nhnil .LT. mxhnil) GO TO 290
8700  msg = 'DLSODPK- Above warning has been issued I1 times. '
8701  CALL xerrwd (msg, 50, 102, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
8702  msg = ' It will not be issued again for this problem.'
8703  CALL xerrwd (msg, 50, 102, 0, 1, mxhnil, 0, 0, 0.0d0, 0.0d0)
8704  290 CONTINUE
8705 C-----------------------------------------------------------------------
8706 C CALL DSTODPK(NEQ,Y,YH,NYH,YH,EWT,SAVF,SAVX,ACOR,WM,IWM,F,JAC,PSOL)
8707 C-----------------------------------------------------------------------
8708  CALL dstodpk (neq, y, rwork(lyh), nyh, rwork(lyh), rwork(lewt),
8709  1 rwork(lsavf), rwork(lsavx), rwork(lacor), rwork(lwm),
8710  2 iwork(liwm), f, jac, psol)
8711  kgo = 1 - kflag
8712  GO TO (300, 530, 540, 550), kgo
8713 C-----------------------------------------------------------------------
8714 C Block F.
8715 C The following block handles the case of a successful return from the
8716 C core integrator (KFLAG = 0). Test for stop conditions.
8717 C-----------------------------------------------------------------------
8718  300 init = 1
8719  GO TO (310, 400, 330, 340, 350), itask
8720 C ITASK = 1. If TOUT has been reached, interpolate. -------------------
8721  310 IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
8722  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
8723  t = tout
8724  GO TO 420
8725 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------
8726  330 IF ((tn - tout)*h .GE. 0.0d0) GO TO 400
8727  GO TO 250
8728 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary.
8729  340 IF ((tn - tout)*h .LT. 0.0d0) GO TO 345
8730  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
8731  t = tout
8732  GO TO 420
8733  345 hmx = abs(tn) + abs(h)
8734  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
8735  IF (ihit) GO TO 400
8736  tnext = tn + h*(1.0d0 + 4.0d0*uround)
8737  IF ((tnext - tcrit)*h .LE. 0.0d0) GO TO 250
8738  h = (tcrit - tn)*(1.0d0 - 4.0d0*uround)
8739  jstart = -2
8740  GO TO 250
8741 C ITASK = 5. see if TCRIT was reached and jump to exit. ---------------
8742  350 hmx = abs(tn) + abs(h)
8743  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
8744 C-----------------------------------------------------------------------
8745 C Block G.
8746 C The following block handles all successful returns from DLSODPK.
8747 C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly.
8748 C ISTATE is set to 2, and the optional outputs are loaded into the
8749 C work arrays before returning.
8750 C-----------------------------------------------------------------------
8751  400 DO 410 i = 1,n
8752  410 y(i) = rwork(i+lyh-1)
8753  t = tn
8754  IF (itask .NE. 4 .AND. itask .NE. 5) GO TO 420
8755  IF (ihit) t = tcrit
8756  420 istate = 2
8757  rwork(11) = hu
8758  rwork(12) = h
8759  rwork(13) = tn
8760  iwork(11) = nst
8761  iwork(12) = nfe
8762  iwork(13) = nje
8763  iwork(14) = nqu
8764  iwork(15) = nq
8765  iwork(19) = nni
8766  iwork(20) = nli
8767  iwork(21) = nps
8768  iwork(22) = ncfn
8769  iwork(23) = ncfl
8770  RETURN
8771 C-----------------------------------------------------------------------
8772 C Block H.
8773 C The following block handles all unsuccessful returns other than
8774 C those for illegal input. First the error message routine is called.
8775 C If there was an error test or convergence test failure, IMXER is set.
8776 C Then Y is loaded from YH and T is set to TN.
8777 C The optional outputs are loaded into the work arrays before returning.
8778 C-----------------------------------------------------------------------
8779 C The maximum number of steps was taken before reaching TOUT. ----------
8780  500 msg = 'DLSODPK- At current T (=R1), MXSTEP (=I1) steps '
8781  CALL xerrwd (msg, 50, 201, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
8782  msg = ' taken on this call before reaching TOUT '
8783  CALL xerrwd (msg, 50, 201, 0, 1, mxstep, 0, 1, tn, 0.0d0)
8784  istate = -1
8785  GO TO 580
8786 C EWT(i) .le. 0.0 for some i (not at start of problem). ----------------
8787  510 ewti = rwork(lewt+i-1)
8788  msg = .le.'DLSODPK- At T (=R1), EWT(I1) has become R20. '
8789  CALL xerrwd (msg, 50, 202, 0, 1, i, 0, 2, tn, ewti)
8790  istate = -6
8791  GO TO 580
8792 C Too much accuracy requested for machine precision. -------------------
8793  520 msg = 'DLSODPK- At T (=R1), too much accuracy requested '
8794  CALL xerrwd (msg, 50, 203, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
8795  msg = ' for precision of machine.. See TOLSF (=R2) '
8796  CALL xerrwd (msg, 50, 203, 0, 0, 0, 0, 2, tn, tolsf)
8797  rwork(14) = tolsf
8798  istate = -2
8799  GO TO 580
8800 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. -----
8801  530 msg = 'DLSODPK- At T(=R1), step size H(=R2), the error '
8802  CALL xerrwd (msg, 50, 204, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
8803  msg = ' test failed repeatedly or with ABS(H) = HMIN'
8804  CALL xerrwd (msg, 50, 204, 0, 0, 0, 0, 2, tn, h)
8805  istate = -4
8806  GO TO 560
8807 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ----
8808  540 msg = 'DLSODPK- At T (=R1) and step size H (=R2), the '
8809  CALL xerrwd (msg, 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
8810  msg = ' corrector convergence failed repeatedly '
8811  CALL xerrwd (msg, 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
8812  msg = ' or with ABS(H) = HMIN '
8813  CALL xerrwd (msg, 30, 205, 0, 0, 0, 0, 2, tn, h)
8814  istate = -5
8815  GO TO 560
8816 C KFLAG = -3. Unrecoverable error from PSOL. --------------------------
8817  550 msg = 'DLSODPK- At T (=R1) an unrecoverable error return'
8818  CALL xerrwd (msg, 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
8819  msg = ' was made from Subroutine PSOL '
8820  CALL xerrwd (msg, 40, 205, 0, 0, 0, 0, 1, tn, 0.0d0)
8821  istate = -7
8822  GO TO 580
8823 C Compute IMXER if relevant. -------------------------------------------
8824  560 big = 0.0d0
8825  imxer = 1
8826  DO 570 i = 1,n
8827  SIZE = abs(rwork(i+lacor-1)*rwork(i+lewt-1))
8828  IF (big .GE. size) GO TO 570
8829  big = SIZE
8830  imxer = i
8831  570 CONTINUE
8832  iwork(16) = imxer
8833 C Set Y vector, T, and optional outputs. -------------------------------
8834  580 DO 590 i = 1,n
8835  590 y(i) = rwork(i+lyh-1)
8836  t = tn
8837  rwork(11) = hu
8838  rwork(12) = h
8839  rwork(13) = tn
8840  iwork(11) = nst
8841  iwork(12) = nfe
8842  iwork(13) = nje
8843  iwork(14) = nqu
8844  iwork(15) = nq
8845  iwork(19) = nni
8846  iwork(20) = nli
8847  iwork(21) = nps
8848  iwork(22) = ncfn
8849  iwork(23) = ncfl
8850  RETURN
8851 C-----------------------------------------------------------------------
8852 C Block I.
8853 C The following block handles all error returns due to illegal input
8854 C (ISTATE = -3), as detected before calling the core integrator.
8855 C First the error message routine is called. If the illegal input
8856 C is a negative ISTATE, the run is aborted (apparent infinite loop).
8857 C-----------------------------------------------------------------------
8858  601 msg = 'DLSODPK- ISTATE(=I1) illegal.'
8859  CALL xerrwd (msg, 30, 1, 0, 1, istate, 0, 0, 0.0d0, 0.0d0)
8860  IF (istate .LT. 0) GO TO 800
8861  GO TO 700
8862  602 msg = 'DLSODPK- ITASK (=I1) illegal.'
8863  CALL xerrwd (msg, 30, 2, 0, 1, itask, 0, 0, 0.0d0, 0.0d0)
8864  GO TO 700
8865  603 msg = .gt.'DLSODPK- ISTATE1 but DLSODPK not initialized.'
8866  CALL xerrwd (msg, 50, 3, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
8867  GO TO 700
8868  604 msg = .lt.'DLSODPK- NEQ (=I1) 1 '
8869  CALL xerrwd (msg, 30, 4, 0, 1, neq(1), 0, 0, 0.0d0, 0.0d0)
8870  GO TO 700
8871  605 msg = 'DLSODPK- ISTATE = 3 and NEQ increased (I1 to I2).'
8872  CALL xerrwd (msg, 50, 5, 0, 2, n, neq(1), 0, 0.0d0, 0.0d0)
8873  GO TO 700
8874  606 msg = 'DLSODPK- ITOL (=I1) illegal. '
8875  CALL xerrwd (msg, 30, 6, 0, 1, itol, 0, 0, 0.0d0, 0.0d0)
8876  GO TO 700
8877  607 msg = 'DLSODPK- IOPT (=I1) illegal. '
8878  CALL xerrwd (msg, 30, 7, 0, 1, iopt, 0, 0, 0.0d0, 0.0d0)
8879  GO TO 700
8880  608 msg = 'DLSODPK- MF (=I1) illegal. '
8881  CALL xerrwd (msg, 30, 8, 0, 1, mf, 0, 0, 0.0d0, 0.0d0)
8882  GO TO 700
8883  611 msg = .lt.'DLSODPK- MAXORD (=I1) 0 '
8884  CALL xerrwd (msg, 30, 11, 0, 1, maxord, 0, 0, 0.0d0, 0.0d0)
8885  GO TO 700
8886  612 msg = .lt.'DLSODPK- MXSTEP (=I1) 0 '
8887  CALL xerrwd (msg, 30, 12, 0, 1, mxstep, 0, 0, 0.0d0, 0.0d0)
8888  GO TO 700
8889  613 msg = .lt.'DLSODPK- MXHNIL (=I1) 0 '
8890  CALL xerrwd (msg, 30, 13, 0, 1, mxhnil, 0, 0, 0.0d0, 0.0d0)
8891  GO TO 700
8892  614 msg = 'DLSODPK- TOUT (=R1) behind T (=R2) '
8893  CALL xerrwd (msg, 40, 14, 0, 0, 0, 0, 2, tout, t)
8894  msg = ' Integration direction is given by H0 (=R1) '
8895  CALL xerrwd (msg, 50, 14, 0, 0, 0, 0, 1, h0, 0.0d0)
8896  GO TO 700
8897  615 msg = .lt.'DLSODPK- HMAX (=R1) 0.0 '
8898  CALL xerrwd (msg, 30, 15, 0, 0, 0, 0, 1, hmax, 0.0d0)
8899  GO TO 700
8900  616 msg = .lt.'DLSODPK- HMIN (=R1) 0.0 '
8901  CALL xerrwd (msg, 30, 16, 0, 0, 0, 0, 1, hmin, 0.0d0)
8902  GO TO 700
8903  617 msg='DLSODPK- RWORK length needed, LENRW(=I1), exceeds LRW(=I2) '
8904  CALL xerrwd (msg, 60, 17, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0)
8905  GO TO 700
8906  618 msg='DLSODPK- IWORK length needed, LENIW(=I1), exceeds LIW(=I2) '
8907  CALL xerrwd (msg, 60, 18, 0, 2, leniw, liw, 0, 0.0d0, 0.0d0)
8908  GO TO 700
8909  619 msg = .lt.'DLSODPK- RTOL(I1) is R1 0.0 '
8910  CALL xerrwd (msg, 40, 19, 0, 1, i, 0, 1, rtoli, 0.0d0)
8911  GO TO 700
8912  620 msg = .lt.'DLSODPK- ATOL(I1) is R1 0.0 '
8913  CALL xerrwd (msg, 40, 20, 0, 1, i, 0, 1, atoli, 0.0d0)
8914  GO TO 700
8915  621 ewti = rwork(lewt+i-1)
8916  msg = .le.'DLSODPK- EWT(I1) is R1 0.0 '
8917  CALL xerrwd (msg, 40, 21, 0, 1, i, 0, 1, ewti, 0.0d0)
8918  GO TO 700
8919  622 msg='DLSODPK- TOUT(=R1) too close to T(=R2) to start integration.'
8920  CALL xerrwd (msg, 60, 22, 0, 0, 0, 0, 2, tout, t)
8921  GO TO 700
8922  623 msg='DLSODPK- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) '
8923  CALL xerrwd (msg, 60, 23, 0, 1, itask, 0, 2, tout, tp)
8924  GO TO 700
8925  624 msg='DLSODPK- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) '
8926  CALL xerrwd (msg, 60, 24, 0, 0, 0, 0, 2, tcrit, tn)
8927  GO TO 700
8928  625 msg='DLSODPK- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) '
8929  CALL xerrwd (msg, 60, 25, 0, 0, 0, 0, 2, tcrit, tout)
8930  GO TO 700
8931  626 msg = 'DLSODPK- At start of problem, too much accuracy '
8932  CALL xerrwd (msg, 50, 26, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
8933  msg=' requested for precision of machine.. See TOLSF (=R1) '
8934  CALL xerrwd (msg, 60, 26, 0, 0, 0, 0, 1, tolsf, 0.0d0)
8935  rwork(14) = tolsf
8936  GO TO 700
8937  627 msg = 'DLSODPK- Trouble in DINTDY. ITASK = I1, TOUT = R1'
8938  CALL xerrwd (msg, 50, 27, 0, 1, itask, 0, 1, tout, 0.0d0)
8939 C
8940  700 istate = -3
8941  RETURN
8942 C
8943  800 msg = 'DLSODPK- Run aborted.. apparent infinite loop. '
8944  CALL xerrwd (msg, 50, 303, 2, 0, 0, 0, 0, 0.0d0, 0.0d0)
8945  RETURN
8946 C----------------------- End of Subroutine DLSODPK ---------------------
8947  END
8948 *DECK DLSODKR
8949  SUBROUTINE dlsodkr (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK,
8950  1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, PSOL,
8951  2 MF, G, NG, JROOT)
8952  EXTERNAL f, jac, psol, g
8953  INTEGER neq, itol, itask, istate, iopt, lrw, iwork, liw, mf,
8954  1 ng, jroot
8955  DOUBLE PRECISION y, t, tout, rtol, atol, rwork
8956  dimension neq(*), y(*), rtol(*), atol(*), rwork(lrw), iwork(liw),
8957  1 jroot(*)
8958 C-----------------------------------------------------------------------
8959 C This is the 18 November 2003 version of
8960 C DLSODKR: Livermore Solver for Ordinary Differential equations,
8961 C with preconditioned Krylov iteration methods for the
8962 C Newton correction linear systems, and with Rootfinding.
8963 C
8964 C This version is in double precision.
8965 C
8966 C DLSODKR solves the initial value problem for stiff or nonstiff
8967 C systems of first order ODEs,
8968 C dy/dt = f(t,y) , or, in component form,
8969 C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ).
8970 C At the same time, it locates the roots of any of a set of functions
8971 C g(i) = g(i,t,y(1),...,y(NEQ)) (i = 1,...,ng).
8972 C
8973 C-----------------------------------------------------------------------
8974 C Introduction.
8975 C
8976 C This is a modification of the DLSODE package, and differs from it
8977 C in five ways:
8978 C (a) It uses various preconditioned Krylov subspace iteration methods
8979 C for the linear algebraic systems that arise in the case of stiff
8980 C systems. See the introductory notes below.
8981 C (b) It does automatic switching between functional (fixpoint)
8982 C iteration and Newton iteration in the corrector iteration.
8983 C (c) It finds the root of at least one of a set of constraint
8984 C functions g(i) of the independent and dependent variables.
8985 C It finds only those roots for which some g(i), as a function
8986 C of t, changes sign in the interval of integration.
8987 C It then returns the solution at the root, if that occurs
8988 C sooner than the specified stop condition, and otherwise returns
8989 C the solution according the specified stop condition.
8990 C (d) It supplies to JAC an input flag, JOK, which indicates whether
8991 C JAC may (optionally) bypass the evaluation of Jacobian matrix data
8992 C and instead process saved data (with the current value of scalar hl0).
8993 C (e) It contains a new subroutine that calculates the initial step
8994 C size to be attempted.
8995 C
8996 C
8997 C Introduction to the Krylov methods in DLSODKR:
8998 C
8999 C The linear systems that must be solved have the form
9000 C A * x = b , where A = identity - hl0 * (df/dy) .
9001 C Here hl0 is a scalar, and df/dy is the Jacobian matrix of partial
9002 C derivatives of f (NEQ by NEQ).
9003 C
9004 C The particular Krylov method is chosen by setting the second digit,
9005 C MITER, in the method flag MF.
9006 C Currently, the values of MITER have the following meanings:
9007 C
9008 C MITER = 1 means the Scaled Preconditioned Incomplete
9009 C Orthogonalization Method (SPIOM).
9010 C
9011 C 2 means an incomplete version of the preconditioned scaled
9012 C Generalized Minimal Residual method (SPIGMR).
9013 C This is the best choice in general.
9014 C
9015 C 3 means the Preconditioned Conjugate Gradient method (PCG).
9016 C Recommended only when df/dy is symmetric or nearly so.
9017 C
9018 C 4 means the scaled Preconditioned Conjugate Gradient method
9019 C (PCGS). Recommended only when D-inverse * df/dy * D is
9020 C symmetric or nearly so, where D is the diagonal scaling
9021 C matrix with elements 1/EWT(i) (see RTOL/ATOL description).
9022 C
9023 C 9 means that only a user-supplied matrix P (approximating A)
9024 C will be used, with no Krylov iteration done. This option
9025 C allows the user to provide the complete linear system
9026 C solution algorithm, if desired.
9027 C
9028 C The user can apply preconditioning to the linear system A*x = b,
9029 C by means of arbitrary matrices (the preconditioners).
9030 C In the case of SPIOM and SPIGMR, one can apply left and right
9031 C preconditioners P1 and P2, and the basic iterative method is then
9032 C applied to the matrix (P1-inverse)*A*(P2-inverse) instead of to the
9033 C matrix A. The product P1*P2 should be an approximation to matrix A
9034 C such that linear systems with P1 or P2 are easier to solve than with
9035 C A. Preconditioning from the left only or right only means using
9036 C P2 = identity or P1 = identity, respectively.
9037 C In the case of the PCG and PCGS methods, there is only one
9038 C preconditioner matrix P (but it can be the product of more than one).
9039 C It should approximate the matrix A but allow for relatively
9040 C easy solution of linear systems with coefficient matrix P.
9041 C For PCG, P should be positive definite symmetric, or nearly so,
9042 C and for PCGS, the scaled preconditioner D-inverse * P * D
9043 C should be symmetric or nearly so.
9044 C If the Jacobian J = df/dy splits in a natural way into a sum
9045 C J = J1 + J2, then one possible choice of preconditioners is
9046 C P1 = identity - hl0 * J1 and P2 = identity - hl0 * J2
9047 C provided each of these is easy to solve (or approximately solve).
9048 C
9049 C-----------------------------------------------------------------------
9050 C References:
9051 C 1. Peter N. Brown and Alan C. Hindmarsh, Reduced Storage Matrix
9052 C Methods in Stiff ODE Systems, J. Appl. Math. & Comp., 31 (1989),
9053 C pp. 40-91; also L.L.N.L. Report UCRL-95088, Rev. 1, June 1987.
9054 C 2. Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE
9055 C Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.),
9056 C North-Holland, Amsterdam, 1983, pp. 55-64.
9057 C-----------------------------------------------------------------------
9058 C Authors: Alan C. Hindmarsh and Peter N. Brown
9059 C Center for Applied Scientific Computing, L-561
9060 C Lawrence Livermore National Laboratory
9061 C Livermore, CA 94551
9062 C-----------------------------------------------------------------------
9063 C Summary of Usage.
9064 C
9065 C Communication between the user and the DLSODKR package, for normal
9066 C situations, is summarized here. This summary describes only a subset
9067 C of the full set of options available. See the full description for
9068 C details, including optional communication, nonstandard options,
9069 C and instructions for special situations. See also the demonstration
9070 C program distributed with this solver.
9071 C
9072 C A. First provide a subroutine of the form:
9073 C SUBROUTINE F (NEQ, T, Y, YDOT)
9074 C DOUBLE PRECISION T, Y(*), YDOT(*)
9075 C which supplies the vector function f by loading YDOT(i) with f(i).
9076 C
9077 C B. Provide a subroutine of the form:
9078 C SUBROUTINE G (NEQ, T, Y, NG, GOUT)
9079 C DOUBLE PRECISION T, Y(*), GOUT(NG)
9080 C which supplies the vector function g by loading GOUT(i) with
9081 C g(i), the i-th constraint function whose root is sought.
9082 C
9083 C C. Next determine (or guess) whether or not the problem is stiff.
9084 C Stiffness occurs when the Jacobian matrix df/dy has an eigenvalue
9085 C whose real part is negative and large in magnitude, compared to the
9086 C reciprocal of the t span of interest. If the problem is nonstiff,
9087 C use a method flag MF = 10. If it is stiff, MF should be between 21
9088 C and 24, or possibly 29. MF = 22 is generally the best choice.
9089 C Use 23 or 24 only if symmetry is present. Use MF = 29 if the
9090 C complete linear system solution is to be provided by the user.
9091 C The following four parameters must also be set.
9092 C IWORK(1) = LWP = length of real array WP for preconditioning.
9093 C IWORK(2) = LIWP = length of integer array IWP for preconditioning.
9094 C IWORK(3) = JPRE = preconditioner type flag:
9095 C = 0 for no preconditioning (P1 = P2 = P = identity)
9096 C = 1 for left-only preconditioning (P2 = identity)
9097 C = 2 for right-only preconditioning (P1 = identity)
9098 C = 3 for two-sided preconditioning (and PCG or PCGS)
9099 C IWORK(4) = JACFLG = flag for whether JAC is called.
9100 C = 0 if JAC is not to be called,
9101 C = 1 if JAC is to be called.
9102 C Use JACFLG = 1 if JAC computes any nonconstant data for use in
9103 C preconditioning, such as Jacobian elements.
9104 C The arrays WP and IWP are work arrays under the user's control,
9105 C for use in the routines that perform preconditioning operations.
9106 C
9107 C D. If the problem is stiff, you must supply two routines that deal
9108 C with the preconditioning of the linear systems to be solved.
9109 C These are as follows:
9110 C
9111 C SUBROUTINE JAC (F, NEQ, T, Y, YSV, REWT, FTY,V,HL0,JOK,WP,IWP,IER)
9112 C DOUBLE PRECISION T, Y(*), YSV(*), REWT(*), FTY(*), V(*), HL0,WP(*)
9113 C INTEGER IWP(*)
9114 C This routine must evaluate and preprocess any parts of the
9115 C Jacobian matrix df/dy involved in the preconditioners P1, P2, P.
9116 C The Y and FTY arrays contain the current values of y and f(t,y),
9117 C respectively, and YSV also contains the current value of y.
9118 C The array V is work space of length NEQ.
9119 C JAC must multiply all computed Jacobian elements by the scalar
9120 C -HL0, add the identity matrix, and do any factorization
9121 C operations called for, in preparation for solving linear systems
9122 C with a coefficient matrix of P1, P2, or P. The matrix P1*P2 or P
9123 C should be an approximation to identity - hl0 * (df/dy).
9124 C JAC should return IER = 0 if successful, and IER .ne. 0 if not.
9125 C (If IER .ne. 0, a smaller time step will be tried.)
9126 C JAC may alter Y and V, but not YSV, REWT, FTY, or HL0.
9127 C The JOK argument can be ignored (or see full description below).
9128 C
9129 C SUBROUTINE PSOL (NEQ, T, Y, FTY, WK, HL0, WP, IWP, B, LR, IER)
9130 C DOUBLE PRECISION T, Y(*), FTY(*), WK(*), HL0, WP(*), B(*)
9131 C INTEGER IWP(*)
9132 C This routine must solve a linear system with B as right-hand
9133 C side and one of the preconditioning matrices, P1, P2, or P, as
9134 C coefficient matrix, and return the solution vector in B.
9135 C LR is a flag concerning left vs right preconditioning, input
9136 C to PSOL. PSOL is to use P1 if LR = 1 and P2 if LR = 2.
9137 C In the case of the PCG or PCGS method, LR will be 3, and PSOL
9138 C should solve the system P*x = B with the preconditioner matrix P.
9139 C In the case MF = 29 (no Krylov iteration), LR will be 0,
9140 C and PSOL is to return in B the desired approximate solution
9141 C to A * x = B, where A = identity - hl0 * (df/dy).
9142 C PSOL can use data generated in the JAC routine and stored in
9143 C WP and IWP. WK is a work array of length NEQ.
9144 C The argument HL0 is the current value of the scalar appearing
9145 C in the linear system. If the old value, at the time of the last
9146 C JAC call, is needed, it must have been saved by JAC in WP.
9147 C on return, PSOL should set the error flag IER as follows:
9148 C IER = 0 if PSOL was successful,
9149 C IER .gt. 0 if a recoverable error occurred, meaning that the
9150 C time step will be retried,
9151 C IER .lt. 0 if an unrecoverable error occurred, meaning that the
9152 C solver is to stop immediately.
9153 C
9154 C E. Write a main program which calls Subroutine DLSODKR once for
9155 C each point at which answers are desired. This should also provide
9156 C for possible use of logical unit 6 for output of error messages
9157 C by DLSODKR. On the first call to DLSODKR, supply arguments as
9158 C follows:
9159 C F = name of subroutine for right-hand side vector f.
9160 C This name must be declared External in calling program.
9161 C NEQ = number of first order ODEs.
9162 C Y = array of initial values, of length NEQ.
9163 C T = the initial value of the independent variable.
9164 C TOUT = first point where output is desired (.ne. T).
9165 C ITOL = 1 or 2 according as ATOL (below) is a scalar or array.
9166 C RTOL = relative tolerance parameter (scalar).
9167 C ATOL = absolute tolerance parameter (scalar or array).
9168 C The estimated local error in y(i) will be controlled so as
9169 C to be roughly less (in magnitude) than
9170 C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or
9171 C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2.
9172 C Thus the local error test passes if, in each component,
9173 C either the absolute error is less than ATOL (or ATOL(i)),
9174 C or the relative error is less than RTOL.
9175 C Use RTOL = 0.0 for pure absolute error control, and
9176 C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error
9177 C control. Caution: Actual (global) errors may exceed these
9178 C local tolerances, so choose them conservatively.
9179 C ITASK = 1 for normal computation of output values of y at t = TOUT.
9180 C ISTATE = integer flag (input and output). Set ISTATE = 1.
9181 C IOPT = 0 to indicate no optional inputs used.
9182 C RWORK = real work array of length at least:
9183 C 20 + 16*NEQ + 3*NG for MF = 10,
9184 C 45 + 17*NEQ + 3*NG + LWP for MF = 21,
9185 C 61 + 17*NEQ + 3*NG + LWP for MF = 22,
9186 C 20 + 15*NEQ + 3*NG + LWP for MF = 23 or 24,
9187 C 20 + 12*NEQ + 3*NG + LWP for MF = 29.
9188 C LRW = declared length of RWORK (in user's dimension).
9189 C IWORK = integer work array of length at least:
9190 C 30 for MF = 10,
9191 C 35 + LIWP for MF = 21,
9192 C 30 + LIWP for MF = 22, 23, 24, or 29.
9193 C LIW = declared length of IWORK (in user's dimension).
9194 C JAC,PSOL = names of subroutines for preconditioning.
9195 C These names must be declared External in the calling program.
9196 C MF = method flag. Standard values are:
9197 C 10 for nonstiff (Adams) method.
9198 C 21 for stiff (BDF) method, with preconditioned SIOM.
9199 C 22 for stiff method, with preconditioned GMRES method.
9200 C 23 for stiff method, with preconditioned CG method.
9201 C 24 for stiff method, with scaled preconditioned CG method.
9202 C 29 for stiff method, with user's PSOL routine only.
9203 C G = name of subroutine for constraint functions, whose
9204 C roots are desired during the integration.
9205 C This name must be declared External in calling program.
9206 C NG = number of constraint functions g(i). If there are none,
9207 C set NG = 0, and pass a dummy name for G.
9208 C JROOT = integer array of length NG for output of root information.
9209 C See next paragraph.
9210 C Note that the main program must declare arrays Y, RWORK, IWORK,
9211 C JROOT, and possibly ATOL.
9212 C
9213 C F. The output from the first call (or any call) is:
9214 C Y = array of computed values of y(t) vector.
9215 C T = corresponding value of independent variable (normally TOUT).
9216 C ISTATE = 2 or 3 if DLSODKR was successful, negative otherwise.
9217 C 2 means no root was found, and TOUT was reached as desired.
9218 C 3 means a root was found prior to reaching TOUT.
9219 C -1 means excess work done on this call (perhaps wrong MF).
9220 C -2 means excess accuracy requested (tolerances too small).
9221 C -3 means illegal input detected (see printed message).
9222 C -4 means repeated error test failures (check all inputs).
9223 C -5 means repeated convergence failures (perhaps bad JAC
9224 C or PSOL routine supplied or wrong choice of MF or
9225 C tolerances, or this solver is inappropriate).
9226 C -6 means error weight became zero during problem. (Solution
9227 C component i vanished, and ATOL or ATOL(i) = 0.)
9228 C -7 means an unrecoverable error occurred in PSOL.
9229 C JROOT = array showing roots found if ISTATE = 3 on return.
9230 C JROOT(i) = 1 if g(i) has a root at T, or 0 otherwise.
9231 C
9232 C G. To continue the integration after a successful return, proceed
9233 C as follows:
9234 C (a) If ISTATE = 2 on return, reset TOUT and call DLSODKR again.
9235 C (b) If ISTATE = 3 on return, reset ISTATE to 2 and call DLSODKR again.
9236 C In either case, no other parameters need be reset.
9237 C
9238 C-----------------------------------------------------------------------
9239 C-----------------------------------------------------------------------
9240 C Full Description of User Interface to DLSODKR.
9241 C
9242 C The user interface to DLSODKR consists of the following parts.
9243 C
9244 C 1. The call sequence to Subroutine DLSODKR, which is a driver
9245 C routine for the solver. This includes descriptions of both
9246 C the call sequence arguments and of user-supplied routines.
9247 C Following these descriptions is a description of
9248 C optional inputs available through the call sequence, and then
9249 C a description of optional outputs (in the work arrays).
9250 C
9251 C 2. Descriptions of other routines in the DLSODKR package that may be
9252 C (optionally) called by the user. These provide the ability to
9253 C alter error message handling, save and restore the internal
9254 C Common, and obtain specified derivatives of the solution y(t).
9255 C
9256 C 3. Descriptions of Common blocks to be declared in overlay
9257 C or similar environments, or to be saved when doing an interrupt
9258 C of the problem and continued solution later.
9259 C
9260 C 4. Description of two routines in the DLSODKR package, either of
9261 C which the user may replace with his/her own version, if desired.
9262 C These relate to the measurement of errors.
9263 C
9264 C-----------------------------------------------------------------------
9265 C Part 1. Call Sequence.
9266 C
9267 C The call sequence parameters used for input only are
9268 C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, PSOL, MF,
9269 C G, and NG,
9270 C that used only for output is JROOT,
9271 C and those used for both input and output are
9272 C Y, T, ISTATE.
9273 C The work arrays RWORK and IWORK are also used for conditional and
9274 C optional inputs and optional outputs. (The term output here refers
9275 C to the return from Subroutine DLSODKR to the user's calling program.)
9276 C
9277 C The legality of input parameters will be thoroughly checked on the
9278 C initial call for the problem, but not checked thereafter unless a
9279 C change in input parameters is flagged by ISTATE = 3 on input.
9280 C
9281 C The descriptions of the call arguments are as follows.
9282 C
9283 C F = the name of the user-supplied subroutine defining the
9284 C ODE system. The system must be put in the first-order
9285 C form dy/dt = f(t,y), where f is a vector-valued function
9286 C of the scalar t and the vector y. Subroutine F is to
9287 C compute the function f. It is to have the form
9288 C SUBROUTINE F (NEQ, T, Y, YDOT)
9289 C DOUBLE PRECISION T, Y(*), YDOT(*)
9290 C where NEQ, T, and Y are input, and the array YDOT = f(t,y)
9291 C is output. Y and YDOT are arrays of length NEQ.
9292 C Subroutine F should not alter Y(1),...,Y(NEQ).
9293 C F must be declared External in the calling program.
9294 C
9295 C Subroutine F may access user-defined quantities in
9296 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array
9297 C (dimensioned in F) and/or Y has length exceeding NEQ(1).
9298 C See the descriptions of NEQ and Y below.
9299 C
9300 C If quantities computed in the F routine are needed
9301 C externally to DLSODKR, an extra call to F should be made
9302 C for this purpose, for consistent and accurate results.
9303 C If only the derivative dy/dt is needed, use DINTDY instead.
9304 C
9305 C NEQ = the size of the ODE system (number of first order
9306 C ordinary differential equations). Used only for input.
9307 C NEQ may be decreased, but not increased, during the problem.
9308 C If NEQ is decreased (with ISTATE = 3 on input), the
9309 C remaining components of Y should be left undisturbed, if
9310 C these are to be accessed in the user-supplied routines.
9311 C
9312 C Normally, NEQ is a scalar, and it is generally referred to
9313 C as a scalar in this user interface description. However,
9314 C NEQ may be an array, with NEQ(1) set to the system size.
9315 C (The DLSODKR package accesses only NEQ(1).) In either case,
9316 C this parameter is passed as the NEQ argument in all calls
9317 C to the user-supplied routines. Hence, if it is an array,
9318 C locations NEQ(2),... may be used to store other integer data
9319 C and pass it to the user-supplied routines. Each such routine
9320 C must include NEQ in a Dimension statement in that case.
9321 C
9322 C Y = a real array for the vector of dependent variables, of
9323 C length NEQ or more. Used for both input and output on the
9324 C first call (ISTATE = 1), and only for output on other calls.
9325 C On the first call, Y must contain the vector of initial
9326 C values. On output, Y contains the computed solution vector,
9327 C evaluated at T. If desired, the Y array may be used
9328 C for other purposes between calls to the solver.
9329 C
9330 C This array is passed as the Y argument in all calls to F, G,
9331 C JAC, and PSOL. Hence its length may exceed NEQ, and
9332 C locations Y(NEQ+1),... may be used to store other real data
9333 C and pass it to the user-supplied routines.
9334 C (The DLSODKR package accesses only Y(1),...,Y(NEQ).)
9335 C
9336 C T = the independent variable. On input, T is used only on the
9337 C first call, as the initial point of the integration.
9338 C On output, after each call, T is the value at which a
9339 C computed solution y is evaluated (usually the same as TOUT).
9340 C If a root was found, T is the computed location of the
9341 C root reached first, on output.
9342 C On an error return, T is the farthest point reached.
9343 C
9344 C TOUT = the next value of t at which a computed solution is desired.
9345 C Used only for input.
9346 C
9347 C When starting the problem (ISTATE = 1), TOUT may be equal
9348 C to T for one call, then should .ne. T for the next call.
9349 C For the initial T, an input value of TOUT .ne. T is used
9350 C in order to determine the direction of the integration
9351 C (i.e. the algebraic sign of the step sizes) and the rough
9352 C scale of the problem. Integration in either direction
9353 C (forward or backward in t) is permitted.
9354 C
9355 C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after
9356 C the first call (i.e. the first call with TOUT .ne. T).
9357 C Otherwise, TOUT is required on every call.
9358 C
9359 C If ITASK = 1, 3, or 4, the values of TOUT need not be
9360 C monotone, but a value of TOUT which backs up is limited
9361 C to the current internal T interval, whose endpoints are
9362 C TCUR - HU and TCUR (see optional outputs, below, for
9363 C TCUR and HU).
9364 C
9365 C ITOL = an indicator for the type of error control. See
9366 C description below under ATOL. Used only for input.
9367 C
9368 C RTOL = a relative error tolerance parameter, either a scalar or
9369 C an array of length NEQ. See description below under ATOL.
9370 C Input only.
9371 C
9372 C ATOL = an absolute error tolerance parameter, either a scalar or
9373 C an array of length NEQ. Input only.
9374 C
9375 C The input parameters ITOL, RTOL, and ATOL determine
9376 C the error control performed by the solver. The solver will
9377 C control the vector E = (E(i)) of estimated local errors
9378 C in y, according to an inequality of the form
9379 C RMS-norm of ( E(i)/EWT(i) ) .le. 1,
9380 C where EWT(i) = RTOL(i)*ABS(Y(i)) + ATOL(i),
9381 C and the RMS-norm (root-mean-square norm) here is
9382 C RMS-norm(v) = SQRT(sum v(i)**2 / NEQ). Here EWT = (EWT(i))
9383 C is a vector of weights which must always be positive, and
9384 C the values of RTOL and ATOL should all be non-negative.
9385 C The following table gives the types (scalar/array) of
9386 C RTOL and ATOL, and the corresponding form of EWT(i).
9387 C
9388 C ITOL RTOL ATOL EWT(i)
9389 C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL
9390 C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i)
9391 C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL
9392 C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i)
9393 C
9394 C When either of these parameters is a scalar, it need not
9395 C be dimensioned in the user's calling program.
9396 C
9397 C If none of the above choices (with ITOL, RTOL, and ATOL
9398 C fixed throughout the problem) is suitable, more general
9399 C error controls can be obtained by substituting
9400 C user-supplied routines for the setting of EWT and/or for
9401 C the norm calculation. See Part 4 below.
9402 C
9403 C If global errors are to be estimated by making a repeated
9404 C run on the same problem with smaller tolerances, then all
9405 C components of RTOL and ATOL (i.e. of EWT) should be scaled
9406 C down uniformly.
9407 C
9408 C ITASK = an index specifying the task to be performed.
9409 C Input only. ITASK has the following values and meanings.
9410 C 1 means normal computation of output values of y(t) at
9411 C t = TOUT (by overshooting and interpolating).
9412 C 2 means take one step only and return.
9413 C 3 means stop at the first internal mesh point at or
9414 C beyond t = TOUT and return.
9415 C 4 means normal computation of output values of y(t) at
9416 C t = TOUT but without overshooting t = TCRIT.
9417 C TCRIT must be input as RWORK(1). TCRIT may be equal to
9418 C or beyond TOUT, but not behind it in the direction of
9419 C integration. This option is useful if the problem
9420 C has a singularity at or beyond t = TCRIT.
9421 C 5 means take one step, without passing TCRIT, and return.
9422 C TCRIT must be input as RWORK(1).
9423 C
9424 C Note: If ITASK = 4 or 5 and the solver reaches TCRIT
9425 C (within roundoff), it will return T = TCRIT (exactly) to
9426 C indicate this (unless ITASK = 4 and TOUT comes before TCRIT,
9427 C in which case answers at T = TOUT are returned first).
9428 C
9429 C ISTATE = an index used for input and output to specify the
9430 C the state of the calculation.
9431 C
9432 C On input, the values of ISTATE are as follows.
9433 C 1 means this is the first call for the problem
9434 C (initializations will be done). See note below.
9435 C 2 means this is not the first call, and the calculation
9436 C is to continue normally, with no change in any input
9437 C parameters except possibly TOUT and ITASK.
9438 C (If ITOL, RTOL, and/or ATOL are changed between calls
9439 C with ISTATE = 2, the new values will be used but not
9440 C tested for legality.)
9441 C 3 means this is not the first call, and the
9442 C calculation is to continue normally, but with
9443 C a change in input parameters other than
9444 C TOUT and ITASK. Changes are allowed in
9445 C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF,
9446 C and any of the optional inputs except H0.
9447 C In addition, immediately following a return with
9448 C ISTATE = 3 (root found), NG and G may be changed.
9449 C (But changing NG from 0 to .gt. 0 is not allowed.)
9450 C Note: A preliminary call with TOUT = T is not counted
9451 C as a first call here, as no initialization or checking of
9452 C input is done. (Such a call is sometimes useful for the
9453 C purpose of outputting the initial conditions.)
9454 C Thus the first call for which TOUT .ne. T requires
9455 C ISTATE = 1 on input.
9456 C
9457 C On output, ISTATE has the following values and meanings.
9458 C 1 means nothing was done; TOUT = T and ISTATE = 1 on input.
9459 C 2 means the integration was performed successfully.
9460 C 3 means the integration was successful, and one or more
9461 C roots were found before satisfying the stop condition
9462 C specified by ITASK. See JROOT.
9463 C -1 means an excessive amount of work (more than MXSTEP
9464 C steps) was done on this call, before completing the
9465 C requested task, but the integration was otherwise
9466 C successful as far as T. (MXSTEP is an optional input
9467 C and is normally 500.) To continue, the user may
9468 C simply reset ISTATE to a value .gt. 1 and call again
9469 C (the excess work step counter will be reset to 0).
9470 C In addition, the user may increase MXSTEP to avoid
9471 C this error return (see below on optional inputs).
9472 C -2 means too much accuracy was requested for the precision
9473 C of the machine being used. This was detected before
9474 C completing the requested task, but the integration
9475 C was successful as far as T. To continue, the tolerance
9476 C parameters must be reset, and ISTATE must be set
9477 C to 3. The optional output TOLSF may be used for this
9478 C purpose. (Note: If this condition is detected before
9479 C taking any steps, then an illegal input return
9480 C (ISTATE = -3) occurs instead.)
9481 C -3 means illegal input was detected, before taking any
9482 C integration steps. See written message for details.
9483 C Note: If the solver detects an infinite loop of calls
9484 C to the solver with illegal input, it will cause
9485 C the run to stop.
9486 C -4 means there were repeated error test failures on
9487 C one attempted step, before completing the requested
9488 C task, but the integration was successful as far as T.
9489 C The problem may have a singularity, or the input
9490 C may be inappropriate.
9491 C -5 means there were repeated convergence test failures on
9492 C one attempted step, before completing the requested
9493 C task, but the integration was successful as far as T.
9494 C -6 means EWT(i) became zero for some i during the
9495 C integration. Pure relative error control (ATOL(i)=0.0)
9496 C was requested on a variable which has now vanished.
9497 C The integration was successful as far as T.
9498 C -7 means the PSOL routine returned an unrecoverable error
9499 C flag (IER .lt. 0). The integration was successful as
9500 C far as T.
9501 C
9502 C Note: Since the normal output value of ISTATE is 2,
9503 C it does not need to be reset for normal continuation.
9504 C Also, since a negative input value of ISTATE will be
9505 C regarded as illegal, a negative output value requires the
9506 C user to change it, and possibly other inputs, before
9507 C calling the solver again.
9508 C
9509 C IOPT = an integer flag to specify whether or not any optional
9510 C inputs are being used on this call. Input only.
9511 C The optional inputs are listed separately below.
9512 C IOPT = 0 means no optional inputs are being used.
9513 C Default values will be used in all cases.
9514 C IOPT = 1 means one or more optional inputs are being used.
9515 C
9516 C RWORK = a real working array (double precision).
9517 C The length of RWORK must be at least
9518 C 20 + NYH*(MAXORD+1) + 3*NEQ + 3*NG + LENLS + LWP where
9519 C NYH = the initial value of NEQ,
9520 C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a
9521 C smaller value is given as an optional input),
9522 C LENLS = length of work space for linear system (Krylov)
9523 C method, excluding preconditioning:
9524 C LENLS = 0 if MITER = 0,
9525 C LENLS = NEQ*(MAXL+3) + MAXL**2 if MITER = 1,
9526 C LENLS = NEQ*(MAXL+3+MIN(1,MAXL-KMP))
9527 C + (MAXL+3)*MAXL + 1 if MITER = 2,
9528 C LENLS = 6*NEQ if MITER = 3 or 4,
9529 C LENLS = 3*NEQ if MITER = 9.
9530 C (See the MF description for METH and MITER, and the
9531 C list of optional inputs for MAXL and KMP.)
9532 C LWP = length of real user work space for preconditioning
9533 C (see JAC/PSOL).
9534 C Thus if default values are used and NEQ is constant,
9535 C this length is:
9536 C 20 + 16*NEQ + 3*NG for MF = 10,
9537 C 45 + 24*NEQ + 3*NG + LWP for MF = 11,
9538 C 61 + 24*NEQ + 3*NG + LWP for MF = 12,
9539 C 20 + 22*NEQ + 3*NG + LWP for MF = 13 or 14,
9540 C 20 + 19*NEQ + 3*NG + LWP for MF = 19,
9541 C 20 + 9*NEQ + 3*NG for MF = 20,
9542 C 45 + 17*NEQ + 3*NG + LWP for MF = 21,
9543 C 61 + 17*NEQ + 3*NG + LWP for MF = 22,
9544 C 20 + 15*NEQ + 3*NG + LWP for MF = 23 or 24,
9545 C 20 + 12*NEQ + 3*NG + LWP for MF = 29.
9546 C The first 20 words of RWORK are reserved for conditional
9547 C and optional inputs and optional outputs.
9548 C
9549 C The following word in RWORK is a conditional input:
9550 C RWORK(1) = TCRIT = critical value of t which the solver
9551 C is not to overshoot. Required if ITASK is
9552 C 4 or 5, and ignored otherwise. (See ITASK.)
9553 C
9554 C LRW = the length of the array RWORK, as declared by the user.
9555 C (This will be checked by the solver.)
9556 C
9557 C IWORK = an integer work array. The length of IWORK must be at least
9558 C 30 if MITER = 0 (MF = 10 or 20),
9559 C 30 + MAXL + LIWP if MITER = 1 (MF = 11, 21),
9560 C 30 + LIWP if MITER = 2, 3, 4, or 9.
9561 C MAXL = 5 unless a different optional input value is given.
9562 C LIWP = length of integer user work space for preconditioning
9563 C (see conditional input list following).
9564 C The first few words of IWORK are used for conditional and
9565 C optional inputs and optional outputs.
9566 C
9567 C The following 4 words in IWORK are conditional inputs,
9568 C required if MITER .ge. 1:
9569 C IWORK(1) = LWP = length of real array WP for use in
9570 C preconditioning (part of RWORK array).
9571 C IWORK(2) = LIWP = length of integer array IWP for use in
9572 C preconditioning (part of IWORK array).
9573 C The arrays WP and IWP are work arrays under the
9574 C user's control, for use in the routines that
9575 C perform preconditioning operations (JAC and PSOL).
9576 C IWORK(3) = JPRE = preconditioner type flag:
9577 C = 0 for no preconditioning (P1 = P2 = P = identity)
9578 C = 1 for left-only preconditioning (P2 = identity)
9579 C = 2 for right-only preconditioning (P1 = identity)
9580 C = 3 for two-sided preconditioning (and PCG or PCGS)
9581 C IWORK(4) = JACFLG = flag for whether JAC is called.
9582 C = 0 if JAC is not to be called,
9583 C = 1 if JAC is to be called.
9584 C Use JACFLG = 1 if JAC computes any nonconstant
9585 C data needed in preconditioning operations,
9586 C such as some of the Jacobian elements.
9587 C
9588 C LIW = the length of the array IWORK, as declared by the user.
9589 C (This will be checked by the solver.)
9590 C
9591 C Note: The work arrays must not be altered between calls to DLSODKR
9592 C for the same problem, except possibly for the conditional and
9593 C optional inputs, and except for the last 3*NEQ words of RWORK.
9594 C The latter space is used for internal scratch space, and so is
9595 C available for use by the user outside DLSODKR between calls, if
9596 C desired (but not for use by any of the user-supplied routines).
9597 C
9598 C JAC = the name of the user-supplied routine to compute any
9599 C Jacobian elements (or approximations) involved in the
9600 C matrix preconditioning operations (MITER .ge. 1).
9601 C It is to have the form
9602 C SUBROUTINE JAC (F, NEQ, T, Y, YSV, REWT, FTY, V,
9603 C 1 HL0, JOK, WP, IWP, IER)
9604 C DOUBLE PRECISION T, Y(*), YSV(*), REWT(*), FTY(*), V(*),
9605 C 1 HL0, WP(*)
9606 C INTEGER IWP(*)
9607 C This routine must evaluate and preprocess any parts of the
9608 C Jacobian matrix df/dy used in the preconditioners P1, P2, P.
9609 C The Y and FTY arrays contain the current values of y and
9610 C f(t,y), respectively, and the YSV array also contains
9611 C the current y vector. The array V is work space of length
9612 C NEQ for use by JAC. REWT is the array of reciprocal error
9613 C weights (1/EWT). JAC must multiply all computed Jacobian
9614 C elements by the scalar -HL0, add the identity matrix, and do
9615 C any factorization operations called for, in preparation
9616 C for solving linear systems with a coefficient matrix of
9617 C P1, P2, or P. The matrix P1*P2 or P should be an
9618 C approximation to identity - hl0 * (df/dy). JAC should
9619 C return IER = 0 if successful, and IER .ne. 0 if not.
9620 C (If IER .ne. 0, a smaller time step will be tried.)
9621 C The arrays WP (of length LWP) and IWP (of length LIWP)
9622 C are for use by JAC and PSOL for work space and for storage
9623 C of data needed for the solution of the preconditioner
9624 C linear systems. Their lengths and contents are under the
9625 C user's control.
9626 C The argument JOK is an input flag for optional use
9627 C by JAC in deciding whether to recompute Jacobian elements
9628 C or use saved values. If JOK = -1, then JAC must compute
9629 C any relevant Jacobian elements (or approximations) used in
9630 C the preconditioners. Optionally, JAC may also save these
9631 C elements for later reuse. If JOK = 1, the integrator has
9632 C made a judgement (based on the convergence history and the
9633 C value of HL0) that JAC need not recompute Jacobian elements,
9634 C but instead use saved values, and the current value of HL0,
9635 C to reconstruct the preconditioner matrices, followed by
9636 C any required factorizations. This may be cost-effective if
9637 C Jacobian elements are costly and storage is available.
9638 C JAC may alter Y and V, but not YSV, REWT, FTY, or HL0.
9639 C JAC must be declared External in the calling program.
9640 C Subroutine JAC may access user-defined quantities in
9641 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array
9642 C (dimensioned in JAC) and/or Y has length exceeding NEQ(1).
9643 C See the descriptions of NEQ and Y above.
9644 C
9645 C PSOL = the name of the user-supplied routine for the
9646 C solution of preconditioner linear systems.
9647 C It is to have the form
9648 C SUBROUTINE PSOL (NEQ, T, Y, FTY, WK,HL0, WP,IWP, B, LR,IER)
9649 C DOUBLE PRECISION T, Y(*), FTY(*), WK(*), HL0, WP(*), B(*)
9650 C INTEGER IWP(*)
9651 C This routine must solve a linear system with B as right-hand
9652 C side and one of the preconditioning matrices, P1, P2, or P,
9653 C as coefficient matrix, and return the solution vector in B.
9654 C LR is a flag concerning left vs right preconditioning, input
9655 C to PSOL. PSOL is to use P1 if LR = 1 and P2 if LR = 2.
9656 C In the case of the PCG or PCGS method, LR will be 3, and PSOL
9657 C should solve the system P*x = B with the preconditioner P.
9658 C In the case MITER = 9 (no Krylov iteration), LR will be 0,
9659 C and PSOL is to return in B the desired approximate solution
9660 C to A * x = B, where A = identity - hl0 * (df/dy).
9661 C PSOL can use data generated in the JAC routine and stored in
9662 C WP and IWP.
9663 C The Y and FTY arrays contain the current values of y and
9664 C f(t,y), respectively. The array WK is work space of length
9665 C NEQ for use by PSOL.
9666 C The argument HL0 is the current value of the scalar appearing
9667 C in the linear system. If the old value, as of the last
9668 C JAC call, is needed, it must have been saved by JAC in WP.
9669 C On return, PSOL should set the error flag IER as follows:
9670 C IER = 0 if PSOL was successful,
9671 C IER .gt. 0 on a recoverable error, meaning that the
9672 C time step will be retried,
9673 C IER .lt. 0 on an unrecoverable error, meaning that the
9674 C solver is to stop immediately.
9675 C PSOL may not alter Y, FTY, or HL0.
9676 C PSOL must be declared External in the calling program.
9677 C Subroutine PSOL may access user-defined quantities in
9678 C NEQ(2),... and Y(NEQ(1)+1),... if NEQ is an array
9679 C (dimensioned in PSOL) and/or Y has length exceeding NEQ(1).
9680 C See the descriptions of NEQ and Y above.
9681 C
9682 C MF = the method flag. Used only for input. The legal values of
9683 C MF are 10, 11, 12, 13, 14, 19, 20, 21, 22, 23, 24, and 29.
9684 C MF has decimal digits METH and MITER: MF = 10*METH + MITER.
9685 C METH indicates the basic linear multistep method:
9686 C METH = 1 means the implicit Adams method.
9687 C METH = 2 means the method based on Backward
9688 C Differentiation Formulas (BDFs).
9689 C MITER indicates the corrector iteration method:
9690 C MITER = 0 means functional iteration (no linear system
9691 C is involved).
9692 C MITER = 1 means Newton iteration with Scaled Preconditioned
9693 C Incomplete Orthogonalization Method (SPIOM)
9694 C for the linear systems.
9695 C MITER = 2 means Newton iteration with Scaled Preconditioned
9696 C Incomplete Generalized Minimal Residual method
9697 C (SPIGMR) for the linear systems.
9698 C MITER = 3 means Newton iteration with Preconditioned
9699 C Conjugate Gradient method (PCG)
9700 C for the linear systems.
9701 C MITER = 4 means Newton iteration with scaled preconditioned
9702 C Conjugate Gradient method (PCGS)
9703 C for the linear systems.
9704 C MITER = 9 means Newton iteration with only the
9705 C user-supplied PSOL routine called (no Krylov
9706 C iteration) for the linear systems.
9707 C JPRE is ignored, and PSOL is called with LR = 0.
9708 C See comments in the introduction about the choice of MITER.
9709 C If MITER .ge. 1, the user must supply routines JAC and PSOL
9710 C (the names are arbitrary) as described above.
9711 C For MITER = 0, a dummy argument can be used.
9712 C
9713 C G = the name of subroutine for constraint functions, whose
9714 C roots are desired during the integration. It is to have
9715 C the form
9716 C SUBROUTINE G (NEQ, T, Y, NG, GOUT)
9717 C DOUBLE PRECISION T, Y(*), GOUT(NG)
9718 C where NEQ, T, Y, and NG are input, and the array GOUT
9719 C is output. NEQ, T, and Y have the same meaning as in
9720 C the F routine, and GOUT is an array of length NG.
9721 C For i = 1,...,NG, this routine is to load into GOUT(i)
9722 C the value at (t,y) of the i-th constraint function g(i).
9723 C DLSODKR will find roots of the g(i) of odd multiplicity
9724 C (i.e. sign changes) as they occur during the integration.
9725 C G must be declared External in the calling program.
9726 C
9727 C Caution: Because of numerical errors in the functions
9728 C g(i) due to roundoff and integration error, DLSODKR may
9729 C return false roots, or return the same root at two or more
9730 C nearly equal values of t. If such false roots are
9731 C suspected, the user should consider smaller error tolerances
9732 C and/or higher precision in the evaluation of the g(i).
9733 C
9734 C If a root of some g(i) defines the end of the problem,
9735 C the input to DLSODKR should nevertheless allow integration
9736 C to a point slightly past that root, so that DLSODKR can
9737 C locate the root by interpolation.
9738 C
9739 C Subroutine G may access user-defined quantities in
9740 C NEQ(2),... and Y(NEQ(1)+1),... if NEQ is an array
9741 C (dimensioned in G) and/or Y has length exceeding NEQ(1).
9742 C See the descriptions of NEQ and Y above.
9743 C
9744 C NG = number of constraint functions g(i). If there are none,
9745 C set NG = 0, and pass a dummy name for G.
9746 C
9747 C JROOT = integer array of length NG. Used only for output.
9748 C On a return with ISTATE = 3 (one or more roots found),
9749 C JROOT(i) = 1 if g(i) has a root at t, or JROOT(i) = 0 if not.
9750 C-----------------------------------------------------------------------
9751 C Optional Inputs.
9752 C
9753 C The following is a list of the optional inputs provided for in the
9754 C call sequence. (See also Part 2.) For each such input variable,
9755 C this table lists its name as used in this documentation, its
9756 C location in the call sequence, its meaning, and the default value.
9757 C The use of any of these inputs requires IOPT = 1, and in that
9758 C case all of these inputs are examined. A value of zero for any
9759 C of these optional inputs will cause the default value to be used.
9760 C Thus to use a subset of the optional inputs, simply preload
9761 C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and
9762 C then set those of interest to nonzero values.
9763 C
9764 C Name Location Meaning and Default Value
9765 C
9766 C H0 RWORK(5) the step size to be attempted on the first step.
9767 C The default value is determined by the solver.
9768 C
9769 C HMAX RWORK(6) the maximum absolute step size allowed.
9770 C The default value is infinite.
9771 C
9772 C HMIN RWORK(7) the minimum absolute step size allowed.
9773 C The default value is 0. (This lower bound is not
9774 C enforced on the final step before reaching TCRIT
9775 C when ITASK = 4 or 5.)
9776 C
9777 C DELT RWORK(8) convergence test constant in Krylov iteration
9778 C algorithm. The default is .05.
9779 C
9780 C MAXORD IWORK(5) the maximum order to be allowed. The default
9781 C value is 12 if METH = 1, and 5 if METH = 2.
9782 C If MAXORD exceeds the default value, it will
9783 C be reduced to the default value.
9784 C If MAXORD is changed during the problem, it may
9785 C cause the current order to be reduced.
9786 C
9787 C MXSTEP IWORK(6) maximum number of (internally defined) steps
9788 C allowed during one call to the solver.
9789 C The default value is 500.
9790 C
9791 C MXHNIL IWORK(7) maximum number of messages printed (per problem)
9792 C warning that T + H = T on a step (H = step size).
9793 C This must be positive to result in a non-default
9794 C value. The default value is 10.
9795 C
9796 C MAXL IWORK(8) maximum number of iterations in the SPIOM, SPIGMR,
9797 C PCG, or PCGS algorithm (.le. NEQ).
9798 C The default is MAXL = MIN(5,NEQ).
9799 C
9800 C KMP IWORK(9) number of vectors on which orthogonalization
9801 C is done in SPIOM or SPIGMR algorithm (.le. MAXL).
9802 C The default is KMP = MAXL.
9803 C Note: When KMP .lt. MAXL and MF = 22, the length
9804 C of RWORK must be defined accordingly. See
9805 C the definition of RWORK above.
9806 C-----------------------------------------------------------------------
9807 C Optional Outputs.
9808 C
9809 C As optional additional output from DLSODKR, the variables listed
9810 C below are quantities related to the performance of DLSODKR
9811 C which are available to the user. These are communicated by way of
9812 C the work arrays, but also have internal mnemonic names as shown.
9813 C Except where stated otherwise, all of these outputs are defined
9814 C on any successful return from DLSODKR, and on any return with
9815 C ISTATE = -1, -2, -4, -5, -6, or -7. On an illegal input return
9816 C (ISTATE = -3), they will be unchanged from their existing values
9817 C (if any), except possibly for TOLSF, LENRW, and LENIW.
9818 C On any error return, outputs relevant to the error will be defined,
9819 C as noted below.
9820 C
9821 C Name Location Meaning
9822 C
9823 C HU RWORK(11) the step size in t last used (successfully).
9824 C
9825 C HCUR RWORK(12) the step size to be attempted on the next step.
9826 C
9827 C TCUR RWORK(13) the current value of the independent variable
9828 C which the solver has actually reached, i.e. the
9829 C current internal mesh point in t. On output, TCUR
9830 C will always be at least as far as the argument
9831 C T, but may be farther (if interpolation was done).
9832 C
9833 C TOLSF RWORK(14) a tolerance scale factor, greater than 1.0,
9834 C computed when a request for too much accuracy was
9835 C detected (ISTATE = -3 if detected at the start of
9836 C the problem, ISTATE = -2 otherwise). If ITOL is
9837 C left unaltered but RTOL and ATOL are uniformly
9838 C scaled up by a factor of TOLSF for the next call,
9839 C then the solver is deemed likely to succeed.
9840 C (The user may also ignore TOLSF and alter the
9841 C tolerance parameters in any other way appropriate.)
9842 C
9843 C NGE IWORK(10) the number of g evaluations for the problem so far.
9844 C
9845 C NST IWORK(11) the number of steps taken for the problem so far.
9846 C
9847 C NFE IWORK(12) the number of f evaluations for the problem so far.
9848 C
9849 C NPE IWORK(13) the number of calls to JAC so far (for evaluation
9850 C of preconditioners).
9851 C
9852 C NQU IWORK(14) the method order last used (successfully).
9853 C
9854 C NQCUR IWORK(15) the order to be attempted on the next step.
9855 C
9856 C IMXER IWORK(16) the index of the component of largest magnitude in
9857 C the weighted local error vector ( E(i)/EWT(i) ),
9858 C on an error return with ISTATE = -4 or -5.
9859 C
9860 C LENRW IWORK(17) the length of RWORK actually required.
9861 C This is defined on normal returns and on an illegal
9862 C input return for insufficient storage.
9863 C
9864 C LENIW IWORK(18) the length of IWORK actually required.
9865 C This is defined on normal returns and on an illegal
9866 C input return for insufficient storage.
9867 C
9868 C NNI IWORK(19) number of nonlinear iterations so far (each of
9869 C which calls an iterative linear solver).
9870 C
9871 C NLI IWORK(20) number of linear iterations so far.
9872 C Note: A measure of the success of algorithm is
9873 C the average number of linear iterations per
9874 C nonlinear iteration, given by NLI/NNI.
9875 C If this is close to MAXL, MAXL may be too small.
9876 C
9877 C NPS IWORK(21) number of preconditioning solve operations
9878 C (PSOL calls) so far.
9879 C
9880 C NCFN IWORK(22) number of convergence failures of the nonlinear
9881 C (Newton) iteration so far.
9882 C Note: A measure of success is the overall
9883 C rate of nonlinear convergence failures, NCFN/NST.
9884 C
9885 C NCFL IWORK(23) number of convergence failures of the linear
9886 C iteration so far.
9887 C Note: A measure of success is the overall
9888 C rate of linear convergence failures, NCFL/NNI.
9889 C
9890 C NSFI IWORK(24) number of functional iteration steps so far.
9891 C Note: A measure of the extent to which the
9892 C problem is nonstiff is the ratio NSFI/NST.
9893 C
9894 C NJEV IWORK(25) number of JAC calls with JOK = -1 so far
9895 C (number of evaluations of Jacobian data).
9896 C
9897 C The following two arrays are segments of the RWORK array which
9898 C may also be of interest to the user as optional outputs.
9899 C For each array, the table below gives its internal name,
9900 C its base address in RWORK, and its description.
9901 C
9902 C Name Base Address Description
9903 C
9904 C YH 21 + 3*NG the Nordsieck history array, of size NYH by
9905 C (NQCUR + 1), where NYH is the initial value
9906 C of NEQ. For j = 0,1,...,NQCUR, column j+1
9907 C of YH contains HCUR**j/factorial(j) times
9908 C the j-th derivative of the interpolating
9909 C polynomial currently representing the solution,
9910 C evaluated at t = TCUR.
9911 C
9912 C ACOR LENRW-NEQ+1 array of size NEQ used for the accumulated
9913 C corrections on each step, scaled on output
9914 C to represent the estimated local error in y
9915 C on the last step. This is the vector E in
9916 C the description of the error control. It is
9917 C defined only on a successful return from
9918 C DLSODKR.
9919 C
9920 C-----------------------------------------------------------------------
9921 C Part 2. Other Routines Callable.
9922 C
9923 C The following are optional calls which the user may make to
9924 C gain additional capabilities in conjunction with DLSODKR.
9925 C (The routines XSETUN and XSETF are designed to conform to the
9926 C SLATEC error handling package.)
9927 C
9928 C Form of Call Function
9929 C CALL XSETUN(LUN) Set the logical unit number, LUN, for
9930 C output of messages from DLSODKR, if
9931 C the default is not desired.
9932 C The default value of LUN is 6.
9933 C
9934 C CALL XSETF(MFLAG) Set a flag to control the printing of
9935 C messages by DLSODKR.
9936 C MFLAG = 0 means do not print. (Danger:
9937 C This risks losing valuable information.)
9938 C MFLAG = 1 means print (the default).
9939 C
9940 C Either of the above calls may be made at
9941 C any time and will take effect immediately.
9942 C
9943 C CALL DSRCKR(RSAV,ISAV,JOB) saves and restores the contents of
9944 C the internal Common blocks used by
9945 C DLSODKR (see Part 3 below).
9946 C RSAV must be a real array of length 228
9947 C or more, and ISAV must be an integer
9948 C array of length 63 or more.
9949 C JOB=1 means save Common into RSAV/ISAV.
9950 C JOB=2 means restore Common from RSAV/ISAV.
9951 C DSRCKR is useful if one is
9952 C interrupting a run and restarting
9953 C later, or alternating between two or
9954 C more problems solved with DLSODKR.
9955 C
9956 C CALL DINTDY(,,,,,) Provide derivatives of y, of various
9957 C (see below) orders, at a specified point t, if
9958 C desired. It may be called only after
9959 C a successful return from DLSODKR.
9960 C
9961 C The detailed instructions for using DINTDY are as follows.
9962 C The form of the call is:
9963 C
9964 C LYH = 21 + 3*NG
9965 C CALL DINTDY (T, K, RWORK(LYH), NYH, DKY, IFLAG)
9966 C
9967 C The input parameters are:
9968 C
9969 C T = value of independent variable where answers are desired
9970 C (normally the same as the T last returned by DLSODKR).
9971 C For valid results, T must lie between TCUR - HU and TCUR.
9972 C (See optional outputs for TCUR and HU.)
9973 C K = integer order of the derivative desired. K must satisfy
9974 C 0 .le. K .le. NQCUR, where NQCUR is the current order
9975 C (see optional outputs). The capability corresponding
9976 C to K = 0, i.e. computing y(T), is already provided
9977 C by DLSODKR directly. Since NQCUR .ge. 1, the first
9978 C derivative dy/dt is always available with DINTDY.
9979 C LYH = 21 + 3*NG = base address in RWORK of the history array YH.
9980 C NYH = column length of YH, equal to the initial value of NEQ.
9981 C
9982 C The output parameters are:
9983 C
9984 C DKY = a real array of length NEQ containing the computed value
9985 C of the K-th derivative of y(t).
9986 C IFLAG = integer flag, returned as 0 if K and T were legal,
9987 C -1 if K was illegal, and -2 if T was illegal.
9988 C On an error return, a message is also written.
9989 C-----------------------------------------------------------------------
9990 C Part 3. Common Blocks.
9991 C
9992 C If DLSODKR is to be used in an overlay situation, the user
9993 C must declare, in the primary overlay, the variables in:
9994 C (1) the call sequence to DLSODKR, and
9995 C (2) the four internal Common blocks
9996 C /DLS001/ of length 255 (218 double precision words
9997 C followed by 37 integer words),
9998 C /DLS002/ of length 5 (1 double precision word
9999 C followed by 4 integer words),
10000 C /DLPK01/ of length 17 (4 double precision words
10001 C followed by 13 integer words),
10002 C /DLSR01/ of length 14 (5 double precision words
10003 C followed by 9 integer words).
10004 C
10005 C If DLSODKR is used on a system in which the contents of internal
10006 C Common blocks are not preserved between calls, the user should
10007 C declare the above Common blocks in the calling program to insure
10008 C that their contents are preserved.
10009 C
10010 C If the solution of a given problem by DLSODKR is to be interrupted
10011 C and then later continued, such as when restarting an interrupted run
10012 C or alternating between two or more problems, the user should save,
10013 C following the return from the last DLSODKR call prior to the
10014 C interruption, the contents of the call sequence variables and the
10015 C internal Common blocks, and later restore these values before the
10016 C next DLSODKR call for that problem. To save and restore the Common
10017 C blocks, use Subroutine DSRCKR (see Part 2 above).
10018 C
10019 C-----------------------------------------------------------------------
10020 C Part 4. Optionally Replaceable Solver Routines.
10021 C
10022 C Below are descriptions of two routines in the DLSODKR package which
10023 C relate to the measurement of errors. Either routine can be
10024 C replaced by a user-supplied version, if desired. However, since such
10025 C a replacement may have a major impact on performance, it should be
10026 C done only when absolutely necessary, and only with great caution.
10027 C (Note: The means by which the package version of a routine is
10028 C superseded by the user's version may be system-dependent.)
10029 C
10030 C (a) DEWSET.
10031 C The following subroutine is called just before each internal
10032 C integration step, and sets the array of error weights, EWT, as
10033 C described under ITOL/RTOL/ATOL above:
10034 C SUBROUTINE DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT)
10035 C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODKR call sequence,
10036 C YCUR contains the current dependent variable vector, and
10037 C EWT is the array of weights set by DEWSET.
10038 C
10039 C If the user supplies this subroutine, it must return in EWT(i)
10040 C (i = 1,...,NEQ) a positive quantity suitable for comparing errors
10041 C in y(i) to. The EWT array returned by DEWSET is passed to the DVNORM
10042 C routine (see below), and also used by DLSODKR in the computation
10043 C of the optional output IMXER, the diagonal Jacobian approximation,
10044 C and the increments for difference quotient Jacobians.
10045 C
10046 C In the user-supplied version of DEWSET, it may be desirable to use
10047 C the current values of derivatives of y. Derivatives up to order NQ
10048 C are available from the history array YH, described above under
10049 C optional outputs. In DEWSET, YH is identical to the YCUR array,
10050 C extended to NQ + 1 columns with a column length of NYH and scale
10051 C factors of H**j/factorial(j). On the first call for the problem,
10052 C given by NST = 0, NQ is 1 and H is temporarily set to 1.0.
10053 C NYH is the initial value of NEQ. The quantities NQ, H, and NST
10054 C can be obtained by including in DEWSET the statements:
10055 C DOUBLE PRECISION RLS
10056 C COMMON /DLS001/ RLS(218),ILS(37)
10057 C NQ = ILS(33)
10058 C NST = ILS(34)
10059 C H = RLS(212)
10060 C Thus, for example, the current value of dy/dt can be obtained as
10061 C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is
10062 C unnecessary when NST = 0).
10063 C
10064 C (b) DVNORM.
10065 C The following is a real function routine which computes the weighted
10066 C root-mean-square norm of a vector v:
10067 C D = DVNORM (N, V, W)
10068 C where:
10069 C N = the length of the vector,
10070 C V = real array of length N containing the vector,
10071 C W = real array of length N containing weights,
10072 C D = SQRT( (1/N) * sum(V(i)*W(i))**2 ).
10073 C DVNORM is called with N = NEQ and with W(i) = 1.0/EWT(i), where
10074 C EWT is as set by Subroutine DEWSET.
10075 C
10076 C If the user supplies this function, it should return a non-negative
10077 C value of DVNORM suitable for use in the error control in DLSODKR.
10078 C None of the arguments should be altered by DVNORM.
10079 C For example, a user-supplied DVNORM routine might:
10080 C -substitute a max-norm of (V(i)*W(i)) for the RMS-norm, or
10081 C -ignore some components of V in the norm, with the effect of
10082 C suppressing the error control on those components of y.
10083 C-----------------------------------------------------------------------
10084 C
10085 C***REVISION HISTORY (YYYYMMDD)
10086 C 19900117 DATE WRITTEN
10087 C 19900503 Added iteration switching (functional/Newton).
10088 C 19900802 Added flag for Jacobian-saving in user preconditioner.
10089 C 19900910 Added new initial stepsize routine LHIN.
10090 C 19901019 Corrected LHIN - y array restored.
10091 C 19910909 Changed names STOPK to STOKA, PKSET to SETPK;
10092 C removed unused variables in driver declarations;
10093 C minor corrections to main prologue.
10094 C 20010425 Major update: convert source lines to upper case;
10095 C added *DECK lines; changed from 1 to * in dummy dimensions;
10096 C changed names R1MACH/D1MACH to RUMACH/DUMACH;
10097 C renamed routines for uniqueness across single/double prec.;
10098 C converted intrinsic names to generic form;
10099 C removed ILLIN and NTREP (data loaded) from Common;
10100 C removed all 'own' variables from Common;
10101 C changed error messages to quoted strings;
10102 C replaced XERRWV/XERRWD with 1993 revised version;
10103 C converted prologues, comments, error messages to mixed case;
10104 C numerous corrections to prologues and internal comments.
10105 C 20010507 Converted single precision source to double precision.
10106 C 20020502 Corrected declarations in descriptions of user routines.
10107 C 20030603 Corrected duplicate type declaration for DUMACH.
10108 C 20031105 Restored 'own' variables to Common blocks, to enable
10109 C interrupt/restart feature.
10110 C 20031112 Added SAVE statements for data-loaded constants.
10111 C 20031117 Changed internal name NPE to NJE.
10112 C
10113 C-----------------------------------------------------------------------
10114 C Other routines in the DLSODKR package.
10115 C
10116 C In addition to Subroutine DLSODKR, the DLSODKR package includes the
10117 C following subroutines and function routines:
10118 C DLHIN calculates a step size to be attempted initially.
10119 C DRCHEK does preliminary checking for roots, and serves as an
10120 C interface between Subroutine DLSODKR and Subroutine DROOTS.
10121 C DROOTS finds the leftmost root of a set of functions.
10122 C DINTDY computes an interpolated value of the y vector at t = TOUT.
10123 C DEWSET sets the error weight vector EWT before each step.
10124 C DVNORM computes the weighted RMS-norm of a vector.
10125 C DSTOKA is the core integrator, which does one step of the
10126 C integration and the associated error control.
10127 C DCFODE sets all method coefficients and test constants.
10128 C DSETPK interfaces between DSTOKA and the JAC routine.
10129 C DSOLPK manages solution of linear system in Newton iteration.
10130 C DSPIOM performs the SPIOM algorithm.
10131 C DATV computes a scaled, preconditioned product (I-hl0*J)*v.
10132 C DORTHOG orthogonalizes a vector against previous basis vectors.
10133 C DHEFA generates an LU factorization of a Hessenberg matrix.
10134 C DHESL solves a Hessenberg square linear system.
10135 C DSPIGMR performs the SPIGMR algorithm.
10136 C DHEQR generates a QR factorization of a Hessenberg matrix.
10137 C DHELS finds the least squares solution of a Hessenberg system.
10138 C DPCG performs preconditioned conjugate gradient algorithm (PCG).
10139 C DPCGS performs the PCGS algorithm.
10140 C DATP computes the product A*p, where A = I - hl0*df/dy.
10141 C DUSOL interfaces to the user's PSOL routine (MITER = 9).
10142 C DSRCKR is a user-callable routine to save and restore
10143 C the contents of the internal Common blocks.
10144 C DAXPY, DCOPY, DDOT, DNRM2, and DSCAL are basic linear
10145 C algebra modules (from the BLAS collection).
10146 C DUMACH computes the unit roundoff in a machine-independent manner.
10147 C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all
10148 C error messages and warnings. XERRWD is machine-dependent.
10149 C Note: DVNORM, DDOT, DNRM2, DUMACH, IXSAV, and IUMACH are function
10150 C routines. All the others are subroutines.
10151 C
10152 C-----------------------------------------------------------------------
10153  DOUBLE PRECISION dumach, dvnorm
10154  INTEGER init, mxstep, mxhnil, nhnil, nslast, nyh, iowns,
10155  1 icf, ierpj, iersl, jcur, jstart, kflag, l,
10156  2 lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
10157  3 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
10158  INTEGER newt, nsfi, nslj, njev
10159  INTEGER lg0, lg1, lgx, iownr3, irfnd, itaskc, ngc, nge
10160  INTEGER jpre, jacflg, locwp, lociwp, lsavx, kmp, maxl, mnewt,
10161  1 nni, nli, nps, ncfn, ncfl
10162  INTEGER i, i1, i2, ier, iflag, imxer, kgo, lf0,
10163  1 leniw, leniwk, lenrw, lenwm, lenwk, liwp, lwp, mord, mxhnl0,
10164  2 mxstp0, ncfn0, ncfl0, niter, nli0, nni0, nnid, nstd, nwarn
10165  INTEGER irfp, irt, lenyh, lyhnew
10166  DOUBLE PRECISION rowns,
10167  1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
10168  DOUBLE PRECISION stifr
10169  DOUBLE PRECISION rownr3, t0, tlast, toutc
10170  DOUBLE PRECISION delt, epcon, sqrtn, rsqrtn
10171  DOUBLE PRECISION atoli, avdim, big, ewti, h0, hmax, hmx, rcfl,
10172  1 rcfn, rh, rtoli, tcrit, tnext, tolsf, tp, SIZE
10173  dimension mord(2)
10174  LOGICAL ihit, lavd, lcfn, lcfl, lwarn
10175  CHARACTER*60 msg
10176  SAVE mord, mxstp0, mxhnl0
10177 C-----------------------------------------------------------------------
10178 C The following four internal Common blocks contain
10179 C (a) variables which are local to any subroutine but whose values must
10180 C be preserved between calls to the routine ("own" variables), and
10181 C (b) variables which are communicated between subroutines.
10182 C The block DLS001 is declared in subroutines DLSODKR, DINTDY,
10183 C DSTOKA, DSOLPK, and DATV.
10184 C The block DLS002 is declared in subroutines DLSODKR and DSTOKA.
10185 C The block DLSR01 is declared in subroutines DLSODKR, DRCHEK, DROOTS.
10186 C The block DLPK01 is declared in subroutines DLSODKR, DSTOKA, DSETPK,
10187 C and DSOLPK.
10188 C Groups of variables are replaced by dummy arrays in the Common
10189 C declarations in routines where those variables are not used.
10190 C-----------------------------------------------------------------------
10191  COMMON /dls001/ rowns(209),
10192  1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
10193  2 init, mxstep, mxhnil, nhnil, nslast, nyh, iowns(6),
10194  3 icf, ierpj, iersl, jcur, jstart, kflag, l,
10195  4 lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
10196  5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
10197 C
10198  COMMON /dls002/ stifr, newt, nsfi, nslj, njev
10199 C
10200  COMMON /dlsr01/ rownr3(2), t0, tlast, toutc,
10201  1 lg0, lg1, lgx, iownr3(2), irfnd, itaskc, ngc, nge
10202 C
10203  COMMON /dlpk01/ delt, epcon, sqrtn, rsqrtn,
10204  1 jpre, jacflg, locwp, lociwp, lsavx, kmp, maxl, mnewt,
10205  2 nni, nli, nps, ncfn, ncfl
10206 C
10207  DATA mord(1),mord(2)/12,5/, mxstp0/500/, mxhnl0/10/
10208 C-----------------------------------------------------------------------
10209 C Block A.
10210 C This code block is executed on every call.
10211 C It tests ISTATE and ITASK for legality and branches appropriately.
10212 C If ISTATE .gt. 1 but the flag INIT shows that initialization has
10213 C not yet been done, an error return occurs.
10214 C If ISTATE = 1 and TOUT = T, return immediately.
10215 C-----------------------------------------------------------------------
10216  IF (istate .LT. 1 .OR. istate .GT. 3) GO TO 601
10217  IF (itask .LT. 1 .OR. itask .GT. 5) GO TO 602
10218  itaskc = itask
10219  IF (istate .EQ. 1) GO TO 10
10220  IF (init .EQ. 0) GO TO 603
10221  IF (istate .EQ. 2) GO TO 200
10222  GO TO 20
10223  10 init = 0
10224  IF (tout .EQ. t) RETURN
10225 C-----------------------------------------------------------------------
10226 C Block B.
10227 C The next code block is executed for the initial call (ISTATE = 1),
10228 C or for a continuation call with parameter changes (ISTATE = 3).
10229 C It contains checking of all inputs and various initializations.
10230 C
10231 C First check legality of the non-optional inputs NEQ, ITOL, IOPT, MF,
10232 C and NG.
10233 C-----------------------------------------------------------------------
10234  20 IF (neq(1) .LE. 0) GO TO 604
10235  IF (istate .EQ. 1) GO TO 25
10236  IF (neq(1) .GT. n) GO TO 605
10237  25 n = neq(1)
10238  IF (itol .LT. 1 .OR. itol .GT. 4) GO TO 606
10239  IF (iopt .LT. 0 .OR. iopt .GT. 1) GO TO 607
10240  meth = mf/10
10241  miter = mf - 10*meth
10242  IF (meth .LT. 1 .OR. meth .GT. 2) GO TO 608
10243  IF (miter .LT. 0) GO TO 608
10244  IF (miter .GT. 4 .AND. miter .LT. 9) GO TO 608
10245  IF (miter .GE. 1) jpre = iwork(3)
10246  jacflg = 0
10247  IF (miter .GE. 1) jacflg = iwork(4)
10248  IF (ng .LT. 0) GO TO 630
10249  IF (istate .EQ. 1) GO TO 35
10250  IF (irfnd .EQ. 0 .AND. ng .NE. ngc) GO TO 631
10251  35 ngc = ng
10252 C Next process and check the optional inputs. --------------------------
10253  IF (iopt .EQ. 1) GO TO 40
10254  maxord = mord(meth)
10255  mxstep = mxstp0
10256  mxhnil = mxhnl0
10257  IF (istate .EQ. 1) h0 = 0.0d0
10258  hmxi = 0.0d0
10259  hmin = 0.0d0
10260  maxl = min(5,n)
10261  kmp = maxl
10262  delt = 0.05d0
10263  GO TO 60
10264  40 maxord = iwork(5)
10265  IF (maxord .LT. 0) GO TO 611
10266  IF (maxord .EQ. 0) maxord = 100
10267  maxord = min(maxord,mord(meth))
10268  mxstep = iwork(6)
10269  IF (mxstep .LT. 0) GO TO 612
10270  IF (mxstep .EQ. 0) mxstep = mxstp0
10271  mxhnil = iwork(7)
10272  IF (mxhnil .LT. 0) GO TO 613
10273  IF (mxhnil .EQ. 0) mxhnil = mxhnl0
10274  IF (istate .NE. 1) GO TO 50
10275  h0 = rwork(5)
10276  IF ((tout - t)*h0 .LT. 0.0d0) GO TO 614
10277  50 hmax = rwork(6)
10278  IF (hmax .LT. 0.0d0) GO TO 615
10279  hmxi = 0.0d0
10280  IF (hmax .GT. 0.0d0) hmxi = 1.0d0/hmax
10281  hmin = rwork(7)
10282  IF (hmin .LT. 0.0d0) GO TO 616
10283  maxl = iwork(8)
10284  IF (maxl .EQ. 0) maxl = 5
10285  maxl = min(maxl,n)
10286  kmp = iwork(9)
10287  IF (kmp .EQ. 0 .OR. kmp .GT. maxl) kmp = maxl
10288  delt = rwork(8)
10289  IF (delt .EQ. 0.0d0) delt = 0.05d0
10290 C-----------------------------------------------------------------------
10291 C Set work array pointers and check lengths LRW and LIW.
10292 C Pointers to segments of RWORK and IWORK are named by prefixing L to
10293 C the name of the segment. E.g., the segment YH starts at RWORK(LYH).
10294 C RWORK segments (in order) are denoted G0, G1, GX, YH, WM,
10295 C EWT, SAVF, SAVX, ACOR.
10296 C-----------------------------------------------------------------------
10297  60 IF (istate .EQ. 1) nyh = n
10298  lg0 = 21
10299  lg1 = lg0 + ng
10300  lgx = lg1 + ng
10301  lyhnew = lgx + ng
10302  IF (istate .EQ. 1) lyh = lyhnew
10303  IF (lyhnew .EQ. lyh) GO TO 62
10304 C If ISTATE = 3 and NG was changed, shift YH to its new location. ------
10305  lenyh = l*nyh
10306  IF (lrw .LT. lyhnew-1+lenyh) GO TO 62
10307  i1 = 1
10308  IF (lyhnew .GT. lyh) i1 = -1
10309  CALL dcopy (lenyh, rwork(lyh), i1, rwork(lyhnew), i1)
10310  lyh = lyhnew
10311  62 CONTINUE
10312  lwm = lyh + (maxord + 1)*nyh
10313  IF (miter .EQ. 0) lenwk = 0
10314  IF (miter .EQ. 1) lenwk = n*(maxl+2) + maxl*maxl
10315  IF (miter .EQ. 2)
10316  1 lenwk = n*(maxl+2+min(1,maxl-kmp)) + (maxl+3)*maxl + 1
10317  IF (miter .EQ. 3 .OR. miter .EQ. 4) lenwk = 5*n
10318  IF (miter .EQ. 9) lenwk = 2*n
10319  lwp = 0
10320  IF (miter .GE. 1) lwp = iwork(1)
10321  lenwm = lenwk + lwp
10322  locwp = lenwk + 1
10323  lewt = lwm + lenwm
10324  lsavf = lewt + n
10325  lsavx = lsavf + n
10326  lacor = lsavx + n
10327  IF (miter .EQ. 0) lacor = lsavf + n
10328  lenrw = lacor + n - 1
10329  iwork(17) = lenrw
10330  liwm = 31
10331  leniwk = 0
10332  IF (miter .EQ. 1) leniwk = maxl
10333  liwp = 0
10334  IF (miter .GE. 1) liwp = iwork(2)
10335  leniw = 30 + leniwk + liwp
10336  lociwp = leniwk + 1
10337  iwork(18) = leniw
10338  IF (lenrw .GT. lrw) GO TO 617
10339  IF (leniw .GT. liw) GO TO 618
10340 C Check RTOL and ATOL for legality. ------------------------------------
10341  rtoli = rtol(1)
10342  atoli = atol(1)
10343  DO 70 i = 1,n
10344  IF (itol .GE. 3) rtoli = rtol(i)
10345  IF (itol .EQ. 2 .OR. itol .EQ. 4) atoli = atol(i)
10346  IF (rtoli .LT. 0.0d0) GO TO 619
10347  IF (atoli .LT. 0.0d0) GO TO 620
10348  70 CONTINUE
10349 C Load SQRT(N) and its reciprocal in Common. ---------------------------
10350  sqrtn = sqrt(REAL(n))
10351  rsqrtn = 1.0d0/sqrtn
10352  IF (istate .EQ. 1) GO TO 100
10353 C If ISTATE = 3, set flag to signal parameter changes to DSTOKA.--------
10354  jstart = -1
10355  IF (nq .LE. maxord) GO TO 90
10356 C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. ---------
10357  DO 80 i = 1,n
10358  80 rwork(i+lsavf-1) = rwork(i+lwm-1)
10359  90 CONTINUE
10360  IF (n .EQ. nyh) GO TO 200
10361 C NEQ was reduced. Zero part of YH to avoid undefined references. -----
10362  i1 = lyh + l*nyh
10363  i2 = lyh + (maxord + 1)*nyh - 1
10364  IF (i1 .GT. i2) GO TO 200
10365  DO 95 i = i1,i2
10366  95 rwork(i) = 0.0d0
10367  GO TO 200
10368 C-----------------------------------------------------------------------
10369 C Block C.
10370 C The next block is for the initial call only (ISTATE = 1).
10371 C It contains all remaining initializations, the initial call to F,
10372 C and the calculation of the initial step size.
10373 C The error weights in EWT are inverted after being loaded.
10374 C-----------------------------------------------------------------------
10375  100 uround = dumach()
10376  tn = t
10377  IF (itask .NE. 4 .AND. itask .NE. 5) GO TO 110
10378  tcrit = rwork(1)
10379  IF ((tcrit - tout)*(tout - t) .LT. 0.0d0) GO TO 625
10380  IF (h0 .NE. 0.0d0 .AND. (t + h0 - tcrit)*h0 .GT. 0.0d0)
10381  1 h0 = tcrit - t
10382  110 jstart = 0
10383  nhnil = 0
10384  nst = 0
10385  nje = 0
10386  nslast = 0
10387  nli0 = 0
10388  nni0 = 0
10389  ncfn0 = 0
10390  ncfl0 = 0
10391  nwarn = 0
10392  hu = 0.0d0
10393  nqu = 0
10394  ccmax = 0.3d0
10395  maxcor = 3
10396  msbp = 20
10397  mxncf = 10
10398  nni = 0
10399  nli = 0
10400  nps = 0
10401  ncfn = 0
10402  ncfl = 0
10403  nsfi = 0
10404  njev = 0
10405 C Initial call to F. (LF0 points to YH(*,2).) -------------------------
10406  lf0 = lyh + nyh
10407  CALL f (neq, t, y, rwork(lf0))
10408  nfe = 1
10409 C Load the initial value vector in YH. ---------------------------------
10410  DO 115 i = 1,n
10411  115 rwork(i+lyh-1) = y(i)
10412 C Load and invert the EWT array. (H is temporarily set to 1.0.) -------
10413  nq = 1
10414  h = 1.0d0
10415  CALL dewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt))
10416  DO 120 i = 1,n
10417  IF (rwork(i+lewt-1) .LE. 0.0d0) GO TO 621
10418  120 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1)
10419  IF (h0 .NE. 0.0d0) GO TO 180
10420 C Call DLHIN to set initial step size H0 to be attempted. --------------
10421  CALL dlhin (neq, n, t, rwork(lyh), rwork(lf0), f, tout, uround,
10422  1 rwork(lewt), itol, atol, y, rwork(lacor), h0, niter, ier)
10423  nfe = nfe + niter
10424  IF (ier .NE. 0) GO TO 622
10425 C Adjust H0 if necessary to meet HMAX bound. ---------------------------
10426  180 rh = abs(h0)*hmxi
10427  IF (rh .GT. 1.0d0) h0 = h0/rh
10428 C Load H with H0 and scale YH(*,2) by H0. ------------------------------
10429  h = h0
10430  DO 190 i = 1,n
10431  190 rwork(i+lf0-1) = h0*rwork(i+lf0-1)
10432 C Check for a zero of g at T. ------------------------------------------
10433  irfnd = 0
10434  toutc = tout
10435  IF (ngc .EQ. 0) GO TO 270
10436  CALL drchek (1, g, neq, y, rwork(lyh), nyh,
10437  1 rwork(lg0), rwork(lg1), rwork(lgx), jroot, irt)
10438  IF (irt .EQ. 0) GO TO 270
10439  GO TO 632
10440 C-----------------------------------------------------------------------
10441 C Block D.
10442 C The next code block is for continuation calls only (ISTATE = 2 or 3)
10443 C and is to check stop conditions before taking a step.
10444 C First, DRCHEK is called to check for a root within the last step
10445 C taken, other than the last root found there, if any.
10446 C If ITASK = 2 or 5, and y(TN) has not yet been returned to the user
10447 C because of an intervening root, return through Block G.
10448 C-----------------------------------------------------------------------
10449  200 nslast = nst
10450 C
10451  irfp = irfnd
10452  IF (ngc .EQ. 0) GO TO 205
10453  IF (itask .EQ. 1 .OR. itask .EQ. 4) toutc = tout
10454  CALL drchek (2, g, neq, y, rwork(lyh), nyh,
10455  1 rwork(lg0), rwork(lg1), rwork(lgx), jroot, irt)
10456  IF (irt .NE. 1) GO TO 205
10457  irfnd = 1
10458  istate = 3
10459  t = t0
10460  GO TO 425
10461  205 CONTINUE
10462  irfnd = 0
10463  IF (irfp .EQ. 1 .AND. tlast .NE. tn .AND. itask .EQ. 2) GO TO 400
10464 C
10465  nli0 = nli
10466  nni0 = nni
10467  ncfn0 = ncfn
10468  ncfl0 = ncfl
10469  nwarn = 0
10470  GO TO (210, 250, 220, 230, 240), itask
10471  210 IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
10472  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
10473  IF (iflag .NE. 0) GO TO 627
10474  t = tout
10475  GO TO 420
10476  220 tp = tn - hu*(1.0d0 + 100.0d0*uround)
10477  IF ((tp - tout)*h .GT. 0.0d0) GO TO 623
10478  IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
10479  GO TO 400
10480  230 tcrit = rwork(1)
10481  IF ((tn - tcrit)*h .GT. 0.0d0) GO TO 624
10482  IF ((tcrit - tout)*h .LT. 0.0d0) GO TO 625
10483  IF ((tn - tout)*h .LT. 0.0d0) GO TO 245
10484  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
10485  IF (iflag .NE. 0) GO TO 627
10486  t = tout
10487  GO TO 420
10488  240 tcrit = rwork(1)
10489  IF ((tn - tcrit)*h .GT. 0.0d0) GO TO 624
10490  245 hmx = abs(tn) + abs(h)
10491  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
10492  IF (ihit) t = tcrit
10493  IF (irfp .EQ. 1 .AND. tlast .NE. tn .AND. itask .EQ. 5) GO TO 400
10494  IF (ihit) GO TO 400
10495  tnext = tn + h*(1.0d0 + 4.0d0*uround)
10496  IF ((tnext - tcrit)*h .LE. 0.0d0) GO TO 250
10497  h = (tcrit - tn)*(1.0d0 - 4.0d0*uround)
10498  IF (istate .EQ. 2) jstart = -2
10499 C-----------------------------------------------------------------------
10500 C Block E.
10501 C The next block is normally executed for all calls and contains
10502 C the call to the one-step core integrator DSTOKA.
10503 C
10504 C This is a looping point for the integration steps.
10505 C
10506 C First check for too many steps being taken,
10507 C check for poor Newton/Krylov method performance, update EWT (if not
10508 C at start of problem), check for too much accuracy being requested,
10509 C and check for H below the roundoff level in T.
10510 C-----------------------------------------------------------------------
10511  250 CONTINUE
10512  IF ((nst-nslast) .GE. mxstep) GO TO 500
10513  nstd = nst - nslast
10514  nnid = nni - nni0
10515  IF (nstd .LT. 10 .OR. nnid .EQ. 0) GO TO 255
10516  avdim = REAL(nli - nli0)/REAL(nnid)
10517  rcfn = REAL(ncfn - ncfn0)/REAL(nstd)
10518  rcfl = REAL(ncfl - ncfl0)/REAL(nnid)
10519  lavd = avdim .GT. (maxl - 0.05d0)
10520  lcfn = rcfn .GT. 0.9d0
10521  lcfl = rcfl .GT. 0.9d0
10522  lwarn = lavd .OR. lcfn .OR. lcfl
10523  IF (.NOT.lwarn) GO TO 255
10524  nwarn = nwarn + 1
10525  IF (nwarn .GT. 10) GO TO 255
10526  IF (lavd) THEN
10527  msg='DLSODKR- Warning. Poor iterative algorithm performance seen '
10528  CALL xerrwd (msg, 60, 111, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
10529  ENDIF
10530  IF (lavd) THEN
10531  msg=' at T = R1 by average no. of linear iterations = R2 '
10532  CALL xerrwd (msg, 60, 111, 0, 0, 0, 0, 2, tn, avdim)
10533  ENDIF
10534  IF (lcfn) THEN
10535  msg='DLSODKR- Warning. Poor iterative algorithm performance seen '
10536  CALL xerrwd (msg, 60, 112, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
10537  ENDIF
10538  IF (lcfn) THEN
10539  msg=' at T = R1 by nonlinear convergence failure rate = R2 '
10540  CALL xerrwd (msg, 60, 112, 0, 0, 0, 0, 2, tn, rcfn)
10541  ENDIF
10542  IF (lcfl) THEN
10543  msg='DLSODKR- Warning. Poor iterative algorithm performance seen '
10544  CALL xerrwd (msg, 60, 113, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
10545  ENDIF
10546  IF (lcfl) THEN
10547  msg=' at T = R1 by linear convergence failure rate = R2 '
10548  CALL xerrwd (msg, 60, 113, 0, 0, 0, 0, 2, tn, rcfl)
10549  ENDIF
10550  255 CONTINUE
10551  CALL dewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt))
10552  DO 260 i = 1,n
10553  IF (rwork(i+lewt-1) .LE. 0.0d0) GO TO 510
10554  260 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1)
10555  270 tolsf = uround*dvnorm(n, rwork(lyh), rwork(lewt))
10556  IF (tolsf .LE. 1.0d0) GO TO 280
10557  tolsf = tolsf*2.0d0
10558  IF (nst .EQ. 0) GO TO 626
10559  GO TO 520
10560  280 IF ((tn + h) .NE. tn) GO TO 290
10561  nhnil = nhnil + 1
10562  IF (nhnil .GT. mxhnil) GO TO 290
10563  msg = 'DLSODKR- Warning.. Internal T(=R1) and H(=R2) are'
10564  CALL xerrwd (msg, 50, 101, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
10565  msg=' such that in the machine, T + H = T on the next step '
10566  CALL xerrwd (msg, 60, 101, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
10567  msg = ' (H = step size). Solver will continue anyway.'
10568  CALL xerrwd (msg, 50, 101, 0, 0, 0, 0, 2, tn, h)
10569  IF (nhnil .LT. mxhnil) GO TO 290
10570  msg = 'DLSODKR- Above warning has been issued I1 times. '
10571  CALL xerrwd (msg, 50, 102, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
10572  msg = ' It will not be issued again for this problem.'
10573  CALL xerrwd (msg, 50, 102, 0, 1, mxhnil, 0, 0, 0.0d0, 0.0d0)
10574  290 CONTINUE
10575 C-----------------------------------------------------------------------
10576 C CALL DSTOKA(NEQ,Y,YH,NYH,YH,EWT,SAVF,SAVX,ACOR,WM,IWM,F,JAC,PSOL)
10577 C-----------------------------------------------------------------------
10578  CALL dstoka (neq, y, rwork(lyh), nyh, rwork(lyh), rwork(lewt),
10579  1 rwork(lsavf), rwork(lsavx), rwork(lacor), rwork(lwm),
10580  2 iwork(liwm), f, jac, psol)
10581  kgo = 1 - kflag
10582  GO TO (300, 530, 540, 550), kgo
10583 C-----------------------------------------------------------------------
10584 C Block F.
10585 C The following block handles the case of a successful return from the
10586 C core integrator (KFLAG = 0).
10587 C Call DRCHEK to check for a root within the last step.
10588 C Then, if no root was found, check for stop conditions.
10589 C-----------------------------------------------------------------------
10590  300 init = 1
10591 C
10592  IF (ngc .EQ. 0) GO TO 315
10593  CALL drchek (3, g, neq, y, rwork(lyh), nyh,
10594  1 rwork(lg0), rwork(lg1), rwork(lgx), jroot, irt)
10595  IF (irt .NE. 1) GO TO 315
10596  irfnd = 1
10597  istate = 3
10598  t = t0
10599  GO TO 425
10600  315 CONTINUE
10601 C
10602  GO TO (310, 400, 330, 340, 350), itask
10603 C ITASK = 1. If TOUT has been reached, interpolate. -------------------
10604  310 IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
10605  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
10606  t = tout
10607  GO TO 420
10608 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------
10609  330 IF ((tn - tout)*h .GE. 0.0d0) GO TO 400
10610  GO TO 250
10611 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary.
10612  340 IF ((tn - tout)*h .LT. 0.0d0) GO TO 345
10613  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
10614  t = tout
10615  GO TO 420
10616  345 hmx = abs(tn) + abs(h)
10617  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
10618  IF (ihit) GO TO 400
10619  tnext = tn + h*(1.0d0 + 4.0d0*uround)
10620  IF ((tnext - tcrit)*h .LE. 0.0d0) GO TO 250
10621  h = (tcrit - tn)*(1.0d0 - 4.0d0*uround)
10622  jstart = -2
10623  GO TO 250
10624 C ITASK = 5. See if TCRIT was reached and jump to exit. ---------------
10625  350 hmx = abs(tn) + abs(h)
10626  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
10627 C-----------------------------------------------------------------------
10628 C Block G.
10629 C The following block handles all successful returns from DLSODKR.
10630 C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly.
10631 C ISTATE is set to 2, and the optional outputs are loaded into the
10632 C work arrays before returning.
10633 C-----------------------------------------------------------------------
10634  400 DO 410 i = 1,n
10635  410 y(i) = rwork(i+lyh-1)
10636  t = tn
10637  IF (itask .NE. 4 .AND. itask .NE. 5) GO TO 420
10638  IF (ihit) t = tcrit
10639  420 istate = 2
10640  425 CONTINUE
10641  rwork(11) = hu
10642  rwork(12) = h
10643  rwork(13) = tn
10644  iwork(11) = nst
10645  iwork(12) = nfe
10646  iwork(13) = nje
10647  iwork(14) = nqu
10648  iwork(15) = nq
10649  iwork(19) = nni
10650  iwork(20) = nli
10651  iwork(21) = nps
10652  iwork(22) = ncfn
10653  iwork(23) = ncfl
10654  iwork(24) = nsfi
10655  iwork(25) = njev
10656  iwork(10) = nge
10657  tlast = t
10658  RETURN
10659 C-----------------------------------------------------------------------
10660 C Block H.
10661 C The following block handles all unsuccessful returns other than
10662 C those for illegal input. First the error message routine is called.
10663 C If there was an error test or convergence test failure, IMXER is set.
10664 C Then Y is loaded from YH and T is set to TN.
10665 C The optional outputs are loaded into the work arrays before returning.
10666 C-----------------------------------------------------------------------
10667 C The maximum number of steps was taken before reaching TOUT. ----------
10668  500 msg = 'DLSODKR- At current T (=R1), MXSTEP (=I1) steps '
10669  CALL xerrwd (msg, 50, 201, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
10670  msg = ' taken on this call before reaching TOUT '
10671  CALL xerrwd (msg, 50, 201, 0, 1, mxstep, 0, 1, tn, 0.0d0)
10672  istate = -1
10673  GO TO 580
10674 C EWT(i) .le. 0.0 for some i (not at start of problem). ----------------
10675  510 ewti = rwork(lewt+i-1)
10676  msg = .le.'DLSODKR- At T(=R1), EWT(I1) has become R2 0.'
10677  CALL xerrwd (msg, 50, 202, 0, 1, i, 0, 2, tn, ewti)
10678  istate = -6
10679  GO TO 580
10680 C Too much accuracy requested for machine precision. -------------------
10681  520 msg = 'DLSODKR- At T (=R1), too much accuracy requested '
10682  CALL xerrwd (msg, 50, 203, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
10683  msg = ' for precision of machine.. See TOLSF (=R2) '
10684  CALL xerrwd (msg, 50, 203, 0, 0, 0, 0, 2, tn, tolsf)
10685  rwork(14) = tolsf
10686  istate = -2
10687  GO TO 580
10688 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. -----
10689  530 msg = 'DLSODKR- At T(=R1) and step size H(=R2), the error'
10690  CALL xerrwd (msg, 50, 204, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
10691  msg = ' test failed repeatedly or with ABS(H) = HMIN'
10692  CALL xerrwd (msg, 50, 204, 0, 0, 0, 0, 2, tn, h)
10693  istate = -4
10694  GO TO 560
10695 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ----
10696  540 msg = 'DLSODKR- At T (=R1) and step size H (=R2), the '
10697  CALL xerrwd (msg, 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
10698  msg = ' corrector convergence failed repeatedly '
10699  CALL xerrwd (msg, 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
10700  msg = ' or with ABS(H) = HMIN '
10701  CALL xerrwd (msg, 30, 205, 0, 0, 0, 0, 2, tn, h)
10702  istate = -5
10703  GO TO 580
10704 C KFLAG = -3. Unrecoverable error from PSOL. --------------------------
10705  550 msg = 'DLSODKR- At T (=R1) an unrecoverable error return'
10706  CALL xerrwd (msg, 50, 206, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
10707  msg = ' was made from Subroutine PSOL '
10708  CALL xerrwd (msg, 40, 206, 0, 0, 0, 0, 1, tn, 0.0d0)
10709  istate = -7
10710  GO TO 580
10711 C Compute IMXER if relevant. -------------------------------------------
10712  560 big = 0.0d0
10713  imxer = 1
10714  DO 570 i = 1,n
10715  SIZE = abs(rwork(i+lacor-1)*rwork(i+lewt-1))
10716  IF (big .GE. size) GO TO 570
10717  big = SIZE
10718  imxer = i
10719  570 CONTINUE
10720  iwork(16) = imxer
10721 C Set Y vector, T, and optional outputs. -------------------------------
10722  580 DO 590 i = 1,n
10723  590 y(i) = rwork(i+lyh-1)
10724  t = tn
10725  rwork(11) = hu
10726  rwork(12) = h
10727  rwork(13) = tn
10728  iwork(11) = nst
10729  iwork(12) = nfe
10730  iwork(13) = nje
10731  iwork(14) = nqu
10732  iwork(15) = nq
10733  iwork(19) = nni
10734  iwork(20) = nli
10735  iwork(21) = nps
10736  iwork(22) = ncfn
10737  iwork(23) = ncfl
10738  iwork(24) = nsfi
10739  iwork(25) = njev
10740  iwork(10) = nge
10741  tlast = t
10742  RETURN
10743 C-----------------------------------------------------------------------
10744 C Block I.
10745 C The following block handles all error returns due to illegal input
10746 C (ISTATE = -3), as detected before calling the core integrator.
10747 C First the error message routine is called. If the illegal input
10748 C is a negative ISTATE, the run is aborted (apparent infinite loop).
10749 C-----------------------------------------------------------------------
10750  601 msg = 'DLSODKR- ISTATE(=I1) illegal.'
10751  CALL xerrwd (msg, 30, 1, 0, 1, istate, 0, 0, 0.0d0, 0.0d0)
10752  IF (istate .LT. 0) GO TO 800
10753  GO TO 700
10754  602 msg = 'DLSODKR- ITASK (=I1) illegal.'
10755  CALL xerrwd (msg, 30, 2, 0, 1, itask, 0, 0, 0.0d0, 0.0d0)
10756  GO TO 700
10757  603 msg = .gt.'DLSODKR- ISTATE1 but DLSODKR not initialized. '
10758  CALL xerrwd (msg, 50, 3, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
10759  GO TO 700
10760  604 msg = .lt.'DLSODKR- NEQ (=I1) 1 '
10761  CALL xerrwd (msg, 30, 4, 0, 1, neq(1), 0, 0, 0.0d0, 0.0d0)
10762  GO TO 700
10763  605 msg = 'DLSODKR- ISTATE = 3 and NEQ increased (I1 to I2).'
10764  CALL xerrwd (msg, 50, 5, 0, 2, n, neq(1), 0, 0.0d0, 0.0d0)
10765  GO TO 700
10766  606 msg = 'DLSODKR- ITOL (=I1) illegal. '
10767  CALL xerrwd (msg, 30, 6, 0, 1, itol, 0, 0, 0.0d0, 0.0d0)
10768  GO TO 700
10769  607 msg = 'DLSODKR- IOPT (=I1) illegal. '
10770  CALL xerrwd (msg, 30, 7, 0, 1, iopt, 0, 0, 0.0d0, 0.0d0)
10771  GO TO 700
10772  608 msg = 'DLSODKR- MF (=I1) illegal. '
10773  CALL xerrwd (msg, 30, 8, 0, 1, mf, 0, 0, 0.0d0, 0.0d0)
10774  GO TO 700
10775  611 msg = .lt.'DLSODKR- MAXORD (=I1) 0 '
10776  CALL xerrwd (msg, 30, 11, 0, 1, maxord, 0, 0, 0.0d0, 0.0d0)
10777  GO TO 700
10778  612 msg = .lt.'DLSODKR- MXSTEP (=I1) 0 '
10779  CALL xerrwd (msg, 30, 12, 0, 1, mxstep, 0, 0, 0.0d0, 0.0d0)
10780  GO TO 700
10781  613 msg = .lt.'DLSODKR- MXHNIL (=I1) 0 '
10782  CALL xerrwd (msg, 30, 13, 0, 1, mxhnil, 0, 0, 0.0d0, 0.0d0)
10783  GO TO 700
10784  614 msg = 'DLSODKR- TOUT (=R1) behind T (=R2) '
10785  CALL xerrwd (msg, 40, 14, 0, 0, 0, 0, 2, tout, t)
10786  msg = ' Integration direction is given by H0 (=R1) '
10787  CALL xerrwd (msg, 50, 14, 0, 0, 0, 0, 1, h0, 0.0d0)
10788  GO TO 700
10789  615 msg = .lt.'DLSODKR- HMAX (=R1) 0.0 '
10790  CALL xerrwd (msg, 30, 15, 0, 0, 0, 0, 1, hmax, 0.0d0)
10791  GO TO 700
10792  616 msg = .lt.'DLSODKR- HMIN (=R1) 0.0 '
10793  CALL xerrwd (msg, 30, 16, 0, 0, 0, 0, 1, hmin, 0.0d0)
10794  GO TO 700
10795  617 msg='DLSODKR- RWORK length needed, LENRW(=I1), exceeds LRW(=I2) '
10796  CALL xerrwd (msg, 60, 17, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0)
10797  GO TO 700
10798  618 msg='DLSODKR- IWORK length needed, LENIW(=I1), exceeds LIW(=I2) '
10799  CALL xerrwd (msg, 60, 18, 0, 2, leniw, liw, 0, 0.0d0, 0.0d0)
10800  GO TO 700
10801  619 msg = .lt.'DLSODKR- RTOL(I1) is R1 0.0 '
10802  CALL xerrwd (msg, 40, 19, 0, 1, i, 0, 1, rtoli, 0.0d0)
10803  GO TO 700
10804  620 msg = .lt.'DLSODKR- ATOL(I1) is R1 0.0 '
10805  CALL xerrwd (msg, 40, 20, 0, 1, i, 0, 1, atoli, 0.0d0)
10806  GO TO 700
10807  621 ewti = rwork(lewt+i-1)
10808  msg = .le.'DLSODKR- EWT(I1) is R1 0.0 '
10809  CALL xerrwd (msg, 40, 21, 0, 1, i, 0, 1, ewti, 0.0d0)
10810  GO TO 700
10811  622 msg='DLSODKR- TOUT(=R1) too close to T(=R2) to start integration.'
10812  CALL xerrwd (msg, 60, 22, 0, 0, 0, 0, 2, tout, t)
10813  GO TO 700
10814  623 msg='DLSODKR- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) '
10815  CALL xerrwd (msg, 60, 23, 0, 1, itask, 0, 2, tout, tp)
10816  GO TO 700
10817  624 msg='DLSODKR- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) '
10818  CALL xerrwd (msg, 60, 24, 0, 0, 0, 0, 2, tcrit, tn)
10819  GO TO 700
10820  625 msg='DLSODKR- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) '
10821  CALL xerrwd (msg, 60, 25, 0, 0, 0, 0, 2, tcrit, tout)
10822  GO TO 700
10823  626 msg = 'DLSODKR- At start of problem, too much accuracy '
10824  CALL xerrwd (msg, 50, 26, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
10825  msg=' requested for precision of machine.. See TOLSF (=R1) '
10826  CALL xerrwd (msg, 60, 26, 0, 0, 0, 0, 1, tolsf, 0.0d0)
10827  rwork(14) = tolsf
10828  GO TO 700
10829  627 msg = 'DLSODKR- Trouble in DINTDY. ITASK = I1, TOUT = R1'
10830  CALL xerrwd (msg, 50, 27, 0, 1, itask, 0, 1, tout, 0.0d0)
10831  GO TO 700
10832  630 msg = .lt.'DLSODKR- NG (=I1) 0 '
10833  CALL xerrwd (msg, 30, 30, 0, 1, ng, 0, 0, 0.0d0, 0.0d0)
10834  GO TO 700
10835  631 msg = 'DLSODKR- NG changed (from I1 to I2) illegally, '
10836  CALL xerrwd (msg, 50, 31, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
10837  msg = ' i.e. not immediately after a root was found.'
10838  CALL xerrwd (msg, 50, 31, 0, 2, ngc, ng, 0, 0.0d0, 0.0d0)
10839  GO TO 700
10840  632 msg = 'DLSODKR- One or more components of g has a root '
10841  CALL xerrwd (msg, 50, 32, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
10842  msg = ' too near to the initial point. '
10843  CALL xerrwd (msg, 40, 32, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
10844 C
10845  700 istate = -3
10846  RETURN
10847 C
10848  800 msg = 'DLSODKR- Run aborted.. apparent infinite loop. '
10849  CALL xerrwd (msg, 50, 303, 2, 0, 0, 0, 0, 0.0d0, 0.0d0)
10850  RETURN
10851 C----------------------- End of Subroutine DLSODKR ---------------------
10852  END
10853 *DECK DLSODI
10854  SUBROUTINE dlsodi (RES, ADDA, JAC, NEQ, Y, YDOTI, T, TOUT, ITOL,
10855  1 RTOL, ATOL, ITASK, ISTATE, IOPT, RWORK, LRW, IWORK, LIW, MF )
10856  EXTERNAL res, adda, jac
10857  INTEGER neq, itol, itask, istate, iopt, lrw, iwork, liw, mf
10858  DOUBLE PRECISION y, ydoti, t, tout, rtol, atol, rwork
10859  dimension neq(*), y(*), ydoti(*), rtol(*), atol(*), rwork(lrw),
10860  1 iwork(liw)
10861 C-----------------------------------------------------------------------
10862 C This is the 18 November 2003 version of
10863 C DLSODI: Livermore Solver for Ordinary Differential Equations
10864 C (Implicit form).
10865 C
10866 C This version is in double precision.
10867 C
10868 C DLSODI solves the initial value problem for linearly implicit
10869 C systems of first order ODEs,
10870 C A(t,y) * dy/dt = g(t,y) , where A(t,y) is a square matrix,
10871 C or, in component form,
10872 C ( a * ( dy / dt )) + ... + ( a * ( dy / dt )) =
10873 C i,1 1 i,NEQ NEQ
10874 C
10875 C = g ( t, y , y ,..., y ) ( i = 1,...,NEQ )
10876 C i 1 2 NEQ
10877 C
10878 C If A is singular, this is a differential-algebraic system.
10879 C
10880 C DLSODI is a variant version of the DLSODE package.
10881 C-----------------------------------------------------------------------
10882 C Reference:
10883 C Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE
10884 C Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.),
10885 C North-Holland, Amsterdam, 1983, pp. 55-64.
10886 C-----------------------------------------------------------------------
10887 C Authors: Alan C. Hindmarsh and Jeffrey F. Painter
10888 C Center for Applied Scientific Computing, L-561
10889 C Lawrence Livermore National Laboratory
10890 C Livermore, CA 94551
10891 C-----------------------------------------------------------------------
10892 C Summary of Usage.
10893 C
10894 C Communication between the user and the DLSODI package, for normal
10895 C situations, is summarized here. This summary describes only a subset
10896 C of the full set of options available. See the full description for
10897 C details, including optional communication, nonstandard options,
10898 C and instructions for special situations. See also the example
10899 C problem (with program and output) following this summary.
10900 C
10901 C A. First, provide a subroutine of the form:
10902 C SUBROUTINE RES (NEQ, T, Y, S, R, IRES)
10903 C DOUBLE PRECISION T, Y(*), S(*), R(*)
10904 C which computes the residual function
10905 C r = g(t,y) - A(t,y) * s ,
10906 C as a function of t and the vectors y and s. (s is an internally
10907 C generated approximation to dy/dt.) The arrays Y and S are inputs
10908 C to the RES routine and should not be altered. The residual
10909 C vector is to be stored in the array R. The argument IRES should be
10910 C ignored for casual use of DLSODI. (For uses of IRES, see the
10911 C paragraph on RES in the full description below.)
10912 C
10913 C B. Next, decide whether full or banded form is more economical
10914 C for the storage of matrices. DLSODI must deal internally with the
10915 C matrices A and dr/dy, where r is the residual function defined above.
10916 C DLSODI generates a linear combination of these two matrices, and
10917 C this is treated in either full or banded form.
10918 C The matrix structure is communicated by a method flag MF,
10919 C which is 21 or 22 for the full case, and 24 or 25 in the band case.
10920 C In the banded case, DLSODI requires two half-bandwidth
10921 C parameters ML and MU. These are, respectively, the widths of the
10922 C lower and upper parts of the band, excluding the main diagonal.
10923 C Thus the band consists of the locations (i,j) with
10924 C i-ML .le. j .le. i+MU, and the full bandwidth is ML+MU+1.
10925 C Note that the band must accommodate the nonzero elements of
10926 C A(t,y), dg/dy, and d(A*s)/dy (s fixed). Alternatively, one
10927 C can define a band that encloses only the elements that are relatively
10928 C large in magnitude, and gain some economy in storage and possibly
10929 C also efficiency, although the appropriate threshhold for
10930 C retaining matrix elements is highly problem-dependent.
10931 C
10932 C C. You must also provide a subroutine of the form:
10933 C SUBROUTINE ADDA (NEQ, T, Y, ML, MU, P, NROWP)
10934 C DOUBLE PRECISION T, Y(*), P(NROWP,*)
10935 C which adds the matrix A = A(t,y) to the contents of the array P.
10936 C T and the Y array are input and should not be altered.
10937 C In the full matrix case, this routine should add elements of
10938 C to P in the usual order. I.e., add A(i,j) to P(i,j). (Ignore the
10939 C ML and MU arguments in this case.)
10940 C In the band matrix case, this routine should add element A(i,j)
10941 C to P(i-j+MU+1,j). I.e., add the diagonal lines of A to the rows of
10942 C P from the top down (the top line of A added to the first row of P).
10943 C
10944 C D. For the sake of efficiency, you are encouraged to supply the
10945 C Jacobian matrix dr/dy in closed form, where r = g(t,y) - A(t,y)*s
10946 C (s = a fixed vector) as above. If dr/dy is being supplied,
10947 C use MF = 21 or 24, and provide a subroutine of the form:
10948 C SUBROUTINE JAC (NEQ, T, Y, S, ML, MU, P, NROWP)
10949 C DOUBLE PRECISION T, Y(*), S(*), P(NROWP,*)
10950 C which computes dr/dy as a function of t, y, and s. Here T, Y, and
10951 C S are inputs, and the routine is to load dr/dy into P as follows:
10952 C In the full matrix case (MF = 21), load P(i,j) with dr(i)/dy(j),
10953 C the partial derivative of r(i) with respect to y(j). (Ignore the
10954 C ML and MU arguments in this case.)
10955 C In the band matrix case (MF = 24), load P(i-j+mu+1,j) with
10956 C dr(i)/dy(j), i.e. load the diagonal lines of dr/dy into the rows of
10957 C P from the top down.
10958 C In either case, only nonzero elements need be loaded, and the
10959 C indexing of P is the same as in the ADDA routine.
10960 C Note that if A is independent of y (or this dependence
10961 C is weak enough to be ignored) then JAC is to compute dg/dy.
10962 C If it is not feasible to provide a JAC routine, use
10963 C MF = 22 or 25, and DLSODI will compute an approximate Jacobian
10964 C internally by difference quotients.
10965 C
10966 C E. Next decide whether or not to provide the initial value of the
10967 C derivative vector dy/dt. If the initial value of A(t,y) is
10968 C nonsingular (and not too ill-conditioned), you may let DLSODI compute
10969 C this vector (ISTATE = 0). (DLSODI will solve the system A*s = g for
10970 C s, with initial values of A and g.) If A(t,y) is initially
10971 C singular, then the system is a differential-algebraic system, and
10972 C you must make use of the particular form of the system to compute the
10973 C initial values of y and dy/dt. In that case, use ISTATE = 1 and
10974 C load the initial value of dy/dt into the array YDOTI.
10975 C The input array YDOTI and the initial Y array must be consistent with
10976 C the equations A*dy/dt = g. This implies that the initial residual
10977 C r = g(t,y) - A(t,y)*YDOTI must be approximately zero.
10978 C
10979 C F. Write a main program which calls Subroutine DLSODI once for
10980 C each point at which answers are desired. This should also provide
10981 C for possible use of logical unit 6 for output of error messages
10982 C by DLSODI. On the first call to DLSODI, supply arguments as follows:
10983 C RES = name of user subroutine for residual function r.
10984 C ADDA = name of user subroutine for computing and adding A(t,y).
10985 C JAC = name of user subroutine for Jacobian matrix dr/dy
10986 C (MF = 21 or 24). If not used, pass a dummy name.
10987 C Note: the names for the RES and ADDA routines and (if used) the
10988 C JAC routine must be declared External in the calling program.
10989 C NEQ = number of scalar equations in the system.
10990 C Y = array of initial values, of length NEQ.
10991 C YDOTI = array of length NEQ (containing initial dy/dt if ISTATE = 1).
10992 C T = the initial value of the independent variable.
10993 C TOUT = first point where output is desired (.ne. T).
10994 C ITOL = 1 or 2 according as ATOL (below) is a scalar or array.
10995 C RTOL = relative tolerance parameter (scalar).
10996 C ATOL = absolute tolerance parameter (scalar or array).
10997 C the estimated local error in y(i) will be controlled so as
10998 C to be roughly less (in magnitude) than
10999 C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or
11000 C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2.
11001 C Thus the local error test passes if, in each component,
11002 C either the absolute error is less than ATOL (or ATOL(i)),
11003 C or the relative error is less than RTOL.
11004 C Use RTOL = 0.0 for pure absolute error control, and
11005 C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error
11006 C control. Caution: Actual (global) errors may exceed these
11007 C local tolerances, so choose them conservatively.
11008 C ITASK = 1 for normal computation of output values of y at t = TOUT.
11009 C ISTATE = integer flag (input and output). Set ISTATE = 1 if the
11010 C initial dy/dt is supplied, and 0 otherwise.
11011 C IOPT = 0 to indicate no optional inputs used.
11012 C RWORK = real work array of length at least:
11013 C 22 + 9*NEQ + NEQ**2 for MF = 21 or 22,
11014 C 22 + 10*NEQ + (2*ML + MU)*NEQ for MF = 24 or 25.
11015 C LRW = declared length of RWORK (in user's dimension).
11016 C IWORK = integer work array of length at least 20 + NEQ.
11017 C If MF = 24 or 25, input in IWORK(1),IWORK(2) the lower
11018 C and upper half-bandwidths ML,MU.
11019 C LIW = declared length of IWORK (in user's dimension).
11020 C MF = method flag. Standard values are:
11021 C 21 for a user-supplied full Jacobian.
11022 C 22 for an internally generated full Jacobian.
11023 C 24 for a user-supplied banded Jacobian.
11024 C 25 for an internally generated banded Jacobian.
11025 C for other choices of MF, see the paragraph on MF in
11026 C the full description below.
11027 C Note that the main program must declare arrays Y, YDOTI, RWORK, IWORK,
11028 C and possibly ATOL.
11029 C
11030 C G. The output from the first call (or any call) is:
11031 C Y = array of computed values of y(t) vector.
11032 C T = corresponding value of independent variable (normally TOUT).
11033 C ISTATE = 2 if DLSODI was successful, negative otherwise.
11034 C -1 means excess work done on this call (check all inputs).
11035 C -2 means excess accuracy requested (tolerances too small).
11036 C -3 means illegal input detected (see printed message).
11037 C -4 means repeated error test failures (check all inputs).
11038 C -5 means repeated convergence failures (perhaps bad Jacobian
11039 C supplied or wrong choice of tolerances).
11040 C -6 means error weight became zero during problem. (Solution
11041 C component i vanished, and ATOL or ATOL(i) = 0.)
11042 C -7 cannot occur in casual use.
11043 C -8 means DLSODI was unable to compute the initial dy/dt.
11044 C In casual use, this means A(t,y) is initially singular.
11045 C Supply YDOTI and use ISTATE = 1 on the first call.
11046 C
11047 C If DLSODI returns ISTATE = -1, -4, or -5, then the output of
11048 C DLSODI also includes YDOTI = array containing residual vector
11049 C r = g - A * dy/dt evaluated at the current t, y, and dy/dt.
11050 C
11051 C H. To continue the integration after a successful return, simply
11052 C reset TOUT and call DLSODI again. No other parameters need be reset.
11053 C
11054 C-----------------------------------------------------------------------
11055 C Example Problem.
11056 C
11057 C The following is a simple example problem, with the coding
11058 C needed for its solution by DLSODI. The problem is from chemical
11059 C kinetics, and consists of the following three equations:
11060 C dy1/dt = -.04*y1 + 1.e4*y2*y3
11061 C dy2/dt = .04*y1 - 1.e4*y2*y3 - 3.e7*y2**2
11062 C 0. = y1 + y2 + y3 - 1.
11063 C on the interval from t = 0.0 to t = 4.e10, with initial conditions
11064 C y1 = 1.0, y2 = y3 = 0.
11065 C
11066 C The following coding solves this problem with DLSODI, using MF = 21
11067 C and printing results at t = .4, 4., ..., 4.e10. It uses
11068 C ITOL = 2 and ATOL much smaller for y2 than y1 or y3 because
11069 C y2 has much smaller values. dy/dt is supplied in YDOTI. We had
11070 C obtained the initial value of dy3/dt by differentiating the
11071 C third equation and evaluating the first two at t = 0.
11072 C At the end of the run, statistical quantities of interest are
11073 C printed (see optional outputs in the full description below).
11074 C
11075 C EXTERNAL RESID, APLUSP, DGBYDY
11076 C DOUBLE PRECISION ATOL, RTOL, RWORK, T, TOUT, Y, YDOTI
11077 C DIMENSION Y(3), YDOTI(3), ATOL(3), RWORK(58), IWORK(23)
11078 C NEQ = 3
11079 C Y(1) = 1.
11080 C Y(2) = 0.
11081 C Y(3) = 0.
11082 C YDOTI(1) = -.04
11083 C YDOTI(2) = .04
11084 C YDOTI(3) = 0.
11085 C T = 0.
11086 C TOUT = .4
11087 C ITOL = 2
11088 C RTOL = 1.D-4
11089 C ATOL(1) = 1.D-6
11090 C ATOL(2) = 1.D-10
11091 C ATOL(3) = 1.D-6
11092 C ITASK = 1
11093 C ISTATE = 1
11094 C IOPT = 0
11095 C LRW = 58
11096 C LIW = 23
11097 C MF = 21
11098 C DO 40 IOUT = 1,12
11099 C CALL DLSODI(RESID, APLUSP, DGBYDY, NEQ, Y, YDOTI, T, TOUT, ITOL,
11100 C 1 RTOL, ATOL, ITASK, ISTATE, IOPT, RWORK, LRW, IWORK, LIW, MF)
11101 C WRITE (6,20) T, Y(1), Y(2), Y(3)
11102 C 20 FORMAT(' At t =',D12.4,' Y =',3D14.6)
11103 C IF (ISTATE .LT. 0 ) GO TO 80
11104 C 40 TOUT = TOUT*10.
11105 C WRITE (6,60) IWORK(11), IWORK(12), IWORK(13)
11106 C 60 FORMAT(/' No. steps =',I4,' No. r-s =',I4,' No. J-s =',I4)
11107 C STOP
11108 C 80 WRITE (6,90) ISTATE
11109 C 90 FORMAT(///' Error halt.. ISTATE =',I3)
11110 C STOP
11111 C END
11112 C
11113 C SUBROUTINE RESID(NEQ, T, Y, S, R, IRES)
11114 C DOUBLE PRECISION T, Y, S, R
11115 C DIMENSION Y(3), S(3), R(3)
11116 C R(1) = -.04*Y(1) + 1.D4*Y(2)*Y(3) - S(1)
11117 C R(2) = .04*Y(1) - 1.D4*Y(2)*Y(3) - 3.D7*Y(2)*Y(2) - S(2)
11118 C R(3) = Y(1) + Y(2) + Y(3) - 1.
11119 C RETURN
11120 C END
11121 C
11122 C SUBROUTINE APLUSP(NEQ, T, Y, ML, MU, P, NROWP)
11123 C DOUBLE PRECISION T, Y, P
11124 C DIMENSION Y(3), P(NROWP,3)
11125 C P(1,1) = P(1,1) + 1.
11126 C P(2,2) = P(2,2) + 1.
11127 C RETURN
11128 C END
11129 C
11130 C SUBROUTINE DGBYDY(NEQ, T, Y, S, ML, MU, P, NROWP)
11131 C DOUBLE PRECISION T, Y, S, P
11132 C DIMENSION Y(3), S(3), P(NROWP,3)
11133 C P(1,1) = -.04
11134 C P(1,2) = 1.D4*Y(3)
11135 C P(1,3) = 1.D4*Y(2)
11136 C P(2,1) = .04
11137 C P(2,2) = -1.D4*Y(3) - 6.D7*Y(2)
11138 C P(2,3) = -1.D4*Y(2)
11139 C P(3,1) = 1.
11140 C P(3,2) = 1.
11141 C P(3,3) = 1.
11142 C RETURN
11143 C END
11144 C
11145 C The output of this program (on a CDC-7600 in single precision)
11146 C is as follows:
11147 C
11148 C At t = 4.0000e-01 Y = 9.851726e-01 3.386406e-05 1.479357e-02
11149 C At t = 4.0000e+00 Y = 9.055142e-01 2.240418e-05 9.446344e-02
11150 C At t = 4.0000e+01 Y = 7.158050e-01 9.184616e-06 2.841858e-01
11151 C At t = 4.0000e+02 Y = 4.504846e-01 3.222434e-06 5.495122e-01
11152 C At t = 4.0000e+03 Y = 1.831701e-01 8.940379e-07 8.168290e-01
11153 C At t = 4.0000e+04 Y = 3.897016e-02 1.621193e-07 9.610297e-01
11154 C At t = 4.0000e+05 Y = 4.935213e-03 1.983756e-08 9.950648e-01
11155 C At t = 4.0000e+06 Y = 5.159269e-04 2.064759e-09 9.994841e-01
11156 C At t = 4.0000e+07 Y = 5.306413e-05 2.122677e-10 9.999469e-01
11157 C At t = 4.0000e+08 Y = 5.494532e-06 2.197826e-11 9.999945e-01
11158 C At t = 4.0000e+09 Y = 5.129457e-07 2.051784e-12 9.999995e-01
11159 C At t = 4.0000e+10 Y = -7.170472e-08 -2.868188e-13 1.000000e+00
11160 C
11161 C No. steps = 330 No. r-s = 404 No. J-s = 69
11162 C
11163 C-----------------------------------------------------------------------
11164 C Full Description of User Interface to DLSODI.
11165 C
11166 C The user interface to DLSODI consists of the following parts.
11167 C
11168 C 1. The call sequence to Subroutine DLSODI, which is a driver
11169 C routine for the solver. This includes descriptions of both
11170 C the call sequence arguments and of user-supplied routines.
11171 C Following these descriptions is a description of
11172 C optional inputs available through the call sequence, and then
11173 C a description of optional outputs (in the work arrays).
11174 C
11175 C 2. Descriptions of other routines in the DLSODI package that may be
11176 C (optionally) called by the user. These provide the ability to
11177 C alter error message handling, save and restore the internal
11178 C Common, and obtain specified derivatives of the solution y(t).
11179 C
11180 C 3. Descriptions of Common blocks to be declared in overlay
11181 C or similar environments, or to be saved when doing an interrupt
11182 C of the problem and continued solution later.
11183 C
11184 C 4. Description of two routines in the DLSODI package, either of
11185 C which the user may replace with his/her own version, if desired.
11186 C These relate to the measurement of errors.
11187 C
11188 C-----------------------------------------------------------------------
11189 C Part 1. Call Sequence.
11190 C
11191 C The call sequence parameters used for input only are
11192 C RES, ADDA, JAC, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK,
11193 C IOPT, LRW, LIW, MF,
11194 C and those used for both input and output are
11195 C Y, T, ISTATE, YDOTI.
11196 C The work arrays RWORK and IWORK are also used for conditional and
11197 C optional inputs and optional outputs. (The term output here refers
11198 C to the return from Subroutine DLSODI to the user's calling program.)
11199 C
11200 C The legality of input parameters will be thoroughly checked on the
11201 C initial call for the problem, but not checked thereafter unless a
11202 C change in input parameters is flagged by ISTATE = 3 on input.
11203 C
11204 C The descriptions of the call arguments are as follows.
11205 C
11206 C RES = the name of the user-supplied subroutine which supplies
11207 C the residual vector for the ODE system, defined by
11208 C r = g(t,y) - A(t,y) * s
11209 C as a function of the scalar t and the vectors
11210 C s and y (s approximates dy/dt). This subroutine
11211 C is to have the form
11212 C SUBROUTINE RES (NEQ, T, Y, S, R, IRES)
11213 C DOUBLE PRECISION T, Y(*), S(*), R(*)
11214 C where NEQ, T, Y, S, and IRES are input, and R and
11215 C IRES are output. Y, S, and R are arrays of length NEQ.
11216 C On input, IRES indicates how DLSODI will use the
11217 C returned array R, as follows:
11218 C IRES = 1 means that DLSODI needs the full residual,
11219 C r = g - A*s, exactly.
11220 C IRES = -1 means that DLSODI is using R only to compute
11221 C the Jacobian dr/dy by difference quotients.
11222 C The RES routine can ignore IRES, or it can omit some terms
11223 C if IRES = -1. If A does not depend on y, then RES can
11224 C just return R = g when IRES = -1. If g - A*s contains other
11225 C additive terms that are independent of y, these can also be
11226 C dropped, if done consistently, when IRES = -1.
11227 C The subroutine should set the flag IRES if it
11228 C encounters a halt condition or illegal input.
11229 C Otherwise, it should not reset IRES. On output,
11230 C IRES = 1 or -1 represents a normal return, and
11231 C DLSODI continues integrating the ODE. Leave IRES
11232 C unchanged from its input value.
11233 C IRES = 2 tells DLSODI to immediately return control
11234 C to the calling program, with ISTATE = 3. This lets
11235 C the calling program change parameters of the problem,
11236 C if necessary.
11237 C IRES = 3 represents an error condition (for example, an
11238 C illegal value of y). DLSODI tries to integrate the system
11239 C without getting IRES = 3 from RES. If it cannot, DLSODI
11240 C returns with ISTATE = -7 or -1.
11241 C On an DLSODI return with ISTATE = 3, -1, or -7, the values
11242 C of T and Y returned correspond to the last point reached
11243 C successfully without getting the flag IRES = 2 or 3.
11244 C The flag values IRES = 2 and 3 should not be used to
11245 C handle switches or root-stop conditions. This is better
11246 C done by calling DLSODI in a one-step mode and checking the
11247 C stopping function for a sign change at each step.
11248 C If quantities computed in the RES routine are needed
11249 C externally to DLSODI, an extra call to RES should be made
11250 C for this purpose, for consistent and accurate results.
11251 C To get the current dy/dt for the S argument, use DINTDY.
11252 C RES must be declared External in the calling
11253 C program. See note below for more about RES.
11254 C
11255 C ADDA = the name of the user-supplied subroutine which adds the
11256 C matrix A = A(t,y) to another matrix stored in the same form
11257 C as A. The storage form is determined by MITER (see MF).
11258 C This subroutine is to have the form
11259 C SUBROUTINE ADDA (NEQ, T, Y, ML, MU, P, NROWP)
11260 C DOUBLE PRECISION T, Y(*), P(NROWP,*)
11261 C where NEQ, T, Y, ML, MU, and NROWP are input and P is
11262 C output. Y is an array of length NEQ, and the matrix P is
11263 C stored in an NROWP by NEQ array.
11264 C In the full matrix case ( MITER = 1 or 2) ADDA should
11265 C add A to P(i,j). ML and MU are ignored.
11266 C i,j
11267 C In the band matrix case ( MITER = 4 or 5) ADDA should
11268 C add A to P(i-j+MU+1,j).
11269 C i,j
11270 C See JAC for details on this band storage form.
11271 C ADDA must be declared External in the calling program.
11272 C See note below for more information about ADDA.
11273 C
11274 C JAC = the name of the user-supplied subroutine which supplies the
11275 C Jacobian matrix, dr/dy, where r = g - A*s. The form of the
11276 C Jacobian matrix is determined by MITER. JAC is required
11277 C if MITER = 1 or 4 -- otherwise a dummy name can be
11278 C passed. This subroutine is to have the form
11279 C SUBROUTINE JAC ( NEQ, T, Y, S, ML, MU, P, NROWP )
11280 C DOUBLE PRECISION T, Y(*), S(*), P(NROWP,*)
11281 C where NEQ, T, Y, S, ML, MU, and NROWP are input and P
11282 C is output. Y and S are arrays of length NEQ, and the
11283 C matrix P is stored in an NROWP by NEQ array.
11284 C P is to be loaded with partial derivatives (elements
11285 C of the Jacobian matrix) on output.
11286 C In the full matrix case (MITER = 1), ML and MU
11287 C are ignored and the Jacobian is to be loaded into P
11288 C by columns-- i.e., dr(i)/dy(j) is loaded into P(i,j).
11289 C In the band matrix case (MITER = 4), the elements
11290 C within the band are to be loaded into P by columns,
11291 C with diagonal lines of dr/dy loaded into the
11292 C rows of P. Thus dr(i)/dy(j) is to be loaded
11293 C into P(i-j+MU+1,j). The locations in P in the two
11294 C triangular areas which correspond to nonexistent matrix
11295 C elements can be ignored or loaded arbitrarily, as they
11296 C they are overwritten by DLSODI. ML and MU are the
11297 C half-bandwidth parameters (see IWORK).
11298 C In either case, P is preset to zero by the solver,
11299 C so that only the nonzero elements need be loaded by JAC.
11300 C Each call to JAC is preceded by a call to RES with the same
11301 C arguments NEQ, T, Y, and S. Thus to gain some efficiency,
11302 C intermediate quantities shared by both calculations may be
11303 C saved in a user Common block by RES and not recomputed by JAC
11304 C if desired. Also, JAC may alter the Y array, if desired.
11305 C JAC need not provide dr/dy exactly. A crude
11306 C approximation (possibly with a smaller bandwidth) will do.
11307 C JAC must be declared External in the calling program.
11308 C See note below for more about JAC.
11309 C
11310 C Note on RES, ADDA, and JAC:
11311 C These subroutines may access user-defined quantities in
11312 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array
11313 C (dimensioned in the subroutines) and/or Y has length
11314 C exceeding NEQ(1). However, these routines should not alter
11315 C NEQ(1), Y(1),...,Y(NEQ) or any other input variables.
11316 C See the descriptions of NEQ and Y below.
11317 C
11318 C NEQ = the size of the system (number of first order ordinary
11319 C differential equations or scalar algebraic equations).
11320 C Used only for input.
11321 C NEQ may be decreased, but not increased, during the problem.
11322 C If NEQ is decreased (with ISTATE = 3 on input), the
11323 C remaining components of Y should be left undisturbed, if
11324 C these are to be accessed in RES, ADDA, or JAC.
11325 C
11326 C Normally, NEQ is a scalar, and it is generally referred to
11327 C as a scalar in this user interface description. However,
11328 C NEQ may be an array, with NEQ(1) set to the system size.
11329 C (The DLSODI package accesses only NEQ(1).) In either case,
11330 C this parameter is passed as the NEQ argument in all calls
11331 C to RES, ADDA, and JAC. Hence, if it is an array,
11332 C locations NEQ(2),... may be used to store other integer data
11333 C and pass it to RES, ADDA, or JAC. Each such subroutine
11334 C must include NEQ in a Dimension statement in that case.
11335 C
11336 C Y = a real array for the vector of dependent variables, of
11337 C length NEQ or more. Used for both input and output on the
11338 C first call (ISTATE = 0 or 1), and only for output on other
11339 C calls. On the first call, Y must contain the vector of
11340 C initial values. On output, Y contains the computed solution
11341 C vector, evaluated at T. If desired, the Y array may be used
11342 C for other purposes between calls to the solver.
11343 C
11344 C This array is passed as the Y argument in all calls to RES,
11345 C ADDA, and JAC. Hence its length may exceed NEQ,
11346 C and locations Y(NEQ+1),... may be used to store other real
11347 C data and pass it to RES, ADDA, or JAC. (The DLSODI
11348 C package accesses only Y(1),...,Y(NEQ). )
11349 C
11350 C YDOTI = a real array for the initial value of the vector
11351 C dy/dt and for work space, of dimension at least NEQ.
11352 C
11353 C On input:
11354 C If ISTATE = 0, then DLSODI will compute the initial value
11355 C of dy/dt, if A is nonsingular. Thus YDOTI will
11356 C serve only as work space and may have any value.
11357 C If ISTATE = 1, then YDOTI must contain the initial value
11358 C of dy/dt.
11359 C If ISTATE = 2 or 3 (continuation calls), then YDOTI
11360 C may have any value.
11361 C Note: If the initial value of A is singular, then
11362 C DLSODI cannot compute the initial value of dy/dt, so
11363 C it must be provided in YDOTI, with ISTATE = 1.
11364 C
11365 C On output, when DLSODI terminates abnormally with ISTATE =
11366 C -1, -4, or -5, YDOTI will contain the residual
11367 C r = g(t,y) - A(t,y)*(dy/dt). If r is large, t is near
11368 C its initial value, and YDOTI is supplied with ISTATE = 1,
11369 C then there may have been an incorrect input value of
11370 C YDOTI = dy/dt, or the problem (as given to DLSODI)
11371 C may not have a solution.
11372 C
11373 C If desired, the YDOTI array may be used for other
11374 C purposes between calls to the solver.
11375 C
11376 C T = the independent variable. On input, T is used only on the
11377 C first call, as the initial point of the integration.
11378 C On output, after each call, T is the value at which a
11379 C computed solution Y is evaluated (usually the same as TOUT).
11380 C on an error return, T is the farthest point reached.
11381 C
11382 C TOUT = the next value of t at which a computed solution is desired.
11383 C Used only for input.
11384 C
11385 C When starting the problem (ISTATE = 0 or 1), TOUT may be
11386 C equal to T for one call, then should .ne. T for the next
11387 C call. For the initial T, an input value of TOUT .ne. T is
11388 C used in order to determine the direction of the integration
11389 C (i.e. the algebraic sign of the step sizes) and the rough
11390 C scale of the problem. Integration in either direction
11391 C (forward or backward in t) is permitted.
11392 C
11393 C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after
11394 C the first call (i.e. the first call with TOUT .ne. T).
11395 C Otherwise, TOUT is required on every call.
11396 C
11397 C If ITASK = 1, 3, or 4, the values of TOUT need not be
11398 C monotone, but a value of TOUT which backs up is limited
11399 C to the current internal T interval, whose endpoints are
11400 C TCUR - HU and TCUR (see optional outputs, below, for
11401 C TCUR and HU).
11402 C
11403 C ITOL = an indicator for the type of error control. See
11404 C description below under ATOL. Used only for input.
11405 C
11406 C RTOL = a relative error tolerance parameter, either a scalar or
11407 C an array of length NEQ. See description below under ATOL.
11408 C Input only.
11409 C
11410 C ATOL = an absolute error tolerance parameter, either a scalar or
11411 C an array of length NEQ. Input only.
11412 C
11413 C The input parameters ITOL, RTOL, and ATOL determine
11414 C the error control performed by the solver. The solver will
11415 C control the vector E = (E(i)) of estimated local errors
11416 C in y, according to an inequality of the form
11417 C RMS-norm of ( E(i)/EWT(i) ) .le. 1,
11418 C where EWT(i) = RTOL(i)*ABS(Y(i)) + ATOL(i),
11419 C and the RMS-norm (root-mean-square norm) here is
11420 C RMS-norm(v) = SQRT(sum v(i)**2 / NEQ). Here EWT = (EWT(i))
11421 C is a vector of weights which must always be positive, and
11422 C the values of RTOL and ATOL should all be non-negative.
11423 C The following table gives the types (scalar/array) of
11424 C RTOL and ATOL, and the corresponding form of EWT(i).
11425 C
11426 C ITOL RTOL ATOL EWT(i)
11427 C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL
11428 C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i)
11429 C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL
11430 C 4 array scalar RTOL(i)*ABS(Y(i)) + ATOL(i)
11431 C
11432 C When either of these parameters is a scalar, it need not
11433 C be dimensioned in the user's calling program.
11434 C
11435 C If none of the above choices (with ITOL, RTOL, and ATOL
11436 C fixed throughout the problem) is suitable, more general
11437 C error controls can be obtained by substituting
11438 C user-supplied routines for the setting of EWT and/or for
11439 C the norm calculation. See Part 4 below.
11440 C
11441 C If global errors are to be estimated by making a repeated
11442 C run on the same problem with smaller tolerances, then all
11443 C components of RTOL and ATOL (i.e. of EWT) should be scaled
11444 C down uniformly.
11445 C
11446 C ITASK = an index specifying the task to be performed.
11447 C Input only. ITASK has the following values and meanings.
11448 C 1 means normal computation of output values of y(t) at
11449 C t = TOUT (by overshooting and interpolating).
11450 C 2 means take one step only and return.
11451 C 3 means stop at the first internal mesh point at or
11452 C beyond t = TOUT and return.
11453 C 4 means normal computation of output values of y(t) at
11454 C t = TOUT but without overshooting t = TCRIT.
11455 C TCRIT must be input as RWORK(1). TCRIT may be equal to
11456 C or beyond TOUT, but not behind it in the direction of
11457 C integration. This option is useful if the problem
11458 C has a singularity at or beyond t = TCRIT.
11459 C 5 means take one step, without passing TCRIT, and return.
11460 C TCRIT must be input as RWORK(1).
11461 C
11462 C Note: If ITASK = 4 or 5 and the solver reaches TCRIT
11463 C (within roundoff), it will return T = TCRIT (exactly) to
11464 C indicate this (unless ITASK = 4 and TOUT comes before TCRIT,
11465 C in which case answers at t = TOUT are returned first).
11466 C
11467 C ISTATE = an index used for input and output to specify the
11468 C state of the calculation.
11469 C
11470 C On input, the values of ISTATE are as follows.
11471 C 0 means this is the first call for the problem, and
11472 C DLSODI is to compute the initial value of dy/dt
11473 C (while doing other initializations). See note below.
11474 C 1 means this is the first call for the problem, and
11475 C the initial value of dy/dt has been supplied in
11476 C YDOTI (DLSODI will do other initializations). See note
11477 C below.
11478 C 2 means this is not the first call, and the calculation
11479 C is to continue normally, with no change in any input
11480 C parameters except possibly TOUT and ITASK.
11481 C (If ITOL, RTOL, and/or ATOL are changed between calls
11482 C with ISTATE = 2, the new values will be used but not
11483 C tested for legality.)
11484 C 3 means this is not the first call, and the
11485 C calculation is to continue normally, but with
11486 C a change in input parameters other than
11487 C TOUT and ITASK. Changes are allowed in
11488 C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, ML, MU,
11489 C and any of the optional inputs except H0.
11490 C (See IWORK description for ML and MU.)
11491 C Note: A preliminary call with TOUT = T is not counted
11492 C as a first call here, as no initialization or checking of
11493 C input is done. (Such a call is sometimes useful for the
11494 C purpose of outputting the initial conditions.)
11495 C Thus the first call for which TOUT .ne. T requires
11496 C ISTATE = 0 or 1 on input.
11497 C
11498 C On output, ISTATE has the following values and meanings.
11499 C 0 or 1 means nothing was done; TOUT = t and
11500 C ISTATE = 0 or 1 on input.
11501 C 2 means that the integration was performed successfully.
11502 C 3 means that the user-supplied Subroutine RES signalled
11503 C DLSODI to halt the integration and return (IRES = 2).
11504 C Integration as far as T was achieved with no occurrence
11505 C of IRES = 2, but this flag was set on attempting the
11506 C next step.
11507 C -1 means an excessive amount of work (more than MXSTEP
11508 C steps) was done on this call, before completing the
11509 C requested task, but the integration was otherwise
11510 C successful as far as T. (MXSTEP is an optional input
11511 C and is normally 500.) To continue, the user may
11512 C simply reset ISTATE to a value .gt. 1 and call again
11513 C (the excess work step counter will be reset to 0).
11514 C In addition, the user may increase MXSTEP to avoid
11515 C this error return (see below on optional inputs).
11516 C -2 means too much accuracy was requested for the precision
11517 C of the machine being used. This was detected before
11518 C completing the requested task, but the integration
11519 C was successful as far as T. To continue, the tolerance
11520 C parameters must be reset, and ISTATE must be set
11521 C to 3. The optional output TOLSF may be used for this
11522 C purpose. (Note: If this condition is detected before
11523 C taking any steps, then an illegal input return
11524 C (ISTATE = -3) occurs instead.)
11525 C -3 means illegal input was detected, before taking any
11526 C integration steps. See written message for details.
11527 C Note: If the solver detects an infinite loop of calls
11528 C to the solver with illegal input, it will cause
11529 C the run to stop.
11530 C -4 means there were repeated error test failures on
11531 C one attempted step, before completing the requested
11532 C task, but the integration was successful as far as T.
11533 C The problem may have a singularity, or the input
11534 C may be inappropriate.
11535 C -5 means there were repeated convergence test failures on
11536 C one attempted step, before completing the requested
11537 C task, but the integration was successful as far as T.
11538 C This may be caused by an inaccurate Jacobian matrix.
11539 C -6 means EWT(i) became zero for some i during the
11540 C integration. pure relative error control (ATOL(i)=0.0)
11541 C was requested on a variable which has now vanished.
11542 C the integration was successful as far as T.
11543 C -7 means that the user-supplied Subroutine RES set
11544 C its error flag (IRES = 3) despite repeated tries by
11545 C DLSODI to avoid that condition.
11546 C -8 means that ISTATE was 0 on input but DLSODI was unable
11547 C to compute the initial value of dy/dt. See the
11548 C printed message for details.
11549 C
11550 C Note: Since the normal output value of ISTATE is 2,
11551 C it does not need to be reset for normal continuation.
11552 C Similarly, ISTATE (= 3) need not be reset if RES told
11553 C DLSODI to return because the calling program must change
11554 C the parameters of the problem.
11555 C Also, since a negative input value of ISTATE will be
11556 C regarded as illegal, a negative output value requires the
11557 C user to change it, and possibly other inputs, before
11558 C calling the solver again.
11559 C
11560 C IOPT = an integer flag to specify whether or not any optional
11561 C inputs are being used on this call. Input only.
11562 C The optional inputs are listed separately below.
11563 C IOPT = 0 means no optional inputs are being used.
11564 C Default values will be used in all cases.
11565 C IOPT = 1 means one or more optional inputs are being used.
11566 C
11567 C RWORK = a real working array (double precision).
11568 C The length of RWORK must be at least
11569 C 20 + NYH*(MAXORD + 1) + 3*NEQ + LENWM where
11570 C NYH = the initial value of NEQ,
11571 C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a
11572 C smaller value is given as an optional input),
11573 C LENWM = NEQ**2 + 2 if MITER is 1 or 2, and
11574 C LENWM = (2*ML+MU+1)*NEQ + 2 if MITER is 4 or 5.
11575 C (See MF description for the definition of METH and MITER.)
11576 C Thus if MAXORD has its default value and NEQ is constant,
11577 C this length is
11578 C 22 + 16*NEQ + NEQ**2 for MF = 11 or 12,
11579 C 22 + 17*NEQ + (2*ML+MU)*NEQ for MF = 14 or 15,
11580 C 22 + 9*NEQ + NEQ**2 for MF = 21 or 22,
11581 C 22 + 10*NEQ + (2*ML+MU)*NEQ for MF = 24 or 25.
11582 C The first 20 words of RWORK are reserved for conditional
11583 C and optional inputs and optional outputs.
11584 C
11585 C The following word in RWORK is a conditional input:
11586 C RWORK(1) = TCRIT = critical value of t which the solver
11587 C is not to overshoot. Required if ITASK is
11588 C 4 or 5, and ignored otherwise. (See ITASK.)
11589 C
11590 C LRW = the length of the array RWORK, as declared by the user.
11591 C (This will be checked by the solver.)
11592 C
11593 C IWORK = an integer work array. The length of IWORK must be at least
11594 C 20 + NEQ . The first few words of IWORK are used for
11595 C conditional and optional inputs and optional outputs.
11596 C
11597 C The following 2 words in IWORK are conditional inputs:
11598 C IWORK(1) = ML These are the lower and upper
11599 C IWORK(2) = MU half-bandwidths, respectively, of the
11600 C matrices in the problem-- the Jacobian dr/dy
11601 C and the left-hand side matrix A. These
11602 C half-bandwidths exclude the main diagonal,
11603 C so the total bandwidth is ML + MU + 1 .
11604 C The band is defined by the matrix locations
11605 C (i,j) with i-ML .le. j .le. i+MU. ML and MU
11606 C must satisfy 0 .le. ML,MU .le. NEQ-1.
11607 C These are required if MITER is 4 or 5, and
11608 C ignored otherwise.
11609 C ML and MU may in fact be the band parameters
11610 C for matrices to which dr/dy and A are only
11611 C approximately equal.
11612 C
11613 C LIW = the length of the array IWORK, as declared by the user.
11614 C (This will be checked by the solver.)
11615 C
11616 C Note: The work arrays must not be altered between calls to DLSODI
11617 C for the same problem, except possibly for the conditional and
11618 C optional inputs, and except for the last 3*NEQ words of RWORK.
11619 C The latter space is used for internal scratch space, and so is
11620 C available for use by the user outside DLSODI between calls, if
11621 C desired (but not for use by RES, ADDA, or JAC).
11622 C
11623 C MF = the method flag. Used only for input. The legal values of
11624 C MF are 11, 12, 14, 15, 21, 22, 24, and 25.
11625 C MF has decimal digits METH and MITER: MF = 10*METH + MITER.
11626 C METH indicates the basic linear multistep method:
11627 C METH = 1 means the implicit Adams method.
11628 C METH = 2 means the method based on Backward
11629 C Differentiation Formulas (BDFs).
11630 C The BDF method is strongly preferred for stiff
11631 C problems, while the Adams method is preferred when
11632 C the problem is not stiff. If the matrix A(t,y) is
11633 C nonsingular, stiffness here can be taken to mean that of
11634 C the explicit ODE system dy/dt = A-inverse * g. If A is
11635 C singular, the concept of stiffness is not well defined.
11636 C If you do not know whether the problem is stiff, we
11637 C recommend using METH = 2. If it is stiff, the advantage
11638 C of METH = 2 over METH = 1 will be great, while if it is
11639 C not stiff, the advantage of METH = 1 will be slight.
11640 C If maximum efficiency is important, some experimentation
11641 C with METH may be necessary.
11642 C MITER indicates the corrector iteration method:
11643 C MITER = 1 means chord iteration with a user-supplied
11644 C full (NEQ by NEQ) Jacobian.
11645 C MITER = 2 means chord iteration with an internally
11646 C generated (difference quotient) full Jacobian.
11647 C This uses NEQ+1 extra calls to RES per dr/dy
11648 C evaluation.
11649 C MITER = 4 means chord iteration with a user-supplied
11650 C banded Jacobian.
11651 C MITER = 5 means chord iteration with an internally
11652 C generated banded Jacobian (using ML+MU+2
11653 C extra calls to RES per dr/dy evaluation).
11654 C If MITER = 1 or 4, the user must supply a Subroutine JAC
11655 C (the name is arbitrary) as described above under JAC.
11656 C For other values of MITER, a dummy argument can be used.
11657 C-----------------------------------------------------------------------
11658 C Optional Inputs.
11659 C
11660 C The following is a list of the optional inputs provided for in the
11661 C call sequence. (See also Part 2.) For each such input variable,
11662 C this table lists its name as used in this documentation, its
11663 C location in the call sequence, its meaning, and the default value.
11664 C the use of any of these inputs requires IOPT = 1, and in that
11665 C case all of these inputs are examined. A value of zero for any
11666 C of these optional inputs will cause the default value to be used.
11667 C Thus to use a subset of the optional inputs, simply preload
11668 C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and
11669 C then set those of interest to nonzero values.
11670 C
11671 C Name Location Meaning and Default Value
11672 C
11673 C H0 RWORK(5) the step size to be attempted on the first step.
11674 C The default value is determined by the solver.
11675 C
11676 C HMAX RWORK(6) the maximum absolute step size allowed.
11677 C The default value is infinite.
11678 C
11679 C HMIN RWORK(7) the minimum absolute step size allowed.
11680 C The default value is 0. (This lower bound is not
11681 C enforced on the final step before reaching TCRIT
11682 C when ITASK = 4 or 5.)
11683 C
11684 C MAXORD IWORK(5) the maximum order to be allowed. The default
11685 C value is 12 if METH = 1, and 5 if METH = 2.
11686 C If MAXORD exceeds the default value, it will
11687 C be reduced to the default value.
11688 C If MAXORD is changed during the problem, it may
11689 C cause the current order to be reduced.
11690 C
11691 C MXSTEP IWORK(6) maximum number of (internally defined) steps
11692 C allowed during one call to the solver.
11693 C The default value is 500.
11694 C
11695 C MXHNIL IWORK(7) maximum number of messages printed (per problem)
11696 C warning that T + H = T on a step (H = step size).
11697 C This must be positive to result in a non-default
11698 C value. The default value is 10.
11699 C-----------------------------------------------------------------------
11700 C Optional Outputs.
11701 C
11702 C As optional additional output from DLSODI, the variables listed
11703 C below are quantities related to the performance of DLSODI
11704 C which are available to the user. These are communicated by way of
11705 C the work arrays, but also have internal mnemonic names as shown.
11706 C Except where stated otherwise, all of these outputs are defined
11707 C on any successful return from DLSODI, and on any return with
11708 C ISTATE = -1, -2, -4, -5, -6, or -7. On a return with -3 (illegal
11709 C input) or -8, they will be unchanged from their existing values
11710 C (if any), except possibly for TOLSF, LENRW, and LENIW.
11711 C On any error return, outputs relevant to the error will be defined,
11712 C as noted below.
11713 C
11714 C Name Location Meaning
11715 C
11716 C HU RWORK(11) the step size in t last used (successfully).
11717 C
11718 C HCUR RWORK(12) the step size to be attempted on the next step.
11719 C
11720 C TCUR RWORK(13) the current value of the independent variable
11721 C which the solver has actually reached, i.e. the
11722 C current internal mesh point in t. On output, TCUR
11723 C will always be at least as far as the argument
11724 C T, but may be farther (if interpolation was done).
11725 C
11726 C TOLSF RWORK(14) a tolerance scale factor, greater than 1.0,
11727 C computed when a request for too much accuracy was
11728 C detected (ISTATE = -3 if detected at the start of
11729 C the problem, ISTATE = -2 otherwise). If ITOL is
11730 C left unaltered but RTOL and ATOL are uniformly
11731 C scaled up by a factor of TOLSF for the next call,
11732 C then the solver is deemed likely to succeed.
11733 C (The user may also ignore TOLSF and alter the
11734 C tolerance parameters in any other way appropriate.)
11735 C
11736 C NST IWORK(11) the number of steps taken for the problem so far.
11737 C
11738 C NRE IWORK(12) the number of residual evaluations (RES calls)
11739 C for the problem so far.
11740 C
11741 C NJE IWORK(13) the number of Jacobian evaluations (each involving
11742 C an evaluation of A and dr/dy) for the problem so
11743 C far. This equals the number of calls to ADDA and
11744 C (if MITER = 1 or 4) JAC, and the number of matrix
11745 C LU decompositions.
11746 C
11747 C NQU IWORK(14) the method order last used (successfully).
11748 C
11749 C NQCUR IWORK(15) the order to be attempted on the next step.
11750 C
11751 C IMXER IWORK(16) the index of the component of largest magnitude in
11752 C the weighted local error vector ( E(i)/EWT(i) ),
11753 C on an error return with ISTATE = -4 or -5.
11754 C
11755 C LENRW IWORK(17) the length of RWORK actually required.
11756 C This is defined on normal returns and on an illegal
11757 C input return for insufficient storage.
11758 C
11759 C LENIW IWORK(18) the length of IWORK actually required.
11760 C This is defined on normal returns and on an illegal
11761 C input return for insufficient storage.
11762 C
11763 C
11764 C The following two arrays are segments of the RWORK array which
11765 C may also be of interest to the user as optional outputs.
11766 C For each array, the table below gives its internal name,
11767 C its base address in RWORK, and its description.
11768 C
11769 C Name Base Address Description
11770 C
11771 C YH 21 the Nordsieck history array, of size NYH by
11772 C (NQCUR + 1), where NYH is the initial value
11773 C of NEQ. For j = 0,1,...,NQCUR, column j+1
11774 C of YH contains HCUR**j/factorial(j) times
11775 C the j-th derivative of the interpolating
11776 C polynomial currently representing the solution,
11777 C evaluated at t = TCUR.
11778 C
11779 C ACOR LENRW-NEQ+1 array of size NEQ used for the accumulated
11780 C corrections on each step, scaled on output to
11781 C represent the estimated local error in y on the
11782 C last step. This is the vector E in the descrip-
11783 C tion of the error control. It is defined only
11784 C on a return from DLSODI with ISTATE = 2.
11785 C
11786 C-----------------------------------------------------------------------
11787 C Part 2. Other Routines Callable.
11788 C
11789 C The following are optional calls which the user may make to
11790 C gain additional capabilities in conjunction with DLSODI.
11791 C (The routines XSETUN and XSETF are designed to conform to the
11792 C SLATEC error handling package.)
11793 C
11794 C Form of Call Function
11795 C CALL XSETUN(LUN) Set the logical unit number, LUN, for
11796 C output of messages from DLSODI, if
11797 C the default is not desired.
11798 C The default value of LUN is 6.
11799 C
11800 C CALL XSETF(MFLAG) Set a flag to control the printing of
11801 C messages by DLSODI.
11802 C MFLAG = 0 means do not print. (Danger:
11803 C This risks losing valuable information.)
11804 C MFLAG = 1 means print (the default).
11805 C
11806 C Either of the above calls may be made at
11807 C any time and will take effect immediately.
11808 C
11809 C CALL DSRCOM(RSAV,ISAV,JOB) saves and restores the contents of
11810 C the internal Common blocks used by
11811 C DLSODI (see Part 3 below).
11812 C RSAV must be a real array of length 218
11813 C or more, and ISAV must be an integer
11814 C array of length 37 or more.
11815 C JOB=1 means save Common into RSAV/ISAV.
11816 C JOB=2 means restore Common from RSAV/ISAV.
11817 C DSRCOM is useful if one is
11818 C interrupting a run and restarting
11819 C later, or alternating between two or
11820 C more problems solved with DLSODI.
11821 C
11822 C CALL DINTDY(,,,,,) Provide derivatives of y, of various
11823 C (see below) orders, at a specified point t, if
11824 C desired. It may be called only after
11825 C a successful return from DLSODI.
11826 C
11827 C The detailed instructions for using DINTDY are as follows.
11828 C The form of the call is:
11829 C
11830 C CALL DINTDY (T, K, RWORK(21), NYH, DKY, IFLAG)
11831 C
11832 C The input parameters are:
11833 C
11834 C T = value of independent variable where answers are desired
11835 C (normally the same as the T last returned by DLSODI).
11836 C For valid results, T must lie between TCUR - HU and TCUR.
11837 C (See optional outputs for TCUR and HU.)
11838 C K = integer order of the derivative desired. K must satisfy
11839 C 0 .le. K .le. NQCUR, where NQCUR is the current order
11840 C (see optional outputs). The capability corresponding
11841 C to K = 0, i.e. computing y(T), is already provided
11842 C by DLSODI directly. Since NQCUR .ge. 1, the first
11843 C derivative dy/dt is always available with DINTDY.
11844 C RWORK(21) = the base address of the history array YH.
11845 C NYH = column length of YH, equal to the initial value of NEQ.
11846 C
11847 C The output parameters are:
11848 C
11849 C DKY = a real array of length NEQ containing the computed value
11850 C of the K-th derivative of y(t).
11851 C IFLAG = integer flag, returned as 0 if K and T were legal,
11852 C -1 if K was illegal, and -2 if T was illegal.
11853 C On an error return, a message is also written.
11854 C-----------------------------------------------------------------------
11855 C Part 3. Common Blocks.
11856 C
11857 C If DLSODI is to be used in an overlay situation, the user
11858 C must declare, in the primary overlay, the variables in:
11859 C (1) the call sequence to DLSODI, and
11860 C (2) the internal Common block
11861 C /DLS001/ of length 255 (218 double precision words
11862 C followed by 37 integer words),
11863 C
11864 C If DLSODI is used on a system in which the contents of internal
11865 C Common blocks are not preserved between calls, the user should
11866 C declare the above Common block in the calling program to insure
11867 C that their contents are preserved.
11868 C
11869 C If the solution of a given problem by DLSODI is to be interrupted
11870 C and then later continued, such as when restarting an interrupted run
11871 C or alternating between two or more problems, the user should save,
11872 C following the return from the last DLSODI call prior to the
11873 C interruption, the contents of the call sequence variables and the
11874 C internal Common blocks, and later restore these values before the
11875 C next DLSODI call for that problem. To save and restore the Common
11876 C blocks, use Subroutine DSRCOM (see Part 2 above).
11877 C
11878 C-----------------------------------------------------------------------
11879 C Part 4. Optionally Replaceable Solver Routines.
11880 C
11881 C Below are descriptions of two routines in the DLSODI package which
11882 C relate to the measurement of errors. Either routine can be
11883 C replaced by a user-supplied version, if desired. However, since such
11884 C a replacement may have a major impact on performance, it should be
11885 C done only when absolutely necessary, and only with great caution.
11886 C (Note: The means by which the package version of a routine is
11887 C superseded by the user's version may be system-dependent.)
11888 C
11889 C (a) DEWSET.
11890 C The following subroutine is called just before each internal
11891 C integration step, and sets the array of error weights, EWT, as
11892 C described under ITOL/RTOL/ATOL above:
11893 C SUBROUTINE DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT)
11894 C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODI call sequence,
11895 C YCUR contains the current dependent variable vector, and
11896 C EWT is the array of weights set by DEWSET.
11897 C
11898 C If the user supplies this subroutine, it must return in EWT(i)
11899 C (i = 1,...,NEQ) a positive quantity suitable for comparing errors
11900 C in y(i) to. The EWT array returned by DEWSET is passed to the DVNORM
11901 C routine (see below), and also used by DLSODI in the computation
11902 C of the optional output IMXER, the diagonal Jacobian approximation,
11903 C and the increments for difference quotient Jacobians.
11904 C
11905 C In the user-supplied version of DEWSET, it may be desirable to use
11906 C the current values of derivatives of y. Derivatives up to order NQ
11907 C are available from the history array YH, described above under
11908 C optional outputs. In DEWSET, YH is identical to the YCUR array,
11909 C extended to NQ + 1 columns with a column length of NYH and scale
11910 C factors of H**j/factorial(j). On the first call for the problem,
11911 C given by NST = 0, NQ is 1 and H is temporarily set to 1.0.
11912 C NYH is the initial value of NEQ. The quantities NQ, H, and NST
11913 C can be obtained by including in DEWSET the statements:
11914 C DOUBLE PRECISION RLS
11915 C COMMON /DLS001/ RLS(218),ILS(37)
11916 C NQ = ILS(33)
11917 C NST = ILS(34)
11918 C H = RLS(212)
11919 C Thus, for example, the current value of dy/dt can be obtained as
11920 C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is
11921 C unnecessary when NST = 0).
11922 C
11923 C (b) DVNORM.
11924 C The following is a real function routine which computes the weighted
11925 C root-mean-square norm of a vector v:
11926 C D = DVNORM (N, V, W)
11927 C where:
11928 C N = the length of the vector,
11929 C V = real array of length N containing the vector,
11930 C W = real array of length N containing weights,
11931 C D = SQRT( (1/N) * sum(V(i)*W(i))**2 ).
11932 C DVNORM is called with N = NEQ and with W(i) = 1.0/EWT(i), where
11933 C EWT is as set by Subroutine DEWSET.
11934 C
11935 C If the user supplies this function, it should return a non-negative
11936 C value of DVNORM suitable for use in the error control in DLSODI.
11937 C None of the arguments should be altered by DVNORM.
11938 C For example, a user-supplied DVNORM routine might:
11939 C -substitute a max-norm of (V(i)*W(i)) for the RMS-norm, or
11940 C -ignore some components of V in the norm, with the effect of
11941 C suppressing the error control on those components of y.
11942 C-----------------------------------------------------------------------
11943 C
11944 C***REVISION HISTORY (YYYYMMDD)
11945 C 19800424 DATE WRITTEN
11946 C 19800519 Corrected access of YH on forced order reduction;
11947 C numerous corrections to prologues and other comments.
11948 C 19800617 In main driver, added loading of SQRT(UROUND) in RWORK;
11949 C minor corrections to main prologue.
11950 C 19800903 Corrected ISTATE logic; minor changes in prologue.
11951 C 19800923 Added zero initialization of HU and NQU.
11952 C 19801028 Reorganized RES calls in AINVG, STODI, and PREPJI;
11953 C in LSODI, corrected NRE increment and reset LDY0 at 580;
11954 C numerous corrections to main prologue.
11955 C 19801218 Revised XERRWD routine; minor corrections to main prologue.
11956 C 19810330 Added Common block /LSI001/; use LSODE's INTDY and SOLSY;
11957 C minor corrections to XERRWD and error message at 604;
11958 C minor corrections to declarations; corrections to prologues.
11959 C 19810818 Numerous revisions: replaced EWT by 1/EWT; used flags
11960 C JCUR, ICF, IERPJ, IERSL between STODI and subordinates;
11961 C added tuning parameters CCMAX, MAXCOR, MSBP, MXNCF;
11962 C reorganized returns from STODI; reorganized type decls.;
11963 C fixed message length in XERRWD; changed default LUNIT to 6;
11964 C changed Common lengths; changed comments throughout.
11965 C 19820906 Corrected use of ABS(H) in STODI; minor comment fixes.
11966 C 19830510 Numerous revisions: revised diff. quotient increment;
11967 C eliminated block /LSI001/, using IERPJ flag;
11968 C revised STODI logic after PJAC return;
11969 C revised tuning of H change and step attempts in STODI;
11970 C corrections to main prologue and internal comments.
11971 C 19870330 Major update: corrected comments throughout;
11972 C removed TRET from Common; rewrote EWSET with 4 loops;
11973 C fixed t test in INTDY; added Cray directives in STODI;
11974 C in STODI, fixed DELP init. and logic around PJAC call;
11975 C combined routines to save/restore Common;
11976 C passed LEVEL = 0 in error message calls (except run abort).
11977 C 20010425 Major update: convert source lines to upper case;
11978 C added *DECK lines; changed from 1 to * in dummy dimensions;
11979 C changed names R1MACH/D1MACH to RUMACH/DUMACH;
11980 C renamed routines for uniqueness across single/double prec.;
11981 C converted intrinsic names to generic form;
11982 C removed ILLIN and NTREP (data loaded) from Common;
11983 C removed all 'own' variables from Common;
11984 C changed error messages to quoted strings;
11985 C replaced XERRWV/XERRWD with 1993 revised version;
11986 C converted prologues, comments, error messages to mixed case;
11987 C converted arithmetic IF statements to logical IF statements;
11988 C numerous corrections to prologues and internal comments.
11989 C 20010507 Converted single precision source to double precision.
11990 C 20020502 Corrected declarations in descriptions of user routines.
11991 C 20031105 Restored 'own' variables to Common block, to enable
11992 C interrupt/restart feature.
11993 C 20031112 Added SAVE statements for data-loaded constants.
11994 C 20031117 Changed internal names NRE, LSAVR to NFE, LSAVF resp.
11995 C
11996 C-----------------------------------------------------------------------
11997 C Other routines in the DLSODI package.
11998 C
11999 C In addition to Subroutine DLSODI, the DLSODI package includes the
12000 C following subroutines and function routines:
12001 C DAINVG computes the initial value of the vector
12002 C dy/dt = A-inverse * g
12003 C DINTDY computes an interpolated value of the y vector at t = TOUT.
12004 C DSTODI is the core integrator, which does one step of the
12005 C integration and the associated error control.
12006 C DCFODE sets all method coefficients and test constants.
12007 C DPREPJI computes and preprocesses the Jacobian matrix
12008 C and the Newton iteration matrix P.
12009 C DSOLSY manages solution of linear system in chord iteration.
12010 C DEWSET sets the error weight vector EWT before each step.
12011 C DVNORM computes the weighted RMS-norm of a vector.
12012 C DSRCOM is a user-callable routine to save and restore
12013 C the contents of the internal Common blocks.
12014 C DGEFA and DGESL are routines from LINPACK for solving full
12015 C systems of linear algebraic equations.
12016 C DGBFA and DGBSL are routines from LINPACK for solving banded
12017 C linear systems.
12018 C DUMACH computes the unit roundoff in a machine-independent manner.
12019 C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all
12020 C error messages and warnings. XERRWD is machine-dependent.
12021 C Note: DVNORM, DUMACH, IXSAV, and IUMACH are function routines.
12022 C All the others are subroutines.
12023 C
12024 C-----------------------------------------------------------------------
12025  EXTERNAL dprepji, dsolsy
12026  DOUBLE PRECISION dumach, dvnorm
12027  INTEGER init, mxstep, mxhnil, nhnil, nslast, nyh, iowns,
12028  1 icf, ierpj, iersl, jcur, jstart, kflag, l,
12029  2 lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
12030  3 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
12031  INTEGER i, i1, i2, ier, iflag, imxer, ires, kgo,
12032  1 leniw, lenrw, lenwm, lp, lyd0, ml, mord, mu, mxhnl0, mxstp0
12033  DOUBLE PRECISION rowns,
12034  1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
12035  DOUBLE PRECISION atoli, ayi, big, ewti, h0, hmax, hmx, rh, rtoli,
12036  1 tcrit, tdist, tnext, tol, tolsf, tp, SIZE, sum, w0
12037  dimension mord(2)
12038  LOGICAL ihit
12039  CHARACTER*60 msg
12040  SAVE mord, mxstp0, mxhnl0
12041 C-----------------------------------------------------------------------
12042 C The following internal Common block contains
12043 C (a) variables which are local to any subroutine but whose values must
12044 C be preserved between calls to the routine ("own" variables), and
12045 C (b) variables which are communicated between subroutines.
12046 C The block DLS001 is declared in subroutines DLSODI, DINTDY, DSTODI,
12047 C DPREPJI, and DSOLSY.
12048 C Groups of variables are replaced by dummy arrays in the Common
12049 C declarations in routines where those variables are not used.
12050 C-----------------------------------------------------------------------
12051  COMMON /dls001/ rowns(209),
12052  1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
12053  2 init, mxstep, mxhnil, nhnil, nslast, nyh, iowns(6),
12054  3 icf, ierpj, iersl, jcur, jstart, kflag, l,
12055  4 lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
12056  5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
12057 C
12058  DATA mord(1),mord(2)/12,5/, mxstp0/500/, mxhnl0/10/
12059 C-----------------------------------------------------------------------
12060 C Block A.
12061 C This code block is executed on every call.
12062 C It tests ISTATE and ITASK for legality and branches appropriately.
12063 C If ISTATE .gt. 1 but the flag INIT shows that initialization has
12064 C not yet been done, an error return occurs.
12065 C If ISTATE = 0 or 1 and TOUT = T, return immediately.
12066 C-----------------------------------------------------------------------
12067  IF (istate .LT. 0 .OR. istate .GT. 3) GO TO 601
12068  IF (itask .LT. 1 .OR. itask .GT. 5) GO TO 602
12069  IF (istate .LE. 1) GO TO 10
12070  IF (init .EQ. 0) GO TO 603
12071  IF (istate .EQ. 2) GO TO 200
12072  GO TO 20
12073  10 init = 0
12074  IF (tout .EQ. t) RETURN
12075 C-----------------------------------------------------------------------
12076 C Block B.
12077 C The next code block is executed for the initial call (ISTATE = 0 or 1)
12078 C or for a continuation call with parameter changes (ISTATE = 3).
12079 C It contains checking of all inputs and various initializations.
12080 C
12081 C First check legality of the non-optional inputs NEQ, ITOL, IOPT,
12082 C MF, ML, and MU.
12083 C-----------------------------------------------------------------------
12084  20 IF (neq(1) .LE. 0) GO TO 604
12085  IF (istate .LE. 1) GO TO 25
12086  IF (neq(1) .GT. n) GO TO 605
12087  25 n = neq(1)
12088  IF (itol .LT. 1 .OR. itol .GT. 4) GO TO 606
12089  IF (iopt .LT. 0 .OR. iopt .GT. 1) GO TO 607
12090  meth = mf/10
12091  miter = mf - 10*meth
12092  IF (meth .LT. 1 .OR. meth .GT. 2) GO TO 608
12093  IF (miter .LE. 0 .OR. miter .GT. 5) GO TO 608
12094  IF (miter .EQ. 3) GO TO 608
12095  IF (miter .LT. 3) GO TO 30
12096  ml = iwork(1)
12097  mu = iwork(2)
12098  IF (ml .LT. 0 .OR. ml .GE. n) GO TO 609
12099  IF (mu .LT. 0 .OR. mu .GE. n) GO TO 610
12100  30 CONTINUE
12101 C Next process and check the optional inputs. --------------------------
12102  IF (iopt .EQ. 1) GO TO 40
12103  maxord = mord(meth)
12104  mxstep = mxstp0
12105  mxhnil = mxhnl0
12106  IF (istate .LE. 1) h0 = 0.0d0
12107  hmxi = 0.0d0
12108  hmin = 0.0d0
12109  GO TO 60
12110  40 maxord = iwork(5)
12111  IF (maxord .LT. 0) GO TO 611
12112  IF (maxord .EQ. 0) maxord = 100
12113  maxord = min(maxord,mord(meth))
12114  mxstep = iwork(6)
12115  IF (mxstep .LT. 0) GO TO 612
12116  IF (mxstep .EQ. 0) mxstep = mxstp0
12117  mxhnil = iwork(7)
12118  IF (mxhnil .LT. 0) GO TO 613
12119  IF (mxhnil .EQ. 0) mxhnil = mxhnl0
12120  IF (istate .GT. 1) GO TO 50
12121  h0 = rwork(5)
12122  IF ((tout - t)*h0 .LT. 0.0d0) GO TO 614
12123  50 hmax = rwork(6)
12124  IF (hmax .LT. 0.0d0) GO TO 615
12125  hmxi = 0.0d0
12126  IF (hmax .GT. 0.0d0) hmxi = 1.0d0/hmax
12127  hmin = rwork(7)
12128  IF (hmin .LT. 0.0d0) GO TO 616
12129 C-----------------------------------------------------------------------
12130 C Set work array pointers and check lengths LRW and LIW.
12131 C Pointers to segments of RWORK and IWORK are named by prefixing L to
12132 C the name of the segment. E.g., the segment YH starts at RWORK(LYH).
12133 C Segments of RWORK (in order) are denoted YH, WM, EWT, SAVR, ACOR.
12134 C-----------------------------------------------------------------------
12135  60 lyh = 21
12136  IF (istate .LE. 1) nyh = n
12137  lwm = lyh + (maxord + 1)*nyh
12138  IF (miter .LE. 2) lenwm = n*n + 2
12139  IF (miter .GE. 4) lenwm = (2*ml + mu + 1)*n + 2
12140  lewt = lwm + lenwm
12141  lsavf = lewt + n
12142  lacor = lsavf + n
12143  lenrw = lacor + n - 1
12144  iwork(17) = lenrw
12145  liwm = 1
12146  leniw = 20 + n
12147  iwork(18) = leniw
12148  IF (lenrw .GT. lrw) GO TO 617
12149  IF (leniw .GT. liw) GO TO 618
12150 C Check RTOL and ATOL for legality. ------------------------------------
12151  rtoli = rtol(1)
12152  atoli = atol(1)
12153  DO 70 i = 1,n
12154  IF (itol .GE. 3) rtoli = rtol(i)
12155  IF (itol .EQ. 2 .OR. itol .EQ. 4) atoli = atol(i)
12156  IF (rtoli .LT. 0.0d0) GO TO 619
12157  IF (atoli .LT. 0.0d0) GO TO 620
12158  70 CONTINUE
12159  IF (istate .LE. 1) GO TO 100
12160 C If ISTATE = 3, set flag to signal parameter changes to DSTODI. -------
12161  jstart = -1
12162  IF (nq .LE. maxord) GO TO 90
12163 C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into YDOTI.---------
12164  DO 80 i = 1,n
12165  80 ydoti(i) = rwork(i+lwm-1)
12166 C Reload WM(1) = RWORK(lWM), since lWM may have changed. ---------------
12167  90 rwork(lwm) = sqrt(uround)
12168  IF (n .EQ. nyh) GO TO 200
12169 C NEQ was reduced. Zero part of YH to avoid undefined references. -----
12170  i1 = lyh + l*nyh
12171  i2 = lyh + (maxord + 1)*nyh - 1
12172  IF (i1 .GT. i2) GO TO 200
12173  DO 95 i = i1,i2
12174  95 rwork(i) = 0.0d0
12175  GO TO 200
12176 C-----------------------------------------------------------------------
12177 C Block C.
12178 C The next block is for the initial call only (ISTATE = 0 or 1).
12179 C It contains all remaining initializations, the call to DAINVG
12180 C (if ISTATE = 1), and the calculation of the initial step size.
12181 C The error weights in EWT are inverted after being loaded.
12182 C-----------------------------------------------------------------------
12183  100 uround = dumach()
12184  tn = t
12185  IF (itask .NE. 4 .AND. itask .NE. 5) GO TO 105
12186  tcrit = rwork(1)
12187  IF ((tcrit - tout)*(tout - t) .LT. 0.0d0) GO TO 625
12188  IF (h0 .NE. 0.0d0 .AND. (t + h0 - tcrit)*h0 .GT. 0.0d0)
12189  1 h0 = tcrit - t
12190  105 jstart = 0
12191  rwork(lwm) = sqrt(uround)
12192  nhnil = 0
12193  nst = 0
12194  nfe = 0
12195  nje = 0
12196  nslast = 0
12197  hu = 0.0d0
12198  nqu = 0
12199  ccmax = 0.3d0
12200  maxcor = 3
12201  msbp = 20
12202  mxncf = 10
12203 C Compute initial dy/dt, if necessary, and load it and initial Y into YH
12204  lyd0 = lyh + nyh
12205  lp = lwm + 1
12206  IF (istate .EQ. 1) GO TO 120
12207 C DLSODI must compute initial dy/dt (LYD0 points to YH(*,2)). ----------
12208  CALL dainvg( res, adda, neq, t, y, rwork(lyd0), miter,
12209  1 ml, mu, rwork(lp), iwork(21), ier )
12210  nfe = nfe + 1
12211  IF (ier .LT. 0) GO TO 560
12212  IF (ier .GT. 0) GO TO 565
12213  DO 115 i = 1,n
12214  115 rwork(i+lyh-1) = y(i)
12215  GO TO 130
12216 C Initial dy/dt was supplied. Load into YH (LYD0 points to YH(*,2).). -
12217  120 DO 125 i = 1,n
12218  rwork(i+lyh-1) = y(i)
12219  125 rwork(i+lyd0-1) = ydoti(i)
12220 C Load and invert the EWT array. (H is temporarily set to 1.0.) -------
12221  130 CONTINUE
12222  nq = 1
12223  h = 1.0d0
12224  CALL dewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt))
12225  DO 135 i = 1,n
12226  IF (rwork(i+lewt-1) .LE. 0.0d0) GO TO 621
12227  135 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1)
12228 C-----------------------------------------------------------------------
12229 C The coding below computes the step size, H0, to be attempted on the
12230 C first step, unless the user has supplied a value for this.
12231 C First check that TOUT - T differs significantly from zero.
12232 C A scalar tolerance quantity TOL is computed, as MAX(RTOL(i))
12233 C if this is positive, or MAX(ATOL(i)/ABS(Y(i))) otherwise, adjusted
12234 C so as to be between 100*UROUND and 1.0E-3.
12235 C Then the computed value H0 is given by..
12236 C NEQ
12237 C H0**2 = TOL / ( w0**-2 + (1/NEQ) * Sum ( YDOT(i)/ywt(i) )**2 )
12238 C 1
12239 C where w0 = MAX ( ABS(T), ABS(TOUT) ),
12240 C YDOT(i) = i-th component of initial value of dy/dt,
12241 C ywt(i) = EWT(i)/TOL (a weight for y(i)).
12242 C The sign of H0 is inferred from the initial values of TOUT and T.
12243 C-----------------------------------------------------------------------
12244  IF (h0 .NE. 0.0d0) GO TO 180
12245  tdist = abs(tout - t)
12246  w0 = max(abs(t),abs(tout))
12247  IF (tdist .LT. 2.0d0*uround*w0) GO TO 622
12248  tol = rtol(1)
12249  IF (itol .LE. 2) GO TO 145
12250  DO 140 i = 1,n
12251  140 tol = max(tol,rtol(i))
12252  145 IF (tol .GT. 0.0d0) GO TO 160
12253  atoli = atol(1)
12254  DO 150 i = 1,n
12255  IF (itol .EQ. 2 .OR. itol .EQ. 4) atoli = atol(i)
12256  ayi = abs(y(i))
12257  IF (ayi .NE. 0.0d0) tol = max(tol,atoli/ayi)
12258  150 CONTINUE
12259  160 tol = max(tol,100.0d0*uround)
12260  tol = min(tol,0.001d0)
12261  sum = dvnorm(n, rwork(lyd0), rwork(lewt))
12262  sum = 1.0d0/(tol*w0*w0) + tol*sum**2
12263  h0 = 1.0d0/sqrt(sum)
12264  h0 = min(h0,tdist)
12265  h0 = sign(h0,tout-t)
12266 C Adjust H0 if necessary to meet HMAX bound. ---------------------------
12267  180 rh = abs(h0)*hmxi
12268  IF (rh .GT. 1.0d0) h0 = h0/rh
12269 C Load H with H0 and scale YH(*,2) by H0. ------------------------------
12270  h = h0
12271  DO 190 i = 1,n
12272  190 rwork(i+lyd0-1) = h0*rwork(i+lyd0-1)
12273  GO TO 270
12274 C-----------------------------------------------------------------------
12275 C Block D.
12276 C The next code block is for continuation calls only (ISTATE = 2 or 3)
12277 C and is to check stop conditions before taking a step.
12278 C-----------------------------------------------------------------------
12279  200 nslast = nst
12280  GO TO (210, 250, 220, 230, 240), itask
12281  210 IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
12282  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
12283  IF (iflag .NE. 0) GO TO 627
12284  t = tout
12285  GO TO 420
12286  220 tp = tn - hu*(1.0d0 + 100.0d0*uround)
12287  IF ((tp - tout)*h .GT. 0.0d0) GO TO 623
12288  IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
12289  GO TO 400
12290  230 tcrit = rwork(1)
12291  IF ((tn - tcrit)*h .GT. 0.0d0) GO TO 624
12292  IF ((tcrit - tout)*h .LT. 0.0d0) GO TO 625
12293  IF ((tn - tout)*h .LT. 0.0d0) GO TO 245
12294  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
12295  IF (iflag .NE. 0) GO TO 627
12296  t = tout
12297  GO TO 420
12298  240 tcrit = rwork(1)
12299  IF ((tn - tcrit)*h .GT. 0.0d0) GO TO 624
12300  245 hmx = abs(tn) + abs(h)
12301  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
12302  IF (ihit) GO TO 400
12303  tnext = tn + h*(1.0d0 + 4.0d0*uround)
12304  IF ((tnext - tcrit)*h .LE. 0.0d0) GO TO 250
12305  h = (tcrit - tn)*(1.0d0 - 4.0d0*uround)
12306  IF (istate .EQ. 2) jstart = -2
12307 C-----------------------------------------------------------------------
12308 C Block E.
12309 C The next block is normally executed for all calls and contains
12310 C the call to the one-step core integrator DSTODI.
12311 C
12312 C This is a looping point for the integration steps.
12313 C
12314 C First check for too many steps being taken, update EWT (if not at
12315 C start of problem), check for too much accuracy being requested, and
12316 C check for H below the roundoff level in T.
12317 C-----------------------------------------------------------------------
12318  250 CONTINUE
12319  IF ((nst-nslast) .GE. mxstep) GO TO 500
12320  CALL dewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt))
12321  DO 260 i = 1,n
12322  IF (rwork(i+lewt-1) .LE. 0.0d0) GO TO 510
12323  260 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1)
12324  270 tolsf = uround*dvnorm(n, rwork(lyh), rwork(lewt))
12325  IF (tolsf .LE. 1.0d0) GO TO 280
12326  tolsf = tolsf*2.0d0
12327  IF (nst .EQ. 0) GO TO 626
12328  GO TO 520
12329  280 IF ((tn + h) .NE. tn) GO TO 290
12330  nhnil = nhnil + 1
12331  IF (nhnil .GT. mxhnil) GO TO 290
12332  msg = 'DLSODI- Warning..Internal T (=R1) and H (=R2) are'
12333  CALL xerrwd (msg, 50, 101, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
12334  msg=' such that in the machine, T + H = T on the next step '
12335  CALL xerrwd (msg, 60, 101, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
12336  msg = ' (H = step size). Solver will continue anyway.'
12337  CALL xerrwd (msg, 50, 101, 0, 0, 0, 0, 2, tn, h)
12338  IF (nhnil .LT. mxhnil) GO TO 290
12339  msg = 'DLSODI- Above warning has been issued I1 times. '
12340  CALL xerrwd (msg, 50, 102, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
12341  msg = ' It will not be issued again for this problem.'
12342  CALL xerrwd (msg, 50, 102, 0, 1, mxhnil, 0, 0, 0.0d0, 0.0d0)
12343  290 CONTINUE
12344 C-----------------------------------------------------------------------
12345 C CALL DSTODI(NEQ,Y,YH,NYH,YH1,EWT,SAVF,SAVR,ACOR,WM,IWM,RES,
12346 C ADDA,JAC,DPREPJI,DSOLSY)
12347 C Note: SAVF in DSTODI occupies the same space as YDOTI in DLSODI.
12348 C-----------------------------------------------------------------------
12349  CALL dstodi (neq, y, rwork(lyh), nyh, rwork(lyh), rwork(lewt),
12350  1 ydoti, rwork(lsavf), rwork(lacor), rwork(lwm),
12351  2 iwork(liwm), res, adda, jac, dprepji, dsolsy )
12352  kgo = 1 - kflag
12353  GO TO (300, 530, 540, 400, 550), kgo
12354 C
12355 C KGO = 1:success; 2:error test failure; 3:convergence failure;
12356 C 4:RES ordered return. 5:RES returned error.
12357 C-----------------------------------------------------------------------
12358 C Block F.
12359 C The following block handles the case of a successful return from the
12360 C core integrator (KFLAG = 0). Test for stop conditions.
12361 C-----------------------------------------------------------------------
12362  300 init = 1
12363  GO TO (310, 400, 330, 340, 350), itask
12364 C ITASK = 1. If TOUT has been reached, interpolate. -------------------
12365  310 IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
12366  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
12367  t = tout
12368  GO TO 420
12369 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------
12370  330 IF ((tn - tout)*h .GE. 0.0d0) GO TO 400
12371  GO TO 250
12372 C ITASK = 4. see if TOUT or TCRIT was reached. adjust h if necessary.
12373  340 IF ((tn - tout)*h .LT. 0.0d0) GO TO 345
12374  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
12375  t = tout
12376  GO TO 420
12377  345 hmx = abs(tn) + abs(h)
12378  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
12379  IF (ihit) GO TO 400
12380  tnext = tn + h*(1.0d0 + 4.0d0*uround)
12381  IF ((tnext - tcrit)*h .LE. 0.0d0) GO TO 250
12382  h = (tcrit - tn)*(1.0d0 - 4.0d0*uround)
12383  jstart = -2
12384  GO TO 250
12385 C ITASK = 5. See if TCRIT was reached and jump to exit. ---------------
12386  350 hmx = abs(tn) + abs(h)
12387  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
12388 C-----------------------------------------------------------------------
12389 C Block G.
12390 C The following block handles all successful returns from DLSODI.
12391 C if ITASK .ne. 1, Y is loaded from YH and T is set accordingly.
12392 C ISTATE is set to 2, and the optional outputs are loaded into the
12393 C work arrays before returning.
12394 C-----------------------------------------------------------------------
12395  400 DO 410 i = 1,n
12396  410 y(i) = rwork(i+lyh-1)
12397  t = tn
12398  IF (itask .NE. 4 .AND. itask .NE. 5) GO TO 420
12399  IF (ihit) t = tcrit
12400  420 istate = 2
12401  IF (kflag .EQ. -3) istate = 3
12402  rwork(11) = hu
12403  rwork(12) = h
12404  rwork(13) = tn
12405  iwork(11) = nst
12406  iwork(12) = nfe
12407  iwork(13) = nje
12408  iwork(14) = nqu
12409  iwork(15) = nq
12410  RETURN
12411 C-----------------------------------------------------------------------
12412 C Block H.
12413 C The following block handles all unsuccessful returns other than
12414 C those for illegal input. First the error message routine is called.
12415 C If there was an error test or convergence test failure, IMXER is set.
12416 C Then Y is loaded from YH and T is set to TN.
12417 C The optional outputs are loaded into the work arrays before returning.
12418 C-----------------------------------------------------------------------
12419 C The maximum number of steps was taken before reaching TOUT. ----------
12420  500 msg = 'DLSODI- At current T (=R1), MXSTEP (=I1) steps '
12421  CALL xerrwd (msg, 50, 201, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
12422  msg = ' taken on this call before reaching TOUT '
12423  CALL xerrwd (msg, 50, 201, 0, 1, mxstep, 0, 1, tn, 0.0d0)
12424  istate = -1
12425  GO TO 580
12426 C EWT(i) .le. 0.0 for some i (not at start of problem). ----------------
12427  510 ewti = rwork(lewt+i-1)
12428  msg = .le.'DLSODI- At T (=R1), EWT(I1) has become R2 0.'
12429  CALL xerrwd (msg, 50, 202, 0, 1, i, 0, 2, tn, ewti)
12430  istate = -6
12431  GO TO 590
12432 C Too much accuracy requested for machine precision. -------------------
12433  520 msg = 'DLSODI- At T (=R1), too much accuracy requested '
12434  CALL xerrwd (msg, 50, 203, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
12435  msg = ' for precision of machine.. See TOLSF (=R2) '
12436  CALL xerrwd (msg, 50, 203, 0, 0, 0, 0, 2, tn, tolsf)
12437  rwork(14) = tolsf
12438  istate = -2
12439  GO TO 590
12440 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. -----
12441  530 msg = 'DLSODI- At T(=R1) and step size H(=R2), the error'
12442  CALL xerrwd (msg, 50, 204, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
12443  msg = ' test failed repeatedly or with ABS(H) = HMIN'
12444  CALL xerrwd (msg, 50, 204, 0, 0, 0, 0, 2, tn, h)
12445  istate = -4
12446  GO TO 570
12447 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ----
12448  540 msg = 'DLSODI- At T (=R1) and step size H (=R2), the '
12449  CALL xerrwd (msg, 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
12450  msg = ' corrector convergence failed repeatedly '
12451  CALL xerrwd (msg, 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
12452  msg = ' or with ABS(H) = HMIN '
12453  CALL xerrwd (msg, 30, 205, 0, 0, 0, 0, 2, tn, h)
12454  istate = -5
12455  GO TO 570
12456 C IRES = 3 returned by RES, despite retries by DSTODI. -----------------
12457  550 msg = 'DLSODI- At T (=R1) residual routine returned '
12458  CALL xerrwd (msg, 50, 206, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
12459  msg = ' error IRES = 3 repeatedly. '
12460  CALL xerrwd (msg, 40, 206, 0, 0, 0, 0, 1, tn, 0.0d0)
12461  istate = -7
12462  GO TO 590
12463 C DAINVG failed because matrix A was singular. -------------------------
12464  560 ier = -ier
12465  msg='DLSODI- Attempt to initialize dy/dt failed: Matrix A is '
12466  CALL xerrwd (msg, 60, 207, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
12467  msg = ' singular. DGEFA or DGBFA returned INFO = I1'
12468  CALL xerrwd (msg, 50, 207, 0, 1, ier, 0, 0, 0.0d0, 0.0d0)
12469  istate = -8
12470  RETURN
12471 C DAINVG failed because RES set IRES to 2 or 3. ------------------------
12472  565 msg = 'DLSODI- Attempt to initialize dy/dt failed '
12473  CALL xerrwd (msg, 50, 208, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
12474  msg = ' because residual routine set its error flag '
12475  CALL xerrwd (msg, 50, 208, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
12476  msg = ' to IRES = (I1)'
12477  CALL xerrwd (msg, 20, 208, 0, 1, ier, 0, 0, 0.0d0, 0.0d0)
12478  istate = -8
12479  RETURN
12480 C Compute IMXER if relevant. -------------------------------------------
12481  570 big = 0.0d0
12482  imxer = 1
12483  DO 575 i = 1,n
12484  SIZE = abs(rwork(i+lacor-1)*rwork(i+lewt-1))
12485  IF (big .GE. size) GO TO 575
12486  big = SIZE
12487  imxer = i
12488  575 CONTINUE
12489  iwork(16) = imxer
12490 C Compute residual if relevant. ----------------------------------------
12491  580 lyd0 = lyh + nyh
12492  DO 585 i = 1,n
12493  rwork(i+lsavf-1) = rwork(i+lyd0-1)/h
12494  585 y(i) = rwork(i+lyh-1)
12495  ires = 1
12496  CALL res (neq, tn, y, rwork(lsavf), ydoti, ires )
12497  nfe = nfe + 1
12498  IF (ires .LE. 1) GO TO 595
12499  msg = 'DLSODI- Residual routine set its flag IRES '
12500  CALL xerrwd (msg, 50, 210, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
12501  msg = ' to (I1) when called for final output. '
12502  CALL xerrwd (msg, 50, 210, 0, 1, ires, 0, 0, 0.0d0, 0.0d0)
12503  GO TO 595
12504 C Set Y vector, T, and optional outputs. -------------------------------
12505  590 DO 592 i = 1,n
12506  592 y(i) = rwork(i+lyh-1)
12507  595 t = tn
12508  rwork(11) = hu
12509  rwork(12) = h
12510  rwork(13) = tn
12511  iwork(11) = nst
12512  iwork(12) = nfe
12513  iwork(13) = nje
12514  iwork(14) = nqu
12515  iwork(15) = nq
12516  RETURN
12517 C-----------------------------------------------------------------------
12518 C Block I.
12519 C The following block handles all error returns due to illegal input
12520 C (ISTATE = -3), as detected before calling the core integrator.
12521 C First the error message routine is called. If the illegal input
12522 C is a negative ISTATE, the run is aborted (apparent infinite loop).
12523 C-----------------------------------------------------------------------
12524  601 msg = 'DLSODI- ISTATE (=I1) illegal.'
12525  CALL xerrwd (msg, 30, 1, 0, 1, istate, 0, 0, 0.0d0, 0.0d0)
12526  IF (istate .LT. 0) GO TO 800
12527  GO TO 700
12528  602 msg = 'DLSODI- ITASK (=I1) illegal. '
12529  CALL xerrwd (msg, 30, 2, 0, 1, itask, 0, 0, 0.0d0, 0.0d0)
12530  GO TO 700
12531  603 msg = .gt.'DLSODI- ISTATE 1 but DLSODI not initialized.'
12532  CALL xerrwd (msg, 50, 3, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
12533  GO TO 700
12534  604 msg = .lt.'DLSODI- NEQ (=I1) 1 '
12535  CALL xerrwd (msg, 30, 4, 0, 1, neq(1), 0, 0, 0.0d0, 0.0d0)
12536  GO TO 700
12537  605 msg = 'DLSODI- ISTATE = 3 and NEQ increased (I1 to I2). '
12538  CALL xerrwd (msg, 50, 5, 0, 2, n, neq(1), 0, 0.0d0, 0.0d0)
12539  GO TO 700
12540  606 msg = 'DLSODI- ITOL (=I1) illegal. '
12541  CALL xerrwd (msg, 30, 6, 0, 1, itol, 0, 0, 0.0d0, 0.0d0)
12542  GO TO 700
12543  607 msg = 'DLSODI- IOPT (=I1) illegal. '
12544  CALL xerrwd (msg, 30, 7, 0, 1, iopt, 0, 0, 0.0d0, 0.0d0)
12545  GO TO 700
12546  608 msg = 'DLSODI- MF (=I1) illegal. '
12547  CALL xerrwd (msg, 30, 8, 0, 1, mf, 0, 0, 0.0d0, 0.0d0)
12548  GO TO 700
12549  609 msg = .lt..ge.'DLSODI- ML(=I1) illegal: 0 or NEQ(=I2) '
12550  CALL xerrwd (msg, 50, 9, 0, 2, ml, neq(1), 0, 0.0d0, 0.0d0)
12551  GO TO 700
12552  610 msg = .lt..ge.'DLSODI- MU(=I1) illegal: 0 or NEQ(=I2) '
12553  CALL xerrwd (msg, 50, 10, 0, 2, mu, neq(1), 0, 0.0d0, 0.0d0)
12554  GO TO 700
12555  611 msg = .lt.'DLSODI- MAXORD (=I1) 0 '
12556  CALL xerrwd (msg, 30, 11, 0, 1, maxord, 0, 0, 0.0d0, 0.0d0)
12557  GO TO 700
12558  612 msg = .lt.'DLSODI- MXSTEP (=I1) 0 '
12559  CALL xerrwd (msg, 30, 12, 0, 1, mxstep, 0, 0, 0.0d0, 0.0d0)
12560  GO TO 700
12561  613 msg = .lt.'DLSODI- MXHNIL (=I1) 0 '
12562  CALL xerrwd (msg, 30, 13, 0, 1, mxhnil, 0, 0, 0.0d0, 0.0d0)
12563  GO TO 700
12564  614 msg = 'DLSODI- TOUT (=R1) behind T (=R2) '
12565  CALL xerrwd (msg, 40, 14, 0, 0, 0, 0, 2, tout, t)
12566  msg = ' Integration direction is given by H0 (=R1) '
12567  CALL xerrwd (msg, 50, 14, 0, 0, 0, 0, 1, h0, 0.0d0)
12568  GO TO 700
12569  615 msg = .lt.'DLSODI- HMAX (=R1) 0.0 '
12570  CALL xerrwd (msg, 30, 15, 0, 0, 0, 0, 1, hmax, 0.0d0)
12571  GO TO 700
12572  616 msg = .lt.'DLSODI- HMIN (=R1) 0.0 '
12573  CALL xerrwd (msg, 30, 16, 0, 0, 0, 0, 1, hmin, 0.0d0)
12574  GO TO 700
12575  617 msg='DLSODI- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)'
12576  CALL xerrwd (msg, 60, 17, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0)
12577  GO TO 700
12578  618 msg='DLSODI- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)'
12579  CALL xerrwd (msg, 60, 18, 0, 2, leniw, liw, 0, 0.0d0, 0.0d0)
12580  GO TO 700
12581  619 msg = .lt.'DLSODI- RTOL(=I1) is R1 0.0 '
12582  CALL xerrwd (msg, 40, 19, 0, 1, i, 0, 1, rtoli, 0.0d0)
12583  GO TO 700
12584  620 msg = .lt.'DLSODI- ATOL(=I1) is R1 0.0 '
12585  CALL xerrwd (msg, 40, 20, 0, 1, i, 0, 1, atoli, 0.0d0)
12586  GO TO 700
12587  621 ewti = rwork(lewt+i-1)
12588  msg = .le.'DLSODI- EWT(I1) is R1 0.0 '
12589  CALL xerrwd (msg, 40, 21, 0, 1, i, 0, 1, ewti, 0.0d0)
12590  GO TO 700
12591  622 msg='DLSODI- TOUT(=R1) too close to T(=R2) to start integration.'
12592  CALL xerrwd (msg, 60, 22, 0, 0, 0, 0, 2, tout, t)
12593  GO TO 700
12594  623 msg='DLSODI- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) '
12595  CALL xerrwd (msg, 60, 23, 0, 1, itask, 0, 2, tout, tp)
12596  GO TO 700
12597  624 msg='DLSODI- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) '
12598  CALL xerrwd (msg, 60, 24, 0, 0, 0, 0, 2, tcrit, tn)
12599  GO TO 700
12600  625 msg='DLSODI- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) '
12601  CALL xerrwd (msg, 60, 25, 0, 0, 0, 0, 2, tcrit, tout)
12602  GO TO 700
12603  626 msg = 'DLSODI- At start of problem, too much accuracy '
12604  CALL xerrwd (msg, 50, 26, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
12605  msg=' requested for precision of machine.. See TOLSF (=R1) '
12606  CALL xerrwd (msg, 60, 26, 0, 0, 0, 0, 1, tolsf, 0.0d0)
12607  rwork(14) = tolsf
12608  GO TO 700
12609  627 msg = 'DLSODI- Trouble in DINTDY. ITASK = I1, TOUT = R1'
12610  CALL xerrwd (msg, 50, 27, 0, 1, itask, 0, 1, tout, 0.0d0)
12611 C
12612  700 istate = -3
12613  RETURN
12614 C
12615  800 msg = 'DLSODI- Run aborted.. apparent infinite loop. '
12616  CALL xerrwd (msg, 50, 303, 2, 0, 0, 0, 0, 0.0d0, 0.0d0)
12617  RETURN
12618 C----------------------- End of Subroutine DLSODI ----------------------
12619  END
12620 *DECK DLSOIBT
12621  SUBROUTINE dlsoibt (RES, ADDA, JAC, NEQ, Y, YDOTI, T, TOUT, ITOL,
12622  1 RTOL, ATOL, ITASK, ISTATE, IOPT, RWORK, LRW, IWORK, LIW, MF )
12623  EXTERNAL res, adda, jac
12624  INTEGER neq, itol, itask, istate, iopt, lrw, iwork, liw, mf
12625  DOUBLE PRECISION y, ydoti, t, tout, rtol, atol, rwork
12626  dimension neq(*), y(*), ydoti(*), rtol(*), atol(*), rwork(lrw),
12627  1 iwork(liw)
12628 C-----------------------------------------------------------------------
12629 C This is the 18 November 2003 version of
12630 C DLSOIBT: Livermore Solver for Ordinary differential equations given
12631 C in Implicit form, with Block-Tridiagonal Jacobian treatment.
12632 C
12633 C This version is in double precision.
12634 C
12635 C DLSOIBT solves the initial value problem for linearly implicit
12636 C systems of first order ODEs,
12637 C A(t,y) * dy/dt = g(t,y) , where A(t,y) is a square matrix,
12638 C or, in component form,
12639 C ( a * ( dy / dt )) + ... + ( a * ( dy / dt )) =
12640 C i,1 1 i,NEQ NEQ
12641 C
12642 C = g ( t, y , y ,..., y ) ( i = 1,...,NEQ )
12643 C i 1 2 NEQ
12644 C
12645 C If A is singular, this is a differential-algebraic system.
12646 C
12647 C DLSOIBT is a variant version of the DLSODI package, for the case where
12648 C the matrices A, dg/dy, and d(A*s)/dy are all block-tridiagonal.
12649 C-----------------------------------------------------------------------
12650 C Reference:
12651 C Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE
12652 C Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.),
12653 C North-Holland, Amsterdam, 1983, pp. 55-64.
12654 C-----------------------------------------------------------------------
12655 C Authors: Alan C. Hindmarsh and Jeffrey F. Painter
12656 C Center for Applied Scientific Computing, L-561
12657 C Lawrence Livermore National Laboratory
12658 C Livermore, CA 94551
12659 C and
12660 C Charles S. Kenney
12661 C formerly at: Naval Weapons Center
12662 C China Lake, CA 93555
12663 C-----------------------------------------------------------------------
12664 C Summary of Usage.
12665 C
12666 C Communication between the user and the DLSOIBT package, for normal
12667 C situations, is summarized here. This summary describes only a subset
12668 C of the full set of options available. See the full description for
12669 C details, including optional communication, nonstandard options,
12670 C and instructions for special situations. See also the example
12671 C problem (with program and output) following this summary.
12672 C
12673 C A. First, provide a subroutine of the form:
12674 C SUBROUTINE RES (NEQ, T, Y, S, R, IRES)
12675 C DOUBLE PRECISION T, Y(*), S(*), R(*)
12676 C which computes the residual function
12677 C r = g(t,y) - A(t,y) * s ,
12678 C as a function of t and the vectors y and s. (s is an internally
12679 C generated approximation to dy/dt.) The arrays Y and S are inputs
12680 C to the RES routine and should not be altered. The residual
12681 C vector is to be stored in the array R. The argument IRES should be
12682 C ignored for casual use of DLSOIBT. (For uses of IRES, see the
12683 C paragraph on RES in the full description below.)
12684 C
12685 C B. Next, identify the block structure of the matrices A = A(t,y) and
12686 C dr/dy. DLSOIBT must deal internally with a linear combination, P, of
12687 C these two matrices. The matrix P (hence both A and dr/dy) must have
12688 C a block-tridiagonal form with fixed structure parameters
12689 C MB = block size, MB .ge. 1, and
12690 C NB = number of blocks in each direction, NB .ge. 4,
12691 C with MB*NB = NEQ. In each of the NB block-rows of the matrix P
12692 C (each consisting of MB consecutive rows), the nonzero elements are
12693 C to lie in three consecutive MB by MB blocks. In block-rows
12694 C 2 through NB - 1, these are centered about the main diagonal.
12695 C in block-rows 1 and NB, they are the diagonal blocks and the two
12696 C blocks adjacent to the diagonal block. (Thus block positions (1,3)
12697 C and (NB,NB-2) can be nonzero.)
12698 C Alternatively, P (hence A and dr/dy) may be only approximately
12699 C equal to matrices with this form, and DLSOIBT should still succeed.
12700 C The block-tridiagonal matrix P is described by three arrays,
12701 C each of size MB by MB by NB:
12702 C PA = array of diagonal blocks,
12703 C PB = array of superdiagonal (and one subdiagonal) blocks, and
12704 C PC = array of subdiagonal (and one superdiagonal) blocks.
12705 C Specifically, the three MB by MB blocks in the k-th block-row of P
12706 C are stored in (reading across):
12707 C PC(*,*,k) = block to the left of the diagonal block,
12708 C PA(*,*,k) = diagonal block, and
12709 C PB(*,*,k) = block to the right of the diagonal block,
12710 C except for k = 1, where the three blocks (reading across) are
12711 C PA(*,*,1) (= diagonal block), PB(*,*,1), and PC(*,*,1),
12712 C and k = NB, where they are
12713 C PB(*,*,NB), PC(*,*,NB), and PA(*,*,NB) (= diagonal block).
12714 C (Each asterisk * stands for an index that ranges from 1 to MB.)
12715 C
12716 C C. You must also provide a subroutine of the form:
12717 C SUBROUTINE ADDA (NEQ, T, Y, MB, NB, PA, PB, PC)
12718 C DOUBLE PRECISION T, Y(*), PA(MB,MB,NB), PB(MB,MB,NB), PC(MB,MB,NB)
12719 C which adds the nonzero blocks of the matrix A = A(t,y) to the
12720 C contents of the arrays PA, PB, and PC, following the structure
12721 C description in Paragraph B above.
12722 C T and the Y array are input and should not be altered.
12723 C Thus the affect of ADDA should be the following:
12724 C DO 30 K = 1,NB
12725 C DO 20 J = 1,MB
12726 C DO 10 I = 1,MB
12727 C PA(I,J,K) = PA(I,J,K) +
12728 C ( (I,J) element of K-th diagonal block of A)
12729 C PB(I,J,K) = PB(I,J,K) +
12730 C ( (I,J) element of block in block position (K,K+1) of A,
12731 C or in block position (NB,NB-2) if K = NB)
12732 C PC(I,J,K) = PC(I,J,K) +
12733 C ( (I,J) element of block in block position (K,K-1) of A,
12734 C or in block position (1,3) if K = 1)
12735 C 10 CONTINUE
12736 C 20 CONTINUE
12737 C 30 CONTINUE
12738 C
12739 C D. For the sake of efficiency, you are encouraged to supply the
12740 C Jacobian matrix dr/dy in closed form, where r = g(t,y) - A(t,y)*s
12741 C (s = a fixed vector) as above. If dr/dy is being supplied,
12742 C use MF = 21, and provide a subroutine of the form:
12743 C SUBROUTINE JAC (NEQ, T, Y, S, MB, NB, PA, PB, PC)
12744 C DOUBLE PRECISION T, Y(*), S(*), PA(MB,MB,NB), PB(MB,MB,NB),
12745 C 1 PC(MB,MB,NB)
12746 C which computes dr/dy as a function of t, y, and s. Here T, Y, and
12747 C S are inputs, and the routine is to load dr/dy into PA, PB, PC,
12748 C according to the structure description in Paragraph B above.
12749 C That is, load the diagonal blocks into PA, the superdiagonal blocks
12750 C (and block (NB,NB-2) ) into PB, and the subdiagonal blocks (and
12751 C block (1,3) ) into PC. The blocks in block-row k of dr/dy are to
12752 C be loaded into PA(*,*,k), PB(*,*,k), and PC(*,*,k).
12753 C Only nonzero elements need be loaded, and the indexing
12754 C of PA, PB, and PC is the same as in the ADDA routine.
12755 C Note that if A is independent of Y (or this dependence
12756 C is weak enough to be ignored) then JAC is to compute dg/dy.
12757 C If it is not feasible to provide a JAC routine, use
12758 C MF = 22, and DLSOIBT will compute an approximate Jacobian
12759 C internally by difference quotients.
12760 C
12761 C E. Next decide whether or not to provide the initial value of the
12762 C derivative vector dy/dt. If the initial value of A(t,y) is
12763 C nonsingular (and not too ill-conditioned), you may let DLSOIBT compute
12764 C this vector (ISTATE = 0). (DLSOIBT will solve the system A*s = g for
12765 C s, with initial values of A and g.) If A(t,y) is initially
12766 C singular, then the system is a differential-algebraic system, and
12767 C you must make use of the particular form of the system to compute the
12768 C initial values of y and dy/dt. In that case, use ISTATE = 1 and
12769 C load the initial value of dy/dt into the array YDOTI.
12770 C The input array YDOTI and the initial Y array must be consistent with
12771 C the equations A*dy/dt = g. This implies that the initial residual
12772 C r = g(t,y) - A(t,y)*YDOTI must be approximately zero.
12773 C
12774 C F. Write a main program which calls Subroutine DLSOIBT once for
12775 C each point at which answers are desired. This should also provide
12776 C for possible use of logical unit 6 for output of error messages by
12777 C DLSOIBT. on the first call to DLSOIBT, supply arguments as follows:
12778 C RES = name of user subroutine for residual function r.
12779 C ADDA = name of user subroutine for computing and adding A(t,y).
12780 C JAC = name of user subroutine for Jacobian matrix dr/dy
12781 C (MF = 21). If not used, pass a dummy name.
12782 C Note: the names for the RES and ADDA routines and (if used) the
12783 C JAC routine must be declared External in the calling program.
12784 C NEQ = number of scalar equations in the system.
12785 C Y = array of initial values, of length NEQ.
12786 C YDOTI = array of length NEQ (containing initial dy/dt if ISTATE = 1).
12787 C T = the initial value of the independent variable.
12788 C TOUT = first point where output is desired (.ne. T).
12789 C ITOL = 1 or 2 according as ATOL (below) is a scalar or array.
12790 C RTOL = relative tolerance parameter (scalar).
12791 C ATOL = absolute tolerance parameter (scalar or array).
12792 C the estimated local error in y(i) will be controlled so as
12793 C to be roughly less (in magnitude) than
12794 C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or
12795 C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2.
12796 C Thus the local error test passes if, in each component,
12797 C either the absolute error is less than ATOL (or ATOL(i)),
12798 C or the relative error is less than RTOL.
12799 C Use RTOL = 0.0 for pure absolute error control, and
12800 C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error
12801 C control. Caution: Actual (global) errors may exceed these
12802 C local tolerances, so choose them conservatively.
12803 C ITASK = 1 for normal computation of output values of y at t = TOUT.
12804 C ISTATE = integer flag (input and output). Set ISTATE = 1 if the
12805 C initial dy/dt is supplied, and 0 otherwise.
12806 C IOPT = 0 to indicate no optional inputs used.
12807 C RWORK = real work array of length at least:
12808 C 22 + 9*NEQ + 3*MB*MB*NB for MF = 21 or 22.
12809 C LRW = declared length of RWORK (in user's dimension).
12810 C IWORK = integer work array of length at least 20 + NEQ.
12811 C Input in IWORK(1) the block size MB and in IWORK(2) the
12812 C number NB of blocks in each direction along the matrix A.
12813 C These must satisfy MB .ge. 1, NB .ge. 4, and MB*NB = NEQ.
12814 C LIW = declared length of IWORK (in user's dimension).
12815 C MF = method flag. Standard values are:
12816 C 21 for a user-supplied Jacobian.
12817 C 22 for an internally generated Jacobian.
12818 C For other choices of MF, see the paragraph on MF in
12819 C the full description below.
12820 C Note that the main program must declare arrays Y, YDOTI, RWORK, IWORK,
12821 C and possibly ATOL.
12822 C
12823 C G. The output from the first call (or any call) is:
12824 C Y = array of computed values of y(t) vector.
12825 C T = corresponding value of independent variable (normally TOUT).
12826 C ISTATE = 2 if DLSOIBT was successful, negative otherwise.
12827 C -1 means excess work done on this call (check all inputs).
12828 C -2 means excess accuracy requested (tolerances too small).
12829 C -3 means illegal input detected (see printed message).
12830 C -4 means repeated error test failures (check all inputs).
12831 C -5 means repeated convergence failures (perhaps bad Jacobian
12832 C supplied or wrong choice of tolerances).
12833 C -6 means error weight became zero during problem. (Solution
12834 C component i vanished, and ATOL or ATOL(i) = 0.)
12835 C -7 cannot occur in casual use.
12836 C -8 means DLSOIBT was unable to compute the initial dy/dt.
12837 C In casual use, this means A(t,y) is initially singular.
12838 C Supply YDOTI and use ISTATE = 1 on the first call.
12839 C
12840 C If DLSOIBT returns ISTATE = -1, -4, or -5, then the output of
12841 C DLSOIBT also includes YDOTI = array containing residual vector
12842 C r = g - A * dy/dt evaluated at the current t, y, and dy/dt.
12843 C
12844 C H. To continue the integration after a successful return, simply
12845 C reset TOUT and call DLSOIBT again. No other parameters need be reset.
12846 C
12847 C-----------------------------------------------------------------------
12848 C Example Problem.
12849 C
12850 C The following is an example problem, with the coding needed
12851 C for its solution by DLSOIBT. The problem comes from the partial
12852 C differential equation (the Burgers equation)
12853 C du/dt = - u * du/dx + eta * d**2 u/dx**2, eta = .05,
12854 C on -1 .le. x .le. 1. The boundary conditions are
12855 C du/dx = 0 at x = -1 and at x = 1.
12856 C The initial profile is a square wave,
12857 C u = 1 in ABS(x) .lt. .5, u = .5 at ABS(x) = .5, u = 0 elsewhere.
12858 C The PDE is discretized in x by a simplified Galerkin method,
12859 C using piecewise linear basis functions, on a grid of 40 intervals.
12860 C The equations at x = -1 and 1 use a 3-point difference approximation
12861 C for the right-hand side. The result is a system A * dy/dt = g(y),
12862 C of size NEQ = 41, where y(i) is the approximation to u at x = x(i),
12863 C with x(i) = -1 + (i-1)*delx, delx = 2/(NEQ-1) = .05. The individual
12864 C equations in the system are
12865 C dy(1)/dt = ( y(3) - 2*y(2) + y(1) ) * eta / delx**2,
12866 C dy(NEQ)/dt = ( y(NEQ-2) - 2*y(NEQ-1) + y(NEQ) ) * eta / delx**2,
12867 C and for i = 2, 3, ..., NEQ-1,
12868 C (1/6) dy(i-1)/dt + (4/6) dy(i)/dt + (1/6) dy(i+1)/dt
12869 C = ( y(i-1)**2 - y(i+1)**2 ) / (4*delx)
12870 C + ( y(i+1) - 2*y(i) + y(i-1) ) * eta / delx**2.
12871 C The following coding solves the problem with MF = 21, with output
12872 C of solution statistics at t = .1, .2, .3, and .4, and of the
12873 C solution vector at t = .4. Here the block size is just MB = 1.
12874 C
12875 C EXTERNAL RESID, ADDABT, JACBT
12876 C DOUBLE PRECISION ATOL, RTOL, RWORK, T, TOUT, Y, YDOTI
12877 C DIMENSION Y(41), YDOTI(41), RWORK(514), IWORK(61)
12878 C NEQ = 41
12879 C DO 10 I = 1,NEQ
12880 C 10 Y(I) = 0.0
12881 C Y(11) = 0.5
12882 C DO 20 I = 12,30
12883 C 20 Y(I) = 1.0
12884 C Y(31) = 0.5
12885 C T = 0.0
12886 C TOUT = 0.1
12887 C ITOL = 1
12888 C RTOL = 1.0D-4
12889 C ATOL = 1.0D-5
12890 C ITASK = 1
12891 C ISTATE = 0
12892 C IOPT = 0
12893 C LRW = 514
12894 C LIW = 61
12895 C IWORK(1) = 1
12896 C IWORK(2) = NEQ
12897 C MF = 21
12898 C DO 40 IO = 1,4
12899 C CALL DLSOIBT (RESID, ADDABT, JACBT, NEQ, Y, YDOTI, T, TOUT,
12900 C 1 ITOL,RTOL,ATOL, ITASK, ISTATE, IOPT, RWORK,LRW,IWORK,LIW, MF)
12901 C WRITE (6,30) T, IWORK(11), IWORK(12), IWORK(13)
12902 C 30 FORMAT(' At t =',F5.2,' No. steps =',I4,' No. r-s =',I4,
12903 C 1 ' No. J-s =',I3)
12904 C IF (ISTATE .NE. 2) GO TO 90
12905 C TOUT = TOUT + 0.1
12906 C 40 CONTINUE
12907 C WRITE(6,50) (Y(I),I=1,NEQ)
12908 C 50 FORMAT(/' Final solution values..'/9(5D12.4/))
12909 C STOP
12910 C 90 WRITE(6,95) ISTATE
12911 C 95 FORMAT(///' Error halt.. ISTATE =',I3)
12912 C STOP
12913 C END
12914 C
12915 C SUBROUTINE RESID (N, T, Y, S, R, IRES)
12916 C DOUBLE PRECISION T, Y, S, R, ETA, DELX, EODSQ
12917 C DIMENSION Y(N), S(N), R(N)
12918 C DATA ETA/0.05/, DELX/0.05/
12919 C EODSQ = ETA/DELX**2
12920 C R(1) = EODSQ*(Y(3) - 2.0*Y(2) + Y(1)) - S(1)
12921 C NM1 = N - 1
12922 C DO 10 I = 2,NM1
12923 C R(I) = (Y(I-1)**2 - Y(I+1)**2)/(4.0*DELX)
12924 C 1 + EODSQ*(Y(I+1) - 2.0*Y(I) + Y(I-1))
12925 C 2 - (S(I-1) + 4.0*S(I) + S(I+1))/6.0
12926 C 10 CONTINUE
12927 C R(N) = EODSQ*(Y(N-2) - 2.0*Y(NM1) + Y(N)) - S(N)
12928 C RETURN
12929 C END
12930 C
12931 C SUBROUTINE ADDABT (N, T, Y, MB, NB, PA, PB, PC)
12932 C DOUBLE PRECISION T, Y, PA, PB, PC
12933 C DIMENSION Y(N), PA(MB,MB,NB), PB(MB,MB,NB), PC(MB,MB,NB)
12934 C PA(1,1,1) = PA(1,1,1) + 1.0
12935 C NM1 = N - 1
12936 C DO 10 K = 2,NM1
12937 C PA(1,1,K) = PA(1,1,K) + (4.0/6.0)
12938 C PB(1,1,K) = PB(1,1,K) + (1.0/6.0)
12939 C PC(1,1,K) = PC(1,1,K) + (1.0/6.0)
12940 C 10 CONTINUE
12941 C PA(1,1,N) = PA(1,1,N) + 1.0
12942 C RETURN
12943 C END
12944 C
12945 C SUBROUTINE JACBT (N, T, Y, S, MB, NB, PA, PB, PC)
12946 C DOUBLE PRECISION T, Y, S, PA, PB, PC, ETA, DELX, EODSQ
12947 C DIMENSION Y(N), S(N), PA(MB,MB,NB),PB(MB,MB,NB),PC(MB,MB,NB)
12948 C DATA ETA/0.05/, DELX/0.05/
12949 C EODSQ = ETA/DELX**2
12950 C PA(1,1,1) = EODSQ
12951 C PB(1,1,1) = -2.0*EODSQ
12952 C PC(1,1,1) = EODSQ
12953 C DO 10 K = 2,N
12954 C PA(1,1,K) = -2.0*EODSQ
12955 C PB(1,1,K) = -Y(K+1)*(0.5/DELX) + EODSQ
12956 C PC(1,1,K) = Y(K-1)*(0.5/DELX) + EODSQ
12957 C 10 CONTINUE
12958 C PB(1,1,N) = EODSQ
12959 C PC(1,1,N) = -2.0*EODSQ
12960 C PA(1,1,N) = EODSQ
12961 C RETURN
12962 C END
12963 C
12964 C The output of this program (on a CDC-7600 in single precision)
12965 C is as follows:
12966 C
12967 C At t = 0.10 No. steps = 35 No. r-s = 45 No. J-s = 9
12968 C At t = 0.20 No. steps = 43 No. r-s = 54 No. J-s = 10
12969 C At t = 0.30 No. steps = 48 No. r-s = 60 No. J-s = 11
12970 C At t = 0.40 No. steps = 51 No. r-s = 64 No. J-s = 12
12971 C
12972 C Final solution values..
12973 C 1.2747e-02 1.1997e-02 1.5560e-02 2.3767e-02 3.7224e-02
12974 C 5.6646e-02 8.2645e-02 1.1557e-01 1.5541e-01 2.0177e-01
12975 C 2.5397e-01 3.1104e-01 3.7189e-01 4.3530e-01 5.0000e-01
12976 C 5.6472e-01 6.2816e-01 6.8903e-01 7.4612e-01 7.9829e-01
12977 C 8.4460e-01 8.8438e-01 9.1727e-01 9.4330e-01 9.6281e-01
12978 C 9.7632e-01 9.8426e-01 9.8648e-01 9.8162e-01 9.6617e-01
12979 C 9.3374e-01 8.7535e-01 7.8236e-01 6.5321e-01 5.0003e-01
12980 C 3.4709e-01 2.1876e-01 1.2771e-01 7.3671e-02 5.0642e-02
12981 C 5.4496e-02
12982 C
12983 C-----------------------------------------------------------------------
12984 C Full Description of User Interface to DLSOIBT.
12985 C
12986 C The user interface to DLSOIBT consists of the following parts.
12987 C
12988 C 1. The call sequence to Subroutine DLSOIBT, which is a driver
12989 C routine for the solver. This includes descriptions of both
12990 C the call sequence arguments and of user-supplied routines.
12991 C Following these descriptions is a description of
12992 C optional inputs available through the call sequence, and then
12993 C a description of optional outputs (in the work arrays).
12994 C
12995 C 2. Descriptions of other routines in the DLSOIBT package that may be
12996 C (optionally) called by the user. These provide the ability to
12997 C alter error message handling, save and restore the internal
12998 C Common, and obtain specified derivatives of the solution y(t).
12999 C
13000 C 3. Descriptions of Common blocks to be declared in overlay
13001 C or similar environments, or to be saved when doing an interrupt
13002 C of the problem and continued solution later.
13003 C
13004 C 4. Description of two routines in the DLSOIBT package, either of
13005 C which the user may replace with his/her own version, if desired.
13006 C These relate to the measurement of errors.
13007 C
13008 C-----------------------------------------------------------------------
13009 C Part 1. Call Sequence.
13010 C
13011 C The call sequence parameters used for input only are
13012 C RES, ADDA, JAC, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK,
13013 C IOPT, LRW, LIW, MF,
13014 C and those used for both input and output are
13015 C Y, T, ISTATE, YDOTI.
13016 C The work arrays RWORK and IWORK are also used for additional and
13017 C optional inputs and optional outputs. (The term output here refers
13018 C to the return from Subroutine DLSOIBT to the user's calling program.)
13019 C
13020 C The legality of input parameters will be thoroughly checked on the
13021 C initial call for the problem, but not checked thereafter unless a
13022 C change in input parameters is flagged by ISTATE = 3 on input.
13023 C
13024 C The descriptions of the call arguments are as follows.
13025 C
13026 C RES = the name of the user-supplied subroutine which supplies
13027 C the residual vector for the ODE system, defined by
13028 C r = g(t,y) - A(t,y) * s
13029 C as a function of the scalar t and the vectors
13030 C s and y (s approximates dy/dt). This subroutine
13031 C is to have the form
13032 C SUBROUTINE RES (NEQ, T, Y, S, R, IRES)
13033 C DOUBLE PRECISION T, Y(*), S(*), R(*)
13034 C where NEQ, T, Y, S, and IRES are input, and R and
13035 C IRES are output. Y, S, and R are arrays of length NEQ.
13036 C On input, IRES indicates how DLSOIBT will use the
13037 C returned array R, as follows:
13038 C IRES = 1 means that DLSOIBT needs the full residual,
13039 C r = g - A*s, exactly.
13040 C IRES = -1 means that DLSOIBT is using R only to compute
13041 C the Jacobian dr/dy by difference quotients.
13042 C The RES routine can ignore IRES, or it can omit some terms
13043 C if IRES = -1. If A does not depend on y, then RES can
13044 C just return R = g when IRES = -1. If g - A*s contains other
13045 C additive terms that are independent of y, these can also be
13046 C dropped, if done consistently, when IRES = -1.
13047 C The subroutine should set the flag IRES if it
13048 C encounters a halt condition or illegal input.
13049 C Otherwise, it should not reset IRES. On output,
13050 C IRES = 1 or -1 represents a normal return, and
13051 C DLSOIBT continues integrating the ODE. Leave IRES
13052 C unchanged from its input value.
13053 C IRES = 2 tells DLSOIBT to immediately return control
13054 C to the calling program, with ISTATE = 3. This lets
13055 C the calling program change parameters of the problem
13056 C if necessary.
13057 C IRES = 3 represents an error condition (for example, an
13058 C illegal value of y). DLSOIBT tries to integrate the system
13059 C without getting IRES = 3 from RES. If it cannot, DLSOIBT
13060 C returns with ISTATE = -7 or -1.
13061 C On an DLSOIBT return with ISTATE = 3, -1, or -7, the
13062 C values of T and Y returned correspond to the last point
13063 C reached successfully without getting the flag IRES = 2 or 3.
13064 C The flag values IRES = 2 and 3 should not be used to
13065 C handle switches or root-stop conditions. This is better
13066 C done by calling DLSOIBT in a one-step mode and checking the
13067 C stopping function for a sign change at each step.
13068 C If quantities computed in the RES routine are needed
13069 C externally to DLSOIBT, an extra call to RES should be made
13070 C for this purpose, for consistent and accurate results.
13071 C To get the current dy/dt for the S argument, use DINTDY.
13072 C RES must be declared External in the calling
13073 C program. See note below for more about RES.
13074 C
13075 C ADDA = the name of the user-supplied subroutine which adds the
13076 C matrix A = A(t,y) to another matrix, P, stored in
13077 C block-tridiagonal form. This routine is to have the form
13078 C SUBROUTINE ADDA (NEQ, T, Y, MB, NB, PA, PB, PC)
13079 C DOUBLE PRECISION T, Y(*), PA(MB,MB,NB), PB(MB,MB,NB),
13080 C 1 PC(MB,MB,NB)
13081 C where NEQ, T, Y, MB, NB, and the arrays PA, PB, and PC
13082 C are input, and the arrays PA, PB, and PC are output.
13083 C Y is an array of length NEQ, and the arrays PA, PB, PC
13084 C are all MB by MB by NB.
13085 C Here a block-tridiagonal structure is assumed for A(t,y),
13086 C and also for the matrix P to which A is added here,
13087 C as described in Paragraph B of the Summary of Usage above.
13088 C Thus the affect of ADDA should be the following:
13089 C DO 30 K = 1,NB
13090 C DO 20 J = 1,MB
13091 C DO 10 I = 1,MB
13092 C PA(I,J,K) = PA(I,J,K) +
13093 C ( (I,J) element of K-th diagonal block of A)
13094 C PB(I,J,K) = PB(I,J,K) +
13095 C ( (I,J) element of block (K,K+1) of A,
13096 C or block (NB,NB-2) if K = NB)
13097 C PC(I,J,K) = PC(I,J,K) +
13098 C ( (I,J) element of block (K,K-1) of A,
13099 C or block (1,3) if K = 1)
13100 C 10 CONTINUE
13101 C 20 CONTINUE
13102 C 30 CONTINUE
13103 C ADDA must be declared External in the calling program.
13104 C See note below for more information about ADDA.
13105 C
13106 C JAC = the name of the user-supplied subroutine which supplies
13107 C the Jacobian matrix, dr/dy, where r = g - A*s. JAC is
13108 C required if MITER = 1. Otherwise a dummy name can be
13109 C passed. This subroutine is to have the form
13110 C SUBROUTINE JAC (NEQ, T, Y, S, MB, NB, PA, PB, PC)
13111 C DOUBLE PRECISION T, Y(*), S(*), PA(MB,MB,NB),
13112 C 1 PB(MB,MB,NB), PC(MB,MB,NB)
13113 C where NEQ, T, Y, S, MB, NB, and the arrays PA, PB, and PC
13114 C are input, and the arrays PA, PB, and PC are output.
13115 C Y and S are arrays of length NEQ, and the arrays PA, PB, PC
13116 C are all MB by MB by NB.
13117 C PA, PB, and PC are to be loaded with partial derivatives
13118 C (elements of the Jacobian matrix) on output, in terms of the
13119 C block-tridiagonal structure assumed, as described
13120 C in Paragraph B of the Summary of Usage above.
13121 C That is, load the diagonal blocks into PA, the
13122 C superdiagonal blocks (and block (NB,NB-2) ) into PB, and
13123 C the subdiagonal blocks (and block (1,3) ) into PC.
13124 C The blocks in block-row k of dr/dy are to be loaded into
13125 C PA(*,*,k), PB(*,*,k), and PC(*,*,k).
13126 C Thus the affect of JAC should be the following:
13127 C DO 30 K = 1,NB
13128 C DO 20 J = 1,MB
13129 C DO 10 I = 1,MB
13130 C PA(I,J,K) = ( (I,J) element of
13131 C K-th diagonal block of dr/dy)
13132 C PB(I,J,K) = ( (I,J) element of block (K,K+1)
13133 C of dr/dy, or block (NB,NB-2) if K = NB)
13134 C PC(I,J,K) = ( (I,J) element of block (K,K-1)
13135 C of dr/dy, or block (1,3) if K = 1)
13136 C 10 CONTINUE
13137 C 20 CONTINUE
13138 C 30 CONTINUE
13139 C PA, PB, and PC are preset to zero by the solver,
13140 C so that only the nonzero elements need be loaded by JAC.
13141 C Each call to JAC is preceded by a call to RES with the same
13142 C arguments NEQ, T, Y, and S. Thus to gain some efficiency,
13143 C intermediate quantities shared by both calculations may be
13144 C saved in a user Common block by RES and not recomputed by JAC
13145 C if desired. Also, JAC may alter the Y array, if desired.
13146 C JAC need not provide dr/dy exactly. A crude
13147 C approximation will do, so that DLSOIBT may be used when
13148 C A and dr/dy are not really block-tridiagonal, but are close
13149 C to matrices that are.
13150 C JAC must be declared External in the calling program.
13151 C See note below for more about JAC.
13152 C
13153 C Note on RES, ADDA, and JAC:
13154 C These subroutines may access user-defined quantities in
13155 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array
13156 C (dimensioned in the subroutines) and/or Y has length
13157 C exceeding NEQ(1). However, these routines should not alter
13158 C NEQ(1), Y(1),...,Y(NEQ) or any other input variables.
13159 C See the descriptions of NEQ and Y below.
13160 C
13161 C NEQ = the size of the system (number of first order ordinary
13162 C differential equations or scalar algebraic equations).
13163 C Used only for input.
13164 C NEQ may be decreased, but not increased, during the problem.
13165 C If NEQ is decreased (with ISTATE = 3 on input), the
13166 C remaining components of Y should be left undisturbed, if
13167 C these are to be accessed in RES, ADDA, or JAC.
13168 C
13169 C Normally, NEQ is a scalar, and it is generally referred to
13170 C as a scalar in this user interface description. However,
13171 C NEQ may be an array, with NEQ(1) set to the system size.
13172 C (The DLSOIBT package accesses only NEQ(1).) In either case,
13173 C this parameter is passed as the NEQ argument in all calls
13174 C to RES, ADDA, and JAC. Hence, if it is an array,
13175 C locations NEQ(2),... may be used to store other integer data
13176 C and pass it to RES, ADDA, or JAC. Each such subroutine
13177 C must include NEQ in a Dimension statement in that case.
13178 C
13179 C Y = a real array for the vector of dependent variables, of
13180 C length NEQ or more. Used for both input and output on the
13181 C first call (ISTATE = 0 or 1), and only for output on other
13182 C calls. On the first call, Y must contain the vector of
13183 C initial values. On output, Y contains the computed solution
13184 C vector, evaluated at t. If desired, the Y array may be used
13185 C for other purposes between calls to the solver.
13186 C
13187 C This array is passed as the Y argument in all calls to RES,
13188 C ADDA, and JAC. Hence its length may exceed NEQ,
13189 C and locations Y(NEQ+1),... may be used to store other real
13190 C data and pass it to RES, ADDA, or JAC. (The DLSOIBT
13191 C package accesses only Y(1),...,Y(NEQ). )
13192 C
13193 C YDOTI = a real array for the initial value of the vector
13194 C dy/dt and for work space, of dimension at least NEQ.
13195 C
13196 C On input:
13197 C If ISTATE = 0 then DLSOIBT will compute the initial value
13198 C of dy/dt, if A is nonsingular. Thus YDOTI will
13199 C serve only as work space and may have any value.
13200 C If ISTATE = 1 then YDOTI must contain the initial value
13201 C of dy/dt.
13202 C If ISTATE = 2 or 3 (continuation calls) then YDOTI
13203 C may have any value.
13204 C Note: If the initial value of A is singular, then
13205 C DLSOIBT cannot compute the initial value of dy/dt, so
13206 C it must be provided in YDOTI, with ISTATE = 1.
13207 C
13208 C On output, when DLSOIBT terminates abnormally with ISTATE =
13209 C -1, -4, or -5, YDOTI will contain the residual
13210 C r = g(t,y) - A(t,y)*(dy/dt). If r is large, t is near
13211 C its initial value, and YDOTI is supplied with ISTATE = 1,
13212 C there may have been an incorrect input value of
13213 C YDOTI = dy/dt, or the problem (as given to DLSOIBT)
13214 C may not have a solution.
13215 C
13216 C If desired, the YDOTI array may be used for other
13217 C purposes between calls to the solver.
13218 C
13219 C T = the independent variable. On input, T is used only on the
13220 C first call, as the initial point of the integration.
13221 C On output, after each call, T is the value at which a
13222 C computed solution y is evaluated (usually the same as TOUT).
13223 C On an error return, T is the farthest point reached.
13224 C
13225 C TOUT = the next value of t at which a computed solution is desired.
13226 C Used only for input.
13227 C
13228 C When starting the problem (ISTATE = 0 or 1), TOUT may be
13229 C equal to T for one call, then should .ne. T for the next
13230 C call. For the initial T, an input value of TOUT .ne. T is
13231 C used in order to determine the direction of the integration
13232 C (i.e. the algebraic sign of the step sizes) and the rough
13233 C scale of the problem. Integration in either direction
13234 C (forward or backward in t) is permitted.
13235 C
13236 C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after
13237 C the first call (i.e. the first call with TOUT .ne. T).
13238 C Otherwise, TOUT is required on every call.
13239 C
13240 C If ITASK = 1, 3, or 4, the values of TOUT need not be
13241 C monotone, but a value of TOUT which backs up is limited
13242 C to the current internal T interval, whose endpoints are
13243 C TCUR - HU and TCUR (see optional outputs, below, for
13244 C TCUR and HU).
13245 C
13246 C ITOL = an indicator for the type of error control. See
13247 C description below under ATOL. Used only for input.
13248 C
13249 C RTOL = a relative error tolerance parameter, either a scalar or
13250 C an array of length NEQ. See description below under ATOL.
13251 C Input only.
13252 C
13253 C ATOL = an absolute error tolerance parameter, either a scalar or
13254 C an array of length NEQ. Input only.
13255 C
13256 C The input parameters ITOL, RTOL, and ATOL determine
13257 C the error control performed by the solver. The solver will
13258 C control the vector E = (E(i)) of estimated local errors
13259 C in y, according to an inequality of the form
13260 C RMS-norm of ( E(i)/EWT(i) ) .le. 1,
13261 C where EWT(i) = RTOL(i)*ABS(Y(i)) + ATOL(i),
13262 C and the RMS-norm (root-mean-square norm) here is
13263 C RMS-norm(v) = SQRT(sum v(i)**2 / NEQ). Here EWT = (EWT(i))
13264 C is a vector of weights which must always be positive, and
13265 C the values of RTOL and ATOL should all be non-negative.
13266 C The following table gives the types (scalar/array) of
13267 C RTOL and ATOL, and the corresponding form of EWT(i).
13268 C
13269 C ITOL RTOL ATOL EWT(i)
13270 C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL
13271 C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i)
13272 C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL
13273 C 4 array scalar RTOL(i)*ABS(Y(i)) + ATOL(i)
13274 C
13275 C When either of these parameters is a scalar, it need not
13276 C be dimensioned in the user's calling program.
13277 C
13278 C If none of the above choices (with ITOL, RTOL, and ATOL
13279 C fixed throughout the problem) is suitable, more general
13280 C error controls can be obtained by substituting
13281 C user-supplied routines for the setting of EWT and/or for
13282 C the norm calculation. See Part 4 below.
13283 C
13284 C If global errors are to be estimated by making a repeated
13285 C run on the same problem with smaller tolerances, then all
13286 C components of RTOL and ATOL (i.e. of EWT) should be scaled
13287 C down uniformly.
13288 C
13289 C ITASK = an index specifying the task to be performed.
13290 C Input only. ITASK has the following values and meanings.
13291 C 1 means normal computation of output values of y(t) at
13292 C t = TOUT (by overshooting and interpolating).
13293 C 2 means take one step only and return.
13294 C 3 means stop at the first internal mesh point at or
13295 C beyond t = TOUT and return.
13296 C 4 means normal computation of output values of y(t) at
13297 C t = TOUT but without overshooting t = TCRIT.
13298 C TCRIT must be input as RWORK(1). TCRIT may be equal to
13299 C or beyond TOUT, but not behind it in the direction of
13300 C integration. This option is useful if the problem
13301 C has a singularity at or beyond t = TCRIT.
13302 C 5 means take one step, without passing TCRIT, and return.
13303 C TCRIT must be input as RWORK(1).
13304 C
13305 C Note: If ITASK = 4 or 5 and the solver reaches TCRIT
13306 C (within roundoff), it will return T = TCRIT (exactly) to
13307 C indicate this (unless ITASK = 4 and TOUT comes before TCRIT,
13308 C in which case answers at t = TOUT are returned first).
13309 C
13310 C ISTATE = an index used for input and output to specify the
13311 C state of the calculation.
13312 C
13313 C On input, the values of ISTATE are as follows.
13314 C 0 means this is the first call for the problem, and
13315 C DLSOIBT is to compute the initial value of dy/dt
13316 C (while doing other initializations). See note below.
13317 C 1 means this is the first call for the problem, and
13318 C the initial value of dy/dt has been supplied in
13319 C YDOTI (DLSOIBT will do other initializations).
13320 C See note below.
13321 C 2 means this is not the first call, and the calculation
13322 C is to continue normally, with no change in any input
13323 C parameters except possibly TOUT and ITASK.
13324 C (If ITOL, RTOL, and/or ATOL are changed between calls
13325 C with ISTATE = 2, the new values will be used but not
13326 C tested for legality.)
13327 C 3 means this is not the first call, and the
13328 C calculation is to continue normally, but with
13329 C a change in input parameters other than
13330 C TOUT and ITASK. Changes are allowed in
13331 C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, MB, NB,
13332 C and any of the optional inputs except H0.
13333 C (See IWORK description for MB and NB.)
13334 C Note: A preliminary call with TOUT = T is not counted
13335 C as a first call here, as no initialization or checking of
13336 C input is done. (Such a call is sometimes useful for the
13337 C purpose of outputting the initial conditions.)
13338 C Thus the first call for which TOUT .ne. T requires
13339 C ISTATE = 0 or 1 on input.
13340 C
13341 C On output, ISTATE has the following values and meanings.
13342 C 0 or 1 means nothing was done; TOUT = t and
13343 C ISTATE = 0 or 1 on input.
13344 C 2 means that the integration was performed successfully.
13345 C 3 means that the user-supplied Subroutine RES signalled
13346 C DLSOIBT to halt the integration and return (IRES = 2).
13347 C Integration as far as T was achieved with no occurrence
13348 C of IRES = 2, but this flag was set on attempting the
13349 C next step.
13350 C -1 means an excessive amount of work (more than MXSTEP
13351 C steps) was done on this call, before completing the
13352 C requested task, but the integration was otherwise
13353 C successful as far as T. (MXSTEP is an optional input
13354 C and is normally 500.) To continue, the user may
13355 C simply reset ISTATE to a value .gt. 1 and call again
13356 C (the excess work step counter will be reset to 0).
13357 C In addition, the user may increase MXSTEP to avoid
13358 C this error return (see below on optional inputs).
13359 C -2 means too much accuracy was requested for the precision
13360 C of the machine being used. This was detected before
13361 C completing the requested task, but the integration
13362 C was successful as far as T. To continue, the tolerance
13363 C parameters must be reset, and ISTATE must be set
13364 C to 3. The optional output TOLSF may be used for this
13365 C purpose. (Note: If this condition is detected before
13366 C taking any steps, then an illegal input return
13367 C (ISTATE = -3) occurs instead.)
13368 C -3 means illegal input was detected, before taking any
13369 C integration steps. See written message for details.
13370 C Note: If the solver detects an infinite loop of calls
13371 C to the solver with illegal input, it will cause
13372 C the run to stop.
13373 C -4 means there were repeated error test failures on
13374 C one attempted step, before completing the requested
13375 C task, but the integration was successful as far as T.
13376 C The problem may have a singularity, or the input
13377 C may be inappropriate.
13378 C -5 means there were repeated convergence test failures on
13379 C one attempted step, before completing the requested
13380 C task, but the integration was successful as far as T.
13381 C This may be caused by an inaccurate Jacobian matrix.
13382 C -6 means EWT(i) became zero for some i during the
13383 C integration. Pure relative error control (ATOL(i) = 0.0)
13384 C was requested on a variable which has now vanished.
13385 C The integration was successful as far as T.
13386 C -7 means that the user-supplied Subroutine RES set
13387 C its error flag (IRES = 3) despite repeated tries by
13388 C DLSOIBT to avoid that condition.
13389 C -8 means that ISTATE was 0 on input but DLSOIBT was unable
13390 C to compute the initial value of dy/dt. See the
13391 C printed message for details.
13392 C
13393 C Note: Since the normal output value of ISTATE is 2,
13394 C it does not need to be reset for normal continuation.
13395 C Similarly, ISTATE (= 3) need not be reset if RES told
13396 C DLSOIBT to return because the calling program must change
13397 C the parameters of the problem.
13398 C Also, since a negative input value of ISTATE will be
13399 C regarded as illegal, a negative output value requires the
13400 C user to change it, and possibly other inputs, before
13401 C calling the solver again.
13402 C
13403 C IOPT = an integer flag to specify whether or not any optional
13404 C inputs are being used on this call. Input only.
13405 C The optional inputs are listed separately below.
13406 C IOPT = 0 means no optional inputs are being used.
13407 C Default values will be used in all cases.
13408 C IOPT = 1 means one or more optional inputs are being used.
13409 C
13410 C RWORK = a real working array (double precision).
13411 C The length of RWORK must be at least
13412 C 20 + NYH*(MAXORD + 1) + 3*NEQ + LENWM where
13413 C NYH = the initial value of NEQ,
13414 C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a
13415 C smaller value is given as an optional input),
13416 C LENWM = 3*MB*MB*NB + 2.
13417 C (See MF description for the definition of METH.)
13418 C Thus if MAXORD has its default value and NEQ is constant,
13419 C this length is
13420 C 22 + 16*NEQ + 3*MB*MB*NB for MF = 11 or 12,
13421 C 22 + 9*NEQ + 3*MB*MB*NB for MF = 21 or 22.
13422 C The first 20 words of RWORK are reserved for conditional
13423 C and optional inputs and optional outputs.
13424 C
13425 C The following word in RWORK is a conditional input:
13426 C RWORK(1) = TCRIT = critical value of t which the solver
13427 C is not to overshoot. Required if ITASK is
13428 C 4 or 5, and ignored otherwise. (See ITASK.)
13429 C
13430 C LRW = the length of the array RWORK, as declared by the user.
13431 C (This will be checked by the solver.)
13432 C
13433 C IWORK = an integer work array. The length of IWORK must be at least
13434 C 20 + NEQ . The first few words of IWORK are used for
13435 C additional and optional inputs and optional outputs.
13436 C
13437 C The following 2 words in IWORK are additional required
13438 C inputs to DLSOIBT:
13439 C IWORK(1) = MB = block size
13440 C IWORK(2) = NB = number of blocks in the main diagonal
13441 C These must satisfy MB .ge. 1, NB .ge. 4, and MB*NB = NEQ.
13442 C
13443 C LIW = the length of the array IWORK, as declared by the user.
13444 C (This will be checked by the solver.)
13445 C
13446 C Note: The work arrays must not be altered between calls to DLSOIBT
13447 C for the same problem, except possibly for the additional and
13448 C optional inputs, and except for the last 3*NEQ words of RWORK.
13449 C The latter space is used for internal scratch space, and so is
13450 C available for use by the user outside DLSOIBT between calls, if
13451 C desired (but not for use by RES, ADDA, or JAC).
13452 C
13453 C MF = the method flag. used only for input. The legal values of
13454 C MF are 11, 12, 21, and 22.
13455 C MF has decimal digits METH and MITER: MF = 10*METH + MITER.
13456 C METH indicates the basic linear multistep method:
13457 C METH = 1 means the implicit Adams method.
13458 C METH = 2 means the method based on Backward
13459 C Differentiation Formulas (BDFS).
13460 C The BDF method is strongly preferred for stiff
13461 C problems, while the Adams method is preferred when the
13462 C problem is not stiff. If the matrix A(t,y) is
13463 C nonsingular, stiffness here can be taken to mean that of
13464 C the explicit ODE system dy/dt = A-inverse * g. If A is
13465 C singular, the concept of stiffness is not well defined.
13466 C If you do not know whether the problem is stiff, we
13467 C recommend using METH = 2. If it is stiff, the advantage
13468 C of METH = 2 over METH = 1 will be great, while if it is
13469 C not stiff, the advantage of METH = 1 will be slight.
13470 C If maximum efficiency is important, some experimentation
13471 C with METH may be necessary.
13472 C MITER indicates the corrector iteration method:
13473 C MITER = 1 means chord iteration with a user-supplied
13474 C block-tridiagonal Jacobian.
13475 C MITER = 2 means chord iteration with an internally
13476 C generated (difference quotient) block-
13477 C tridiagonal Jacobian approximation, using
13478 C 3*MB+1 extra calls to RES per dr/dy evaluation.
13479 C If MITER = 1, the user must supply a Subroutine JAC
13480 C (the name is arbitrary) as described above under JAC.
13481 C For MITER = 2, a dummy argument can be used.
13482 C-----------------------------------------------------------------------
13483 C Optional Inputs.
13484 C
13485 C The following is a list of the optional inputs provided for in the
13486 C call sequence. (See also Part 2.) For each such input variable,
13487 C this table lists its name as used in this documentation, its
13488 C location in the call sequence, its meaning, and the default value.
13489 C The use of any of these inputs requires IOPT = 1, and in that
13490 C case all of these inputs are examined. A value of zero for any
13491 C of these optional inputs will cause the default value to be used.
13492 C Thus to use a subset of the optional inputs, simply preload
13493 C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and
13494 C then set those of interest to nonzero values.
13495 C
13496 C Name Location Meaning and Default Value
13497 C
13498 C H0 RWORK(5) the step size to be attempted on the first step.
13499 C The default value is determined by the solver.
13500 C
13501 C HMAX RWORK(6) the maximum absolute step size allowed.
13502 C The default value is infinite.
13503 C
13504 C HMIN RWORK(7) the minimum absolute step size allowed.
13505 C The default value is 0. (This lower bound is not
13506 C enforced on the final step before reaching TCRIT
13507 C when ITASK = 4 or 5.)
13508 C
13509 C MAXORD IWORK(5) the maximum order to be allowed. The default
13510 C value is 12 if METH = 1, and 5 if METH = 2.
13511 C If MAXORD exceeds the default value, it will
13512 C be reduced to the default value.
13513 C If MAXORD is changed during the problem, it may
13514 C cause the current order to be reduced.
13515 C
13516 C MXSTEP IWORK(6) maximum number of (internally defined) steps
13517 C allowed during one call to the solver.
13518 C The default value is 500.
13519 C
13520 C MXHNIL IWORK(7) maximum number of messages printed (per problem)
13521 C warning that T + H = T on a step (H = step size).
13522 C This must be positive to result in a non-default
13523 C value. The default value is 10.
13524 C-----------------------------------------------------------------------
13525 C Optional Outputs.
13526 C
13527 C As optional additional output from DLSOIBT, the variables listed
13528 C below are quantities related to the performance of DLSOIBT
13529 C which are available to the user. These are communicated by way of
13530 C the work arrays, but also have internal mnemonic names as shown.
13531 C Except where stated otherwise, all of these outputs are defined
13532 C on any successful return from DLSOIBT, and on any return with
13533 C ISTATE = -1, -2, -4, -5, -6, or -7. On a return with -3 (illegal
13534 C input) or -8, they will be unchanged from their existing values
13535 C (if any), except possibly for TOLSF, LENRW, and LENIW.
13536 C On any error return, outputs relevant to the error will be defined,
13537 C as noted below.
13538 C
13539 C Name Location Meaning
13540 C
13541 C HU RWORK(11) the step size in t last used (successfully).
13542 C
13543 C HCUR RWORK(12) the step size to be attempted on the next step.
13544 C
13545 C TCUR RWORK(13) the current value of the independent variable
13546 C which the solver has actually reached, i.e. the
13547 C current internal mesh point in t. On output, TCUR
13548 C will always be at least as far as the argument
13549 C T, but may be farther (if interpolation was done).
13550 C
13551 C TOLSF RWORK(14) a tolerance scale factor, greater than 1.0,
13552 C computed when a request for too much accuracy was
13553 C detected (ISTATE = -3 if detected at the start of
13554 C the problem, ISTATE = -2 otherwise). If ITOL is
13555 C left unaltered but RTOL and ATOL are uniformly
13556 C scaled up by a factor of TOLSF for the next call,
13557 C then the solver is deemed likely to succeed.
13558 C (The user may also ignore TOLSF and alter the
13559 C tolerance parameters in any other way appropriate.)
13560 C
13561 C NST IWORK(11) the number of steps taken for the problem so far.
13562 C
13563 C NRE IWORK(12) the number of residual evaluations (RES calls)
13564 C for the problem so far.
13565 C
13566 C NJE IWORK(13) the number of Jacobian evaluations (each involving
13567 C an evaluation of a and dr/dy) for the problem so
13568 C far. This equals the number of calls to ADDA and
13569 C (if MITER = 1) to JAC, and the number of matrix
13570 C LU decompositions.
13571 C
13572 C NQU IWORK(14) the method order last used (successfully).
13573 C
13574 C NQCUR IWORK(15) the order to be attempted on the next step.
13575 C
13576 C IMXER IWORK(16) the index of the component of largest magnitude in
13577 C the weighted local error vector ( E(i)/EWT(i) ),
13578 C on an error return with ISTATE = -4 or -5.
13579 C
13580 C LENRW IWORK(17) the length of RWORK actually required.
13581 C This is defined on normal returns and on an illegal
13582 C input return for insufficient storage.
13583 C
13584 C LENIW IWORK(18) the length of IWORK actually required.
13585 C This is defined on normal returns and on an illegal
13586 C input return for insufficient storage.
13587 C
13588 C
13589 C The following two arrays are segments of the RWORK array which
13590 C may also be of interest to the user as optional outputs.
13591 C For each array, the table below gives its internal name,
13592 C its base address in RWORK, and its description.
13593 C
13594 C Name Base Address Description
13595 C
13596 C YH 21 the Nordsieck history array, of size NYH by
13597 C (NQCUR + 1), where NYH is the initial value
13598 C of NEQ. For j = 0,1,...,NQCUR, column j+1
13599 C of YH contains HCUR**j/factorial(j) times
13600 C the j-th derivative of the interpolating
13601 C polynomial currently representing the solution,
13602 C evaluated at t = TCUR.
13603 C
13604 C ACOR LENRW-NEQ+1 array of size NEQ used for the accumulated
13605 C corrections on each step, scaled on output to
13606 C represent the estimated local error in y on
13607 C the last step. This is the vector E in the
13608 C description of the error control. It is
13609 C defined only on a return from DLSOIBT with
13610 C ISTATE = 2.
13611 C
13612 C-----------------------------------------------------------------------
13613 C Part 2. Other Routines Callable.
13614 C
13615 C The following are optional calls which the user may make to
13616 C gain additional capabilities in conjunction with DLSOIBT.
13617 C (The routines XSETUN and XSETF are designed to conform to the
13618 C SLATEC error handling package.)
13619 C
13620 C Form of Call Function
13621 C CALL XSETUN(LUN) Set the logical unit number, LUN, for
13622 C output of messages from DLSOIBT, if
13623 C the default is not desired.
13624 C The default value of LUN is 6.
13625 C
13626 C CALL XSETF(MFLAG) Set a flag to control the printing of
13627 C messages by DLSOIBT.
13628 C MFLAG = 0 means do not print. (Danger:
13629 C This risks losing valuable information.)
13630 C MFLAG = 1 means print (the default).
13631 C
13632 C Either of the above calls may be made at
13633 C any time and will take effect immediately.
13634 C
13635 C CALL DSRCOM(RSAV,ISAV,JOB) saves and restores the contents of
13636 C the internal Common blocks used by
13637 C DLSOIBT (see Part 3 below).
13638 C RSAV must be a real array of length 218
13639 C or more, and ISAV must be an integer
13640 C array of length 37 or more.
13641 C JOB=1 means save Common into RSAV/ISAV.
13642 C JOB=2 means restore Common from RSAV/ISAV.
13643 C DSRCOM is useful if one is
13644 C interrupting a run and restarting
13645 C later, or alternating between two or
13646 C more problems solved with DLSOIBT.
13647 C
13648 C CALL DINTDY(,,,,,) Provide derivatives of y, of various
13649 C (see below) orders, at a specified point t, if
13650 C desired. It may be called only after
13651 C a successful return from DLSOIBT.
13652 C
13653 C The detailed instructions for using DINTDY are as follows.
13654 C The form of the call is:
13655 C
13656 C CALL DINTDY (T, K, RWORK(21), NYH, DKY, IFLAG)
13657 C
13658 C The input parameters are:
13659 C
13660 C T = value of independent variable where answers are desired
13661 C (normally the same as the t last returned by DLSOIBT).
13662 C For valid results, T must lie between TCUR - HU and TCUR.
13663 C (See optional outputs for TCUR and HU.)
13664 C K = integer order of the derivative desired. K must satisfy
13665 C 0 .le. K .le. NQCUR, where NQCUR is the current order
13666 C (see optional outputs). The capability corresponding
13667 C to K = 0, i.e. computing y(t), is already provided
13668 C by DLSOIBT directly. Since NQCUR .ge. 1, the first
13669 C derivative dy/dt is always available with DINTDY.
13670 C RWORK(21) = the base address of the history array YH.
13671 C NYH = column length of YH, equal to the initial value of NEQ.
13672 C
13673 C The output parameters are:
13674 C
13675 C DKY = a real array of length NEQ containing the computed value
13676 C of the K-th derivative of y(t).
13677 C IFLAG = integer flag, returned as 0 if K and T were legal,
13678 C -1 if K was illegal, and -2 if T was illegal.
13679 C On an error return, a message is also written.
13680 C-----------------------------------------------------------------------
13681 C Part 3. Common Blocks.
13682 C
13683 C If DLSOIBT is to be used in an overlay situation, the user
13684 C must declare, in the primary overlay, the variables in:
13685 C (1) the call sequence to DLSOIBT, and
13686 C (2) the internal Common block
13687 C /DLS001/ of length 255 (218 double precision words
13688 C followed by 37 integer words),
13689 C
13690 C If DLSOIBT is used on a system in which the contents of internal
13691 C Common blocks are not preserved between calls, the user should
13692 C declare the above Common block in the calling program to insure
13693 C that their contents are preserved.
13694 C
13695 C If the solution of a given problem by DLSOIBT is to be interrupted
13696 C and then later continued, such as when restarting an interrupted run
13697 C or alternating between two or more problems, the user should save,
13698 C following the return from the last DLSOIBT call prior to the
13699 C interruption, the contents of the call sequence variables and the
13700 C internal Common blocks, and later restore these values before the
13701 C next DLSOIBT call for that problem. To save and restore the Common
13702 C blocks, use Subroutine DSRCOM (see Part 2 above).
13703 C
13704 C-----------------------------------------------------------------------
13705 C Part 4. Optionally Replaceable Solver Routines.
13706 C
13707 C Below are descriptions of two routines in the DLSOIBT package which
13708 C relate to the measurement of errors. Either routine can be
13709 C replaced by a user-supplied version, if desired. However, since such
13710 C a replacement may have a major impact on performance, it should be
13711 C done only when absolutely necessary, and only with great caution.
13712 C (Note: The means by which the package version of a routine is
13713 C superseded by the user's version may be system-dependent.)
13714 C
13715 C (a) DEWSET.
13716 C The following subroutine is called just before each internal
13717 C integration step, and sets the array of error weights, EWT, as
13718 C described under ITOL/RTOL/ATOL above:
13719 C SUBROUTINE DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT)
13720 C where NEQ, ITOL, RTOL, and ATOL are as in the DLSOIBT call sequence,
13721 C YCUR contains the current dependent variable vector, and
13722 C EWT is the array of weights set by DEWSET.
13723 C
13724 C If the user supplies this subroutine, it must return in EWT(i)
13725 C (i = 1,...,NEQ) a positive quantity suitable for comparing errors
13726 C in y(i) to. The EWT array returned by DEWSET is passed to the DVNORM
13727 C routine (see below), and also used by DLSOIBT in the computation
13728 C of the optional output IMXER, the diagonal Jacobian approximation,
13729 C and the increments for difference quotient Jacobians.
13730 C
13731 C In the user-supplied version of DEWSET, it may be desirable to use
13732 C the current values of derivatives of y. Derivatives up to order NQ
13733 C are available from the history array YH, described above under
13734 C optional outputs. In DEWSET, YH is identical to the YCUR array,
13735 C extended to NQ + 1 columns with a column length of NYH and scale
13736 C factors of H**j/factorial(j). On the first call for the problem,
13737 C given by NST = 0, NQ is 1 and H is temporarily set to 1.0.
13738 C NYH is the initial value of NEQ. The quantities NQ, H, and NST
13739 C can be obtained by including in DEWSET the statements:
13740 C DOUBLE PRECISION RLS
13741 C COMMON /DLS001/ RLS(218),ILS(37)
13742 C NQ = ILS(33)
13743 C NST = ILS(34)
13744 C H = RLS(212)
13745 C Thus, for example, the current value of dy/dt can be obtained as
13746 C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is
13747 C unnecessary when NST = 0).
13748 C
13749 C (b) DVNORM.
13750 C The following is a real function routine which computes the weighted
13751 C root-mean-square norm of a vector v:
13752 C D = DVNORM (N, V, W)
13753 C where:
13754 C N = the length of the vector,
13755 C V = real array of length N containing the vector,
13756 C W = real array of length N containing weights,
13757 C D = SQRT( (1/N) * sum(V(i)*W(i))**2 ).
13758 C DVNORM is called with N = NEQ and with W(i) = 1.0/EWT(i), where
13759 C EWT is as set by Subroutine DEWSET.
13760 C
13761 C If the user supplies this function, it should return a non-negative
13762 C value of DVNORM suitable for use in the error control in DLSOIBT.
13763 C None of the arguments should be altered by DVNORM.
13764 C For example, a user-supplied DVNORM routine might:
13765 C -substitute a max-norm of (V(i)*W(i)) for the RMS-norm, or
13766 C -ignore some components of V in the norm, with the effect of
13767 C suppressing the error control on those components of y.
13768 C-----------------------------------------------------------------------
13769 C
13770 C***REVISION HISTORY (YYYYMMDD)
13771 C 19840625 DATE WRITTEN
13772 C 19870330 Major update: corrected comments throughout;
13773 C removed TRET from Common; rewrote EWSET with 4 loops;
13774 C fixed t test in INTDY; added Cray directives in STODI;
13775 C in STODI, fixed DELP init. and logic around PJAC call;
13776 C combined routines to save/restore Common;
13777 C passed LEVEL = 0 in error message calls (except run abort).
13778 C 20010425 Major update: convert source lines to upper case;
13779 C added *DECK lines; changed from 1 to * in dummy dimensions;
13780 C changed names R1MACH/D1MACH to RUMACH/DUMACH;
13781 C renamed routines for uniqueness across single/double prec.;
13782 C converted intrinsic names to generic form;
13783 C removed ILLIN and NTREP (data loaded) from Common;
13784 C removed all 'own' variables from Common;
13785 C changed error messages to quoted strings;
13786 C replaced XERRWV/XERRWD with 1993 revised version;
13787 C converted prologues, comments, error messages to mixed case;
13788 C converted arithmetic IF statements to logical IF statements;
13789 C numerous corrections to prologues and internal comments.
13790 C 20010507 Converted single precision source to double precision.
13791 C 20020502 Corrected declarations in descriptions of user routines.
13792 C 20031105 Restored 'own' variables to Common block, to enable
13793 C interrupt/restart feature.
13794 C 20031112 Added SAVE statements for data-loaded constants.
13795 C 20031117 Changed internal names NRE, LSAVR to NFE, LSAVF resp.
13796 C
13797 C-----------------------------------------------------------------------
13798 C Other routines in the DLSOIBT package.
13799 C
13800 C In addition to Subroutine DLSOIBT, the DLSOIBT package includes the
13801 C following subroutines and function routines:
13802 C DAIGBT computes the initial value of the vector
13803 C dy/dt = A-inverse * g
13804 C DINTDY computes an interpolated value of the y vector at t = TOUT.
13805 C DSTODI is the core integrator, which does one step of the
13806 C integration and the associated error control.
13807 C DCFODE sets all method coefficients and test constants.
13808 C DEWSET sets the error weight vector EWT before each step.
13809 C DVNORM computes the weighted RMS-norm of a vector.
13810 C DSRCOM is a user-callable routine to save and restore
13811 C the contents of the internal Common blocks.
13812 C DPJIBT computes and preprocesses the Jacobian matrix
13813 C and the Newton iteration matrix P.
13814 C DSLSBT manages solution of linear system in chord iteration.
13815 C DDECBT and DSOLBT are routines for solving block-tridiagonal
13816 C systems of linear algebraic equations.
13817 C DGEFA and DGESL are routines from LINPACK for solving full
13818 C systems of linear algebraic equations.
13819 C DDOT is one of the basic linear algebra modules (BLAS).
13820 C DUMACH computes the unit roundoff in a machine-independent manner.
13821 C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all
13822 C error messages and warnings. XERRWD is machine-dependent.
13823 C Note: DVNORM, DDOT, DUMACH, IXSAV, and IUMACH are function routines.
13824 C All the others are subroutines.
13825 C
13826 C-----------------------------------------------------------------------
13827  EXTERNAL dpjibt, dslsbt
13828  DOUBLE PRECISION dumach, dvnorm
13829  INTEGER init, mxstep, mxhnil, nhnil, nslast, nyh, iowns,
13830  1 icf, ierpj, iersl, jcur, jstart, kflag, l,
13831  2 lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
13832  3 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
13833  INTEGER i, i1, i2, ier, iflag, imxer, ires, kgo,
13834  1 leniw, lenrw, lenwm, lp, lyd0, mb, mord, mxhnl0, mxstp0, nb
13835  DOUBLE PRECISION rowns,
13836  1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
13837  DOUBLE PRECISION atoli, ayi, big, ewti, h0, hmax, hmx, rh, rtoli,
13838  1 tcrit, tdist, tnext, tol, tolsf, tp, SIZE, sum, w0
13839  dimension mord(2)
13840  LOGICAL ihit
13841  CHARACTER*60 msg
13842  SAVE mord, mxstp0, mxhnl0
13843 C-----------------------------------------------------------------------
13844 C The following internal Common block contains
13845 C (a) variables which are local to any subroutine but whose values must
13846 C be preserved between calls to the routine ("own" variables), and
13847 C (b) variables which are communicated between subroutines.
13848 C The block DLS001 is declared in subroutines DLSOIBT, DINTDY, DSTODI,
13849 C DPJIBT, and DSLSBT.
13850 C Groups of variables are replaced by dummy arrays in the Common
13851 C declarations in routines where those variables are not used.
13852 C-----------------------------------------------------------------------
13853  COMMON /dls001/ rowns(209),
13854  1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
13855  2 init, mxstep, mxhnil, nhnil, nslast, nyh, iowns(6),
13856  3 icf, ierpj, iersl, jcur, jstart, kflag, l,
13857  4 lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
13858  5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
13859 C
13860  DATA mord(1),mord(2)/12,5/, mxstp0/500/, mxhnl0/10/
13861 C-----------------------------------------------------------------------
13862 C Block A.
13863 C This code block is executed on every call.
13864 C It tests ISTATE and ITASK for legality and branches appropriately.
13865 C If ISTATE .gt. 1 but the flag INIT shows that initialization has
13866 C not yet been done, an error return occurs.
13867 C If ISTATE = 0 or 1 and TOUT = T, return immediately.
13868 C-----------------------------------------------------------------------
13869  IF (istate .LT. 0 .OR. istate .GT. 3) GO TO 601
13870  IF (itask .LT. 1 .OR. itask .GT. 5) GO TO 602
13871  IF (istate .LE. 1) GO TO 10
13872  IF (init .EQ. 0) GO TO 603
13873  IF (istate .EQ. 2) GO TO 200
13874  GO TO 20
13875  10 init = 0
13876  IF (tout .EQ. t) RETURN
13877 C-----------------------------------------------------------------------
13878 C Block B.
13879 C The next code block is executed for the initial call (ISTATE = 0 or 1)
13880 C or for a continuation call with parameter changes (ISTATE = 3).
13881 C It contains checking of all inputs and various initializations.
13882 C
13883 C First check legality of the non-optional inputs NEQ, ITOL, IOPT,
13884 C MF, MB, and NB.
13885 C-----------------------------------------------------------------------
13886  20 IF (neq(1) .LE. 0) GO TO 604
13887  IF (istate .LE. 1) GO TO 25
13888  IF (neq(1) .GT. n) GO TO 605
13889  25 n = neq(1)
13890  IF (itol .LT. 1 .OR. itol .GT. 4) GO TO 606
13891  IF (iopt .LT. 0 .OR. iopt .GT. 1) GO TO 607
13892  meth = mf/10
13893  miter = mf - 10*meth
13894  IF (meth .LT. 1 .OR. meth .GT. 2) GO TO 608
13895  IF (miter .LT. 1 .OR. miter .GT. 2) GO TO 608
13896  mb = iwork(1)
13897  nb = iwork(2)
13898  IF (mb .LT. 1 .OR. mb .GT. n) GO TO 609
13899  IF (nb .LT. 4) GO TO 610
13900  IF (mb*nb .NE. n) GO TO 609
13901 C Next process and check the optional inputs. --------------------------
13902  IF (iopt .EQ. 1) GO TO 40
13903  maxord = mord(meth)
13904  mxstep = mxstp0
13905  mxhnil = mxhnl0
13906  IF (istate .LE. 1) h0 = 0.0d0
13907  hmxi = 0.0d0
13908  hmin = 0.0d0
13909  GO TO 60
13910  40 maxord = iwork(5)
13911  IF (maxord .LT. 0) GO TO 611
13912  IF (maxord .EQ. 0) maxord = 100
13913  maxord = min(maxord,mord(meth))
13914  mxstep = iwork(6)
13915  IF (mxstep .LT. 0) GO TO 612
13916  IF (mxstep .EQ. 0) mxstep = mxstp0
13917  mxhnil = iwork(7)
13918  IF (mxhnil .LT. 0) GO TO 613
13919  IF (mxhnil .EQ. 0) mxhnil = mxhnl0
13920  IF (istate .GT. 1) GO TO 50
13921  h0 = rwork(5)
13922  IF ((tout - t)*h0 .LT. 0.0d0) GO TO 614
13923  50 hmax = rwork(6)
13924  IF (hmax .LT. 0.0d0) GO TO 615
13925  hmxi = 0.0d0
13926  IF (hmax .GT. 0.0d0) hmxi = 1.0d0/hmax
13927  hmin = rwork(7)
13928  IF (hmin .LT. 0.0d0) GO TO 616
13929 C-----------------------------------------------------------------------
13930 C Set work array pointers and check lengths LRW and LIW.
13931 C Pointers to segments of RWORK and IWORK are named by prefixing L to
13932 C the name of the segment. E.g., the segment YH starts at RWORK(LYH).
13933 C Segments of RWORK (in order) are denoted YH, WM, EWT, SAVR, ACOR.
13934 C-----------------------------------------------------------------------
13935  60 lyh = 21
13936  IF (istate .LE. 1) nyh = n
13937  lwm = lyh + (maxord + 1)*nyh
13938  lenwm = 3*mb*mb*nb + 2
13939  lewt = lwm + lenwm
13940  lsavf = lewt + n
13941  lacor = lsavf + n
13942  lenrw = lacor + n - 1
13943  iwork(17) = lenrw
13944  liwm = 1
13945  leniw = 20 + n
13946  iwork(18) = leniw
13947  IF (lenrw .GT. lrw) GO TO 617
13948  IF (leniw .GT. liw) GO TO 618
13949 C Check RTOL and ATOL for legality. ------------------------------------
13950  rtoli = rtol(1)
13951  atoli = atol(1)
13952  DO 70 i = 1,n
13953  IF (itol .GE. 3) rtoli = rtol(i)
13954  IF (itol .EQ. 2 .OR. itol .EQ. 4) atoli = atol(i)
13955  IF (rtoli .LT. 0.0d0) GO TO 619
13956  IF (atoli .LT. 0.0d0) GO TO 620
13957  70 CONTINUE
13958  IF (istate .LE. 1) GO TO 100
13959 C If ISTATE = 3, set flag to signal parameter changes to DSTODI. -------
13960  jstart = -1
13961  IF (nq .LE. maxord) GO TO 90
13962 C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into YDOTI.---------
13963  DO 80 i = 1,n
13964  80 ydoti(i) = rwork(i+lwm-1)
13965 C Reload WM(1) = RWORK(lWM), since lWM may have changed. ---------------
13966  90 rwork(lwm) = sqrt(uround)
13967  IF (n .EQ. nyh) GO TO 200
13968 C NEQ was reduced. Zero part of YH to avoid undefined references. -----
13969  i1 = lyh + l*nyh
13970  i2 = lyh + (maxord + 1)*nyh - 1
13971  IF (i1 .GT. i2) GO TO 200
13972  DO 95 i = i1,i2
13973  95 rwork(i) = 0.0d0
13974  GO TO 200
13975 C-----------------------------------------------------------------------
13976 C Block C.
13977 C The next block is for the initial call only (ISTATE = 0 or 1).
13978 C It contains all remaining initializations, the call to DAIGBT
13979 C (if ISTATE = 1), and the calculation of the initial step size.
13980 C The error weights in EWT are inverted after being loaded.
13981 C-----------------------------------------------------------------------
13982  100 uround = dumach()
13983  tn = t
13984  IF (itask .NE. 4 .AND. itask .NE. 5) GO TO 105
13985  tcrit = rwork(1)
13986  IF ((tcrit - tout)*(tout - t) .LT. 0.0d0) GO TO 625
13987  IF (h0 .NE. 0.0d0 .AND. (t + h0 - tcrit)*h0 .GT. 0.0d0)
13988  1 h0 = tcrit - t
13989  105 jstart = 0
13990  rwork(lwm) = sqrt(uround)
13991  nhnil = 0
13992  nst = 0
13993  nfe = 0
13994  nje = 0
13995  nslast = 0
13996  hu = 0.0d0
13997  nqu = 0
13998  ccmax = 0.3d0
13999  maxcor = 3
14000  msbp = 20
14001  mxncf = 10
14002 C Compute initial dy/dt, if necessary, and load it and initial Y into YH
14003  lyd0 = lyh + nyh
14004  lp = lwm + 1
14005  IF ( istate .EQ. 1 ) GO TO 120
14006 C DLSOIBT must compute initial dy/dt (LYD0 points to YH(*,2)). ---------
14007  CALL daigbt( res, adda, neq, t, y, rwork(lyd0),
14008  1 mb, nb, rwork(lp), iwork(21), ier )
14009  nfe = nfe + 1
14010  IF (ier .LT. 0) GO TO 560
14011  IF (ier .GT. 0) GO TO 565
14012  DO 115 i = 1,n
14013  115 rwork(i+lyh-1) = y(i)
14014  GO TO 130
14015 C Initial dy/dt was supplied. Load into YH (LYD0 points to YH(*,2).). -
14016  120 DO 125 i = 1,n
14017  rwork(i+lyh-1) = y(i)
14018  125 rwork(i+lyd0-1) = ydoti(i)
14019 C Load and invert the EWT array. (H is temporarily set to 1.0.) -------
14020  130 CONTINUE
14021  nq = 1
14022  h = 1.0d0
14023  CALL dewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt))
14024  DO 135 i = 1,n
14025  IF (rwork(i+lewt-1) .LE. 0.0d0) GO TO 621
14026  135 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1)
14027 C-----------------------------------------------------------------------
14028 C The coding below computes the step size, H0, to be attempted on the
14029 C first step, unless the user has supplied a value for this.
14030 C First check that TOUT - T differs significantly from zero.
14031 C A scalar tolerance quantity TOL is computed, as MAX(RTOL(i))
14032 C if this is positive, or MAX(ATOL(i)/ABS(Y(i))) otherwise, adjusted
14033 C so as to be between 100*UROUND and 1.0E-3.
14034 C Then the computed value H0 is given by..
14035 C NEQ
14036 C H0**2 = TOL / ( w0**-2 + (1/NEQ) * Sum ( YDOT(i)/ywt(i) )**2 )
14037 C 1
14038 C where w0 = MAX ( ABS(T), ABS(TOUT) ),
14039 C YDOT(i) = i-th component of initial value of dy/dt,
14040 C ywt(i) = EWT(i)/TOL (a weight for y(i)).
14041 C The sign of H0 is inferred from the initial values of TOUT and T.
14042 C-----------------------------------------------------------------------
14043  IF (h0 .NE. 0.0d0) GO TO 180
14044  tdist = abs(tout - t)
14045  w0 = max(abs(t),abs(tout))
14046  IF (tdist .LT. 2.0d0*uround*w0) GO TO 622
14047  tol = rtol(1)
14048  IF (itol .LE. 2) GO TO 145
14049  DO 140 i = 1,n
14050  140 tol = max(tol,rtol(i))
14051  145 IF (tol .GT. 0.0d0) GO TO 160
14052  atoli = atol(1)
14053  DO 150 i = 1,n
14054  IF (itol .EQ. 2 .OR. itol .EQ. 4) atoli = atol(i)
14055  ayi = abs(y(i))
14056  IF (ayi .NE. 0.0d0) tol = max(tol,atoli/ayi)
14057  150 CONTINUE
14058  160 tol = max(tol,100.0d0*uround)
14059  tol = min(tol,0.001d0)
14060  sum = dvnorm(n, rwork(lyd0), rwork(lewt))
14061  sum = 1.0d0/(tol*w0*w0) + tol*sum**2
14062  h0 = 1.0d0/sqrt(sum)
14063  h0 = min(h0,tdist)
14064  h0 = sign(h0,tout-t)
14065 C Adjust H0 if necessary to meet HMAX bound. ---------------------------
14066  180 rh = abs(h0)*hmxi
14067  IF (rh .GT. 1.0d0) h0 = h0/rh
14068 C Load H with H0 and scale YH(*,2) by H0. ------------------------------
14069  h = h0
14070  DO 190 i = 1,n
14071  190 rwork(i+lyd0-1) = h0*rwork(i+lyd0-1)
14072  GO TO 270
14073 C-----------------------------------------------------------------------
14074 C Block D.
14075 C The next code block is for continuation calls only (ISTATE = 2 or 3)
14076 C and is to check stop conditions before taking a step.
14077 C-----------------------------------------------------------------------
14078  200 nslast = nst
14079  GO TO (210, 250, 220, 230, 240), itask
14080  210 IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
14081  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
14082  IF (iflag .NE. 0) GO TO 627
14083  t = tout
14084  GO TO 420
14085  220 tp = tn - hu*(1.0d0 + 100.0d0*uround)
14086  IF ((tp - tout)*h .GT. 0.0d0) GO TO 623
14087  IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
14088  GO TO 400
14089  230 tcrit = rwork(1)
14090  IF ((tn - tcrit)*h .GT. 0.0d0) GO TO 624
14091  IF ((tcrit - tout)*h .LT. 0.0d0) GO TO 625
14092  IF ((tn - tout)*h .LT. 0.0d0) GO TO 245
14093  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
14094  IF (iflag .NE. 0) GO TO 627
14095  t = tout
14096  GO TO 420
14097  240 tcrit = rwork(1)
14098  IF ((tn - tcrit)*h .GT. 0.0d0) GO TO 624
14099  245 hmx = abs(tn) + abs(h)
14100  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
14101  IF (ihit) GO TO 400
14102  tnext = tn + h*(1.0d0 + 4.0d0*uround)
14103  IF ((tnext - tcrit)*h .LE. 0.0d0) GO TO 250
14104  h = (tcrit - tn)*(1.0d0 - 4.0d0*uround)
14105  IF (istate .EQ. 2) jstart = -2
14106 C-----------------------------------------------------------------------
14107 C Block E.
14108 C The next block is normally executed for all calls and contains
14109 C the call to the one-step core integrator DSTODI.
14110 C
14111 C This is a looping point for the integration steps.
14112 C
14113 C First check for too many steps being taken, update EWT (if not at
14114 C start of problem), check for too much accuracy being requested, and
14115 C check for H below the roundoff level in T.
14116 C-----------------------------------------------------------------------
14117  250 CONTINUE
14118  IF ((nst-nslast) .GE. mxstep) GO TO 500
14119  CALL dewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt))
14120  DO 260 i = 1,n
14121  IF (rwork(i+lewt-1) .LE. 0.0d0) GO TO 510
14122  260 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1)
14123  270 tolsf = uround*dvnorm(n, rwork(lyh), rwork(lewt))
14124  IF (tolsf .LE. 1.0d0) GO TO 280
14125  tolsf = tolsf*2.0d0
14126  IF (nst .EQ. 0) GO TO 626
14127  GO TO 520
14128  280 IF ((tn + h) .NE. tn) GO TO 290
14129  nhnil = nhnil + 1
14130  IF (nhnil .GT. mxhnil) GO TO 290
14131  msg = 'DLSOIBT- Warning..Internal T (=R1) and H (=R2) are'
14132  CALL xerrwd (msg, 50, 101, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
14133  msg=' such that in the machine, T + H = T on the next step '
14134  CALL xerrwd (msg, 60, 101, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
14135  msg = ' (H = step size). Solver will continue anyway.'
14136  CALL xerrwd (msg, 50, 101, 0, 0, 0, 0, 2, tn, h)
14137  IF (nhnil .LT. mxhnil) GO TO 290
14138  msg = 'DLSOIBT- Above warning has been issued I1 times. '
14139  CALL xerrwd (msg, 50, 102, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
14140  msg = ' It will not be issued again for this problem.'
14141  CALL xerrwd (msg, 50, 102, 0, 1, mxhnil, 0, 0, 0.0d0, 0.0d0)
14142  290 CONTINUE
14143 C-----------------------------------------------------------------------
14144 C CALL DSTODI(NEQ,Y,YH,NYH,YH1,EWT,SAVF,SAVR,ACOR,WM,IWM,RES,
14145 C ADDA,JAC,DPJIBT,DSLSBT)
14146 C Note: SAVF in DSTODI occupies the same space as YDOTI in DLSOIBT.
14147 C-----------------------------------------------------------------------
14148  CALL dstodi (neq, y, rwork(lyh), nyh, rwork(lyh), rwork(lewt),
14149  1 ydoti, rwork(lsavf), rwork(lacor), rwork(lwm),
14150  2 iwork(liwm), res, adda, jac, dpjibt, dslsbt )
14151  kgo = 1 - kflag
14152  GO TO (300, 530, 540, 400, 550), kgo
14153 C
14154 C KGO = 1:success; 2:error test failure; 3:convergence failure;
14155 C 4:RES ordered return; 5:RES returned error.
14156 C-----------------------------------------------------------------------
14157 C Block F.
14158 C The following block handles the case of a successful return from the
14159 C core integrator (KFLAG = 0). Test for stop conditions.
14160 C-----------------------------------------------------------------------
14161  300 init = 1
14162  GO TO (310, 400, 330, 340, 350), itask
14163 C ITASK = 1. If TOUT has been reached, interpolate. -------------------
14164  310 IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
14165  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
14166  t = tout
14167  GO TO 420
14168 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------
14169  330 IF ((tn - tout)*h .GE. 0.0d0) GO TO 400
14170  GO TO 250
14171 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary.
14172  340 IF ((tn - tout)*h .LT. 0.0d0) GO TO 345
14173  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
14174  t = tout
14175  GO TO 420
14176  345 hmx = abs(tn) + abs(h)
14177  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
14178  IF (ihit) GO TO 400
14179  tnext = tn + h*(1.0d0 + 4.0d0*uround)
14180  IF ((tnext - tcrit)*h .LE. 0.0d0) GO TO 250
14181  h = (tcrit - tn)*(1.0d0 - 4.0d0*uround)
14182  jstart = -2
14183  GO TO 250
14184 C ITASK = 5. see if TCRIT was reached and jump to exit. ---------------
14185  350 hmx = abs(tn) + abs(h)
14186  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
14187 C-----------------------------------------------------------------------
14188 C Block G.
14189 C The following block handles all successful returns from DLSOIBT.
14190 C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly.
14191 C ISTATE is set to 2, and the optional outputs are loaded into the
14192 C work arrays before returning.
14193 C-----------------------------------------------------------------------
14194  400 DO 410 i = 1,n
14195  410 y(i) = rwork(i+lyh-1)
14196  t = tn
14197  IF (itask .NE. 4 .AND. itask .NE. 5) GO TO 420
14198  IF (ihit) t = tcrit
14199  420 istate = 2
14200  IF ( kflag .EQ. -3 ) istate = 3
14201  rwork(11) = hu
14202  rwork(12) = h
14203  rwork(13) = tn
14204  iwork(11) = nst
14205  iwork(12) = nfe
14206  iwork(13) = nje
14207  iwork(14) = nqu
14208  iwork(15) = nq
14209  RETURN
14210 C-----------------------------------------------------------------------
14211 C Block H.
14212 C The following block handles all unsuccessful returns other than
14213 C those for illegal input. First the error message routine is called.
14214 C If there was an error test or convergence test failure, IMXER is set.
14215 C Then Y is loaded from YH and T is set to TN.
14216 C The optional outputs are loaded into the work arrays before returning.
14217 C-----------------------------------------------------------------------
14218 C The maximum number of steps was taken before reaching TOUT. ----------
14219  500 msg = 'DLSOIBT- At current T (=R1), MXSTEP (=I1) steps '
14220  CALL xerrwd (msg, 50, 201, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
14221  msg = ' taken on this call before reaching TOUT '
14222  CALL xerrwd (msg, 50, 201, 0, 1, mxstep, 0, 1, tn, 0.0d0)
14223  istate = -1
14224  GO TO 580
14225 C EWT(i) .le. 0.0 for some i (not at start of problem). ----------------
14226  510 ewti = rwork(lewt+i-1)
14227  msg = .le.'DLSOIBT- At T (=R1), EWT(I1) has become R2 0.'
14228  CALL xerrwd (msg, 50, 202, 0, 1, i, 0, 2, tn, ewti)
14229  istate = -6
14230  GO TO 590
14231 C Too much accuracy requested for machine precision. -------------------
14232  520 msg = 'DLSOIBT- At T (=R1), too much accuracy requested '
14233  CALL xerrwd (msg, 50, 203, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
14234  msg = ' for precision of machine.. See TOLSF (=R2) '
14235  CALL xerrwd (msg, 50, 203, 0, 0, 0, 0, 2, tn, tolsf)
14236  rwork(14) = tolsf
14237  istate = -2
14238  GO TO 590
14239 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. -----
14240  530 msg = 'DLSOIBT- At T (=R1) and step size H (=R2), the '
14241  CALL xerrwd (msg, 50, 204, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
14242  msg = 'error test failed repeatedly or with ABS(H) = HMIN'
14243  CALL xerrwd (msg, 50, 204, 0, 0, 0, 0, 2, tn, h)
14244  istate = -4
14245  GO TO 570
14246 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ----
14247  540 msg = 'DLSOIBT- At T (=R1) and step size H (=R2), the '
14248  CALL xerrwd (msg, 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
14249  msg = ' corrector convergence failed repeatedly '
14250  CALL xerrwd (msg, 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
14251  msg = ' or with ABS(H) = HMIN '
14252  CALL xerrwd (msg, 30, 205, 0, 0, 0, 0, 2, tn, h)
14253  istate = -5
14254  GO TO 570
14255 C IRES = 3 returned by RES, despite retries by DSTODI.------------------
14256  550 msg = 'DLSOIBT- At T (=R1) residual routine returned '
14257  CALL xerrwd (msg, 50, 206, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
14258  msg = ' error IRES = 3 repeatedly. '
14259  CALL xerrwd (msg, 40, 206, 0, 0, 0, 0, 1, tn, 0.0d0)
14260  istate = -7
14261  GO TO 590
14262 C DAIGBT failed because a diagonal block of A matrix was singular. -----
14263  560 ier = -ier
14264  msg='DLSOIBT- Attempt to initialize dy/dt failed: Matrix A has a'
14265  CALL xerrwd (msg, 60, 207, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
14266  msg = ' singular diagonal block, block no. = (I1) '
14267  CALL xerrwd (msg, 50, 207, 0, 1, ier, 0, 0, 0.0d0, 0.0d0)
14268  istate = -8
14269  RETURN
14270 C DAIGBT failed because RES set IRES to 2 or 3. ------------------------
14271  565 msg = 'DLSOIBT- Attempt to initialize dy/dt failed '
14272  CALL xerrwd (msg, 50, 208, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
14273  msg = ' because residual routine set its error flag '
14274  CALL xerrwd (msg, 50, 208, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
14275  msg = ' to IRES = (I1)'
14276  CALL xerrwd (msg, 20, 208, 0, 1, ier, 0, 0, 0.0d0, 0.0d0)
14277  istate = -8
14278  RETURN
14279 C Compute IMXER if relevant. -------------------------------------------
14280  570 big = 0.0d0
14281  imxer = 1
14282  DO 575 i = 1,n
14283  SIZE = abs(rwork(i+lacor-1)*rwork(i+lewt-1))
14284  IF (big .GE. size) GO TO 575
14285  big = SIZE
14286  imxer = i
14287  575 CONTINUE
14288  iwork(16) = imxer
14289 C Compute residual if relevant. ----------------------------------------
14290  580 lyd0 = lyh + nyh
14291  DO 585 i = 1,n
14292  rwork(i+lsavf-1) = rwork(i+lyd0-1)/h
14293  585 y(i) = rwork(i+lyh-1)
14294  ires = 1
14295  CALL res (neq, tn, y, rwork(lsavf), ydoti, ires)
14296  nfe = nfe + 1
14297  IF (ires .LE. 1) GO TO 595
14298  msg = 'DLSOIBT- Residual routine set its flag IRES '
14299  CALL xerrwd (msg, 50, 210, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
14300  msg = ' to (I1) when called for final output. '
14301  CALL xerrwd (msg, 50, 210, 0, 1, ires, 0, 0, 0.0d0, 0.0d0)
14302  GO TO 595
14303 C Set Y vector, T, and optional outputs. -------------------------------
14304  590 DO 592 i = 1,n
14305  592 y(i) = rwork(i+lyh-1)
14306  595 t = tn
14307  rwork(11) = hu
14308  rwork(12) = h
14309  rwork(13) = tn
14310  iwork(11) = nst
14311  iwork(12) = nfe
14312  iwork(13) = nje
14313  iwork(14) = nqu
14314  iwork(15) = nq
14315  RETURN
14316 C-----------------------------------------------------------------------
14317 C Block I.
14318 C The following block handles all error returns due to illegal input
14319 C (ISTATE = -3), as detected before calling the core integrator.
14320 C First the error message routine is called. If the illegal input
14321 C is a negative ISTATE, the run is aborted (apparent infinite loop).
14322 C-----------------------------------------------------------------------
14323  601 msg = 'DLSOIBT- ISTATE (=I1) illegal.'
14324  CALL xerrwd (msg, 30, 1, 0, 1, istate, 0, 0, 0.0d0, 0.0d0)
14325  IF (istate .LT. 0) GO TO 800
14326  GO TO 700
14327  602 msg = 'DLSOIBT- ITASK (=I1) illegal. '
14328  CALL xerrwd (msg, 30, 2, 0, 1, itask, 0, 0, 0.0d0, 0.0d0)
14329  GO TO 700
14330  603 msg = .gt.'DLSOIBT- ISTATE1 but DLSOIBT not initialized. '
14331  CALL xerrwd (msg, 50, 3, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
14332  GO TO 700
14333  604 msg = .lt.'DLSOIBT- NEQ (=I1) 1 '
14334  CALL xerrwd (msg, 30, 4, 0, 1, neq(1), 0, 0, 0.0d0, 0.0d0)
14335  GO TO 700
14336  605 msg = 'DLSOIBT- ISTATE = 3 and NEQ increased (I1 to I2). '
14337  CALL xerrwd (msg, 50, 5, 0, 2, n, neq(1), 0, 0.0d0, 0.0d0)
14338  GO TO 700
14339  606 msg = 'DLSOIBT- ITOL (=I1) illegal. '
14340  CALL xerrwd (msg, 30, 6, 0, 1, itol, 0, 0, 0.0d0, 0.0d0)
14341  GO TO 700
14342  607 msg = 'DLSOIBT- IOPT (=I1) illegal. '
14343  CALL xerrwd (msg, 30, 7, 0, 1, iopt, 0, 0, 0.0d0, 0.0d0)
14344  GO TO 700
14345  608 msg = 'DLSOIBT- MF (=I1) illegal. '
14346  CALL xerrwd (msg, 30, 8, 0, 1, mf, 0, 0, 0.0d0, 0.0d0)
14347  GO TO 700
14348  609 msg = 'DLSOIBT- MB (=I1) or NB (=I2) illegal. '
14349  CALL xerrwd (msg, 40, 9, 0, 2, mb, nb, 0, 0.0d0, 0.0d0)
14350  GO TO 700
14351  610 msg = .lt.'DLSOIBT- NB (=I1) 4 illegal. '
14352  CALL xerrwd (msg, 40, 10, 0, 1, nb, 0, 0, 0.0d0, 0.0d0)
14353  GO TO 700
14354  611 msg = .lt.'DLSOIBT- MAXORD (=I1) 0 '
14355  CALL xerrwd (msg, 30, 11, 0, 1, maxord, 0, 0, 0.0d0, 0.0d0)
14356  GO TO 700
14357  612 msg = .lt.'DLSOIBT- MXSTEP (=I1) 0 '
14358  CALL xerrwd (msg, 30, 12, 0, 1, mxstep, 0, 0, 0.0d0, 0.0d0)
14359  GO TO 700
14360  613 msg = .lt.'DLSOIBT- MXHNIL (=I1) 0 '
14361  CALL xerrwd (msg, 30, 13, 0, 1, mxhnil, 0, 0, 0.0d0, 0.0d0)
14362  GO TO 700
14363  614 msg = 'DLSOIBT- TOUT (=R1) behind T (=R2) '
14364  CALL xerrwd (msg, 40, 14, 0, 0, 0, 0, 2, tout, t)
14365  msg = ' Integration direction is given by H0 (=R1) '
14366  CALL xerrwd (msg, 50, 14, 0, 0, 0, 0, 1, h0, 0.0d0)
14367  GO TO 700
14368  615 msg = .lt.'DLSOIBT- HMAX (=R1) 0.0 '
14369  CALL xerrwd (msg, 30, 15, 0, 0, 0, 0, 1, hmax, 0.0d0)
14370  GO TO 700
14371  616 msg = .lt.'DLSOIBT- HMIN (=R1) 0.0 '
14372  CALL xerrwd (msg, 30, 16, 0, 0, 0, 0, 1, hmin, 0.0d0)
14373  GO TO 700
14374  617 msg='DLSOIBT- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)'
14375  CALL xerrwd (msg, 60, 17, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0)
14376  GO TO 700
14377  618 msg='DLSOIBT- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)'
14378  CALL xerrwd (msg, 60, 18, 0, 2, leniw, liw, 0, 0.0d0, 0.0d0)
14379  GO TO 700
14380  619 msg = .lt.'DLSOIBT- RTOL(=I1) is R1 0.0 '
14381  CALL xerrwd (msg, 40, 19, 0, 1, i, 0, 1, rtoli, 0.0d0)
14382  GO TO 700
14383  620 msg = .lt.'DLSOIBT- ATOL(=I1) is R1 0.0 '
14384  CALL xerrwd (msg, 40, 20, 0, 1, i, 0, 1, atoli, 0.0d0)
14385  GO TO 700
14386  621 ewti = rwork(lewt+i-1)
14387  msg = .le.'DLSOIBT- EWT(I1) is R1 0.0 '
14388  CALL xerrwd (msg, 40, 21, 0, 1, i, 0, 1, ewti, 0.0d0)
14389  GO TO 700
14390  622 msg='DLSOIBT- TOUT(=R1) too close to T(=R2) to start integration.'
14391  CALL xerrwd (msg, 60, 22, 0, 0, 0, 0, 2, tout, t)
14392  GO TO 700
14393  623 msg='DLSOIBT- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) '
14394  CALL xerrwd (msg, 60, 23, 0, 1, itask, 0, 2, tout, tp)
14395  GO TO 700
14396  624 msg='DLSOIBT- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) '
14397  CALL xerrwd (msg, 60, 24, 0, 0, 0, 0, 2, tcrit, tn)
14398  GO TO 700
14399  625 msg='DLSOIBT- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) '
14400  CALL xerrwd (msg, 60, 25, 0, 0, 0, 0, 2, tcrit, tout)
14401  GO TO 700
14402  626 msg = 'DLSOIBT- At start of problem, too much accuracy '
14403  CALL xerrwd (msg, 50, 26, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
14404  msg=' requested for precision of machine.. See TOLSF (=R1) '
14405  CALL xerrwd (msg, 60, 26, 0, 0, 0, 0, 1, tolsf, 0.0d0)
14406  rwork(14) = tolsf
14407  GO TO 700
14408  627 msg = 'DLSOIBT- Trouble in DINTDY. ITASK = I1, TOUT = R1'
14409  CALL xerrwd (msg, 50, 27, 0, 1, itask, 0, 1, tout, 0.0d0)
14410 C
14411  700 istate = -3
14412  RETURN
14413 C
14414  800 msg = 'DLSOIBT- Run aborted.. apparent infinite loop. '
14415  CALL xerrwd (msg, 50, 303, 2, 0, 0, 0, 0, 0.0d0, 0.0d0)
14416  RETURN
14417 C----------------------- End of Subroutine DLSOIBT ---------------------
14418  END
14419 *DECK DLSODIS
14420  SUBROUTINE dlsodis (RES, ADDA, JAC, NEQ, Y, YDOTI, T, TOUT, ITOL,
14421  1 RTOL, ATOL, ITASK, ISTATE, IOPT, RWORK, LRW, IWORK, LIW, MF )
14422  EXTERNAL res, adda, jac
14423  INTEGER neq, itol, itask, istate, iopt, lrw, iwork, liw, mf
14424  DOUBLE PRECISION y, ydoti, t, tout, rtol, atol, rwork
14425  dimension neq(*), y(*), ydoti(*), rtol(*), atol(*), rwork(lrw),
14426  1 iwork(liw)
14427 C-----------------------------------------------------------------------
14428 C This is the 18 November 2003 version of
14429 C DLSODIS: Livermore Solver for Ordinary Differential equations
14430 C (Implicit form) with general Sparse Jacobian matrices.
14431 C
14432 C This version is in double precision.
14433 C
14434 C DLSODIS solves the initial value problem for linearly implicit
14435 C systems of first order ODEs,
14436 C A(t,y) * dy/dt = g(t,y) , where A(t,y) is a square matrix,
14437 C or, in component form,
14438 C ( a * ( dy / dt )) + ... + ( a * ( dy / dt )) =
14439 C i,1 1 i,NEQ NEQ
14440 C
14441 C = g ( t, y , y ,..., y ) ( i = 1,...,NEQ )
14442 C i 1 2 NEQ
14443 C
14444 C If A is singular, this is a differential-algebraic system.
14445 C
14446 C DLSODIS is a variant version of the DLSODI package, and is intended
14447 C for stiff problems in which the matrix A and the Jacobian matrix
14448 C d(g - A*s)/dy have arbitrary sparse structures.
14449 C
14450 C Authors: Alan C. Hindmarsh
14451 C Center for Applied Scientific Computing, L-561
14452 C Lawrence Livermore National Laboratory
14453 C Livermore, CA 94551
14454 C and
14455 C Sheila Balsdon
14456 C Zycor, Inc.
14457 C Austin, TX 78741
14458 C-----------------------------------------------------------------------
14459 C References:
14460 C 1. M. K. Seager and S. Balsdon, LSODIS, A Sparse Implicit
14461 C ODE Solver, in Proceedings of the IMACS 10th World Congress,
14462 C Montreal, August 8-13, 1982.
14463 C
14464 C 2. Alan C. Hindmarsh, LSODE and LSODI, Two New Initial Value
14465 C Ordinary Differential Equation Solvers,
14466 C ACM-SIGNUM Newsletter, vol. 15, no. 4 (1980), pp. 10-11.
14467 C
14468 C 3. S. C. Eisenstat, M. C. Gursky, M. H. Schultz, and A. H. Sherman,
14469 C Yale Sparse Matrix Package: I. The Symmetric Codes,
14470 C Int. J. Num. Meth. Eng., vol. 18 (1982), pp. 1145-1151.
14471 C
14472 C 4. S. C. Eisenstat, M. C. Gursky, M. H. Schultz, and A. H. Sherman,
14473 C Yale Sparse Matrix Package: II. The Nonsymmetric Codes,
14474 C Research Report No. 114, Dept. of Computer Sciences, Yale
14475 C University, 1977.
14476 C-----------------------------------------------------------------------
14477 C Summary of Usage.
14478 C
14479 C Communication between the user and the DLSODIS package, for normal
14480 C situations, is summarized here. This summary describes only a subset
14481 C of the full set of options available. See the full description for
14482 C details, including optional communication, nonstandard options,
14483 C and instructions for special situations. See also the example
14484 C problem (with program and output) following this summary.
14485 C
14486 C A. First, provide a subroutine of the form:
14487 C SUBROUTINE RES (NEQ, T, Y, S, R, IRES)
14488 C DOUBLE PRECISION T, Y(*), S(*), R(*)
14489 C which computes the residual function
14490 C r = g(t,y) - A(t,y) * s ,
14491 C as a function of t and the vectors y and s. (s is an internally
14492 C generated approximation to dy/dt.) The arrays Y and S are inputs
14493 C to the RES routine and should not be altered. The residual
14494 C vector is to be stored in the array R. The argument IRES should be
14495 C ignored for casual use of DLSODIS. (For uses of IRES, see the
14496 C paragraph on RES in the full description below.)
14497 C
14498 C B. DLSODIS must deal internally with the matrices A and dr/dy, where
14499 C r is the residual function defined above. DLSODIS generates a linear
14500 C combination of these two matrices in sparse form.
14501 C The matrix structure is communicated by a method flag, MF:
14502 C MF = 21 or 22 when the user provides the structures of
14503 C matrix A and dr/dy,
14504 C MF = 121 or 222 when the user does not provide structure
14505 C information, and
14506 C MF = 321 or 422 when the user provides the structure
14507 C of matrix A.
14508 C
14509 C C. You must also provide a subroutine of the form:
14510 C SUBROUTINE ADDA (NEQ, T, Y, J, IAN, JAN, P)
14511 C DOUBLE PRECISION T, Y(*), P(*)
14512 C INTEGER IAN(*), JAN(*)
14513 C which adds the matrix A = A(t,y) to the contents of the array P.
14514 C NEQ, T, Y, and J are input arguments and should not be altered.
14515 C This routine should add the J-th column of matrix A to the array
14516 C P (of length NEQ). I.e. add A(i,J) to P(i) for all relevant
14517 C values of i. The arguments IAN and JAN should be ignored for normal
14518 C situations. DLSODIS will call the ADDA routine with J = 1,2,...,NEQ.
14519 C
14520 C D. For the sake of efficiency, you are encouraged to supply the
14521 C Jacobian matrix dr/dy in closed form, where r = g(t,y) - A(t,y)*s
14522 C (s = a fixed vector) as above. If dr/dy is being supplied,
14523 C use MF = 21, 121, or 321, and provide a subroutine of the form:
14524 C SUBROUTINE JAC (NEQ, T, Y, S, J, IAN, JAN, PDJ)
14525 C DOUBLE PRECISION T, Y(*), S(*), PDJ(*)
14526 C INTEGER IAN(*), JAN(*)
14527 C which computes dr/dy as a function of t, y, and s. Here NEQ, T, Y, S,
14528 C and J are input arguments, and the JAC routine is to load the array
14529 C PDJ (of length NEQ) with the J-th column of dr/dy. I.e. load PDJ(i)
14530 C with dr(i)/dy(J) for all relevant values of i. The arguments IAN and
14531 C JAN should be ignored for normal situations. DLSODIS will call the
14532 C JAC routine with J = 1,2,...,NEQ.
14533 C Only nonzero elements need be loaded. A crude approximation
14534 C to dr/dy, possibly with fewer nonzero elememts, will suffice.
14535 C Note that if A is independent of y (or this dependence
14536 C is weak enough to be ignored) then JAC is to compute dg/dy.
14537 C If it is not feasible to provide a JAC routine, use
14538 C MF = 22, 222, or 422 and DLSODIS will compute an approximate
14539 C Jacobian internally by difference quotients.
14540 C
14541 C E. Next decide whether or not to provide the initial value of the
14542 C derivative vector dy/dt. If the initial value of A(t,y) is
14543 C nonsingular (and not too ill-conditioned), you may let DLSODIS compute
14544 C this vector (ISTATE = 0). (DLSODIS will solve the system A*s = g for
14545 C s, with initial values of A and g.) If A(t,y) is initially
14546 C singular, then the system is a differential-algebraic system, and
14547 C you must make use of the particular form of the system to compute the
14548 C initial values of y and dy/dt. In that case, use ISTATE = 1 and
14549 C load the initial value of dy/dt into the array YDOTI.
14550 C The input array YDOTI and the initial Y array must be consistent with
14551 C the equations A*dy/dt = g. This implies that the initial residual
14552 C r = g(t,y) - A(t,y)*YDOTI must be approximately zero.
14553 C
14554 C F. Write a main program which calls Subroutine DLSODIS once for
14555 C each point at which answers are desired. This should also provide
14556 C for possible use of logical unit 6 for output of error messages by
14557 C DLSODIS. On the first call to DLSODIS, supply arguments as follows:
14558 C RES = name of user subroutine for residual function r.
14559 C ADDA = name of user subroutine for computing and adding A(t,y).
14560 C JAC = name of user subroutine for Jacobian matrix dr/dy
14561 C (MF = 121). If not used, pass a dummy name.
14562 C Note: The names for the RES and ADDA routines and (if used) the
14563 C JAC routine must be declared External in the calling program.
14564 C NEQ = number of scalar equations in the system.
14565 C Y = array of initial values, of length NEQ.
14566 C YDOTI = array of length NEQ (containing initial dy/dt if ISTATE = 1).
14567 C T = the initial value of the independent variable.
14568 C TOUT = first point where output is desired (.ne. T).
14569 C ITOL = 1 or 2 according as ATOL (below) is a scalar or array.
14570 C RTOL = relative tolerance parameter (scalar).
14571 C ATOL = absolute tolerance parameter (scalar or array).
14572 C The estimated local error in y(i) will be controlled so as
14573 C to be roughly less (in magnitude) than
14574 C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or
14575 C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2.
14576 C Thus the local error test passes if, in each component,
14577 C either the absolute error is less than ATOL (or ATOL(i)),
14578 C or the relative error is less than RTOL.
14579 C Use RTOL = 0.0 for pure absolute error control, and
14580 C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error
14581 C control. Caution: Actual (global) errors may exceed these
14582 C local tolerances, so choose them conservatively.
14583 C ITASK = 1 for normal computation of output values of y at t = TOUT.
14584 C ISTATE = integer flag (input and output). Set ISTATE = 1 if the
14585 C initial dy/dt is supplied, and 0 otherwise.
14586 C IOPT = 0 to indicate no optional inputs used.
14587 C RWORK = real work array of length at least:
14588 C 20 + (2 + 1./LENRAT)*NNZ + (11 + 9./LENRAT)*NEQ
14589 C where:
14590 C NNZ = the number of nonzero elements in the sparse
14591 C iteration matrix P = A - con*dr/dy (con = scalar)
14592 C (If NNZ is unknown, use an estimate of it.)
14593 C LENRAT = the real to integer wordlength ratio (usually 1 in
14594 C single precision and 2 in double precision).
14595 C In any case, the required size of RWORK cannot generally
14596 C be predicted in advance for any value of MF, and the
14597 C value above is a rough estimate of a crude lower bound.
14598 C Some experimentation with this size may be necessary.
14599 C (When known, the correct required length is an optional
14600 C output, available in IWORK(17).)
14601 C LRW = declared length of RWORK (in user's dimension).
14602 C IWORK = integer work array of length at least 30.
14603 C LIW = declared length of IWORK (in user's dimension).
14604 C MF = method flag. Standard values are:
14605 C 121 for a user-supplied sparse Jacobian.
14606 C 222 for an internally generated sparse Jacobian.
14607 C For other choices of MF, see the paragraph on MF in
14608 C the full description below.
14609 C Note that the main program must declare arrays Y, YDOTI, RWORK, IWORK,
14610 C and possibly ATOL.
14611 C
14612 C G. The output from the first call, or any call, is:
14613 C Y = array of computed values of y(t) vector.
14614 C T = corresponding value of independent variable (normally TOUT).
14615 C ISTATE = 2 if DLSODIS was successful, negative otherwise.
14616 C -1 means excess work done on this call (check all inputs).
14617 C -2 means excess accuracy requested (tolerances too small).
14618 C -3 means illegal input detected (see printed message).
14619 C -4 means repeated error test failures (check all inputs).
14620 C -5 means repeated convergence failures (perhaps bad Jacobian
14621 C supplied or wrong choice of tolerances).
14622 C -6 means error weight became zero during problem. (Solution
14623 C component i vanished, and ATOL or ATOL(i) = 0.)
14624 C -7 cannot occur in casual use.
14625 C -8 means DLSODIS was unable to compute the initial dy/dt.
14626 C in casual use, this means A(t,y) is initially singular.
14627 C Supply YDOTI and use ISTATE = 1 on the first call.
14628 C -9 means a fatal error return flag came from sparse solver
14629 C CDRV by way of DPRJIS or DSOLSS. Should never happen.
14630 C
14631 C A return with ISTATE = -1, -4, or -5, may result from using
14632 C an inappropriate sparsity structure, one that is quite
14633 C different from the initial structure. Consider calling
14634 C DLSODIS again with ISTATE = 3 to force the structure to be
14635 C reevaluated. See the full description of ISTATE below.
14636 C
14637 C If DLSODIS returns ISTATE = -1, -4 or -5, then the output of
14638 C DLSODIS also includes YDOTI = array containing residual vector
14639 C r = g - A * dy/dt evaluated at the current t, y, and dy/dt.
14640 C
14641 C H. To continue the integration after a successful return, simply
14642 C reset TOUT and call DLSODIS again. No other parameters need be reset.
14643 C
14644 C-----------------------------------------------------------------------
14645 C Example Problem.
14646 C
14647 C The following is an example problem, with the coding needed
14648 C for its solution by DLSODIS. The problem comes from the partial
14649 C differential equation (the Burgers equation)
14650 C du/dt = - u * du/dx + eta * d**2 u/dx**2, eta = .05,
14651 C on -1 .le. x .le. 1. The boundary conditions are periodic:
14652 C u(-1,t) = u(1,t) and du/dx(-1,t) = du/dx(1,t)
14653 C The initial profile is a square wave,
14654 C u = 1 in ABS(x) .lt. .5, u = .5 at ABS(x) = .5, u = 0 elsewhere.
14655 C The PDE is discretized in x by a simplified Galerkin method,
14656 C using piecewise linear basis functions, on a grid of 40 intervals.
14657 C The result is a system A * dy/dt = g(y), of size NEQ = 40,
14658 C where y(i) is the approximation to u at x = x(i), with
14659 C x(i) = -1 + (i-1)*delx, delx = 2/NEQ = .05.
14660 C The individual equations in the system are (in order):
14661 C (1/6)dy(NEQ)/dt+(4/6)dy(1)/dt+(1/6)dy(2)/dt
14662 C = r4d*(y(NEQ)**2-y(2)**2)+eodsq*(y(2)-2*y(1)+y(NEQ))
14663 C for i = 2,3,...,nm1,
14664 C (1/6)dy(i-1)/dt+(4/6)dy(i)/dt+(1/6)dy(i+1)/dt
14665 C = r4d*(y(i-1)**2-y(i+1)**2)+eodsq*(y(i+1)-2*y(i)+y(i-1))
14666 C and finally
14667 C (1/6)dy(nm1)/dt+(4/6)dy(NEQ)/dt+(1/6)dy(1)/dt
14668 C = r4d*(y(nm1)**2-y(1)**2)+eodsq*(y(1)-2*y(NEQ)+y(nm1))
14669 C where r4d = 1/(4*delx), eodsq = eta/delx**2 and nm1 = NEQ-1.
14670 C The following coding solves the problem with MF = 121, with output
14671 C of solution statistics at t = .1, .2, .3, and .4, and of the
14672 C solution vector at t = .4. Optional outputs (run statistics) are
14673 C also printed.
14674 C
14675 C EXTERNAL RESID, ADDASP, JACSP
14676 C DOUBLE PRECISION ATOL, RTOL, RW, T, TOUT, Y, YDOTI, R4D, EODSQ, DELX
14677 C DIMENSION Y(40), YDOTI(40), RW(1409), IW(30)
14678 C COMMON /TEST1/ R4D, EODSQ, NM1
14679 C DATA ITOL/1/, RTOL/1.0D-3/, ATOL/1.0D-3/, ITASK/1/, IOPT/0/
14680 C DATA NEQ/40/, LRW/1409/, LIW/30/, MF/121/
14681 C
14682 C DELX = 2.0/NEQ
14683 C R4D = 0.25/DELX
14684 C EODSQ = 0.05/DELX**2
14685 C NM1 = NEQ - 1
14686 C DO 10 I = 1,NEQ
14687 C 10 Y(I) = 0.0
14688 C Y(11) = 0.5
14689 C DO 15 I = 12,30
14690 C 15 Y(I) = 1.0
14691 C Y(31) = 0.5
14692 C T = 0.0
14693 C TOUT = 0.1
14694 C ISTATE = 0
14695 C DO 30 IO = 1,4
14696 C CALL DLSODIS (RESID, ADDASP, JACSP, NEQ, Y, YDOTI, T, TOUT,
14697 C 1 ITOL, RTOL, ATOL, ITASK, ISTATE, IOPT, RW, LRW, IW, LIW, MF)
14698 C WRITE(6,20) T,IW(11),RW(11)
14699 C 20 FORMAT(' At t =',F5.2,' No. steps =',I4,
14700 C 1 ' Last step =',D12.4)
14701 C IF (ISTATE .NE. 2) GO TO 90
14702 C TOUT = TOUT + 0.1
14703 C 30 CONTINUE
14704 C WRITE (6,40) (Y(I),I=1,NEQ)
14705 C 40 FORMAT(/' Final solution values..'/8(5D12.4/))
14706 C WRITE(6,50) IW(17),IW(18),IW(11),IW(12),IW(13)
14707 C NNZLU = IW(25) + IW(26) + NEQ
14708 C WRITE(6,60) IW(19),NNZLU
14709 C 50 FORMAT(/' Required RW size =',I5,' IW size =',I4/
14710 C 1 ' No. steps =',I4,' No. r-s =',I4,' No. J-s =',i4)
14711 C 60 FORMAT(' No. of nonzeros in P matrix =',I4,
14712 C 1 ' No. of nonzeros in LU =',I4)
14713 C STOP
14714 C 90 WRITE (6,95) ISTATE
14715 C 95 FORMAT(///' Error halt.. ISTATE =',I3)
14716 C STOP
14717 C END
14718 C
14719 C SUBROUTINE GFUN (N, T, Y, G)
14720 C DOUBLE PRECISION T, Y, G, R4D, EODSQ
14721 C DIMENSION G(N), Y(N)
14722 C COMMON /TEST1/ R4D, EODSQ, NM1
14723 C G(1) = R4D*(Y(N)**2-Y(2)**2) + EODSQ*(Y(2)-2.0*Y(1)+Y(N))
14724 C DO 10 I = 2,NM1
14725 C G(I) = R4D*(Y(I-1)**2 - Y(I+1)**2)
14726 C 1 + EODSQ*(Y(I+1) - 2.0*Y(I) + Y(I-1))
14727 C 10 CONTINUE
14728 C G(N) = R4D*(Y(NM1)**2-Y(1)**2) + EODSQ*(Y(1)-2.0*Y(N)+Y(NM1))
14729 C RETURN
14730 C END
14731 C
14732 C SUBROUTINE RESID (N, T, Y, S, R, IRES)
14733 C DOUBLE PRECISION T, Y, S, R, R4D, EODSQ
14734 C DIMENSION Y(N), S(N), R(N)
14735 C COMMON /TEST1/ R4D, EODSQ, NM1
14736 C CALL GFUN (N, T, Y, R)
14737 C R(1) = R(1) - (S(N) + 4.0*S(1) + S(2))/6.0
14738 C DO 10 I = 2,NM1
14739 C 10 R(I) = R(I) - (S(I-1) + 4.0*S(I) + S(I+1))/6.0
14740 C R(N) = R(N) - (S(NM1) + 4.0*S(N) + S(1))/6.0
14741 C RETURN
14742 C END
14743 C
14744 C SUBROUTINE ADDASP (N, T, Y, J, IP, JP, P)
14745 C DOUBLE PRECISION T, Y, P
14746 C DIMENSION Y(N), IP(*), JP(*), P(N)
14747 C JM1 = J - 1
14748 C JP1 = J + 1
14749 C IF (J .EQ. N) JP1 = 1
14750 C IF (J .EQ. 1) JM1 = N
14751 C P(J) = P(J) + (2.0/3.0)
14752 C P(JP1) = P(JP1) + (1.0/6.0)
14753 C P(JM1) = P(JM1) + (1.0/6.0)
14754 C RETURN
14755 C END
14756 C
14757 C SUBROUTINE JACSP (N, T, Y, S, J, IP, JP, PDJ)
14758 C DOUBLE PRECISION T, Y, S, PDJ, R4D, EODSQ
14759 C DIMENSION Y(N), S(N), IP(*), JP(*), PDJ(N)
14760 C COMMON /TEST1/ R4D, EODSQ, NM1
14761 C JM1 = J - 1
14762 C JP1 = J + 1
14763 C IF (J .EQ. 1) JM1 = N
14764 C IF (J .EQ. N) JP1 = 1
14765 C PDJ(JM1) = -2.0*R4D*Y(J) + EODSQ
14766 C PDJ(J) = -2.0*EODSQ
14767 C PDJ(JP1) = 2.0*R4D*Y(J) + EODSQ
14768 C RETURN
14769 C END
14770 C
14771 C The output of this program (on a CDC-7600 in single precision)
14772 C is as follows:
14773 C
14774 C At t = 0.10 No. steps = 15 Last step = 1.6863e-02
14775 C At t = 0.20 No. steps = 19 Last step = 2.4101e-02
14776 C At t = 0.30 No. steps = 22 Last step = 4.3143e-02
14777 C At t = 0.40 No. steps = 24 Last step = 5.7819e-02
14778 C
14779 C Final solution values..
14780 C 1.8371e-02 1.3578e-02 1.5864e-02 2.3805e-02 3.7245e-02
14781 C 5.6630e-02 8.2538e-02 1.1538e-01 1.5522e-01 2.0172e-01
14782 C 2.5414e-01 3.1150e-01 3.7259e-01 4.3608e-01 5.0060e-01
14783 C 5.6482e-01 6.2751e-01 6.8758e-01 7.4415e-01 7.9646e-01
14784 C 8.4363e-01 8.8462e-01 9.1853e-01 9.4500e-01 9.6433e-01
14785 C 9.7730e-01 9.8464e-01 9.8645e-01 9.8138e-01 9.6584e-01
14786 C 9.3336e-01 8.7497e-01 7.8213e-01 6.5315e-01 4.9997e-01
14787 C 3.4672e-01 2.1758e-01 1.2461e-01 6.6208e-02 3.3784e-02
14788 C
14789 C Required RW size = 1409 IW size = 30
14790 C No. steps = 24 No. r-s = 33 No. J-s = 8
14791 C No. of nonzeros in P matrix = 120 No. of nonzeros in LU = 194
14792 C
14793 C-----------------------------------------------------------------------
14794 C Full Description of User Interface to DLSODIS.
14795 C
14796 C The user interface to DLSODIS consists of the following parts.
14797 C
14798 C 1. The call sequence to Subroutine DLSODIS, which is a driver
14799 C routine for the solver. This includes descriptions of both
14800 C the call sequence arguments and of user-supplied routines.
14801 C Following these descriptions is a description of
14802 C optional inputs available through the call sequence, and then
14803 C a description of optional outputs (in the work arrays).
14804 C
14805 C 2. Descriptions of other routines in the DLSODIS package that may be
14806 C (optionally) called by the user. These provide the ability to
14807 C alter error message handling, save and restore the internal
14808 C Common, and obtain specified derivatives of the solution y(t).
14809 C
14810 C 3. Descriptions of Common blocks to be declared in overlay
14811 C or similar environments, or to be saved when doing an interrupt
14812 C of the problem and continued solution later.
14813 C
14814 C 4. Description of two routines in the DLSODIS package, either of
14815 C which the user may replace with his/her own version, if desired.
14816 C These relate to the measurement of errors.
14817 C
14818 C-----------------------------------------------------------------------
14819 C Part 1. Call Sequence.
14820 C
14821 C The call sequence parameters used for input only are
14822 C RES, ADDA, JAC, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK,
14823 C IOPT, LRW, LIW, MF,
14824 C and those used for both input and output are
14825 C Y, T, ISTATE, YDOTI.
14826 C The work arrays RWORK and IWORK are also used for conditional and
14827 C optional inputs and optional outputs. (The term output here refers
14828 C to the return from Subroutine DLSODIS to the user's calling program.)
14829 C
14830 C The legality of input parameters will be thoroughly checked on the
14831 C initial call for the problem, but not checked thereafter unless a
14832 C change in input parameters is flagged by ISTATE = 3 on input.
14833 C
14834 C The descriptions of the call arguments are as follows.
14835 C
14836 C RES = the name of the user-supplied subroutine which supplies
14837 C the residual vector for the ODE system, defined by
14838 C r = g(t,y) - A(t,y) * s
14839 C as a function of the scalar t and the vectors
14840 C s and y (s approximates dy/dt). This subroutine
14841 C is to have the form
14842 C SUBROUTINE RES (NEQ, T, Y, S, R, IRES)
14843 C DOUBLE PRECISION T, Y(*), S(*), R(*)
14844 C where NEQ, T, Y, S, and IRES are input, and R and
14845 C IRES are output. Y, S, and R are arrays of length NEQ.
14846 C On input, IRES indicates how DLSODIS will use the
14847 C returned array R, as follows:
14848 C IRES = 1 means that DLSODIS needs the full residual,
14849 C r = g - A*s, exactly.
14850 C IRES = -1 means that DLSODIS is using R only to compute
14851 C the Jacobian dr/dy by difference quotients.
14852 C The RES routine can ignore IRES, or it can omit some terms
14853 C if IRES = -1. If A does not depend on y, then RES can
14854 C just return R = g when IRES = -1. If g - A*s contains other
14855 C additive terms that are independent of y, these can also be
14856 C dropped, if done consistently, when IRES = -1.
14857 C The subroutine should set the flag IRES if it
14858 C encounters a halt condition or illegal input.
14859 C Otherwise, it should not reset IRES. On output,
14860 C IRES = 1 or -1 represents a normal return, and
14861 C DLSODIS continues integrating the ODE. Leave IRES
14862 C unchanged from its input value.
14863 C IRES = 2 tells DLSODIS to immediately return control
14864 C to the calling program, with ISTATE = 3. This lets
14865 C the calling program change parameters of the problem
14866 C if necessary.
14867 C IRES = 3 represents an error condition (for example, an
14868 C illegal value of y). DLSODIS tries to integrate the system
14869 C without getting IRES = 3 from RES. If it cannot, DLSODIS
14870 C returns with ISTATE = -7 or -1.
14871 C On a return with ISTATE = 3, -1, or -7, the values
14872 C of T and Y returned correspond to the last point reached
14873 C successfully without getting the flag IRES = 2 or 3.
14874 C The flag values IRES = 2 and 3 should not be used to
14875 C handle switches or root-stop conditions. This is better
14876 C done by calling DLSODIS in a one-step mode and checking the
14877 C stopping function for a sign change at each step.
14878 C If quantities computed in the RES routine are needed
14879 C externally to DLSODIS, an extra call to RES should be made
14880 C for this purpose, for consistent and accurate results.
14881 C To get the current dy/dt for the S argument, use DINTDY.
14882 C RES must be declared External in the calling
14883 C program. See note below for more about RES.
14884 C
14885 C ADDA = the name of the user-supplied subroutine which adds the
14886 C matrix A = A(t,y) to another matrix stored in sparse form.
14887 C This subroutine is to have the form
14888 C SUBROUTINE ADDA (NEQ, T, Y, J, IAN, JAN, P)
14889 C DOUBLE PRECISION T, Y(*), P(*)
14890 C INTEGER IAN(*), JAN(*)
14891 C where NEQ, T, Y, J, IAN, JAN, and P are input. This routine
14892 C should add the J-th column of matrix A to the array P, of
14893 C length NEQ. Thus a(i,J) is to be added to P(i) for all
14894 C relevant values of i. Here T and Y have the same meaning as
14895 C in Subroutine RES, and J is a column index (1 to NEQ).
14896 C IAN and JAN are undefined in calls to ADDA for structure
14897 C determination (MOSS .ne. 0). Otherwise, IAN and JAN are
14898 C structure descriptors, as defined under optional outputs
14899 C below, and so can be used to determine the relevant row
14900 C indices i, if desired.
14901 C Calls to ADDA are made with J = 1,...,NEQ, in that
14902 C order. ADDA must not alter its input arguments.
14903 C ADDA must be declared External in the calling program.
14904 C See note below for more information about ADDA.
14905 C
14906 C JAC = the name of the user-supplied subroutine which supplies
14907 C the Jacobian matrix, dr/dy, where r = g - A*s. JAC is
14908 C required if MITER = 1, or MOSS = 1 or 3. Otherwise a dummy
14909 C name can be passed. This subroutine is to have the form
14910 C SUBROUTINE JAC (NEQ, T, Y, S, J, IAN, JAN, PDJ)
14911 C DOUBLE PRECISION T, Y(*), S(*), PDJ(*)
14912 C INTEGER IAN(*), JAN(*)
14913 C where NEQ, T, Y, S, J, IAN, and JAN are input. The
14914 C array PDJ, of length NEQ, is to be loaded with column J
14915 C of the Jacobian on output. Thus dr(i)/dy(J) is to be
14916 C loaded into PDJ(i) for all relevant values of i.
14917 C Here T, Y, and S have the same meaning as in Subroutine RES,
14918 C and J is a column index (1 to NEQ). IAN and JAN
14919 C are undefined in calls to JAC for structure determination
14920 C (MOSS .ne. 0). Otherwise, IAN and JAN are structure
14921 C descriptors, as defined under optional outputs below, and
14922 C so can be used to determine the relevant row indices i, if
14923 C desired.
14924 C JAC need not provide dr/dy exactly. A crude
14925 C approximation (possibly with greater sparsity) will do.
14926 C In any case, PDJ is preset to zero by the solver,
14927 C so that only the nonzero elements need be loaded by JAC.
14928 C Calls to JAC are made with J = 1,...,NEQ, in that order, and
14929 C each such set of calls is preceded by a call to RES with the
14930 C same arguments NEQ, T, Y, S, and IRES. Thus to gain some
14931 C efficiency intermediate quantities shared by both calculations
14932 C may be saved in a user Common block by RES and not recomputed
14933 C by JAC, if desired. JAC must not alter its input arguments.
14934 C JAC must be declared External in the calling program.
14935 C See note below for more about JAC.
14936 C
14937 C Note on RES, ADDA, and JAC:
14938 C These subroutines may access user-defined quantities in
14939 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array
14940 C (dimensioned in the subroutines) and/or Y has length
14941 C exceeding NEQ(1). However, these subroutines should not
14942 C alter NEQ(1), Y(1),...,Y(NEQ) or any other input variables.
14943 C See the descriptions of NEQ and Y below.
14944 C
14945 C NEQ = the size of the system (number of first order ordinary
14946 C differential equations or scalar algebraic equations).
14947 C Used only for input.
14948 C NEQ may be decreased, but not increased, during the problem.
14949 C If NEQ is decreased (with ISTATE = 3 on input), the
14950 C remaining components of Y should be left undisturbed, if
14951 C these are to be accessed in RES, ADDA, or JAC.
14952 C
14953 C Normally, NEQ is a scalar, and it is generally referred to
14954 C as a scalar in this user interface description. However,
14955 C NEQ may be an array, with NEQ(1) set to the system size.
14956 C (The DLSODIS package accesses only NEQ(1).) In either case,
14957 C this parameter is passed as the NEQ argument in all calls
14958 C to RES, ADDA, and JAC. Hence, if it is an array,
14959 C locations NEQ(2),... may be used to store other integer data
14960 C and pass it to RES, ADDA, or JAC. Each such subroutine
14961 C must include NEQ in a Dimension statement in that case.
14962 C
14963 C Y = a real array for the vector of dependent variables, of
14964 C length NEQ or more. Used for both input and output on the
14965 C first call (ISTATE = 0 or 1), and only for output on other
14966 C calls. On the first call, Y must contain the vector of
14967 C initial values. On output, Y contains the computed solution
14968 C vector, evaluated at T. If desired, the Y array may be used
14969 C for other purposes between calls to the solver.
14970 C
14971 C This array is passed as the Y argument in all calls to RES,
14972 C ADDA, and JAC. Hence its length may exceed NEQ,
14973 C and locations Y(NEQ+1),... may be used to store other real
14974 C data and pass it to RES, ADDA, or JAC. (The DLSODIS
14975 C package accesses only Y(1),...,Y(NEQ). )
14976 C
14977 C YDOTI = a real array for the initial value of the vector
14978 C dy/dt and for work space, of dimension at least NEQ.
14979 C
14980 C On input:
14981 C If ISTATE = 0 then DLSODIS will compute the initial value
14982 C of dy/dt, if A is nonsingular. Thus YDOTI will
14983 C serve only as work space and may have any value.
14984 C If ISTATE = 1 then YDOTI must contain the initial value
14985 C of dy/dt.
14986 C If ISTATE = 2 or 3 (continuation calls) then YDOTI
14987 C may have any value.
14988 C Note: If the initial value of A is singular, then
14989 C DLSODIS cannot compute the initial value of dy/dt, so
14990 C it must be provided in YDOTI, with ISTATE = 1.
14991 C
14992 C On output, when DLSODIS terminates abnormally with ISTATE =
14993 C -1, -4, or -5, YDOTI will contain the residual
14994 C r = g(t,y) - A(t,y)*(dy/dt). If r is large, t is near
14995 C its initial value, and YDOTI is supplied with ISTATE = 1,
14996 C there may have been an incorrect input value of
14997 C YDOTI = dy/dt, or the problem (as given to DLSODIS)
14998 C may not have a solution.
14999 C
15000 C If desired, the YDOTI array may be used for other
15001 C purposes between calls to the solver.
15002 C
15003 C T = the independent variable. On input, T is used only on the
15004 C first call, as the initial point of the integration.
15005 C On output, after each call, T is the value at which a
15006 C computed solution y is evaluated (usually the same as TOUT).
15007 C On an error return, T is the farthest point reached.
15008 C
15009 C TOUT = the next value of t at which a computed solution is desired.
15010 C Used only for input.
15011 C
15012 C When starting the problem (ISTATE = 0 or 1), TOUT may be
15013 C equal to T for one call, then should .ne. T for the next
15014 C call. For the initial T, an input value of TOUT .ne. T is
15015 C used in order to determine the direction of the integration
15016 C (i.e. the algebraic sign of the step sizes) and the rough
15017 C scale of the problem. Integration in either direction
15018 C (forward or backward in t) is permitted.
15019 C
15020 C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after
15021 C the first call (i.e. the first call with TOUT .ne. T).
15022 C Otherwise, TOUT is required on every call.
15023 C
15024 C If ITASK = 1, 3, or 4, the values of TOUT need not be
15025 C monotone, but a value of TOUT which backs up is limited
15026 C to the current internal T interval, whose endpoints are
15027 C TCUR - HU and TCUR (see optional outputs, below, for
15028 C TCUR and HU).
15029 C
15030 C ITOL = an indicator for the type of error control. See
15031 C description below under ATOL. Used only for input.
15032 C
15033 C RTOL = a relative error tolerance parameter, either a scalar or
15034 C an array of length NEQ. See description below under ATOL.
15035 C Input only.
15036 C
15037 C ATOL = an absolute error tolerance parameter, either a scalar or
15038 C an array of length NEQ. Input only.
15039 C
15040 C The input parameters ITOL, RTOL, and ATOL determine
15041 C the error control performed by the solver. The solver will
15042 C control the vector E = (E(i)) of estimated local errors
15043 C in y, according to an inequality of the form
15044 C RMS-norm of ( E(i)/EWT(i) ) .le. 1,
15045 C where EWT(i) = RTOL(i)*ABS(Y(i)) + ATOL(i),
15046 C and the RMS-norm (root-mean-square norm) here is
15047 C RMS-norm(v) = SQRT(sum v(i)**2 / NEQ). Here EWT = (EWT(i))
15048 C is a vector of weights which must always be positive, and
15049 C the values of RTOL and ATOL should all be non-negative.
15050 C The following table gives the types (scalar/array) of
15051 C RTOL and ATOL, and the corresponding form of EWT(i).
15052 C
15053 C ITOL RTOL ATOL EWT(i)
15054 C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL
15055 C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i)
15056 C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL
15057 C 4 array scalar RTOL(i)*ABS(Y(i)) + ATOL(i)
15058 C
15059 C When either of these parameters is a scalar, it need not
15060 C be dimensioned in the user's calling program.
15061 C
15062 C If none of the above choices (with ITOL, RTOL, and ATOL
15063 C fixed throughout the problem) is suitable, more general
15064 C error controls can be obtained by substituting
15065 C user-supplied routines for the setting of EWT and/or for
15066 C the norm calculation. See Part 4 below.
15067 C
15068 C If global errors are to be estimated by making a repeated
15069 C run on the same problem with smaller tolerances, then all
15070 C components of RTOL and ATOL (i.e. of EWT) should be scaled
15071 C down uniformly.
15072 C
15073 C ITASK = an index specifying the task to be performed.
15074 C Input only. ITASK has the following values and meanings.
15075 C 1 means normal computation of output values of y(t) at
15076 C t = TOUT (by overshooting and interpolating).
15077 C 2 means take one step only and return.
15078 C 3 means stop at the first internal mesh point at or
15079 C beyond t = TOUT and return.
15080 C 4 means normal computation of output values of y(t) at
15081 C t = TOUT but without overshooting t = TCRIT.
15082 C TCRIT must be input as RWORK(1). TCRIT may be equal to
15083 C or beyond TOUT, but not behind it in the direction of
15084 C integration. This option is useful if the problem
15085 C has a singularity at or beyond t = TCRIT.
15086 C 5 means take one step, without passing TCRIT, and return.
15087 C TCRIT must be input as RWORK(1).
15088 C
15089 C Note: If ITASK = 4 or 5 and the solver reaches TCRIT
15090 C (within roundoff), it will return T = TCRIT (exactly) to
15091 C indicate this (unless ITASK = 4 and TOUT comes before TCRIT,
15092 C in which case answers at t = TOUT are returned first).
15093 C
15094 C ISTATE = an index used for input and output to specify the
15095 C state of the calculation.
15096 C
15097 C On input, the values of ISTATE are as follows.
15098 C 0 means this is the first call for the problem, and
15099 C DLSODIS is to compute the initial value of dy/dt
15100 C (while doing other initializations). See note below.
15101 C 1 means this is the first call for the problem, and
15102 C the initial value of dy/dt has been supplied in
15103 C YDOTI (DLSODIS will do other initializations).
15104 C See note below.
15105 C 2 means this is not the first call, and the calculation
15106 C is to continue normally, with no change in any input
15107 C parameters except possibly TOUT and ITASK.
15108 C (If ITOL, RTOL, and/or ATOL are changed between calls
15109 C with ISTATE = 2, the new values will be used but not
15110 C tested for legality.)
15111 C 3 means this is not the first call, and the
15112 C calculation is to continue normally, but with
15113 C a change in input parameters other than
15114 C TOUT and ITASK. Changes are allowed in
15115 C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF,
15116 C the conditional inputs IA, JA, IC, and JC,
15117 C and any of the optional inputs except H0.
15118 C A call with ISTATE = 3 will cause the sparsity
15119 C structure of the problem to be recomputed.
15120 C (Structure information is reread from IA and JA if
15121 C MOSS = 0, 3, or 4 and from IC and JC if MOSS = 0).
15122 C Note: A preliminary call with TOUT = T is not counted
15123 C as a first call here, as no initialization or checking of
15124 C input is done. (Such a call is sometimes useful for the
15125 C purpose of outputting the initial conditions.)
15126 C Thus the first call for which TOUT .ne. T requires
15127 C ISTATE = 0 or 1 on input.
15128 C
15129 C On output, ISTATE has the following values and meanings.
15130 C 0 or 1 means nothing was done; TOUT = T and
15131 C ISTATE = 0 or 1 on input.
15132 C 2 means that the integration was performed successfully.
15133 C 3 means that the user-supplied Subroutine RES signalled
15134 C DLSODIS to halt the integration and return (IRES = 2).
15135 C Integration as far as T was achieved with no occurrence
15136 C of IRES = 2, but this flag was set on attempting the
15137 C next step.
15138 C -1 means an excessive amount of work (more than MXSTEP
15139 C steps) was done on this call, before completing the
15140 C requested task, but the integration was otherwise
15141 C successful as far as T. (MXSTEP is an optional input
15142 C and is normally 500.) To continue, the user may
15143 C simply reset ISTATE to a value .gt. 1 and call again
15144 C (the excess work step counter will be reset to 0).
15145 C In addition, the user may increase MXSTEP to avoid
15146 C this error return (see below on optional inputs).
15147 C -2 means too much accuracy was requested for the precision
15148 C of the machine being used. This was detected before
15149 C completing the requested task, but the integration
15150 C was successful as far as T. To continue, the tolerance
15151 C parameters must be reset, and ISTATE must be set
15152 C to 3. The optional output TOLSF may be used for this
15153 C purpose. (Note: If this condition is detected before
15154 C taking any steps, then an illegal input return
15155 C (ISTATE = -3) occurs instead.)
15156 C -3 means illegal input was detected, before taking any
15157 C integration steps. See written message for details.
15158 C Note: If the solver detects an infinite loop of calls
15159 C to the solver with illegal input, it will cause
15160 C the run to stop.
15161 C -4 means there were repeated error test failures on
15162 C one attempted step, before completing the requested
15163 C task, but the integration was successful as far as T.
15164 C The problem may have a singularity, or the input
15165 C may be inappropriate.
15166 C -5 means there were repeated convergence test failures on
15167 C one attempted step, before completing the requested
15168 C task, but the integration was successful as far as T.
15169 C This may be caused by an inaccurate Jacobian matrix.
15170 C -6 means EWT(i) became zero for some i during the
15171 C integration. Pure relative error control (ATOL(i) = 0.0)
15172 C was requested on a variable which has now vanished.
15173 C the integration was successful as far as T.
15174 C -7 means that the user-supplied Subroutine RES set
15175 C its error flag (IRES = 3) despite repeated tries by
15176 C DLSODIS to avoid that condition.
15177 C -8 means that ISTATE was 0 on input but DLSODIS was unable
15178 C to compute the initial value of dy/dt. See the
15179 C printed message for details.
15180 C -9 means a fatal error return flag came from the sparse
15181 C solver CDRV by way of DPRJIS or DSOLSS (numerical
15182 C factorization or backsolve). This should never happen.
15183 C The integration was successful as far as T.
15184 C
15185 C Note: An error return with ISTATE = -1, -4, or -5
15186 C may mean that the sparsity structure of the
15187 C problem has changed significantly since it was last
15188 C determined (or input). In that case, one can attempt to
15189 C complete the integration by setting ISTATE = 3 on the next
15190 C call, so that a new structure determination is done.
15191 C
15192 C Note: Since the normal output value of ISTATE is 2,
15193 C it does not need to be reset for normal continuation.
15194 C similarly, ISTATE (= 3) need not be reset if RES told
15195 C DLSODIS to return because the calling program must change
15196 C the parameters of the problem.
15197 C Also, since a negative input value of ISTATE will be
15198 C regarded as illegal, a negative output value requires the
15199 C user to change it, and possibly other inputs, before
15200 C calling the solver again.
15201 C
15202 C IOPT = an integer flag to specify whether or not any optional
15203 C inputs are being used on this call. Input only.
15204 C The optional inputs are listed separately below.
15205 C IOPT = 0 means no optional inputs are being used.
15206 C Default values will be used in all cases.
15207 C IOPT = 1 means one or more optional inputs are being used.
15208 C
15209 C RWORK = a work array used for a mixture of real (double precision)
15210 C and integer work space.
15211 C The length of RWORK (in real words) must be at least
15212 C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM where
15213 C NYH = the initial value of NEQ,
15214 C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a
15215 C smaller value is given as an optional input),
15216 C LWM = 2*NNZ + 2*NEQ + (NNZ+9*NEQ)/LENRAT if MITER = 1,
15217 C LWM = 2*NNZ + 2*NEQ + (NNZ+10*NEQ)/LENRAT if MITER = 2.
15218 C in the above formulas,
15219 C NNZ = number of nonzero elements in the iteration matrix
15220 C P = A - con*J (con is a constant and J is the
15221 C Jacobian matrix dr/dy).
15222 C LENRAT = the real to integer wordlength ratio (usually 1 in
15223 C single precision and 2 in double precision).
15224 C (See the MF description for METH and MITER.)
15225 C Thus if MAXORD has its default value and NEQ is constant,
15226 C the minimum length of RWORK is:
15227 C 20 + 16*NEQ + LWM for MF = 11, 111, 311, 12, 212, 412,
15228 C 20 + 9*NEQ + LWM for MF = 21, 121, 321, 22, 222, 422.
15229 C The above formula for LWM is only a crude lower bound.
15230 C The required length of RWORK cannot be readily predicted
15231 C in general, as it depends on the sparsity structure
15232 C of the problem. Some experimentation may be necessary.
15233 C
15234 C The first 20 words of RWORK are reserved for conditional
15235 C and optional inputs and optional outputs.
15236 C
15237 C The following word in RWORK is a conditional input:
15238 C RWORK(1) = TCRIT = critical value of t which the solver
15239 C is not to overshoot. Required if ITASK is
15240 C 4 or 5, and ignored otherwise. (See ITASK.)
15241 C
15242 C LRW = the length of the array RWORK, as declared by the user.
15243 C (This will be checked by the solver.)
15244 C
15245 C IWORK = an integer work array. The length of IWORK must be at least
15246 C 32 + 2*NEQ + NZA + NZC for MOSS = 0,
15247 C 30 for MOSS = 1 or 2,
15248 C 31 + NEQ + NZA for MOSS = 3 or 4.
15249 C (NZA is the number of nonzero elements in matrix A, and
15250 C NZC is the number of nonzero elements in dr/dy.)
15251 C
15252 C In DLSODIS, IWORK is used for conditional and
15253 C optional inputs and optional outputs.
15254 C
15255 C The following two blocks of words in IWORK are conditional
15256 C inputs, required if MOSS = 0, 3, or 4, but not otherwise
15257 C (see the description of MF for MOSS).
15258 C IWORK(30+j) = IA(j) (j=1,...,NEQ+1)
15259 C IWORK(31+NEQ+k) = JA(k) (k=1,...,NZA)
15260 C The two arrays IA and JA describe the sparsity structure
15261 C to be assumed for the matrix A. JA contains the row
15262 C indices where nonzero elements occur, reading in columnwise
15263 C order, and IA contains the starting locations in JA of the
15264 C descriptions of columns 1,...,NEQ, in that order, with
15265 C IA(1) = 1. Thus, for each column index j = 1,...,NEQ, the
15266 C values of the row index i in column j where a nonzero
15267 C element may occur are given by
15268 C i = JA(k), where IA(j) .le. k .lt. IA(j+1).
15269 C If NZA is the total number of nonzero locations assumed,
15270 C then the length of the JA array is NZA, and IA(NEQ+1) must
15271 C be NZA + 1. Duplicate entries are not allowed.
15272 C The following additional blocks of words are required
15273 C if MOSS = 0, but not otherwise. If LC = 31 + NEQ + NZA, then
15274 C IWORK(LC+j) = IC(j) (j=1,...,NEQ+1), and
15275 C IWORK(LC+NEQ+1+k) = JC(k) (k=1,...,NZC)
15276 C The two arrays IC and JC describe the sparsity
15277 C structure to be assumed for the Jacobian matrix dr/dy.
15278 C They are used in the same manner as the above IA and JA
15279 C arrays. If NZC is the number of nonzero locations
15280 C assumed, then the length of the JC array is NZC, and
15281 C IC(NEQ+1) must be NZC + 1. Duplicate entries are not
15282 C allowed.
15283 C
15284 C LIW = the length of the array IWORK, as declared by the user.
15285 C (This will be checked by the solver.)
15286 C
15287 C Note: The work arrays must not be altered between calls to DLSODIS
15288 C for the same problem, except possibly for the conditional and
15289 C optional inputs, and except for the last 3*NEQ words of RWORK.
15290 C The latter space is used for internal scratch space, and so is
15291 C available for use by the user outside DLSODIS between calls, if
15292 C desired (but not for use by RES, ADDA, or JAC).
15293 C
15294 C MF = the method flag. Used only for input.
15295 C MF has three decimal digits-- MOSS, METH, and MITER.
15296 C For standard options:
15297 C MF = 100*MOSS + 10*METH + MITER.
15298 C MOSS indicates the method to be used to obtain the sparsity
15299 C structure of the Jacobian matrix:
15300 C MOSS = 0 means the user has supplied IA, JA, IC, and JC
15301 C (see descriptions under IWORK above).
15302 C MOSS = 1 means the user has supplied JAC (see below) and
15303 C the structure will be obtained from NEQ initial
15304 C calls to JAC and NEQ initial calls to ADDA.
15305 C MOSS = 2 means the structure will be obtained from NEQ+1
15306 C initial calls to RES and NEQ initial calls to ADDA
15307 C MOSS = 3 like MOSS = 1, except user has supplied IA and JA.
15308 C MOSS = 4 like MOSS = 2, except user has supplied IA and JA.
15309 C METH indicates the basic linear multistep method:
15310 C METH = 1 means the implicit Adams method.
15311 C METH = 2 means the method based on Backward
15312 C Differentiation Formulas (BDFs).
15313 C The BDF method is strongly preferred for stiff problems,
15314 C while the Adams method is preferred when the problem is
15315 C not stiff. If the matrix A(t,y) is nonsingular,
15316 C stiffness here can be taken to mean that of the explicit
15317 C ODE system dy/dt = A-inverse * g. If A is singular,
15318 C the concept of stiffness is not well defined.
15319 C If you do not know whether the problem is stiff, we
15320 C recommend using METH = 2. If it is stiff, the advantage
15321 C of METH = 2 over METH = 1 will be great, while if it is
15322 C not stiff, the advantage of METH = 1 will be slight.
15323 C If maximum efficiency is important, some experimentation
15324 C with METH may be necessary.
15325 C MITER indicates the corrector iteration method:
15326 C MITER = 1 means chord iteration with a user-supplied
15327 C sparse Jacobian, given by Subroutine JAC.
15328 C MITER = 2 means chord iteration with an internally
15329 C generated (difference quotient) sparse
15330 C Jacobian (using NGP extra calls to RES per
15331 C dr/dy value, where NGP is an optional
15332 C output described below.)
15333 C If MITER = 1 or MOSS = 1 or 3 the user must supply a
15334 C Subroutine JAC (the name is arbitrary) as described above
15335 C under JAC. Otherwise, a dummy argument can be used.
15336 C
15337 C The standard choices for MF are:
15338 C MF = 21 or 22 for a stiff problem with IA/JA and IC/JC
15339 C supplied,
15340 C MF = 121 for a stiff problem with JAC supplied, but not
15341 C IA/JA or IC/JC,
15342 C MF = 222 for a stiff problem with neither IA/JA, IC/JC/,
15343 C nor JAC supplied,
15344 C MF = 321 for a stiff problem with IA/JA and JAC supplied,
15345 C but not IC/JC,
15346 C MF = 422 for a stiff problem with IA/JA supplied, but not
15347 C IC/JC or JAC.
15348 C
15349 C The sparseness structure can be changed during the problem
15350 C by making a call to DLSODIS with ISTATE = 3.
15351 C-----------------------------------------------------------------------
15352 C Optional Inputs.
15353 C
15354 C The following is a list of the optional inputs provided for in the
15355 C call sequence. (See also Part 2.) For each such input variable,
15356 C this table lists its name as used in this documentation, its
15357 C location in the call sequence, its meaning, and the default value.
15358 C The use of any of these inputs requires IOPT = 1, and in that
15359 C case all of these inputs are examined. A value of zero for any
15360 C of these optional inputs will cause the default value to be used.
15361 C Thus to use a subset of the optional inputs, simply preload
15362 C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and
15363 C then set those of interest to nonzero values.
15364 C
15365 C Name Location Meaning and Default Value
15366 C
15367 C H0 RWORK(5) the step size to be attempted on the first step.
15368 C The default value is determined by the solver.
15369 C
15370 C HMAX RWORK(6) the maximum absolute step size allowed.
15371 C The default value is infinite.
15372 C
15373 C HMIN RWORK(7) the minimum absolute step size allowed.
15374 C The default value is 0. (This lower bound is not
15375 C enforced on the final step before reaching TCRIT
15376 C when ITASK = 4 or 5.)
15377 C
15378 C MAXORD IWORK(5) the maximum order to be allowed. The default
15379 C value is 12 if METH = 1, and 5 if METH = 2.
15380 C If MAXORD exceeds the default value, it will
15381 C be reduced to the default value.
15382 C If MAXORD is changed during the problem, it may
15383 C cause the current order to be reduced.
15384 C
15385 C MXSTEP IWORK(6) maximum number of (internally defined) steps
15386 C allowed during one call to the solver.
15387 C The default value is 500.
15388 C
15389 C MXHNIL IWORK(7) maximum number of messages printed (per problem)
15390 C warning that T + H = T on a step (H = step size).
15391 C This must be positive to result in a non-default
15392 C value. The default value is 10.
15393 C-----------------------------------------------------------------------
15394 C Optional Outputs.
15395 C
15396 C As optional additional output from DLSODIS, the variables listed
15397 C below are quantities related to the performance of DLSODIS
15398 C which are available to the user. These are communicated by way of
15399 C the work arrays, but also have internal mnemonic names as shown.
15400 C Except where stated otherwise, all of these outputs are defined
15401 C on any successful return from DLSODIS, and on any return with
15402 C ISTATE = -1, -2, -4, -5, -6, or -7. On a return with -3 (illegal
15403 C input) or -8, they will be unchanged from their existing values
15404 C (if any), except possibly for TOLSF, LENRW, and LENIW.
15405 C On any error return, outputs relevant to the error will be defined,
15406 C as noted below.
15407 C
15408 C Name Location Meaning
15409 C
15410 C HU RWORK(11) the step size in t last used (successfully).
15411 C
15412 C HCUR RWORK(12) the step size to be attempted on the next step.
15413 C
15414 C TCUR RWORK(13) the current value of the independent variable
15415 C which the solver has actually reached, i.e. the
15416 C current internal mesh point in t. On output, TCUR
15417 C will always be at least as far as the argument
15418 C T, but may be farther (if interpolation was done).
15419 C
15420 C TOLSF RWORK(14) a tolerance scale factor, greater than 1.0,
15421 C computed when a request for too much accuracy was
15422 C detected (ISTATE = -3 if detected at the start of
15423 C the problem, ISTATE = -2 otherwise). If ITOL is
15424 C left unaltered but RTOL and ATOL are uniformly
15425 C scaled up by a factor of TOLSF for the next call,
15426 C then the solver is deemed likely to succeed.
15427 C (The user may also ignore TOLSF and alter the
15428 C tolerance parameters in any other way appropriate.)
15429 C
15430 C NST IWORK(11) the number of steps taken for the problem so far.
15431 C
15432 C NRE IWORK(12) the number of residual evaluations (RES calls)
15433 C for the problem so far, excluding those for
15434 C structure determination (MOSS = 2 or 4).
15435 C
15436 C NJE IWORK(13) the number of Jacobian evaluations (each involving
15437 C an evaluation of A and dr/dy) for the problem so
15438 C far, excluding those for structure determination
15439 C (MOSS = 1 or 3). This equals the number of calls
15440 C to ADDA and (if MITER = 1) JAC.
15441 C
15442 C NQU IWORK(14) the method order last used (successfully).
15443 C
15444 C NQCUR IWORK(15) the order to be attempted on the next step.
15445 C
15446 C IMXER IWORK(16) the index of the component of largest magnitude in
15447 C the weighted local error vector ( E(i)/EWT(i) ),
15448 C on an error return with ISTATE = -4 or -5.
15449 C
15450 C LENRW IWORK(17) the length of RWORK actually required.
15451 C This is defined on normal returns and on an illegal
15452 C input return for insufficient storage.
15453 C
15454 C LENIW IWORK(18) the length of IWORK actually required.
15455 C This is defined on normal returns and on an illegal
15456 C input return for insufficient storage.
15457 C
15458 C NNZ IWORK(19) the number of nonzero elements in the iteration
15459 C matrix P = A - con*J (con is a constant and
15460 C J is the Jacobian matrix dr/dy).
15461 C
15462 C NGP IWORK(20) the number of groups of column indices, used in
15463 C difference quotient Jacobian aproximations if
15464 C MITER = 2. This is also the number of extra RES
15465 C evaluations needed for each Jacobian evaluation.
15466 C
15467 C NLU IWORK(21) the number of sparse LU decompositions for the
15468 C problem so far. (Excludes the LU decomposition
15469 C necessary when ISTATE = 0.)
15470 C
15471 C LYH IWORK(22) the base address in RWORK of the history array YH,
15472 C described below in this list.
15473 C
15474 C IPIAN IWORK(23) the base address of the structure descriptor array
15475 C IAN, described below in this list.
15476 C
15477 C IPJAN IWORK(24) the base address of the structure descriptor array
15478 C JAN, described below in this list.
15479 C
15480 C NZL IWORK(25) the number of nonzero elements in the strict lower
15481 C triangle of the LU factorization used in the chord
15482 C iteration.
15483 C
15484 C NZU IWORK(26) the number of nonzero elements in the strict upper
15485 C triangle of the LU factorization used in the chord
15486 C iteration. The total number of nonzeros in the
15487 C factorization is therefore NZL + NZU + NEQ.
15488 C
15489 C The following four arrays are segments of the RWORK array which
15490 C may also be of interest to the user as optional outputs.
15491 C For each array, the table below gives its internal name,
15492 C its base address, and its description.
15493 C For YH and ACOR, the base addresses are in RWORK (a real array).
15494 C The integer arrays IAN and JAN are to be obtained by declaring an
15495 C integer array IWK and identifying IWK(1) with RWORK(21), using either
15496 C an equivalence statement or a subroutine call. Then the base
15497 C addresses IPIAN (of IAN) and IPJAN (of JAN) in IWK are to be obtained
15498 C as optional outputs IWORK(23) and IWORK(24), respectively.
15499 C Thus IAN(1) is IWK(ipian), etc.
15500 C
15501 C Name Base Address Description
15502 C
15503 C IAN IPIAN (in IWK) structure descriptor array of size NEQ + 1.
15504 C JAN IPJAN (in IWK) structure descriptor array of size NNZ.
15505 C (see above) IAN and JAN together describe the sparsity
15506 C structure of the iteration matrix
15507 C P = A - con*J, as used by DLSODIS.
15508 C JAN contains the row indices of the nonzero
15509 C locations, reading in columnwise order, and
15510 C IAN contains the starting locations in JAN of
15511 C the descriptions of columns 1,...,NEQ, in
15512 C that order, with IAN(1) = 1. Thus for each
15513 C j = 1,...,NEQ, the row indices i of the
15514 C nonzero locations in column j are
15515 C i = JAN(k), IAN(j) .le. k .lt. IAN(j+1).
15516 C Note that IAN(NEQ+1) = NNZ + 1.
15517 C YH LYH the Nordsieck history array, of size NYH by
15518 C (optional (NQCUR + 1), where NYH is the initial value
15519 C output) of NEQ. For j = 0,1,...,NQCUR, column j+1
15520 C of YH contains HCUR**j/factorial(j) times
15521 C the j-th derivative of the interpolating
15522 C polynomial currently representing the solution,
15523 C evaluated at t = TCUR. The base address LYH
15524 C is another optional output, listed above.
15525 C
15526 C ACOR LENRW-NEQ+1 array of size NEQ used for the accumulated
15527 C corrections on each step, scaled on output to
15528 C represent the estimated local error in y on the
15529 C last step. This is the vector E in the
15530 C description of the error control. It is defined
15531 C only on a return from DLSODIS with ISTATE = 2.
15532 C
15533 C-----------------------------------------------------------------------
15534 C Part 2. Other Routines Callable.
15535 C
15536 C The following are optional calls which the user may make to
15537 C gain additional capabilities in conjunction with DLSODIS.
15538 C (The routines XSETUN and XSETF are designed to conform to the
15539 C SLATEC error handling package.)
15540 C
15541 C Form of Call Function
15542 C CALL XSETUN(LUN) Set the logical unit number, LUN, for
15543 C output of messages from DLSODIS, if
15544 C The default is not desired.
15545 C The default value of LUN is 6.
15546 C
15547 C CALL XSETF(MFLAG) Set a flag to control the printing of
15548 C messages by DLSODIS.
15549 C MFLAG = 0 means do not print. (Danger:
15550 C This risks losing valuable information.)
15551 C MFLAG = 1 means print (the default).
15552 C
15553 C Either of the above calls may be made at
15554 C any time and will take effect immediately.
15555 C
15556 C CALL DSRCMS(RSAV,ISAV,JOB) saves and restores the contents of
15557 C the internal Common blocks used by
15558 C DLSODIS (see Part 3 below).
15559 C RSAV must be a real array of length 224
15560 C or more, and ISAV must be an integer
15561 C array of length 71 or more.
15562 C JOB=1 means save Common into RSAV/ISAV.
15563 C JOB=2 means restore Common from RSAV/ISAV.
15564 C DSRCMS is useful if one is
15565 C interrupting a run and restarting
15566 C later, or alternating between two or
15567 C more problems solved with DLSODIS.
15568 C
15569 C CALL DINTDY(,,,,,) Provide derivatives of y, of various
15570 C (see below) orders, at a specified point t, if
15571 C desired. It may be called only after
15572 C a successful return from DLSODIS.
15573 C
15574 C The detailed instructions for using DINTDY are as follows.
15575 C The form of the call is:
15576 C
15577 C LYH = IWORK(22)
15578 C CALL DINTDY (T, K, RWORK(LYH), NYH, DKY, IFLAG)
15579 C
15580 C The input parameters are:
15581 C
15582 C T = value of independent variable where answers are desired
15583 C (normally the same as the T last returned by DLSODIS).
15584 C For valid results, T must lie between TCUR - HU and TCUR.
15585 C (See optional outputs for TCUR and HU.)
15586 C K = integer order of the derivative desired. K must satisfy
15587 C 0 .le. K .le. NQCUR, where NQCUR is the current order
15588 C (see optional outputs). The capability corresponding
15589 C to K = 0, i.e. computing y(t), is already provided
15590 C by DLSODIS directly. Since NQCUR .ge. 1, the first
15591 C derivative dy/dt is always available with DINTDY.
15592 C LYH = the base address of the history array YH, obtained
15593 C as an optional output as shown above.
15594 C NYH = column length of YH, equal to the initial value of NEQ.
15595 C
15596 C The output parameters are:
15597 C
15598 C DKY = a real array of length NEQ containing the computed value
15599 C of the K-th derivative of y(t).
15600 C IFLAG = integer flag, returned as 0 if K and T were legal,
15601 C -1 if K was illegal, and -2 if T was illegal.
15602 C On an error return, a message is also written.
15603 C-----------------------------------------------------------------------
15604 C Part 3. Common Blocks.
15605 C
15606 C If DLSODIS is to be used in an overlay situation, the user
15607 C must declare, in the primary overlay, the variables in:
15608 C (1) the call sequence to DLSODIS, and
15609 C (2) the two internal Common blocks
15610 C /DLS001/ of length 255 (218 double precision words
15611 C followed by 37 integer words),
15612 C /DLSS01/ of length 40 (6 double precision words
15613 C followed by 34 integer words).
15614 C
15615 C If DLSODIS is used on a system in which the contents of internal
15616 C Common blocks are not preserved between calls, the user should
15617 C declare the above Common blocks in the calling program to insure
15618 C that their contents are preserved.
15619 C
15620 C If the solution of a given problem by DLSODIS is to be interrupted
15621 C and then later continued, such as when restarting an interrupted run
15622 C or alternating between two or more problems, the user should save,
15623 C following the return from the last DLSODIS call prior to the
15624 C interruption, the contents of the call sequence variables and the
15625 C internal Common blocks, and later restore these values before the
15626 C next DLSODIS call for that problem. To save and restore the Common
15627 C blocks, use Subroutines DSRCMS (see Part 2 above).
15628 C
15629 C-----------------------------------------------------------------------
15630 C Part 4. Optionally Replaceable Solver Routines.
15631 C
15632 C Below are descriptions of two routines in the DLSODIS package which
15633 C relate to the measurement of errors. Either routine can be
15634 C replaced by a user-supplied version, if desired. However, since such
15635 C a replacement may have a major impact on performance, it should be
15636 C done only when absolutely necessary, and only with great caution.
15637 C (Note: The means by which the package version of a routine is
15638 C superseded by the user's version may be system-dependent.)
15639 C
15640 C (a) DEWSET.
15641 C The following subroutine is called just before each internal
15642 C integration step, and sets the array of error weights, EWT, as
15643 C described under ITOL/RTOL/ATOL above:
15644 C SUBROUTINE DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT)
15645 C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODIS call sequence,
15646 C YCUR contains the current dependent variable vector, and
15647 C EWT is the array of weights set by DEWSET.
15648 C
15649 C If the user supplies this subroutine, it must return in EWT(i)
15650 C (i = 1,...,NEQ) a positive quantity suitable for comparing errors
15651 C in y(i) to. The EWT array returned by DEWSET is passed to the DVNORM
15652 C routine (see below), and also used by DLSODIS in the computation
15653 C of the optional output IMXER, and the increments for difference
15654 C quotient Jacobians.
15655 C
15656 C In the user-supplied version of DEWSET, it may be desirable to use
15657 C the current values of derivatives of y. Derivatives up to order NQ
15658 C are available from the history array YH, described above under
15659 C optional outputs. In DEWSET, YH is identical to the YCUR array,
15660 C extended to NQ + 1 columns with a column length of NYH and scale
15661 C factors of H**j/factorial(j). On the first call for the problem,
15662 C given by NST = 0, NQ is 1 and H is temporarily set to 1.0.
15663 C NYH is the initial value of NEQ. The quantities NQ, H, and NST
15664 C can be obtained by including in DEWSET the statements:
15665 C DOUBLE PRECISION RLS
15666 C COMMON /DLS001/ RLS(218),ILS(37)
15667 C NQ = ILS(33)
15668 C NST = ILS(34)
15669 C H = RLS(212)
15670 C Thus, for example, the current value of dy/dt can be obtained as
15671 C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is
15672 C unnecessary when NST = 0).
15673 C
15674 C (b) DVNORM.
15675 C The following is a real function routine which computes the weighted
15676 C root-mean-square norm of a vector v:
15677 C D = DVNORM (N, V, W)
15678 C where:
15679 C N = the length of the vector,
15680 C V = real array of length N containing the vector,
15681 C W = real array of length N containing weights,
15682 C D = SQRT( (1/N) * sum(V(i)*W(i))**2 ).
15683 C DVNORM is called with N = NEQ and with W(i) = 1.0/EWT(i), where
15684 C EWT is as set by Subroutine DEWSET.
15685 C
15686 C If the user supplies this function, it should return a non-negative
15687 C value of DVNORM suitable for use in the error control in DLSODIS.
15688 C None of the arguments should be altered by DVNORM.
15689 C For example, a user-supplied DVNORM routine might:
15690 C -substitute a max-norm of (V(i)*w(I)) for the RMS-norm, or
15691 C -ignore some components of V in the norm, with the effect of
15692 C suppressing the error control on those components of y.
15693 C-----------------------------------------------------------------------
15694 C
15695 C***REVISION HISTORY (YYYYMMDD)
15696 C 19820714 DATE WRITTEN
15697 C 19830812 Major update, based on recent LSODI and LSODES revisions:
15698 C Upgraded MDI in ODRV package: operates on M + M-transpose.
15699 C Numerous revisions in use of work arrays;
15700 C use wordlength ratio LENRAT; added IPISP & LRAT to Common;
15701 C added optional outputs IPIAN/IPJAN;
15702 C Added routine CNTNZU; added NZL and NZU to /LSS001/;
15703 C changed ADJLR call logic; added optional outputs NZL & NZU;
15704 C revised counter initializations; revised PREPI stmt. nos.;
15705 C revised difference quotient increment;
15706 C eliminated block /LSI001/, using IERPJ flag;
15707 C revised STODI logic after PJAC return;
15708 C revised tuning of H change and step attempts in STODI;
15709 C corrections to main prologue and comments throughout.
15710 C 19870320 Corrected jump on test of umax in CDRV routine.
15711 C 20010125 Numerous revisions: corrected comments throughout;
15712 C removed TRET from Common; rewrote EWSET with 4 loops;
15713 C fixed t test in INTDY; added Cray directives in STODI;
15714 C in STODI, fixed DELP init. and logic around PJAC call;
15715 C combined routines to save/restore Common;
15716 C passed LEVEL = 0 in error message calls (except run abort).
15717 C 20010425 Major update: convert source lines to upper case;
15718 C added *DECK lines; changed from 1 to * in dummy dimensions;
15719 C changed names R1MACH/D1MACH to RUMACH/DUMACH;
15720 C renamed routines for uniqueness across single/double prec.;
15721 C converted intrinsic names to generic form;
15722 C removed ILLIN and NTREP (data loaded) from Common;
15723 C removed all 'own' variables from Common;
15724 C changed error messages to quoted strings;
15725 C replaced XERRWV/XERRWD with 1993 revised version;
15726 C converted prologues, comments, error messages to mixed case;
15727 C converted arithmetic IF statements to logical IF statements;
15728 C numerous corrections to prologues and internal comments.
15729 C 20010507 Converted single precision source to double precision.
15730 C 20020502 Corrected declarations in descriptions of user routines.
15731 C 20031021 Fixed address offset bugs in Subroutine DPREPI.
15732 C 20031027 Changed 0. to 0.0D0 in Subroutine DPREPI.
15733 C 20031105 Restored 'own' variables to Common blocks, to enable
15734 C interrupt/restart feature.
15735 C 20031112 Added SAVE statements for data-loaded constants.
15736 C 20031117 Changed internal names NRE, LSAVR to NFE, LSAVF resp.
15737 C
15738 C-----------------------------------------------------------------------
15739 C Other routines in the DLSODIS package.
15740 C
15741 C In addition to Subroutine DLSODIS, the DLSODIS package includes the
15742 C following subroutines and function routines:
15743 C DIPREPI acts as an interface between DLSODIS and DPREPI, and also
15744 C does adjusting of work space pointers and work arrays.
15745 C DPREPI is called by DIPREPI to compute sparsity and do sparse
15746 C matrix preprocessing.
15747 C DAINVGS computes the initial value of the vector
15748 C dy/dt = A-inverse * g
15749 C ADJLR adjusts the length of required sparse matrix work space.
15750 C It is called by DPREPI.
15751 C CNTNZU is called by DPREPI and counts the nonzero elements in the
15752 C strict upper triangle of P + P-transpose.
15753 C JGROUP is called by DPREPI to compute groups of Jacobian column
15754 C indices for use when MITER = 2.
15755 C DINTDY computes an interpolated value of the y vector at t = TOUT.
15756 C DSTODI is the core integrator, which does one step of the
15757 C integration and the associated error control.
15758 C DCFODE sets all method coefficients and test constants.
15759 C DPRJIS computes and preprocesses the Jacobian matrix J = dr/dy
15760 C and the Newton iteration matrix P = A - h*l0*J.
15761 C DSOLSS manages solution of linear system in chord iteration.
15762 C DEWSET sets the error weight vector EWT before each step.
15763 C DVNORM computes the weighted RMS-norm of a vector.
15764 C DSRCMS is a user-callable routine to save and restore
15765 C the contents of the internal Common blocks.
15766 C ODRV constructs a reordering of the rows and columns of
15767 C a matrix by the minimum degree algorithm. ODRV is a
15768 C driver routine which calls Subroutines MD, MDI, MDM,
15769 C MDP, MDU, and SRO. See Ref. 2 for details. (The ODRV
15770 C module has been modified since Ref. 2, however.)
15771 C CDRV performs reordering, symbolic factorization, numerical
15772 C factorization, or linear system solution operations,
15773 C depending on a path argument IPATH. CDRV is a
15774 C driver routine which calls Subroutines NROC, NSFC,
15775 C NNFC, NNSC, and NNTC. See Ref. 3 for details.
15776 C DLSODIS uses CDRV to solve linear systems in which the
15777 C coefficient matrix is P = A - con*J, where A is the
15778 C matrix for the linear system A(t,y)*dy/dt = g(t,y),
15779 C con is a scalar, and J is an approximation to
15780 C the Jacobian dr/dy. Because CDRV deals with rowwise
15781 C sparsity descriptions, CDRV works with P-transpose, not P.
15782 C DLSODIS also uses CDRV to solve the linear system
15783 C A(t,y)*dy/dt = g(t,y) for dy/dt when ISTATE = 0.
15784 C (For this, CDRV works with A-transpose, not A.)
15785 C DUMACH computes the unit roundoff in a machine-independent manner.
15786 C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all
15787 C error messages and warnings. XERRWD is machine-dependent.
15788 C Note: DVNORM, DUMACH, IXSAV, and IUMACH are function routines.
15789 C All the others are subroutines.
15790 C
15791 C-----------------------------------------------------------------------
15792  EXTERNAL dprjis, dsolss
15793  DOUBLE PRECISION dumach, dvnorm
15794  INTEGER init, mxstep, mxhnil, nhnil, nslast, nyh, iowns,
15795  1 icf, ierpj, iersl, jcur, jstart, kflag, l,
15796  2 lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
15797  3 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
15798  INTEGER iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp,
15799  1 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa,
15800  2 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj,
15801  3 nslj, ngp, nlu, nnz, nsp, nzl, nzu
15802  INTEGER i, i1, i2, ier, igo, iflag, imax, imul, imxer, ipflag,
15803  1 ipgo, irem, ires, j, kgo, lenrat, lenyht, leniw, lenrw,
15804  2 lia, lic, lja, ljc, lrtem, lwtem, lyd0, lyhd, lyhn, mf1,
15805  3 mord, mxhnl0, mxstp0, ncolm
15806  DOUBLE PRECISION rowns,
15807  1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
15808  DOUBLE PRECISION con0, conmin, ccmxj, psmall, rbig, seth
15809  DOUBLE PRECISION atoli, ayi, big, ewti, h0, hmax, hmx, rh, rtoli,
15810  1 tcrit, tdist, tnext, tol, tolsf, tp, SIZE, sum, w0
15811  dimension mord(2)
15812  LOGICAL ihit
15813  CHARACTER*60 msg
15814  SAVE lenrat, mord, mxstp0, mxhnl0
15815 C-----------------------------------------------------------------------
15816 C The following two internal Common blocks contain
15817 C (a) variables which are local to any subroutine but whose values must
15818 C be preserved between calls to the routine ("own" variables), and
15819 C (b) variables which are communicated between subroutines.
15820 C The block DLS001 is declared in subroutines DLSODIS, DIPREPI, DPREPI,
15821 C DINTDY, DSTODI, DPRJIS, and DSOLSS.
15822 C The block DLSS01 is declared in subroutines DLSODIS, DAINVGS,
15823 C DIPREPI, DPREPI, DPRJIS, and DSOLSS.
15824 C Groups of variables are replaced by dummy arrays in the Common
15825 C declarations in routines where those variables are not used.
15826 C-----------------------------------------------------------------------
15827  COMMON /dls001/ rowns(209),
15828  1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
15829  2 init, mxstep, mxhnil, nhnil, nslast, nyh, iowns(6),
15830  3 icf, ierpj, iersl, jcur, jstart, kflag, l,
15831  4 lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
15832  5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
15833 C
15834  COMMON /dlss01/ con0, conmin, ccmxj, psmall, rbig, seth,
15835  1 iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp,
15836  2 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa,
15837  3 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj,
15838  4 nslj, ngp, nlu, nnz, nsp, nzl, nzu
15839 C
15840  DATA mord(1),mord(2)/12,5/, mxstp0/500/, mxhnl0/10/
15841 C-----------------------------------------------------------------------
15842 C In the Data statement below, set LENRAT equal to the ratio of
15843 C the wordlength for a real number to that for an integer. Usually,
15844 C LENRAT = 1 for single precision and 2 for double precision. If the
15845 C true ratio is not an integer, use the next smaller integer (.ge. 1),
15846 C-----------------------------------------------------------------------
15847  DATA lenrat/2/
15848 C-----------------------------------------------------------------------
15849 C Block A.
15850 C This code block is executed on every call.
15851 C It tests ISTATE and ITASK for legality and branches appropirately.
15852 C If ISTATE .gt. 1 but the flag INIT shows that initialization has
15853 C not yet been done, an error return occurs.
15854 C If ISTATE = 0 or 1 and TOUT = T, return immediately.
15855 C-----------------------------------------------------------------------
15856  IF (istate .LT. 0 .OR. istate .GT. 3) GO TO 601
15857  IF (itask .LT. 1 .OR. itask .GT. 5) GO TO 602
15858  IF (istate .LE. 1) GO TO 10
15859  IF (init .EQ. 0) GO TO 603
15860  IF (istate .EQ. 2) GO TO 200
15861  GO TO 20
15862  10 init = 0
15863  IF (tout .EQ. t) RETURN
15864 C-----------------------------------------------------------------------
15865 C Block B.
15866 C The next code block is executed for the initial call (ISTATE = 0 or 1)
15867 C or for a continuation call with parameter changes (ISTATE = 3).
15868 C It contains checking of all inputs and various initializations.
15869 C If ISTATE = 0 or 1, the final setting of work space pointers, the
15870 C matrix preprocessing, and other initializations are done in Block C.
15871 C
15872 C First check legality of the non-optional inputs NEQ, ITOL, IOPT, and
15873 C MF.
15874 C-----------------------------------------------------------------------
15875  20 IF (neq(1) .LE. 0) GO TO 604
15876  IF (istate .LE. 1) GO TO 25
15877  IF (neq(1) .GT. n) GO TO 605
15878  25 n = neq(1)
15879  IF (itol .LT. 1 .OR. itol .GT. 4) GO TO 606
15880  IF (iopt .LT. 0 .OR. iopt .GT. 1) GO TO 607
15881  moss = mf/100
15882  mf1 = mf - 100*moss
15883  meth = mf1/10
15884  miter = mf1 - 10*meth
15885  IF (moss .LT. 0 .OR. moss .GT. 4) GO TO 608
15886  IF (miter .EQ. 2 .AND. moss .EQ. 1) moss = moss + 1
15887  IF (miter .EQ. 2 .AND. moss .EQ. 3) moss = moss + 1
15888  IF (miter .EQ. 1 .AND. moss .EQ. 2) moss = moss - 1
15889  IF (miter .EQ. 1 .AND. moss .EQ. 4) moss = moss - 1
15890  IF (meth .LT. 1 .OR. meth .GT. 2) GO TO 608
15891  IF (miter .LT. 1 .OR. miter .GT. 2) GO TO 608
15892 C Next process and check the optional inputs. --------------------------
15893  IF (iopt .EQ. 1) GO TO 40
15894  maxord = mord(meth)
15895  mxstep = mxstp0
15896  mxhnil = mxhnl0
15897  IF (istate .LE. 1) h0 = 0.0d0
15898  hmxi = 0.0d0
15899  hmin = 0.0d0
15900  GO TO 60
15901  40 maxord = iwork(5)
15902  IF (maxord .LT. 0) GO TO 611
15903  IF (maxord .EQ. 0) maxord = 100
15904  maxord = min(maxord,mord(meth))
15905  mxstep = iwork(6)
15906  IF (mxstep .LT. 0) GO TO 612
15907  IF (mxstep .EQ. 0) mxstep = mxstp0
15908  mxhnil = iwork(7)
15909  IF (mxhnil .LT. 0) GO TO 613
15910  IF (mxhnil .EQ. 0) mxhnil = mxhnl0
15911  IF (istate .GT. 1) GO TO 50
15912  h0 = rwork(5)
15913  IF ((tout - t)*h0 .LT. 0.0d0) GO TO 614
15914  50 hmax = rwork(6)
15915  IF (hmax .LT. 0.0d0) GO TO 615
15916  hmxi = 0.0d0
15917  IF (hmax .GT. 0.0d0) hmxi = 1.0d0/hmax
15918  hmin = rwork(7)
15919  IF (hmin .LT. 0.0d0) GO TO 616
15920 C Check RTOL and ATOL for legality. ------------------------------------
15921  60 rtoli = rtol(1)
15922  atoli = atol(1)
15923  DO 65 i = 1,n
15924  IF (itol .GE. 3) rtoli = rtol(i)
15925  IF (itol .EQ. 2 .OR. itol .EQ. 4) atoli = atol(i)
15926  IF (rtoli .LT. 0.0d0) GO TO 619
15927  IF (atoli .LT. 0.0d0) GO TO 620
15928  65 CONTINUE
15929 C-----------------------------------------------------------------------
15930 C Compute required work array lengths, as far as possible, and test
15931 C these against LRW and LIW. Then set tentative pointers for work
15932 C arrays. Pointers to RWORK/IWORK segments are named by prefixing L to
15933 C the name of the segment. E.g., the segment YH starts at RWORK(LYH).
15934 C Segments of RWORK (in order) are denoted WM, YH, SAVR, EWT, ACOR.
15935 C The required length of the matrix work space WM is not yet known,
15936 C and so a crude minimum value is used for the initial tests of LRW
15937 C and LIW, and YH is temporarily stored as far to the right in RWORK
15938 C as possible, to leave the maximum amount of space for WM for matrix
15939 C preprocessing. Thus if MOSS .ne. 2 or 4, some of the segments of
15940 C RWORK are temporarily omitted, as they are not needed in the
15941 C preprocessing. These omitted segments are: ACOR if ISTATE = 1,
15942 C EWT and ACOR if ISTATE = 3 and MOSS = 1, and SAVR, EWT, and ACOR if
15943 C ISTATE = 3 and MOSS = 0.
15944 C-----------------------------------------------------------------------
15945  lrat = lenrat
15946  IF (istate .LE. 1) nyh = n
15947  IF (miter .EQ. 1) lwmin = 4*n + 10*n/lrat
15948  IF (miter .EQ. 2) lwmin = 4*n + 11*n/lrat
15949  lenyh = (maxord+1)*nyh
15950  lrest = lenyh + 3*n
15951  lenrw = 20 + lwmin + lrest
15952  iwork(17) = lenrw
15953  leniw = 30
15954  IF (moss .NE. 1 .AND. moss .NE. 2) leniw = leniw + n + 1
15955  iwork(18) = leniw
15956  IF (lenrw .GT. lrw) GO TO 617
15957  IF (leniw .GT. liw) GO TO 618
15958  lia = 31
15959  IF (moss .NE. 1 .AND. moss .NE. 2)
15960  1 leniw = leniw + iwork(lia+n) - 1
15961  iwork(18) = leniw
15962  IF (leniw .GT. liw) GO TO 618
15963  lja = lia + n + 1
15964  lia = min(lia,liw)
15965  lja = min(lja,liw)
15966  lic = leniw + 1
15967  IF (moss .EQ. 0) leniw = leniw + n + 1
15968  iwork(18) = leniw
15969  IF (leniw .GT. liw) GO TO 618
15970  IF (moss .EQ. 0) leniw = leniw + iwork(lic+n) - 1
15971  iwork(18) = leniw
15972  IF (leniw .GT. liw) GO TO 618
15973  ljc = lic + n + 1
15974  lic = min(lic,liw)
15975  ljc = min(ljc,liw)
15976  lwm = 21
15977  IF (istate .LE. 1) nq = istate
15978  ncolm = min(nq+1,maxord+2)
15979  lenyhm = ncolm*nyh
15980  lenyht = lenyhm
15981  imul = 2
15982  IF (istate .EQ. 3) imul = moss
15983  IF (istate .EQ. 3 .AND. moss .EQ. 3) imul = 1
15984  IF (moss .EQ. 2 .OR. moss .EQ. 4) imul = 3
15985  lrtem = lenyht + imul*n
15986  lwtem = lrw - 20 - lrtem
15987  lenwk = lwtem
15988  lyhn = lwm + lwtem
15989  lsavf = lyhn + lenyht
15990  lewt = lsavf + n
15991  lacor = lewt + n
15992  istatc = istate
15993  IF (istate .LE. 1) GO TO 100
15994 C-----------------------------------------------------------------------
15995 C ISTATE = 3. Move YH to its new location.
15996 C Note that only the part of YH needed for the next step, namely
15997 C MIN(NQ+1,MAXORD+2) columns, is actually moved.
15998 C A temporary error weight array EWT is loaded if MOSS = 2 or 4.
15999 C Sparse matrix processing is done in DIPREPI/DPREPI.
16000 C If MAXORD was reduced below NQ, then the pointers are finally set
16001 C so that SAVR is identical to (YH*,MAXORD+2)
16002 C-----------------------------------------------------------------------
16003  lyhd = lyh - lyhn
16004  imax = lyhn - 1 + lenyhm
16005 C Move YH. Move right if LYHD < 0; move left if LYHD > 0. -------------
16006  IF (lyhd .LT. 0) THEN
16007  DO 72 i = lyhn,imax
16008  j = imax + lyhn - i
16009  72 rwork(j) = rwork(j+lyhd)
16010  ENDIF
16011  IF (lyhd .GT. 0) THEN
16012  DO 76 i = lyhn,imax
16013  76 rwork(i) = rwork(i+lyhd)
16014  ENDIF
16015  80 lyh = lyhn
16016  iwork(22) = lyh
16017  IF (moss .NE. 2 .AND. moss .NE. 4) GO TO 85
16018 C Temporarily load EWT if MOSS = 2 or 4.
16019  CALL dewset (n,itol,rtol,atol,rwork(lyh),rwork(lewt))
16020  DO 82 i = 1,n
16021  IF (rwork(i+lewt-1) .LE. 0.0d0) GO TO 621
16022  82 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1)
16023  85 CONTINUE
16024 C DIPREPI and DPREPI do sparse matrix preprocessing. -------------------
16025  lsavf = min(lsavf,lrw)
16026  lewt = min(lewt,lrw)
16027  lacor = min(lacor,lrw)
16028  CALL diprepi (neq, y, ydoti, rwork, iwork(lia), iwork(lja),
16029  1 iwork(lic), iwork(ljc), ipflag, res, jac, adda)
16030  lenrw = lwm - 1 + lenwk + lrest
16031  iwork(17) = lenrw
16032  IF (ipflag .NE. -1) iwork(23) = ipian
16033  IF (ipflag .NE. -1) iwork(24) = ipjan
16034  ipgo = -ipflag + 1
16035  GO TO (90, 628, 629, 630, 631, 632, 633, 634, 634), ipgo
16036  90 iwork(22) = lyh
16037  lyd0 = lyh + n
16038  IF (lenrw .GT. lrw) GO TO 617
16039 C Set flag to signal changes to DSTODI.---------------------------------
16040  jstart = -1
16041  IF (nq .LE. maxord) GO TO 94
16042 C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into YDOTI. --------
16043  DO 92 i = 1,n
16044  92 ydoti(i) = rwork(i+lsavf-1)
16045  94 IF (n .EQ. nyh) GO TO 200
16046 C NEQ was reduced. Zero part of YH to avoid undefined references. -----
16047  i1 = lyh + l*nyh
16048  i2 = lyh + (maxord + 1)*nyh - 1
16049  IF (i1 .GT. i2) GO TO 200
16050  DO 95 i = i1,i2
16051  95 rwork(i) = 0.0d0
16052  GO TO 200
16053 C-----------------------------------------------------------------------
16054 C Block C.
16055 C The next block is for the initial call only (ISTATE = 0 or 1).
16056 C It contains all remaining initializations, the call to DAINVGS
16057 C (if ISTATE = 0), the sparse matrix preprocessing, and the
16058 C calculation if the initial step size.
16059 C The error weights in EWT are inverted after being loaded.
16060 C-----------------------------------------------------------------------
16061  100 CONTINUE
16062  lyh = lyhn
16063  iwork(22) = lyh
16064  tn = t
16065  nst = 0
16066  nfe = 0
16067  h = 1.0d0
16068  nnz = 0
16069  ngp = 0
16070  nzl = 0
16071  nzu = 0
16072 C Load the initial value vector in YH.----------------------------------
16073  DO 105 i = 1,n
16074  105 rwork(i+lyh-1) = y(i)
16075  IF (istate .NE. 1) GO TO 108
16076 C Initial dy/dt was supplied. Load it into YH (LYD0 points to YH(*,2).)
16077  lyd0 = lyh + nyh
16078  DO 106 i = 1,n
16079  106 rwork(i+lyd0-1) = ydoti(i)
16080  108 CONTINUE
16081 C Load and invert the EWT array. (H is temporarily set to 1.0.)--------
16082  CALL dewset (n,itol,rtol,atol,rwork(lyh),rwork(lewt))
16083  DO 110 i = 1,n
16084  IF (rwork(i+lewt-1) .LE. 0.0d0) GO TO 621
16085  110 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1)
16086 C Call DIPREPI and DPREPI to do sparse matrix preprocessing.------------
16087  lacor = min(lacor,lrw)
16088  CALL diprepi (neq, y, ydoti, rwork, iwork(lia), iwork(lja),
16089  1 iwork(lic), iwork(ljc), ipflag, res, jac, adda)
16090  lenrw = lwm - 1 + lenwk + lrest
16091  iwork(17) = lenrw
16092  IF (ipflag .NE. -1) iwork(23) = ipian
16093  IF (ipflag .NE. -1) iwork(24) = ipjan
16094  ipgo = -ipflag + 1
16095  GO TO (115, 628, 629, 630, 631, 632, 633, 634, 634), ipgo
16096  115 iwork(22) = lyh
16097  IF (lenrw .GT. lrw) GO TO 617
16098 C Compute initial dy/dt, if necessary, and load it into YH.-------------
16099  lyd0 = lyh + n
16100  IF (istate .NE. 0) GO TO 120
16101  CALL dainvgs (neq, t, y, rwork(lwm), rwork(lwm), rwork(lacor),
16102  1 rwork(lyd0), ier, res, adda)
16103  nfe = nfe + 1
16104  igo = ier + 1
16105  GO TO (120, 565, 560, 560), igo
16106 C Check TCRIT for legality (ITASK = 4 or 5). ---------------------------
16107  120 CONTINUE
16108  IF (itask .NE. 4 .AND. itask .NE. 5) GO TO 125
16109  tcrit = rwork(1)
16110  IF ((tcrit - tout)*(tout - t) .LT. 0.0d0) GO TO 625
16111  IF (h0 .NE. 0.0d0 .AND. (t + h0 - tcrit)*h0 .GT. 0.0d0)
16112  1 h0 = tcrit - t
16113 C Initialize all remaining parameters. ---------------------------------
16114  125 uround = dumach()
16115  jstart = 0
16116  rwork(lwm) = sqrt(uround)
16117  nhnil = 0
16118  nje = 0
16119  nlu = 0
16120  nslast = 0
16121  hu = 0.0d0
16122  nqu = 0
16123  ccmax = 0.3d0
16124  maxcor = 3
16125  msbp = 20
16126  mxncf = 10
16127 C-----------------------------------------------------------------------
16128 C The coding below computes the step size, H0, to be attempted on the
16129 C first step, unless the user has supplied a value for this.
16130 C First check that TOUT - T differs significantly from zero.
16131 C A scalar tolerance quantity TOL is computed, as MAX(RTOL(i))
16132 C if this is positive, or MAX(ATOL(i)/ABS(Y(i))) otherwise, adjusted
16133 C so as to be between 100*UROUND and 1.0E-3.
16134 C Then the computed value H0 is given by..
16135 C NEQ
16136 C H0**2 = TOL / ( w0**-2 + (1/NEQ) * Sum ( YDOT(i)/ywt(i) )**2 )
16137 C 1
16138 C where w0 = MAX ( ABS(T), ABS(TOUT) ),
16139 C YDOT(i) = i-th component of initial value of dy/dt,
16140 C ywt(i) = EWT(i)/TOL (a weight for y(i)).
16141 C The sign of H0 is inferred from the initial values of TOUT and T.
16142 C-----------------------------------------------------------------------
16143  IF (h0 .NE. 0.0d0) GO TO 180
16144  tdist = abs(tout - t)
16145  w0 = max(abs(t),abs(tout))
16146  IF (tdist .LT. 2.0d0*uround*w0) GO TO 622
16147  tol = rtol(1)
16148  IF (itol .LE. 2) GO TO 145
16149  DO 140 i = 1,n
16150  140 tol = max(tol,rtol(i))
16151  145 IF (tol .GT. 0.0d0) GO TO 160
16152  atoli = atol(1)
16153  DO 150 i = 1,n
16154  IF (itol .EQ. 2 .OR. itol .EQ. 4) atoli = atol(i)
16155  ayi = abs(y(i))
16156  IF (ayi .NE. 0.0d0) tol = max(tol,atoli/ayi)
16157  150 CONTINUE
16158  160 tol = max(tol,100.0d0*uround)
16159  tol = min(tol,0.001d0)
16160  sum = dvnorm(n, rwork(lyd0), rwork(lewt))
16161  sum = 1.0d0/(tol*w0*w0) + tol*sum**2
16162  h0 = 1.0d0/sqrt(sum)
16163  h0 = min(h0,tdist)
16164  h0 = sign(h0,tout-t)
16165 C Adjust H0 if necessary to meet HMAX bound. ---------------------------
16166  180 rh = abs(h0)*hmxi
16167  IF (rh .GT. 1.0d0) h0 = h0/rh
16168 C Load H with H0 and scale YH(*,2) by H0. ------------------------------
16169  h = h0
16170  DO 190 i = 1,n
16171  190 rwork(i+lyd0-1) = h0*rwork(i+lyd0-1)
16172  GO TO 270
16173 C-----------------------------------------------------------------------
16174 C Block D.
16175 C The next code block is for continuation calls only (ISTATE = 2 or 3)
16176 C and is to check stop conditions before taking a step.
16177 C-----------------------------------------------------------------------
16178  200 nslast = nst
16179  GO TO (210, 250, 220, 230, 240), itask
16180  210 IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
16181  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
16182  IF (iflag .NE. 0) GO TO 627
16183  t = tout
16184  GO TO 420
16185  220 tp = tn - hu*(1.0d0 + 100.0d0*uround)
16186  IF ((tp - tout)*h .GT. 0.0d0) GO TO 623
16187  IF ((tn - tout)*h .LT. 0.0d0) GO TO 250
16188  GO TO 400
16189  230 tcrit = rwork(1)
16190  IF ((tn - tcrit)*h .GT. 0.0d0) GO TO 624
16191  IF ((tcrit - tout)*h .LT. 0.0d0) GO TO 625
16192  IF ((tn - tout)*h .LT. 0.0d0) GO TO 245
16193  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
16194  IF (iflag .NE. 0) GO TO 627
16195  t = tout
16196  GO TO 420
16197  240 tcrit = rwork(1)
16198  IF ((tn - tcrit)*h .GT. 0.0d0) GO TO 624
16199  245 hmx = abs(tn) + abs(h)
16200  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
16201  IF (ihit) GO TO 400
16202  tnext = tn + h*(1.0d0 + 4.0d0*uround)
16203  IF ((tnext - tcrit)*h .LE. 0.0d0) GO TO 250
16204  h = (tcrit - tn)*(1.0d0 - 4.0d0*uround)
16205  IF (istate .EQ. 2) jstart = -2
16206 C-----------------------------------------------------------------------
16207 C Block E.
16208 C The next block is normally executed for all calls and contains
16209 C the call to the one-step core integrator DSTODI.
16210 C
16211 C This is a looping point for the integration steps.
16212 C
16213 C First check for too many steps being taken, update EWT (if not at
16214 C start of problem), check for too much accuracy being requested, and
16215 C check for H below the roundoff level in T.
16216 C-----------------------------------------------------------------------
16217  250 CONTINUE
16218  IF ((nst-nslast) .GE. mxstep) GO TO 500
16219  CALL dewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt))
16220  DO 260 i = 1,n
16221  IF (rwork(i+lewt-1) .LE. 0.0d0) GO TO 510
16222  260 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1)
16223  270 tolsf = uround*dvnorm(n, rwork(lyh), rwork(lewt))
16224  IF (tolsf .LE. 1.0d0) GO TO 280
16225  tolsf = tolsf*2.0d0
16226  IF (nst .EQ. 0) GO TO 626
16227  GO TO 520
16228  280 IF ((tn + h) .NE. tn) GO TO 290
16229  nhnil = nhnil + 1
16230  IF (nhnil .GT. mxhnil) GO TO 290
16231  msg = 'DLSODIS- Warning..Internal T (=R1) and H (=R2) are'
16232  CALL xerrwd (msg, 50, 101, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16233  msg=' such that in the machine, T + H = T on the next step '
16234  CALL xerrwd (msg, 60, 101, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16235  msg = ' (H = step size). Solver will continue anyway.'
16236  CALL xerrwd (msg, 50, 101, 0, 0, 0, 0, 2, tn, h)
16237  IF (nhnil .LT. mxhnil) GO TO 290
16238  msg = 'DLSODIS- Above warning has been issued I1 times. '
16239  CALL xerrwd (msg, 50, 102, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16240  msg = ' It will not be issued again for this problem.'
16241  CALL xerrwd (msg, 50, 102, 0, 1, mxhnil, 0, 0, 0.0d0, 0.0d0)
16242  290 CONTINUE
16243 C-----------------------------------------------------------------------
16244 C CALL DSTODI(NEQ,Y,YH,NYH,YH1,EWT,SAVF,SAVR,ACOR,WM,WM,RES,
16245 C ADDA,JAC,DPRJIS,DSOLSS)
16246 C Note: SAVF in DSTODI occupies the same space as YDOTI in DLSODIS.
16247 C-----------------------------------------------------------------------
16248  CALL dstodi (neq, y, rwork(lyh), nyh, rwork(lyh), rwork(lewt),
16249  1 ydoti, rwork(lsavf), rwork(lacor), rwork(lwm),
16250  2 rwork(lwm), res, adda, jac, dprjis, dsolss )
16251  kgo = 1 - kflag
16252  GO TO (300, 530, 540, 400, 550, 555), kgo
16253 C
16254 C KGO = 1:success; 2:error test failure; 3:convergence failure;
16255 C 4:RES ordered return; 5:RES returned error;
16256 C 6:fatal error from CDRV via DPRJIS or DSOLSS.
16257 C-----------------------------------------------------------------------
16258 C Block F.
16259 C The following block handles the case of a successful return from the
16260 C core integrator (KFLAG = 0). Test for stop conditions.
16261 C-----------------------------------------------------------------------
16262  300 init = 1
16263  GO TO (310, 400, 330, 340, 350), itask
16264 C ITASK = 1. If TOUT has been reached, interpolate. -------------------
16265  310 iF ((tn - tout)*h .LT. 0.0d0) GO TO 250
16266  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
16267  t = tout
16268  GO TO 420
16269 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------
16270  330 IF ((tn - tout)*h .GE. 0.0d0) GO TO 400
16271  GO TO 250
16272 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary.
16273  340 IF ((tn - tout)*h .LT. 0.0d0) GO TO 345
16274  CALL dintdy (tout, 0, rwork(lyh), nyh, y, iflag)
16275  t = tout
16276  GO TO 420
16277  345 hmx = abs(tn) + abs(h)
16278  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
16279  IF (ihit) GO TO 400
16280  tnext = tn + h*(1.0d0 + 4.0d0*uround)
16281  IF ((tnext - tcrit)*h .LE. 0.0d0) GO TO 250
16282  h = (tcrit - tn)*(1.0d0 - 4.0d0*uround)
16283  jstart = -2
16284  GO TO 250
16285 C ITASK = 5. See if TCRIT was reached and jump to exit. ---------------
16286  350 hmx = abs(tn) + abs(h)
16287  ihit = abs(tn - tcrit) .LE. 100.0d0*uround*hmx
16288 C-----------------------------------------------------------------------
16289 C Block G.
16290 C The following block handles all successful returns from DLSODIS.
16291 C if ITASK .ne. 1, Y is loaded from YH and T is set accordingly.
16292 C ISTATE is set to 2, and the optional outputs are loaded into the
16293 C work arrays before returning.
16294 C-----------------------------------------------------------------------
16295  400 DO 410 i = 1,n
16296  410 y(i) = rwork(i+lyh-1)
16297  t = tn
16298  IF (itask .NE. 4 .AND. itask .NE. 5) GO TO 420
16299  IF (ihit) t = tcrit
16300  420 istate = 2
16301  IF ( kflag .EQ. -3 ) istate = 3
16302  rwork(11) = hu
16303  rwork(12) = h
16304  rwork(13) = tn
16305  iwork(11) = nst
16306  iwork(12) = nfe
16307  iwork(13) = nje
16308  iwork(14) = nqu
16309  iwork(15) = nq
16310  iwork(19) = nnz
16311  iwork(20) = ngp
16312  iwork(21) = nlu
16313  iwork(25) = nzl
16314  iwork(26) = nzu
16315  RETURN
16316 C-----------------------------------------------------------------------
16317 C Block H.
16318 C The following block handles all unsuccessful returns other than
16319 C those for illegal input. First the error message routine is called.
16320 C If there was an error test or convergence test failure, IMXER is set.
16321 C Then Y is loaded from YH and T is set to TN.
16322 C The optional outputs are loaded into the work arrays before returning.
16323 C-----------------------------------------------------------------------
16324 C The maximum number of steps was taken before reaching TOUT. ----------
16325  500 msg = 'DLSODIS- At current T (=R1), MXSTEP (=I1) steps '
16326  CALL xerrwd (msg, 50, 201, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16327  msg = ' taken on this call before reaching TOUT '
16328  CALL xerrwd (msg, 50, 201, 0, 1, mxstep, 0, 1, tn, 0.0d0)
16329  istate = -1
16330  GO TO 580
16331 C EWT(i) .le. 0.0 for some i (not at start of problem). ----------------
16332  510 ewti = rwork(lewt+i-1)
16333  msg = .le.'DLSODIS- At T (=R1), EWT(I1) has become R2 0.'
16334  CALL xerrwd (msg, 50, 202, 0, 1, i, 0, 2, tn, ewti)
16335  istate = -6
16336  GO TO 590
16337 C Too much accuracy requested for machine precision. -------------------
16338  520 msg = 'DLSODIS- At T (=R1), too much accuracy requested '
16339  CALL xerrwd (msg, 50, 203, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16340  msg = ' for precision of machine.. See TOLSF (=R2) '
16341  CALL xerrwd (msg, 50, 203, 0, 0, 0, 0, 2, tn, tolsf)
16342  rwork(14) = tolsf
16343  istate = -2
16344  GO TO 590
16345 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. -----
16346  530 msg = 'DLSODIS- At T (=R1) and step size H (=R2), the '
16347  CALL xerrwd (msg, 50, 204, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16348  msg=' error test failed repeatedly or with ABS(H) = HMIN '
16349  CALL xerrwd (msg, 60, 204, 0, 0, 0, 0, 2, tn, h)
16350  istate = -4
16351  GO TO 570
16352 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ----
16353  540 msg = 'DLSODIS- At T (=R1) and step size H (=R2), the '
16354  CALL xerrwd (msg, 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16355  msg = ' corrector convergence failed repeatedly '
16356  CALL xerrwd (msg, 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16357  msg = ' or with ABS(H) = HMIN '
16358  CALL xerrwd (msg, 30, 205, 0, 0, 0, 0, 2, tn, h)
16359  istate = -5
16360  GO TO 570
16361 C IRES = 3 returned by RES, despite retries by DSTODI. -----------------
16362  550 msg = 'DLSODIS- At T (=R1) residual routine returned '
16363  CALL xerrwd (msg, 50, 206, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16364  msg = ' error IRES = 3 repeatedly.'
16365  CALL xerrwd (msg, 30, 206, 1, 0, 0, 0, 0, tn, 0.0d0)
16366  istate = -7
16367  GO TO 590
16368 C KFLAG = -5. Fatal error flag returned by DPRJIS or DSOLSS (CDRV). ---
16369  555 msg = 'DLSODIS- At T (=R1) and step size H (=R2), a fatal'
16370  CALL xerrwd (msg, 50, 207, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16371  msg = ' error flag was returned by CDRV (by way of '
16372  CALL xerrwd (msg, 50, 207, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16373  msg = ' Subroutine DPRJIS or DSOLSS) '
16374  CALL xerrwd (msg, 40, 207, 0, 0, 0, 0, 2, tn, h)
16375  istate = -9
16376  GO TO 580
16377 C DAINVGS failed because matrix A was singular. ------------------------
16378  560 msg='DLSODIS- Attempt to initialize dy/dt failed because matrix A'
16379  CALL xerrwd (msg, 60, 208, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16380  msg=' was singular. CDRV returned zero pivot error flag. '
16381  CALL xerrwd (msg, 60, 208, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16382  msg = 'DAINVGS set its error flag to IER = (I1)'
16383  CALL xerrwd (msg, 40, 208, 0, 1, ier, 0, 0, 0.0d0, 0.0d0)
16384  istate = -8
16385  RETURN
16386 C DAINVGS failed because RES set IRES to 2 or 3. -----------------------
16387  565 msg = 'DLSODIS- Attempt to initialize dy/dt failed '
16388  CALL xerrwd (msg, 50, 209, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16389  msg = ' because residual routine set its error flag '
16390  CALL xerrwd (msg, 50, 209, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16391  msg = ' to IRES = (I1)'
16392  CALL xerrwd (msg, 20, 209, 0, 1, ier, 0, 0, 0.0d0, 0.0d0)
16393  istate = -8
16394  RETURN
16395 C Compute IMXER if relevant. -------------------------------------------
16396  570 big = 0.0d0
16397  imxer = 1
16398  DO 575 i = 1,n
16399  SIZE = abs(rwork(i+lacor-1)*rwork(i+lewt-1))
16400  IF (big .GE. size) GO TO 575
16401  big = SIZE
16402  imxer = i
16403  575 CONTINUE
16404  iwork(16) = imxer
16405 C Compute residual if relevant. ----------------------------------------
16406  580 lyd0 = lyh + nyh
16407  DO 585 i = 1, n
16408  rwork(i+lsavf-1) = rwork(i+lyd0-1) / h
16409  585 y(i) = rwork(i+lyh-1)
16410  ires = 1
16411  CALL res (neq, tn, y, rwork(lsavf), ydoti, ires)
16412  nfe = nfe + 1
16413  IF ( ires .LE. 1 ) GO TO 595
16414  msg = 'DLSODIS- Residual routine set its flag IRES '
16415  CALL xerrwd (msg, 50, 210, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16416  msg = ' to (I1) when called for final output. '
16417  CALL xerrwd (msg, 50, 210, 0, 1, ires, 0, 0, 0.0d0, 0.0d0)
16418  GO TO 595
16419 C set y vector, t, and optional outputs. -------------------------------
16420  590 DO 592 i = 1,n
16421  592 y(i) = rwork(i+lyh-1)
16422  595 t = tn
16423  rwork(11) = hu
16424  rwork(12) = h
16425  rwork(13) = tn
16426  iwork(11) = nst
16427  iwork(12) = nfe
16428  iwork(13) = nje
16429  iwork(14) = nqu
16430  iwork(15) = nq
16431  iwork(19) = nnz
16432  iwork(20) = ngp
16433  iwork(21) = nlu
16434  iwork(25) = nzl
16435  iwork(26) = nzu
16436  RETURN
16437 C-----------------------------------------------------------------------
16438 C Block I.
16439 C The following block handles all error returns due to illegal input
16440 C (ISTATE = -3), as detected before calling the core integrator.
16441 C First the error message routine is called. If the illegal input
16442 C is a negative ISTATE, the run is aborted (apparent infinite loop).
16443 C-----------------------------------------------------------------------
16444  601 msg = 'DLSODIS- ISTATE (=I1) illegal.'
16445  CALL xerrwd (msg, 30, 1, 0, 1, istate, 0, 0, 0.0d0, 0.0d0)
16446  IF (istate .LT. 0) GO TO 800
16447  GO TO 700
16448  602 msg = 'DLSODIS- ITASK (=I1) illegal. '
16449  CALL xerrwd (msg, 30, 2, 0, 1, itask, 0, 0, 0.0d0, 0.0d0)
16450  GO TO 700
16451  603 msg = .gt.'DLSODIS-ISTATE 1 but DLSODIS not initialized.'
16452  CALL xerrwd (msg, 50, 3, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16453  GO TO 700
16454  604 msg = .lt.'DLSODIS- NEQ (=I1) 1 '
16455  CALL xerrwd (msg, 30, 4, 0, 1, neq(1), 0, 0, 0.0d0, 0.0d0)
16456  GO TO 700
16457  605 msg = 'DLSODIS- ISTATE = 3 and NEQ increased (I1 to I2). '
16458  CALL xerrwd (msg, 50, 5, 0, 2, n, neq(1), 0, 0.0d0, 0.0d0)
16459  GO TO 700
16460  606 msg = 'DLSODIS- ITOL (=I1) illegal. '
16461  CALL xerrwd (msg, 30, 6, 0, 1, itol, 0, 0, 0.0d0, 0.0d0)
16462  GO TO 700
16463  607 msg = 'DLSODIS- IOPT (=I1) illegal. '
16464  CALL xerrwd (msg, 30, 7, 0, 1, iopt, 0, 0, 0.0d0, 0.0d0)
16465  GO TO 700
16466  608 msg = 'DLSODIS- MF (=I1) illegal. '
16467  CALL xerrwd (msg, 30, 8, 0, 1, mf, 0, 0, 0.0d0, 0.0d0)
16468  GO TO 700
16469  611 msg = .lt.'DLSODIS- MAXORD (=I1) 0 '
16470  CALL xerrwd (msg, 30, 11, 0, 1, maxord, 0, 0, 0.0d0, 0.0d0)
16471  GO TO 700
16472  612 msg = .lt.'DLSODIS- MXSTEP (=I1) 0 '
16473  CALL xerrwd (msg, 30, 12, 0, 1, mxstep, 0, 0, 0.0d0, 0.0d0)
16474  GO TO 700
16475  613 msg = .lt.'DLSODIS- MXHNIL (=I1) 0 '
16476  CALL xerrwd (msg, 30, 13, 0, 1, mxhnil, 0, 0, 0.0d0, 0.0d0)
16477  GO TO 700
16478  614 msg = 'DLSODIS- TOUT (=R1) behind T (=R2) '
16479  CALL xerrwd (msg, 40, 14, 0, 0, 0, 0, 2, tout, t)
16480  msg = ' Integration direction is given by H0 (=R1) '
16481  CALL xerrwd (msg, 50, 14, 0, 0, 0, 0, 1, h0, 0.0d0)
16482  GO TO 700
16483  615 msg = .lt.'DLSODIS- HMAX (=R1) 0.0 '
16484  CALL xerrwd (msg, 30, 15, 0, 0, 0, 0, 1, hmax, 0.0d0)
16485  GO TO 700
16486  616 msg = .lt.'DLSODIS- HMIN (=R1) 0.0 '
16487  CALL xerrwd (msg, 30, 16, 0, 0, 0, 0, 1, hmin, 0.0d0)
16488  GO TO 700
16489  617 msg = 'DLSODIS- RWORK length is insufficient to proceed. '
16490  CALL xerrwd (msg, 50, 17, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16491  msg=.ge.' Length needed is LENRW (=I1), exceeds LRW (=I2)'
16492  CALL xerrwd (msg, 60, 17, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0)
16493  GO TO 700
16494  618 msg = 'DLSODIS- IWORK length is insufficient to proceed. '
16495  CALL xerrwd (msg, 50, 18, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16496  msg=.ge.' Length needed is LENIW (=I1), exceeds LIW (=I2)'
16497  CALL xerrwd (msg, 60, 18, 0, 2, leniw, liw, 0, 0.0d0, 0.0d0)
16498  GO TO 700
16499  619 msg = .lt.'DLSODIS- RTOL(=I1) is R1 0.0 '
16500  CALL xerrwd (msg, 40, 19, 0, 1, i, 0, 1, rtoli, 0.0d0)
16501  GO TO 700
16502  620 msg = .lt.'DLSODIS- ATOL(=I1) is R1 0.0 '
16503  CALL xerrwd (msg, 40, 20, 0, 1, i, 0, 1, atoli, 0.0d0)
16504  GO TO 700
16505  621 ewti = rwork(lewt+i-1)
16506  msg = .le.'DLSODIS- EWT(I1) is R1 0.0 '
16507  CALL xerrwd (msg, 40, 21, 0, 1, i, 0, 1, ewti, 0.0d0)
16508  GO TO 700
16509  622 msg='DLSODIS- TOUT(=R1) too close to T(=R2) to start integration.'
16510  CALL xerrwd (msg, 60, 22, 0, 0, 0, 0, 2, tout, t)
16511  GO TO 700
16512  623 msg='DLSODIS- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) '
16513  CALL xerrwd (msg, 60, 23, 0, 1, itask, 0, 2, tout, tp)
16514  GO TO 700
16515  624 msg='DLSODIS- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) '
16516  CALL xerrwd (msg, 60, 24, 0, 0, 0, 0, 2, tcrit, tn)
16517  GO TO 700
16518  625 msg='DLSODIS- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) '
16519  CALL xerrwd (msg, 60, 25, 0, 0, 0, 0, 2, tcrit, tout)
16520  GO TO 700
16521  626 msg = 'DLSODIS- At start of problem, too much accuracy '
16522  CALL xerrwd (msg, 50, 26, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16523  msg=' requested for precision of machine.. See TOLSF (=R1) '
16524  CALL xerrwd (msg, 60, 26, 0, 0, 0, 0, 1, tolsf, 0.0d0)
16525  rwork(14) = tolsf
16526  GO TO 700
16527  627 msg = 'DLSODIS- Trouble in DINTDY. ITASK = I1, TOUT = R1'
16528  CALL xerrwd (msg, 50, 27, 0, 1, itask, 0, 1, tout, 0.0d0)
16529  GO TO 700
16530  628 msg='DLSODIS- RWORK length insufficient (for Subroutine DPREPI). '
16531  CALL xerrwd (msg, 60, 28, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16532  msg=.ge.' Length needed is LENRW (=I1), exceeds LRW (=I2)'
16533  CALL xerrwd (msg, 60, 28, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0)
16534  GO TO 700
16535  629 msg='DLSODIS- RWORK length insufficient (for Subroutine JGROUP). '
16536  CALL xerrwd (msg, 60, 29, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16537  msg=.ge.' Length needed is LENRW (=I1), exceeds LRW (=I2)'
16538  CALL xerrwd (msg, 60, 29, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0)
16539  GO TO 700
16540  630 msg='DLSODIS- RWORK length insufficient (for Subroutine ODRV). '
16541  CALL xerrwd (msg, 60, 30, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16542  msg=.ge.' Length needed is LENRW (=I1), exceeds LRW (=I2)'
16543  CALL xerrwd (msg, 60, 30, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0)
16544  GO TO 700
16545  631 msg='DLSODIS- Error from ODRV in Yale Sparse Matrix Package. '
16546  CALL xerrwd (msg, 60, 31, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16547  imul = (iys - 1)/n
16548  irem = iys - imul*n
16549  msg=' At T (=R1), ODRV returned error flag = I1*NEQ + I2. '
16550  CALL xerrwd (msg, 60, 31, 0, 2, imul, irem, 1, tn, 0.0d0)
16551  GO TO 700
16552  632 msg='DLSODIS- RWORK length insufficient (for Subroutine CDRV). '
16553  CALL xerrwd (msg, 60, 32, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16554  msg=.ge.' Length needed is LENRW (=I1), exceeds LRW (=I2)'
16555  CALL xerrwd (msg, 60, 32, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0)
16556  GO TO 700
16557  633 msg='DLSODIS- Error from CDRV in Yale Sparse Matrix Package. '
16558  CALL xerrwd (msg, 60, 33, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16559  imul = (iys - 1)/n
16560  irem = iys - imul*n
16561  msg=' At T (=R1), CDRV returned error flag = I1*NEQ + I2. '
16562  CALL xerrwd (msg, 60, 33, 0, 2, imul, irem, 1, tn, 0.0d0)
16563  IF (imul .EQ. 2) THEN
16564  msg=' Duplicate entry in sparsity structure descriptors. '
16565  CALL xerrwd (msg, 60, 33, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16566  ENDIF
16567  IF (imul .EQ. 3 .OR. imul .EQ. 6) THEN
16568  msg=' Insufficient storage for NSFC (called by CDRV). '
16569  CALL xerrwd (msg, 60, 33, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16570  ENDIF
16571  GO TO 700
16572  634 msg='DLSODIS- At T (=R1) residual routine (called by DPREPI) '
16573  CALL xerrwd (msg, 60, 34, 0, 0, 0, 0, 0, 0.0d0, 0.0d0)
16574  ier = -ipflag - 5
16575  msg = ' returned error IRES (=I1)'
16576  CALL xerrwd (msg, 30, 34, 0, 1, ier, 0, 1, tn, 0.0d0)
16577 C
16578  700 istate = -3
16579  RETURN
16580 C
16581  800 msg = 'DLSODIS- Run aborted.. apparent infinite loop. '
16582  CALL xerrwd (msg, 50, 303, 2, 0, 0, 0, 0, 0.0d0, 0.0d0)
16583  RETURN
16584 C----------------------- End of Subroutine DLSODIS ---------------------
16585  END
16586 
16587