share/fftpack5/lisp/rfft2f.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 rfft2f (ldim l m r wsave lensav work lenwrk ier)
  21   (declare (type (array double-float (*)) work wsave r)
  22            (type (f2cl-lib:integer4) ier lenwrk lensav m l ldim))
  23   (f2cl-lib:with-multi-array-data
  24       ((r double-float r-%data% r-%offset%)
  25        (wsave double-float wsave-%data% wsave-%offset%)
  26        (work double-float work-%data% work-%offset%))
  27     (prog ((i 0) (j 0) (ier1 0) (mwsav 0) (lwsav 0))
  28       (declare (type (f2cl-lib:integer4) lwsav mwsav ier1 j i))
  29       (setf ier 0)
  30       (setf lwsav
  31               (f2cl-lib:int-add l
  32                                 (f2cl-lib:int
  33                                  (f2cl-lib:flog (f2cl-lib:freal l)))
  34                                 4))
  35       (setf mwsav
  36               (f2cl-lib:int-add (f2cl-lib:int-mul 2 m)
  37                                 (f2cl-lib:int
  38                                  (f2cl-lib:flog (f2cl-lib:freal m)))
  39                                 4))
  40       (cond
  41         ((< lensav (f2cl-lib:int-add lwsav mwsav))
  42          (setf ier 2)
  43          (xerfft "RFFT2F" 6)
  44          (go label100)))
  45       (cond
  46         ((< lenwrk
  47             (f2cl-lib:int-mul 2 (f2cl-lib:int-add (f2cl-lib:f2cl/ l 2) 1) m))
  48          (setf ier 3)
  49          (xerfft "RFFT2F" 8)
  50          (go label100)))
  51       (cond
  52         ((< ldim (f2cl-lib:int-mul 2 (f2cl-lib:int-add (f2cl-lib:f2cl/ l 2) 1)))
  53          (setf ier 5)
  54          (xerfft "RFFT2F" -6)
  55          (go label100)))
  56       (multiple-value-bind
  57             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
  58              var-10)
  59           (rfftmf m ldim l 1 r (f2cl-lib:int-mul m ldim)
  60            (f2cl-lib:array-slice wsave-%data%
  61                                  double-float
  62                                  (1)
  63                                  ((1 lensav))
  64                                  wsave-%offset%)
  65            (f2cl-lib:int-add l
  66                              (f2cl-lib:int (f2cl-lib:flog (f2cl-lib:freal l)))
  67                              4)
  68            work (* 2 (+ (the f2cl-lib:integer4 (truncate l 2)) 1) m) ier1)
  69         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
  70                          var-9))
  71         (setf ier1 var-10))
  72       (cond
  73         ((/= ier1 0)
  74          (setf ier 20)
  75          (xerfft "RFFT2F" -5)
  76          (go label100)))
  77       (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
  78                     ((> j m) nil)
  79         (tagbody
  80           (if (= (mod l 2) 0)
  81               (setf (f2cl-lib:fref r-%data%
  82                                    ((f2cl-lib:int-add l 2) j)
  83                                    ((1 ldim) (1 m))
  84                                    r-%offset%)
  85                       0.0d0))
  86           (f2cl-lib:fdo (i l (f2cl-lib:int-add i (f2cl-lib:int-sub 1)))
  87                         ((> i 2) nil)
  88             (tagbody
  89               (setf (f2cl-lib:fref r-%data%
  90                                    ((f2cl-lib:int-add i 1) j)
  91                                    ((1 ldim) (1 m))
  92                                    r-%offset%)
  93                       (f2cl-lib:fref r-%data%
  94                                      (i j)
  95                                      ((1 ldim) (1 m))
  96                                      r-%offset%))
  97              label100001))
  98           (setf (f2cl-lib:fref r-%data% (2 j) ((1 ldim) (1 m)) r-%offset%)
  99                   0.0d0)
 100          label100000))
 101       (let ((%copy-r
 102              (f2cl-lib:make-compatible-seq (array f2cl-lib:complex16 (*))
 103                                            r
 104                                            (array double-float (*)))))
 105         (f2cl-lib:f2cl-copy-seq %copy-r r f2cl-lib:complex16 double-float)
 106         (multiple-value-bind
 107               (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
 108                var-10)
 109             (cfftmf (+ (the f2cl-lib:integer4 (truncate l 2)) 1) 1 m
 110              (the f2cl-lib:integer4 (truncate ldim 2)) %copy-r
 111              (the f2cl-lib:integer4 (truncate (* m ldim) 2))
 112              (f2cl-lib:array-slice wsave-%data%
 113                                    double-float
 114                                    ((+ l
 115                                        (f2cl-lib:int
 116                                         (f2cl-lib:flog (f2cl-lib:freal l)))
 117                                        5))
 118                                    ((1 lensav))
 119                                    wsave-%offset%)
 120              (f2cl-lib:int-add (f2cl-lib:int-mul 2 m)
 121                                (f2cl-lib:int
 122                                 (f2cl-lib:flog (f2cl-lib:freal m)))
 123                                4)
 124              work (* 2 (+ (the f2cl-lib:integer4 (truncate l 2)) 1) m) ier1)
 125           (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
 126                            var-8 var-9))
 127           (setf ier1 var-10))
 128         (f2cl-lib:f2cl-copy-seq r %copy-r double-float f2cl-lib:complex16))
 129       (cond
 130         ((/= ier1 0)
 131          (setf ier 20)
 132          (xerfft "RFFT2F" -5)
 133          (go label100)))
 134      label100
 135       (go end_label)
 136      end_label
 137       (return (values nil nil nil nil nil nil nil nil ier)))))
 138
 139 (in-package #:cl-user)
 140 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 141 (eval-when (:load-toplevel :compile-toplevel :execute)
 142   (setf (gethash 'fortran-to-lisp::rfft2f
 143                  fortran-to-lisp::*f2cl-function-info*)
 144           (fortran-to-lisp::make-f2cl-finfo
 145            :arg-types '((fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 146                         (fortran-to-lisp::integer4) (array double-float (*))
 147                         (array double-float (*)) (fortran-to-lisp::integer4)
 148                         (array double-float (*)) (fortran-to-lisp::integer4)
 149                         (fortran-to-lisp::integer4))
 150            :return-values '(nil nil nil nil nil nil nil nil
 151                             fortran-to-lisp::ier)
 152            :calls '(fortran-to-lisp::cfftmf fortran-to-lisp::rfftmf
 153                     fortran-to-lisp::xerfft))))
 154