share/fftpack5/lisp/rffti1.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 (let ((ntryh
  21        (make-array 4
  22                    :element-type 'f2cl-lib:integer4
  23                    :initial-contents '(4 2 3 5))))
  24   (declare (type (array f2cl-lib:integer4 (4)) ntryh))
  25   (defun rffti1 (n wa fac)
  26     (declare (type (array double-float (*)) fac)
  27              (type (array double-float (*)) wa)
  28              (type (f2cl-lib:integer4) n))
  29     (f2cl-lib:with-multi-array-data
  30         ((wa double-float wa-%data% wa-%offset%)
  31          (fac double-float fac-%data% fac-%offset%))
  32       (prog ((tpi 0.0d0) (argh 0.0d0) (argld 0.0d0) (arg 0.0d0) (ii 0)
  33              (fi 0.0d0) (ipm 0) (ido 0) (l2 0) (ld 0) (ip 0) (k1 0) (l1 0)
  34              (nfm1 0) (is 0) (ib 0) (i 0) (nr 0) (nq 0) (ntry 0) (j 0) (nf 0)
  35              (nl 0))
  36         (declare (type (f2cl-lib:integer4) nl nf j ntry nq nr i ib is nfm1 l1
  37                                            k1 ip ld l2 ido ipm ii)
  38                  (type (double-float) fi arg argld argh tpi))
  39         (setf nl n)
  40         (setf nf 0)
  41         (setf j 0)
  42        label101
  43         (setf j (f2cl-lib:int-add j 1))
  44         (f2cl-lib:arithmetic-if (f2cl-lib:int-sub j 4)
  45                                 (go label102)
  46                                 (go label102)
  47                                 (go label103))
  48        label102
  49         (setf ntry (f2cl-lib:fref ntryh (j) ((1 4))))
  50         (go label104)
  51        label103
  52         (setf ntry (f2cl-lib:int-add ntry 2))
  53        label104
  54         (setf nq (the f2cl-lib:integer4 (truncate nl ntry)))
  55         (setf nr (f2cl-lib:int-sub nl (f2cl-lib:int-mul ntry nq)))
  56         (f2cl-lib:arithmetic-if nr (go label101) (go label105) (go label101))
  57        label105
  58         (setf nf (f2cl-lib:int-add nf 1))
  59         (setf (f2cl-lib:fref fac-%data%
  60                              ((f2cl-lib:int-add nf 2))
  61                              ((1 15))
  62                              fac-%offset%)
  63                 (coerce (the f2cl-lib:integer4 ntry) 'double-float))
  64         (setf nl nq)
  65         (if (/= ntry 2) (go label107))
  66         (if (= nf 1) (go label107))
  67         (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1))
  68                       ((> i nf) nil)
  69           (tagbody
  70             (setf ib (f2cl-lib:int-add (f2cl-lib:int-sub nf i) 2))
  71             (setf (f2cl-lib:fref fac-%data%
  72                                  ((f2cl-lib:int-add ib 2))
  73                                  ((1 15))
  74                                  fac-%offset%)
  75                     (f2cl-lib:fref fac-%data%
  76                                    ((f2cl-lib:int-add ib 1))
  77                                    ((1 15))
  78                                    fac-%offset%))
  79            label106))
  80         (setf (f2cl-lib:fref fac-%data% (3) ((1 15)) fac-%offset%)
  81                 (coerce (the f2cl-lib:integer4 2) 'double-float))
  82        label107
  83         (if (/= nl 1) (go label104))
  84         (setf (f2cl-lib:fref fac-%data% (1) ((1 15)) fac-%offset%)
  85                 (coerce (the f2cl-lib:integer4 n) 'double-float))
  86         (setf (f2cl-lib:fref fac-%data% (2) ((1 15)) fac-%offset%)
  87                 (coerce (the f2cl-lib:integer4 nf) 'double-float))
  88         (setf tpi (* 8.0d0 (f2cl-lib:datan 1.0d0)))
  89         (setf argh (/ tpi (f2cl-lib:ffloat n)))
  90         (setf is 0)
  91         (setf nfm1 (f2cl-lib:int-sub nf 1))
  92         (setf l1 1)
  93         (if (= nfm1 0) (go end_label))
  94         (f2cl-lib:fdo (k1 1 (f2cl-lib:int-add k1 1))
  95                       ((> k1 nfm1) nil)
  96           (tagbody
  97             (setf ip
  98                     (f2cl-lib:int
  99                      (f2cl-lib:fref fac-%data%
 100                                     ((f2cl-lib:int-add k1 2))
 101                                     ((1 15))
 102                                     fac-%offset%)))
 103             (setf ld 0)
 104             (setf l2 (f2cl-lib:int-mul l1 ip))
 105             (setf ido (the f2cl-lib:integer4 (truncate n l2)))
 106             (setf ipm (f2cl-lib:int-sub ip 1))
 107             (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 108                           ((> j ipm) nil)
 109               (tagbody
 110                 (setf ld (f2cl-lib:int-add ld l1))
 111                 (setf i is)
 112                 (setf argld (* (f2cl-lib:ffloat ld) argh))
 113                 (setf fi 0.0d0)
 114                 (f2cl-lib:fdo (ii 3 (f2cl-lib:int-add ii 2))
 115                               ((> ii ido) nil)
 116                   (tagbody
 117                     (setf i (f2cl-lib:int-add i 2))
 118                     (setf fi (+ fi 1.0d0))
 119                     (setf arg (* fi argld))
 120                     (setf (f2cl-lib:fref wa-%data%
 121                                          ((f2cl-lib:int-sub i 1))
 122                                          ((1 n))
 123                                          wa-%offset%)
 124                             (f2cl-lib:dcos arg))
 125                     (setf (f2cl-lib:fref wa-%data% (i) ((1 n)) wa-%offset%)
 126                             (f2cl-lib:dsin arg))
 127                    label108))
 128                 (setf is (f2cl-lib:int-add is ido))
 129                label109))
 130             (setf l1 l2)
 131            label110))
 132         (go end_label)
 133        end_label
 134         (return (values nil nil nil))))))
 135
 136 (in-package #:cl-user)
 137 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 138 (eval-when (:load-toplevel :compile-toplevel :execute)
 139   (setf (gethash 'fortran-to-lisp::rffti1
 140                  fortran-to-lisp::*f2cl-function-info*)
 141           (fortran-to-lisp::make-f2cl-finfo
 142            :arg-types '((fortran-to-lisp::integer4) (array double-float (*))
 143                         (array double-float (*)))
 144            :return-values '(nil nil nil)
 145            :calls 'nil)))
 146