share/fftpack5/lisp/rfft2b.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 rfft2b (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 "RFFT2B" 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 "RFFT2B" 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 "RFFT2B" -6)
  55          (go label100)))
  56       (let ((%copy-r
  57              (f2cl-lib:make-compatible-seq (array f2cl-lib:complex16 (*))
  58                                            r
  59                                            (array double-float (*)))))
  60         (f2cl-lib:f2cl-copy-seq %copy-r r f2cl-lib:complex16 double-float)
  61         (multiple-value-bind
  62               (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
  63                var-10)
  64             (cfftmb (+ (the f2cl-lib:integer4 (truncate l 2)) 1) 1 m
  65              (the f2cl-lib:integer4 (truncate ldim 2)) %copy-r
  66              (the f2cl-lib:integer4 (truncate (* m ldim) 2))
  67              (f2cl-lib:array-slice wsave-%data%
  68                                    double-float
  69                                    ((+ l
  70                                        (f2cl-lib:int
  71                                         (f2cl-lib:flog (f2cl-lib:freal l)))
  72                                        5))
  73                                    ((1 lensav))
  74                                    wsave-%offset%)
  75              (f2cl-lib:int-add (f2cl-lib:int-mul 2 m)
  76                                (f2cl-lib:int
  77                                 (f2cl-lib:flog (f2cl-lib:freal m)))
  78                                4)
  79              work (* 2 (+ (the f2cl-lib:integer4 (truncate l 2)) 1) m) ier1)
  80           (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
  81                            var-8 var-9))
  82           (setf ier1 var-10))
  83         (f2cl-lib:f2cl-copy-seq r %copy-r double-float f2cl-lib:complex16))
  84       (cond
  85         ((/= ier1 0)
  86          (setf ier 20)
  87          (xerfft "RFFT2B" -5)
  88          (go label100)))
  89       (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
  90                     ((> j m) nil)
  91         (tagbody
  92           (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1))
  93                         ((> i l) nil)
  94             (tagbody
  95               (setf (f2cl-lib:fref r-%data% (i j) ((1 ldim) (1 m)) r-%offset%)
  96                       (f2cl-lib:fref r-%data%
  97                                      ((f2cl-lib:int-add i 1) j)
  98                                      ((1 ldim) (1 m))
  99                                      r-%offset%))
 100              label100001))
 101          label100000))
 102       (multiple-value-bind
 103             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
 104              var-10)
 105           (rfftmb m ldim l 1 r (f2cl-lib:int-mul m ldim)
 106            (f2cl-lib:array-slice wsave-%data%
 107                                  double-float
 108                                  (1)
 109                                  ((1 lensav))
 110                                  wsave-%offset%)
 111            (f2cl-lib:int-add l
 112                              (f2cl-lib:int (f2cl-lib:flog (f2cl-lib:freal l)))
 113                              4)
 114            work (* 2 (+ (the f2cl-lib:integer4 (truncate l 2)) 1) m) ier1)
 115         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
 116                          var-9))
 117         (setf ier1 var-10))
 118       (cond
 119         ((/= ier1 0)
 120          (setf ier 20)
 121          (xerfft "RFFT2F" -5)
 122          (go label100)))
 123      label100
 124       (go end_label)
 125      end_label
 126       (return (values nil nil nil nil nil nil nil nil ier)))))
 127
 128 (in-package #:cl-user)
 129 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 130 (eval-when (:load-toplevel :compile-toplevel :execute)
 131   (setf (gethash 'fortran-to-lisp::rfft2b
 132                  fortran-to-lisp::*f2cl-function-info*)
 133           (fortran-to-lisp::make-f2cl-finfo
 134            :arg-types '((fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 135                         (fortran-to-lisp::integer4) (array double-float (*))
 136                         (array double-float (*)) (fortran-to-lisp::integer4)
 137                         (array double-float (*)) (fortran-to-lisp::integer4)
 138                         (fortran-to-lisp::integer4))
 139            :return-values '(nil nil nil nil nil nil nil nil
 140                             fortran-to-lisp::ier)
 141            :calls '(fortran-to-lisp::rfftmb fortran-to-lisp::cfftmb
 142                     fortran-to-lisp::xerfft))))
 143