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")
22 :element-type
'double-float
23 :initial-contents
'(0.5d0
0.575d0
0.55d0
0.45d0
0.35d0
24 0.25d0
0.2d0
0.15d0
0.1d0
0.075d0
0.05d0
26 (declare (type (array double-float
(12)) sm1
))
27 (defun dstoda (neq y yh nyh yh1 ewt savf acor wm iwm f jac pjac slvs
)
28 (declare (type (f2cl-lib:integer4
) nyh
)
29 (type (array double-float
(*)) wm acor savf ewt yh1 yh y
)
30 (type (array f2cl-lib
:integer4
(*)) iwm neq
))
33 :element-type
'double-float
34 :displaced-to
(dls001-part-0 *dls001-common-block
*)
35 :displaced-index-offset
2))
38 :element-type
'double-float
39 :displaced-to
(dls001-part-0 *dls001-common-block
*)
40 :displaced-index-offset
15))
43 :element-type
'double-float
44 :displaced-to
(dls001-part-0 *dls001-common-block
*)
45 :displaced-index-offset
173))
48 :element-type
'double-float
49 :displaced-to
(dlsa01-part-0 *dlsa01-common-block
*)
50 :displaced-index-offset
1))
53 :element-type
'double-float
54 :displaced-to
(dlsa01-part-0 *dlsa01-common-block
*)
55 :displaced-index-offset
13)))
56 (symbol-macrolet ((conit (aref (dls001-part-0 *dls001-common-block
*) 0))
57 (crate (aref (dls001-part-0 *dls001-common-block
*) 1))
60 (hold (aref (dls001-part-0 *dls001-common-block
*) 171))
61 (rmax (aref (dls001-part-0 *dls001-common-block
*) 172))
64 (aref (dls001-part-0 *dls001-common-block
*) 209))
65 (el0 (aref (dls001-part-0 *dls001-common-block
*) 210))
66 (h (aref (dls001-part-0 *dls001-common-block
*) 211))
67 (hmin (aref (dls001-part-0 *dls001-common-block
*) 212))
68 (hmxi (aref (dls001-part-0 *dls001-common-block
*) 213))
69 (hu (aref (dls001-part-0 *dls001-common-block
*) 214))
70 (rc (aref (dls001-part-0 *dls001-common-block
*) 215))
71 (tn (aref (dls001-part-0 *dls001-common-block
*) 216))
73 (aref (dls001-part-0 *dls001-common-block
*) 217))
74 (ialth (aref (dls001-part-1 *dls001-common-block
*) 6))
75 (ipup (aref (dls001-part-1 *dls001-common-block
*) 7))
76 (lmax (aref (dls001-part-1 *dls001-common-block
*) 8))
77 (nqnyh (aref (dls001-part-1 *dls001-common-block
*) 10))
78 (nslp (aref (dls001-part-1 *dls001-common-block
*) 11))
79 (icf (aref (dls001-part-1 *dls001-common-block
*) 12))
80 (ierpj (aref (dls001-part-1 *dls001-common-block
*) 13))
81 (iersl (aref (dls001-part-1 *dls001-common-block
*) 14))
82 (jcur (aref (dls001-part-1 *dls001-common-block
*) 15))
84 (aref (dls001-part-1 *dls001-common-block
*) 16))
85 (kflag (aref (dls001-part-1 *dls001-common-block
*) 17))
86 (l (aref (dls001-part-1 *dls001-common-block
*) 18))
87 (meth (aref (dls001-part-1 *dls001-common-block
*) 25))
88 (miter (aref (dls001-part-1 *dls001-common-block
*) 26))
90 (aref (dls001-part-1 *dls001-common-block
*) 27))
92 (aref (dls001-part-1 *dls001-common-block
*) 28))
93 (msbp (aref (dls001-part-1 *dls001-common-block
*) 29))
94 (mxncf (aref (dls001-part-1 *dls001-common-block
*) 30))
95 (n (aref (dls001-part-1 *dls001-common-block
*) 31))
96 (nq (aref (dls001-part-1 *dls001-common-block
*) 32))
97 (nst (aref (dls001-part-1 *dls001-common-block
*) 33))
98 (nfe (aref (dls001-part-1 *dls001-common-block
*) 34))
99 (nqu (aref (dls001-part-1 *dls001-common-block
*) 36))
102 (pdest (aref (dlsa01-part-0 *dlsa01-common-block
*) 18))
104 (aref (dlsa01-part-0 *dlsa01-common-block
*) 19))
105 (ratio (aref (dlsa01-part-0 *dlsa01-common-block
*) 20))
107 (aref (dlsa01-part-0 *dlsa01-common-block
*) 21))
108 (icount (aref (dlsa01-part-1 *dlsa01-common-block
*) 3))
109 (irflag (aref (dlsa01-part-1 *dlsa01-common-block
*) 4))
110 (jtyp (aref (dlsa01-part-1 *dlsa01-common-block
*) 5))
111 (mused (aref (dlsa01-part-1 *dlsa01-common-block
*) 6))
112 (mxordn (aref (dlsa01-part-1 *dlsa01-common-block
*) 7))
113 (mxords (aref (dlsa01-part-1 *dlsa01-common-block
*) 8)))
114 (f2cl-lib:with-multi-array-data
115 ((neq f2cl-lib
:integer4 neq-%data% neq-%offset%
)
116 (iwm f2cl-lib
:integer4 iwm-%data% iwm-%offset%
)
117 (y double-float y-%data% y-%offset%
)
118 (yh double-float yh-%data% yh-%offset%
)
119 (yh1 double-float yh1-%data% yh1-%offset%
)
120 (ewt double-float ewt-%data% ewt-%offset%
)
121 (savf double-float savf-%data% savf-%offset%
)
122 (acor double-float acor-%data% acor-%offset%
)
123 (wm double-float wm-%data% wm-%offset%
))
124 (prog ((newq 0) (ncf 0) (m 0) (jb 0) (j 0) (iret 0) (iredo 0) (i1 0)
125 (i 0) (nqm2 0) (nqm1 0) (lm2p1 0) (lm2 0) (lm1p1 0) (lm1 0)
126 (told 0.0d0
) (rhup 0.0d0
) (rhsm 0.0d0
) (rhdn 0.0d0
) (rh 0.0d0
)
127 (r 0.0d0
) (exup 0.0d0
) (exsm 0.0d0
) (exdn 0.0d0
) (dup 0.0d0
)
128 (dsm 0.0d0
) (delp 0.0d0
) (del 0.0d0
) (ddn 0.0d0
) (dcon 0.0d0
)
129 (rm 0.0d0
) (rh2 0.0d0
) (rh1it 0.0d0
) (rh1 0.0d0
) (rate 0.0d0
)
130 (pnorm 0.0d0
) (pdh 0.0d0
) (exm2 0.0d0
) (exm1 0.0d0
)
131 (dm2 0.0d0
) (dm1 0.0d0
) (alpha 0.0d0
))
132 (declare (type (double-float) alpha dm1 dm2 exm1 exm2 pdh pnorm
133 rate rh1 rh1it rh2 rm dcon ddn del
134 delp dsm dup exdn exsm exup r rh rhdn
136 (type (f2cl-lib:integer4
) lm1 lm1p1 lm2 lm2p1 nqm1 nqm2 i
137 i1 iredo iret j jb m ncf newq
))
146 (if (> jstart
0) (go label200
))
147 (if (= jstart -
1) (go label100
))
148 (if (= jstart -
2) (go label160
))
149 (setf lmax
(f2cl-lib:int-add maxord
1))
153 (setf rmax
10000.0d0
)
166 (dcfode 2 elco tesco
)
167 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
171 (setf (f2cl-lib:fref cm2
(i) ((1 5)))
172 (* (f2cl-lib:fref tesco
(2 i
) ((1 3) (1 12)))
174 ((f2cl-lib:int-add i
1) i
)
176 (dcfode 1 elco tesco
)
177 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
181 (setf (f2cl-lib:fref cm1
(i) ((1 12)))
182 (* (f2cl-lib:fref tesco
(2 i
) ((1 3) (1 12)))
184 ((f2cl-lib:int-add i
1) i
)
189 (setf lmax
(f2cl-lib:int-add maxord
1))
190 (if (= ialth
1) (setf ialth
2))
191 (if (= meth mused
) (go label160
))
192 (dcfode meth elco tesco
)
196 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
200 (setf (f2cl-lib:fref el
(i) ((1 13)))
201 (f2cl-lib:fref elco
(i nq
) ((1 13) (1 12))))))
202 (setf nqnyh
(f2cl-lib:int-mul nq nyh
))
203 (setf rc
(/ (* rc
(f2cl-lib:fref el
(1) ((1 13)))) el0
))
204 (setf el0
(f2cl-lib:fref el
(1) ((1 13))))
205 (setf conit
(/ 0.5d0
(f2cl-lib:int-add nq
2)))
206 (f2cl-lib:computed-goto
(label160 label170 label200
) iret
)
208 (if (= h hold
) (go label200
))
214 (setf rh
(max rh
(/ hmin
(abs h
))))
216 (setf rh
(min rh rmax
))
217 (setf rh
(/ rh
(max 1.0d0
(* (abs h
) hmxi rh
))))
218 (if (= meth
2) (go label178
))
220 (setf pdh
(max (* (abs h
) pdlast
) 1.0d-6
))
221 (if (< (* rh pdh
1.00001d0
) (f2cl-lib:fref sm1
(nq) ((1 12))))
223 (setf rh
(/ (f2cl-lib:fref sm1
(nq) ((1 12))) pdh
))
227 (f2cl-lib:fdo
(j 2 (f2cl-lib:int-add j
1))
231 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
234 (setf (f2cl-lib:fref yh-%data%
239 (f2cl-lib:fref yh-%data%
248 (if (= iredo
0) (go label690
))
250 (if (> (abs (- rc
1.0d0
)) ccmax
) (setf ipup miter
))
251 (if (>= nst
(f2cl-lib:int-add nslp msbp
)) (setf ipup miter
))
253 (setf i1
(f2cl-lib:int-add nqnyh
1))
254 (f2cl-lib:fdo
(jb 1 (f2cl-lib:int-add jb
1))
257 (setf i1
(f2cl-lib:int-sub i1 nyh
))
258 (f2cl-lib:fdo
(i i1
(f2cl-lib:int-add i
1))
262 (setf (f2cl-lib:fref yh1-%data%
(i) ((1 *)) yh1-%offset%
)
264 (f2cl-lib:fref yh1-%data%
268 (f2cl-lib:fref yh1-%data%
269 ((f2cl-lib:int-add i nyh
))
273 (setf pnorm
(dmnorm n yh1 ewt
))
278 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
282 (setf (f2cl-lib:fref y-%data%
(i) ((1 *)) y-%offset%
)
283 (f2cl-lib:fref yh-%data%
287 (multiple-value-bind (var-0 var-1 var-2 var-3
)
288 (funcall f neq tn y savf
)
289 (declare (ignore var-0 var-2 var-3
))
292 (setf nfe
(f2cl-lib:int-add nfe
1))
293 (if (<= ipup
0) (go label250
))
295 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
297 (funcall pjac neq y yh nyh ewt acor savf wm iwm f jac
)
298 (declare (ignore var-0 var-1 var-2 var-4 var-5 var-6 var-7 var-8
306 (if (/= ierpj
0) (go label430
))
308 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
312 (setf (f2cl-lib:fref acor-%data%
(i) ((1 *)) acor-%offset%
)
315 (if (/= miter
0) (go label350
))
316 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
319 (setf (f2cl-lib:fref savf-%data%
(i) ((1 *)) savf-%offset%
)
322 (f2cl-lib:fref savf-%data%
326 (f2cl-lib:fref yh-%data%
331 (setf (f2cl-lib:fref y-%data%
(i) ((1 *)) y-%offset%
)
333 (f2cl-lib:fref savf-%data%
(i) ((1 *)) savf-%offset%
)
334 (f2cl-lib:fref acor-%data%
338 (setf del
(dmnorm n y ewt
))
339 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
342 (setf (f2cl-lib:fref y-%data%
(i) ((1 *)) y-%offset%
)
344 (f2cl-lib:fref yh-%data%
348 (* (f2cl-lib:fref el
(1) ((1 13)))
349 (f2cl-lib:fref savf-%data%
354 (setf (f2cl-lib:fref acor-%data%
(i) ((1 *)) acor-%offset%
)
355 (f2cl-lib:fref savf-%data%
361 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
365 (setf (f2cl-lib:fref y-%data%
(i) ((1 *)) y-%offset%
)
368 (f2cl-lib:fref savf-%data%
373 (f2cl-lib:fref yh-%data%
377 (f2cl-lib:fref acor-%data%
381 (funcall slvs wm iwm y savf
)
382 (if (< iersl
0) (go label430
))
383 (if (> iersl
0) (go label410
))
384 (setf del
(dmnorm n y ewt
))
385 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
388 (setf (f2cl-lib:fref acor-%data%
(i) ((1 *)) acor-%offset%
)
390 (f2cl-lib:fref acor-%data%
(i) ((1 *)) acor-%offset%
)
391 (f2cl-lib:fref y-%data%
(i) ((1 *)) y-%offset%
)))
393 (setf (f2cl-lib:fref y-%data%
(i) ((1 *)) y-%offset%
)
395 (f2cl-lib:fref yh-%data%
399 (* (f2cl-lib:fref el
(1) ((1 13)))
400 (f2cl-lib:fref acor-%data%
405 (if (<= del
(* 100.0d0 pnorm uround
)) (go label450
))
406 (if (and (= m
0) (= meth
1)) (go label405
))
407 (if (= m
0) (go label402
))
409 (if (<= del
(* 1024.0d0 delp
)) (setf rm
(/ del delp
)))
410 (setf rate
(max rate rm
))
411 (setf crate
(max (* 0.2d0 crate
) rm
))
414 (/ (* del
(min 1.0d0
(* 1.5d0 crate
)))
415 (* (f2cl-lib:fref tesco
(2 nq
) ((1 3) (1 12))) conit
)))
416 (if (> dcon
1.0d0
) (go label405
))
419 (/ rate
(abs (* h
(f2cl-lib:fref el
(1) ((1 13))))))))
420 (if (/= pdest
0.0d0
) (setf pdlast pdest
))
423 (setf m
(f2cl-lib:int-add m
1))
424 (if (= m maxcor
) (go label410
))
425 (if (and (>= m
2) (> del
(* 2.0d0 delp
))) (go label410
))
427 (multiple-value-bind (var-0 var-1 var-2 var-3
)
428 (funcall f neq tn y savf
)
429 (declare (ignore var-0 var-2 var-3
))
432 (setf nfe
(f2cl-lib:int-add nfe
1))
435 (if (or (= miter
0) (= jcur
1)) (go label430
))
441 (setf ncf
(f2cl-lib:int-add ncf
1))
444 (setf i1
(f2cl-lib:int-add nqnyh
1))
445 (f2cl-lib:fdo
(jb 1 (f2cl-lib:int-add jb
1))
448 (setf i1
(f2cl-lib:int-sub i1 nyh
))
449 (f2cl-lib:fdo
(i i1
(f2cl-lib:int-add i
1))
453 (setf (f2cl-lib:fref yh1-%data%
(i) ((1 *)) yh1-%offset%
)
455 (f2cl-lib:fref yh1-%data%
459 (f2cl-lib:fref yh1-%data%
460 ((f2cl-lib:int-add i nyh
))
464 (if (or (< ierpj
0) (< iersl
0)) (go label680
))
465 (if (<= (abs h
) (* hmin
1.00001d0
)) (go label670
))
466 (if (= ncf mxncf
) (go label670
))
474 (setf dsm
(/ del
(f2cl-lib:fref tesco
(2 nq
) ((1 3) (1 12))))))
477 (/ (dmnorm n acor ewt
)
478 (f2cl-lib:fref tesco
(2 nq
) ((1 3) (1 12))))))
479 (if (> dsm
1.0d0
) (go label500
))
482 (setf nst
(f2cl-lib:int-add nst
1))
486 (f2cl-lib:fdo
(j 1 (f2cl-lib:int-add j
1))
489 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
492 (setf (f2cl-lib:fref yh-%data%
497 (f2cl-lib:fref yh-%data%
501 (* (f2cl-lib:fref el
(j) ((1 13)))
502 (f2cl-lib:fref acor-%data%
505 acor-%offset%
))))))))
507 (setf icount
(f2cl-lib:int-sub icount
1))
508 (if (>= icount
0) (go label488
))
509 (if (= meth
2) (go label480
))
510 (if (> nq
5) (go label488
))
511 (if (and (> dsm
(* 100.0d0 pnorm uround
)) (/= pdest
0.0d0
))
513 (if (= irflag
0) (go label488
))
516 (min (the f2cl-lib
:integer4 nq
)
517 (the f2cl-lib
:integer4 mxords
)))
520 (setf exsm
(/ 1.0d0 l
))
521 (setf rh1
(/ 1.0d0
(+ (* 1.2d0
(expt dsm exsm
)) 1.2d-6
)))
522 (setf rh1it
(* 2.0d0 rh1
))
523 (setf pdh
(* pdlast
(abs h
)))
524 (if (> (* pdh rh1
) 1.0d-5
)
525 (setf rh1it
(/ (f2cl-lib:fref sm1
(nq) ((1 12))) pdh
)))
526 (setf rh1
(min rh1 rh1it
))
527 (if (<= nq mxords
) (go label474
))
529 (setf lm2
(f2cl-lib:int-add mxords
1))
530 (setf exm2
(/ 1.0d0 lm2
))
531 (setf lm2p1
(f2cl-lib:int-add lm2
1))
535 (f2cl-lib:array-slice yh-%data%
541 (f2cl-lib:fref cm2
(mxords) ((1 5)))))
542 (setf rh2
(/ 1.0d0
(+ (* 1.2d0
(expt dm2 exm2
)) 1.2d-6
)))
547 (/ (f2cl-lib:fref cm1
(nq) ((1 12)))
548 (f2cl-lib:fref cm2
(nq) ((1 5))))))
549 (setf rh2
(/ 1.0d0
(+ (* 1.2d0
(expt dm2 exsm
)) 1.2d-6
)))
552 (if (< rh2
(* ratio rh1
)) (go label488
))
560 (setf l
(f2cl-lib:int-add nq
1))
563 (setf exsm
(/ 1.0d0 l
))
564 (if (>= mxordn nq
) (go label484
))
566 (setf lm1
(f2cl-lib:int-add mxordn
1))
567 (setf exm1
(/ 1.0d0 lm1
))
568 (setf lm1p1
(f2cl-lib:int-add lm1
1))
572 (f2cl-lib:array-slice yh-%data%
578 (f2cl-lib:fref cm1
(mxordn) ((1 12)))))
579 (setf rh1
(/ 1.0d0
(+ (* 1.2d0
(expt dm1 exm1
)) 1.2d-6
)))
584 (/ (f2cl-lib:fref cm2
(nq) ((1 5)))
585 (f2cl-lib:fref cm1
(nq) ((1 12))))))
586 (setf rh1
(/ 1.0d0
(+ (* 1.2d0
(expt dm1 exsm
)) 1.2d-6
)))
590 (setf rh1it
(* 2.0d0 rh1
))
591 (setf pdh
(* pdnorm
(abs h
)))
592 (if (> (* pdh rh1
) 1.0d-5
)
593 (setf rh1it
(/ (f2cl-lib:fref sm1
(nqm1) ((1 12))) pdh
)))
594 (setf rh1
(min rh1 rh1it
))
595 (setf rh2
(/ 1.0d0
(+ (* 1.2d0
(expt dsm exsm
)) 1.2d-6
)))
596 (if (< (* rh1 ratio
) (* 5.0d0 rh2
)) (go label488
))
597 (setf alpha
(max 0.001d0 rh1
))
598 (setf dm1
(* (expt alpha exm1
) dm1
))
599 (if (<= dm1
(* 1000.0d0 uround pnorm
)) (go label488
))
606 (setf l
(f2cl-lib:int-add nq
1))
609 (setf ialth
(f2cl-lib:int-sub ialth
1))
610 (if (= ialth
0) (go label520
))
611 (if (> ialth
1) (go label700
))
612 (if (= l lmax
) (go label700
))
613 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
617 (setf (f2cl-lib:fref yh-%data%
621 (f2cl-lib:fref acor-%data%
627 (setf kflag
(f2cl-lib:int-sub kflag
1))
629 (setf i1
(f2cl-lib:int-add nqnyh
1))
630 (f2cl-lib:fdo
(jb 1 (f2cl-lib:int-add jb
1))
633 (setf i1
(f2cl-lib:int-sub i1 nyh
))
634 (f2cl-lib:fdo
(i i1
(f2cl-lib:int-add i
1))
638 (setf (f2cl-lib:fref yh1-%data%
(i) ((1 *)) yh1-%offset%
)
640 (f2cl-lib:fref yh1-%data%
644 (f2cl-lib:fref yh1-%data%
645 ((f2cl-lib:int-add i nyh
))
650 (if (<= (abs h
) (* hmin
1.00001d0
)) (go label660
))
651 (if (<= kflag -
3) (go label640
))
657 (if (= l lmax
) (go label540
))
658 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
662 (setf (f2cl-lib:fref savf-%data%
(i) ((1 *)) savf-%offset%
)
664 (f2cl-lib:fref acor-%data%
(i) ((1 *)) acor-%offset%
)
665 (f2cl-lib:fref yh-%data%
670 (/ (dmnorm n savf ewt
)
671 (f2cl-lib:fref tesco
(3 nq
) ((1 3) (1 12)))))
672 (setf exup
(/ 1.0d0
(f2cl-lib:int-add l
1)))
673 (setf rhup
(/ 1.0d0
(+ (* 1.4d0
(expt dup exup
)) 1.4d-6
)))
675 (setf exsm
(/ 1.0d0 l
))
676 (setf rhsm
(/ 1.0d0
(+ (* 1.2d0
(expt dsm exsm
)) 1.2d-6
)))
678 (if (= nq
1) (go label550
))
682 (f2cl-lib:array-slice yh-%data%
688 (f2cl-lib:fref tesco
(1 nq
) ((1 3) (1 12)))))
689 (setf exdn
(/ 1.0d0 nq
))
690 (setf rhdn
(/ 1.0d0
(+ (* 1.3d0
(expt ddn exdn
)) 1.3d-6
)))
692 (if (= meth
2) (go label560
))
693 (setf pdh
(max (* (abs h
) pdlast
) 1.0d-6
))
696 (min rhup
(/ (f2cl-lib:fref sm1
(l) ((1 12))) pdh
))))
697 (setf rhsm
(min rhsm
(/ (f2cl-lib:fref sm1
(nq) ((1 12))) pdh
)))
703 ((f2cl-lib:int-sub nq
1))
708 (if (>= rhsm rhup
) (go label570
))
709 (if (> rhup rhdn
) (go label590
))
712 (if (< rhsm rhdn
) (go label580
))
717 (setf newq
(f2cl-lib:int-sub nq
1))
719 (if (and (< kflag
0) (> rh
1.0d0
)) (setf rh
1.0d0
))
724 (if (< rh
1.1d0
) (go label610
))
725 (setf r
(/ (f2cl-lib:fref el
(l) ((1 13))) l
))
726 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
730 (setf (f2cl-lib:fref yh-%data%
731 (i (f2cl-lib:int-add newq
1))
735 (f2cl-lib:fref acor-%data%
(i) ((1 *)) acor-%offset%
)
742 (if (= meth
2) (go label622
))
743 (if (>= (* rh pdh
1.00001d0
) (f2cl-lib:fref sm1
(newq) ((1 12))))
746 (if (and (= kflag
0) (< rh
1.1d0
)) (go label610
))
748 (if (<= kflag -
2) (setf rh
(min rh
0.2d0
)))
749 (if (= newq nq
) (go label170
))
752 (setf l
(f2cl-lib:int-add nq
1))
756 (if (= kflag -
10) (go label660
))
758 (setf rh
(max (/ hmin
(abs h
)) rh
))
760 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
764 (setf (f2cl-lib:fref y-%data%
(i) ((1 *)) y-%offset%
)
765 (f2cl-lib:fref yh-%data%
769 (multiple-value-bind (var-0 var-1 var-2 var-3
)
770 (funcall f neq tn y savf
)
771 (declare (ignore var-0 var-2 var-3
))
774 (setf nfe
(f2cl-lib:int-add nfe
1))
775 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
779 (setf (f2cl-lib:fref yh-%data%
784 (f2cl-lib:fref savf-%data%
790 (if (= nq
1) (go label200
))
807 (setf r
(/ 1.0d0
(f2cl-lib:fref tesco
(2 nqu
) ((1 3) (1 12)))))
808 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
812 (setf (f2cl-lib:fref acor-%data%
(i) ((1 *)) acor-%offset%
)
814 (f2cl-lib:fref acor-%data%
(i) ((1 *)) acor-%offset%
)
837 (in-package #:cl-user
)
838 #+#.
(cl:if
(cl:find-package
'#:f2cl
) '(and) '(or))
839 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
840 (setf (gethash 'fortran-to-lisp
::dstoda
841 fortran-to-lisp
::*f2cl-function-info
*)
842 (fortran-to-lisp::make-f2cl-finfo
843 :arg-types
'((array fortran-to-lisp
::integer4
(*))
844 (array double-float
(*)) (array double-float
(*))
845 (fortran-to-lisp::integer4
) (array double-float
(*))
846 (array double-float
(*)) (array double-float
(*))
847 (array double-float
(*)) (array double-float
(*))
848 (array fortran-to-lisp
::integer4
(*)) t t t t
)
849 :return-values
'(nil nil nil fortran-to-lisp
::nyh nil nil nil nil
850 nil nil nil nil nil nil
)
851 :calls
'(fortran-to-lisp::dmnorm fortran-to-lisp
::dcfode
))))