share/odepack/src/dlsode.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 t)
  15 ;;;           (:float-format double-float))
  16
  17 (in-package "ODEPACK")
  18
  19
  20 (let ((mord
  21        (make-array 2
  22                    :element-type 'f2cl-lib:integer4
  23                    :initial-contents '(12 5)))
  24       (mxstp0 500)
  25       (mxhnl0 10))
  26   (declare (type (simple-array f2cl-lib:integer4 (2)) mord)
  27            (type (f2cl-lib:integer4) mxstp0 mxhnl0))
  28   (defun dlsode
  29          (f neq y t$ tout itol rtol atol itask istate iopt rwork lrw iwork liw
  30           jac mf)
  31     (declare (type (f2cl-lib:integer4) mf liw lrw iopt istate itask itol)
  32              (type (double-float) tout t$)
  33              (type (array double-float (*)) rwork atol rtol y)
  34              (type (array f2cl-lib:integer4 (*)) iwork neq))
  35     (let ()
  36       (symbol-macrolet ((ccmax
  37                          (aref (dls001-part-0 *dls001-common-block*) 209))
  38                         (h (aref (dls001-part-0 *dls001-common-block*) 211))
  39                         (hmin (aref (dls001-part-0 *dls001-common-block*) 212))
  40                         (hmxi (aref (dls001-part-0 *dls001-common-block*) 213))
  41                         (hu (aref (dls001-part-0 *dls001-common-block*) 214))
  42                         (tn (aref (dls001-part-0 *dls001-common-block*) 216))
  43                         (uround
  44                          (aref (dls001-part-0 *dls001-common-block*) 217))
  45                         (init (aref (dls001-part-1 *dls001-common-block*) 0))
  46                         (mxstep (aref (dls001-part-1 *dls001-common-block*) 1))
  47                         (mxhnil (aref (dls001-part-1 *dls001-common-block*) 2))
  48                         (nhnil (aref (dls001-part-1 *dls001-common-block*) 3))
  49                         (nslast (aref (dls001-part-1 *dls001-common-block*) 4))
  50                         (nyh (aref (dls001-part-1 *dls001-common-block*) 5))
  51                         (jstart
  52                          (aref (dls001-part-1 *dls001-common-block*) 16))
  53                         (kflag (aref (dls001-part-1 *dls001-common-block*) 17))
  54                         (l (aref (dls001-part-1 *dls001-common-block*) 18))
  55                         (lyh (aref (dls001-part-1 *dls001-common-block*) 19))
  56                         (lewt (aref (dls001-part-1 *dls001-common-block*) 20))
  57                         (lacor (aref (dls001-part-1 *dls001-common-block*) 21))
  58                         (lsavf (aref (dls001-part-1 *dls001-common-block*) 22))
  59                         (lwm (aref (dls001-part-1 *dls001-common-block*) 23))
  60                         (liwm (aref (dls001-part-1 *dls001-common-block*) 24))
  61                         (meth (aref (dls001-part-1 *dls001-common-block*) 25))
  62                         (miter (aref (dls001-part-1 *dls001-common-block*) 26))
  63                         (maxord
  64                          (aref (dls001-part-1 *dls001-common-block*) 27))
  65                         (maxcor
  66                          (aref (dls001-part-1 *dls001-common-block*) 28))
  67                         (msbp (aref (dls001-part-1 *dls001-common-block*) 29))
  68                         (mxncf (aref (dls001-part-1 *dls001-common-block*) 30))
  69                         (n (aref (dls001-part-1 *dls001-common-block*) 31))
  70                         (nq (aref (dls001-part-1 *dls001-common-block*) 32))
  71                         (nst (aref (dls001-part-1 *dls001-common-block*) 33))
  72                         (nfe (aref (dls001-part-1 *dls001-common-block*) 34))
  73                         (nje (aref (dls001-part-1 *dls001-common-block*) 35))
  74                         (nqu (aref (dls001-part-1 *dls001-common-block*) 36)))
  75         (prog ((mu 0) (ml 0) (lenwm 0) (lenrw 0) (leniw 0) (lf0 0) (kgo 0)
  76                (imxer 0) (iflag 0) (i2 0) (i1 0) (i 0) (w0 0.0) (sum 0.0)
  77                (size 0.0) (tp 0.0) (tolsf 0.0) (tol 0.0) (tnext 0.0)
  78                (tdist 0.0) (tcrit 0.0) (rtoli 0.0) (rh 0.0) (hmx 0.0)
  79                (hmax 0.0) (h0 0.0) (ewti 0.0) (big 0.0) (ayi 0.0) (atoli 0.0)
  80                (ihit nil)
  81                (msg
  82                 (make-array '(80)
  83                             :element-type 'character
  84                             :initial-element #\ )))
  85           (declare (type (string 80) msg)
  86                    (type f2cl-lib:logical ihit)
  87                    (type (double-float) atoli ayi big ewti h0 hmax hmx rh rtoli
  88                                         tcrit tdist tnext tol tolsf tp size sum
  89                                         w0)
  90                    (type (f2cl-lib:integer4) i i1 i2 iflag imxer kgo lf0 leniw
  91                                              lenrw lenwm ml mu))
  92           (if (or (< istate 1) (> istate 3)) (go label601))
  93           (if (or (< itask 1) (> itask 5)) (go label602))
  94           (if (= istate 1) (go label10))
  95           (if (= init 0) (go label603))
  96           (if (= istate 2) (go label200))
  97           (go label20)
  98          label10
  99           (setf init 0)
 100           (if (= tout t$) (go end_label))
 101          label20
 102           (if (<= (f2cl-lib:fref neq (1) ((1 *))) 0) (go label604))
 103           (if (= istate 1) (go label25))
 104           (if (> (f2cl-lib:fref neq (1) ((1 *))) n) (go label605))
 105          label25
 106           (setf n (f2cl-lib:fref neq (1) ((1 *))))
 107           (if (or (< itol 1) (> itol 4)) (go label606))
 108           (if (or (< iopt 0) (> iopt 1)) (go label607))
 109           (setf meth (the f2cl-lib:integer4 (truncate mf 10)))
 110           (setf miter (f2cl-lib:int-sub mf (f2cl-lib:int-mul 10 meth)))
 111           (if (or (< meth 1) (> meth 2)) (go label608))
 112           (if (or (< miter 0) (> miter 5)) (go label608))
 113           (if (<= miter 3) (go label30))
 114           (setf ml (f2cl-lib:fref iwork (1) ((1 liw))))
 115           (setf mu (f2cl-lib:fref iwork (2) ((1 liw))))
 116           (if (or (< ml 0) (>= ml n)) (go label609))
 117           (if (or (< mu 0) (>= mu n)) (go label610))
 118          label30
 119           (if (= iopt 1) (go label40))
 120           (setf maxord (f2cl-lib:fref mord (meth) ((1 2))))
 121           (setf mxstep mxstp0)
 122           (setf mxhnil mxhnl0)
 123           (if (= istate 1) (setf h0 0.0))
 124           (setf hmxi 0.0)
 125           (setf hmin 0.0)
 126           (go label60)
 127          label40
 128           (setf maxord (f2cl-lib:fref iwork (5) ((1 liw))))
 129           (if (< maxord 0) (go label611))
 130           (if (= maxord 0) (setf maxord 100))
 131           (setf maxord
 132                   (min (the f2cl-lib:integer4 maxord)
 133                        (the f2cl-lib:integer4
 134                             (f2cl-lib:fref mord (meth) ((1 2))))))
 135           (setf mxstep (f2cl-lib:fref iwork (6) ((1 liw))))
 136           (if (< mxstep 0) (go label612))
 137           (if (= mxstep 0) (setf mxstep mxstp0))
 138           (setf mxhnil (f2cl-lib:fref iwork (7) ((1 liw))))
 139           (if (< mxhnil 0) (go label613))
 140           (if (= mxhnil 0) (setf mxhnil mxhnl0))
 141           (if (/= istate 1) (go label50))
 142           (setf h0 (f2cl-lib:fref rwork (5) ((1 lrw))))
 143           (if (< (* (- tout t$) h0) 0.0) (go label614))
 144          label50
 145           (setf hmax (f2cl-lib:fref rwork (6) ((1 lrw))))
 146           (if (< hmax 0.0) (go label615))
 147           (setf hmxi 0.0)
 148           (if (> hmax 0.0) (setf hmxi (/ 1.0 hmax)))
 149           (setf hmin (f2cl-lib:fref rwork (7) ((1 lrw))))
 150           (if (< hmin 0.0) (go label616))
 151          label60
 152           (setf lyh 21)
 153           (if (= istate 1) (setf nyh n))
 154           (setf lwm
 155                   (f2cl-lib:int-add lyh
 156                                     (f2cl-lib:int-mul
 157                                      (f2cl-lib:int-add maxord 1)
 158                                      nyh)))
 159           (if (= miter 0) (setf lenwm 0))
 160           (if (or (= miter 1) (= miter 2))
 161               (setf lenwm (f2cl-lib:int-add (f2cl-lib:int-mul n n) 2)))
 162           (if (= miter 3) (setf lenwm (f2cl-lib:int-add n 2)))
 163           (if (>= miter 4)
 164               (setf lenwm
 165                       (f2cl-lib:int-add
 166                        (f2cl-lib:int-mul
 167                         (f2cl-lib:int-add (f2cl-lib:int-mul 2 ml) mu 1)
 168                         n)
 169                        2)))
 170           (setf lewt (f2cl-lib:int-add lwm lenwm))
 171           (setf lsavf (f2cl-lib:int-add lewt n))
 172           (setf lacor (f2cl-lib:int-add lsavf n))
 173           (setf lenrw (f2cl-lib:int-sub (f2cl-lib:int-add lacor n) 1))
 174           (setf (f2cl-lib:fref iwork (17) ((1 liw))) lenrw)
 175           (setf liwm 1)
 176           (setf leniw (f2cl-lib:int-add 20 n))
 177           (if (or (= miter 0) (= miter 3)) (setf leniw 20))
 178           (setf (f2cl-lib:fref iwork (18) ((1 liw))) leniw)
 179           (if (> lenrw lrw) (go label617))
 180           (if (> leniw liw) (go label618))
 181           (setf rtoli (f2cl-lib:fref rtol (1) ((1 *))))
 182           (setf atoli (f2cl-lib:fref atol (1) ((1 *))))
 183           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 184                         ((> i n) nil)
 185             (tagbody
 186               (if (>= itol 3) (setf rtoli (f2cl-lib:fref rtol (i) ((1 *)))))
 187               (if (or (= itol 2) (= itol 4))
 188                   (setf atoli (f2cl-lib:fref atol (i) ((1 *)))))
 189               (if (< rtoli 0.0) (go label619))
 190               (if (< atoli 0.0) (go label620))
 191              label70))
 192           (if (= istate 1) (go label100))
 193           (setf jstart -1)
 194           (if (<= nq maxord) (go label90))
 195           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 196                         ((> i n) nil)
 197             (tagbody
 198              label80
 199               (setf (f2cl-lib:fref rwork
 200                                    ((f2cl-lib:int-sub
 201                                      (f2cl-lib:int-add i lsavf)
 202                                      1))
 203                                    ((1 lrw)))
 204                       (f2cl-lib:fref rwork
 205                                      ((f2cl-lib:int-sub
 206                                        (f2cl-lib:int-add i lwm)
 207                                        1))
 208                                      ((1 lrw))))))
 209          label90
 210           (if (> miter 0)
 211               (setf (f2cl-lib:fref rwork (lwm) ((1 lrw)))
 212                       (f2cl-lib:fsqrt uround)))
 213           (if (= n nyh) (go label200))
 214           (setf i1 (f2cl-lib:int-add lyh (f2cl-lib:int-mul l nyh)))
 215           (setf i2
 216                   (f2cl-lib:int-sub
 217                    (f2cl-lib:int-add lyh
 218                                      (f2cl-lib:int-mul
 219                                       (f2cl-lib:int-add maxord 1)
 220                                       nyh))
 221                    1))
 222           (if (> i1 i2) (go label200))
 223           (f2cl-lib:fdo (i i1 (f2cl-lib:int-add i 1))
 224                         ((> i i2) nil)
 225             (tagbody label95 (setf (f2cl-lib:fref rwork (i) ((1 lrw))) 0.0)))
 226           (go label200)
 227          label100
 228           (setf uround (dumach))
 229           (setf tn t$)
 230           (if (and (/= itask 4) (/= itask 5)) (go label110))
 231           (setf tcrit (f2cl-lib:fref rwork (1) ((1 lrw))))
 232           (if (< (* (- tcrit tout) (- tout t$)) 0.0) (go label625))
 233           (if (and (/= h0 0.0) (> (* (- (+ t$ h0) tcrit) h0) 0.0))
 234               (setf h0 (- tcrit t$)))
 235          label110
 236           (setf jstart 0)
 237           (if (> miter 0)
 238               (setf (f2cl-lib:fref rwork (lwm) ((1 lrw)))
 239                       (f2cl-lib:fsqrt uround)))
 240           (setf nhnil 0)
 241           (setf nst 0)
 242           (setf nje 0)
 243           (setf nslast 0)
 244           (setf hu 0.0)
 245           (setf nqu 0)
 246           (setf ccmax 0.3)
 247           (setf maxcor 3)
 248           (setf msbp 20)
 249           (setf mxncf 10)
 250           (setf lf0 (f2cl-lib:int-add lyh nyh))
 251           (multiple-value-bind (var-0 var-1 var-2 var-3)
 252               (funcall f
 253                        neq
 254                        t$
 255                        y
 256                        (f2cl-lib:array-slice rwork
 257                                              double-float
 258                                              (lf0)
 259                                              ((1 lrw))))
 260             (declare (ignore var-0 var-2 var-3))
 261             (when var-1
 262               (setf t$ var-1)))
 263           (setf nfe 1)
 264           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 265                         ((> i n) nil)
 266             (tagbody
 267              label115
 268               (setf (f2cl-lib:fref rwork
 269                                    ((f2cl-lib:int-sub (f2cl-lib:int-add i lyh)
 270                                                       1))
 271                                    ((1 lrw)))
 272                       (f2cl-lib:fref y (i) ((1 *))))))
 273           (setf nq 1)
 274           (setf h 1.0)
 275           (dewset n itol rtol atol
 276            (f2cl-lib:array-slice rwork double-float (lyh) ((1 lrw)))
 277            (f2cl-lib:array-slice rwork double-float (lewt) ((1 lrw))))
 278           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 279                         ((> i n) nil)
 280             (tagbody
 281               (if
 282                (<=
 283                 (f2cl-lib:fref rwork
 284                                ((f2cl-lib:int-sub (f2cl-lib:int-add i lewt) 1))
 285                                ((1 lrw)))
 286                 0.0)
 287                (go label621))
 288              label120
 289               (setf (f2cl-lib:fref rwork
 290                                    ((f2cl-lib:int-sub (f2cl-lib:int-add i lewt)
 291                                                       1))
 292                                    ((1 lrw)))
 293                       (/ 1.0
 294                          (f2cl-lib:fref rwork
 295                                         ((f2cl-lib:int-sub
 296                                           (f2cl-lib:int-add i lewt)
 297                                           1))
 298                                         ((1 lrw)))))))
 299           (if (/= h0 0.0) (go label180))
 300           (setf tdist (abs (- tout t$)))
 301           (setf w0 (max (abs t$) (abs tout)))
 302           (if (< tdist (* 2.0 uround w0)) (go label622))
 303           (setf tol (f2cl-lib:fref rtol (1) ((1 *))))
 304           (if (<= itol 2) (go label140))
 305           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 306                         ((> i n) nil)
 307             (tagbody
 308              label130
 309               (setf tol (max tol (f2cl-lib:fref rtol (i) ((1 *)))))))
 310          label140
 311           (if (> tol 0.0) (go label160))
 312           (setf atoli (f2cl-lib:fref atol (1) ((1 *))))
 313           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 314                         ((> i n) nil)
 315             (tagbody
 316               (if (or (= itol 2) (= itol 4))
 317                   (setf atoli (f2cl-lib:fref atol (i) ((1 *)))))
 318               (setf ayi (abs (f2cl-lib:fref y (i) ((1 *)))))
 319               (if (/= ayi 0.0) (setf tol (max tol (/ atoli ayi))))
 320              label150))
 321          label160
 322           (setf tol (max tol (* 100.0 uround)))
 323           (setf tol (min tol 0.001))
 324           (setf sum
 325                   (dvnorm n
 326                    (f2cl-lib:array-slice rwork double-float (lf0) ((1 lrw)))
 327                    (f2cl-lib:array-slice rwork double-float (lewt) ((1 lrw)))))
 328           (setf sum (+ (/ 1.0 (* tol w0 w0)) (* tol (expt sum 2))))
 329           (setf h0 (/ 1.0 (f2cl-lib:fsqrt sum)))
 330           (setf h0 (min h0 tdist))
 331           (setf h0 (f2cl-lib:sign h0 (- tout t$)))
 332          label180
 333           (setf rh (* (abs h0) hmxi))
 334           (if (> rh 1.0) (setf h0 (/ h0 rh)))
 335           (setf h h0)
 336           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 337                         ((> i n) nil)
 338             (tagbody
 339              label190
 340               (setf (f2cl-lib:fref rwork
 341                                    ((f2cl-lib:int-sub (f2cl-lib:int-add i lf0)
 342                                                       1))
 343                                    ((1 lrw)))
 344                       (* h0
 345                          (f2cl-lib:fref rwork
 346                                         ((f2cl-lib:int-sub
 347                                           (f2cl-lib:int-add i lf0)
 348                                           1))
 349                                         ((1 lrw)))))))
 350           (go label270)
 351          label200
 352           (setf nslast nst)
 353           (f2cl-lib:computed-goto
 354            (label210 label250 label220 label230 label240)
 355            itask)
 356          label210
 357           (if (< (* (- tn tout) h) 0.0) (go label250))
 358           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
 359               (dintdy tout 0
 360                (f2cl-lib:array-slice rwork double-float (lyh) ((1 lrw))) nyh y
 361                iflag)
 362             (declare (ignore var-0 var-1 var-2 var-3 var-4))
 363             (setf iflag var-5))
 364           (if (/= iflag 0) (go label627))
 365           (setf t$ tout)
 366           (go label420)
 367          label220
 368           (setf tp (- tn (* hu (+ 1.0 (* 100.0 uround)))))
 369           (if (> (* (- tp tout) h) 0.0) (go label623))
 370           (if (< (* (- tn tout) h) 0.0) (go label250))
 371           (go label400)
 372          label230
 373           (setf tcrit (f2cl-lib:fref rwork (1) ((1 lrw))))
 374           (if (> (* (- tn tcrit) h) 0.0) (go label624))
 375           (if (< (* (- tcrit tout) h) 0.0) (go label625))
 376           (if (< (* (- tn tout) h) 0.0) (go label245))
 377           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
 378               (dintdy tout 0
 379                (f2cl-lib:array-slice rwork double-float (lyh) ((1 lrw))) nyh y
 380                iflag)
 381             (declare (ignore var-0 var-1 var-2 var-3 var-4))
 382             (setf iflag var-5))
 383           (if (/= iflag 0) (go label627))
 384           (setf t$ tout)
 385           (go label420)
 386          label240
 387           (setf tcrit (f2cl-lib:fref rwork (1) ((1 lrw))))
 388           (if (> (* (- tn tcrit) h) 0.0) (go label624))
 389          label245
 390           (setf hmx (+ (abs tn) (abs h)))
 391           (setf ihit (<= (abs (- tn tcrit)) (* 100.0 uround hmx)))
 392           (if ihit (go label400))
 393           (setf tnext (+ tn (* h (+ 1.0 (* 4.0 uround)))))
 394           (if (<= (* (- tnext tcrit) h) 0.0) (go label250))
 395           (setf h (* (- tcrit tn) (- 1.0 (* 4.0 uround))))
 396           (if (= istate 2) (setf jstart -2))
 397          label250
 398           (if (>= (f2cl-lib:int-sub nst nslast) mxstep) (go label500))
 399           (dewset n itol rtol atol
 400            (f2cl-lib:array-slice rwork double-float (lyh) ((1 lrw)))
 401            (f2cl-lib:array-slice rwork double-float (lewt) ((1 lrw))))
 402           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 403                         ((> i n) nil)
 404             (tagbody
 405               (if
 406                (<=
 407                 (f2cl-lib:fref rwork
 408                                ((f2cl-lib:int-sub (f2cl-lib:int-add i lewt) 1))
 409                                ((1 lrw)))
 410                 0.0)
 411                (go label510))
 412              label260
 413               (setf (f2cl-lib:fref rwork
 414                                    ((f2cl-lib:int-sub (f2cl-lib:int-add i lewt)
 415                                                       1))
 416                                    ((1 lrw)))
 417                       (/ 1.0
 418                          (f2cl-lib:fref rwork
 419                                         ((f2cl-lib:int-sub
 420                                           (f2cl-lib:int-add i lewt)
 421                                           1))
 422                                         ((1 lrw)))))))
 423          label270
 424           (setf tolsf
 425                   (* uround
 426                      (dvnorm n
 427                       (f2cl-lib:array-slice rwork double-float (lyh) ((1 lrw)))
 428                       (f2cl-lib:array-slice rwork
 429                                             double-float
 430                                             (lewt)
 431                                             ((1 lrw))))))
 432           (if (<= tolsf 1.0) (go label280))
 433           (setf tolsf (* tolsf 2.0))
 434           (if (= nst 0) (go label626))
 435           (go label520)
 436          label280
 437           (if (/= (+ tn h) tn) (go label290))
 438           (setf nhnil (f2cl-lib:int-add nhnil 1))
 439           (if (> nhnil mxhnil) (go label290))
 440           (f2cl-lib:f2cl-set-string msg
 441                                     "DLSODE-  Warning..internal T (=R1) and H (=R2) are"
 442                                     (string 80))
 443           (xerrwd msg 50 101 0 0 0 0 0 0.0 0.0)
 444           (f2cl-lib:f2cl-set-string msg
 445                                     "      such that in the machine, T + H = T on the next step  "
 446                                     (string 80))
 447           (xerrwd msg 60 101 0 0 0 0 0 0.0 0.0)
 448           (f2cl-lib:f2cl-set-string msg
 449                                     "      (H = step size). Solver will continue anyway"
 450                                     (string 80))
 451           (xerrwd msg 50 101 0 0 0 0 2 tn h)
 452           (if (< nhnil mxhnil) (go label290))
 453           (f2cl-lib:f2cl-set-string msg
 454                                     "DLSODE-  Above warning has been issued I1 times.  "
 455                                     (string 80))
 456           (xerrwd msg 50 102 0 0 0 0 0 0.0 0.0)
 457           (f2cl-lib:f2cl-set-string msg
 458                                     "      It will not be issued again for this problem"
 459                                     (string 80))
 460           (xerrwd msg 50 102 0 1 mxhnil 0 0 0.0 0.0)
 461          label290
 462           (multiple-value-bind
 463                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
 464                  var-10 var-11 var-12 var-13)
 465               (dstode neq y
 466                (f2cl-lib:array-slice rwork double-float (lyh) ((1 lrw))) nyh
 467                (f2cl-lib:array-slice rwork double-float (lyh) ((1 lrw)))
 468                (f2cl-lib:array-slice rwork double-float (lewt) ((1 lrw)))
 469                (f2cl-lib:array-slice rwork double-float (lsavf) ((1 lrw)))
 470                (f2cl-lib:array-slice rwork double-float (lacor) ((1 lrw)))
 471                (f2cl-lib:array-slice rwork double-float (lwm) ((1 lrw)))
 472                (f2cl-lib:array-slice iwork f2cl-lib:integer4 (liwm) ((1 liw)))
 473                f jac #'dprepj #'dsolsy)
 474             (declare (ignore var-0 var-1 var-2 var-4 var-5 var-6 var-7 var-8
 475                              var-9 var-10 var-11 var-12 var-13))
 476             (setf nyh var-3))
 477           (setf kgo (f2cl-lib:int-sub 1 kflag))
 478           (f2cl-lib:computed-goto (label300 label530 label540) kgo)
 479          label300
 480           (setf init 1)
 481           (f2cl-lib:computed-goto
 482            (label310 label400 label330 label340 label350)
 483            itask)
 484          label310
 485           (if (< (* (- tn tout) h) 0.0) (go label250))
 486           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
 487               (dintdy tout 0
 488                (f2cl-lib:array-slice rwork double-float (lyh) ((1 lrw))) nyh y
 489                iflag)
 490             (declare (ignore var-0 var-1 var-2 var-3 var-4))
 491             (setf iflag var-5))
 492           (setf t$ tout)
 493           (go label420)
 494          label330
 495           (if (>= (* (- tn tout) h) 0.0) (go label400))
 496           (go label250)
 497          label340
 498           (if (< (* (- tn tout) h) 0.0) (go label345))
 499           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
 500               (dintdy tout 0
 501                (f2cl-lib:array-slice rwork double-float (lyh) ((1 lrw))) nyh y
 502                iflag)
 503             (declare (ignore var-0 var-1 var-2 var-3 var-4))
 504             (setf iflag var-5))
 505           (setf t$ tout)
 506           (go label420)
 507          label345
 508           (setf hmx (+ (abs tn) (abs h)))
 509           (setf ihit (<= (abs (- tn tcrit)) (* 100.0 uround hmx)))
 510           (if ihit (go label400))
 511           (setf tnext (+ tn (* h (+ 1.0 (* 4.0 uround)))))
 512           (if (<= (* (- tnext tcrit) h) 0.0) (go label250))
 513           (setf h (* (- tcrit tn) (- 1.0 (* 4.0 uround))))
 514           (setf jstart -2)
 515           (go label250)
 516          label350
 517           (setf hmx (+ (abs tn) (abs h)))
 518           (setf ihit (<= (abs (- tn tcrit)) (* 100.0 uround hmx)))
 519          label400
 520           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 521                         ((> i n) nil)
 522             (tagbody
 523              label410
 524               (setf (f2cl-lib:fref y (i) ((1 *)))
 525                       (f2cl-lib:fref rwork
 526                                      ((f2cl-lib:int-sub
 527                                        (f2cl-lib:int-add i lyh)
 528                                        1))
 529                                      ((1 lrw))))))
 530           (setf t$ tn)
 531           (if (and (/= itask 4) (/= itask 5)) (go label420))
 532           (if ihit (setf t$ tcrit))
 533          label420
 534           (setf istate 2)
 535           (setf (f2cl-lib:fref rwork (11) ((1 lrw))) hu)
 536           (setf (f2cl-lib:fref rwork (12) ((1 lrw))) h)
 537           (setf (f2cl-lib:fref rwork (13) ((1 lrw))) tn)
 538           (setf (f2cl-lib:fref iwork (11) ((1 liw))) nst)
 539           (setf (f2cl-lib:fref iwork (12) ((1 liw))) nfe)
 540           (setf (f2cl-lib:fref iwork (13) ((1 liw))) nje)
 541           (setf (f2cl-lib:fref iwork (14) ((1 liw))) nqu)
 542           (setf (f2cl-lib:fref iwork (15) ((1 liw))) nq)
 543           (go end_label)
 544          label500
 545           (f2cl-lib:f2cl-set-string msg
 546                                     "DLSODE-  At current T (=R1), MXSTEP (=I1) steps   "
 547                                     (string 80))
 548           (xerrwd msg 50 201 0 0 0 0 0 0.0 0.0)
 549           (f2cl-lib:f2cl-set-string msg
 550                                     "      taken on this call before reaching TOUT     "
 551                                     (string 80))
 552           (xerrwd msg 50 201 0 1 mxstep 0 1 tn 0.0)
 553           (setf istate -1)
 554           (go label580)
 555          label510
 556           (setf ewti
 557                   (f2cl-lib:fref rwork
 558                                  ((f2cl-lib:int-sub (f2cl-lib:int-add lewt i)
 559                                                     1))
 560                                  ((1 lrw))))
 561           (f2cl-lib:f2cl-set-string msg
 562                                     "DLSODE-  At T (=R1), EWT(I1) has become R2  <=  0."
 563                                     (string 80))
 564           (xerrwd msg 50 202 0 1 i 0 2 tn ewti)
 565           (setf istate -6)
 566           (go label580)
 567          label520
 568           (f2cl-lib:f2cl-set-string msg
 569                                     "DLSODE-  At T (=R1), too much accuracy requested  "
 570                                     (string 80))
 571           (xerrwd msg 50 203 0 0 0 0 0 0.0 0.0)
 572           (f2cl-lib:f2cl-set-string msg
 573                                     "      for precision of machine..  see TOLSF (=R2) "
 574                                     (string 80))
 575           (xerrwd msg 50 203 0 0 0 0 2 tn tolsf)
 576           (setf (f2cl-lib:fref rwork (14) ((1 lrw))) tolsf)
 577           (setf istate -2)
 578           (go label580)
 579          label530
 580           (f2cl-lib:f2cl-set-string msg
 581                                     "DLSODE-  At T(=R1) and step size H(=R2), the error"
 582                                     (string 80))
 583           (xerrwd msg 50 204 0 0 0 0 0 0.0 0.0)
 584           (f2cl-lib:f2cl-set-string msg
 585                                     "      test failed repeatedly or with ABS(H) = HMIN"
 586                                     (string 80))
 587           (xerrwd msg 50 204 0 0 0 0 2 tn h)
 588           (setf istate -4)
 589           (go label560)
 590          label540
 591           (f2cl-lib:f2cl-set-string msg
 592                                     "DLSODE-  At T (=R1) and step size H (=R2), the    "
 593                                     (string 80))
 594           (xerrwd msg 50 205 0 0 0 0 0 0.0 0.0)
 595           (f2cl-lib:f2cl-set-string msg
 596                                     "      corrector convergence failed repeatedly     "
 597                                     (string 80))
 598           (xerrwd msg 50 205 0 0 0 0 0 0.0 0.0)
 599           (f2cl-lib:f2cl-set-string msg
 600                                     "      or with ABS(H) = HMIN   "
 601                                     (string 80))
 602           (xerrwd msg 30 205 0 0 0 0 2 tn h)
 603           (setf istate -5)
 604          label560
 605           (setf big 0.0)
 606           (setf imxer 1)
 607           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 608                         ((> i n) nil)
 609             (tagbody
 610               (setf size
 611                       (abs
 612                        (*
 613                         (f2cl-lib:fref rwork
 614                                        ((f2cl-lib:int-sub
 615                                          (f2cl-lib:int-add i lacor)
 616                                          1))
 617                                        ((1 lrw)))
 618                         (f2cl-lib:fref rwork
 619                                        ((f2cl-lib:int-sub
 620                                          (f2cl-lib:int-add i lewt)
 621                                          1))
 622                                        ((1 lrw))))))
 623               (if (>= big size) (go label570))
 624               (setf big size)
 625               (setf imxer i)
 626              label570))
 627           (setf (f2cl-lib:fref iwork (16) ((1 liw))) imxer)
 628          label580
 629           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 630                         ((> i n) nil)
 631             (tagbody
 632              label590
 633               (setf (f2cl-lib:fref y (i) ((1 *)))
 634                       (f2cl-lib:fref rwork
 635                                      ((f2cl-lib:int-sub
 636                                        (f2cl-lib:int-add i lyh)
 637                                        1))
 638                                      ((1 lrw))))))
 639           (setf t$ tn)
 640           (setf (f2cl-lib:fref rwork (11) ((1 lrw))) hu)
 641           (setf (f2cl-lib:fref rwork (12) ((1 lrw))) h)
 642           (setf (f2cl-lib:fref rwork (13) ((1 lrw))) tn)
 643           (setf (f2cl-lib:fref iwork (11) ((1 liw))) nst)
 644           (setf (f2cl-lib:fref iwork (12) ((1 liw))) nfe)
 645           (setf (f2cl-lib:fref iwork (13) ((1 liw))) nje)
 646           (setf (f2cl-lib:fref iwork (14) ((1 liw))) nqu)
 647           (setf (f2cl-lib:fref iwork (15) ((1 liw))) nq)
 648           (go end_label)
 649          label601
 650           (f2cl-lib:f2cl-set-string msg
 651                                     "DLSODE-  ISTATE (=I1) illegal "
 652                                     (string 80))
 653           (xerrwd msg 30 1 0 1 istate 0 0 0.0 0.0)
 654           (if (< istate 0) (go label800))
 655           (go label700)
 656          label602
 657           (f2cl-lib:f2cl-set-string msg
 658                                     "DLSODE-  ITASK (=I1) illegal  "
 659                                     (string 80))
 660           (xerrwd msg 30 2 0 1 itask 0 0 0.0 0.0)
 661           (go label700)
 662          label603
 663           (f2cl-lib:f2cl-set-string msg
 664                                     "DLSODE-  ISTATE  >  1 but DLSODE not initialized "
 665                                     (string 80))
 666           (xerrwd msg 50 3 0 0 0 0 0 0.0 0.0)
 667           (go label700)
 668          label604
 669           (f2cl-lib:f2cl-set-string msg
 670                                     "DLSODE-  NEQ (=I1)  <  1     "
 671                                     (string 80))
 672           (xerrwd msg 30 4 0 1 (f2cl-lib:fref neq (1) ((1 *))) 0 0 0.0 0.0)
 673           (go label700)
 674          label605
 675           (f2cl-lib:f2cl-set-string msg
 676                                     "DLSODE-  ISTATE = 3 and NEQ increased (I1 to I2)  "
 677                                     (string 80))
 678           (xerrwd msg 50 5 0 2 n (f2cl-lib:fref neq (1) ((1 *))) 0 0.0 0.0)
 679           (go label700)
 680          label606
 681           (f2cl-lib:f2cl-set-string msg
 682                                     "DLSODE-  ITOL (=I1) illegal   "
 683                                     (string 80))
 684           (xerrwd msg 30 6 0 1 itol 0 0 0.0 0.0)
 685           (go label700)
 686          label607
 687           (f2cl-lib:f2cl-set-string msg
 688                                     "DLSODE-  IOPT (=I1) illegal   "
 689                                     (string 80))
 690           (xerrwd msg 30 7 0 1 iopt 0 0 0.0 0.0)
 691           (go label700)
 692          label608
 693           (f2cl-lib:f2cl-set-string msg
 694                                     "DLSODE-  MF (=I1) illegal     "
 695                                     (string 80))
 696           (xerrwd msg 30 8 0 1 mf 0 0 0.0 0.0)
 697           (go label700)
 698          label609
 699           (f2cl-lib:f2cl-set-string msg
 700                                     "DLSODE-  ML (=I1) illegal..  < 0 or  >= NEQ (=I2)"
 701                                     (string 80))
 702           (xerrwd msg 50 9 0 2 ml (f2cl-lib:fref neq (1) ((1 *))) 0 0.0 0.0)
 703           (go label700)
 704          label610
 705           (f2cl-lib:f2cl-set-string msg
 706                                     "DLSODE-  MU (=I1) illegal..  < 0 or  >= NEQ (=I2)"
 707                                     (string 80))
 708           (xerrwd msg 50 10 0 2 mu (f2cl-lib:fref neq (1) ((1 *))) 0 0.0 0.0)
 709           (go label700)
 710          label611
 711           (f2cl-lib:f2cl-set-string msg
 712                                     "DLSODE-  MAXORD (=I1)  <  0  "
 713                                     (string 80))
 714           (xerrwd msg 30 11 0 1 maxord 0 0 0.0 0.0)
 715           (go label700)
 716          label612
 717           (f2cl-lib:f2cl-set-string msg
 718                                     "DLSODE-  MXSTEP (=I1)  <  0  "
 719                                     (string 80))
 720           (xerrwd msg 30 12 0 1 mxstep 0 0 0.0 0.0)
 721           (go label700)
 722          label613
 723           (f2cl-lib:f2cl-set-string msg
 724                                     "DLSODE-  MXHNIL (=I1)  <  0  "
 725                                     (string 80))
 726           (xerrwd msg 30 13 0 1 mxhnil 0 0 0.0 0.0)
 727           (go label700)
 728          label614
 729           (f2cl-lib:f2cl-set-string msg
 730                                     "DLSODE-  TOUT (=R1) behind T (=R2)      "
 731                                     (string 80))
 732           (xerrwd msg 40 14 0 0 0 0 2 tout t$)
 733           (f2cl-lib:f2cl-set-string msg
 734                                     "      Integration direction is given by H0 (=R1)  "
 735                                     (string 80))
 736           (xerrwd msg 50 14 0 0 0 0 1 h0 0.0)
 737           (go label700)
 738          label615
 739           (f2cl-lib:f2cl-set-string msg
 740                                     "DLSODE-  HMAX (=R1)  <  0.0  "
 741                                     (string 80))
 742           (xerrwd msg 30 15 0 0 0 0 1 hmax 0.0)
 743           (go label700)
 744          label616
 745           (f2cl-lib:f2cl-set-string msg
 746                                     "DLSODE-  HMIN (=R1)  <  0.0  "
 747                                     (string 80))
 748           (xerrwd msg 30 16 0 0 0 0 1 hmin 0.0)
 749           (go label700)
 750          label617
 751           (f2cl-lib:f2cl-set-string msg
 752                                     "DLSODE-  RWORK length needed, LENRW (=I1), exceeds LRW (=I2)"
 753                                     (string 80))
 754           (xerrwd msg 60 17 0 2 lenrw lrw 0 0.0 0.0)
 755           (go label700)
 756          label618
 757           (f2cl-lib:f2cl-set-string msg
 758                                     "DLSODE-  IWORK length needed, LENIW (=I1), exceeds LIW (=I2)"
 759                                     (string 80))
 760           (xerrwd msg 60 18 0 2 leniw liw 0 0.0 0.0)
 761           (go label700)
 762          label619
 763           (f2cl-lib:f2cl-set-string msg
 764                                     "DLSODE-  RTOL(I1) is R1  <  0.0        "
 765                                     (string 80))
 766           (xerrwd msg 40 19 0 1 i 0 1 rtoli 0.0)
 767           (go label700)
 768          label620
 769           (f2cl-lib:f2cl-set-string msg
 770                                     "DLSODE-  ATOL(I1) is R1  <  0.0        "
 771                                     (string 80))
 772           (xerrwd msg 40 20 0 1 i 0 1 atoli 0.0)
 773           (go label700)
 774          label621
 775           (setf ewti
 776                   (f2cl-lib:fref rwork
 777                                  ((f2cl-lib:int-sub (f2cl-lib:int-add lewt i)
 778                                                     1))
 779                                  ((1 lrw))))
 780           (f2cl-lib:f2cl-set-string msg
 781                                     "DLSODE-  EWT(I1) is R1  <=  0.0         "
 782                                     (string 80))
 783           (xerrwd msg 40 21 0 1 i 0 1 ewti 0.0)
 784           (go label700)
 785          label622
 786           (f2cl-lib:f2cl-set-string msg
 787                                     "DLSODE-  TOUT (=R1) too close to T(=R2) to start integration"
 788                                     (string 80))
 789           (xerrwd msg 60 22 0 0 0 0 2 tout t$)
 790           (go label700)
 791          label623
 792           (f2cl-lib:f2cl-set-string msg
 793                                     "DLSODE-  ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2)  "
 794                                     (string 80))
 795           (xerrwd msg 60 23 0 1 itask 0 2 tout tp)
 796           (go label700)
 797          label624
 798           (f2cl-lib:f2cl-set-string msg
 799                                     "DLSODE-  ITASK = 4 OR 5 and TCRIT (=R1) behind TCUR (=R2)   "
 800                                     (string 80))
 801           (xerrwd msg 60 24 0 0 0 0 2 tcrit tn)
 802           (go label700)
 803          label625
 804           (f2cl-lib:f2cl-set-string msg
 805                                     "DLSODE-  ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2)   "
 806                                     (string 80))
 807           (xerrwd msg 60 25 0 0 0 0 2 tcrit tout)
 808           (go label700)
 809          label626
 810           (f2cl-lib:f2cl-set-string msg
 811                                     "DLSODE-  At start of problem, too much accuracy   "
 812                                     (string 80))
 813           (xerrwd msg 50 26 0 0 0 0 0 0.0 0.0)
 814           (f2cl-lib:f2cl-set-string msg
 815                                     "      requested for precision of machine..  See TOLSF (=R1) "
 816                                     (string 80))
 817           (xerrwd msg 60 26 0 0 0 0 1 tolsf 0.0)
 818           (setf (f2cl-lib:fref rwork (14) ((1 lrw))) tolsf)
 819           (go label700)
 820          label627
 821           (f2cl-lib:f2cl-set-string msg
 822                                     "DLSODE-  Trouble in DINTDY.  ITASK = I1, TOUT = R1"
 823                                     (string 80))
 824           (xerrwd msg 50 27 0 1 itask 0 1 tout 0.0)
 825          label700
 826           (setf istate -3)
 827           (go end_label)
 828          label800
 829           (f2cl-lib:f2cl-set-string msg
 830                                     "DLSODE-  Run aborted.. apparent infinite loop     "
 831                                     (string 80))
 832           (xerrwd msg 50 303 2 0 0 0 0 0.0 0.0)
 833           (go end_label)
 834          end_label
 835           (return
 836            (values nil
 837                    nil
 838                    nil
 839                    t$
 840                    nil
 841                    nil
 842                    nil
 843                    nil
 844                    nil
 845                    istate
 846                    nil
 847                    nil
 848                    nil
 849                    nil
 850                    nil
 851                    nil
 852                    nil)))))))
 853
 854 (in-package #:cl-user)
 855 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 856 (eval-when (:load-toplevel :compile-toplevel :execute)
 857   (setf (gethash 'fortran-to-lisp::dlsode
 858                  fortran-to-lisp::*f2cl-function-info*)
 859           (fortran-to-lisp::make-f2cl-finfo
 860            :arg-types '(t (array fortran-to-lisp::integer4 (*))
 861                         (array double-float (*)) (double-float) (double-float)
 862                         (fortran-to-lisp::integer4) (array double-float (*))
 863                         (array double-float (*)) (fortran-to-lisp::integer4)
 864                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 865                         (array double-float (*)) (fortran-to-lisp::integer4)
 866                         (array fortran-to-lisp::integer4 (*))
 867                         (fortran-to-lisp::integer4) t
 868                         (fortran-to-lisp::integer4))
 869            :return-values '(nil nil nil fortran-to-lisp::t$ nil nil nil nil nil
 870                             fortran-to-lisp::istate nil nil nil nil nil nil
 871                             nil)
 872            :calls '(fortran-to-lisp::dstode fortran-to-lisp::xerrwd
 873                     fortran-to-lisp::dintdy fortran-to-lisp::dvnorm
 874                     fortran-to-lisp::dewset))))
 875