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