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