share/odepack/src/dcfode.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-2017-01 (21B Unicode)
  11 ;;;
  12 ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  13 ;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
  14 ;;;           (:array-slicing t) (:declare-common nil)
  15 ;;;           (:float-format double-float))
  16
  17 (in-package "ODEPACK")
  18
  19
  20 (defun dcfode (meth elco tesco)
  21   (declare (type (array double-float (*)) tesco)
  22            (type (array double-float (*)) elco)
  23            (type (f2cl-lib:integer4) meth))
  24   (prog ((pc (make-array 12 :element-type 'double-float)) (agamq 0.0) (fnq 0.0)
  25          (fnqm1 0.0) (pint 0.0) (ragq 0.0) (rqfac 0.0) (rq1fac 0.0) (tsign 0.0)
  26          (xpin 0.0) (i 0) (ib 0) (nq 0) (nqm1 0) (nqp1 0))
  27     (declare (type (f2cl-lib:integer4) nqp1 nqm1 nq ib i)
  28              (type (simple-array double-float (12)) pc)
  29              (type (double-float) xpin tsign rq1fac rqfac ragq pint fnqm1 fnq
  30                                   agamq))
  31     (f2cl-lib:computed-goto (label100 label200) meth)
  32    label100
  33     (setf (f2cl-lib:fref elco (1 1) ((1 13) (1 12))) 1.0)
  34     (setf (f2cl-lib:fref elco (2 1) ((1 13) (1 12))) 1.0)
  35     (setf (f2cl-lib:fref tesco (1 1) ((1 3) (1 12))) 0.0)
  36     (setf (f2cl-lib:fref tesco (2 1) ((1 3) (1 12))) 2.0)
  37     (setf (f2cl-lib:fref tesco (1 2) ((1 3) (1 12))) 1.0)
  38     (setf (f2cl-lib:fref tesco (3 12) ((1 3) (1 12))) 0.0)
  39     (setf (f2cl-lib:fref pc (1) ((1 12))) 1.0)
  40     (setf rqfac 1.0)
  41     (f2cl-lib:fdo (nq 2 (f2cl-lib:int-add nq 1))
  42                   ((> nq 12) nil)
  43       (tagbody
  44         (setf rq1fac rqfac)
  45         (setf rqfac (/ rqfac nq))
  46         (setf nqm1 (f2cl-lib:int-sub nq 1))
  47         (setf fnqm1 (coerce (the f2cl-lib:integer4 nqm1) 'double-float))
  48         (setf nqp1 (f2cl-lib:int-add nq 1))
  49         (setf (f2cl-lib:fref pc (nq) ((1 12))) 0.0)
  50         (f2cl-lib:fdo (ib 1 (f2cl-lib:int-add ib 1))
  51                       ((> ib nqm1) nil)
  52           (tagbody
  53             (setf i (f2cl-lib:int-sub nqp1 ib))
  54            label110
  55             (setf (f2cl-lib:fref pc (i) ((1 12)))
  56                     (+ (f2cl-lib:fref pc ((f2cl-lib:int-sub i 1)) ((1 12)))
  57                        (* fnqm1 (f2cl-lib:fref pc (i) ((1 12))))))))
  58         (setf (f2cl-lib:fref pc (1) ((1 12)))
  59                 (* fnqm1 (f2cl-lib:fref pc (1) ((1 12)))))
  60         (setf pint (f2cl-lib:fref pc (1) ((1 12))))
  61         (setf xpin (/ (f2cl-lib:fref pc (1) ((1 12))) 2.0))
  62         (setf tsign 1.0)
  63         (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1))
  64                       ((> i nq) nil)
  65           (tagbody
  66             (setf tsign (- tsign))
  67             (setf pint
  68                     (+ pint (/ (* tsign (f2cl-lib:fref pc (i) ((1 12)))) i)))
  69            label120
  70             (setf xpin
  71                     (+ xpin
  72                        (/ (* tsign (f2cl-lib:fref pc (i) ((1 12))))
  73                           (f2cl-lib:int-add i 1))))))
  74         (setf (f2cl-lib:fref elco (1 nq) ((1 13) (1 12))) (* pint rq1fac))
  75         (setf (f2cl-lib:fref elco (2 nq) ((1 13) (1 12))) 1.0)
  76         (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1))
  77                       ((> i nq) nil)
  78           (tagbody
  79            label130
  80             (setf (f2cl-lib:fref elco
  81                                  ((f2cl-lib:int-add i 1) nq)
  82                                  ((1 13) (1 12)))
  83                     (/ (* rq1fac (f2cl-lib:fref pc (i) ((1 12)))) i))))
  84         (setf agamq (* rqfac xpin))
  85         (setf ragq (/ 1.0 agamq))
  86         (setf (f2cl-lib:fref tesco (2 nq) ((1 3) (1 12))) ragq)
  87         (if (< nq 12)
  88             (setf (f2cl-lib:fref tesco (1 nqp1) ((1 3) (1 12)))
  89                     (/ (* ragq rqfac) nqp1)))
  90         (setf (f2cl-lib:fref tesco (3 nqm1) ((1 3) (1 12))) ragq)
  91        label140))
  92     (go end_label)
  93    label200
  94     (setf (f2cl-lib:fref pc (1) ((1 12))) 1.0)
  95     (setf rq1fac 1.0)
  96     (f2cl-lib:fdo (nq 1 (f2cl-lib:int-add nq 1))
  97                   ((> nq 5) nil)
  98       (tagbody
  99         (setf fnq (coerce (the f2cl-lib:integer4 nq) 'double-float))
 100         (setf nqp1 (f2cl-lib:int-add nq 1))
 101         (setf (f2cl-lib:fref pc (nqp1) ((1 12))) 0.0)
 102         (f2cl-lib:fdo (ib 1 (f2cl-lib:int-add ib 1))
 103                       ((> ib nq) nil)
 104           (tagbody
 105             (setf i (f2cl-lib:int-sub (f2cl-lib:int-add nq 2) ib))
 106            label210
 107             (setf (f2cl-lib:fref pc (i) ((1 12)))
 108                     (+ (f2cl-lib:fref pc ((f2cl-lib:int-sub i 1)) ((1 12)))
 109                        (* fnq (f2cl-lib:fref pc (i) ((1 12))))))))
 110         (setf (f2cl-lib:fref pc (1) ((1 12)))
 111                 (* fnq (f2cl-lib:fref pc (1) ((1 12)))))
 112         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 113                       ((> i nqp1) nil)
 114           (tagbody
 115            label220
 116             (setf (f2cl-lib:fref elco (i nq) ((1 13) (1 12)))
 117                     (/ (f2cl-lib:fref pc (i) ((1 12)))
 118                        (f2cl-lib:fref pc (2) ((1 12)))))))
 119         (setf (f2cl-lib:fref elco (2 nq) ((1 13) (1 12))) 1.0)
 120         (setf (f2cl-lib:fref tesco (1 nq) ((1 3) (1 12))) rq1fac)
 121         (setf (f2cl-lib:fref tesco (2 nq) ((1 3) (1 12)))
 122                 (/ nqp1 (f2cl-lib:fref elco (1 nq) ((1 13) (1 12)))))
 123         (setf (f2cl-lib:fref tesco (3 nq) ((1 3) (1 12)))
 124                 (/ (f2cl-lib:int-add nq 2)
 125                    (f2cl-lib:fref elco (1 nq) ((1 13) (1 12)))))
 126         (setf rq1fac (/ rq1fac fnq))
 127        label230))
 128     (go end_label)
 129    end_label
 130     (return (values nil nil nil))))
 131
 132 (in-package #:cl-user)
 133 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 134 (eval-when (:load-toplevel :compile-toplevel :execute)
 135   (setf (gethash 'fortran-to-lisp::dcfode
 136                  fortran-to-lisp::*f2cl-function-info*)
 137           (fortran-to-lisp::make-f2cl-finfo
 138            :arg-types '((fortran-to-lisp::integer4) (array double-float (*))
 139                         (array double-float (*)))
 140            :return-values '(nil nil nil)
 141            :calls 'nil)))
 142