share/odepack/src/dainvgs.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 dainvgs (neq t$ y wk iwk tem ydot ier res adda)
  21   (declare (type (array f2cl-lib:integer4 (*)) iwk)
  22            (type (array double-float (*)) ydot tem wk y)
  23            (type (double-float) t$)
  24            (type (f2cl-lib:integer4) ier neq))
  25   (let ()
  26     (symbol-macrolet ((iesp (aref (dlss01-part-1 *dlss01-common-block*) 1))
  27                       (iys (aref (dlss01-part-1 *dlss01-common-block*) 3))
  28                       (iba (aref (dlss01-part-1 *dlss01-common-block*) 4))
  29                       (ibjan (aref (dlss01-part-1 *dlss01-common-block*) 6))
  30                       (ipian (aref (dlss01-part-1 *dlss01-common-block*) 8))
  31                       (ipjan (aref (dlss01-part-1 *dlss01-common-block*) 9))
  32                       (ipr (aref (dlss01-part-1 *dlss01-common-block*) 12))
  33                       (ipc (aref (dlss01-part-1 *dlss01-common-block*) 13))
  34                       (ipic (aref (dlss01-part-1 *dlss01-common-block*) 14))
  35                       (ipisp (aref (dlss01-part-1 *dlss01-common-block*) 15))
  36                       (iprsp (aref (dlss01-part-1 *dlss01-common-block*) 16))
  37                       (ipa (aref (dlss01-part-1 *dlss01-common-block*) 17))
  38                       (nlu (aref (dlss01-part-1 *dlss01-common-block*) 29))
  39                       (nnz (aref (dlss01-part-1 *dlss01-common-block*) 30))
  40                       (nsp (aref (dlss01-part-1 *dlss01-common-block*) 31)))
  41       (f2cl-lib:with-multi-array-data
  42           ((y double-float y-%data% y-%offset%)
  43            (wk double-float wk-%data% wk-%offset%)
  44            (tem double-float tem-%data% tem-%offset%)
  45            (ydot double-float ydot-%data% ydot-%offset%)
  46            (iwk f2cl-lib:integer4 iwk-%data% iwk-%offset%))
  47         (prog ((kmax 0) (kmin 0) (k 0) (j 0) (imul 0) (i 0))
  48           (declare (type (f2cl-lib:integer4) i imul j k kmin kmax))
  49           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  50                         ((> i nnz) nil)
  51             (tagbody
  52              label10
  53               (setf (f2cl-lib:fref wk-%data%
  54                                    ((f2cl-lib:int-add iba i))
  55                                    ((1 *))
  56                                    wk-%offset%)
  57                       0.0d0)))
  58           (setf ier 1)
  59           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
  60               (funcall res
  61                        neq
  62                        t$
  63                        y
  64                        (f2cl-lib:array-slice wk-%data%
  65                                              double-float
  66                                              (ipa)
  67                                              ((1 *))
  68                                              wk-%offset%)
  69                        ydot
  70                        ier)
  71             (declare (ignore var-2 var-3 var-4))
  72             (when var-0
  73               (setf neq var-0))
  74             (when var-1
  75               (setf t$ var-1))
  76             (when var-5
  77               (setf ier var-5)))
  78           (if (> ier 1) (go end_label))
  79           (setf kmin (f2cl-lib:fref iwk-%data% (ipian) ((1 *)) iwk-%offset%))
  80           (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
  81                         ((> j neq) nil)
  82             (tagbody
  83               (setf kmax
  84                       (f2cl-lib:int-sub
  85                        (f2cl-lib:fref iwk-%data%
  86                                       ((f2cl-lib:int-add ipian j))
  87                                       ((1 *))
  88                                       iwk-%offset%)
  89                        1))
  90               (f2cl-lib:fdo (k kmin (f2cl-lib:int-add k 1))
  91                             ((> k kmax) nil)
  92                 (tagbody
  93                   (setf i
  94                           (f2cl-lib:fref iwk-%data%
  95                                          ((f2cl-lib:int-add ibjan k))
  96                                          ((1 *))
  97                                          iwk-%offset%))
  98                  label15
  99                   (setf (f2cl-lib:fref tem-%data% (i) ((1 *)) tem-%offset%)
 100                           0.0d0)))
 101               (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 102                   (funcall adda
 103                            neq
 104                            t$
 105                            y
 106                            j
 107                            (f2cl-lib:array-slice iwk-%data%
 108                                                  f2cl-lib:integer4
 109                                                  (ipian)
 110                                                  ((1 *))
 111                                                  iwk-%offset%)
 112                            (f2cl-lib:array-slice iwk-%data%
 113                                                  f2cl-lib:integer4
 114                                                  (ipjan)
 115                                                  ((1 *))
 116                                                  iwk-%offset%)
 117                            tem)
 118                 (declare (ignore var-2 var-4 var-5 var-6))
 119                 (when var-0
 120                   (setf neq var-0))
 121                 (when var-1
 122                   (setf t$ var-1))
 123                 (when var-3
 124                   (setf j var-3)))
 125               (f2cl-lib:fdo (k kmin (f2cl-lib:int-add k 1))
 126                             ((> k kmax) nil)
 127                 (tagbody
 128                   (setf i
 129                           (f2cl-lib:fref iwk-%data%
 130                                          ((f2cl-lib:int-add ibjan k))
 131                                          ((1 *))
 132                                          iwk-%offset%))
 133                  label20
 134                   (setf (f2cl-lib:fref wk-%data%
 135                                        ((f2cl-lib:int-add iba k))
 136                                        ((1 *))
 137                                        wk-%offset%)
 138                           (f2cl-lib:fref tem-%data%
 139                                          (i)
 140                                          ((1 *))
 141                                          tem-%offset%))))
 142               (setf kmin (f2cl-lib:int-add kmax 1))
 143              label30))
 144           (setf nlu (f2cl-lib:int-add nlu 1))
 145           (setf ier 0)
 146           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 147                         ((> i neq) nil)
 148             (tagbody
 149              label40
 150               (setf (f2cl-lib:fref tem-%data% (i) ((1 *)) tem-%offset%)
 151                       0.0d0)))
 152           (multiple-value-bind
 153                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
 154                  var-10 var-11 var-12 var-13 var-14)
 155               (cdrv neq
 156                (f2cl-lib:array-slice iwk-%data%
 157                                      f2cl-lib:integer4
 158                                      (ipr)
 159                                      ((1 *))
 160                                      iwk-%offset%)
 161                (f2cl-lib:array-slice iwk-%data%
 162                                      f2cl-lib:integer4
 163                                      (ipc)
 164                                      ((1 *))
 165                                      iwk-%offset%)
 166                (f2cl-lib:array-slice iwk-%data%
 167                                      f2cl-lib:integer4
 168                                      (ipic)
 169                                      ((1 *))
 170                                      iwk-%offset%)
 171                (f2cl-lib:array-slice iwk-%data%
 172                                      f2cl-lib:integer4
 173                                      (ipian)
 174                                      ((1 *))
 175                                      iwk-%offset%)
 176                (f2cl-lib:array-slice iwk-%data%
 177                                      f2cl-lib:integer4
 178                                      (ipjan)
 179                                      ((1 *))
 180                                      iwk-%offset%)
 181                (f2cl-lib:array-slice wk-%data%
 182                                      double-float
 183                                      (ipa)
 184                                      ((1 *))
 185                                      wk-%offset%)
 186                tem tem nsp
 187                (f2cl-lib:array-slice iwk-%data%
 188                                      f2cl-lib:integer4
 189                                      (ipisp)
 190                                      ((1 *))
 191                                      iwk-%offset%)
 192                (f2cl-lib:array-slice wk-%data%
 193                                      double-float
 194                                      (iprsp)
 195                                      ((1 *))
 196                                      wk-%offset%)
 197                iesp 2 iys)
 198             (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
 199                              var-8 var-9 var-10 var-11 var-13))
 200             (setf iesp var-12)
 201             (setf iys var-14))
 202           (if (= iys 0) (go label50))
 203           (setf imul (the f2cl-lib:integer4 (truncate (- iys 1) neq)))
 204           (setf ier 5)
 205           (if (= imul 8) (setf ier 1))
 206           (if (= imul 10) (setf ier 4))
 207           (go end_label)
 208          label50
 209           (multiple-value-bind
 210                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
 211                  var-10 var-11 var-12 var-13 var-14)
 212               (cdrv neq
 213                (f2cl-lib:array-slice iwk-%data%
 214                                      f2cl-lib:integer4
 215                                      (ipr)
 216                                      ((1 *))
 217                                      iwk-%offset%)
 218                (f2cl-lib:array-slice iwk-%data%
 219                                      f2cl-lib:integer4
 220                                      (ipc)
 221                                      ((1 *))
 222                                      iwk-%offset%)
 223                (f2cl-lib:array-slice iwk-%data%
 224                                      f2cl-lib:integer4
 225                                      (ipic)
 226                                      ((1 *))
 227                                      iwk-%offset%)
 228                (f2cl-lib:array-slice iwk-%data%
 229                                      f2cl-lib:integer4
 230                                      (ipian)
 231                                      ((1 *))
 232                                      iwk-%offset%)
 233                (f2cl-lib:array-slice iwk-%data%
 234                                      f2cl-lib:integer4
 235                                      (ipjan)
 236                                      ((1 *))
 237                                      iwk-%offset%)
 238                (f2cl-lib:array-slice wk-%data%
 239                                      double-float
 240                                      (ipa)
 241                                      ((1 *))
 242                                      wk-%offset%)
 243                ydot ydot nsp
 244                (f2cl-lib:array-slice iwk-%data%
 245                                      f2cl-lib:integer4
 246                                      (ipisp)
 247                                      ((1 *))
 248                                      iwk-%offset%)
 249                (f2cl-lib:array-slice wk-%data%
 250                                      double-float
 251                                      (iprsp)
 252                                      ((1 *))
 253                                      wk-%offset%)
 254                iesp 4 iys)
 255             (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
 256                              var-8 var-9 var-10 var-11 var-13))
 257             (setf iesp var-12)
 258             (setf iys var-14))
 259           (if (/= iys 0) (setf ier 5))
 260           (go end_label)
 261          end_label
 262           (return (values neq t$ nil nil nil nil nil ier nil nil)))))))
 263
 264 (in-package #:cl-user)
 265 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 266 (eval-when (:load-toplevel :compile-toplevel :execute)
 267   (setf (gethash 'fortran-to-lisp::dainvgs
 268                  fortran-to-lisp::*f2cl-function-info*)
 269           (fortran-to-lisp::make-f2cl-finfo
 270            :arg-types '((fortran-to-lisp::integer4) (double-float)
 271                         (array double-float (*)) (array double-float (*))
 272                         (array fortran-to-lisp::integer4 (*))
 273                         (array double-float (*)) (array double-float (*))
 274                         (fortran-to-lisp::integer4) t t)
 275            :return-values '(fortran-to-lisp::neq fortran-to-lisp::t$ nil nil
 276                             nil nil nil fortran-to-lisp::ier nil nil)
 277            :calls '(fortran-to-lisp::cdrv))))
 278