share/odepack/src/dprja.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 dprja (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                       (pdnorm (aref (dlsa01-part-0 *dlsa01-common-block*) 21)))
  36       (f2cl-lib:with-multi-array-data
  37           ((neq f2cl-lib:integer4 neq-%data% neq-%offset%)
  38            (iwm f2cl-lib:integer4 iwm-%data% iwm-%offset%)
  39            (y double-float y-%data% y-%offset%)
  40            (yh double-float yh-%data% yh-%offset%)
  41            (ewt double-float ewt-%data% ewt-%offset%)
  42            (ftem double-float ftem-%data% ftem-%offset%)
  43            (savf double-float savf-%data% savf-%offset%)
  44            (wm double-float wm-%data% wm-%offset%))
  45         (prog ((np1 0) (mu 0) (ml3 0) (ml 0) (meband 0) (meb1 0) (mband 0)
  46                (mba 0) (lenp 0) (jj 0) (j1 0) (j 0) (ii 0) (ier 0) (i2 0)
  47                (i1 0) (i 0) (yjj 0.0d0) (yj 0.0d0) (yi 0.0d0) (srur 0.0d0)
  48                (r0 0.0d0) (r 0.0d0) (hl0 0.0d0) (fac 0.0d0) (con 0.0d0))
  49           (declare (type (double-float) con fac hl0 r r0 srur yi yj yjj)
  50                    (type (f2cl-lib:integer4) i i1 i2 ier ii j j1 jj lenp mba
  51                                              mband meb1 meband ml ml3 mu np1))
  52           (setf nje (f2cl-lib:int-add nje 1))
  53           (setf ierpj 0)
  54           (setf jcur 1)
  55           (setf hl0 (* h el0))
  56           (f2cl-lib:computed-goto
  57            (label100 label200 label300 label400 label500)
  58            miter)
  59          label100
  60           (setf lenp (f2cl-lib:int-mul n n))
  61           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  62                         ((> i lenp) nil)
  63             (tagbody
  64              label110
  65               (setf (f2cl-lib:fref wm-%data%
  66                                    ((f2cl-lib:int-add i 2))
  67                                    ((1 *))
  68                                    wm-%offset%)
  69                       0.0d0)))
  70           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
  71               (funcall jac
  72                        neq
  73                        tn
  74                        y
  75                        0
  76                        0
  77                        (f2cl-lib:array-slice wm-%data%
  78                                              double-float
  79                                              (3)
  80                                              ((1 *))
  81                                              wm-%offset%)
  82                        n)
  83             (declare (ignore var-0 var-2 var-3 var-4 var-5))
  84             (when var-1
  85               (setf tn var-1))
  86             (when var-6
  87               (setf n var-6)))
  88           (setf con (- hl0))
  89           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  90                         ((> i lenp) nil)
  91             (tagbody
  92              label120
  93               (setf (f2cl-lib:fref wm-%data%
  94                                    ((f2cl-lib:int-add i 2))
  95                                    ((1 *))
  96                                    wm-%offset%)
  97                       (*
  98                        (f2cl-lib:fref wm-%data%
  99                                       ((f2cl-lib:int-add i 2))
 100                                       ((1 *))
 101                                       wm-%offset%)
 102                        con))))
 103           (go label240)
 104          label200
 105           (setf fac (dmnorm n savf ewt))
 106           (setf r0 (* 1000.0d0 (abs h) uround n fac))
 107           (if (= r0 0.0d0) (setf r0 1.0d0))
 108           (setf srur (f2cl-lib:fref wm-%data% (1) ((1 *)) wm-%offset%))
 109           (setf j1 2)
 110           (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 111                         ((> j n) nil)
 112             (tagbody
 113               (setf yj (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%))
 114               (setf r
 115                       (max (* srur (abs yj))
 116                            (/ r0
 117                               (f2cl-lib:fref ewt-%data%
 118                                              (j)
 119                                              ((1 *))
 120                                              ewt-%offset%))))
 121               (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%)
 122                       (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) r))
 123               (setf fac (/ (- hl0) r))
 124               (multiple-value-bind (var-0 var-1 var-2 var-3)
 125                   (funcall f neq tn y ftem)
 126                 (declare (ignore var-0 var-2 var-3))
 127                 (when var-1
 128                   (setf tn var-1)))
 129               (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 130                             ((> i n) nil)
 131                 (tagbody
 132                  label220
 133                   (setf (f2cl-lib:fref wm-%data%
 134                                        ((f2cl-lib:int-add i j1))
 135                                        ((1 *))
 136                                        wm-%offset%)
 137                           (*
 138                            (-
 139                             (f2cl-lib:fref ftem-%data%
 140                                            (i)
 141                                            ((1 *))
 142                                            ftem-%offset%)
 143                             (f2cl-lib:fref savf-%data%
 144                                            (i)
 145                                            ((1 *))
 146                                            savf-%offset%))
 147                            fac))))
 148               (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) yj)
 149               (setf j1 (f2cl-lib:int-add j1 n))
 150              label230))
 151           (setf nfe (f2cl-lib:int-add nfe n))
 152          label240
 153           (setf pdnorm
 154                   (/
 155                    (dfnorm n
 156                     (f2cl-lib:array-slice wm-%data%
 157                                           double-float
 158                                           (3)
 159                                           ((1 *))
 160                                           wm-%offset%)
 161                     ewt)
 162                    (abs hl0)))
 163           (setf j 3)
 164           (setf np1 (f2cl-lib:int-add n 1))
 165           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 166                         ((> i n) nil)
 167             (tagbody
 168               (setf (f2cl-lib:fref wm-%data% (j) ((1 *)) wm-%offset%)
 169                       (+ (f2cl-lib:fref wm-%data% (j) ((1 *)) wm-%offset%)
 170                          1.0d0))
 171              label250
 172               (setf j (f2cl-lib:int-add j np1))))
 173           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
 174               (dgefa
 175                (f2cl-lib:array-slice wm-%data%
 176                                      double-float
 177                                      (3)
 178                                      ((1 *))
 179                                      wm-%offset%)
 180                n n
 181                (f2cl-lib:array-slice iwm-%data%
 182                                      f2cl-lib:integer4
 183                                      (21)
 184                                      ((1 *))
 185                                      iwm-%offset%)
 186                ier)
 187             (declare (ignore var-0 var-1 var-2 var-3))
 188             (setf ier var-4))
 189           (if (/= ier 0) (setf ierpj 1))
 190           (go end_label)
 191          label300
 192           (go end_label)
 193          label400
 194           (setf ml (f2cl-lib:fref iwm-%data% (1) ((1 *)) iwm-%offset%))
 195           (setf mu (f2cl-lib:fref iwm-%data% (2) ((1 *)) iwm-%offset%))
 196           (setf ml3 (f2cl-lib:int-add ml 3))
 197           (setf mband (f2cl-lib:int-add ml mu 1))
 198           (setf meband (f2cl-lib:int-add mband ml))
 199           (setf lenp (f2cl-lib:int-mul meband n))
 200           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 201                         ((> i lenp) nil)
 202             (tagbody
 203              label410
 204               (setf (f2cl-lib:fref wm-%data%
 205                                    ((f2cl-lib:int-add i 2))
 206                                    ((1 *))
 207                                    wm-%offset%)
 208                       0.0d0)))
 209           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 210               (funcall jac
 211                        neq
 212                        tn
 213                        y
 214                        ml
 215                        mu
 216                        (f2cl-lib:array-slice wm-%data%
 217                                              double-float
 218                                              (ml3)
 219                                              ((1 *))
 220                                              wm-%offset%)
 221                        meband)
 222             (declare (ignore var-0 var-2 var-5))
 223             (when var-1
 224               (setf tn var-1))
 225             (when var-3
 226               (setf ml var-3))
 227             (when var-4
 228               (setf mu var-4))
 229             (when var-6
 230               (setf meband var-6)))
 231           (setf con (- hl0))
 232           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 233                         ((> i lenp) nil)
 234             (tagbody
 235              label420
 236               (setf (f2cl-lib:fref wm-%data%
 237                                    ((f2cl-lib:int-add i 2))
 238                                    ((1 *))
 239                                    wm-%offset%)
 240                       (*
 241                        (f2cl-lib:fref wm-%data%
 242                                       ((f2cl-lib:int-add i 2))
 243                                       ((1 *))
 244                                       wm-%offset%)
 245                        con))))
 246           (go label570)
 247          label500
 248           (setf ml (f2cl-lib:fref iwm-%data% (1) ((1 *)) iwm-%offset%))
 249           (setf mu (f2cl-lib:fref iwm-%data% (2) ((1 *)) iwm-%offset%))
 250           (setf mband (f2cl-lib:int-add ml mu 1))
 251           (setf mba
 252                   (min (the f2cl-lib:integer4 mband)
 253                        (the f2cl-lib:integer4 n)))
 254           (setf meband (f2cl-lib:int-add mband ml))
 255           (setf meb1 (f2cl-lib:int-sub meband 1))
 256           (setf srur (f2cl-lib:fref wm-%data% (1) ((1 *)) wm-%offset%))
 257           (setf fac (dmnorm n savf ewt))
 258           (setf r0 (* 1000.0d0 (abs h) uround n fac))
 259           (if (= r0 0.0d0) (setf r0 1.0d0))
 260           (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 261                         ((> j mba) nil)
 262             (tagbody
 263               (f2cl-lib:fdo (i j (f2cl-lib:int-add i mband))
 264                             ((> i n) nil)
 265                 (tagbody
 266                   (setf yi (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%))
 267                   (setf r
 268                           (max (* srur (abs yi))
 269                                (/ r0
 270                                   (f2cl-lib:fref ewt-%data%
 271                                                  (i)
 272                                                  ((1 *))
 273                                                  ewt-%offset%))))
 274                  label530
 275                   (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%)
 276                           (+ (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%)
 277                              r))))
 278               (multiple-value-bind (var-0 var-1 var-2 var-3)
 279                   (funcall f neq tn y ftem)
 280                 (declare (ignore var-0 var-2 var-3))
 281                 (when var-1
 282                   (setf tn var-1)))
 283               (f2cl-lib:fdo (jj j (f2cl-lib:int-add jj mband))
 284                             ((> jj n) nil)
 285                 (tagbody
 286                   (setf (f2cl-lib:fref y-%data% (jj) ((1 *)) y-%offset%)
 287                           (f2cl-lib:fref yh-%data%
 288                                          (jj 1)
 289                                          ((1 nyh) (1 *))
 290                                          yh-%offset%))
 291                   (setf yjj (f2cl-lib:fref y-%data% (jj) ((1 *)) y-%offset%))
 292                   (setf r
 293                           (max (* srur (abs yjj))
 294                                (/ r0
 295                                   (f2cl-lib:fref ewt-%data%
 296                                                  (jj)
 297                                                  ((1 *))
 298                                                  ewt-%offset%))))
 299                   (setf fac (/ (- hl0) r))
 300                   (setf i1
 301                           (max (the f2cl-lib:integer4 (f2cl-lib:int-sub jj mu))
 302                                (the f2cl-lib:integer4 1)))
 303                   (setf i2
 304                           (min (the f2cl-lib:integer4 (f2cl-lib:int-add jj ml))
 305                                (the f2cl-lib:integer4 n)))
 306                   (setf ii
 307                           (f2cl-lib:int-add
 308                            (f2cl-lib:int-sub (f2cl-lib:int-mul jj meb1) ml)
 309                            2))
 310                   (f2cl-lib:fdo (i i1 (f2cl-lib:int-add i 1))
 311                                 ((> i i2) nil)
 312                     (tagbody
 313                      label540
 314                       (setf (f2cl-lib:fref wm-%data%
 315                                            ((f2cl-lib:int-add ii i))
 316                                            ((1 *))
 317                                            wm-%offset%)
 318                               (*
 319                                (-
 320                                 (f2cl-lib:fref ftem-%data%
 321                                                (i)
 322                                                ((1 *))
 323                                                ftem-%offset%)
 324                                 (f2cl-lib:fref savf-%data%
 325                                                (i)
 326                                                ((1 *))
 327                                                savf-%offset%))
 328                                fac))))
 329                  label550))
 330              label560))
 331           (setf nfe (f2cl-lib:int-add nfe mba))
 332          label570
 333           (setf pdnorm
 334                   (/
 335                    (dbnorm n
 336                     (f2cl-lib:array-slice wm-%data%
 337                                           double-float
 338                                           ((+ ml 3))
 339                                           ((1 *))
 340                                           wm-%offset%)
 341                     meband ml mu ewt)
 342                    (abs hl0)))
 343           (setf ii (f2cl-lib:int-add mband 2))
 344           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 345                         ((> i n) nil)
 346             (tagbody
 347               (setf (f2cl-lib:fref wm-%data% (ii) ((1 *)) wm-%offset%)
 348                       (+ (f2cl-lib:fref wm-%data% (ii) ((1 *)) wm-%offset%)
 349                          1.0d0))
 350              label580
 351               (setf ii (f2cl-lib:int-add ii meband))))
 352           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 353               (dgbfa
 354                (f2cl-lib:array-slice wm-%data%
 355                                      double-float
 356                                      (3)
 357                                      ((1 *))
 358                                      wm-%offset%)
 359                meband n ml mu
 360                (f2cl-lib:array-slice iwm-%data%
 361                                      f2cl-lib:integer4
 362                                      (21)
 363                                      ((1 *))
 364                                      iwm-%offset%)
 365                ier)
 366             (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5))
 367             (setf ier var-6))
 368           (if (/= ier 0) (setf ierpj 1))
 369           (go end_label)
 370          end_label
 371           (return (values nil nil nil nil nil nil nil nil nil nil nil)))))))
 372
 373 (in-package #:cl-user)
 374 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 375 (eval-when (:load-toplevel :compile-toplevel :execute)
 376   (setf (gethash 'fortran-to-lisp::dprja fortran-to-lisp::*f2cl-function-info*)
 377           (fortran-to-lisp::make-f2cl-finfo
 378            :arg-types '((array fortran-to-lisp::integer4 (*))
 379                         (array double-float (*)) (array double-float (*))
 380                         (fortran-to-lisp::integer4) (array double-float (*))
 381                         (array double-float (*)) (array double-float (*))
 382                         (array double-float (*))
 383                         (array fortran-to-lisp::integer4 (*)) t t)
 384            :return-values '(nil nil nil nil nil nil nil nil nil nil nil)
 385            :calls '(fortran-to-lisp::dgbfa fortran-to-lisp::dbnorm
 386                     fortran-to-lisp::dgefa fortran-to-lisp::dfnorm
 387                     fortran-to-lisp::dmnorm))))
 388