?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
fixes typos and a missing reference.
[maxima.git] / share / odepack / src / nnfc.lisp
blob00f77285d57f56df73a57c0a4bb68f13fc64905a
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 (defun nnfc
21 (n r c ic ia ja a z b lmax il jl ijl l d umax iu ju iju u row tmp irl
22 jrl flag)
23 (declare (type (array double-float (*)) tmp row u d l b z a)
24 (type (array f2cl-lib:integer4 (*)) jrl irl iju ju iu ijl jl il ja
25 ia ic c r)
26 (type (f2cl-lib:integer4) flag umax lmax n))
27 (f2cl-lib:with-multi-array-data
28 ((r f2cl-lib:integer4 r-%data% r-%offset%)
29 (c f2cl-lib:integer4 c-%data% c-%offset%)
30 (ic f2cl-lib:integer4 ic-%data% ic-%offset%)
31 (ia f2cl-lib:integer4 ia-%data% ia-%offset%)
32 (ja f2cl-lib:integer4 ja-%data% ja-%offset%)
33 (il f2cl-lib:integer4 il-%data% il-%offset%)
34 (jl f2cl-lib:integer4 jl-%data% jl-%offset%)
35 (ijl f2cl-lib:integer4 ijl-%data% ijl-%offset%)
36 (iu f2cl-lib:integer4 iu-%data% iu-%offset%)
37 (ju f2cl-lib:integer4 ju-%data% ju-%offset%)
38 (iju f2cl-lib:integer4 iju-%data% iju-%offset%)
39 (irl f2cl-lib:integer4 irl-%data% irl-%offset%)
40 (jrl f2cl-lib:integer4 jrl-%data% jrl-%offset%)
41 (a double-float a-%data% a-%offset%)
42 (z double-float z-%data% z-%offset%)
43 (b double-float b-%data% b-%offset%)
44 (l double-float l-%data% l-%offset%)
45 (d double-float d-%data% d-%offset%)
46 (u double-float u-%data% u-%offset%)
47 (row double-float row-%data% row-%offset%)
48 (tmp double-float tmp-%data% tmp-%offset%))
49 (prog ((lki 0.0d0) (sum 0.0d0) (dk 0.0d0) (rk 0) (ijlb 0) (mu 0) (j 0)
50 (jmax 0) (jmin 0) (i2 0) (i 0) (i1 0) (k 0))
51 (declare (type (f2cl-lib:integer4) k i1 i i2 jmin jmax j mu ijlb rk)
52 (type (double-float) dk sum lki))
53 (if
54 (>
55 (f2cl-lib:int-sub
56 (f2cl-lib:fref il-%data% ((f2cl-lib:int-add n 1)) ((1 *)) il-%offset%)
57 1)
58 lmax)
59 (go label104))
60 (if
61 (>
62 (f2cl-lib:int-sub
63 (f2cl-lib:fref iu-%data% ((f2cl-lib:int-add n 1)) ((1 *)) iu-%offset%)
64 1)
65 umax)
66 (go label107))
67 (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
68 ((> k n) nil)
69 (tagbody
70 (setf (f2cl-lib:fref irl-%data% (k) ((1 *)) irl-%offset%)
71 (f2cl-lib:fref il-%data% (k) ((1 *)) il-%offset%))
72 (setf (f2cl-lib:fref jrl-%data% (k) ((1 *)) jrl-%offset%) 0)
73 label1))
74 (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
75 ((> k n) nil)
76 (tagbody
77 (setf (f2cl-lib:fref row-%data% (k) ((1 *)) row-%offset%)
78 (coerce (the f2cl-lib:integer4 0) 'double-float))
79 (setf i1 0)
80 (if (= (f2cl-lib:fref jrl-%data% (k) ((1 *)) jrl-%offset%) 0)
81 (go label3))
82 (setf i (f2cl-lib:fref jrl-%data% (k) ((1 *)) jrl-%offset%))
83 label2
84 (setf i2 (f2cl-lib:fref jrl-%data% (i) ((1 *)) jrl-%offset%))
85 (setf (f2cl-lib:fref jrl-%data% (i) ((1 *)) jrl-%offset%) i1)
86 (setf i1 i)
87 (setf (f2cl-lib:fref row-%data% (i) ((1 *)) row-%offset%)
88 (coerce (the f2cl-lib:integer4 0) 'double-float))
89 (setf i i2)
90 (if (/= i 0) (go label2))
91 label3
92 (setf jmin (f2cl-lib:fref iju-%data% (k) ((1 *)) iju-%offset%))
93 (setf jmax
94 (f2cl-lib:int-sub
95 (f2cl-lib:int-add jmin
96 (f2cl-lib:fref iu-%data%
97 ((f2cl-lib:int-add k 1))
98 ((1 *))
99 iu-%offset%))
100 (f2cl-lib:fref iu-%data% (k) ((1 *)) iu-%offset%)
101 1))
102 (if (> jmin jmax) (go label5))
103 (f2cl-lib:fdo (j jmin (f2cl-lib:int-add j 1))
104 ((> j jmax) nil)
105 (tagbody
106 label4
107 (setf (f2cl-lib:fref row-%data%
108 ((f2cl-lib:fref ju (j) ((1 *))))
109 ((1 *))
110 row-%offset%)
111 (coerce (the f2cl-lib:integer4 0) 'double-float))))
112 label5
113 (setf rk (f2cl-lib:fref r-%data% (k) ((1 *)) r-%offset%))
114 (setf jmin (f2cl-lib:fref ia-%data% (rk) ((1 *)) ia-%offset%))
115 (setf jmax
116 (f2cl-lib:int-sub
117 (f2cl-lib:fref ia-%data%
118 ((f2cl-lib:int-add rk 1))
119 ((1 *))
120 ia-%offset%)
121 1))
122 (f2cl-lib:fdo (j jmin (f2cl-lib:int-add j 1))
123 ((> j jmax) nil)
124 (tagbody
125 (setf (f2cl-lib:fref row-%data%
126 ((f2cl-lib:fref ic
127 ((f2cl-lib:fref ja
128 (j)
129 ((1 *))))
130 ((1 *))))
131 ((1 *))
132 row-%offset%)
133 (f2cl-lib:fref a-%data% (j) ((1 *)) a-%offset%))
134 label6))
135 (setf sum (f2cl-lib:fref b-%data% (rk) ((1 *)) b-%offset%))
136 (setf i i1)
137 (if (= i 0) (go label10))
138 label7
139 (setf lki (- (f2cl-lib:fref row-%data% (i) ((1 *)) row-%offset%)))
140 (setf (f2cl-lib:fref l-%data%
141 ((f2cl-lib:fref irl (i) ((1 *))))
142 ((1 *))
143 l-%offset%)
144 (- lki))
145 (setf sum
146 (+ sum
147 (* lki
148 (f2cl-lib:fref tmp-%data% (i) ((1 *)) tmp-%offset%))))
149 (setf jmin (f2cl-lib:fref iu-%data% (i) ((1 *)) iu-%offset%))
150 (setf jmax
151 (f2cl-lib:int-sub
152 (f2cl-lib:fref iu-%data%
153 ((f2cl-lib:int-add i 1))
154 ((1 *))
155 iu-%offset%)
156 1))
157 (if (> jmin jmax) (go label9))
158 (setf mu
159 (f2cl-lib:int-sub
160 (f2cl-lib:fref iju-%data% (i) ((1 *)) iju-%offset%)
161 jmin))
162 (f2cl-lib:fdo (j jmin (f2cl-lib:int-add j 1))
163 ((> j jmax) nil)
164 (tagbody
165 label8
166 (setf (f2cl-lib:fref row-%data%
167 ((f2cl-lib:fref ju
168 ((f2cl-lib:int-add mu j))
169 ((1 *))))
170 ((1 *))
171 row-%offset%)
172 (+
173 (f2cl-lib:fref row-%data%
174 ((f2cl-lib:fref ju
175 ((f2cl-lib:int-add mu j))
176 ((1 *))))
177 ((1 *))
178 row-%offset%)
179 (* lki
180 (f2cl-lib:fref u-%data% (j) ((1 *)) u-%offset%))))))
181 label9
182 (setf i (f2cl-lib:fref jrl-%data% (i) ((1 *)) jrl-%offset%))
183 (if (/= i 0) (go label7))
184 label10
185 (if (= (f2cl-lib:fref row-%data% (k) ((1 *)) row-%offset%) 0.0d0)
186 (go label108))
187 (setf dk
188 (/ 1.0d0
189 (f2cl-lib:fref row-%data% (k) ((1 *)) row-%offset%)))
190 (setf (f2cl-lib:fref d-%data% (k) ((1 *)) d-%offset%) dk)
191 (setf (f2cl-lib:fref tmp-%data% (k) ((1 *)) tmp-%offset%) (* sum dk))
192 (if (= k n) (go label19))
193 (setf jmin (f2cl-lib:fref iu-%data% (k) ((1 *)) iu-%offset%))
194 (setf jmax
195 (f2cl-lib:int-sub
196 (f2cl-lib:fref iu-%data%
197 ((f2cl-lib:int-add k 1))
198 ((1 *))
199 iu-%offset%)
200 1))
201 (if (> jmin jmax) (go label12))
202 (setf mu
203 (f2cl-lib:int-sub
204 (f2cl-lib:fref iju-%data% (k) ((1 *)) iju-%offset%)
205 jmin))
206 (f2cl-lib:fdo (j jmin (f2cl-lib:int-add j 1))
207 ((> j jmax) nil)
208 (tagbody
209 label11
210 (setf (f2cl-lib:fref u-%data% (j) ((1 *)) u-%offset%)
211 (*
212 (f2cl-lib:fref row-%data%
213 ((f2cl-lib:fref ju
214 ((f2cl-lib:int-add mu j))
215 ((1 *))))
216 ((1 *))
217 row-%offset%)
218 dk))))
219 label12
220 (setf i i1)
221 (if (= i 0) (go label18))
222 label14
223 (setf (f2cl-lib:fref irl-%data% (i) ((1 *)) irl-%offset%)
224 (f2cl-lib:int-add
225 (f2cl-lib:fref irl-%data% (i) ((1 *)) irl-%offset%)
226 1))
227 (setf i1 (f2cl-lib:fref jrl-%data% (i) ((1 *)) jrl-%offset%))
228 (if
229 (>= (f2cl-lib:fref irl-%data% (i) ((1 *)) irl-%offset%)
230 (f2cl-lib:fref il-%data%
231 ((f2cl-lib:int-add i 1))
232 ((1 *))
233 il-%offset%))
234 (go label17))
235 (setf ijlb
236 (f2cl-lib:int-add
237 (f2cl-lib:int-sub
238 (f2cl-lib:fref irl-%data% (i) ((1 *)) irl-%offset%)
239 (f2cl-lib:fref il-%data% (i) ((1 *)) il-%offset%))
240 (f2cl-lib:fref ijl-%data% (i) ((1 *)) ijl-%offset%)))
241 (setf j (f2cl-lib:fref jl-%data% (ijlb) ((1 *)) jl-%offset%))
242 label15
243 (if (> i (f2cl-lib:fref jrl-%data% (j) ((1 *)) jrl-%offset%))
244 (go label16))
245 (setf j (f2cl-lib:fref jrl-%data% (j) ((1 *)) jrl-%offset%))
246 (go label15)
247 label16
248 (setf (f2cl-lib:fref jrl-%data% (i) ((1 *)) jrl-%offset%)
249 (f2cl-lib:fref jrl-%data% (j) ((1 *)) jrl-%offset%))
250 (setf (f2cl-lib:fref jrl-%data% (j) ((1 *)) jrl-%offset%) i)
251 label17
252 (setf i i1)
253 (if (/= i 0) (go label14))
254 label18
255 (if
256 (>= (f2cl-lib:fref irl-%data% (k) ((1 *)) irl-%offset%)
257 (f2cl-lib:fref il-%data%
258 ((f2cl-lib:int-add k 1))
259 ((1 *))
260 il-%offset%))
261 (go label19))
262 (setf j
263 (f2cl-lib:fref jl-%data%
264 ((f2cl-lib:fref ijl (k) ((1 *))))
265 ((1 *))
266 jl-%offset%))
267 (setf (f2cl-lib:fref jrl-%data% (k) ((1 *)) jrl-%offset%)
268 (f2cl-lib:fref jrl-%data% (j) ((1 *)) jrl-%offset%))
269 (setf (f2cl-lib:fref jrl-%data% (j) ((1 *)) jrl-%offset%) k)
270 label19))
271 (setf k n)
272 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
273 ((> i n) nil)
274 (tagbody
275 (setf sum (f2cl-lib:fref tmp-%data% (k) ((1 *)) tmp-%offset%))
276 (setf jmin (f2cl-lib:fref iu-%data% (k) ((1 *)) iu-%offset%))
277 (setf jmax
278 (f2cl-lib:int-sub
279 (f2cl-lib:fref iu-%data%
280 ((f2cl-lib:int-add k 1))
281 ((1 *))
282 iu-%offset%)
283 1))
284 (if (> jmin jmax) (go label21))
285 (setf mu
286 (f2cl-lib:int-sub
287 (f2cl-lib:fref iju-%data% (k) ((1 *)) iju-%offset%)
288 jmin))
289 (f2cl-lib:fdo (j jmin (f2cl-lib:int-add j 1))
290 ((> j jmax) nil)
291 (tagbody
292 label20
293 (setf sum
294 (- sum
295 (* (f2cl-lib:fref u-%data% (j) ((1 *)) u-%offset%)
296 (f2cl-lib:fref tmp-%data%
297 ((f2cl-lib:fref ju
298 ((f2cl-lib:int-add
299 mu
300 j))
301 ((1 *))))
302 ((1 *))
303 tmp-%offset%))))))
304 label21
305 (setf (f2cl-lib:fref tmp-%data% (k) ((1 *)) tmp-%offset%) sum)
306 (setf (f2cl-lib:fref z-%data%
307 ((f2cl-lib:fref c (k) ((1 *))))
308 ((1 *))
309 z-%offset%)
310 sum)
311 label22
312 (setf k (f2cl-lib:int-sub k 1))))
313 (setf flag 0)
314 (go end_label)
315 label104
316 (setf flag (f2cl-lib:int-add (f2cl-lib:int-mul 4 n) 1))
317 (go end_label)
318 label107
319 (setf flag (f2cl-lib:int-add (f2cl-lib:int-mul 7 n) 1))
320 (go end_label)
321 label108
322 (setf flag (f2cl-lib:int-add (f2cl-lib:int-mul 8 n) k))
323 (go end_label)
324 end_label
325 (return
326 (values nil
327 nil
328 nil
329 nil
330 nil
331 nil
332 nil
333 nil
334 nil
335 nil
336 nil
337 nil
338 nil
339 nil
340 nil
341 nil
342 nil
343 nil
344 nil
345 nil
346 nil
347 nil
348 nil
349 nil
350 flag)))))
351
352 (in-package #-gcl #:cl-user #+gcl "CL-USER")
353 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
354 (eval-when (:load-toplevel :compile-toplevel :execute)
355 (setf (gethash 'fortran-to-lisp::nnfc fortran-to-lisp::*f2cl-function-info*)
356 (fortran-to-lisp::make-f2cl-finfo
357 :arg-types '((fortran-to-lisp::integer4)
358 (array fortran-to-lisp::integer4 (*))
359 (array fortran-to-lisp::integer4 (*))
360 (array fortran-to-lisp::integer4 (*))
361 (array fortran-to-lisp::integer4 (*))
362 (array fortran-to-lisp::integer4 (*))
363 (array double-float (*)) (array double-float (*))
364 (array double-float (*)) (fortran-to-lisp::integer4)
365 (array fortran-to-lisp::integer4 (*))
366 (array fortran-to-lisp::integer4 (*))
367 (array fortran-to-lisp::integer4 (*))
368 (array double-float (*)) (array double-float (*))
369 (fortran-to-lisp::integer4)
370 (array fortran-to-lisp::integer4 (*))
371 (array fortran-to-lisp::integer4 (*))
372 (array fortran-to-lisp::integer4 (*))
373 (array double-float (*)) (array double-float (*))
374 (array double-float (*))
375 (array fortran-to-lisp::integer4 (*))
376 (array fortran-to-lisp::integer4 (*))
377 (fortran-to-lisp::integer4))
378 :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil
379 nil nil nil nil nil nil nil nil nil nil nil
380 fortran-to-lisp::flag)
381 :calls 'nil)))
382
Maxima, a Computer Algebra System