share/hompack/lisp/sintrp.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-2020-04 (21D 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 double-float))
  16
  17 (in-package "HOMPACK")
  18
  19
  20 (defun sintrp
  21        (x y xout yout ypout neqn kold phi ivc iv kgi gi alpha g w xold p)
  22   (declare (type (array double-float (*)) g)
  23            (type (array double-float (*)) w alpha)
  24            (type (array double-float (*)) gi)
  25            (type (array f2cl-lib:integer4 (*)) iv)
  26            (type (f2cl-lib:integer4) kgi ivc kold neqn)
  27            (type (array double-float (*)) p phi ypout yout y)
  28            (type (double-float) xold xout x))
  29   (f2cl-lib:with-multi-array-data
  30       ((y double-float y-%data% y-%offset%)
  31        (yout double-float yout-%data% yout-%offset%)
  32        (ypout double-float ypout-%data% ypout-%offset%)
  33        (phi double-float phi-%data% phi-%offset%)
  34        (p double-float p-%data% p-%offset%)
  35        (iv f2cl-lib:integer4 iv-%data% iv-%offset%)
  36        (gi double-float gi-%data% gi-%offset%)
  37        (alpha double-float alpha-%data% alpha-%offset%)
  38        (w double-float w-%data% w-%offset%)
  39        (g double-float g-%data% g-%offset%))
  40     (prog ((gtemp (make-array 13 :element-type 'double-float))
  41            (c (make-array 13 :element-type 'double-float))
  42            (wtemp (make-array 13 :element-type 'double-float)) (i 0) (iq 0)
  43            (iw 0) (j 0) (jq 0) (kp1 0) (kp2 0) (l 0) (m 0) (alp 0.0)
  44            (gamma 0.0) (gdi 0.0) (gdif 0.0) (h 0.0) (hi 0.0) (hmu 0.0)
  45            (rmu 0.0) (sigma 0.0) (temp1 0.0) (temp2 0.0) (temp3 0.0) (xi 0.0)
  46            (xim1 0.0) (xiq 0.0))
  47       (declare (type (array double-float (13)) wtemp gtemp c)
  48                (type (double-float) xiq xim1 xi temp3 temp2 temp1 sigma rmu hmu
  49                                     hi h gdif gdi gamma alp)
  50                (type (f2cl-lib:integer4) m l kp2 kp1 jq j iw iq i))
  51       (setf kp1 (f2cl-lib:int-add kold 1))
  52       (setf kp2 (f2cl-lib:int-add kold 2))
  53       (setf hi (- xout xold))
  54       (setf h (- x xold))
  55       (setf xi (/ hi h))
  56       (setf xim1 (- xi 1.0f0))
  57       (setf xiq xi)
  58       (f2cl-lib:fdo (iq 1 (f2cl-lib:int-add iq 1))
  59                     ((> iq kp1) nil)
  60         (tagbody
  61           (setf xiq (* xi xiq))
  62           (setf temp1
  63                   (coerce
  64                    (the f2cl-lib:integer4
  65                         (f2cl-lib:int-mul iq (f2cl-lib:int-add iq 1)))
  66                    'double-float))
  67          label10
  68           (setf (f2cl-lib:fref wtemp (iq) ((1 13))) (/ xiq temp1))))
  69       (if (<= kold kgi) (go label50))
  70       (if (> ivc 0) (go label20))
  71       (setf gdi (/ 1.0f0 temp1))
  72       (setf m 2)
  73       (go label30)
  74      label20
  75       (setf iw (f2cl-lib:fref iv-%data% (ivc) ((1 10)) iv-%offset%))
  76       (setf gdi (f2cl-lib:fref w-%data% (iw) ((1 12)) w-%offset%))
  77       (setf m (f2cl-lib:int-add (f2cl-lib:int-sub kold iw) 3))
  78      label30
  79       (if (> m kold) (go label60))
  80       (f2cl-lib:fdo (i m (f2cl-lib:int-add i 1))
  81                     ((> i kold) nil)
  82         (tagbody
  83          label40
  84           (setf gdi
  85                   (-
  86                    (f2cl-lib:fref w-%data%
  87                                   ((f2cl-lib:int-sub kp2 i))
  88                                   ((1 12))
  89                                   w-%offset%)
  90                    (* (f2cl-lib:fref alpha-%data% (i) ((1 12)) alpha-%offset%)
  91                       gdi)))))
  92       (go label60)
  93      label50
  94       (setf gdi (f2cl-lib:fref gi-%data% (kold) ((1 11)) gi-%offset%))
  95      label60
  96       (setf (f2cl-lib:fref gtemp (1) ((1 13))) xi)
  97       (setf (f2cl-lib:fref gtemp (2) ((1 13))) (* 0.5f0 xi xi))
  98       (setf (f2cl-lib:fref c (1) ((1 13))) (coerce 1.0f0 'double-float))
  99       (setf (f2cl-lib:fref c (2) ((1 13))) xi)
 100       (if (< kold 2) (go label90))
 101       (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1))
 102                     ((> i kold) nil)
 103         (tagbody
 104           (setf alp (f2cl-lib:fref alpha-%data% (i) ((1 12)) alpha-%offset%))
 105           (setf gamma (+ 1.0f0 (* xim1 alp)))
 106           (setf l (f2cl-lib:int-sub kp2 i))
 107           (f2cl-lib:fdo (jq 1 (f2cl-lib:int-add jq 1))
 108                         ((> jq l) nil)
 109             (tagbody
 110              label70
 111               (setf (f2cl-lib:fref wtemp (jq) ((1 13)))
 112                       (- (* gamma (f2cl-lib:fref wtemp (jq) ((1 13))))
 113                          (* alp
 114                             (f2cl-lib:fref wtemp
 115                                            ((f2cl-lib:int-add jq 1))
 116                                            ((1 13))))))))
 117           (setf (f2cl-lib:fref gtemp ((f2cl-lib:int-add i 1)) ((1 13)))
 118                   (f2cl-lib:fref wtemp (1) ((1 13))))
 119          label80
 120           (setf (f2cl-lib:fref c ((f2cl-lib:int-add i 1)) ((1 13)))
 121                   (* gamma (f2cl-lib:fref c (i) ((1 13)))))))
 122      label90
 123       (setf sigma
 124               (/
 125                (- (f2cl-lib:fref wtemp (2) ((1 13)))
 126                   (* xim1 (f2cl-lib:fref wtemp (1) ((1 13)))))
 127                gdi))
 128       (setf rmu (/ (* xim1 (f2cl-lib:fref c (kp1) ((1 13)))) gdi))
 129       (setf hmu (/ rmu h))
 130       (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1))
 131                     ((> l neqn) nil)
 132         (tagbody
 133           (setf (f2cl-lib:fref yout-%data% (l) ((1 neqn)) yout-%offset%)
 134                   (coerce 0.0f0 'double-float))
 135          label100
 136           (setf (f2cl-lib:fref ypout-%data% (l) ((1 neqn)) ypout-%offset%)
 137                   (coerce 0.0f0 'double-float))))
 138       (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 139                     ((> j kold) nil)
 140         (tagbody
 141           (setf i (f2cl-lib:int-sub kp2 j))
 142           (setf gdif
 143                   (- (f2cl-lib:fref g-%data% (i) ((1 13)) g-%offset%)
 144                      (f2cl-lib:fref g-%data%
 145                                     ((f2cl-lib:int-sub i 1))
 146                                     ((1 13))
 147                                     g-%offset%)))
 148           (setf temp2
 149                   (- (f2cl-lib:fref gtemp (i) ((1 13)))
 150                      (f2cl-lib:fref gtemp ((f2cl-lib:int-sub i 1)) ((1 13)))
 151                      (* sigma gdif)))
 152           (setf temp3
 153                   (+
 154                    (- (f2cl-lib:fref c (i) ((1 13)))
 155                       (f2cl-lib:fref c ((f2cl-lib:int-sub i 1)) ((1 13))))
 156                    (* rmu gdif)))
 157           (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1))
 158                         ((> l neqn) nil)
 159             (tagbody
 160               (setf (f2cl-lib:fref yout-%data% (l) ((1 neqn)) yout-%offset%)
 161                       (+
 162                        (f2cl-lib:fref yout-%data% (l) ((1 neqn)) yout-%offset%)
 163                        (* temp2
 164                           (f2cl-lib:fref phi-%data%
 165                                          (l i)
 166                                          ((1 neqn) (1 16))
 167                                          phi-%offset%))))
 168              label110
 169               (setf (f2cl-lib:fref ypout-%data% (l) ((1 neqn)) ypout-%offset%)
 170                       (+
 171                        (f2cl-lib:fref ypout-%data%
 172                                       (l)
 173                                       ((1 neqn))
 174                                       ypout-%offset%)
 175                        (* temp3
 176                           (f2cl-lib:fref phi-%data%
 177                                          (l i)
 178                                          ((1 neqn) (1 16))
 179                                          phi-%offset%))))))
 180          label120))
 181       (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1))
 182                     ((> l neqn) nil)
 183         (tagbody
 184           (setf (f2cl-lib:fref yout-%data% (l) ((1 neqn)) yout-%offset%)
 185                   (+
 186                    (* (- 1.0f0 sigma)
 187                       (f2cl-lib:fref p-%data% (l) ((1 neqn)) p-%offset%))
 188                    (* sigma (f2cl-lib:fref y-%data% (l) ((1 neqn)) y-%offset%))
 189                    (* h
 190                       (+
 191                        (f2cl-lib:fref yout-%data% (l) ((1 neqn)) yout-%offset%)
 192                        (*
 193                         (- (f2cl-lib:fref gtemp (1) ((1 13)))
 194                            (* sigma
 195                               (f2cl-lib:fref g-%data%
 196                                              (1)
 197                                              ((1 13))
 198                                              g-%offset%)))
 199                         (f2cl-lib:fref phi-%data%
 200                                        (l 1)
 201                                        ((1 neqn) (1 16))
 202                                        phi-%offset%))))))
 203          label130
 204           (setf (f2cl-lib:fref ypout-%data% (l) ((1 neqn)) ypout-%offset%)
 205                   (+
 206                    (* hmu
 207                       (- (f2cl-lib:fref p-%data% (l) ((1 neqn)) p-%offset%)
 208                          (f2cl-lib:fref y-%data% (l) ((1 neqn)) y-%offset%)))
 209                    (+
 210                     (f2cl-lib:fref ypout-%data% (l) ((1 neqn)) ypout-%offset%)
 211                     (*
 212                      (+ (f2cl-lib:fref c (1) ((1 13)))
 213                         (* rmu
 214                            (f2cl-lib:fref g-%data% (1) ((1 13)) g-%offset%)))
 215                      (f2cl-lib:fref phi-%data%
 216                                     (l 1)
 217                                     ((1 neqn) (1 16))
 218                                     phi-%offset%)))))))
 219       (go end_label)
 220      end_label
 221       (return
 222        (values nil
 223                nil
 224                nil
 225                nil
 226                nil
 227                nil
 228                nil
 229                nil
 230                nil
 231                nil
 232                nil
 233                nil
 234                nil
 235                nil
 236                nil
 237                nil
 238                nil)))))
 239
 240 (in-package #:cl-user)
 241 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 242 (eval-when (:load-toplevel :compile-toplevel :execute)
 243   (setf (gethash 'fortran-to-lisp::sintrp
 244                  fortran-to-lisp::*f2cl-function-info*)
 245           (fortran-to-lisp::make-f2cl-finfo
 246            :arg-types '((double-float) (array double-float (*)) (double-float)
 247                         (array double-float (*)) (array double-float (*))
 248                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 249                         (array double-float (*)) (fortran-to-lisp::integer4)
 250                         (array fortran-to-lisp::integer4 (*))
 251                         (fortran-to-lisp::integer4) (array double-float (*))
 252                         (array double-float (*)) (array double-float (*))
 253                         (array double-float (*)) (double-float)
 254                         (array double-float (*)))
 255            :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil
 256                             nil nil nil nil)
 257            :calls 'nil)))
 258