share/odepack/src/dprepj.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-2017-01 (21B Unicode)
  11 ;;;
  12 ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  13 ;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
  14 ;;;           (:array-slicing t) (:declare-common nil)
  15 ;;;           (:float-format double-float))
  16
  17 (in-package "ODEPACK")
  18
  19
  20 (defun dprepj (neq y yh nyh ewt ftem savf wm iwm f jac)
  21   (declare (type (f2cl-lib:integer4) nyh)
  22            (type (array double-float (*)) wm savf ftem ewt yh y)
  23            (type (array f2cl-lib:integer4 (*)) iwm neq))
  24   (let ()
  25     (symbol-macrolet ((el0 (aref (dls001-part-0 *dls001-common-block*) 210))
  26                       (h (aref (dls001-part-0 *dls001-common-block*) 211))
  27                       (tn (aref (dls001-part-0 *dls001-common-block*) 216))
  28                       (uround (aref (dls001-part-0 *dls001-common-block*) 217))
  29                       (ierpj (aref (dls001-part-1 *dls001-common-block*) 13))
  30                       (jcur (aref (dls001-part-1 *dls001-common-block*) 15))
  31                       (miter (aref (dls001-part-1 *dls001-common-block*) 26))
  32                       (n (aref (dls001-part-1 *dls001-common-block*) 31))
  33                       (nfe (aref (dls001-part-1 *dls001-common-block*) 34))
  34                       (nje (aref (dls001-part-1 *dls001-common-block*) 35)))
  35       (prog ((np1 0) (mu 0) (ml3 0) (ml 0) (meband 0) (meb1 0) (mband 0)
  36              (mba 0) (lenp 0) (jj 0) (j1 0) (j 0) (ii 0) (ier 0) (i2 0) (i1 0)
  37              (i 0) (yjj 0.0) (yj 0.0) (yi 0.0) (srur 0.0) (r0 0.0) (r 0.0)
  38              (hl0 0.0) (fac 0.0) (di 0.0) (con 0.0))
  39         (declare (type (double-float) con di fac hl0 r r0 srur yi yj yjj)
  40                  (type (f2cl-lib:integer4) i i1 i2 ier ii j j1 jj lenp mba
  41                                            mband meb1 meband ml ml3 mu np1))
  42         (setf nje (f2cl-lib:int-add nje 1))
  43         (setf ierpj 0)
  44         (setf jcur 1)
  45         (setf hl0 (* h el0))
  46         (f2cl-lib:computed-goto (label100 label200 label300 label400 label500)
  47                                 miter)
  48        label100
  49         (setf lenp (f2cl-lib:int-mul n n))
  50         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  51                       ((> i lenp) nil)
  52           (tagbody
  53            label110
  54             (setf (f2cl-lib:fref wm ((f2cl-lib:int-add i 2)) ((1 *))) 0.0)))
  55         (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
  56             (funcall jac
  57                      neq
  58                      tn
  59                      y
  60                      0
  61                      0
  62                      (f2cl-lib:array-slice wm double-float (3) ((1 *)))
  63                      n)
  64           (declare (ignore var-0 var-2 var-3 var-4 var-5))
  65           (when var-1
  66             (setf tn var-1))
  67           (when var-6
  68             (setf n var-6)))
  69         (setf con (- hl0))
  70         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  71                       ((> i lenp) nil)
  72           (tagbody
  73            label120
  74             (setf (f2cl-lib:fref wm ((f2cl-lib:int-add i 2)) ((1 *)))
  75                     (* (f2cl-lib:fref wm ((f2cl-lib:int-add i 2)) ((1 *)))
  76                        con))))
  77         (go label240)
  78        label200
  79         (setf fac (dvnorm n savf ewt))
  80         (setf r0 (* 1000.0 (abs h) uround n fac))
  81         (if (= r0 0.0) (setf r0 1.0))
  82         (setf srur (f2cl-lib:fref wm (1) ((1 *))))
  83         (setf j1 2)
  84         (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
  85                       ((> j n) nil)
  86           (tagbody
  87             (setf yj (f2cl-lib:fref y (j) ((1 *))))
  88             (setf r
  89                     (max (* srur (abs yj))
  90                          (/ r0 (f2cl-lib:fref ewt (j) ((1 *))))))
  91             (setf (f2cl-lib:fref y (j) ((1 *)))
  92                     (+ (f2cl-lib:fref y (j) ((1 *))) r))
  93             (setf fac (/ (- hl0) r))
  94             (multiple-value-bind (var-0 var-1 var-2 var-3)
  95                 (funcall f neq tn y ftem)
  96               (declare (ignore var-0 var-2 var-3))
  97               (when var-1
  98                 (setf tn var-1)))
  99             (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 100                           ((> i n) nil)
 101               (tagbody
 102                label220
 103                 (setf (f2cl-lib:fref wm ((f2cl-lib:int-add i j1)) ((1 *)))
 104                         (*
 105                          (- (f2cl-lib:fref ftem (i) ((1 *)))
 106                             (f2cl-lib:fref savf (i) ((1 *))))
 107                          fac))))
 108             (setf (f2cl-lib:fref y (j) ((1 *))) yj)
 109             (setf j1 (f2cl-lib:int-add j1 n))
 110            label230))
 111         (setf nfe (f2cl-lib:int-add nfe n))
 112        label240
 113         (setf j 3)
 114         (setf np1 (f2cl-lib:int-add n 1))
 115         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 116                       ((> i n) nil)
 117           (tagbody
 118             (setf (f2cl-lib:fref wm (j) ((1 *)))
 119                     (+ (f2cl-lib:fref wm (j) ((1 *))) 1.0))
 120            label250
 121             (setf j (f2cl-lib:int-add j np1))))
 122         (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
 123             (dgefa (f2cl-lib:array-slice wm double-float (3) ((1 *))) n n
 124              (f2cl-lib:array-slice iwm f2cl-lib:integer4 (21) ((1 *))) ier)
 125           (declare (ignore var-0 var-1 var-2 var-3))
 126           (setf ier var-4))
 127         (if (/= ier 0) (setf ierpj 1))
 128         (go end_label)
 129        label300
 130         (setf (f2cl-lib:fref wm (2) ((1 *))) hl0)
 131         (setf r (* el0 0.1))
 132         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 133                       ((> i n) nil)
 134           (tagbody
 135            label310
 136             (setf (f2cl-lib:fref y (i) ((1 *)))
 137                     (+ (f2cl-lib:fref y (i) ((1 *)))
 138                        (* r
 139                           (- (* h (f2cl-lib:fref savf (i) ((1 *))))
 140                              (f2cl-lib:fref yh (i 2) ((1 nyh) (1 *)))))))))
 141         (multiple-value-bind (var-0 var-1 var-2 var-3)
 142             (funcall f
 143                      neq
 144                      tn
 145                      y
 146                      (f2cl-lib:array-slice wm double-float (3) ((1 *))))
 147           (declare (ignore var-0 var-2 var-3))
 148           (when var-1
 149             (setf tn var-1)))
 150         (setf nfe (f2cl-lib:int-add nfe 1))
 151         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 152                       ((> i n) nil)
 153           (tagbody
 154             (setf r0
 155                     (- (* h (f2cl-lib:fref savf (i) ((1 *))))
 156                        (f2cl-lib:fref yh (i 2) ((1 nyh) (1 *)))))
 157             (setf di
 158                     (- (* 0.1 r0)
 159                        (* h
 160                           (-
 161                            (f2cl-lib:fref wm ((f2cl-lib:int-add i 2)) ((1 *)))
 162                            (f2cl-lib:fref savf (i) ((1 *)))))))
 163             (setf (f2cl-lib:fref wm ((f2cl-lib:int-add i 2)) ((1 *))) 1.0)
 164             (if (< (abs r0) (/ uround (f2cl-lib:fref ewt (i) ((1 *)))))
 165                 (go label320))
 166             (if (= (abs di) 0.0) (go label330))
 167             (setf (f2cl-lib:fref wm ((f2cl-lib:int-add i 2)) ((1 *)))
 168                     (/ (* 0.1 r0) di))
 169            label320))
 170         (go end_label)
 171        label330
 172         (setf ierpj 1)
 173         (go end_label)
 174        label400
 175         (setf ml (f2cl-lib:fref iwm (1) ((1 *))))
 176         (setf mu (f2cl-lib:fref iwm (2) ((1 *))))
 177         (setf ml3 (f2cl-lib:int-add ml 3))
 178         (setf mband (f2cl-lib:int-add ml mu 1))
 179         (setf meband (f2cl-lib:int-add mband ml))
 180         (setf lenp (f2cl-lib:int-mul meband n))
 181         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 182                       ((> i lenp) nil)
 183           (tagbody
 184            label410
 185             (setf (f2cl-lib:fref wm ((f2cl-lib:int-add i 2)) ((1 *))) 0.0)))
 186         (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 187             (funcall jac
 188                      neq
 189                      tn
 190                      y
 191                      ml
 192                      mu
 193                      (f2cl-lib:array-slice wm double-float (ml3) ((1 *)))
 194                      meband)
 195           (declare (ignore var-0 var-2 var-5))
 196           (when var-1
 197             (setf tn var-1))
 198           (when var-3
 199             (setf ml var-3))
 200           (when var-4
 201             (setf mu var-4))
 202           (when var-6
 203             (setf meband var-6)))
 204         (setf con (- hl0))
 205         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 206                       ((> i lenp) nil)
 207           (tagbody
 208            label420
 209             (setf (f2cl-lib:fref wm ((f2cl-lib:int-add i 2)) ((1 *)))
 210                     (* (f2cl-lib:fref wm ((f2cl-lib:int-add i 2)) ((1 *)))
 211                        con))))
 212         (go label570)
 213        label500
 214         (setf ml (f2cl-lib:fref iwm (1) ((1 *))))
 215         (setf mu (f2cl-lib:fref iwm (2) ((1 *))))
 216         (setf mband (f2cl-lib:int-add ml mu 1))
 217         (setf mba
 218                 (min (the f2cl-lib:integer4 mband) (the f2cl-lib:integer4 n)))
 219         (setf meband (f2cl-lib:int-add mband ml))
 220         (setf meb1 (f2cl-lib:int-sub meband 1))
 221         (setf srur (f2cl-lib:fref wm (1) ((1 *))))
 222         (setf fac (dvnorm n savf ewt))
 223         (setf r0 (* 1000.0 (abs h) uround n fac))
 224         (if (= r0 0.0) (setf r0 1.0))
 225         (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 226                       ((> j mba) nil)
 227           (tagbody
 228             (f2cl-lib:fdo (i j (f2cl-lib:int-add i mband))
 229                           ((> i n) nil)
 230               (tagbody
 231                 (setf yi (f2cl-lib:fref y (i) ((1 *))))
 232                 (setf r
 233                         (max (* srur (abs yi))
 234                              (/ r0 (f2cl-lib:fref ewt (i) ((1 *))))))
 235                label530
 236                 (setf (f2cl-lib:fref y (i) ((1 *)))
 237                         (+ (f2cl-lib:fref y (i) ((1 *))) r))))
 238             (multiple-value-bind (var-0 var-1 var-2 var-3)
 239                 (funcall f neq tn y ftem)
 240               (declare (ignore var-0 var-2 var-3))
 241               (when var-1
 242                 (setf tn var-1)))
 243             (f2cl-lib:fdo (jj j (f2cl-lib:int-add jj mband))
 244                           ((> jj n) nil)
 245               (tagbody
 246                 (setf (f2cl-lib:fref y (jj) ((1 *)))
 247                         (f2cl-lib:fref yh (jj 1) ((1 nyh) (1 *))))
 248                 (setf yjj (f2cl-lib:fref y (jj) ((1 *))))
 249                 (setf r
 250                         (max (* srur (abs yjj))
 251                              (/ r0 (f2cl-lib:fref ewt (jj) ((1 *))))))
 252                 (setf fac (/ (- hl0) r))
 253                 (setf i1
 254                         (max (the f2cl-lib:integer4 (f2cl-lib:int-sub jj mu))
 255                              (the f2cl-lib:integer4 1)))
 256                 (setf i2
 257                         (min (the f2cl-lib:integer4 (f2cl-lib:int-add jj ml))
 258                              (the f2cl-lib:integer4 n)))
 259                 (setf ii
 260                         (f2cl-lib:int-add
 261                          (f2cl-lib:int-sub (f2cl-lib:int-mul jj meb1) ml)
 262                          2))
 263                 (f2cl-lib:fdo (i i1 (f2cl-lib:int-add i 1))
 264                               ((> i i2) nil)
 265                   (tagbody
 266                    label540
 267                     (setf (f2cl-lib:fref wm ((f2cl-lib:int-add ii i)) ((1 *)))
 268                             (*
 269                              (- (f2cl-lib:fref ftem (i) ((1 *)))
 270                                 (f2cl-lib:fref savf (i) ((1 *))))
 271                              fac))))
 272                label550))
 273            label560))
 274         (setf nfe (f2cl-lib:int-add nfe mba))
 275        label570
 276         (setf ii (f2cl-lib:int-add mband 2))
 277         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 278                       ((> i n) nil)
 279           (tagbody
 280             (setf (f2cl-lib:fref wm (ii) ((1 *)))
 281                     (+ (f2cl-lib:fref wm (ii) ((1 *))) 1.0))
 282            label580
 283             (setf ii (f2cl-lib:int-add ii meband))))
 284         (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 285             (dgbfa (f2cl-lib:array-slice wm double-float (3) ((1 *))) meband n
 286              ml mu (f2cl-lib:array-slice iwm f2cl-lib:integer4 (21) ((1 *)))
 287              ier)
 288           (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5))
 289           (setf ier var-6))
 290         (if (/= ier 0) (setf ierpj 1))
 291         (go end_label)
 292        end_label
 293         (return (values nil nil nil nil nil nil nil nil nil nil nil))))))
 294
 295 (in-package #:cl-user)
 296 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 297 (eval-when (:load-toplevel :compile-toplevel :execute)
 298   (setf (gethash 'fortran-to-lisp::dprepj
 299                  fortran-to-lisp::*f2cl-function-info*)
 300           (fortran-to-lisp::make-f2cl-finfo
 301            :arg-types '((array fortran-to-lisp::integer4 (*))
 302                         (array double-float (*)) (array double-float (*))
 303                         (fortran-to-lisp::integer4) (array double-float (*))
 304                         (array double-float (*)) (array double-float (*))
 305                         (array double-float (*))
 306                         (array fortran-to-lisp::integer4 (*)) t t)
 307            :return-values '(nil nil nil nil nil nil nil nil nil nil nil)
 308            :calls '(fortran-to-lisp::dgbfa fortran-to-lisp::dgefa
 309                     fortran-to-lisp::dvnorm))))
 310