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