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