?  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 / cdrv.lisp
blob7b3963a1175ecc9c216569658dfdb6f3c1ffd904
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 ((lratio 2))
21 (declare (type (f2cl-lib:integer4) lratio))
22 (defun cdrv (n r c ic ia ja a b z nsp isp rsp esp path flag)
23 (declare (type (array double-float (*)) rsp z b a)
24 (type (array f2cl-lib:integer4 (*)) isp ja ia ic c r)
25 (type (f2cl-lib:integer4) flag path esp nsp n))
26 (f2cl-lib:with-multi-array-data
27 ((r f2cl-lib:integer4 r-%data% r-%offset%)
28 (c f2cl-lib:integer4 c-%data% c-%offset%)
29 (ic f2cl-lib:integer4 ic-%data% ic-%offset%)
30 (ia f2cl-lib:integer4 ia-%data% ia-%offset%)
31 (ja f2cl-lib:integer4 ja-%data% ja-%offset%)
32 (isp f2cl-lib:integer4 isp-%data% isp-%offset%)
33 (a double-float a-%data% a-%offset%)
34 (b double-float b-%data% b-%offset%)
35 (z double-float z-%data% z-%offset%)
36 (rsp double-float rsp-%data% rsp-%offset%))
37 (prog ((d 0) (u 0) (q 0) (row 0) (tmp 0) (ar 0) (umax 0) (lmax 0) (l 0)
38 (j 0) (ju 0) (i 0) (jumax 0) (jutmp 0) (jru 0) (iru 0) (irac 0)
39 (jra 0) (ira 0) (jlmax 0) (max (the f2cl-lib:integer4 0)) (jl 0)
40 (jrl 0) (irl 0) (iju 0) (iu 0) (ijl 0) (il 0))
41 (declare (type (f2cl-lib:integer4) il ijl iu iju irl jrl jl max jlmax
42 ira jra irac iru jru jutmp jumax i
43 ju j l lmax umax ar tmp row q u d))
44 (if (or (< path 1) (< 5 path)) (go label111))
45 (setf il 1)
46 (setf ijl (f2cl-lib:int-add il (f2cl-lib:int-add n 1)))
47 (setf iu (f2cl-lib:int-add ijl n))
48 (setf iju (f2cl-lib:int-add iu (f2cl-lib:int-add n 1)))
49 (setf irl (f2cl-lib:int-add iju n))
50 (setf jrl (f2cl-lib:int-add irl n))
51 (setf jl (f2cl-lib:int-add jrl n))
52 (if
53 (/=
54 (f2cl-lib:int-mul (f2cl-lib:int-sub path 1)
55 (f2cl-lib:int-sub path 5))
56 0)
57 (go label5))
58 (setf max
59 (f2cl-lib:int-sub
60 (f2cl-lib:int-add (f2cl-lib:int-mul lratio nsp) 1)
61 jl
62 (f2cl-lib:int-add n 1)
63 (f2cl-lib:int-mul 5 n)))
64 (setf jlmax (the f2cl-lib:integer4 (truncate max 2)))
65 (setf q (f2cl-lib:int-add jl jlmax))
66 (setf ira (f2cl-lib:int-add q (f2cl-lib:int-add n 1)))
67 (setf jra (f2cl-lib:int-add ira n))
68 (setf irac (f2cl-lib:int-add jra n))
69 (setf iru (f2cl-lib:int-add irac n))
70 (setf jru (f2cl-lib:int-add iru n))
71 (setf jutmp (f2cl-lib:int-add jru n))
72 (setf jumax
73 (f2cl-lib:int-sub
74 (f2cl-lib:int-add (f2cl-lib:int-mul lratio nsp) 1)
75 jutmp))
76 (setf esp (the f2cl-lib:integer4 (truncate max lratio)))
77 (if (or (<= jlmax 0) (<= jumax 0)) (go label110))
78 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
79 ((> i n) nil)
80 (tagbody
81 (if (/= (f2cl-lib:fref c-%data% (i) ((1 *)) c-%offset%) i)
82 (go label2))
83 label1))
84 (go label3)
85 label2
86 (setf ar (f2cl-lib:int-sub (f2cl-lib:int-add nsp 1) n))
87 (multiple-value-bind
88 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)
89 (nroc n ic ia ja a
90 (f2cl-lib:array-slice isp-%data%
91 f2cl-lib:integer4
92 (il)
93 ((1 *))
94 isp-%offset%)
95 (f2cl-lib:array-slice rsp-%data%
96 double-float
97 (ar)
98 ((1 *))
99 rsp-%offset%)
100 (f2cl-lib:array-slice isp-%data%
101 f2cl-lib:integer4
102 (iu)
103 ((1 *))
104 isp-%offset%)
105 flag)
106 (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7))
107 (setf flag var-8))
108 (if (/= flag 0) (go label100))
109 label3
110 (multiple-value-bind
111 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
112 var-10 var-11 var-12 var-13 var-14 var-15 var-16 var-17 var-18
113 var-19 var-20 var-21)
114 (nsfc n r ic ia ja jlmax
115 (f2cl-lib:array-slice isp-%data%
116 f2cl-lib:integer4
117 (il)
118 ((1 *))
119 isp-%offset%)
120 (f2cl-lib:array-slice isp-%data%
121 f2cl-lib:integer4
122 (jl)
123 ((1 *))
124 isp-%offset%)
125 (f2cl-lib:array-slice isp-%data%
126 f2cl-lib:integer4
127 (ijl)
128 ((1 *))
129 isp-%offset%)
130 jumax
131 (f2cl-lib:array-slice isp-%data%
132 f2cl-lib:integer4
133 (iu)
134 ((1 *))
135 isp-%offset%)
136 (f2cl-lib:array-slice isp-%data%
137 f2cl-lib:integer4
138 (jutmp)
139 ((1 *))
140 isp-%offset%)
141 (f2cl-lib:array-slice isp-%data%
142 f2cl-lib:integer4
143 (iju)
144 ((1 *))
145 isp-%offset%)
146 (f2cl-lib:array-slice isp-%data%
147 f2cl-lib:integer4
148 (q)
149 ((1 *))
150 isp-%offset%)
151 (f2cl-lib:array-slice isp-%data%
152 f2cl-lib:integer4
153 (ira)
154 ((1 *))
155 isp-%offset%)
156 (f2cl-lib:array-slice isp-%data%
157 f2cl-lib:integer4
158 (jra)
159 ((1 *))
160 isp-%offset%)
161 (f2cl-lib:array-slice isp-%data%
162 f2cl-lib:integer4
163 (irac)
164 ((1 *))
165 isp-%offset%)
166 (f2cl-lib:array-slice isp-%data%
167 f2cl-lib:integer4
168 (irl)
169 ((1 *))
170 isp-%offset%)
171 (f2cl-lib:array-slice isp-%data%
172 f2cl-lib:integer4
173 (jrl)
174 ((1 *))
175 isp-%offset%)
176 (f2cl-lib:array-slice isp-%data%
177 f2cl-lib:integer4
178 (iru)
179 ((1 *))
180 isp-%offset%)
181 (f2cl-lib:array-slice isp-%data%
182 f2cl-lib:integer4
183 (jru)
184 ((1 *))
185 isp-%offset%)
186 flag)
187 (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
188 var-8 var-9 var-10 var-11 var-12 var-13 var-14
189 var-15 var-16 var-17 var-18 var-19 var-20))
190 (setf flag var-21))
191 (if (/= flag 0) (go label100))
192 (setf jlmax
193 (f2cl-lib:fref isp-%data%
194 ((f2cl-lib:int-sub (f2cl-lib:int-add ijl n) 1))
195 ((1 *))
196 isp-%offset%))
197 (setf ju (f2cl-lib:int-add jl jlmax))
198 (setf jumax
199 (f2cl-lib:fref isp-%data%
200 ((f2cl-lib:int-sub (f2cl-lib:int-add iju n) 1))
201 ((1 *))
202 isp-%offset%))
203 (if (<= jumax 0) (go label5))
204 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
205 ((> j jumax) nil)
206 (tagbody
207 label4
208 (setf (f2cl-lib:fref isp-%data%
209 ((f2cl-lib:int-sub (f2cl-lib:int-add ju j) 1))
210 ((1 *))
211 isp-%offset%)
212 (f2cl-lib:fref isp-%data%
213 ((f2cl-lib:int-sub
214 (f2cl-lib:int-add jutmp j)
215 1))
216 ((1 *))
217 isp-%offset%))))
218 label5
219 (setf jlmax
220 (f2cl-lib:fref isp-%data%
221 ((f2cl-lib:int-sub (f2cl-lib:int-add ijl n) 1))
222 ((1 *))
223 isp-%offset%))
224 (setf ju (f2cl-lib:int-add jl jlmax))
225 (setf jumax
226 (f2cl-lib:fref isp-%data%
227 ((f2cl-lib:int-sub (f2cl-lib:int-add iju n) 1))
228 ((1 *))
229 isp-%offset%))
230 (setf l
231 (+
232 (the f2cl-lib:integer4
233 (truncate (+ (- (+ ju jumax) 2) lratio) lratio))
234 1))
235 (setf lmax
236 (f2cl-lib:int-sub
237 (f2cl-lib:fref isp-%data%
238 ((f2cl-lib:int-add il n))
239 ((1 *))
240 isp-%offset%)
241 1))
242 (setf d (f2cl-lib:int-add l lmax))
243 (setf u (f2cl-lib:int-add d n))
244 (setf row (f2cl-lib:int-sub (f2cl-lib:int-add nsp 1) n))
245 (setf tmp (f2cl-lib:int-sub row n))
246 (setf umax (f2cl-lib:int-sub tmp u))
247 (setf esp
248 (f2cl-lib:int-sub umax
249 (f2cl-lib:int-sub
250 (f2cl-lib:fref isp-%data%
251 ((f2cl-lib:int-add iu n))
252 ((1 *))
253 isp-%offset%)
254 1)))
255 (if
256 (/=
257 (f2cl-lib:int-mul (f2cl-lib:int-sub path 1)
258 (f2cl-lib:int-sub path 2))
259 0)
260 (go label6))
261 (if (< umax 0) (go label110))
262 (multiple-value-bind
263 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
264 var-10 var-11 var-12 var-13 var-14 var-15 var-16 var-17 var-18
265 var-19 var-20 var-21 var-22 var-23 var-24)
266 (nnfc n r c ic ia ja a z b lmax
267 (f2cl-lib:array-slice isp-%data%
268 f2cl-lib:integer4
269 (il)
270 ((1 *))
271 isp-%offset%)
272 (f2cl-lib:array-slice isp-%data%
273 f2cl-lib:integer4
274 (jl)
275 ((1 *))
276 isp-%offset%)
277 (f2cl-lib:array-slice isp-%data%
278 f2cl-lib:integer4
279 (ijl)
280 ((1 *))
281 isp-%offset%)
282 (f2cl-lib:array-slice rsp-%data%
283 double-float
284 (l)
285 ((1 *))
286 rsp-%offset%)
287 (f2cl-lib:array-slice rsp-%data%
288 double-float
289 (d)
290 ((1 *))
291 rsp-%offset%)
292 umax
293 (f2cl-lib:array-slice isp-%data%
294 f2cl-lib:integer4
295 (iu)
296 ((1 *))
297 isp-%offset%)
298 (f2cl-lib:array-slice isp-%data%
299 f2cl-lib:integer4
300 (ju)
301 ((1 *))
302 isp-%offset%)
303 (f2cl-lib:array-slice isp-%data%
304 f2cl-lib:integer4
305 (iju)
306 ((1 *))
307 isp-%offset%)
308 (f2cl-lib:array-slice rsp-%data%
309 double-float
310 (u)
311 ((1 *))
312 rsp-%offset%)
313 (f2cl-lib:array-slice rsp-%data%
314 double-float
315 (row)
316 ((1 *))
317 rsp-%offset%)
318 (f2cl-lib:array-slice rsp-%data%
319 double-float
320 (tmp)
321 ((1 *))
322 rsp-%offset%)
323 (f2cl-lib:array-slice isp-%data%
324 f2cl-lib:integer4
325 (irl)
326 ((1 *))
327 isp-%offset%)
328 (f2cl-lib:array-slice isp-%data%
329 f2cl-lib:integer4
330 (jrl)
331 ((1 *))
332 isp-%offset%)
333 flag)
334 (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
335 var-8 var-9 var-10 var-11 var-12 var-13 var-14
336 var-15 var-16 var-17 var-18 var-19 var-20 var-21
337 var-22 var-23))
338 (setf flag var-24))
339 (if (/= flag 0) (go label100))
340 label6
341 (if (/= (f2cl-lib:int-sub path 3) 0) (go label7))
342 (nnsc n r c
343 (f2cl-lib:array-slice isp-%data%
344 f2cl-lib:integer4
345 (il)
346 ((1 *))
347 isp-%offset%)
348 (f2cl-lib:array-slice isp-%data%
349 f2cl-lib:integer4
350 (jl)
351 ((1 *))
352 isp-%offset%)
353 (f2cl-lib:array-slice isp-%data%
354 f2cl-lib:integer4
355 (ijl)
356 ((1 *))
357 isp-%offset%)
358 (f2cl-lib:array-slice rsp-%data%
359 double-float
360 (l)
361 ((1 *))
362 rsp-%offset%)
363 (f2cl-lib:array-slice rsp-%data%
364 double-float
365 (d)
366 ((1 *))
367 rsp-%offset%)
368 (f2cl-lib:array-slice isp-%data%
369 f2cl-lib:integer4
370 (iu)
371 ((1 *))
372 isp-%offset%)
373 (f2cl-lib:array-slice isp-%data%
374 f2cl-lib:integer4
375 (ju)
376 ((1 *))
377 isp-%offset%)
378 (f2cl-lib:array-slice isp-%data%
379 f2cl-lib:integer4
380 (iju)
381 ((1 *))
382 isp-%offset%)
383 (f2cl-lib:array-slice rsp-%data%
384 double-float
385 (u)
386 ((1 *))
387 rsp-%offset%)
388 z b
389 (f2cl-lib:array-slice rsp-%data%
390 double-float
391 (tmp)
392 ((1 *))
393 rsp-%offset%))
394 label7
395 (if (/= (f2cl-lib:int-sub path 4) 0) (go label8))
396 (nntc n r c
397 (f2cl-lib:array-slice isp-%data%
398 f2cl-lib:integer4
399 (il)
400 ((1 *))
401 isp-%offset%)
402 (f2cl-lib:array-slice isp-%data%
403 f2cl-lib:integer4
404 (jl)
405 ((1 *))
406 isp-%offset%)
407 (f2cl-lib:array-slice isp-%data%
408 f2cl-lib:integer4
409 (ijl)
410 ((1 *))
411 isp-%offset%)
412 (f2cl-lib:array-slice rsp-%data%
413 double-float
414 (l)
415 ((1 *))
416 rsp-%offset%)
417 (f2cl-lib:array-slice rsp-%data%
418 double-float
419 (d)
420 ((1 *))
421 rsp-%offset%)
422 (f2cl-lib:array-slice isp-%data%
423 f2cl-lib:integer4
424 (iu)
425 ((1 *))
426 isp-%offset%)
427 (f2cl-lib:array-slice isp-%data%
428 f2cl-lib:integer4
429 (ju)
430 ((1 *))
431 isp-%offset%)
432 (f2cl-lib:array-slice isp-%data%
433 f2cl-lib:integer4
434 (iju)
435 ((1 *))
436 isp-%offset%)
437 (f2cl-lib:array-slice rsp-%data%
438 double-float
439 (u)
440 ((1 *))
441 rsp-%offset%)
442 z b
443 (f2cl-lib:array-slice rsp-%data%
444 double-float
445 (tmp)
446 ((1 *))
447 rsp-%offset%))
448 label8
449 (go end_label)
450 label100
451 (go end_label)
452 label110
453 (setf flag (f2cl-lib:int-add (f2cl-lib:int-mul 10 n) 1))
454 (go end_label)
455 label111
456 (setf flag (f2cl-lib:int-add (f2cl-lib:int-mul 11 n) 1))
457 (go end_label)
458 end_label
459 (return
460 (values nil
461 nil
462 nil
463 nil
464 nil
465 nil
466 nil
467 nil
468 nil
469 nil
470 nil
471 nil
472 esp
473 nil
474 flag))))))
475
476 (in-package #:cl-user)
477 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
478 (eval-when (:load-toplevel :compile-toplevel :execute)
479 (setf (gethash 'fortran-to-lisp::cdrv fortran-to-lisp::*f2cl-function-info*)
480 (fortran-to-lisp::make-f2cl-finfo
481 :arg-types '((fortran-to-lisp::integer4)
482 (array fortran-to-lisp::integer4 (*))
483 (array fortran-to-lisp::integer4 (*))
484 (array fortran-to-lisp::integer4 (*))
485 (array fortran-to-lisp::integer4 (*))
486 (array fortran-to-lisp::integer4 (*))
487 (array double-float (*)) (array double-float (*))
488 (array double-float (*)) (fortran-to-lisp::integer4)
489 (array fortran-to-lisp::integer4 (*))
490 (array double-float (*)) (fortran-to-lisp::integer4)
491 (fortran-to-lisp::integer4)
492 (fortran-to-lisp::integer4))
493 :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil
494 fortran-to-lisp::esp nil fortran-to-lisp::flag)
495 :calls '(fortran-to-lisp::nntc fortran-to-lisp::nnsc
496 fortran-to-lisp::nnfc fortran-to-lisp::nsfc
497 fortran-to-lisp::nroc))))
498
Maxima, a Computer Algebra System