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