?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
In documentation for lreduce and rreduce, supply second argument as an explicit list
[maxima.git] / share / odepack / src / dlsodi.lisp
blobe252a5cee5f0ae86530efc9239293447589266ad
1 ;;; Compiled by f2cl version:
2 ;;; ("f2cl1.l,v 95098eb54f13 2013/04/01 00:45:16 toy $"
3 ;;; "f2cl2.l,v 95098eb54f13 2013/04/01 00:45:16 toy $"
4 ;;; "f2cl3.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
5 ;;; "f2cl4.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
6 ;;; "f2cl5.l,v 95098eb54f13 2013/04/01 00:45:16 toy $"
7 ;;; "f2cl6.l,v 1d5cbacbb977 2008/08/24 00:56:27 rtoy $"
8 ;;; "macros.l,v 1409c1352feb 2013/03/24 20:44:50 toy $")
9
10 ;;; Using Lisp CMU Common Lisp snapshot-2013-11 (20E Unicode)
11 ;;;
12 ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
13 ;;; (:coerce-assigns :as-needed) (:array-type ':array)
14 ;;; (:array-slicing t) (:declare-common nil)
15 ;;; (:float-format single-float))
16
17 (in-package "ODEPACK")
18
19
20 (let ((mord
21 (make-array 2
22 :element-type 'f2cl-lib:integer4
23 :initial-contents '(12 5)))
24 (mxstp0 500)
25 (mxhnl0 10))
26 (declare (type (array f2cl-lib:integer4 (2)) mord)
27 (type (f2cl-lib:integer4) mxstp0 mxhnl0))
28 (defun dlsodi
29 (res adda jac neq y ydoti t$ tout itol rtol atol itask istate iopt
30 rwork lrw iwork liw mf)
31 (declare (type (f2cl-lib:integer4) mf liw lrw iopt istate itask itol)
32 (type (double-float) tout t$)
33 (type (array double-float (*)) rwork atol rtol ydoti y)
34 (type (array f2cl-lib:integer4 (*)) iwork neq))
35 (let ()
36 (symbol-macrolet ((ccmax
37 (aref (dls001-part-0 *dls001-common-block*) 209))
38 (h (aref (dls001-part-0 *dls001-common-block*) 211))
39 (hmin (aref (dls001-part-0 *dls001-common-block*) 212))
40 (hmxi (aref (dls001-part-0 *dls001-common-block*) 213))
41 (hu (aref (dls001-part-0 *dls001-common-block*) 214))
42 (tn (aref (dls001-part-0 *dls001-common-block*) 216))
43 (uround
44 (aref (dls001-part-0 *dls001-common-block*) 217))
45 (init (aref (dls001-part-1 *dls001-common-block*) 0))
46 (mxstep (aref (dls001-part-1 *dls001-common-block*) 1))
47 (mxhnil (aref (dls001-part-1 *dls001-common-block*) 2))
48 (nhnil (aref (dls001-part-1 *dls001-common-block*) 3))
49 (nslast (aref (dls001-part-1 *dls001-common-block*) 4))
50 (nyh (aref (dls001-part-1 *dls001-common-block*) 5))
51 (jstart
52 (aref (dls001-part-1 *dls001-common-block*) 16))
53 (kflag (aref (dls001-part-1 *dls001-common-block*) 17))
54 (l (aref (dls001-part-1 *dls001-common-block*) 18))
55 (lyh (aref (dls001-part-1 *dls001-common-block*) 19))
56 (lewt (aref (dls001-part-1 *dls001-common-block*) 20))
57 (lacor (aref (dls001-part-1 *dls001-common-block*) 21))
58 (lsavf (aref (dls001-part-1 *dls001-common-block*) 22))
59 (lwm (aref (dls001-part-1 *dls001-common-block*) 23))
60 (liwm (aref (dls001-part-1 *dls001-common-block*) 24))
61 (meth (aref (dls001-part-1 *dls001-common-block*) 25))
62 (miter (aref (dls001-part-1 *dls001-common-block*) 26))
63 (maxord
64 (aref (dls001-part-1 *dls001-common-block*) 27))
65 (maxcor
66 (aref (dls001-part-1 *dls001-common-block*) 28))
67 (msbp (aref (dls001-part-1 *dls001-common-block*) 29))
68 (mxncf (aref (dls001-part-1 *dls001-common-block*) 30))
69 (n (aref (dls001-part-1 *dls001-common-block*) 31))
70 (nq (aref (dls001-part-1 *dls001-common-block*) 32))
71 (nst (aref (dls001-part-1 *dls001-common-block*) 33))
72 (nfe (aref (dls001-part-1 *dls001-common-block*) 34))
73 (nje (aref (dls001-part-1 *dls001-common-block*) 35))
74 (nqu (aref (dls001-part-1 *dls001-common-block*) 36)))
75 (f2cl-lib:with-multi-array-data
76 ((neq f2cl-lib:integer4 neq-%data% neq-%offset%)
77 (iwork f2cl-lib:integer4 iwork-%data% iwork-%offset%)
78 (y double-float y-%data% y-%offset%)
79 (ydoti double-float ydoti-%data% ydoti-%offset%)
80 (rtol double-float rtol-%data% rtol-%offset%)
81 (atol double-float atol-%data% atol-%offset%)
82 (rwork double-float rwork-%data% rwork-%offset%))
83 (prog ((mu 0) (ml 0) (lyd0 0) (lp 0) (lenwm 0) (lenrw 0) (leniw 0)
84 (kgo 0) (ires 0) (imxer 0) (iflag 0) (ier 0) (i2 0) (i1 0)
85 (i 0) (w0 0.0d0) (sum 0.0d0) (size 0.0d0) (tp 0.0d0)
86 (tolsf 0.0d0) (tol 0.0d0) (tnext 0.0d0) (tdist 0.0d0)
87 (tcrit 0.0d0) (rtoli 0.0d0) (rh 0.0d0) (hmx 0.0d0)
88 (hmax 0.0d0) (h0 0.0d0) (ewti 0.0d0) (big 0.0d0) (ayi 0.0d0)
89 (atoli 0.0d0) (ihit nil)
90 (msg
91 (make-array '(60)
92 :element-type 'character
93 :initial-element #\ )))
94 (declare (type (string 60) msg)
95 (type f2cl-lib:logical ihit)
96 (type (double-float) atoli ayi big ewti h0 hmax hmx rh
97 rtoli tcrit tdist tnext tol tolsf tp
98 size sum w0)
99 (type (f2cl-lib:integer4) i i1 i2 ier iflag imxer ires kgo
100 leniw lenrw lenwm lp lyd0 ml
101 mu))
102 (if (or (< istate 0) (> istate 3)) (go label601))
103 (if (or (< itask 1) (> itask 5)) (go label602))
104 (if (<= istate 1) (go label10))
105 (if (= init 0) (go label603))
106 (if (= istate 2) (go label200))
107 (go label20)
108 label10
109 (setf init 0)
110 (if (= tout t$) (go end_label))
111 label20
112 (if (<= (f2cl-lib:fref neq-%data% (1) ((1 *)) neq-%offset%) 0)
113 (go label604))
114 (if (<= istate 1) (go label25))
115 (if (> (f2cl-lib:fref neq-%data% (1) ((1 *)) neq-%offset%) n)
116 (go label605))
117 label25
118 (setf n (f2cl-lib:fref neq-%data% (1) ((1 *)) neq-%offset%))
119 (if (or (< itol 1) (> itol 4)) (go label606))
120 (if (or (< iopt 0) (> iopt 1)) (go label607))
121 (setf meth (the f2cl-lib:integer4 (truncate mf 10)))
122 (setf miter (f2cl-lib:int-sub mf (f2cl-lib:int-mul 10 meth)))
123 (if (or (< meth 1) (> meth 2)) (go label608))
124 (if (or (<= miter 0) (> miter 5)) (go label608))
125 (if (= miter 3) (go label608))
126 (if (< miter 3) (go label30))
127 (setf ml (f2cl-lib:fref iwork-%data% (1) ((1 liw)) iwork-%offset%))
128 (setf mu (f2cl-lib:fref iwork-%data% (2) ((1 liw)) iwork-%offset%))
129 (if (or (< ml 0) (>= ml n)) (go label609))
130 (if (or (< mu 0) (>= mu n)) (go label610))
131 label30
132 (if (= iopt 1) (go label40))
133 (setf maxord (f2cl-lib:fref mord (meth) ((1 2))))
134 (setf mxstep mxstp0)
135 (setf mxhnil mxhnl0)
136 (if (<= istate 1) (setf h0 0.0d0))
137 (setf hmxi 0.0d0)
138 (setf hmin 0.0d0)
139 (go label60)
140 label40
141 (setf maxord
142 (f2cl-lib:fref iwork-%data% (5) ((1 liw)) iwork-%offset%))
143 (if (< maxord 0) (go label611))
144 (if (= maxord 0) (setf maxord 100))
145 (setf maxord
146 (min (the f2cl-lib:integer4 maxord)
147 (the f2cl-lib:integer4
148 (f2cl-lib:fref mord (meth) ((1 2))))))
149 (setf mxstep
150 (f2cl-lib:fref iwork-%data% (6) ((1 liw)) iwork-%offset%))
151 (if (< mxstep 0) (go label612))
152 (if (= mxstep 0) (setf mxstep mxstp0))
153 (setf mxhnil
154 (f2cl-lib:fref iwork-%data% (7) ((1 liw)) iwork-%offset%))
155 (if (< mxhnil 0) (go label613))
156 (if (= mxhnil 0) (setf mxhnil mxhnl0))
157 (if (> istate 1) (go label50))
158 (setf h0 (f2cl-lib:fref rwork-%data% (5) ((1 lrw)) rwork-%offset%))
159 (if (< (* (- tout t$) h0) 0.0d0) (go label614))
160 label50
161 (setf hmax
162 (f2cl-lib:fref rwork-%data% (6) ((1 lrw)) rwork-%offset%))
163 (if (< hmax 0.0d0) (go label615))
164 (setf hmxi 0.0d0)
165 (if (> hmax 0.0d0) (setf hmxi (/ 1.0d0 hmax)))
166 (setf hmin
167 (f2cl-lib:fref rwork-%data% (7) ((1 lrw)) rwork-%offset%))
168 (if (< hmin 0.0d0) (go label616))
169 label60
170 (setf lyh 21)
171 (if (<= istate 1) (setf nyh n))
172 (setf lwm
173 (f2cl-lib:int-add lyh
174 (f2cl-lib:int-mul
175 (f2cl-lib:int-add maxord 1)
176 nyh)))
177 (if (<= miter 2)
178 (setf lenwm (f2cl-lib:int-add (f2cl-lib:int-mul n n) 2)))
179 (if (>= miter 4)
180 (setf lenwm
181 (f2cl-lib:int-add
182 (f2cl-lib:int-mul
183 (f2cl-lib:int-add (f2cl-lib:int-mul 2 ml) mu 1)
184 n)
185 2)))
186 (setf lewt (f2cl-lib:int-add lwm lenwm))
187 (setf lsavf (f2cl-lib:int-add lewt n))
188 (setf lacor (f2cl-lib:int-add lsavf n))
189 (setf lenrw (f2cl-lib:int-sub (f2cl-lib:int-add lacor n) 1))
190 (setf (f2cl-lib:fref iwork-%data% (17) ((1 liw)) iwork-%offset%)
191 lenrw)
192 (setf liwm 1)
193 (setf leniw (f2cl-lib:int-add 20 n))
194 (setf (f2cl-lib:fref iwork-%data% (18) ((1 liw)) iwork-%offset%)
195 leniw)
196 (if (> lenrw lrw) (go label617))
197 (if (> leniw liw) (go label618))
198 (setf rtoli (f2cl-lib:fref rtol-%data% (1) ((1 *)) rtol-%offset%))
199 (setf atoli (f2cl-lib:fref atol-%data% (1) ((1 *)) atol-%offset%))
200 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
201 ((> i n) nil)
202 (tagbody
203 (if (>= itol 3)
204 (setf rtoli
205 (f2cl-lib:fref rtol-%data%
206 (i)
207 ((1 *))
208 rtol-%offset%)))
209 (if (or (= itol 2) (= itol 4))
210 (setf atoli
211 (f2cl-lib:fref atol-%data%
212 (i)
213 ((1 *))
214 atol-%offset%)))
215 (if (< rtoli 0.0d0) (go label619))
216 (if (< atoli 0.0d0) (go label620))
217 label70))
218 (if (<= istate 1) (go label100))
219 (setf jstart -1)
220 (if (<= nq maxord) (go label90))
221 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
222 ((> i n) nil)
223 (tagbody
224 label80
225 (setf (f2cl-lib:fref ydoti-%data% (i) ((1 *)) ydoti-%offset%)
226 (f2cl-lib:fref rwork-%data%
227 ((f2cl-lib:int-sub
228 (f2cl-lib:int-add i lwm)
229 1))
230 ((1 lrw))
231 rwork-%offset%))))
232 label90
233 (setf (f2cl-lib:fref rwork-%data% (lwm) ((1 lrw)) rwork-%offset%)
234 (f2cl-lib:fsqrt uround))
235 (if (= n nyh) (go label200))
236 (setf i1 (f2cl-lib:int-add lyh (f2cl-lib:int-mul l nyh)))
237 (setf i2
238 (f2cl-lib:int-sub
239 (f2cl-lib:int-add lyh
240 (f2cl-lib:int-mul
241 (f2cl-lib:int-add maxord 1)
242 nyh))
243 1))
244 (if (> i1 i2) (go label200))
245 (f2cl-lib:fdo (i i1 (f2cl-lib:int-add i 1))
246 ((> i i2) nil)
247 (tagbody
248 label95
249 (setf (f2cl-lib:fref rwork-%data% (i) ((1 lrw)) rwork-%offset%)
250 0.0d0)))
251 (go label200)
252 label100
253 (setf uround (dumach))
254 (setf tn t$)
255 (if (and (/= itask 4) (/= itask 5)) (go label105))
256 (setf tcrit
257 (f2cl-lib:fref rwork-%data% (1) ((1 lrw)) rwork-%offset%))
258 (if (< (* (- tcrit tout) (- tout t$)) 0.0d0) (go label625))
259 (if (and (/= h0 0.0d0) (> (* (- (+ t$ h0) tcrit) h0) 0.0d0))
260 (setf h0 (- tcrit t$)))
261 label105
262 (setf jstart 0)
263 (setf (f2cl-lib:fref rwork-%data% (lwm) ((1 lrw)) rwork-%offset%)
264 (f2cl-lib:fsqrt uround))
265 (setf nhnil 0)
266 (setf nst 0)
267 (setf nfe 0)
268 (setf nje 0)
269 (setf nslast 0)
270 (setf hu 0.0d0)
271 (setf nqu 0)
272 (setf ccmax 0.3d0)
273 (setf maxcor 3)
274 (setf msbp 20)
275 (setf mxncf 10)
276 (setf lyd0 (f2cl-lib:int-add lyh nyh))
277 (setf lp (f2cl-lib:int-add lwm 1))
278 (if (= istate 1) (go label120))
279 (multiple-value-bind
280 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
281 var-10 var-11)
282 (dainvg res adda neq t$ y
283 (f2cl-lib:array-slice rwork-%data%
284 double-float
285 (lyd0)
286 ((1 lrw))
287 rwork-%offset%)
288 miter ml mu
289 (f2cl-lib:array-slice rwork-%data%
290 double-float
291 (lp)
292 ((1 lrw))
293 rwork-%offset%)
294 (f2cl-lib:array-slice iwork-%data%
295 f2cl-lib:integer4
296 (21)
297 ((1 liw))
298 iwork-%offset%)
299 ier)
300 (declare (ignore var-0 var-1 var-2 var-4 var-5 var-6 var-9
301 var-10))
302 (setf t$ var-3)
303 (setf ml var-7)
304 (setf mu var-8)
305 (setf ier var-11))
306 (setf nfe (f2cl-lib:int-add nfe 1))
307 (if (< ier 0) (go label560))
308 (if (> ier 0) (go label565))
309 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
310 ((> i n) nil)
311 (tagbody
312 label115
313 (setf (f2cl-lib:fref rwork-%data%
314 ((f2cl-lib:int-sub
315 (f2cl-lib:int-add i lyh)
316 1))
317 ((1 lrw))
318 rwork-%offset%)
319 (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%))))
320 (go label130)
321 label120
322 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
323 ((> i n) nil)
324 (tagbody
325 (setf (f2cl-lib:fref rwork-%data%
326 ((f2cl-lib:int-sub
327 (f2cl-lib:int-add i lyh)
328 1))
329 ((1 lrw))
330 rwork-%offset%)
331 (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%))
332 label125
333 (setf (f2cl-lib:fref rwork-%data%
334 ((f2cl-lib:int-sub
335 (f2cl-lib:int-add i lyd0)
336 1))
337 ((1 lrw))
338 rwork-%offset%)
339 (f2cl-lib:fref ydoti-%data%
340 (i)
341 ((1 *))
342 ydoti-%offset%))))
343 label130
344 (setf nq 1)
345 (setf h 1.0d0)
346 (dewset n itol rtol atol
347 (f2cl-lib:array-slice rwork-%data%
348 double-float
349 (lyh)
350 ((1 lrw))
351 rwork-%offset%)
352 (f2cl-lib:array-slice rwork-%data%
353 double-float
354 (lewt)
355 ((1 lrw))
356 rwork-%offset%))
357 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
358 ((> i n) nil)
359 (tagbody
360 (if
361 (<=
362 (f2cl-lib:fref rwork-%data%
363 ((f2cl-lib:int-sub (f2cl-lib:int-add i lewt)
364 1))
365 ((1 lrw))
366 rwork-%offset%)
367 0.0d0)
368 (go label621))
369 label135
370 (setf (f2cl-lib:fref rwork-%data%
371 ((f2cl-lib:int-sub
372 (f2cl-lib:int-add i lewt)
373 1))
374 ((1 lrw))
375 rwork-%offset%)
376 (/ 1.0d0
377 (f2cl-lib:fref rwork-%data%
378 ((f2cl-lib:int-sub
379 (f2cl-lib:int-add i lewt)
380 1))
381 ((1 lrw))
382 rwork-%offset%)))))
383 (if (/= h0 0.0d0) (go label180))
384 (setf tdist (abs (- tout t$)))
385 (setf w0 (max (abs t$) (abs tout)))
386 (if (< tdist (* 2.0d0 uround w0)) (go label622))
387 (setf tol (f2cl-lib:fref rtol-%data% (1) ((1 *)) rtol-%offset%))
388 (if (<= itol 2) (go label145))
389 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
390 ((> i n) nil)
391 (tagbody
392 label140
393 (setf tol
394 (max tol
395 (f2cl-lib:fref rtol-%data%
396 (i)
397 ((1 *))
398 rtol-%offset%)))))
399 label145
400 (if (> tol 0.0d0) (go label160))
401 (setf atoli (f2cl-lib:fref atol-%data% (1) ((1 *)) atol-%offset%))
402 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
403 ((> i n) nil)
404 (tagbody
405 (if (or (= itol 2) (= itol 4))
406 (setf atoli
407 (f2cl-lib:fref atol-%data%
408 (i)
409 ((1 *))
410 atol-%offset%)))
411 (setf ayi
412 (abs (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%)))
413 (if (/= ayi 0.0d0) (setf tol (max tol (/ atoli ayi))))
414 label150))
415 label160
416 (setf tol (max tol (* 100.0d0 uround)))
417 (setf tol (min tol 0.001d0))
418 (setf sum
419 (dvnorm n
420 (f2cl-lib:array-slice rwork-%data%
421 double-float
422 (lyd0)
423 ((1 lrw))
424 rwork-%offset%)
425 (f2cl-lib:array-slice rwork-%data%
426 double-float
427 (lewt)
428 ((1 lrw))
429 rwork-%offset%)))
430 (setf sum (+ (/ 1.0d0 (* tol w0 w0)) (* tol (expt sum 2))))
431 (setf h0 (/ 1.0d0 (f2cl-lib:fsqrt sum)))
432 (setf h0 (min h0 tdist))
433 (setf h0 (f2cl-lib:sign h0 (- tout t$)))
434 label180
435 (setf rh (* (abs h0) hmxi))
436 (if (> rh 1.0d0) (setf h0 (/ h0 rh)))
437 (setf h h0)
438 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
439 ((> i n) nil)
440 (tagbody
441 label190
442 (setf (f2cl-lib:fref rwork-%data%
443 ((f2cl-lib:int-sub
444 (f2cl-lib:int-add i lyd0)
445 1))
446 ((1 lrw))
447 rwork-%offset%)
448 (* h0
449 (f2cl-lib:fref rwork-%data%
450 ((f2cl-lib:int-sub
451 (f2cl-lib:int-add i lyd0)
452 1))
453 ((1 lrw))
454 rwork-%offset%)))))
455 (go label270)
456 label200
457 (setf nslast nst)
458 (f2cl-lib:computed-goto
459 (label210 label250 label220 label230 label240)
460 itask)
461 label210
462 (if (< (* (- tn tout) h) 0.0d0) (go label250))
463 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
464 (dintdy tout 0
465 (f2cl-lib:array-slice rwork-%data%
466 double-float
467 (lyh)
468 ((1 lrw))
469 rwork-%offset%)
470 nyh y iflag)
471 (declare (ignore var-0 var-1 var-2 var-3 var-4))
472 (setf iflag var-5))
473 (if (/= iflag 0) (go label627))
474 (setf t$ tout)
475 (go label420)
476 label220
477 (setf tp (- tn (* hu (+ 1.0d0 (* 100.0d0 uround)))))
478 (if (> (* (- tp tout) h) 0.0d0) (go label623))
479 (if (< (* (- tn tout) h) 0.0d0) (go label250))
480 (go label400)
481 label230
482 (setf tcrit
483 (f2cl-lib:fref rwork-%data% (1) ((1 lrw)) rwork-%offset%))
484 (if (> (* (- tn tcrit) h) 0.0d0) (go label624))
485 (if (< (* (- tcrit tout) h) 0.0d0) (go label625))
486 (if (< (* (- tn tout) h) 0.0d0) (go label245))
487 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
488 (dintdy tout 0
489 (f2cl-lib:array-slice rwork-%data%
490 double-float
491 (lyh)
492 ((1 lrw))
493 rwork-%offset%)
494 nyh y iflag)
495 (declare (ignore var-0 var-1 var-2 var-3 var-4))
496 (setf iflag var-5))
497 (if (/= iflag 0) (go label627))
498 (setf t$ tout)
499 (go label420)
500 label240
501 (setf tcrit
502 (f2cl-lib:fref rwork-%data% (1) ((1 lrw)) rwork-%offset%))
503 (if (> (* (- tn tcrit) h) 0.0d0) (go label624))
504 label245
505 (setf hmx (+ (abs tn) (abs h)))
506 (setf ihit (<= (abs (- tn tcrit)) (* 100.0d0 uround hmx)))
507 (if ihit (go label400))
508 (setf tnext (+ tn (* h (+ 1.0d0 (* 4.0d0 uround)))))
509 (if (<= (* (- tnext tcrit) h) 0.0d0) (go label250))
510 (setf h (* (- tcrit tn) (- 1.0d0 (* 4.0d0 uround))))
511 (if (= istate 2) (setf jstart -2))
512 label250
513 (if (>= (f2cl-lib:int-sub nst nslast) mxstep) (go label500))
514 (dewset n itol rtol atol
515 (f2cl-lib:array-slice rwork-%data%
516 double-float
517 (lyh)
518 ((1 lrw))
519 rwork-%offset%)
520 (f2cl-lib:array-slice rwork-%data%
521 double-float
522 (lewt)
523 ((1 lrw))
524 rwork-%offset%))
525 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
526 ((> i n) nil)
527 (tagbody
528 (if
529 (<=
530 (f2cl-lib:fref rwork-%data%
531 ((f2cl-lib:int-sub (f2cl-lib:int-add i lewt)
532 1))
533 ((1 lrw))
534 rwork-%offset%)
535 0.0d0)
536 (go label510))
537 label260
538 (setf (f2cl-lib:fref rwork-%data%
539 ((f2cl-lib:int-sub
540 (f2cl-lib:int-add i lewt)
541 1))
542 ((1 lrw))
543 rwork-%offset%)
544 (/ 1.0d0
545 (f2cl-lib:fref rwork-%data%
546 ((f2cl-lib:int-sub
547 (f2cl-lib:int-add i lewt)
548 1))
549 ((1 lrw))
550 rwork-%offset%)))))
551 label270
552 (setf tolsf
553 (* uround
554 (dvnorm n
555 (f2cl-lib:array-slice rwork-%data%
556 double-float
557 (lyh)
558 ((1 lrw))
559 rwork-%offset%)
560 (f2cl-lib:array-slice rwork-%data%
561 double-float
562 (lewt)
563 ((1 lrw))
564 rwork-%offset%))))
565 (if (<= tolsf 1.0d0) (go label280))
566 (setf tolsf (* tolsf 2.0d0))
567 (if (= nst 0) (go label626))
568 (go label520)
569 label280
570 (if (/= (+ tn h) tn) (go label290))
571 (setf nhnil (f2cl-lib:int-add nhnil 1))
572 (if (> nhnil mxhnil) (go label290))
573 (f2cl-lib:f2cl-set-string msg
574 "DLSODI- Warning..Internal T (=R1) and H (=R2) are"
575 (string 60))
576 (xerrwd msg 50 101 0 0 0 0 0 0.0d0 0.0d0)
577 (f2cl-lib:f2cl-set-string msg
578 " such that in the machine, T + H = T on the next step "
579 (string 60))
580 (xerrwd msg 60 101 0 0 0 0 0 0.0d0 0.0d0)
581 (f2cl-lib:f2cl-set-string msg
582 " (H = step size). Solver will continue anyway."
583 (string 60))
584 (xerrwd msg 50 101 0 0 0 0 2 tn h)
585 (if (< nhnil mxhnil) (go label290))
586 (f2cl-lib:f2cl-set-string msg
587 "DLSODI- Above warning has been issued I1 times. "
588 (string 60))
589 (xerrwd msg 50 102 0 0 0 0 0 0.0d0 0.0d0)
590 (f2cl-lib:f2cl-set-string msg
591 " It will not be issued again for this problem."
592 (string 60))
593 (xerrwd msg 50 102 0 1 mxhnil 0 0 0.0d0 0.0d0)
594 label290
595 (multiple-value-bind
596 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
597 var-10 var-11 var-12 var-13 var-14 var-15)
598 (dstodi neq y
599 (f2cl-lib:array-slice rwork-%data%
600 double-float
601 (lyh)
602 ((1 lrw))
603 rwork-%offset%)
604 nyh
605 (f2cl-lib:array-slice rwork-%data%
606 double-float
607 (lyh)
608 ((1 lrw))
609 rwork-%offset%)
610 (f2cl-lib:array-slice rwork-%data%
611 double-float
612 (lewt)
613 ((1 lrw))
614 rwork-%offset%)
615 ydoti
616 (f2cl-lib:array-slice rwork-%data%
617 double-float
618 (lsavf)
619 ((1 lrw))
620 rwork-%offset%)
621 (f2cl-lib:array-slice rwork-%data%
622 double-float
623 (lacor)
624 ((1 lrw))
625 rwork-%offset%)
626 (f2cl-lib:array-slice rwork-%data%
627 double-float
628 (lwm)
629 ((1 lrw))
630 rwork-%offset%)
631 (f2cl-lib:array-slice iwork-%data%
632 f2cl-lib:integer4
633 (liwm)
634 ((1 liw))
635 iwork-%offset%)
636 res adda jac #'dprepji #'dsolsy)
637 (declare (ignore var-0 var-1 var-2 var-4 var-5 var-6 var-7 var-8
638 var-9 var-10 var-11 var-12 var-13 var-14
639 var-15))
640 (setf nyh var-3))
641 (setf kgo (f2cl-lib:int-sub 1 kflag))
642 (f2cl-lib:computed-goto
643 (label300 label530 label540 label400 label550)
644 kgo)
645 label300
646 (setf init 1)
647 (f2cl-lib:computed-goto
648 (label310 label400 label330 label340 label350)
649 itask)
650 label310
651 (if (< (* (- tn tout) h) 0.0d0) (go label250))
652 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
653 (dintdy tout 0
654 (f2cl-lib:array-slice rwork-%data%
655 double-float
656 (lyh)
657 ((1 lrw))
658 rwork-%offset%)
659 nyh y iflag)
660 (declare (ignore var-0 var-1 var-2 var-3 var-4))
661 (setf iflag var-5))
662 (setf t$ tout)
663 (go label420)
664 label330
665 (if (>= (* (- tn tout) h) 0.0d0) (go label400))
666 (go label250)
667 label340
668 (if (< (* (- tn tout) h) 0.0d0) (go label345))
669 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
670 (dintdy tout 0
671 (f2cl-lib:array-slice rwork-%data%
672 double-float
673 (lyh)
674 ((1 lrw))
675 rwork-%offset%)
676 nyh y iflag)
677 (declare (ignore var-0 var-1 var-2 var-3 var-4))
678 (setf iflag var-5))
679 (setf t$ tout)
680 (go label420)
681 label345
682 (setf hmx (+ (abs tn) (abs h)))
683 (setf ihit (<= (abs (- tn tcrit)) (* 100.0d0 uround hmx)))
684 (if ihit (go label400))
685 (setf tnext (+ tn (* h (+ 1.0d0 (* 4.0d0 uround)))))
686 (if (<= (* (- tnext tcrit) h) 0.0d0) (go label250))
687 (setf h (* (- tcrit tn) (- 1.0d0 (* 4.0d0 uround))))
688 (setf jstart -2)
689 (go label250)
690 label350
691 (setf hmx (+ (abs tn) (abs h)))
692 (setf ihit (<= (abs (- tn tcrit)) (* 100.0d0 uround hmx)))
693 label400
694 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
695 ((> i n) nil)
696 (tagbody
697 label410
698 (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%)
699 (f2cl-lib:fref rwork-%data%
700 ((f2cl-lib:int-sub
701 (f2cl-lib:int-add i lyh)
702 1))
703 ((1 lrw))
704 rwork-%offset%))))
705 (setf t$ tn)
706 (if (and (/= itask 4) (/= itask 5)) (go label420))
707 (if ihit (setf t$ tcrit))
708 label420
709 (setf istate 2)
710 (if (= kflag -3) (setf istate 3))
711 (setf (f2cl-lib:fref rwork-%data% (11) ((1 lrw)) rwork-%offset%)
712 hu)
713 (setf (f2cl-lib:fref rwork-%data% (12) ((1 lrw)) rwork-%offset%) h)
714 (setf (f2cl-lib:fref rwork-%data% (13) ((1 lrw)) rwork-%offset%)
715 tn)
716 (setf (f2cl-lib:fref iwork-%data% (11) ((1 liw)) iwork-%offset%)
717 nst)
718 (setf (f2cl-lib:fref iwork-%data% (12) ((1 liw)) iwork-%offset%)
719 nfe)
720 (setf (f2cl-lib:fref iwork-%data% (13) ((1 liw)) iwork-%offset%)
721 nje)
722 (setf (f2cl-lib:fref iwork-%data% (14) ((1 liw)) iwork-%offset%)
723 nqu)
724 (setf (f2cl-lib:fref iwork-%data% (15) ((1 liw)) iwork-%offset%)
725 nq)
726 (go end_label)
727 label500
728 (f2cl-lib:f2cl-set-string msg
729 "DLSODI- At current T (=R1), MXSTEP (=I1) steps "
730 (string 60))
731 (xerrwd msg 50 201 0 0 0 0 0 0.0d0 0.0d0)
732 (f2cl-lib:f2cl-set-string msg
733 " taken on this call before reaching TOUT "
734 (string 60))
735 (xerrwd msg 50 201 0 1 mxstep 0 1 tn 0.0d0)
736 (setf istate -1)
737 (go label580)
738 label510
739 (setf ewti
740 (f2cl-lib:fref rwork-%data%
741 ((f2cl-lib:int-sub (f2cl-lib:int-add lewt i)
742 1))
743 ((1 lrw))
744 rwork-%offset%))
745 (f2cl-lib:f2cl-set-string msg
746 "DLSODI- At T (=R1), EWT(I1) has become R2 <= 0."
747 (string 60))
748 (xerrwd msg 50 202 0 1 i 0 2 tn ewti)
749 (setf istate -6)
750 (go label590)
751 label520
752 (f2cl-lib:f2cl-set-string msg
753 "DLSODI- At T (=R1), too much accuracy requested "
754 (string 60))
755 (xerrwd msg 50 203 0 0 0 0 0 0.0d0 0.0d0)
756 (f2cl-lib:f2cl-set-string msg
757 " for precision of machine.. See TOLSF (=R2) "
758 (string 60))
759 (xerrwd msg 50 203 0 0 0 0 2 tn tolsf)
760 (setf (f2cl-lib:fref rwork-%data% (14) ((1 lrw)) rwork-%offset%)
761 tolsf)
762 (setf istate -2)
763 (go label590)
764 label530
765 (f2cl-lib:f2cl-set-string msg
766 "DLSODI- At T(=R1) and step size H(=R2), the error"
767 (string 60))
768 (xerrwd msg 50 204 0 0 0 0 0 0.0d0 0.0d0)
769 (f2cl-lib:f2cl-set-string msg
770 " test failed repeatedly or with ABS(H) = HMIN"
771 (string 60))
772 (xerrwd msg 50 204 0 0 0 0 2 tn h)
773 (setf istate -4)
774 (go label570)
775 label540
776 (f2cl-lib:f2cl-set-string msg
777 "DLSODI- At T (=R1) and step size H (=R2), the "
778 (string 60))
779 (xerrwd msg 50 205 0 0 0 0 0 0.0d0 0.0d0)
780 (f2cl-lib:f2cl-set-string msg
781 " corrector convergence failed repeatedly "
782 (string 60))
783 (xerrwd msg 50 205 0 0 0 0 0 0.0d0 0.0d0)
784 (f2cl-lib:f2cl-set-string msg
785 " or with ABS(H) = HMIN "
786 (string 60))
787 (xerrwd msg 30 205 0 0 0 0 2 tn h)
788 (setf istate -5)
789 (go label570)
790 label550
791 (f2cl-lib:f2cl-set-string msg
792 "DLSODI- At T (=R1) residual routine returned "
793 (string 60))
794 (xerrwd msg 50 206 0 0 0 0 0 0.0d0 0.0d0)
795 (f2cl-lib:f2cl-set-string msg
796 " error IRES = 3 repeatedly. "
797 (string 60))
798 (xerrwd msg 40 206 0 0 0 0 1 tn 0.0d0)
799 (setf istate -7)
800 (go label590)
801 label560
802 (setf ier (f2cl-lib:int-sub ier))
803 (f2cl-lib:f2cl-set-string msg
804 "DLSODI- Attempt to initialize dy/dt failed: Matrix A is "
805 (string 60))
806 (xerrwd msg 60 207 0 0 0 0 0 0.0d0 0.0d0)
807 (f2cl-lib:f2cl-set-string msg
808 " singular. DGEFA or DGBFA returned INFO = I1"
809 (string 60))
810 (xerrwd msg 50 207 0 1 ier 0 0 0.0d0 0.0d0)
811 (setf istate -8)
812 (go end_label)
813 label565
814 (f2cl-lib:f2cl-set-string msg
815 "DLSODI- Attempt to initialize dy/dt failed "
816 (string 60))
817 (xerrwd msg 50 208 0 0 0 0 0 0.0d0 0.0d0)
818 (f2cl-lib:f2cl-set-string msg
819 " because residual routine set its error flag "
820 (string 60))
821 (xerrwd msg 50 208 0 0 0 0 0 0.0d0 0.0d0)
822 (f2cl-lib:f2cl-set-string msg " to IRES = (I1)" (string 60))
823 (xerrwd msg 20 208 0 1 ier 0 0 0.0d0 0.0d0)
824 (setf istate -8)
825 (go end_label)
826 label570
827 (setf big 0.0d0)
828 (setf imxer 1)
829 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
830 ((> i n) nil)
831 (tagbody
832 (setf size
833 (abs
834 (*
835 (f2cl-lib:fref rwork-%data%
836 ((f2cl-lib:int-sub
837 (f2cl-lib:int-add i lacor)
838 1))
839 ((1 lrw))
840 rwork-%offset%)
841 (f2cl-lib:fref rwork-%data%
842 ((f2cl-lib:int-sub
843 (f2cl-lib:int-add i lewt)
844 1))
845 ((1 lrw))
846 rwork-%offset%))))
847 (if (>= big size) (go label575))
848 (setf big size)
849 (setf imxer i)
850 label575))
851 (setf (f2cl-lib:fref iwork-%data% (16) ((1 liw)) iwork-%offset%)
852 imxer)
853 label580
854 (setf lyd0 (f2cl-lib:int-add lyh nyh))
855 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
856 ((> i n) nil)
857 (tagbody
858 (setf (f2cl-lib:fref rwork-%data%
859 ((f2cl-lib:int-sub
860 (f2cl-lib:int-add i lsavf)
861 1))
862 ((1 lrw))
863 rwork-%offset%)
864 (/
865 (f2cl-lib:fref rwork-%data%
866 ((f2cl-lib:int-sub
867 (f2cl-lib:int-add i lyd0)
868 1))
869 ((1 lrw))
870 rwork-%offset%)
871 h))
872 label585
873 (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%)
874 (f2cl-lib:fref rwork-%data%
875 ((f2cl-lib:int-sub
876 (f2cl-lib:int-add i lyh)
877 1))
878 ((1 lrw))
879 rwork-%offset%))))
880 (setf ires 1)
881 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
882 (funcall res
883 neq
884 tn
885 y
886 (f2cl-lib:array-slice rwork-%data%
887 double-float
888 (lsavf)
889 ((1 lrw))
890 rwork-%offset%)
891 ydoti
892 ires)
893 (declare (ignore var-0 var-2 var-3 var-4))
894 (when var-1
895 (setf tn var-1))
896 (when var-5
897 (setf ires var-5)))
898 (setf nfe (f2cl-lib:int-add nfe 1))
899 (if (<= ires 1) (go label595))
900 (f2cl-lib:f2cl-set-string msg
901 "DLSODI- Residual routine set its flag IRES "
902 (string 60))
903 (xerrwd msg 50 210 0 0 0 0 0 0.0d0 0.0d0)
904 (f2cl-lib:f2cl-set-string msg
905 " to (I1) when called for final output. "
906 (string 60))
907 (xerrwd msg 50 210 0 1 ires 0 0 0.0d0 0.0d0)
908 (go label595)
909 label590
910 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
911 ((> i n) nil)
912 (tagbody
913 label592
914 (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%)
915 (f2cl-lib:fref rwork-%data%
916 ((f2cl-lib:int-sub
917 (f2cl-lib:int-add i lyh)
918 1))
919 ((1 lrw))
920 rwork-%offset%))))
921 label595
922 (setf t$ tn)
923 (setf (f2cl-lib:fref rwork-%data% (11) ((1 lrw)) rwork-%offset%)
924 hu)
925 (setf (f2cl-lib:fref rwork-%data% (12) ((1 lrw)) rwork-%offset%) h)
926 (setf (f2cl-lib:fref rwork-%data% (13) ((1 lrw)) rwork-%offset%)
927 tn)
928 (setf (f2cl-lib:fref iwork-%data% (11) ((1 liw)) iwork-%offset%)
929 nst)
930 (setf (f2cl-lib:fref iwork-%data% (12) ((1 liw)) iwork-%offset%)
931 nfe)
932 (setf (f2cl-lib:fref iwork-%data% (13) ((1 liw)) iwork-%offset%)
933 nje)
934 (setf (f2cl-lib:fref iwork-%data% (14) ((1 liw)) iwork-%offset%)
935 nqu)
936 (setf (f2cl-lib:fref iwork-%data% (15) ((1 liw)) iwork-%offset%)
937 nq)
938 (go end_label)
939 label601
940 (f2cl-lib:f2cl-set-string msg
941 "DLSODI- ISTATE (=I1) illegal."
942 (string 60))
943 (xerrwd msg 30 1 0 1 istate 0 0 0.0d0 0.0d0)
944 (if (< istate 0) (go label800))
945 (go label700)
946 label602
947 (f2cl-lib:f2cl-set-string msg
948 "DLSODI- ITASK (=I1) illegal. "
949 (string 60))
950 (xerrwd msg 30 2 0 1 itask 0 0 0.0d0 0.0d0)
951 (go label700)
952 label603
953 (f2cl-lib:f2cl-set-string msg
954 "DLSODI- ISTATE > 1 but DLSODI not initialized."
955 (string 60))
956 (xerrwd msg 50 3 0 0 0 0 0 0.0d0 0.0d0)
957 (go label700)
958 label604
959 (f2cl-lib:f2cl-set-string msg
960 "DLSODI- NEQ (=I1) < 1 "
961 (string 60))
962 (xerrwd msg 30 4 0 1
963 (f2cl-lib:fref neq-%data% (1) ((1 *)) neq-%offset%) 0 0 0.0d0
964 0.0d0)
965 (go label700)
966 label605
967 (f2cl-lib:f2cl-set-string msg
968 "DLSODI- ISTATE = 3 and NEQ increased (I1 to I2). "
969 (string 60))
970 (xerrwd msg 50 5 0 2 n
971 (f2cl-lib:fref neq-%data% (1) ((1 *)) neq-%offset%) 0 0.0d0 0.0d0)
972 (go label700)
973 label606
974 (f2cl-lib:f2cl-set-string msg
975 "DLSODI- ITOL (=I1) illegal. "
976 (string 60))
977 (xerrwd msg 30 6 0 1 itol 0 0 0.0d0 0.0d0)
978 (go label700)
979 label607
980 (f2cl-lib:f2cl-set-string msg
981 "DLSODI- IOPT (=I1) illegal. "
982 (string 60))
983 (xerrwd msg 30 7 0 1 iopt 0 0 0.0d0 0.0d0)
984 (go label700)
985 label608
986 (f2cl-lib:f2cl-set-string msg
987 "DLSODI- MF (=I1) illegal. "
988 (string 60))
989 (xerrwd msg 30 8 0 1 mf 0 0 0.0d0 0.0d0)
990 (go label700)
991 label609
992 (f2cl-lib:f2cl-set-string msg
993 "DLSODI- ML(=I1) illegal: < 0 or >= NEQ(=I2) "
994 (string 60))
995 (xerrwd msg 50 9 0 2 ml
996 (f2cl-lib:fref neq-%data% (1) ((1 *)) neq-%offset%) 0 0.0d0 0.0d0)
997 (go label700)
998 label610
999 (f2cl-lib:f2cl-set-string msg
1000 "DLSODI- MU(=I1) illegal: < 0 or >= NEQ(=I2) "
1001 (string 60))
1002 (xerrwd msg 50 10 0 2 mu
1003 (f2cl-lib:fref neq-%data% (1) ((1 *)) neq-%offset%) 0 0.0d0 0.0d0)
1004 (go label700)
1005 label611
1006 (f2cl-lib:f2cl-set-string msg
1007 "DLSODI- MAXORD (=I1) < 0 "
1008 (string 60))
1009 (xerrwd msg 30 11 0 1 maxord 0 0 0.0d0 0.0d0)
1010 (go label700)
1011 label612
1012 (f2cl-lib:f2cl-set-string msg
1013 "DLSODI- MXSTEP (=I1) < 0 "
1014 (string 60))
1015 (xerrwd msg 30 12 0 1 mxstep 0 0 0.0d0 0.0d0)
1016 (go label700)
1017 label613
1018 (f2cl-lib:f2cl-set-string msg
1019 "DLSODI- MXHNIL (=I1) < 0 "
1020 (string 60))
1021 (xerrwd msg 30 13 0 1 mxhnil 0 0 0.0d0 0.0d0)
1022 (go label700)
1023 label614
1024 (f2cl-lib:f2cl-set-string msg
1025 "DLSODI- TOUT (=R1) behind T (=R2) "
1026 (string 60))
1027 (xerrwd msg 40 14 0 0 0 0 2 tout t$)
1028 (f2cl-lib:f2cl-set-string msg
1029 " Integration direction is given by H0 (=R1) "
1030 (string 60))
1031 (xerrwd msg 50 14 0 0 0 0 1 h0 0.0d0)
1032 (go label700)
1033 label615
1034 (f2cl-lib:f2cl-set-string msg
1035 "DLSODI- HMAX (=R1) < 0.0 "
1036 (string 60))
1037 (xerrwd msg 30 15 0 0 0 0 1 hmax 0.0d0)
1038 (go label700)
1039 label616
1040 (f2cl-lib:f2cl-set-string msg
1041 "DLSODI- HMIN (=R1) < 0.0 "
1042 (string 60))
1043 (xerrwd msg 30 16 0 0 0 0 1 hmin 0.0d0)
1044 (go label700)
1045 label617
1046 (f2cl-lib:f2cl-set-string msg
1047 "DLSODI- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)"
1048 (string 60))
1049 (xerrwd msg 60 17 0 2 lenrw lrw 0 0.0d0 0.0d0)
1050 (go label700)
1051 label618
1052 (f2cl-lib:f2cl-set-string msg
1053 "DLSODI- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)"
1054 (string 60))
1055 (xerrwd msg 60 18 0 2 leniw liw 0 0.0d0 0.0d0)
1056 (go label700)
1057 label619
1058 (f2cl-lib:f2cl-set-string msg
1059 "DLSODI- RTOL(=I1) is R1 < 0.0 "
1060 (string 60))
1061 (xerrwd msg 40 19 0 1 i 0 1 rtoli 0.0d0)
1062 (go label700)
1063 label620
1064 (f2cl-lib:f2cl-set-string msg
1065 "DLSODI- ATOL(=I1) is R1 < 0.0 "
1066 (string 60))
1067 (xerrwd msg 40 20 0 1 i 0 1 atoli 0.0d0)
1068 (go label700)
1069 label621
1070 (setf ewti
1071 (f2cl-lib:fref rwork-%data%
1072 ((f2cl-lib:int-sub (f2cl-lib:int-add lewt i)
1073 1))
1074 ((1 lrw))
1075 rwork-%offset%))
1076 (f2cl-lib:f2cl-set-string msg
1077 "DLSODI- EWT(I1) is R1 <= 0.0 "
1078 (string 60))
1079 (xerrwd msg 40 21 0 1 i 0 1 ewti 0.0d0)
1080 (go label700)
1081 label622
1082 (f2cl-lib:f2cl-set-string msg
1083 "DLSODI- TOUT(=R1) too close to T(=R2) to start integration."
1084 (string 60))
1085 (xerrwd msg 60 22 0 0 0 0 2 tout t$)
1086 (go label700)
1087 label623
1088 (f2cl-lib:f2cl-set-string msg
1089 "DLSODI- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) "
1090 (string 60))
1091 (xerrwd msg 60 23 0 1 itask 0 2 tout tp)
1092 (go label700)
1093 label624
1094 (f2cl-lib:f2cl-set-string msg
1095 "DLSODI- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) "
1096 (string 60))
1097 (xerrwd msg 60 24 0 0 0 0 2 tcrit tn)
1098 (go label700)
1099 label625
1100 (f2cl-lib:f2cl-set-string msg
1101 "DLSODI- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) "
1102 (string 60))
1103 (xerrwd msg 60 25 0 0 0 0 2 tcrit tout)
1104 (go label700)
1105 label626
1106 (f2cl-lib:f2cl-set-string msg
1107 "DLSODI- At start of problem, too much accuracy "
1108 (string 60))
1109 (xerrwd msg 50 26 0 0 0 0 0 0.0d0 0.0d0)
1110 (f2cl-lib:f2cl-set-string msg
1111 " requested for precision of machine.. See TOLSF (=R1) "
1112 (string 60))
1113 (xerrwd msg 60 26 0 0 0 0 1 tolsf 0.0d0)
1114 (setf (f2cl-lib:fref rwork-%data% (14) ((1 lrw)) rwork-%offset%)
1115 tolsf)
1116 (go label700)
1117 label627
1118 (f2cl-lib:f2cl-set-string msg
1119 "DLSODI- Trouble in DINTDY. ITASK = I1, TOUT = R1"
1120 (string 60))
1121 (xerrwd msg 50 27 0 1 itask 0 1 tout 0.0d0)
1122 label700
1123 (setf istate -3)
1124 (go end_label)
1125 label800
1126 (f2cl-lib:f2cl-set-string msg
1127 "DLSODI- Run aborted.. apparent infinite loop. "
1128 (string 60))
1129 (xerrwd msg 50 303 2 0 0 0 0 0.0d0 0.0d0)
1130 (go end_label)
1131 end_label
1132 (return
1133 (values nil
1134 nil
1135 nil
1136 nil
1137 nil
1138 nil
1139 t$
1140 nil
1141 nil
1142 nil
1143 nil
1144 nil
1145 istate
1146 nil
1147 nil
1148 nil
1149 nil
1150 nil
1151 nil))))))))
1152
1153 (in-package #:cl-user)
1154 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
1155 (eval-when (:load-toplevel :compile-toplevel :execute)
1156 (setf (gethash 'fortran-to-lisp::dlsodi
1157 fortran-to-lisp::*f2cl-function-info*)
1158 (fortran-to-lisp::make-f2cl-finfo
1159 :arg-types '(t t t (array fortran-to-lisp::integer4 (*))
1160 (array double-float (*)) (array double-float (*))
1161 (double-float) (double-float)
1162 (fortran-to-lisp::integer4) (array double-float (*))
1163 (array double-float (*)) (fortran-to-lisp::integer4)
1164 (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
1165 (array double-float (*)) (fortran-to-lisp::integer4)
1166 (array fortran-to-lisp::integer4 (*))
1167 (fortran-to-lisp::integer4)
1168 (fortran-to-lisp::integer4))
1169 :return-values '(nil nil nil nil nil nil fortran-to-lisp::t$ nil nil
1170 nil nil nil fortran-to-lisp::istate nil nil nil nil
1171 nil nil)
1172 :calls '(fortran-to-lisp::dstodi fortran-to-lisp::xerrwd
1173 fortran-to-lisp::dintdy fortran-to-lisp::dvnorm
1174 fortran-to-lisp::dewset fortran-to-lisp::dainvg))))
1175
Maxima, a Computer Algebra System