share/odepack/src/daigbt.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 daigbt (res adda neq t$ y ydot mb nb pw ipvt ier)
  21   (declare (type (f2cl-lib:integer4) ier nb mb)
  22            (type (array double-float (*)) pw ydot y)
  23            (type (double-float) t$)
  24            (type (array f2cl-lib:integer4 (*)) ipvt neq))
  25   (f2cl-lib:with-multi-array-data
  26       ((neq f2cl-lib:integer4 neq-%data% neq-%offset%)
  27        (ipvt f2cl-lib:integer4 ipvt-%data% ipvt-%offset%)
  28        (y double-float y-%data% y-%offset%)
  29        (ydot double-float ydot-%data% ydot-%offset%)
  30        (pw double-float pw-%data% pw-%offset%))
  31     (prog ((i 0) (lenpw 0) (lblox 0) (lpb 0) (lpc 0))
  32       (declare (type (f2cl-lib:integer4) lpc lpb lblox lenpw i))
  33       (setf lblox (f2cl-lib:int-mul mb mb nb))
  34       (setf lpb (f2cl-lib:int-add 1 lblox))
  35       (setf lpc (f2cl-lib:int-add lpb lblox))
  36       (setf lenpw (f2cl-lib:int-mul 3 lblox))
  37       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  38                     ((> i lenpw) nil)
  39         (tagbody
  40          label10
  41           (setf (f2cl-lib:fref pw-%data% (i) ((1 *)) pw-%offset%) 0.0d0)))
  42       (setf ier 1)
  43       (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
  44           (funcall res neq t$ y pw ydot ier)
  45         (declare (ignore var-0 var-2 var-3 var-4))
  46         (when var-1
  47           (setf t$ var-1))
  48         (when var-5
  49           (setf ier var-5)))
  50       (if (> ier 1) (go end_label))
  51       (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)
  52           (funcall adda
  53                    neq
  54                    t$
  55                    y
  56                    mb
  57                    nb
  58                    (f2cl-lib:array-slice pw-%data%
  59                                          double-float
  60                                          (1)
  61                                          ((1 *))
  62                                          pw-%offset%)
  63                    (f2cl-lib:array-slice pw-%data%
  64                                          double-float
  65                                          (lpb)
  66                                          ((1 *))
  67                                          pw-%offset%)
  68                    (f2cl-lib:array-slice pw-%data%
  69                                          double-float
  70                                          (lpc)
  71                                          ((1 *))
  72                                          pw-%offset%))
  73         (declare (ignore var-0 var-2 var-5 var-6 var-7))
  74         (when var-1
  75           (setf t$ var-1))
  76         (when var-3
  77           (setf mb var-3))
  78         (when var-4
  79           (setf nb var-4)))
  80       (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
  81           (ddecbt mb nb pw
  82            (f2cl-lib:array-slice pw-%data%
  83                                  double-float
  84                                  (lpb)
  85                                  ((1 *))
  86                                  pw-%offset%)
  87            (f2cl-lib:array-slice pw-%data%
  88                                  double-float
  89                                  (lpc)
  90                                  ((1 *))
  91                                  pw-%offset%)
  92            ipvt ier)
  93         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5))
  94         (setf ier var-6))
  95       (if (= ier 0) (go label20))
  96       (setf ier (f2cl-lib:int-sub ier))
  97       (go end_label)
  98      label20
  99       (dsolbt mb nb pw
 100        (f2cl-lib:array-slice pw-%data% double-float (lpb) ((1 *)) pw-%offset%)
 101        (f2cl-lib:array-slice pw-%data% double-float (lpc) ((1 *)) pw-%offset%)
 102        ydot ipvt)
 103       (go end_label)
 104      end_label
 105       (return (values nil nil nil t$ nil nil mb nb nil nil ier)))))
 106
 107 (in-package #:cl-user)
 108 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 109 (eval-when (:load-toplevel :compile-toplevel :execute)
 110   (setf (gethash 'fortran-to-lisp::daigbt
 111                  fortran-to-lisp::*f2cl-function-info*)
 112           (fortran-to-lisp::make-f2cl-finfo
 113            :arg-types '(t t (array fortran-to-lisp::integer4 (*))
 114                         (double-float) (array double-float (*))
 115                         (array double-float (*)) (fortran-to-lisp::integer4)
 116                         (fortran-to-lisp::integer4) (array double-float (*))
 117                         (array fortran-to-lisp::integer4 (*))
 118                         (fortran-to-lisp::integer4))
 119            :return-values '(nil nil nil fortran-to-lisp::t$ nil nil
 120                             fortran-to-lisp::mb fortran-to-lisp::nb nil nil
 121                             fortran-to-lisp::ier)
 122            :calls '(fortran-to-lisp::dsolbt fortran-to-lisp::ddecbt))))
 123