share/odepack/src/dstode.lisp

   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-2017-01 (21B Unicode)
  11 ;;;
  12 ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  13 ;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
  14 ;;;           (:array-slicing t) (:declare-common nil)
  15 ;;;           (:float-format double-float))
  16
  17 (in-package "ODEPACK")
  18
  19
  20 (defun dstode (neq y yh nyh yh1 ewt savf acor wm iwm f jac pjac slvs)
  21   (declare (type (f2cl-lib:integer4) nyh)
  22            (type (array double-float (*)) wm acor savf ewt yh1 yh y)
  23            (type (array f2cl-lib:integer4 (*)) iwm neq))
  24   (let ((dls001-el
  25          (make-array 13
  26                      :element-type 'double-float
  27                      :displaced-to (dls001-part-0 *dls001-common-block*)
  28                      :displaced-index-offset 2))
  29         (dls001-elco
  30          (make-array 156
  31                      :element-type 'double-float
  32                      :displaced-to (dls001-part-0 *dls001-common-block*)
  33                      :displaced-index-offset 15))
  34         (dls001-tesco
  35          (make-array 36
  36                      :element-type 'double-float
  37                      :displaced-to (dls001-part-0 *dls001-common-block*)
  38                      :displaced-index-offset 173)))
  39     (symbol-macrolet ((conit (aref (dls001-part-0 *dls001-common-block*) 0))
  40                       (crate (aref (dls001-part-0 *dls001-common-block*) 1))
  41                       (el dls001-el)
  42                       (elco dls001-elco)
  43                       (hold (aref (dls001-part-0 *dls001-common-block*) 171))
  44                       (rmax (aref (dls001-part-0 *dls001-common-block*) 172))
  45                       (tesco dls001-tesco)
  46                       (ccmax (aref (dls001-part-0 *dls001-common-block*) 209))
  47                       (el0 (aref (dls001-part-0 *dls001-common-block*) 210))
  48                       (h (aref (dls001-part-0 *dls001-common-block*) 211))
  49                       (hmin (aref (dls001-part-0 *dls001-common-block*) 212))
  50                       (hmxi (aref (dls001-part-0 *dls001-common-block*) 213))
  51                       (hu (aref (dls001-part-0 *dls001-common-block*) 214))
  52                       (rc (aref (dls001-part-0 *dls001-common-block*) 215))
  53                       (tn (aref (dls001-part-0 *dls001-common-block*) 216))
  54                       (ialth (aref (dls001-part-1 *dls001-common-block*) 6))
  55                       (ipup (aref (dls001-part-1 *dls001-common-block*) 7))
  56                       (lmax (aref (dls001-part-1 *dls001-common-block*) 8))
  57                       (meo (aref (dls001-part-1 *dls001-common-block*) 9))
  58                       (nqnyh (aref (dls001-part-1 *dls001-common-block*) 10))
  59                       (nslp (aref (dls001-part-1 *dls001-common-block*) 11))
  60                       (icf (aref (dls001-part-1 *dls001-common-block*) 12))
  61                       (ierpj (aref (dls001-part-1 *dls001-common-block*) 13))
  62                       (iersl (aref (dls001-part-1 *dls001-common-block*) 14))
  63                       (jcur (aref (dls001-part-1 *dls001-common-block*) 15))
  64                       (jstart (aref (dls001-part-1 *dls001-common-block*) 16))
  65                       (kflag (aref (dls001-part-1 *dls001-common-block*) 17))
  66                       (l (aref (dls001-part-1 *dls001-common-block*) 18))
  67                       (meth (aref (dls001-part-1 *dls001-common-block*) 25))
  68                       (miter (aref (dls001-part-1 *dls001-common-block*) 26))
  69                       (maxord (aref (dls001-part-1 *dls001-common-block*) 27))
  70                       (maxcor (aref (dls001-part-1 *dls001-common-block*) 28))
  71                       (msbp (aref (dls001-part-1 *dls001-common-block*) 29))
  72                       (mxncf (aref (dls001-part-1 *dls001-common-block*) 30))
  73                       (n (aref (dls001-part-1 *dls001-common-block*) 31))
  74                       (nq (aref (dls001-part-1 *dls001-common-block*) 32))
  75                       (nst (aref (dls001-part-1 *dls001-common-block*) 33))
  76                       (nfe (aref (dls001-part-1 *dls001-common-block*) 34))
  77                       (nqu (aref (dls001-part-1 *dls001-common-block*) 36)))
  78       (prog ((newq 0) (ncf 0) (m 0) (jb 0) (j 0) (iret 0) (iredo 0) (i1 0)
  79              (i 0) (told 0.0) (rhup 0.0) (rhsm 0.0) (rhdn 0.0) (rh 0.0) (r 0.0)
  80              (exup 0.0) (exsm 0.0) (exdn 0.0) (dup 0.0) (dsm 0.0) (delp 0.0)
  81              (del 0.0) (ddn 0.0) (dcon 0.0))
  82         (declare (type (double-float) dcon ddn del delp dsm dup exdn exsm exup
  83                                       r rh rhdn rhsm rhup told)
  84                  (type (f2cl-lib:integer4) i i1 iredo iret j jb m ncf newq))
  85         (setf kflag 0)
  86         (setf told tn)
  87         (setf ncf 0)
  88         (setf ierpj 0)
  89         (setf iersl 0)
  90         (setf jcur 0)
  91         (setf icf 0)
  92         (setf delp 0.0)
  93         (if (> jstart 0) (go label200))
  94         (if (= jstart -1) (go label100))
  95         (if (= jstart -2) (go label160))
  96         (setf lmax (f2cl-lib:int-add maxord 1))
  97         (setf nq 1)
  98         (setf l 2)
  99         (setf ialth 2)
 100         (setf rmax 10000.0)
 101         (setf rc 0.0)
 102         (setf el0 1.0)
 103         (setf crate 0.7)
 104         (setf hold h)
 105         (setf meo meth)
 106         (setf nslp 0)
 107         (setf ipup miter)
 108         (setf iret 3)
 109         (go label140)
 110        label100
 111         (setf ipup miter)
 112         (setf lmax (f2cl-lib:int-add maxord 1))
 113         (if (= ialth 1) (setf ialth 2))
 114         (if (= meth meo) (go label110))
 115         (dcfode meth elco tesco)
 116         (setf meo meth)
 117         (if (> nq maxord) (go label120))
 118         (setf ialth l)
 119         (setf iret 1)
 120         (go label150)
 121        label110
 122         (if (<= nq maxord) (go label160))
 123        label120
 124         (setf nq maxord)
 125         (setf l lmax)
 126         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 127                       ((> i l) nil)
 128           (tagbody
 129            label125
 130             (setf (f2cl-lib:fref el (i) ((1 13)))
 131                     (f2cl-lib:fref elco (i nq) ((1 13) (1 12))))))
 132         (setf nqnyh (f2cl-lib:int-mul nq nyh))
 133         (setf rc (/ (* rc (f2cl-lib:fref el (1) ((1 13)))) el0))
 134         (setf el0 (f2cl-lib:fref el (1) ((1 13))))
 135         (setf conit (/ 0.5 (f2cl-lib:int-add nq 2)))
 136         (setf ddn
 137                 (/ (dvnorm n savf ewt)
 138                    (f2cl-lib:fref tesco (1 l) ((1 3) (1 12)))))
 139         (setf exdn (/ 1.0 l))
 140         (setf rhdn (/ 1.0 (+ (* 1.3 (expt ddn exdn)) 1.3e-6)))
 141         (setf rh (min rhdn 1.0))
 142         (setf iredo 3)
 143         (if (= h hold) (go label170))
 144         (setf rh (min rh (abs (/ h hold))))
 145         (setf h hold)
 146         (go label175)
 147        label140
 148         (dcfode meth elco tesco)
 149        label150
 150         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 151                       ((> i l) nil)
 152           (tagbody
 153            label155
 154             (setf (f2cl-lib:fref el (i) ((1 13)))
 155                     (f2cl-lib:fref elco (i nq) ((1 13) (1 12))))))
 156         (setf nqnyh (f2cl-lib:int-mul nq nyh))
 157         (setf rc (/ (* rc (f2cl-lib:fref el (1) ((1 13)))) el0))
 158         (setf el0 (f2cl-lib:fref el (1) ((1 13))))
 159         (setf conit (/ 0.5 (f2cl-lib:int-add nq 2)))
 160         (f2cl-lib:computed-goto (label160 label170 label200) iret)
 161        label160
 162         (if (= h hold) (go label200))
 163         (setf rh (/ h hold))
 164         (setf h hold)
 165         (setf iredo 3)
 166         (go label175)
 167        label170
 168         (setf rh (max rh (/ hmin (abs h))))
 169        label175
 170         (setf rh (min rh rmax))
 171         (setf rh (/ rh (max 1.0 (* (abs h) hmxi rh))))
 172         (setf r 1.0)
 173         (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1))
 174                       ((> j l) nil)
 175           (tagbody
 176             (setf r (* r rh))
 177             (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 178                           ((> i n) nil)
 179               (tagbody
 180                 (setf (f2cl-lib:fref yh (i j) ((1 nyh) (1 *)))
 181                         (* (f2cl-lib:fref yh (i j) ((1 nyh) (1 *))) r))))))
 182        label180
 183         (setf h (* h rh))
 184         (setf rc (* rc rh))
 185         (setf ialth l)
 186         (if (= iredo 0) (go label690))
 187        label200
 188         (if (> (abs (- rc 1.0)) ccmax) (setf ipup miter))
 189         (if (>= nst (f2cl-lib:int-add nslp msbp)) (setf ipup miter))
 190         (setf tn (+ tn h))
 191         (setf i1 (f2cl-lib:int-add nqnyh 1))
 192         (f2cl-lib:fdo (jb 1 (f2cl-lib:int-add jb 1))
 193                       ((> jb nq) nil)
 194           (tagbody
 195             (setf i1 (f2cl-lib:int-sub i1 nyh))
 196             (f2cl-lib:fdo (i i1 (f2cl-lib:int-add i 1))
 197                           ((> i nqnyh) nil)
 198               (tagbody
 199                label210
 200                 (setf (f2cl-lib:fref yh1 (i) ((1 *)))
 201                         (+ (f2cl-lib:fref yh1 (i) ((1 *)))
 202                            (f2cl-lib:fref yh1
 203                                           ((f2cl-lib:int-add i nyh))
 204                                           ((1 *)))))))
 205            label215))
 206        label220
 207         (setf m 0)
 208         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 209                       ((> i n) nil)
 210           (tagbody
 211            label230
 212             (setf (f2cl-lib:fref y (i) ((1 *)))
 213                     (f2cl-lib:fref yh (i 1) ((1 nyh) (1 *))))))
 214         (multiple-value-bind (var-0 var-1 var-2 var-3)
 215             (funcall f neq tn y savf)
 216           (declare (ignore var-0 var-2 var-3))
 217           (when var-1
 218             (setf tn var-1)))
 219         (setf nfe (f2cl-lib:int-add nfe 1))
 220         (if (<= ipup 0) (go label250))
 221         (multiple-value-bind
 222               (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
 223                var-10)
 224             (funcall pjac neq y yh nyh ewt acor savf wm iwm f jac)
 225           (declare (ignore var-0 var-1 var-2 var-4 var-5 var-6 var-7 var-8
 226                            var-9 var-10))
 227           (when var-3
 228             (setf nyh var-3)))
 229         (setf ipup 0)
 230         (setf rc 1.0)
 231         (setf nslp nst)
 232         (setf crate 0.7)
 233         (if (/= ierpj 0) (go label430))
 234        label250
 235         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 236                       ((> i n) nil)
 237           (tagbody label260 (setf (f2cl-lib:fref acor (i) ((1 *))) 0.0)))
 238        label270
 239         (if (/= miter 0) (go label350))
 240         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 241                       ((> i n) nil)
 242           (tagbody
 243             (setf (f2cl-lib:fref savf (i) ((1 *)))
 244                     (- (* h (f2cl-lib:fref savf (i) ((1 *))))
 245                        (f2cl-lib:fref yh (i 2) ((1 nyh) (1 *)))))
 246            label290
 247             (setf (f2cl-lib:fref y (i) ((1 *)))
 248                     (- (f2cl-lib:fref savf (i) ((1 *)))
 249                        (f2cl-lib:fref acor (i) ((1 *)))))))
 250         (setf del (dvnorm n y ewt))
 251         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 252                       ((> i n) nil)
 253           (tagbody
 254             (setf (f2cl-lib:fref y (i) ((1 *)))
 255                     (+ (f2cl-lib:fref yh (i 1) ((1 nyh) (1 *)))
 256                        (* (f2cl-lib:fref el (1) ((1 13)))
 257                           (f2cl-lib:fref savf (i) ((1 *))))))
 258            label300
 259             (setf (f2cl-lib:fref acor (i) ((1 *)))
 260                     (f2cl-lib:fref savf (i) ((1 *))))))
 261         (go label400)
 262        label350
 263         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 264                       ((> i n) nil)
 265           (tagbody
 266            label360
 267             (setf (f2cl-lib:fref y (i) ((1 *)))
 268                     (- (* h (f2cl-lib:fref savf (i) ((1 *))))
 269                        (+ (f2cl-lib:fref yh (i 2) ((1 nyh) (1 *)))
 270                           (f2cl-lib:fref acor (i) ((1 *))))))))
 271         (funcall slvs wm iwm y savf)
 272         (if (< iersl 0) (go label430))
 273         (if (> iersl 0) (go label410))
 274         (setf del (dvnorm n y ewt))
 275         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 276                       ((> i n) nil)
 277           (tagbody
 278             (setf (f2cl-lib:fref acor (i) ((1 *)))
 279                     (+ (f2cl-lib:fref acor (i) ((1 *)))
 280                        (f2cl-lib:fref y (i) ((1 *)))))
 281            label380
 282             (setf (f2cl-lib:fref y (i) ((1 *)))
 283                     (+ (f2cl-lib:fref yh (i 1) ((1 nyh) (1 *)))
 284                        (* (f2cl-lib:fref el (1) ((1 13)))
 285                           (f2cl-lib:fref acor (i) ((1 *))))))))
 286        label400
 287         (if (/= m 0) (setf crate (max (* 0.2 crate) (/ del delp))))
 288         (setf dcon
 289                 (/ (* del (min 1.0 (* 1.5 crate)))
 290                    (* (f2cl-lib:fref tesco (2 nq) ((1 3) (1 12))) conit)))
 291         (if (<= dcon 1.0) (go label450))
 292         (setf m (f2cl-lib:int-add m 1))
 293         (if (= m maxcor) (go label410))
 294         (if (and (>= m 2) (> del (* 2.0 delp))) (go label410))
 295         (setf delp del)
 296         (multiple-value-bind (var-0 var-1 var-2 var-3)
 297             (funcall f neq tn y savf)
 298           (declare (ignore var-0 var-2 var-3))
 299           (when var-1
 300             (setf tn var-1)))
 301         (setf nfe (f2cl-lib:int-add nfe 1))
 302         (go label270)
 303        label410
 304         (if (or (= miter 0) (= jcur 1)) (go label430))
 305         (setf icf 1)
 306         (setf ipup miter)
 307         (go label220)
 308        label430
 309         (setf icf 2)
 310         (setf ncf (f2cl-lib:int-add ncf 1))
 311         (setf rmax 2.0)
 312         (setf tn told)
 313         (setf i1 (f2cl-lib:int-add nqnyh 1))
 314         (f2cl-lib:fdo (jb 1 (f2cl-lib:int-add jb 1))
 315                       ((> jb nq) nil)
 316           (tagbody
 317             (setf i1 (f2cl-lib:int-sub i1 nyh))
 318             (f2cl-lib:fdo (i i1 (f2cl-lib:int-add i 1))
 319                           ((> i nqnyh) nil)
 320               (tagbody
 321                label440
 322                 (setf (f2cl-lib:fref yh1 (i) ((1 *)))
 323                         (- (f2cl-lib:fref yh1 (i) ((1 *)))
 324                            (f2cl-lib:fref yh1
 325                                           ((f2cl-lib:int-add i nyh))
 326                                           ((1 *)))))))
 327            label445))
 328         (if (or (< ierpj 0) (< iersl 0)) (go label680))
 329         (if (<= (abs h) (* hmin 1.00001)) (go label670))
 330         (if (= ncf mxncf) (go label670))
 331         (setf rh 0.25)
 332         (setf ipup miter)
 333         (setf iredo 1)
 334         (go label170)
 335        label450
 336         (setf jcur 0)
 337         (if (= m 0)
 338             (setf dsm (/ del (f2cl-lib:fref tesco (2 nq) ((1 3) (1 12))))))
 339         (if (> m 0)
 340             (setf dsm
 341                     (/ (dvnorm n acor ewt)
 342                        (f2cl-lib:fref tesco (2 nq) ((1 3) (1 12))))))
 343         (if (> dsm 1.0) (go label500))
 344         (setf kflag 0)
 345         (setf iredo 0)
 346         (setf nst (f2cl-lib:int-add nst 1))
 347         (setf hu h)
 348         (setf nqu nq)
 349         (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 350                       ((> j l) nil)
 351           (tagbody
 352             (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 353                           ((> i n) nil)
 354               (tagbody
 355                 (setf (f2cl-lib:fref yh (i j) ((1 nyh) (1 *)))
 356                         (+ (f2cl-lib:fref yh (i j) ((1 nyh) (1 *)))
 357                            (* (f2cl-lib:fref el (j) ((1 13)))
 358                               (f2cl-lib:fref acor (i) ((1 *))))))))))
 359        label470
 360         (setf ialth (f2cl-lib:int-sub ialth 1))
 361         (if (= ialth 0) (go label520))
 362         (if (> ialth 1) (go label700))
 363         (if (= l lmax) (go label700))
 364         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 365                       ((> i n) nil)
 366           (tagbody
 367            label490
 368             (setf (f2cl-lib:fref yh (i lmax) ((1 nyh) (1 *)))
 369                     (f2cl-lib:fref acor (i) ((1 *))))))
 370         (go label700)
 371        label500
 372         (setf kflag (f2cl-lib:int-sub kflag 1))
 373         (setf tn told)
 374         (setf i1 (f2cl-lib:int-add nqnyh 1))
 375         (f2cl-lib:fdo (jb 1 (f2cl-lib:int-add jb 1))
 376                       ((> jb nq) nil)
 377           (tagbody
 378             (setf i1 (f2cl-lib:int-sub i1 nyh))
 379             (f2cl-lib:fdo (i i1 (f2cl-lib:int-add i 1))
 380                           ((> i nqnyh) nil)
 381               (tagbody
 382                label510
 383                 (setf (f2cl-lib:fref yh1 (i) ((1 *)))
 384                         (- (f2cl-lib:fref yh1 (i) ((1 *)))
 385                            (f2cl-lib:fref yh1
 386                                           ((f2cl-lib:int-add i nyh))
 387                                           ((1 *)))))))
 388            label515))
 389         (setf rmax 2.0)
 390         (if (<= (abs h) (* hmin 1.00001)) (go label660))
 391         (if (<= kflag -3) (go label640))
 392         (setf iredo 2)
 393         (setf rhup 0.0)
 394         (go label540)
 395        label520
 396         (setf rhup 0.0)
 397         (if (= l lmax) (go label540))
 398         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 399                       ((> i n) nil)
 400           (tagbody
 401            label530
 402             (setf (f2cl-lib:fref savf (i) ((1 *)))
 403                     (- (f2cl-lib:fref acor (i) ((1 *)))
 404                        (f2cl-lib:fref yh (i lmax) ((1 nyh) (1 *)))))))
 405         (setf dup
 406                 (/ (dvnorm n savf ewt)
 407                    (f2cl-lib:fref tesco (3 nq) ((1 3) (1 12)))))
 408         (setf exup (/ 1.0 (f2cl-lib:int-add l 1)))
 409         (setf rhup (/ 1.0 (+ (* 1.4 (expt dup exup)) 1.4e-6)))
 410        label540
 411         (setf exsm (/ 1.0 l))
 412         (setf rhsm (/ 1.0 (+ (* 1.2 (expt dsm exsm)) 1.2e-6)))
 413         (setf rhdn 0.0)
 414         (if (= nq 1) (go label560))
 415         (setf ddn
 416                 (/
 417                  (dvnorm n
 418                   (f2cl-lib:array-slice yh double-float (1 l) ((1 nyh) (1 *)))
 419                   ewt)
 420                  (f2cl-lib:fref tesco (1 nq) ((1 3) (1 12)))))
 421         (setf exdn (/ 1.0 nq))
 422         (setf rhdn (/ 1.0 (+ (* 1.3 (expt ddn exdn)) 1.3e-6)))
 423        label560
 424         (if (>= rhsm rhup) (go label570))
 425         (if (> rhup rhdn) (go label590))
 426         (go label580)
 427        label570
 428         (if (< rhsm rhdn) (go label580))
 429         (setf newq nq)
 430         (setf rh rhsm)
 431         (go label620)
 432        label580
 433         (setf newq (f2cl-lib:int-sub nq 1))
 434         (setf rh rhdn)
 435         (if (and (< kflag 0) (> rh 1.0)) (setf rh 1.0))
 436         (go label620)
 437        label590
 438         (setf newq l)
 439         (setf rh rhup)
 440         (if (< rh 1.1) (go label610))
 441         (setf r (/ (f2cl-lib:fref el (l) ((1 13))) l))
 442         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 443                       ((> i n) nil)
 444           (tagbody
 445            label600
 446             (setf (f2cl-lib:fref yh
 447                                  (i (f2cl-lib:int-add newq 1))
 448                                  ((1 nyh) (1 *)))
 449                     (* (f2cl-lib:fref acor (i) ((1 *))) r))))
 450         (go label630)
 451        label610
 452         (setf ialth 3)
 453         (go label700)
 454        label620
 455         (if (and (= kflag 0) (< rh 1.1)) (go label610))
 456         (if (<= kflag -2) (setf rh (min rh 0.2)))
 457         (if (= newq nq) (go label170))
 458        label630
 459         (setf nq newq)
 460         (setf l (f2cl-lib:int-add nq 1))
 461         (setf iret 2)
 462         (go label150)
 463        label640
 464         (if (= kflag -10) (go label660))
 465         (setf rh 0.1)
 466         (setf rh (max (/ hmin (abs h)) rh))
 467         (setf h (* h rh))
 468         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 469                       ((> i n) nil)
 470           (tagbody
 471            label645
 472             (setf (f2cl-lib:fref y (i) ((1 *)))
 473                     (f2cl-lib:fref yh (i 1) ((1 nyh) (1 *))))))
 474         (multiple-value-bind (var-0 var-1 var-2 var-3)
 475             (funcall f neq tn y savf)
 476           (declare (ignore var-0 var-2 var-3))
 477           (when var-1
 478             (setf tn var-1)))
 479         (setf nfe (f2cl-lib:int-add nfe 1))
 480         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 481                       ((> i n) nil)
 482           (tagbody
 483            label650
 484             (setf (f2cl-lib:fref yh (i 2) ((1 nyh) (1 *)))
 485                     (* h (f2cl-lib:fref savf (i) ((1 *)))))))
 486         (setf ipup miter)
 487         (setf ialth 5)
 488         (if (= nq 1) (go label200))
 489         (setf nq 1)
 490         (setf l 2)
 491         (setf iret 3)
 492         (go label150)
 493        label660
 494         (setf kflag -1)
 495         (go label720)
 496        label670
 497         (setf kflag -2)
 498         (go label720)
 499        label680
 500         (setf kflag -3)
 501         (go label720)
 502        label690
 503         (setf rmax 10.0)
 504        label700
 505         (setf r (/ 1.0 (f2cl-lib:fref tesco (2 nqu) ((1 3) (1 12)))))
 506         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 507                       ((> i n) nil)
 508           (tagbody
 509            label710
 510             (setf (f2cl-lib:fref acor (i) ((1 *)))
 511                     (* (f2cl-lib:fref acor (i) ((1 *))) r))))
 512        label720
 513         (setf hold h)
 514         (setf jstart 1)
 515         (go end_label)
 516        end_label
 517         (return
 518          (values nil nil nil nyh nil nil nil nil nil nil nil nil nil nil))))))
 519
 520 (in-package #:cl-user)
 521 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 522 (eval-when (:load-toplevel :compile-toplevel :execute)
 523   (setf (gethash 'fortran-to-lisp::dstode
 524                  fortran-to-lisp::*f2cl-function-info*)
 525           (fortran-to-lisp::make-f2cl-finfo
 526            :arg-types '((array fortran-to-lisp::integer4 (*))
 527                         (array double-float (*)) (array double-float (*))
 528                         (fortran-to-lisp::integer4) (array double-float (*))
 529                         (array double-float (*)) (array double-float (*))
 530                         (array double-float (*)) (array double-float (*))
 531                         (array fortran-to-lisp::integer4 (*)) t t t t)
 532            :return-values '(nil nil nil fortran-to-lisp::nyh nil nil nil nil
 533                             nil nil nil nil nil nil)
 534            :calls '(fortran-to-lisp::dvnorm fortran-to-lisp::dcfode))))
 535