share/odepack/src/datv.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 datv (neq y savf v wght ftem f psol z vtem wp iwp hl0 jpre ier npsl)
  21   (declare (type (f2cl-lib:integer4) npsl ier jpre)
  22            (type (double-float) hl0)
  23            (type (array double-float (*)) wp vtem z ftem wght v savf y)
  24            (type (array f2cl-lib:integer4 (*)) iwp neq))
  25   (let ()
  26     (symbol-macrolet ((tn (aref (dls001-part-0 *dls001-common-block*) 216))
  27                       (n (aref (dls001-part-1 *dls001-common-block*) 31))
  28                       (nfe (aref (dls001-part-1 *dls001-common-block*) 34)))
  29       (f2cl-lib:with-multi-array-data
  30           ((neq f2cl-lib:integer4 neq-%data% neq-%offset%)
  31            (iwp f2cl-lib:integer4 iwp-%data% iwp-%offset%)
  32            (y double-float y-%data% y-%offset%)
  33            (savf double-float savf-%data% savf-%offset%)
  34            (v double-float v-%data% v-%offset%)
  35            (wght double-float wght-%data% wght-%offset%)
  36            (ftem double-float ftem-%data% ftem-%offset%)
  37            (z double-float z-%data% z-%offset%)
  38            (vtem double-float vtem-%data% vtem-%offset%)
  39            (wp double-float wp-%data% wp-%offset%))
  40         (prog ((i 0) (tempn 0.0d0) (rnorm 0.0d0) (fac 0.0d0))
  41           (declare (type (double-float) fac rnorm tempn)
  42                    (type (f2cl-lib:integer4) i))
  43           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  44                         ((> i n) nil)
  45             (tagbody
  46              label10
  47               (setf (f2cl-lib:fref vtem-%data% (i) ((1 *)) vtem-%offset%)
  48                       (/ (f2cl-lib:fref v-%data% (i) ((1 *)) v-%offset%)
  49                          (f2cl-lib:fref wght-%data%
  50                                         (i)
  51                                         ((1 *))
  52                                         wght-%offset%)))))
  53           (setf ier 0)
  54           (if (>= jpre 2) (go label30))
  55           (dcopy n y 1 z 1)
  56           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  57                         ((> i n) nil)
  58             (tagbody
  59              label20
  60               (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%)
  61                       (+ (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%)
  62                          (f2cl-lib:fref vtem-%data%
  63                                         (i)
  64                                         ((1 *))
  65                                         vtem-%offset%)))))
  66           (setf fac hl0)
  67           (go label60)
  68          label30
  69           (multiple-value-bind
  70                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
  71                  var-10)
  72               (funcall psol neq tn y savf ftem hl0 wp iwp vtem 2 ier)
  73             (declare (ignore var-0 var-2 var-3 var-4 var-6 var-7 var-8 var-9))
  74             (when var-1
  75               (setf tn var-1))
  76             (when var-5
  77               (setf hl0 var-5))
  78             (when var-10
  79               (setf ier var-10)))
  80           (setf npsl (f2cl-lib:int-add npsl 1))
  81           (if (/= ier 0) (go end_label))
  82           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  83                         ((> i n) nil)
  84             (tagbody
  85              label40
  86               (setf (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%)
  87                       (* (f2cl-lib:fref vtem-%data% (i) ((1 *)) vtem-%offset%)
  88                          (f2cl-lib:fref wght-%data%
  89                                         (i)
  90                                         ((1 *))
  91                                         wght-%offset%)))))
  92           (setf tempn (dnrm2 n z 1))
  93           (setf rnorm (/ 1.0d0 tempn))
  94           (dcopy n y 1 z 1)
  95           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  96                         ((> i n) nil)
  97             (tagbody
  98              label50
  99               (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%)
 100                       (+ (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%)
 101                          (*
 102                           (f2cl-lib:fref vtem-%data% (i) ((1 *)) vtem-%offset%)
 103                           rnorm)))))
 104           (setf fac (* hl0 tempn))
 105          label60
 106           (multiple-value-bind (var-0 var-1 var-2 var-3)
 107               (funcall f neq tn y ftem)
 108             (declare (ignore var-0 var-2 var-3))
 109             (when var-1
 110               (setf tn var-1)))
 111           (setf nfe (f2cl-lib:int-add nfe 1))
 112           (dcopy n z 1 y 1)
 113           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 114                         ((> i n) nil)
 115             (tagbody
 116              label70
 117               (setf (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%)
 118                       (- (f2cl-lib:fref ftem-%data% (i) ((1 *)) ftem-%offset%)
 119                          (f2cl-lib:fref savf-%data%
 120                                         (i)
 121                                         ((1 *))
 122                                         savf-%offset%)))))
 123           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 124                         ((> i n) nil)
 125             (tagbody
 126              label80
 127               (setf (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%)
 128                       (- (f2cl-lib:fref vtem-%data% (i) ((1 *)) vtem-%offset%)
 129                          (* fac
 130                             (f2cl-lib:fref z-%data%
 131                                            (i)
 132                                            ((1 *))
 133                                            z-%offset%))))))
 134           (if (or (= jpre 0) (= jpre 2)) (go label85))
 135           (multiple-value-bind
 136                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
 137                  var-10)
 138               (funcall psol neq tn y savf ftem hl0 wp iwp z 1 ier)
 139             (declare (ignore var-0 var-2 var-3 var-4 var-6 var-7 var-8 var-9))
 140             (when var-1
 141               (setf tn var-1))
 142             (when var-5
 143               (setf hl0 var-5))
 144             (when var-10
 145               (setf ier var-10)))
 146           (setf npsl (f2cl-lib:int-add npsl 1))
 147           (if (/= ier 0) (go end_label))
 148          label85
 149           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 150                         ((> i n) nil)
 151             (tagbody
 152              label90
 153               (setf (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%)
 154                       (* (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%)
 155                          (f2cl-lib:fref wght-%data%
 156                                         (i)
 157                                         ((1 *))
 158                                         wght-%offset%)))))
 159           (go end_label)
 160          end_label
 161           (return
 162            (values nil
 163                    nil
 164                    nil
 165                    nil
 166                    nil
 167                    nil
 168                    nil
 169                    nil
 170                    nil
 171                    nil
 172                    nil
 173                    nil
 174                    hl0
 175                    nil
 176                    ier
 177                    npsl)))))))
 178
 179 (in-package #:cl-user)
 180 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 181 (eval-when (:load-toplevel :compile-toplevel :execute)
 182   (setf (gethash 'fortran-to-lisp::datv fortran-to-lisp::*f2cl-function-info*)
 183           (fortran-to-lisp::make-f2cl-finfo
 184            :arg-types '((array fortran-to-lisp::integer4 (*))
 185                         (array double-float (*)) (array double-float (*))
 186                         (array double-float (*)) (array double-float (*))
 187                         (array double-float (*)) t t (array double-float (*))
 188                         (array double-float (*)) (array double-float (*))
 189                         (array fortran-to-lisp::integer4 (*)) (double-float)
 190                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 191                         (fortran-to-lisp::integer4))
 192            :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil
 193                             fortran-to-lisp::hl0 nil fortran-to-lisp::ier
 194                             fortran-to-lisp::npsl)
 195            :calls '(fortran-to-lisp::dnrm2 fortran-to-lisp::dcopy))))
 196