share/odepack/src/dprepji.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 dprepji (neq y yh nyh ewt rtem savr s wm iwm res jac adda)
  21   (declare (type (f2cl-lib:integer4) nyh)
  22            (type (array double-float (*)) wm s savr rtem ewt yh y)
  23            (type (array f2cl-lib:integer4 (*)) iwm neq))
  24   (let ()
  25     (symbol-macrolet ((el0 (aref (dls001-part-0 *dls001-common-block*) 210))
  26                       (h (aref (dls001-part-0 *dls001-common-block*) 211))
  27                       (tn (aref (dls001-part-0 *dls001-common-block*) 216))
  28                       (ierpj (aref (dls001-part-1 *dls001-common-block*) 13))
  29                       (jcur (aref (dls001-part-1 *dls001-common-block*) 15))
  30                       (miter (aref (dls001-part-1 *dls001-common-block*) 26))
  31                       (n (aref (dls001-part-1 *dls001-common-block*) 31))
  32                       (nfe (aref (dls001-part-1 *dls001-common-block*) 34))
  33                       (nje (aref (dls001-part-1 *dls001-common-block*) 35)))
  34       (f2cl-lib:with-multi-array-data
  35           ((neq f2cl-lib:integer4 neq-%data% neq-%offset%)
  36            (iwm f2cl-lib:integer4 iwm-%data% iwm-%offset%)
  37            (y double-float y-%data% y-%offset%)
  38            (yh double-float yh-%data% yh-%offset%)
  39            (ewt double-float ewt-%data% ewt-%offset%)
  40            (rtem double-float rtem-%data% rtem-%offset%)
  41            (savr double-float savr-%data% savr-%offset%)
  42            (s double-float s-%data% s-%offset%)
  43            (wm double-float wm-%data% wm-%offset%))
  44         (prog ((mu 0) (ml3 0) (ml 0) (meband 0) (meb1 0) (mband 0) (mba 0)
  45                (lenp 0) (jj 0) (j1 0) (j 0) (ires 0) (ii 0) (ier 0) (i2 0)
  46                (i1 0) (i 0) (yjj 0.0d0) (yj 0.0d0) (yi 0.0d0) (srur 0.0d0)
  47                (r 0.0d0) (hl0 0.0d0) (fac 0.0d0) (con 0.0d0))
  48           (declare (type (double-float) con fac hl0 r srur yi yj yjj)
  49                    (type (f2cl-lib:integer4) i i1 i2 ier ii ires j j1 jj lenp
  50                                              mba mband meb1 meband ml ml3 mu))
  51           (setf nje (f2cl-lib:int-add nje 1))
  52           (setf hl0 (* h el0))
  53           (setf ierpj 0)
  54           (setf jcur 1)
  55           (f2cl-lib:computed-goto
  56            (label100 label200 label300 label400 label500)
  57            miter)
  58          label100
  59           (setf ires 1)
  60           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
  61               (funcall res neq tn y s savr ires)
  62             (declare (ignore var-0 var-2 var-3 var-4))
  63             (when var-1
  64               (setf tn var-1))
  65             (when var-5
  66               (setf ires var-5)))
  67           (setf nfe (f2cl-lib:int-add nfe 1))
  68           (if (> ires 1) (go label600))
  69           (setf lenp (f2cl-lib:int-mul n n))
  70           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  71                         ((> i lenp) nil)
  72             (tagbody
  73              label110
  74               (setf (f2cl-lib:fref wm-%data%
  75                                    ((f2cl-lib:int-add i 2))
  76                                    ((1 *))
  77                                    wm-%offset%)
  78                       0.0d0)))
  79           (multiple-value-bind
  80                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)
  81               (funcall jac
  82                        neq
  83                        tn
  84                        y
  85                        s
  86                        0
  87                        0
  88                        (f2cl-lib:array-slice wm-%data%
  89                                              double-float
  90                                              (3)
  91                                              ((1 *))
  92                                              wm-%offset%)
  93                        n)
  94             (declare (ignore var-0 var-2 var-3 var-4 var-5 var-6))
  95             (when var-1
  96               (setf tn var-1))
  97             (when var-7
  98               (setf n var-7)))
  99           (setf con (- hl0))
 100           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 101                         ((> i lenp) nil)
 102             (tagbody
 103              label120
 104               (setf (f2cl-lib:fref wm-%data%
 105                                    ((f2cl-lib:int-add i 2))
 106                                    ((1 *))
 107                                    wm-%offset%)
 108                       (*
 109                        (f2cl-lib:fref wm-%data%
 110                                       ((f2cl-lib:int-add i 2))
 111                                       ((1 *))
 112                                       wm-%offset%)
 113                        con))))
 114           (go label240)
 115          label200
 116           (setf ires -1)
 117           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
 118               (funcall res neq tn y s savr ires)
 119             (declare (ignore var-0 var-2 var-3 var-4))
 120             (when var-1
 121               (setf tn var-1))
 122             (when var-5
 123               (setf ires var-5)))
 124           (setf nfe (f2cl-lib:int-add nfe 1))
 125           (if (> ires 1) (go label600))
 126           (setf srur (f2cl-lib:fref wm-%data% (1) ((1 *)) wm-%offset%))
 127           (setf j1 2)
 128           (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 129                         ((> j n) nil)
 130             (tagbody
 131               (setf yj (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%))
 132               (setf r
 133                       (max (* srur (abs yj))
 134                            (/ 0.01d0
 135                               (f2cl-lib:fref ewt-%data%
 136                                              (j)
 137                                              ((1 *))
 138                                              ewt-%offset%))))
 139               (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%)
 140                       (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) r))
 141               (setf fac (/ (- hl0) r))
 142               (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
 143                   (funcall res neq tn y s rtem ires)
 144                 (declare (ignore var-0 var-2 var-3 var-4))
 145                 (when var-1
 146                   (setf tn var-1))
 147                 (when var-5
 148                   (setf ires var-5)))
 149               (setf nfe (f2cl-lib:int-add nfe 1))
 150               (if (> ires 1) (go label600))
 151               (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 152                             ((> i n) nil)
 153                 (tagbody
 154                  label220
 155                   (setf (f2cl-lib:fref wm-%data%
 156                                        ((f2cl-lib:int-add i j1))
 157                                        ((1 *))
 158                                        wm-%offset%)
 159                           (*
 160                            (-
 161                             (f2cl-lib:fref rtem-%data%
 162                                            (i)
 163                                            ((1 *))
 164                                            rtem-%offset%)
 165                             (f2cl-lib:fref savr-%data%
 166                                            (i)
 167                                            ((1 *))
 168                                            savr-%offset%))
 169                            fac))))
 170               (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) yj)
 171               (setf j1 (f2cl-lib:int-add j1 n))
 172              label230))
 173           (setf ires 1)
 174           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
 175               (funcall res neq tn y s savr ires)
 176             (declare (ignore var-0 var-2 var-3 var-4))
 177             (when var-1
 178               (setf tn var-1))
 179             (when var-5
 180               (setf ires var-5)))
 181           (setf nfe (f2cl-lib:int-add nfe 1))
 182           (if (> ires 1) (go label600))
 183          label240
 184           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 185               (funcall adda
 186                        neq
 187                        tn
 188                        y
 189                        0
 190                        0
 191                        (f2cl-lib:array-slice wm-%data%
 192                                              double-float
 193                                              (3)
 194                                              ((1 *))
 195                                              wm-%offset%)
 196                        n)
 197             (declare (ignore var-0 var-2 var-3 var-4 var-5))
 198             (when var-1
 199               (setf tn var-1))
 200             (when var-6
 201               (setf n var-6)))
 202           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
 203               (dgefa
 204                (f2cl-lib:array-slice wm-%data%
 205                                      double-float
 206                                      (3)
 207                                      ((1 *))
 208                                      wm-%offset%)
 209                n n
 210                (f2cl-lib:array-slice iwm-%data%
 211                                      f2cl-lib:integer4
 212                                      (21)
 213                                      ((1 *))
 214                                      iwm-%offset%)
 215                ier)
 216             (declare (ignore var-0 var-1 var-2 var-3))
 217             (setf ier var-4))
 218           (if (/= ier 0) (setf ierpj 1))
 219           (go end_label)
 220          label300
 221           (go end_label)
 222          label400
 223           (setf ires 1)
 224           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
 225               (funcall res neq tn y s savr ires)
 226             (declare (ignore var-0 var-2 var-3 var-4))
 227             (when var-1
 228               (setf tn var-1))
 229             (when var-5
 230               (setf ires var-5)))
 231           (setf nfe (f2cl-lib:int-add nfe 1))
 232           (if (> ires 1) (go label600))
 233           (setf ml (f2cl-lib:fref iwm-%data% (1) ((1 *)) iwm-%offset%))
 234           (setf mu (f2cl-lib:fref iwm-%data% (2) ((1 *)) iwm-%offset%))
 235           (setf ml3 (f2cl-lib:int-add ml 3))
 236           (setf mband (f2cl-lib:int-add ml mu 1))
 237           (setf meband (f2cl-lib:int-add mband ml))
 238           (setf lenp (f2cl-lib:int-mul meband n))
 239           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 240                         ((> i lenp) nil)
 241             (tagbody
 242              label410
 243               (setf (f2cl-lib:fref wm-%data%
 244                                    ((f2cl-lib:int-add i 2))
 245                                    ((1 *))
 246                                    wm-%offset%)
 247                       0.0d0)))
 248           (multiple-value-bind
 249                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)
 250               (funcall jac
 251                        neq
 252                        tn
 253                        y
 254                        s
 255                        ml
 256                        mu
 257                        (f2cl-lib:array-slice wm-%data%
 258                                              double-float
 259                                              (ml3)
 260                                              ((1 *))
 261                                              wm-%offset%)
 262                        meband)
 263             (declare (ignore var-0 var-2 var-3 var-6))
 264             (when var-1
 265               (setf tn var-1))
 266             (when var-4
 267               (setf ml var-4))
 268             (when var-5
 269               (setf mu var-5))
 270             (when var-7
 271               (setf meband var-7)))
 272           (setf con (- hl0))
 273           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 274                         ((> i lenp) nil)
 275             (tagbody
 276              label420
 277               (setf (f2cl-lib:fref wm-%data%
 278                                    ((f2cl-lib:int-add i 2))
 279                                    ((1 *))
 280                                    wm-%offset%)
 281                       (*
 282                        (f2cl-lib:fref wm-%data%
 283                                       ((f2cl-lib:int-add i 2))
 284                                       ((1 *))
 285                                       wm-%offset%)
 286                        con))))
 287           (go label570)
 288          label500
 289           (setf ires -1)
 290           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
 291               (funcall res neq tn y s savr ires)
 292             (declare (ignore var-0 var-2 var-3 var-4))
 293             (when var-1
 294               (setf tn var-1))
 295             (when var-5
 296               (setf ires var-5)))
 297           (setf nfe (f2cl-lib:int-add nfe 1))
 298           (if (> ires 1) (go label600))
 299           (setf ml (f2cl-lib:fref iwm-%data% (1) ((1 *)) iwm-%offset%))
 300           (setf mu (f2cl-lib:fref iwm-%data% (2) ((1 *)) iwm-%offset%))
 301           (setf ml3 (f2cl-lib:int-add ml 3))
 302           (setf mband (f2cl-lib:int-add ml mu 1))
 303           (setf mba
 304                   (min (the f2cl-lib:integer4 mband)
 305                        (the f2cl-lib:integer4 n)))
 306           (setf meband (f2cl-lib:int-add mband ml))
 307           (setf meb1 (f2cl-lib:int-sub meband 1))
 308           (setf srur (f2cl-lib:fref wm-%data% (1) ((1 *)) wm-%offset%))
 309           (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 310                         ((> j mba) nil)
 311             (tagbody
 312               (f2cl-lib:fdo (i j (f2cl-lib:int-add i mband))
 313                             ((> i n) nil)
 314                 (tagbody
 315                   (setf yi (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%))
 316                   (setf r
 317                           (max (* srur (abs yi))
 318                                (/ 0.01d0
 319                                   (f2cl-lib:fref ewt-%data%
 320                                                  (i)
 321                                                  ((1 *))
 322                                                  ewt-%offset%))))
 323                  label530
 324                   (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%)
 325                           (+ (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%)
 326                              r))))
 327               (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
 328                   (funcall res neq tn y s rtem ires)
 329                 (declare (ignore var-0 var-2 var-3 var-4))
 330                 (when var-1
 331                   (setf tn var-1))
 332                 (when var-5
 333                   (setf ires var-5)))
 334               (setf nfe (f2cl-lib:int-add nfe 1))
 335               (if (> ires 1) (go label600))
 336               (f2cl-lib:fdo (jj j (f2cl-lib:int-add jj mband))
 337                             ((> jj n) nil)
 338                 (tagbody
 339                   (setf (f2cl-lib:fref y-%data% (jj) ((1 *)) y-%offset%)
 340                           (f2cl-lib:fref yh-%data%
 341                                          (jj 1)
 342                                          ((1 nyh) (1 *))
 343                                          yh-%offset%))
 344                   (setf yjj (f2cl-lib:fref y-%data% (jj) ((1 *)) y-%offset%))
 345                   (setf r
 346                           (max (* srur (abs yjj))
 347                                (/ 0.01d0
 348                                   (f2cl-lib:fref ewt-%data%
 349                                                  (jj)
 350                                                  ((1 *))
 351                                                  ewt-%offset%))))
 352                   (setf fac (/ (- hl0) r))
 353                   (setf i1
 354                           (max (the f2cl-lib:integer4 (f2cl-lib:int-sub jj mu))
 355                                (the f2cl-lib:integer4 1)))
 356                   (setf i2
 357                           (min (the f2cl-lib:integer4 (f2cl-lib:int-add jj ml))
 358                                (the f2cl-lib:integer4 n)))
 359                   (setf ii
 360                           (f2cl-lib:int-add
 361                            (f2cl-lib:int-sub (f2cl-lib:int-mul jj meb1) ml)
 362                            2))
 363                   (f2cl-lib:fdo (i i1 (f2cl-lib:int-add i 1))
 364                                 ((> i i2) nil)
 365                     (tagbody
 366                      label540
 367                       (setf (f2cl-lib:fref wm-%data%
 368                                            ((f2cl-lib:int-add ii i))
 369                                            ((1 *))
 370                                            wm-%offset%)
 371                               (*
 372                                (-
 373                                 (f2cl-lib:fref rtem-%data%
 374                                                (i)
 375                                                ((1 *))
 376                                                rtem-%offset%)
 377                                 (f2cl-lib:fref savr-%data%
 378                                                (i)
 379                                                ((1 *))
 380                                                savr-%offset%))
 381                                fac))))
 382                  label550))
 383              label560))
 384           (setf ires 1)
 385           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
 386               (funcall res neq tn y s savr ires)
 387             (declare (ignore var-0 var-2 var-3 var-4))
 388             (when var-1
 389               (setf tn var-1))
 390             (when var-5
 391               (setf ires var-5)))
 392           (setf nfe (f2cl-lib:int-add nfe 1))
 393           (if (> ires 1) (go label600))
 394          label570
 395           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 396               (funcall adda
 397                        neq
 398                        tn
 399                        y
 400                        ml
 401                        mu
 402                        (f2cl-lib:array-slice wm-%data%
 403                                              double-float
 404                                              (ml3)
 405                                              ((1 *))
 406                                              wm-%offset%)
 407                        meband)
 408             (declare (ignore var-0 var-2 var-5))
 409             (when var-1
 410               (setf tn var-1))
 411             (when var-3
 412               (setf ml var-3))
 413             (when var-4
 414               (setf mu var-4))
 415             (when var-6
 416               (setf meband var-6)))
 417           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 418               (dgbfa
 419                (f2cl-lib:array-slice wm-%data%
 420                                      double-float
 421                                      (3)
 422                                      ((1 *))
 423                                      wm-%offset%)
 424                meband n ml mu
 425                (f2cl-lib:array-slice iwm-%data%
 426                                      f2cl-lib:integer4
 427                                      (21)
 428                                      ((1 *))
 429                                      iwm-%offset%)
 430                ier)
 431             (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5))
 432             (setf ier var-6))
 433           (if (/= ier 0) (setf ierpj 1))
 434           (go end_label)
 435          label600
 436           (setf ierpj ires)
 437           (go end_label)
 438          end_label
 439           (return
 440            (values nil nil nil nil nil nil nil nil nil nil nil nil nil)))))))
 441
 442 (in-package #:cl-user)
 443 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 444 (eval-when (:load-toplevel :compile-toplevel :execute)
 445   (setf (gethash 'fortran-to-lisp::dprepji
 446                  fortran-to-lisp::*f2cl-function-info*)
 447           (fortran-to-lisp::make-f2cl-finfo
 448            :arg-types '((array fortran-to-lisp::integer4 (*))
 449                         (array double-float (*)) (array double-float (*))
 450                         (fortran-to-lisp::integer4) (array double-float (*))
 451                         (array double-float (*)) (array double-float (*))
 452                         (array double-float (*)) (array double-float (*))
 453                         (array fortran-to-lisp::integer4 (*)) t t t)
 454            :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil
 455                             nil)
 456            :calls '(fortran-to-lisp::dgbfa fortran-to-lisp::dgefa))))
 457