share/fftpack5/lisp/cmfm1b.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 cmfm1b (lot jump n inc c ch wa fnf fac)
  21   (declare (type (double-float) fnf)
  22            (type (array double-float (*)) fac wa ch)
  23            (type (array f2cl-lib:complex16 (*)) c)
  24            (type (f2cl-lib:integer4) inc n jump lot))
  25   (f2cl-lib:with-multi-array-data
  26       ((c f2cl-lib:complex16 c-%data% c-%offset%)
  27        (ch double-float ch-%data% ch-%offset%)
  28        (wa double-float wa-%data% wa-%offset%)
  29        (fac double-float fac-%data% fac-%offset%))
  30     (prog ((nbr 0) (lid 0) (ido 0) (l2 0) (ip 0) (k1 0) (iw 0) (l1 0) (na 0)
  31            (nf 0))
  32       (declare (type (f2cl-lib:integer4) nf na l1 iw k1 ip l2 ido lid nbr))
  33       (setf nf (f2cl-lib:int fnf))
  34       (setf na 0)
  35       (setf l1 1)
  36       (setf iw 1)
  37       (f2cl-lib:fdo (k1 1 (f2cl-lib:int-add k1 1))
  38                     ((> k1 nf) nil)
  39         (tagbody
  40           (setf ip
  41                   (f2cl-lib:int
  42                    (f2cl-lib:fref fac-%data% (k1) ((1 *)) fac-%offset%)))
  43           (setf l2 (f2cl-lib:int-mul ip l1))
  44           (setf ido (the f2cl-lib:integer4 (truncate n l2)))
  45           (setf lid (f2cl-lib:int-mul l1 ido))
  46           (setf nbr
  47                   (f2cl-lib:int-add 1
  48                                     na
  49                                     (f2cl-lib:int-mul 2
  50                                                       (min
  51                                                        (the f2cl-lib:integer4
  52                                                             (f2cl-lib:int-sub
  53                                                              ip
  54                                                              2))
  55                                                        (the f2cl-lib:integer4
  56                                                             4)))))
  57           (f2cl-lib:computed-goto
  58            (label52 label62 label53 label63 label54 label64 label55 label65
  59             label56 label66)
  60            nbr)
  61          label52
  62           (let ((%copy-c
  63                  (f2cl-lib:make-compatible-seq (array double-float (*))
  64                                                c
  65                                                (array f2cl-lib:complex16 (*)))))
  66             (f2cl-lib:f2cl-copy-seq %copy-c c double-float f2cl-lib:complex16)
  67             (cmf2kb lot ido l1 na %copy-c jump inc ch 1 lot
  68              (f2cl-lib:array-slice wa-%data%
  69                                    double-float
  70                                    (iw)
  71                                    ((1 *))
  72                                    wa-%offset%))
  73             (f2cl-lib:f2cl-copy-seq c %copy-c f2cl-lib:complex16 double-float))
  74           (go label120)
  75          label62
  76           (let ((%copy-c
  77                  (f2cl-lib:make-compatible-seq (array double-float (*))
  78                                                c
  79                                                (array f2cl-lib:complex16 (*)))))
  80             (f2cl-lib:f2cl-copy-seq %copy-c c double-float f2cl-lib:complex16)
  81             (cmf2kb lot ido l1 na ch 1 lot %copy-c jump inc
  82              (f2cl-lib:array-slice wa-%data%
  83                                    double-float
  84                                    (iw)
  85                                    ((1 *))
  86                                    wa-%offset%))
  87             (f2cl-lib:f2cl-copy-seq c %copy-c f2cl-lib:complex16 double-float))
  88           (go label120)
  89          label53
  90           (let ((%copy-c
  91                  (f2cl-lib:make-compatible-seq (array double-float (*))
  92                                                c
  93                                                (array f2cl-lib:complex16 (*)))))
  94             (f2cl-lib:f2cl-copy-seq %copy-c c double-float f2cl-lib:complex16)
  95             (cmf3kb lot ido l1 na %copy-c jump inc ch 1 lot
  96              (f2cl-lib:array-slice wa-%data%
  97                                    double-float
  98                                    (iw)
  99                                    ((1 *))
 100                                    wa-%offset%))
 101             (f2cl-lib:f2cl-copy-seq c %copy-c f2cl-lib:complex16 double-float))
 102           (go label120)
 103          label63
 104           (let ((%copy-c
 105                  (f2cl-lib:make-compatible-seq (array double-float (*))
 106                                                c
 107                                                (array f2cl-lib:complex16 (*)))))
 108             (f2cl-lib:f2cl-copy-seq %copy-c c double-float f2cl-lib:complex16)
 109             (cmf3kb lot ido l1 na ch 1 lot %copy-c jump inc
 110              (f2cl-lib:array-slice wa-%data%
 111                                    double-float
 112                                    (iw)
 113                                    ((1 *))
 114                                    wa-%offset%))
 115             (f2cl-lib:f2cl-copy-seq c %copy-c f2cl-lib:complex16 double-float))
 116           (go label120)
 117          label54
 118           (let ((%copy-c
 119                  (f2cl-lib:make-compatible-seq (array double-float (*))
 120                                                c
 121                                                (array f2cl-lib:complex16 (*)))))
 122             (f2cl-lib:f2cl-copy-seq %copy-c c double-float f2cl-lib:complex16)
 123             (cmf4kb lot ido l1 na %copy-c jump inc ch 1 lot
 124              (f2cl-lib:array-slice wa-%data%
 125                                    double-float
 126                                    (iw)
 127                                    ((1 *))
 128                                    wa-%offset%))
 129             (f2cl-lib:f2cl-copy-seq c %copy-c f2cl-lib:complex16 double-float))
 130           (go label120)
 131          label64
 132           (let ((%copy-c
 133                  (f2cl-lib:make-compatible-seq (array double-float (*))
 134                                                c
 135                                                (array f2cl-lib:complex16 (*)))))
 136             (f2cl-lib:f2cl-copy-seq %copy-c c double-float f2cl-lib:complex16)
 137             (cmf4kb lot ido l1 na ch 1 lot %copy-c jump inc
 138              (f2cl-lib:array-slice wa-%data%
 139                                    double-float
 140                                    (iw)
 141                                    ((1 *))
 142                                    wa-%offset%))
 143             (f2cl-lib:f2cl-copy-seq c %copy-c f2cl-lib:complex16 double-float))
 144           (go label120)
 145          label55
 146           (let ((%copy-c
 147                  (f2cl-lib:make-compatible-seq (array double-float (*))
 148                                                c
 149                                                (array f2cl-lib:complex16 (*)))))
 150             (f2cl-lib:f2cl-copy-seq %copy-c c double-float f2cl-lib:complex16)
 151             (cmf5kb lot ido l1 na %copy-c jump inc ch 1 lot
 152              (f2cl-lib:array-slice wa-%data%
 153                                    double-float
 154                                    (iw)
 155                                    ((1 *))
 156                                    wa-%offset%))
 157             (f2cl-lib:f2cl-copy-seq c %copy-c f2cl-lib:complex16 double-float))
 158           (go label120)
 159          label65
 160           (let ((%copy-c
 161                  (f2cl-lib:make-compatible-seq (array double-float (*))
 162                                                c
 163                                                (array f2cl-lib:complex16 (*)))))
 164             (f2cl-lib:f2cl-copy-seq %copy-c c double-float f2cl-lib:complex16)
 165             (cmf5kb lot ido l1 na ch 1 lot %copy-c jump inc
 166              (f2cl-lib:array-slice wa-%data%
 167                                    double-float
 168                                    (iw)
 169                                    ((1 *))
 170                                    wa-%offset%))
 171             (f2cl-lib:f2cl-copy-seq c %copy-c f2cl-lib:complex16 double-float))
 172           (go label120)
 173          label56
 174           (let ((%copy-c
 175                  (f2cl-lib:make-compatible-seq (array double-float (*))
 176                                                c
 177                                                (array f2cl-lib:complex16 (*)))))
 178             (f2cl-lib:f2cl-copy-seq %copy-c c double-float f2cl-lib:complex16)
 179             (cmfgkb lot ido ip l1 lid na %copy-c %copy-c jump inc ch ch 1 lot
 180              (f2cl-lib:array-slice wa-%data%
 181                                    double-float
 182                                    (iw)
 183                                    ((1 *))
 184                                    wa-%offset%))
 185             (f2cl-lib:f2cl-copy-seq c %copy-c f2cl-lib:complex16 double-float))
 186           (go label120)
 187          label66
 188           (let ((%copy-c
 189                  (f2cl-lib:make-compatible-seq (array double-float (*))
 190                                                c
 191                                                (array f2cl-lib:complex16 (*)))))
 192             (f2cl-lib:f2cl-copy-seq %copy-c c double-float f2cl-lib:complex16)
 193             (cmfgkb lot ido ip l1 lid na ch ch 1 lot %copy-c %copy-c jump inc
 194              (f2cl-lib:array-slice wa-%data%
 195                                    double-float
 196                                    (iw)
 197                                    ((1 *))
 198                                    wa-%offset%))
 199             (f2cl-lib:f2cl-copy-seq c %copy-c f2cl-lib:complex16 double-float))
 200          label120
 201           (setf l1 l2)
 202           (setf iw
 203                   (f2cl-lib:int-add iw
 204                                     (f2cl-lib:int-mul (f2cl-lib:int-sub ip 1)
 205                                                       (f2cl-lib:int-add ido
 206                                                                         ido))))
 207           (if (<= ip 5) (setf na (f2cl-lib:int-sub 1 na)))
 208          label125))
 209       (go end_label)
 210      end_label
 211       (return (values nil nil nil nil nil nil nil nil nil)))))
 212
 213 (in-package #:cl-user)
 214 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 215 (eval-when (:load-toplevel :compile-toplevel :execute)
 216   (setf (gethash 'fortran-to-lisp::cmfm1b
 217                  fortran-to-lisp::*f2cl-function-info*)
 218           (fortran-to-lisp::make-f2cl-finfo
 219            :arg-types '((fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 220                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 221                         (array fortran-to-lisp::complex16 (*))
 222                         (array double-float (*)) (array double-float (*))
 223                         (double-float) (array double-float (*)))
 224            :return-values '(nil nil nil nil nil nil nil nil nil)
 225            :calls '(fortran-to-lisp::cmfgkb fortran-to-lisp::cmf5kb
 226                     fortran-to-lisp::cmf4kb fortran-to-lisp::cmf3kb
 227                     fortran-to-lisp::cmf2kb))))
 228