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