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