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