share/fftpack5/lisp/msntf1.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 msntf1 (lot jump n inc x wsave dsum xh work ier)
  21   (declare (type (double-float) work)
  22            (type (array double-float (*)) xh dsum wsave x)
  23            (type (f2cl-lib:integer4) ier inc n jump lot))
  24   (f2cl-lib:with-multi-array-data
  25       ((x double-float x-%data% x-%offset%)
  26        (wsave double-float wsave-%data% wsave-%offset%)
  27        (dsum double-float dsum-%data% dsum-%offset%)
  28        (xh double-float xh-%data% xh-%offset%))
  29     (prog ((i 0) (sfnp1 0.0d0) (ier1 0) (lnwk 0) (lnsv 0) (lnxh 0) (modn 0)
  30            (t2 0.0d0) (t1 0.0d0) (m1 0) (kc 0) (k 0) (ns2 0) (np1 0)
  31            (xhold 0.0d0) (m 0) (ssqrt3 0.0d0) (lj 0))
  32       (declare (type (double-float) ssqrt3 xhold t1 t2 sfnp1)
  33                (type (f2cl-lib:integer4) lj m np1 ns2 k kc m1 modn lnxh lnsv
  34                                          lnwk ier1 i))
  35       (setf ier 0)
  36       (setf lj
  37               (f2cl-lib:int-add
  38                (f2cl-lib:int-mul (f2cl-lib:int-sub lot 1) jump)
  39                1))
  40       (f2cl-lib:arithmetic-if (f2cl-lib:int-sub n 2)
  41                               (go label101)
  42                               (go label102)
  43                               (go label103))
  44      label102
  45       (setf ssqrt3 (/ 1.0d0 (f2cl-lib:fsqrt 3.0d0)))
  46       (f2cl-lib:fdo (m 1 (f2cl-lib:int-add m jump))
  47                     ((> m lj) nil)
  48         (tagbody
  49           (setf xhold
  50                   (* ssqrt3
  51                      (+
  52                       (f2cl-lib:fref x-%data% (m 1) ((1 inc) (1 *)) x-%offset%)
  53                       (f2cl-lib:fref x-%data%
  54                                      (m 2)
  55                                      ((1 inc) (1 *))
  56                                      x-%offset%))))
  57           (setf (f2cl-lib:fref x-%data% (m 2) ((1 inc) (1 *)) x-%offset%)
  58                   (* ssqrt3
  59                      (-
  60                       (f2cl-lib:fref x-%data% (m 1) ((1 inc) (1 *)) x-%offset%)
  61                       (f2cl-lib:fref x-%data%
  62                                      (m 2)
  63                                      ((1 inc) (1 *))
  64                                      x-%offset%))))
  65           (setf (f2cl-lib:fref x-%data% (m 1) ((1 inc) (1 *)) x-%offset%)
  66                   xhold)
  67          label112))
  68      label101
  69       (go label200)
  70      label103
  71       (setf np1 (f2cl-lib:int-add n 1))
  72       (setf ns2 (the f2cl-lib:integer4 (truncate n 2)))
  73       (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
  74                     ((> k ns2) nil)
  75         (tagbody
  76           (setf kc (f2cl-lib:int-sub np1 k))
  77           (setf m1 0)
  78           (f2cl-lib:fdo (m 1 (f2cl-lib:int-add m jump))
  79                         ((> m lj) nil)
  80             (tagbody
  81               (setf m1 (f2cl-lib:int-add m1 1))
  82               (setf t1
  83                       (-
  84                        (f2cl-lib:fref x-%data%
  85                                       (m k)
  86                                       ((1 inc) (1 *))
  87                                       x-%offset%)
  88                        (f2cl-lib:fref x-%data%
  89                                       (m kc)
  90                                       ((1 inc) (1 *))
  91                                       x-%offset%)))
  92               (setf t2
  93                       (*
  94                        (f2cl-lib:fref wsave-%data% (k) ((1 *)) wsave-%offset%)
  95                        (+
  96                         (f2cl-lib:fref x-%data%
  97                                        (m k)
  98                                        ((1 inc) (1 *))
  99                                        x-%offset%)
 100                         (f2cl-lib:fref x-%data%
 101                                        (m kc)
 102                                        ((1 inc) (1 *))
 103                                        x-%offset%))))
 104               (setf (f2cl-lib:fref xh-%data%
 105                                    (m1 (f2cl-lib:int-add k 1))
 106                                    ((1 lot) (1 *))
 107                                    xh-%offset%)
 108                       (+ t1 t2))
 109               (setf (f2cl-lib:fref xh-%data%
 110                                    (m1 (f2cl-lib:int-add kc 1))
 111                                    ((1 lot) (1 *))
 112                                    xh-%offset%)
 113                       (- t2 t1))
 114              label114))
 115          label104))
 116       (setf modn (mod n 2))
 117       (if (= modn 0) (go label124))
 118       (setf m1 0)
 119       (f2cl-lib:fdo (m 1 (f2cl-lib:int-add m jump))
 120                     ((> m lj) nil)
 121         (tagbody
 122           (setf m1 (f2cl-lib:int-add m1 1))
 123           (setf (f2cl-lib:fref xh-%data%
 124                                (m1 (f2cl-lib:int-add ns2 2))
 125                                ((1 lot) (1 *))
 126                                xh-%offset%)
 127                   (* 4.0d0
 128                      (f2cl-lib:fref x-%data%
 129                                     (m (f2cl-lib:int-add ns2 1))
 130                                     ((1 inc) (1 *))
 131                                     x-%offset%)))
 132          label123))
 133      label124
 134       (f2cl-lib:fdo (m 1 (f2cl-lib:int-add m 1))
 135                     ((> m lot) nil)
 136         (tagbody
 137           (setf (f2cl-lib:fref xh-%data% (m 1) ((1 lot) (1 *)) xh-%offset%)
 138                   0.0d0)
 139          label127))
 140       (setf lnxh
 141               (f2cl-lib:int-add (f2cl-lib:int-sub lot 1)
 142                                 (f2cl-lib:int-mul lot (f2cl-lib:int-sub np1 1))
 143                                 1))
 144       (setf lnsv
 145               (f2cl-lib:int-add np1
 146                                 (f2cl-lib:int
 147                                  (/ (f2cl-lib:flog (f2cl-lib:freal np1))
 148                                     (f2cl-lib:flog 2.0d0)))
 149                                 4))
 150       (setf lnwk (f2cl-lib:int-mul lot np1))
 151       (multiple-value-bind
 152             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
 153              var-10)
 154           (rfftmf lot 1 np1 lot xh lnxh
 155            (f2cl-lib:array-slice wsave-%data%
 156                                  double-float
 157                                  ((+ ns2 1))
 158                                  ((1 *))
 159                                  wsave-%offset%)
 160            lnsv
 161            (make-array 1 :element-type (type-of work) :initial-element work)
 162            lnwk ier1)
 163         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
 164                          var-9))
 165         (setf ier1 var-10))
 166       (cond
 167         ((/= ier1 0)
 168          (setf ier 20)
 169          (xerfft "MSNTF1" -5)
 170          (go label200)))
 171       (if (/= (mod np1 2) 0) (go label30))
 172       (f2cl-lib:fdo (m 1 (f2cl-lib:int-add m 1))
 173                     ((> m lot) nil)
 174         (tagbody
 175           (setf (f2cl-lib:fref xh-%data% (m np1) ((1 lot) (1 *)) xh-%offset%)
 176                   (+
 177                    (f2cl-lib:fref xh-%data%
 178                                   (m np1)
 179                                   ((1 lot) (1 *))
 180                                   xh-%offset%)
 181                    (f2cl-lib:fref xh-%data%
 182                                   (m np1)
 183                                   ((1 lot) (1 *))
 184                                   xh-%offset%)))
 185          label20))
 186      label30
 187       (setf sfnp1 (/ 1.0d0 (f2cl-lib:ffloat np1)))
 188       (setf m1 0)
 189       (f2cl-lib:fdo (m 1 (f2cl-lib:int-add m jump))
 190                     ((> m lj) nil)
 191         (tagbody
 192           (setf m1 (f2cl-lib:int-add m1 1))
 193           (setf (f2cl-lib:fref x-%data% (m 1) ((1 inc) (1 *)) x-%offset%)
 194                   (* 0.5d0
 195                      (f2cl-lib:fref xh-%data%
 196                                     (m1 1)
 197                                     ((1 lot) (1 *))
 198                                     xh-%offset%)))
 199           (setf (f2cl-lib:fref dsum-%data% (m1) ((1 *)) dsum-%offset%)
 200                   (f2cl-lib:fref x-%data% (m 1) ((1 inc) (1 *)) x-%offset%))
 201          label125))
 202       (f2cl-lib:fdo (i 3 (f2cl-lib:int-add i 2))
 203                     ((> i n) nil)
 204         (tagbody
 205           (setf m1 0)
 206           (f2cl-lib:fdo (m 1 (f2cl-lib:int-add m jump))
 207                         ((> m lj) nil)
 208             (tagbody
 209               (setf m1 (f2cl-lib:int-add m1 1))
 210               (setf (f2cl-lib:fref x-%data%
 211                                    (m (f2cl-lib:int-sub i 1))
 212                                    ((1 inc) (1 *))
 213                                    x-%offset%)
 214                       (* 0.5d0
 215                          (f2cl-lib:fref xh-%data%
 216                                         (m1 i)
 217                                         ((1 lot) (1 *))
 218                                         xh-%offset%)))
 219               (setf (f2cl-lib:fref dsum-%data% (m1) ((1 *)) dsum-%offset%)
 220                       (+ (f2cl-lib:fref dsum-%data% (m1) ((1 *)) dsum-%offset%)
 221                          (* 0.5d0
 222                             (f2cl-lib:fref xh-%data%
 223                                            (m1 (f2cl-lib:int-sub i 1))
 224                                            ((1 lot) (1 *))
 225                                            xh-%offset%))))
 226               (setf (f2cl-lib:fref x-%data% (m i) ((1 inc) (1 *)) x-%offset%)
 227                       (f2cl-lib:fref dsum-%data% (m1) ((1 *)) dsum-%offset%))
 228              label115))
 229          label105))
 230       (if (/= modn 0) (go label200))
 231       (setf m1 0)
 232       (f2cl-lib:fdo (m 1 (f2cl-lib:int-add m jump))
 233                     ((> m lj) nil)
 234         (tagbody
 235           (setf m1 (f2cl-lib:int-add m1 1))
 236           (setf (f2cl-lib:fref x-%data% (m n) ((1 inc) (1 *)) x-%offset%)
 237                   (* 0.5d0
 238                      (f2cl-lib:fref xh-%data%
 239                                     (m1 (f2cl-lib:int-add n 1))
 240                                     ((1 lot) (1 *))
 241                                     xh-%offset%)))
 242          label116))
 243      label200
 244       (go end_label)
 245      end_label
 246       (return (values nil nil nil nil nil nil nil nil nil ier)))))
 247
 248 (in-package #:cl-user)
 249 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 250 (eval-when (:load-toplevel :compile-toplevel :execute)
 251   (setf (gethash 'fortran-to-lisp::msntf1
 252                  fortran-to-lisp::*f2cl-function-info*)
 253           (fortran-to-lisp::make-f2cl-finfo
 254            :arg-types '((fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 255                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 256                         (array double-float (*)) (array double-float (*))
 257                         (array double-float (*)) (array double-float (*))
 258                         (double-float) (fortran-to-lisp::integer4))
 259            :return-values '(nil nil nil nil nil nil nil nil nil
 260                             fortran-to-lisp::ier)
 261            :calls '(fortran-to-lisp::xerfft fortran-to-lisp::rfftmf))))
 262