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)
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
))
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
))
50 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
54 (setf (f2cl-lib:fref jroot-%data%
(i) ((1 *)) jroot-%offset%
)
56 (setf hming
(* (+ (abs tn
) (abs h
)) uround
100.0d0
))
57 (f2cl-lib:computed-goto
(label100 label200 label300
) job
)
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
))
68 (setf zroot f2cl-lib
:%false%
)
69 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
74 (<= (abs (f2cl-lib:fref g0-%data%
(i) ((1 *)) g0-%offset%
))
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))
85 (setf (f2cl-lib:fref y-%data%
(i) ((1 *)) y-%offset%
)
86 (+ (f2cl-lib:fref y-%data%
(i) ((1 *)) y-%offset%
)
88 (f2cl-lib:fref yh-%data%
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
))
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))
106 (<= (abs (f2cl-lib:fref g0-%data%
(i) ((1 *)) g0-%offset%
))
108 (setf zroot f2cl-lib
:%true%
))))
109 (if (not zroot
) (go label190
))
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
))
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
))
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))
134 (<= (abs (f2cl-lib:fref g0-%data%
(i) ((1 *)) g0-%offset%
))
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))
146 (setf (f2cl-lib:fref y-%data%
(i) ((1 *)) y-%offset%
)
147 (+ (f2cl-lib:fref y-%data%
(i) ((1 *)) y-%offset%
)
149 (f2cl-lib:fref yh-%data%
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
))
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
))
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))
173 (> (abs (f2cl-lib:fref g0-%data%
(i) ((1 *)) g0-%offset%
))
176 (setf (f2cl-lib:fref jroot-%data%
(i) ((1 *)) jroot-%offset%
) 1)
177 (setf zroot f2cl-lib
:%true%
)
179 (if (not zroot
) (go label260
))
183 (if (= tn tlast
) (go label390
))
185 (if (or (= itaskc
2) (= itaskc
3) (= itaskc
5)) (go label310
))
186 (if (>= (* (- toutc tn
) h
) 0.0d0
) (go label310
))
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
))
196 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
200 (setf (f2cl-lib:fref y-%data%
(i) ((1 *)) y-%offset%
)
201 (f2cl-lib:fref yh-%data%
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
))
213 (setf nge
(f2cl-lib:int-add nge
1))
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
))
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
))
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
))
236 (setf nge
(f2cl-lib:int-add nge
1))
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
))
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
))))