share/odepack/src/dintdy.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 dintdy (t$ k yh nyh dky iflag)
  21   (declare (type (array double-float (*)) dky yh)
  22            (type (f2cl-lib:integer4) iflag nyh k)
  23            (type (double-float) t$))
  24   (let ()
  25     (symbol-macrolet ((h (aref (dls001-part-0 *dls001-common-block*) 211))
  26                       (hu (aref (dls001-part-0 *dls001-common-block*) 214))
  27                       (tn (aref (dls001-part-0 *dls001-common-block*) 216))
  28                       (uround (aref (dls001-part-0 *dls001-common-block*) 217))
  29                       (l (aref (dls001-part-1 *dls001-common-block*) 18))
  30                       (n (aref (dls001-part-1 *dls001-common-block*) 31))
  31                       (nq (aref (dls001-part-1 *dls001-common-block*) 32)))
  32       (prog ((jp1 0) (jj1 0) (jj 0) (jb2 0) (jb 0) (j 0) (ic 0) (i 0) (tp 0.0)
  33              (s 0.0) (r 0.0) (c 0.0)
  34              (msg
  35               (make-array '(80)
  36                           :element-type 'character
  37                           :initial-element #\ )))
  38         (declare (type (string 80) msg)
  39                  (type (double-float) c r s tp)
  40                  (type (f2cl-lib:integer4) i ic j jb jb2 jj jj1 jp1))
  41         (setf iflag 0)
  42         (if (or (< k 0) (> k nq)) (go label80))
  43         (setf tp (+ (- tn hu) (* -100.0 uround (+ tn hu))))
  44         (if (> (* (- t$ tp) (- t$ tn)) 0.0) (go label90))
  45         (setf s (/ (- t$ tn) h))
  46         (setf ic 1)
  47         (if (= k 0) (go label15))
  48         (setf jj1 (f2cl-lib:int-sub l k))
  49         (f2cl-lib:fdo (jj jj1 (f2cl-lib:int-add jj 1))
  50                       ((> jj nq) nil)
  51           (tagbody label10 (setf ic (f2cl-lib:int-mul ic jj))))
  52        label15
  53         (setf c (coerce (the f2cl-lib:integer4 ic) 'double-float))
  54         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  55                       ((> i n) nil)
  56           (tagbody
  57            label20
  58             (setf (f2cl-lib:fref dky (i) ((1 *)))
  59                     (* c (f2cl-lib:fref yh (i l) ((1 nyh) (1 *)))))))
  60         (if (= k nq) (go label55))
  61         (setf jb2 (f2cl-lib:int-sub nq k))
  62         (f2cl-lib:fdo (jb 1 (f2cl-lib:int-add jb 1))
  63                       ((> jb jb2) nil)
  64           (tagbody
  65             (setf j (f2cl-lib:int-sub nq jb))
  66             (setf jp1 (f2cl-lib:int-add j 1))
  67             (setf ic 1)
  68             (if (= k 0) (go label35))
  69             (setf jj1 (f2cl-lib:int-sub jp1 k))
  70             (f2cl-lib:fdo (jj jj1 (f2cl-lib:int-add jj 1))
  71                           ((> jj j) nil)
  72               (tagbody label30 (setf ic (f2cl-lib:int-mul ic jj))))
  73            label35
  74             (setf c (coerce (the f2cl-lib:integer4 ic) 'double-float))
  75             (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  76                           ((> i n) nil)
  77               (tagbody
  78                label40
  79                 (setf (f2cl-lib:fref dky (i) ((1 *)))
  80                         (+ (* c (f2cl-lib:fref yh (i jp1) ((1 nyh) (1 *))))
  81                            (* s (f2cl-lib:fref dky (i) ((1 *))))))))
  82            label50))
  83         (if (= k 0) (go end_label))
  84        label55
  85         (setf r (expt h (f2cl-lib:int-sub k)))
  86         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  87                       ((> i n) nil)
  88           (tagbody
  89            label60
  90             (setf (f2cl-lib:fref dky (i) ((1 *)))
  91                     (* r (f2cl-lib:fref dky (i) ((1 *)))))))
  92         (go end_label)
  93        label80
  94         (f2cl-lib:f2cl-set-string msg
  95                                   "DINTDY-  K (=I1) illegal      "
  96                                   (string 80))
  97         (xerrwd msg 30 51 0 1 k 0 0 0.0 0.0)
  98         (setf iflag -1)
  99         (go end_label)
 100        label90
 101         (f2cl-lib:f2cl-set-string msg
 102                                   "DINTDY-  T (=R1) illegal      "
 103                                   (string 80))
 104         (xerrwd msg 30 52 0 0 0 0 1 t$ 0.0)
 105         (f2cl-lib:f2cl-set-string msg
 106                                   "      T not in interval TCUR - HU (= R1) to TCUR (=R2)      "
 107                                   (string 80))
 108         (xerrwd msg 60 52 0 0 0 0 2 tp tn)
 109         (setf iflag -2)
 110         (go end_label)
 111        end_label
 112         (return (values nil nil nil nil nil iflag))))))
 113
 114 (in-package #:cl-user)
 115 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 116 (eval-when (:load-toplevel :compile-toplevel :execute)
 117   (setf (gethash 'fortran-to-lisp::dintdy
 118                  fortran-to-lisp::*f2cl-function-info*)
 119           (fortran-to-lisp::make-f2cl-finfo
 120            :arg-types '((double-float) (fortran-to-lisp::integer4)
 121                         (array double-float (*)) (fortran-to-lisp::integer4)
 122                         (array double-float (*)) (fortran-to-lisp::integer4))
 123            :return-values '(nil nil nil nil nil fortran-to-lisp::iflag)
 124            :calls '(fortran-to-lisp::xerrwd))))
 125