share/fftpack5/lisp/rfftf1.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 rfftf1 (n in c ch wa fac)
  21   (declare (type (array double-float (*)) fac)
  22            (type (array double-float (*)) wa ch c)
  23            (type (f2cl-lib:integer4) in n))
  24   (f2cl-lib:with-multi-array-data
  25       ((c double-float c-%data% c-%offset%)
  26        (ch double-float ch-%data% ch-%offset%)
  27        (wa double-float wa-%data% wa-%offset%)
  28        (fac double-float fac-%data% fac-%offset%))
  29     (prog ((j 0) (nl 0) (modn 0) (tsnm 0.0d0) (tsn 0.0d0) (sn 0.0d0) (ix4 0)
  30            (ix3 0) (ix2 0) (idl1 0) (ido 0) (l1 0) (ip 0) (kh 0) (k1 0) (iw 0)
  31            (l2 0) (na 0) (nf 0))
  32       (declare (type (double-float) sn tsn tsnm)
  33                (type (f2cl-lib:integer4) nf na l2 iw k1 kh ip l1 ido idl1 ix2
  34                                          ix3 ix4 modn nl j))
  35       (setf nf
  36               (f2cl-lib:int
  37                (f2cl-lib:fref fac-%data% (2) ((1 15)) fac-%offset%)))
  38       (setf na 1)
  39       (setf l2 n)
  40       (setf iw n)
  41       (f2cl-lib:fdo (k1 1 (f2cl-lib:int-add k1 1))
  42                     ((> k1 nf) nil)
  43         (tagbody
  44           (setf kh (f2cl-lib:int-sub nf k1))
  45           (setf ip
  46                   (f2cl-lib:int
  47                    (f2cl-lib:fref fac-%data%
  48                                   ((f2cl-lib:int-add kh 3))
  49                                   ((1 15))
  50                                   fac-%offset%)))
  51           (setf l1 (the f2cl-lib:integer4 (truncate l2 ip)))
  52           (setf ido (the f2cl-lib:integer4 (truncate n l2)))
  53           (setf idl1 (f2cl-lib:int-mul ido l1))
  54           (setf iw
  55                   (f2cl-lib:int-sub iw
  56                                     (f2cl-lib:int-mul (f2cl-lib:int-sub ip 1)
  57                                                       ido)))
  58           (setf na (f2cl-lib:int-sub 1 na))
  59           (if (/= ip 4) (go label102))
  60           (setf ix2 (f2cl-lib:int-add iw ido))
  61           (setf ix3 (f2cl-lib:int-add ix2 ido))
  62           (if (/= na 0) (go label101))
  63           (r1f4kf ido l1 c in ch 1
  64            (f2cl-lib:array-slice wa-%data%
  65                                  double-float
  66                                  (iw)
  67                                  ((1 n))
  68                                  wa-%offset%)
  69            (f2cl-lib:array-slice wa-%data%
  70                                  double-float
  71                                  (ix2)
  72                                  ((1 n))
  73                                  wa-%offset%)
  74            (f2cl-lib:array-slice wa-%data%
  75                                  double-float
  76                                  (ix3)
  77                                  ((1 n))
  78                                  wa-%offset%))
  79           (go label110)
  80          label101
  81           (r1f4kf ido l1 ch 1 c in
  82            (f2cl-lib:array-slice wa-%data%
  83                                  double-float
  84                                  (iw)
  85                                  ((1 n))
  86                                  wa-%offset%)
  87            (f2cl-lib:array-slice wa-%data%
  88                                  double-float
  89                                  (ix2)
  90                                  ((1 n))
  91                                  wa-%offset%)
  92            (f2cl-lib:array-slice wa-%data%
  93                                  double-float
  94                                  (ix3)
  95                                  ((1 n))
  96                                  wa-%offset%))
  97           (go label110)
  98          label102
  99           (if (/= ip 2) (go label104))
 100           (if (/= na 0) (go label103))
 101           (r1f2kf ido l1 c in ch 1
 102            (f2cl-lib:array-slice wa-%data%
 103                                  double-float
 104                                  (iw)
 105                                  ((1 n))
 106                                  wa-%offset%))
 107           (go label110)
 108          label103
 109           (r1f2kf ido l1 ch 1 c in
 110            (f2cl-lib:array-slice wa-%data%
 111                                  double-float
 112                                  (iw)
 113                                  ((1 n))
 114                                  wa-%offset%))
 115           (go label110)
 116          label104
 117           (if (/= ip 3) (go label106))
 118           (setf ix2 (f2cl-lib:int-add iw ido))
 119           (if (/= na 0) (go label105))
 120           (r1f3kf ido l1 c in ch 1
 121            (f2cl-lib:array-slice wa-%data%
 122                                  double-float
 123                                  (iw)
 124                                  ((1 n))
 125                                  wa-%offset%)
 126            (f2cl-lib:array-slice wa-%data%
 127                                  double-float
 128                                  (ix2)
 129                                  ((1 n))
 130                                  wa-%offset%))
 131           (go label110)
 132          label105
 133           (r1f3kf ido l1 ch 1 c in
 134            (f2cl-lib:array-slice wa-%data%
 135                                  double-float
 136                                  (iw)
 137                                  ((1 n))
 138                                  wa-%offset%)
 139            (f2cl-lib:array-slice wa-%data%
 140                                  double-float
 141                                  (ix2)
 142                                  ((1 n))
 143                                  wa-%offset%))
 144           (go label110)
 145          label106
 146           (if (/= ip 5) (go label108))
 147           (setf ix2 (f2cl-lib:int-add iw ido))
 148           (setf ix3 (f2cl-lib:int-add ix2 ido))
 149           (setf ix4 (f2cl-lib:int-add ix3 ido))
 150           (if (/= na 0) (go label107))
 151           (r1f5kf ido l1 c in ch 1
 152            (f2cl-lib:array-slice wa-%data%
 153                                  double-float
 154                                  (iw)
 155                                  ((1 n))
 156                                  wa-%offset%)
 157            (f2cl-lib:array-slice wa-%data%
 158                                  double-float
 159                                  (ix2)
 160                                  ((1 n))
 161                                  wa-%offset%)
 162            (f2cl-lib:array-slice wa-%data%
 163                                  double-float
 164                                  (ix3)
 165                                  ((1 n))
 166                                  wa-%offset%)
 167            (f2cl-lib:array-slice wa-%data%
 168                                  double-float
 169                                  (ix4)
 170                                  ((1 n))
 171                                  wa-%offset%))
 172           (go label110)
 173          label107
 174           (r1f5kf ido l1 ch 1 c in
 175            (f2cl-lib:array-slice wa-%data%
 176                                  double-float
 177                                  (iw)
 178                                  ((1 n))
 179                                  wa-%offset%)
 180            (f2cl-lib:array-slice wa-%data%
 181                                  double-float
 182                                  (ix2)
 183                                  ((1 n))
 184                                  wa-%offset%)
 185            (f2cl-lib:array-slice wa-%data%
 186                                  double-float
 187                                  (ix3)
 188                                  ((1 n))
 189                                  wa-%offset%)
 190            (f2cl-lib:array-slice wa-%data%
 191                                  double-float
 192                                  (ix4)
 193                                  ((1 n))
 194                                  wa-%offset%))
 195           (go label110)
 196          label108
 197           (if (= ido 1) (setf na (f2cl-lib:int-sub 1 na)))
 198           (if (/= na 0) (go label109))
 199           (r1fgkf ido ip l1 idl1 c c c in ch ch 1
 200            (f2cl-lib:array-slice wa-%data%
 201                                  double-float
 202                                  (iw)
 203                                  ((1 n))
 204                                  wa-%offset%))
 205           (setf na 1)
 206           (go label110)
 207          label109
 208           (r1fgkf ido ip l1 idl1 ch ch ch 1 c c in
 209            (f2cl-lib:array-slice wa-%data%
 210                                  double-float
 211                                  (iw)
 212                                  ((1 n))
 213                                  wa-%offset%))
 214           (setf na 0)
 215          label110
 216           (setf l2 l1)
 217          label111))
 218       (setf sn (/ 1.0d0 n))
 219       (setf tsn (/ 2.0d0 n))
 220       (setf tsnm (- tsn))
 221       (setf modn (mod n 2))
 222       (setf nl (f2cl-lib:int-sub n 2))
 223       (if (/= modn 0) (setf nl (f2cl-lib:int-sub n 1)))
 224       (if (/= na 0) (go label120))
 225       (setf (f2cl-lib:fref c-%data% (1 1) ((1 in) (1 *)) c-%offset%)
 226               (* sn (f2cl-lib:fref ch-%data% (1) ((1 *)) ch-%offset%)))
 227       (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 2))
 228                     ((> j nl) nil)
 229         (tagbody
 230           (setf (f2cl-lib:fref c-%data% (1 j) ((1 in) (1 *)) c-%offset%)
 231                   (* tsn (f2cl-lib:fref ch-%data% (j) ((1 *)) ch-%offset%)))
 232           (setf (f2cl-lib:fref c-%data%
 233                                (1 (f2cl-lib:int-add j 1))
 234                                ((1 in) (1 *))
 235                                c-%offset%)
 236                   (* tsnm
 237                      (f2cl-lib:fref ch-%data%
 238                                     ((f2cl-lib:int-add j 1))
 239                                     ((1 *))
 240                                     ch-%offset%)))
 241          label118))
 242       (if (/= modn 0) (go end_label))
 243       (setf (f2cl-lib:fref c-%data% (1 n) ((1 in) (1 *)) c-%offset%)
 244               (* sn (f2cl-lib:fref ch-%data% (n) ((1 *)) ch-%offset%)))
 245       (go end_label)
 246      label120
 247       (setf (f2cl-lib:fref c-%data% (1 1) ((1 in) (1 *)) c-%offset%)
 248               (* sn (f2cl-lib:fref c-%data% (1 1) ((1 in) (1 *)) c-%offset%)))
 249       (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 2))
 250                     ((> j nl) nil)
 251         (tagbody
 252           (setf (f2cl-lib:fref c-%data% (1 j) ((1 in) (1 *)) c-%offset%)
 253                   (* tsn
 254                      (f2cl-lib:fref c-%data% (1 j) ((1 in) (1 *)) c-%offset%)))
 255           (setf (f2cl-lib:fref c-%data%
 256                                (1 (f2cl-lib:int-add j 1))
 257                                ((1 in) (1 *))
 258                                c-%offset%)
 259                   (* tsnm
 260                      (f2cl-lib:fref c-%data%
 261                                     (1 (f2cl-lib:int-add j 1))
 262                                     ((1 in) (1 *))
 263                                     c-%offset%)))
 264          label122))
 265       (if (/= modn 0) (go end_label))
 266       (setf (f2cl-lib:fref c-%data% (1 n) ((1 in) (1 *)) c-%offset%)
 267               (* sn (f2cl-lib:fref c-%data% (1 n) ((1 in) (1 *)) c-%offset%)))
 268       (go end_label)
 269      end_label
 270       (return (values nil nil nil nil nil nil)))))
 271
 272 (in-package #:cl-user)
 273 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 274 (eval-when (:load-toplevel :compile-toplevel :execute)
 275   (setf (gethash 'fortran-to-lisp::rfftf1
 276                  fortran-to-lisp::*f2cl-function-info*)
 277           (fortran-to-lisp::make-f2cl-finfo
 278            :arg-types '((fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 279                         (array double-float (*)) (array double-float (*))
 280                         (array double-float (*)) (array double-float (*)))
 281            :return-values '(nil nil nil nil nil nil)
 282            :calls '(fortran-to-lisp::r1fgkf fortran-to-lisp::r1f5kf
 283                     fortran-to-lisp::r1f3kf fortran-to-lisp::r1f2kf
 284                     fortran-to-lisp::r1f4kf))))
 285