share/hompack/lisp/hfun1p.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 hfun1p
  21        (qdg lambda$ x pdg cl coef rho drhox drhol xdgm1 xdg g dg pxdgm1 pxdg f
  22         df xx trm dtrm clx dxnp1 n mmaxt ideg numt kdeg)
  23   (declare (type (array f2cl-lib:integer4 (*)) kdeg numt ideg)
  24            (type (f2cl-lib:integer4) mmaxt n)
  25            (type (double-float) lambda$)
  26            (type (array double-float (*)) dxnp1 clx dtrm trm xx df f pxdg
  27                                           pxdgm1 dg g xdg xdgm1 drhol drhox rho
  28                                           coef cl pdg x qdg))
  29   (f2cl-lib:with-multi-array-data
  30       ((qdg double-float qdg-%data% qdg-%offset%)
  31        (x double-float x-%data% x-%offset%)
  32        (pdg double-float pdg-%data% pdg-%offset%)
  33        (cl double-float cl-%data% cl-%offset%)
  34        (coef double-float coef-%data% coef-%offset%)
  35        (rho double-float rho-%data% rho-%offset%)
  36        (drhox double-float drhox-%data% drhox-%offset%)
  37        (drhol double-float drhol-%data% drhol-%offset%)
  38        (xdgm1 double-float xdgm1-%data% xdgm1-%offset%)
  39        (xdg double-float xdg-%data% xdg-%offset%)
  40        (g double-float g-%data% g-%offset%)
  41        (dg double-float dg-%data% dg-%offset%)
  42        (pxdgm1 double-float pxdgm1-%data% pxdgm1-%offset%)
  43        (pxdg double-float pxdg-%data% pxdg-%offset%)
  44        (f double-float f-%data% f-%offset%)
  45        (df double-float df-%data% df-%offset%)
  46        (xx double-float xx-%data% xx-%offset%)
  47        (trm double-float trm-%data% trm-%offset%)
  48        (dtrm double-float dtrm-%data% dtrm-%offset%)
  49        (clx double-float clx-%data% clx-%offset%)
  50        (dxnp1 double-float dxnp1-%data% dxnp1-%offset%)
  51        (ideg f2cl-lib:integer4 ideg-%data% ideg-%offset%)
  52        (numt f2cl-lib:integer4 numt-%data% numt-%offset%)
  53        (kdeg f2cl-lib:integer4 kdeg-%data% kdeg-%offset%))
  54     (prog ((oneml 0.0) (j 0) (j2 0) (j2m1 0) (k 0) (k2 0) (k2m1 0))
  55       (declare (type (f2cl-lib:integer4) k2m1 k2 k j2m1 j2 j)
  56                (type (double-float) oneml))
  57       (gfunp n ideg pdg qdg x xdgm1 xdg pxdgm1 pxdg g dg)
  58       (ffunp n numt mmaxt kdeg coef cl x xx trm dtrm clx dxnp1 f df)
  59       (setf oneml (- 1.0f0 lambda$))
  60       (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
  61                     ((> j n) nil)
  62         (tagbody
  63           (setf j2 (f2cl-lib:int-mul 2 j))
  64           (setf j2m1 (f2cl-lib:int-sub j2 1))
  65           (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
  66                         ((> k n) nil)
  67             (tagbody
  68               (setf k2 (f2cl-lib:int-mul 2 k))
  69               (setf k2m1 (f2cl-lib:int-sub k2 1))
  70               (setf (f2cl-lib:fref drhox-%data%
  71                                    (j2m1 k2m1)
  72                                    ((1 (f2cl-lib:int-mul 2 n))
  73                                     (1 (f2cl-lib:int-mul 2 n)))
  74                                    drhox-%offset%)
  75                       (* lambda$
  76                          (f2cl-lib:fref df-%data%
  77                                         (1 j k)
  78                                         ((1 2) (1 n)
  79                                          (1 (f2cl-lib:int-add n 1)))
  80                                         df-%offset%)))
  81               (setf (f2cl-lib:fref drhox-%data%
  82                                    (j2 k2)
  83                                    ((1 (f2cl-lib:int-mul 2 n))
  84                                     (1 (f2cl-lib:int-mul 2 n)))
  85                                    drhox-%offset%)
  86                       (f2cl-lib:fref drhox-%data%
  87                                      (j2m1 k2m1)
  88                                      ((1 (f2cl-lib:int-mul 2 n))
  89                                       (1 (f2cl-lib:int-mul 2 n)))
  90                                      drhox-%offset%))
  91               (setf (f2cl-lib:fref drhox-%data%
  92                                    (j2 k2m1)
  93                                    ((1 (f2cl-lib:int-mul 2 n))
  94                                     (1 (f2cl-lib:int-mul 2 n)))
  95                                    drhox-%offset%)
  96                       (* lambda$
  97                          (f2cl-lib:fref df-%data%
  98                                         (2 j k)
  99                                         ((1 2) (1 n)
 100                                          (1 (f2cl-lib:int-add n 1)))
 101                                         df-%offset%)))
 102               (setf (f2cl-lib:fref drhox-%data%
 103                                    (j2m1 k2)
 104                                    ((1 (f2cl-lib:int-mul 2 n))
 105                                     (1 (f2cl-lib:int-mul 2 n)))
 106                                    drhox-%offset%)
 107                       (-
 108                        (f2cl-lib:fref drhox-%data%
 109                                       (j2 k2m1)
 110                                       ((1 (f2cl-lib:int-mul 2 n))
 111                                        (1 (f2cl-lib:int-mul 2 n)))
 112                                       drhox-%offset%)))
 113              label20))
 114           (setf (f2cl-lib:fref drhox-%data%
 115                                (j2m1 j2m1)
 116                                ((1 (f2cl-lib:int-mul 2 n))
 117                                 (1 (f2cl-lib:int-mul 2 n)))
 118                                drhox-%offset%)
 119                   (+
 120                    (f2cl-lib:fref drhox-%data%
 121                                   (j2m1 j2m1)
 122                                   ((1 (f2cl-lib:int-mul 2 n))
 123                                    (1 (f2cl-lib:int-mul 2 n)))
 124                                   drhox-%offset%)
 125                    (* oneml
 126                       (f2cl-lib:fref dg-%data%
 127                                      (1 j)
 128                                      ((1 2) (1 n))
 129                                      dg-%offset%))))
 130           (setf (f2cl-lib:fref drhox-%data%
 131                                (j2 j2)
 132                                ((1 (f2cl-lib:int-mul 2 n))
 133                                 (1 (f2cl-lib:int-mul 2 n)))
 134                                drhox-%offset%)
 135                   (f2cl-lib:fref drhox-%data%
 136                                  (j2m1 j2m1)
 137                                  ((1 (f2cl-lib:int-mul 2 n))
 138                                   (1 (f2cl-lib:int-mul 2 n)))
 139                                  drhox-%offset%))
 140           (setf (f2cl-lib:fref drhox-%data%
 141                                (j2 j2m1)
 142                                ((1 (f2cl-lib:int-mul 2 n))
 143                                 (1 (f2cl-lib:int-mul 2 n)))
 144                                drhox-%offset%)
 145                   (+
 146                    (f2cl-lib:fref drhox-%data%
 147                                   (j2 j2m1)
 148                                   ((1 (f2cl-lib:int-mul 2 n))
 149                                    (1 (f2cl-lib:int-mul 2 n)))
 150                                   drhox-%offset%)
 151                    (* oneml
 152                       (f2cl-lib:fref dg-%data%
 153                                      (2 j)
 154                                      ((1 2) (1 n))
 155                                      dg-%offset%))))
 156           (setf (f2cl-lib:fref drhox-%data%
 157                                (j2m1 j2)
 158                                ((1 (f2cl-lib:int-mul 2 n))
 159                                 (1 (f2cl-lib:int-mul 2 n)))
 160                                drhox-%offset%)
 161                   (-
 162                    (f2cl-lib:fref drhox-%data%
 163                                   (j2 j2m1)
 164                                   ((1 (f2cl-lib:int-mul 2 n))
 165                                    (1 (f2cl-lib:int-mul 2 n)))
 166                                   drhox-%offset%)))
 167           (setf (f2cl-lib:fref drhol-%data%
 168                                (j2m1)
 169                                ((1 (f2cl-lib:int-mul 2 n)))
 170                                drhol-%offset%)
 171                   (- (f2cl-lib:fref f-%data% (1 j) ((1 2) (1 n)) f-%offset%)
 172                      (f2cl-lib:fref g-%data% (1 j) ((1 2) (1 n)) g-%offset%)))
 173           (setf (f2cl-lib:fref drhol-%data%
 174                                (j2)
 175                                ((1 (f2cl-lib:int-mul 2 n)))
 176                                drhol-%offset%)
 177                   (- (f2cl-lib:fref f-%data% (2 j) ((1 2) (1 n)) f-%offset%)
 178                      (f2cl-lib:fref g-%data% (2 j) ((1 2) (1 n)) g-%offset%)))
 179           (setf (f2cl-lib:fref rho-%data%
 180                                (j2m1)
 181                                ((1 (f2cl-lib:int-mul 2 n)))
 182                                rho-%offset%)
 183                   (+
 184                    (* lambda$
 185                       (f2cl-lib:fref f-%data% (1 j) ((1 2) (1 n)) f-%offset%))
 186                    (* oneml
 187                       (f2cl-lib:fref g-%data%
 188                                      (1 j)
 189                                      ((1 2) (1 n))
 190                                      g-%offset%))))
 191           (setf (f2cl-lib:fref rho-%data%
 192                                (j2)
 193                                ((1 (f2cl-lib:int-mul 2 n)))
 194                                rho-%offset%)
 195                   (+
 196                    (* lambda$
 197                       (f2cl-lib:fref f-%data% (2 j) ((1 2) (1 n)) f-%offset%))
 198                    (* oneml
 199                       (f2cl-lib:fref g-%data%
 200                                      (2 j)
 201                                      ((1 2) (1 n))
 202                                      g-%offset%))))
 203          label30))
 204       (go end_label)
 205      end_label
 206       (return
 207        (values nil
 208                nil
 209                nil
 210                nil
 211                nil
 212                nil
 213                nil
 214                nil
 215                nil
 216                nil
 217                nil
 218                nil
 219                nil
 220                nil
 221                nil
 222                nil
 223                nil
 224                nil
 225                nil
 226                nil
 227                nil
 228                nil
 229                nil
 230                nil
 231                nil
 232                nil
 233                nil)))))
 234
 235 (in-package #:cl-user)
 236 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 237 (eval-when (:load-toplevel :compile-toplevel :execute)
 238   (setf (gethash 'fortran-to-lisp::hfun1p
 239                  fortran-to-lisp::*f2cl-function-info*)
 240           (fortran-to-lisp::make-f2cl-finfo
 241            :arg-types '((array double-float (*)) (double-float)
 242                         (array double-float (*)) (array double-float (*))
 243                         (array double-float (*)) (array double-float (*))
 244                         (array double-float (*)) (array double-float (*))
 245                         (array double-float (*)) (array double-float (*))
 246                         (array double-float (*)) (array double-float (*))
 247                         (array double-float (*)) (array double-float (*))
 248                         (array double-float (*)) (array double-float (*))
 249                         (array double-float (*)) (array double-float (*))
 250                         (array double-float (*)) (array double-float (*))
 251                         (array double-float (*)) (array double-float (*))
 252                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 253                         (array fortran-to-lisp::integer4 (*))
 254                         (array fortran-to-lisp::integer4 (*))
 255                         (array fortran-to-lisp::integer4 (*)))
 256            :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil
 257                             nil nil nil nil nil nil nil nil nil nil nil nil nil
 258                             nil)
 259            :calls '(fortran-to-lisp::ffunp fortran-to-lisp::gfunp))))
 260