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