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