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