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