share/odepack/src/sro.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 sro (n ip ia ja a q r dflag)
  21   (declare (type f2cl-lib:logical dflag)
  22            (type (array double-float (*)) a)
  23            (type (array f2cl-lib:integer4 (*)) r q ja ia ip)
  24            (type (f2cl-lib:integer4) n))
  25   (f2cl-lib:with-multi-array-data
  26       ((ip f2cl-lib:integer4 ip-%data% ip-%offset%)
  27        (ia f2cl-lib:integer4 ia-%data% ia-%offset%)
  28        (ja f2cl-lib:integer4 ja-%data% ja-%offset%)
  29        (q f2cl-lib:integer4 q-%data% q-%offset%)
  30        (r f2cl-lib:integer4 r-%data% r-%offset%)
  31        (a double-float a-%data% a-%offset%))
  32     (prog ((ak 0.0d0) (jak 0) (jdummy 0) (ilast 0) (k 0) (j 0) (jmax 0)
  33            (jmin 0) (i 0))
  34       (declare (type (f2cl-lib:integer4) i jmin jmax j k ilast jdummy jak)
  35                (type (double-float) ak))
  36       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  37                     ((> i n) nil)
  38         (tagbody
  39          label1
  40           (setf (f2cl-lib:fref q-%data% (i) ((1 *)) q-%offset%) 0)))
  41       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  42                     ((> i n) nil)
  43         (tagbody
  44           (setf jmin (f2cl-lib:fref ia-%data% (i) ((1 *)) ia-%offset%))
  45           (setf jmax
  46                   (f2cl-lib:int-sub
  47                    (f2cl-lib:fref ia-%data%
  48                                   ((f2cl-lib:int-add i 1))
  49                                   ((1 *))
  50                                   ia-%offset%)
  51                    1))
  52           (if (> jmin jmax) (go label3))
  53           (f2cl-lib:fdo (j jmin (f2cl-lib:int-add j 1))
  54                         ((> j jmax) nil)
  55             (tagbody
  56               (setf k (f2cl-lib:fref ja-%data% (j) ((1 *)) ja-%offset%))
  57               (if
  58                (< (f2cl-lib:fref ip-%data% (k) ((1 *)) ip-%offset%)
  59                   (f2cl-lib:fref ip-%data% (i) ((1 *)) ip-%offset%))
  60                (setf (f2cl-lib:fref ja-%data% (j) ((1 *)) ja-%offset%) i))
  61               (if
  62                (>= (f2cl-lib:fref ip-%data% (k) ((1 *)) ip-%offset%)
  63                    (f2cl-lib:fref ip-%data% (i) ((1 *)) ip-%offset%))
  64                (setf k i))
  65               (setf (f2cl-lib:fref r-%data% (j) ((1 *)) r-%offset%) k)
  66              label2
  67               (setf (f2cl-lib:fref q-%data% (k) ((1 *)) q-%offset%)
  68                       (f2cl-lib:int-add
  69                        (f2cl-lib:fref q-%data% (k) ((1 *)) q-%offset%)
  70                        1))))
  71          label3))
  72       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  73                     ((> i n) nil)
  74         (tagbody
  75           (setf (f2cl-lib:fref ia-%data%
  76                                ((f2cl-lib:int-add i 1))
  77                                ((1 *))
  78                                ia-%offset%)
  79                   (f2cl-lib:int-add
  80                    (f2cl-lib:fref ia-%data% (i) ((1 *)) ia-%offset%)
  81                    (f2cl-lib:fref q-%data% (i) ((1 *)) q-%offset%)))
  82          label4
  83           (setf (f2cl-lib:fref q-%data% (i) ((1 *)) q-%offset%)
  84                   (f2cl-lib:fref ia-%data%
  85                                  ((f2cl-lib:int-add i 1))
  86                                  ((1 *))
  87                                  ia-%offset%))))
  88       (setf ilast 0)
  89       (setf jmin (f2cl-lib:fref ia-%data% (1) ((1 *)) ia-%offset%))
  90       (setf jmax
  91               (f2cl-lib:int-sub
  92                (f2cl-lib:fref ia-%data%
  93                               ((f2cl-lib:int-add n 1))
  94                               ((1 *))
  95                               ia-%offset%)
  96                1))
  97       (setf j jmax)
  98       (f2cl-lib:fdo (jdummy jmin (f2cl-lib:int-add jdummy 1))
  99                     ((> jdummy jmax) nil)
 100         (tagbody
 101           (setf i (f2cl-lib:fref r-%data% (j) ((1 *)) r-%offset%))
 102           (if
 103            (or (not dflag)
 104                (/= (f2cl-lib:fref ja-%data% (j) ((1 *)) ja-%offset%) i)
 105                (= i ilast))
 106            (go label5))
 107           (setf (f2cl-lib:fref r-%data% (j) ((1 *)) r-%offset%)
 108                   (f2cl-lib:fref ia-%data% (i) ((1 *)) ia-%offset%))
 109           (setf ilast i)
 110           (go label6)
 111          label5
 112           (setf (f2cl-lib:fref q-%data% (i) ((1 *)) q-%offset%)
 113                   (f2cl-lib:int-sub
 114                    (f2cl-lib:fref q-%data% (i) ((1 *)) q-%offset%)
 115                    1))
 116           (setf (f2cl-lib:fref r-%data% (j) ((1 *)) r-%offset%)
 117                   (f2cl-lib:fref q-%data% (i) ((1 *)) q-%offset%))
 118          label6
 119           (setf j (f2cl-lib:int-sub j 1))))
 120       (f2cl-lib:fdo (j jmin (f2cl-lib:int-add j 1))
 121                     ((> j jmax) nil)
 122         (tagbody
 123          label7
 124           (if (= (f2cl-lib:fref r-%data% (j) ((1 *)) r-%offset%) j)
 125               (go label8))
 126           (setf k (f2cl-lib:fref r-%data% (j) ((1 *)) r-%offset%))
 127           (setf (f2cl-lib:fref r-%data% (j) ((1 *)) r-%offset%)
 128                   (f2cl-lib:fref r-%data% (k) ((1 *)) r-%offset%))
 129           (setf (f2cl-lib:fref r-%data% (k) ((1 *)) r-%offset%) k)
 130           (setf jak (f2cl-lib:fref ja-%data% (k) ((1 *)) ja-%offset%))
 131           (setf (f2cl-lib:fref ja-%data% (k) ((1 *)) ja-%offset%)
 132                   (f2cl-lib:fref ja-%data% (j) ((1 *)) ja-%offset%))
 133           (setf (f2cl-lib:fref ja-%data% (j) ((1 *)) ja-%offset%) jak)
 134           (setf ak (f2cl-lib:fref a-%data% (k) ((1 *)) a-%offset%))
 135           (setf (f2cl-lib:fref a-%data% (k) ((1 *)) a-%offset%)
 136                   (f2cl-lib:fref a-%data% (j) ((1 *)) a-%offset%))
 137           (setf (f2cl-lib:fref a-%data% (j) ((1 *)) a-%offset%) ak)
 138           (go label7)
 139          label8))
 140       (go end_label)
 141      end_label
 142       (return (values nil nil nil nil nil nil nil nil)))))
 143
 144 (in-package #:cl-user)
 145 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 146 (eval-when (:load-toplevel :compile-toplevel :execute)
 147   (setf (gethash 'fortran-to-lisp::sro fortran-to-lisp::*f2cl-function-info*)
 148           (fortran-to-lisp::make-f2cl-finfo
 149            :arg-types '((fortran-to-lisp::integer4)
 150                         (array fortran-to-lisp::integer4 (*))
 151                         (array fortran-to-lisp::integer4 (*))
 152                         (array fortran-to-lisp::integer4 (*))
 153                         (array double-float (*))
 154                         (array fortran-to-lisp::integer4 (*))
 155                         (array fortran-to-lisp::integer4 (*))
 156                         fortran-to-lisp::logical)
 157            :return-values '(nil nil nil nil nil nil nil nil)
 158            :calls 'nil)))
 159