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