share/fftpack5/lisp/sintf1.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 single-float))
  16
  17 (in-package "FFTPACK5")
  18
  19
  20 (defun sintf1 (n inc x wsave xh work ier)
  21   (declare (type (double-float) work)
  22            (type (array double-float (*)) xh wsave x)
  23            (type (f2cl-lib:integer4) ier inc n))
  24   (f2cl-lib:with-multi-array-data
  25       ((x double-float x-%data% x-%offset%)
  26        (wsave double-float wsave-%data% wsave-%offset%)
  27        (xh double-float xh-%data% xh-%offset%))
  28     (prog ((dsum 0.0d0) (i 0) (sfnp1 0.0d0) (ier1 0) (lnwk 0) (lnsv 0) (lnxh 0)
  29            (modn 0) (t2 0.0d0) (t1 0.0d0) (kc 0) (k 0) (ns2 0) (np1 0)
  30            (xhold 0.0d0) (ssqrt3 0.0d0))
  31       (declare (type (f2cl-lib:integer4) np1 ns2 k kc modn lnxh lnsv lnwk ier1
  32                                          i)
  33                (type (double-float) ssqrt3 xhold t1 t2 sfnp1 dsum))
  34       (setf ier 0)
  35       (f2cl-lib:arithmetic-if (f2cl-lib:int-sub n 2)
  36                               (go label200)
  37                               (go label102)
  38                               (go label103))
  39      label102
  40       (setf ssqrt3 (/ 1.0d0 (f2cl-lib:fsqrt 3.0d0)))
  41       (setf xhold
  42               (* ssqrt3
  43                  (+ (f2cl-lib:fref x-%data% (1 1) ((1 inc) (1 *)) x-%offset%)
  44                     (f2cl-lib:fref x-%data%
  45                                    (1 2)
  46                                    ((1 inc) (1 *))
  47                                    x-%offset%))))
  48       (setf (f2cl-lib:fref x-%data% (1 2) ((1 inc) (1 *)) x-%offset%)
  49               (* ssqrt3
  50                  (- (f2cl-lib:fref x-%data% (1 1) ((1 inc) (1 *)) x-%offset%)
  51                     (f2cl-lib:fref x-%data%
  52                                    (1 2)
  53                                    ((1 inc) (1 *))
  54                                    x-%offset%))))
  55       (setf (f2cl-lib:fref x-%data% (1 1) ((1 inc) (1 *)) x-%offset%) xhold)
  56       (go label200)
  57      label103
  58       (setf np1 (f2cl-lib:int-add n 1))
  59       (setf ns2 (the f2cl-lib:integer4 (truncate n 2)))
  60       (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
  61                     ((> k ns2) nil)
  62         (tagbody
  63           (setf kc (f2cl-lib:int-sub np1 k))
  64           (setf t1
  65                   (- (f2cl-lib:fref x-%data% (1 k) ((1 inc) (1 *)) x-%offset%)
  66                      (f2cl-lib:fref x-%data%
  67                                     (1 kc)
  68                                     ((1 inc) (1 *))
  69                                     x-%offset%)))
  70           (setf t2
  71                   (* (f2cl-lib:fref wsave-%data% (k) ((1 *)) wsave-%offset%)
  72                      (+
  73                       (f2cl-lib:fref x-%data% (1 k) ((1 inc) (1 *)) x-%offset%)
  74                       (f2cl-lib:fref x-%data%
  75                                      (1 kc)
  76                                      ((1 inc) (1 *))
  77                                      x-%offset%))))
  78           (setf (f2cl-lib:fref xh-%data%
  79                                ((f2cl-lib:int-add k 1))
  80                                ((1 *))
  81                                xh-%offset%)
  82                   (+ t1 t2))
  83           (setf (f2cl-lib:fref xh-%data%
  84                                ((f2cl-lib:int-add kc 1))
  85                                ((1 *))
  86                                xh-%offset%)
  87                   (- t2 t1))
  88          label104))
  89       (setf modn (mod n 2))
  90       (if (= modn 0) (go label124))
  91       (setf (f2cl-lib:fref xh-%data%
  92                            ((f2cl-lib:int-add ns2 2))
  93                            ((1 *))
  94                            xh-%offset%)
  95               (* 4.0d0
  96                  (f2cl-lib:fref x-%data%
  97                                 (1 (f2cl-lib:int-add ns2 1))
  98                                 ((1 inc) (1 *))
  99                                 x-%offset%)))
 100      label124
 101       (setf (f2cl-lib:fref xh-%data% (1) ((1 *)) xh-%offset%) 0.0d0)
 102       (setf lnxh np1)
 103       (setf lnsv
 104               (f2cl-lib:int-add np1
 105                                 (f2cl-lib:int
 106                                  (/ (f2cl-lib:flog (f2cl-lib:freal np1))
 107                                     (f2cl-lib:flog 2.0d0)))
 108                                 4))
 109       (setf lnwk np1)
 110       (multiple-value-bind
 111             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)
 112           (rfft1f np1 1 xh lnxh
 113            (f2cl-lib:array-slice wsave-%data%
 114                                  double-float
 115                                  ((+ ns2 1))
 116                                  ((1 *))
 117                                  wsave-%offset%)
 118            lnsv
 119            (make-array 1 :element-type (type-of work) :initial-element work)
 120            lnwk ier1)
 121         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7))
 122         (setf ier1 var-8))
 123       (cond
 124         ((/= ier1 0)
 125          (setf ier 20)
 126          (xerfft "SINTF1" -5)
 127          (go label200)))
 128       (if (/= (mod np1 2) 0) (go label30))
 129       (setf (f2cl-lib:fref xh-%data% (np1) ((1 *)) xh-%offset%)
 130               (+ (f2cl-lib:fref xh-%data% (np1) ((1 *)) xh-%offset%)
 131                  (f2cl-lib:fref xh-%data% (np1) ((1 *)) xh-%offset%)))
 132      label30
 133       (setf sfnp1 (/ 1.0d0 (f2cl-lib:ffloat np1)))
 134       (setf (f2cl-lib:fref x-%data% (1 1) ((1 inc) (1 *)) x-%offset%)
 135               (* 0.5d0 (f2cl-lib:fref xh-%data% (1) ((1 *)) xh-%offset%)))
 136       (setf dsum (f2cl-lib:fref x-%data% (1 1) ((1 inc) (1 *)) x-%offset%))
 137       (f2cl-lib:fdo (i 3 (f2cl-lib:int-add i 2))
 138                     ((> i n) nil)
 139         (tagbody
 140           (setf (f2cl-lib:fref x-%data%
 141                                (1 (f2cl-lib:int-sub i 1))
 142                                ((1 inc) (1 *))
 143                                x-%offset%)
 144                   (* 0.5d0 (f2cl-lib:fref xh-%data% (i) ((1 *)) xh-%offset%)))
 145           (setf dsum
 146                   (+ dsum
 147                      (* 0.5d0
 148                         (f2cl-lib:fref xh-%data%
 149                                        ((f2cl-lib:int-sub i 1))
 150                                        ((1 *))
 151                                        xh-%offset%))))
 152           (setf (f2cl-lib:fref x-%data% (1 i) ((1 inc) (1 *)) x-%offset%) dsum)
 153          label105))
 154       (if (/= modn 0) (go label200))
 155       (setf (f2cl-lib:fref x-%data% (1 n) ((1 inc) (1 *)) x-%offset%)
 156               (* 0.5d0
 157                  (f2cl-lib:fref xh-%data%
 158                                 ((f2cl-lib:int-add n 1))
 159                                 ((1 *))
 160                                 xh-%offset%)))
 161      label200
 162       (go end_label)
 163      end_label
 164       (return (values nil nil nil nil nil nil ier)))))
 165
 166 (in-package #:cl-user)
 167 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 168 (eval-when (:load-toplevel :compile-toplevel :execute)
 169   (setf (gethash 'fortran-to-lisp::sintf1
 170                  fortran-to-lisp::*f2cl-function-info*)
 171           (fortran-to-lisp::make-f2cl-finfo
 172            :arg-types '((fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 173                         (array double-float (*)) (array double-float (*))
 174                         (array double-float (*)) (double-float)
 175                         (fortran-to-lisp::integer4))
 176            :return-values '(nil nil nil nil nil nil fortran-to-lisp::ier)
 177            :calls '(fortran-to-lisp::xerfft fortran-to-lisp::rfft1f))))
 178