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