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