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