In documentation for lreduce and rreduce, supply second argument as an explicit list
[maxima.git] / share / odepack / src / drchek.lisp
blob959a9e049f012a238de813993ef975fcc98470f3
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 $")
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))
17 (in-package "ODEPACK")
20 (defun drchek (job g neq y yh nyh g0 g1 gx jroot irt)
21 (declare (type (array double-float (*)) gx g1 g0 yh y)
22 (type (array f2cl-lib:integer4 (*)) jroot neq)
23 (type (f2cl-lib:integer4) irt nyh job))
24 (let ()
25 (symbol-macrolet ((h (aref (dls001-part-0 *dls001-common-block*) 211))
26 (tn (aref (dls001-part-0 *dls001-common-block*) 216))
27 (uround (aref (dls001-part-0 *dls001-common-block*) 217))
28 (n (aref (dls001-part-1 *dls001-common-block*) 31))
29 (t0 (aref (dlsr01-part-0 *dlsr01-common-block*) 2))
30 (tlast (aref (dlsr01-part-0 *dlsr01-common-block*) 3))
31 (toutc (aref (dlsr01-part-0 *dlsr01-common-block*) 4))
32 (irfnd (aref (dlsr01-part-1 *dlsr01-common-block*) 5))
33 (itaskc (aref (dlsr01-part-1 *dlsr01-common-block*) 6))
34 (ngc (aref (dlsr01-part-1 *dlsr01-common-block*) 7))
35 (nge (aref (dlsr01-part-1 *dlsr01-common-block*) 8)))
36 (f2cl-lib:with-multi-array-data
37 ((neq f2cl-lib:integer4 neq-%data% neq-%offset%)
38 (jroot f2cl-lib:integer4 jroot-%data% jroot-%offset%)
39 (y double-float y-%data% y-%offset%)
40 (yh double-float yh-%data% yh-%offset%)
41 (g0 double-float g0-%data% g0-%offset%)
42 (g1 double-float g1-%data% g1-%offset%)
43 (gx double-float gx-%data% gx-%offset%))
44 (prog ((jflag 0) (iflag 0) (i 0) (x 0.0d0) (temp2 0.0d0) (temp1 0.0d0)
45 (t1 0.0d0) (hming 0.0d0) (zroot nil))
46 (declare (type f2cl-lib:logical zroot)
47 (type (double-float) hming t1 temp1 temp2 x)
48 (type (f2cl-lib:integer4) i iflag jflag))
49 (setf irt 0)
50 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
51 ((> i ngc) nil)
52 (tagbody
53 label10
54 (setf (f2cl-lib:fref jroot-%data% (i) ((1 *)) jroot-%offset%)
55 0)))
56 (setf hming (* (+ (abs tn) (abs h)) uround 100.0d0))
57 (f2cl-lib:computed-goto (label100 label200 label300) job)
58 label100
59 (setf t0 tn)
60 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
61 (funcall g neq t0 y ngc g0)
62 (declare (ignore var-0 var-2 var-4))
63 (when var-1
64 (setf t0 var-1))
65 (when var-3
66 (setf ngc var-3)))
67 (setf nge 1)
68 (setf zroot f2cl-lib:%false%)
69 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
70 ((> i ngc) nil)
71 (tagbody
72 label110
73 (if
74 (<= (abs (f2cl-lib:fref g0-%data% (i) ((1 *)) g0-%offset%))
75 0.0d0)
76 (setf zroot f2cl-lib:%true%))))
77 (if (not zroot) (go label190))
78 (setf temp1 (f2cl-lib:sign hming h))
79 (setf t0 (+ t0 temp1))
80 (setf temp2 (/ temp1 h))
81 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
82 ((> i n) nil)
83 (tagbody
84 label120
85 (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%)
86 (+ (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%)
87 (* temp2
88 (f2cl-lib:fref yh-%data%
89 (i 2)
90 ((1 nyh) (1 *))
91 yh-%offset%))))))
92 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
93 (funcall g neq t0 y ngc g0)
94 (declare (ignore var-0 var-2 var-4))
95 (when var-1
96 (setf t0 var-1))
97 (when var-3
98 (setf ngc var-3)))
99 (setf nge (f2cl-lib:int-add nge 1))
100 (setf zroot f2cl-lib:%false%)
101 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
102 ((> i ngc) nil)
103 (tagbody
104 label130
106 (<= (abs (f2cl-lib:fref g0-%data% (i) ((1 *)) g0-%offset%))
107 0.0d0)
108 (setf zroot f2cl-lib:%true%))))
109 (if (not zroot) (go label190))
110 (setf irt -1)
111 (go end_label)
112 label190
113 (go end_label)
114 label200
115 (if (= irfnd 0) (go label260))
116 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
117 (dintdy t0 0 yh nyh y iflag)
118 (declare (ignore var-0 var-1 var-2 var-3 var-4))
119 (setf iflag var-5))
120 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
121 (funcall g neq t0 y ngc g0)
122 (declare (ignore var-0 var-2 var-4))
123 (when var-1
124 (setf t0 var-1))
125 (when var-3
126 (setf ngc var-3)))
127 (setf nge (f2cl-lib:int-add nge 1))
128 (setf zroot f2cl-lib:%false%)
129 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
130 ((> i ngc) nil)
131 (tagbody
132 label210
134 (<= (abs (f2cl-lib:fref g0-%data% (i) ((1 *)) g0-%offset%))
135 0.0d0)
136 (setf zroot f2cl-lib:%true%))))
137 (if (not zroot) (go label260))
138 (setf temp1 (f2cl-lib:sign hming h))
139 (setf t0 (+ t0 temp1))
140 (if (< (* (- t0 tn) h) 0.0d0) (go label230))
141 (setf temp2 (/ temp1 h))
142 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
143 ((> i n) nil)
144 (tagbody
145 label220
146 (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%)
147 (+ (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%)
148 (* temp2
149 (f2cl-lib:fref yh-%data%
150 (i 2)
151 ((1 nyh) (1 *))
152 yh-%offset%))))))
153 (go label240)
154 label230
155 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
156 (dintdy t0 0 yh nyh y iflag)
157 (declare (ignore var-0 var-1 var-2 var-3 var-4))
158 (setf iflag var-5))
159 label240
160 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
161 (funcall g neq t0 y ngc g0)
162 (declare (ignore var-0 var-2 var-4))
163 (when var-1
164 (setf t0 var-1))
165 (when var-3
166 (setf ngc var-3)))
167 (setf nge (f2cl-lib:int-add nge 1))
168 (setf zroot f2cl-lib:%false%)
169 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
170 ((> i ngc) nil)
171 (tagbody
173 (> (abs (f2cl-lib:fref g0-%data% (i) ((1 *)) g0-%offset%))
174 0.0d0)
175 (go label250))
176 (setf (f2cl-lib:fref jroot-%data% (i) ((1 *)) jroot-%offset%) 1)
177 (setf zroot f2cl-lib:%true%)
178 label250))
179 (if (not zroot) (go label260))
180 (setf irt 1)
181 (go end_label)
182 label260
183 (if (= tn tlast) (go label390))
184 label300
185 (if (or (= itaskc 2) (= itaskc 3) (= itaskc 5)) (go label310))
186 (if (>= (* (- toutc tn) h) 0.0d0) (go label310))
187 (setf t1 toutc)
188 (if (<= (* (- t1 t0) h) 0.0d0) (go label390))
189 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
190 (dintdy t1 0 yh nyh y iflag)
191 (declare (ignore var-0 var-1 var-2 var-3 var-4))
192 (setf iflag var-5))
193 (go label330)
194 label310
195 (setf t1 tn)
196 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
197 ((> i n) nil)
198 (tagbody
199 label320
200 (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%)
201 (f2cl-lib:fref yh-%data%
202 (i 1)
203 ((1 nyh) (1 *))
204 yh-%offset%))))
205 label330
206 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
207 (funcall g neq t1 y ngc g1)
208 (declare (ignore var-0 var-2 var-4))
209 (when var-1
210 (setf t1 var-1))
211 (when var-3
212 (setf ngc var-3)))
213 (setf nge (f2cl-lib:int-add nge 1))
214 (setf jflag 0)
215 label350
216 (multiple-value-bind
217 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9)
218 (droots ngc hming jflag t0 t1 g0 g1 gx x jroot)
219 (declare (ignore var-0 var-1 var-5 var-6 var-7 var-9))
220 (setf jflag var-2)
221 (setf t0 var-3)
222 (setf t1 var-4)
223 (setf x var-8))
224 (if (> jflag 1) (go label360))
225 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
226 (dintdy x 0 yh nyh y iflag)
227 (declare (ignore var-0 var-1 var-2 var-3 var-4))
228 (setf iflag var-5))
229 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
230 (funcall g neq x y ngc gx)
231 (declare (ignore var-0 var-2 var-4))
232 (when var-1
233 (setf x var-1))
234 (when var-3
235 (setf ngc var-3)))
236 (setf nge (f2cl-lib:int-add nge 1))
237 (go label350)
238 label360
239 (setf t0 x)
240 (dcopy ngc gx 1 g0 1)
241 (if (= jflag 4) (go label390))
242 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
243 (dintdy x 0 yh nyh y iflag)
244 (declare (ignore var-0 var-1 var-2 var-3 var-4))
245 (setf iflag var-5))
246 (setf irt 1)
247 (go end_label)
248 label390
249 (go end_label)
250 end_label
251 (return (values nil nil nil nil nil nil nil nil nil nil irt)))))))
253 (in-package #:cl-user)
254 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
255 (eval-when (:load-toplevel :compile-toplevel :execute)
256 (setf (gethash 'fortran-to-lisp::drchek
257 fortran-to-lisp::*f2cl-function-info*)
258 (fortran-to-lisp::make-f2cl-finfo
259 :arg-types '((fortran-to-lisp::integer4) t
260 (array fortran-to-lisp::integer4 (*))
261 (array double-float (*)) (array double-float (*))
262 (fortran-to-lisp::integer4) (array double-float (*))
263 (array double-float (*)) (array double-float (*))
264 (array fortran-to-lisp::integer4 (*))
265 (fortran-to-lisp::integer4))
266 :return-values '(nil nil nil nil nil nil nil nil nil nil
267 fortran-to-lisp::irt)
268 :calls '(fortran-to-lisp::dcopy fortran-to-lisp::droots
269 fortran-to-lisp::dintdy))))