share/odepack/src/dspiom.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 dspiom
  21        (neq tn y savf b wght n maxl kmp delta hl0 jpre mnewt f psol npsl x v
  22         hes ipvt liom wp iwp wk iflag)
  23   (declare (type (f2cl-lib:integer4) iflag liom npsl mnewt jpre kmp maxl n)
  24            (type (array double-float (*)) wk wp hes v x wght b savf y)
  25            (type (double-float) hl0 delta tn)
  26            (type (array f2cl-lib:integer4 (*)) iwp ipvt neq))
  27   (f2cl-lib:with-multi-array-data
  28       ((neq f2cl-lib:integer4 neq-%data% neq-%offset%)
  29        (ipvt f2cl-lib:integer4 ipvt-%data% ipvt-%offset%)
  30        (iwp f2cl-lib:integer4 iwp-%data% iwp-%offset%)
  31        (y double-float y-%data% y-%offset%)
  32        (savf double-float savf-%data% savf-%offset%)
  33        (b double-float b-%data% b-%offset%)
  34        (wght double-float wght-%data% wght-%offset%)
  35        (x double-float x-%data% x-%offset%)
  36        (v double-float v-%data% v-%offset%)
  37        (hes double-float hes-%data% hes-%offset%)
  38        (wp double-float wp-%data% wp-%offset%)
  39        (wk double-float wk-%data% wk-%offset%))
  40     (prog ((bnrm 0.0d0) (bnrm0 0.0d0) (prod 0.0d0) (rho 0.0d0) (snormw 0.0d0)
  41            (tem 0.0d0) (i 0) (ier 0) (info 0) (j 0) (k 0) (ll 0) (lm1 0))
  42       (declare (type (f2cl-lib:integer4) lm1 ll k j info ier i)
  43                (type (double-float) tem snormw rho prod bnrm0 bnrm))
  44       (setf iflag 0)
  45       (setf liom 0)
  46       (setf npsl 0)
  47       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  48                     ((> i n) nil)
  49         (tagbody
  50          label10
  51           (setf (f2cl-lib:fref v-%data% (i 1) ((1 n) (1 *)) v-%offset%)
  52                   (* (f2cl-lib:fref b-%data% (i) ((1 *)) b-%offset%)
  53                      (f2cl-lib:fref wght-%data% (i) ((1 *)) wght-%offset%)))))
  54       (setf bnrm0 (dnrm2 n v 1))
  55       (setf bnrm bnrm0)
  56       (if (> bnrm0 delta) (go label30))
  57       (if (> mnewt 0) (go label20))
  58       (dcopy n b 1 x 1)
  59       (go end_label)
  60      label20
  61       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  62                     ((> i n) nil)
  63         (tagbody
  64          label25
  65           (setf (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%) 0.0d0)))
  66       (go end_label)
  67      label30
  68       (setf ier 0)
  69       (if (or (= jpre 0) (= jpre 2)) (go label55))
  70       (multiple-value-bind
  71             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
  72              var-10)
  73           (funcall psol neq tn y savf wk hl0 wp iwp b 1 ier)
  74         (declare (ignore var-0 var-2 var-3 var-4 var-6 var-7 var-8 var-9))
  75         (when var-1
  76           (setf tn var-1))
  77         (when var-5
  78           (setf hl0 var-5))
  79         (when var-10
  80           (setf ier var-10)))
  81       (setf npsl 1)
  82       (if (/= ier 0) (go label300))
  83       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  84                     ((> i n) nil)
  85         (tagbody
  86          label50
  87           (setf (f2cl-lib:fref v-%data% (i 1) ((1 n) (1 *)) v-%offset%)
  88                   (* (f2cl-lib:fref b-%data% (i) ((1 *)) b-%offset%)
  89                      (f2cl-lib:fref wght-%data% (i) ((1 *)) wght-%offset%)))))
  90       (setf bnrm (dnrm2 n v 1))
  91       (setf delta (* delta (/ bnrm bnrm0)))
  92      label55
  93       (setf tem (/ 1.0d0 bnrm))
  94       (dscal n tem
  95        (f2cl-lib:array-slice v-%data%
  96                              double-float
  97                              (1 1)
  98                              ((1 n) (1 *))
  99                              v-%offset%)
 100        1)
 101       (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 102                     ((> j maxl) nil)
 103         (tagbody
 104           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 105                         ((> i maxl) nil)
 106             (tagbody
 107              label60
 108               (setf (f2cl-lib:fref hes-%data%
 109                                    (i j)
 110                                    ((1 maxl) (1 maxl))
 111                                    hes-%offset%)
 112                       0.0d0)))
 113          label65))
 114       (setf prod 1.0d0)
 115       (f2cl-lib:fdo (ll 1 (f2cl-lib:int-add ll 1))
 116                     ((> ll maxl) nil)
 117         (tagbody
 118           (setf liom ll)
 119           (multiple-value-bind
 120                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
 121                  var-10 var-11 var-12 var-13 var-14 var-15)
 122               (datv neq y savf
 123                (f2cl-lib:array-slice v-%data%
 124                                      double-float
 125                                      (1 ll)
 126                                      ((1 n) (1 *))
 127                                      v-%offset%)
 128                wght x f psol
 129                (f2cl-lib:array-slice v-%data%
 130                                      double-float
 131                                      (1 (f2cl-lib:int-add ll 1))
 132                                      ((1 n) (1 *))
 133                                      v-%offset%)
 134                wk wp iwp hl0 jpre ier npsl)
 135             (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
 136                              var-8 var-9 var-10 var-11 var-13))
 137             (setf hl0 var-12)
 138             (setf ier var-14)
 139             (setf npsl var-15))
 140           (if (/= ier 0) (go label300))
 141           (multiple-value-bind
 142                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)
 143               (dorthog
 144                (f2cl-lib:array-slice v-%data%
 145                                      double-float
 146                                      (1 (f2cl-lib:int-add ll 1))
 147                                      ((1 n) (1 *))
 148                                      v-%offset%)
 149                v hes n ll maxl kmp snormw)
 150             (declare (ignore var-0 var-1 var-2))
 151             (when var-3
 152               (setf n var-3))
 153             (when var-4
 154               (setf ll var-4))
 155             (when var-5
 156               (setf maxl var-5))
 157             (when var-6
 158               (setf kmp var-6))
 159             (when var-7
 160               (setf snormw var-7)))
 161           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
 162               (dhefa hes maxl ll ipvt info ll)
 163             (declare (ignore var-0 var-1 var-2 var-3 var-5))
 164             (setf info var-4))
 165           (setf lm1 (f2cl-lib:int-sub ll 1))
 166           (if
 167            (and (> ll 1)
 168                 (= (f2cl-lib:fref ipvt-%data% (lm1) ((1 *)) ipvt-%offset%)
 169                    lm1))
 170            (setf prod
 171                    (* prod
 172                       (f2cl-lib:fref hes-%data%
 173                                      (ll lm1)
 174                                      ((1 maxl) (1 maxl))
 175                                      hes-%offset%))))
 176           (if (/= info ll) (go label70))
 177           (if (= snormw 0.0d0) (go label120))
 178           (if (= ll maxl) (go label120))
 179           (go label80)
 180          label70
 181           (setf rho
 182                   (* bnrm
 183                      snormw
 184                      (abs
 185                       (/ prod
 186                          (f2cl-lib:fref hes-%data%
 187                                         (ll ll)
 188                                         ((1 maxl) (1 maxl))
 189                                         hes-%offset%)))))
 190           (if (<= rho delta) (go label200))
 191           (if (= ll maxl) (go label100))
 192          label80
 193           (setf (f2cl-lib:fref hes-%data%
 194                                ((f2cl-lib:int-add ll 1) ll)
 195                                ((1 maxl) (1 maxl))
 196                                hes-%offset%)
 197                   snormw)
 198           (setf tem (/ 1.0d0 snormw))
 199           (dscal n tem
 200            (f2cl-lib:array-slice v-%data%
 201                                  double-float
 202                                  (1 (f2cl-lib:int-add ll 1))
 203                                  ((1 n) (1 *))
 204                                  v-%offset%)
 205            1)
 206          label90))
 207      label100
 208       (if (<= rho 1.0d0) (go label150))
 209       (if (and (<= rho bnrm) (= mnewt 0)) (go label150))
 210      label120
 211       (setf iflag 2)
 212       (go end_label)
 213      label150
 214       (setf iflag 1)
 215      label200
 216       (setf ll liom)
 217       (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
 218                     ((> k ll) nil)
 219         (tagbody
 220          label210
 221           (setf (f2cl-lib:fref b-%data% (k) ((1 *)) b-%offset%) 0.0d0)))
 222       (setf (f2cl-lib:fref b-%data% (1) ((1 *)) b-%offset%) bnrm)
 223       (dhesl hes maxl ll ipvt b)
 224       (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
 225                     ((> k n) nil)
 226         (tagbody
 227          label220
 228           (setf (f2cl-lib:fref x-%data% (k) ((1 *)) x-%offset%) 0.0d0)))
 229       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 230                     ((> i ll) nil)
 231         (tagbody
 232           (daxpy n (f2cl-lib:fref b-%data% (i) ((1 *)) b-%offset%)
 233            (f2cl-lib:array-slice v-%data%
 234                                  double-float
 235                                  (1 i)
 236                                  ((1 n) (1 *))
 237                                  v-%offset%)
 238            1 x 1)
 239          label230))
 240       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 241                     ((> i n) nil)
 242         (tagbody
 243          label240
 244           (setf (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%)
 245                   (/ (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%)
 246                      (f2cl-lib:fref wght-%data% (i) ((1 *)) wght-%offset%)))))
 247       (if (<= jpre 1) (go end_label))
 248       (multiple-value-bind
 249             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
 250              var-10)
 251           (funcall psol neq tn y savf wk hl0 wp iwp x 2 ier)
 252         (declare (ignore var-0 var-2 var-3 var-4 var-6 var-7 var-8 var-9))
 253         (when var-1
 254           (setf tn var-1))
 255         (when var-5
 256           (setf hl0 var-5))
 257         (when var-10
 258           (setf ier var-10)))
 259       (setf npsl (f2cl-lib:int-add npsl 1))
 260       (if (/= ier 0) (go label300))
 261       (go end_label)
 262      label300
 263       (if (< ier 0) (setf iflag -1))
 264       (if (> ier 0) (setf iflag 3))
 265       (go end_label)
 266      end_label
 267       (return
 268        (values nil
 269                tn
 270                nil
 271                nil
 272                nil
 273                nil
 274                n
 275                maxl
 276                kmp
 277                delta
 278                hl0
 279                nil
 280                nil
 281                nil
 282                nil
 283                npsl
 284                nil
 285                nil
 286                nil
 287                nil
 288                liom
 289                nil
 290                nil
 291                nil
 292                iflag)))))
 293
 294 (in-package #:cl-user)
 295 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 296 (eval-when (:load-toplevel :compile-toplevel :execute)
 297   (setf (gethash 'fortran-to-lisp::dspiom
 298                  fortran-to-lisp::*f2cl-function-info*)
 299           (fortran-to-lisp::make-f2cl-finfo
 300            :arg-types '((array fortran-to-lisp::integer4 (*)) (double-float)
 301                         (array double-float (*)) (array double-float (*))
 302                         (array double-float (*)) (array double-float (*))
 303                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 304                         (fortran-to-lisp::integer4) (double-float)
 305                         (double-float) (fortran-to-lisp::integer4)
 306                         (fortran-to-lisp::integer4) t t
 307                         (fortran-to-lisp::integer4) (array double-float (*))
 308                         (array double-float (*)) (array double-float (*))
 309                         (array fortran-to-lisp::integer4 (*))
 310                         (fortran-to-lisp::integer4) (array double-float (*))
 311                         (array fortran-to-lisp::integer4 (*))
 312                         (array double-float (*)) (fortran-to-lisp::integer4))
 313            :return-values '(nil fortran-to-lisp::tn nil nil nil nil
 314                             fortran-to-lisp::n fortran-to-lisp::maxl
 315                             fortran-to-lisp::kmp fortran-to-lisp::delta
 316                             fortran-to-lisp::hl0 nil nil nil nil
 317                             fortran-to-lisp::npsl nil nil nil nil
 318                             fortran-to-lisp::liom nil nil nil
 319                             fortran-to-lisp::iflag)
 320            :calls '(fortran-to-lisp::daxpy fortran-to-lisp::dhesl
 321                     fortran-to-lisp::dhefa fortran-to-lisp::datv
 322                     fortran-to-lisp::dscal fortran-to-lisp::dcopy
 323                     fortran-to-lisp::dnrm2))))
 324