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