share/odepack/src/dsolss.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 dsolss (wk iwk x tem)
  21   (declare (type (array f2cl-lib:integer4 (*)) iwk)
  22            (type (array double-float (*)) tem x wk))
  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                       (iersl (aref (dls001-part-1 *dls001-common-block*) 14))
  27                       (miter (aref (dls001-part-1 *dls001-common-block*) 26))
  28                       (n (aref (dls001-part-1 *dls001-common-block*) 31))
  29                       (iesp (aref (dlss01-part-1 *dlss01-common-block*) 1))
  30                       (ipian (aref (dlss01-part-1 *dlss01-common-block*) 8))
  31                       (ipjan (aref (dlss01-part-1 *dlss01-common-block*) 9))
  32                       (ipr (aref (dlss01-part-1 *dlss01-common-block*) 12))
  33                       (ipc (aref (dlss01-part-1 *dlss01-common-block*) 13))
  34                       (ipic (aref (dlss01-part-1 *dlss01-common-block*) 14))
  35                       (ipisp (aref (dlss01-part-1 *dlss01-common-block*) 15))
  36                       (iprsp (aref (dlss01-part-1 *dlss01-common-block*) 16))
  37                       (ipa (aref (dlss01-part-1 *dlss01-common-block*) 17))
  38                       (nsp (aref (dlss01-part-1 *dlss01-common-block*) 31)))
  39       (f2cl-lib:with-multi-array-data
  40           ((wk double-float wk-%data% wk-%offset%)
  41            (x double-float x-%data% x-%offset%)
  42            (tem double-float tem-%data% tem-%offset%)
  43            (iwk f2cl-lib:integer4 iwk-%data% iwk-%offset%))
  44         (prog ((i 0) (r 0.0d0) (phl0 0.0d0) (hl0 0.0d0) (di 0.0d0))
  45           (declare (type (double-float) di hl0 phl0 r)
  46                    (type (f2cl-lib:integer4) i))
  47           (setf iersl 0)
  48           (f2cl-lib:computed-goto (label100 label100 label300) miter)
  49          label100
  50           (multiple-value-bind
  51                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
  52                  var-10 var-11 var-12 var-13 var-14)
  53               (cdrv n
  54                (f2cl-lib:array-slice iwk-%data%
  55                                      f2cl-lib:integer4
  56                                      (ipr)
  57                                      ((1 *))
  58                                      iwk-%offset%)
  59                (f2cl-lib:array-slice iwk-%data%
  60                                      f2cl-lib:integer4
  61                                      (ipc)
  62                                      ((1 *))
  63                                      iwk-%offset%)
  64                (f2cl-lib:array-slice iwk-%data%
  65                                      f2cl-lib:integer4
  66                                      (ipic)
  67                                      ((1 *))
  68                                      iwk-%offset%)
  69                (f2cl-lib:array-slice iwk-%data%
  70                                      f2cl-lib:integer4
  71                                      (ipian)
  72                                      ((1 *))
  73                                      iwk-%offset%)
  74                (f2cl-lib:array-slice iwk-%data%
  75                                      f2cl-lib:integer4
  76                                      (ipjan)
  77                                      ((1 *))
  78                                      iwk-%offset%)
  79                (f2cl-lib:array-slice wk-%data%
  80                                      double-float
  81                                      (ipa)
  82                                      ((1 *))
  83                                      wk-%offset%)
  84                x x nsp
  85                (f2cl-lib:array-slice iwk-%data%
  86                                      f2cl-lib:integer4
  87                                      (ipisp)
  88                                      ((1 *))
  89                                      iwk-%offset%)
  90                (f2cl-lib:array-slice wk-%data%
  91                                      double-float
  92                                      (iprsp)
  93                                      ((1 *))
  94                                      wk-%offset%)
  95                iesp 4 iersl)
  96             (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
  97                              var-8 var-9 var-10 var-11 var-13))
  98             (setf iesp var-12)
  99             (setf iersl var-14))
 100           (if (/= iersl 0) (setf iersl -1))
 101           (go end_label)
 102          label300
 103           (setf phl0 (f2cl-lib:fref wk-%data% (2) ((1 *)) wk-%offset%))
 104           (setf hl0 (* h el0))
 105           (setf (f2cl-lib:fref wk-%data% (2) ((1 *)) wk-%offset%) hl0)
 106           (if (= hl0 phl0) (go label330))
 107           (setf r (/ hl0 phl0))
 108           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 109                         ((> i n) nil)
 110             (tagbody
 111               (setf di
 112                       (- 1.0d0
 113                          (* r
 114                             (+ 1.0d0
 115                                (/ -1.0d0
 116                                   (f2cl-lib:fref wk-%data%
 117                                                  ((f2cl-lib:int-add i 2))
 118                                                  ((1 *))
 119                                                  wk-%offset%))))))
 120               (if (= (abs di) 0.0d0) (go label390))
 121              label320
 122               (setf (f2cl-lib:fref wk-%data%
 123                                    ((f2cl-lib:int-add i 2))
 124                                    ((1 *))
 125                                    wk-%offset%)
 126                       (/ 1.0d0 di))))
 127          label330
 128           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 129                         ((> i n) nil)
 130             (tagbody
 131              label340
 132               (setf (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%)
 133                       (*
 134                        (f2cl-lib:fref wk-%data%
 135                                       ((f2cl-lib:int-add i 2))
 136                                       ((1 *))
 137                                       wk-%offset%)
 138                        (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%)))))
 139           (go end_label)
 140          label390
 141           (setf iersl 1)
 142           (go end_label)
 143          end_label
 144           (return (values nil nil nil nil)))))))
 145
 146 (in-package #:cl-user)
 147 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 148 (eval-when (:load-toplevel :compile-toplevel :execute)
 149   (setf (gethash 'fortran-to-lisp::dsolss
 150                  fortran-to-lisp::*f2cl-function-info*)
 151           (fortran-to-lisp::make-f2cl-finfo
 152            :arg-types '((array double-float (*))
 153                         (array fortran-to-lisp::integer4 (*))
 154                         (array double-float (*)) (array double-float (*)))
 155            :return-values '(nil nil nil nil)
 156            :calls '(fortran-to-lisp::cdrv))))
 157