share/fftpack5/lisp/mrftf1.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 mrftf1 (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 ((j 0) (i 0) (m2 0) (nl 0) (modn 0) (tsnm 0.0d0) (tsn 0.0d0)
  30            (sn 0.0d0) (ix4 0) (ix3 0) (ix2 0) (idl1 0) (ido 0) (l1 0) (ip 0)
  31            (kh 0) (k1 0) (iw 0) (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 m2 i 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           (mradf4 m ido l1 c im in ch 1 m
  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           (mradf4 m ido l1 ch 1 m c im 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           (mradf2 m ido l1 c im in ch 1 m
 102            (f2cl-lib:array-slice wa-%data%
 103                                  double-float
 104                                  (iw)
 105                                  ((1 n))
 106                                  wa-%offset%))
 107           (go label110)
 108          label103
 109           (mradf2 m ido l1 ch 1 m c im 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           (mradf3 m ido l1 c im in ch 1 m
 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           (mradf3 m ido l1 ch 1 m c im 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           (mradf5 m ido l1 c im in ch 1 m
 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           (mradf5 m ido l1 ch 1 m c im 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           (mradfg m ido ip l1 idl1 c c c im in ch ch 1 m
 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           (mradfg m ido ip l1 idl1 ch ch ch 1 m c c im 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 m2 (f2cl-lib:int-sub 1 im))
 226       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 227                     ((> i m) nil)
 228         (tagbody
 229           (setf m2 (f2cl-lib:int-add m2 im))
 230           (setf (f2cl-lib:fref c-%data% (m2 1) ((1 in) (1 *)) c-%offset%)
 231                   (* sn
 232                      (f2cl-lib:fref ch-%data%
 233                                     (i 1)
 234                                     ((1 m) (1 *))
 235                                     ch-%offset%)))
 236          label117))
 237       (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 2))
 238                     ((> j nl) nil)
 239         (tagbody
 240           (setf m2 (f2cl-lib:int-sub 1 im))
 241           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 242                         ((> i m) nil)
 243             (tagbody
 244               (setf m2 (f2cl-lib:int-add m2 im))
 245               (setf (f2cl-lib:fref c-%data% (m2 j) ((1 in) (1 *)) c-%offset%)
 246                       (* tsn
 247                          (f2cl-lib:fref ch-%data%
 248                                         (i j)
 249                                         ((1 m) (1 *))
 250                                         ch-%offset%)))
 251               (setf (f2cl-lib:fref c-%data%
 252                                    (m2 (f2cl-lib:int-add j 1))
 253                                    ((1 in) (1 *))
 254                                    c-%offset%)
 255                       (* tsnm
 256                          (f2cl-lib:fref ch-%data%
 257                                         (i (f2cl-lib:int-add j 1))
 258                                         ((1 m) (1 *))
 259                                         ch-%offset%)))
 260              label118))))
 261      label118
 262       (if (/= modn 0) (go end_label))
 263       (setf m2 (f2cl-lib:int-sub 1 im))
 264       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 265                     ((> i m) nil)
 266         (tagbody
 267           (setf m2 (f2cl-lib:int-add m2 im))
 268           (setf (f2cl-lib:fref c-%data% (m2 n) ((1 in) (1 *)) c-%offset%)
 269                   (* sn
 270                      (f2cl-lib:fref ch-%data%
 271                                     (i n)
 272                                     ((1 m) (1 *))
 273                                     ch-%offset%)))
 274          label119))
 275       (go end_label)
 276      label120
 277       (setf m2 (f2cl-lib:int-sub 1 im))
 278       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 279                     ((> i m) nil)
 280         (tagbody
 281           (setf m2 (f2cl-lib:int-add m2 im))
 282           (setf (f2cl-lib:fref c-%data% (m2 1) ((1 in) (1 *)) c-%offset%)
 283                   (* sn
 284                      (f2cl-lib:fref c-%data%
 285                                     (m2 1)
 286                                     ((1 in) (1 *))
 287                                     c-%offset%)))
 288          label121))
 289       (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 2))
 290                     ((> j nl) nil)
 291         (tagbody
 292           (setf m2 (f2cl-lib:int-sub 1 im))
 293           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 294                         ((> i m) nil)
 295             (tagbody
 296               (setf m2 (f2cl-lib:int-add m2 im))
 297               (setf (f2cl-lib:fref c-%data% (m2 j) ((1 in) (1 *)) c-%offset%)
 298                       (* tsn
 299                          (f2cl-lib:fref c-%data%
 300                                         (m2 j)
 301                                         ((1 in) (1 *))
 302                                         c-%offset%)))
 303               (setf (f2cl-lib:fref c-%data%
 304                                    (m2 (f2cl-lib:int-add j 1))
 305                                    ((1 in) (1 *))
 306                                    c-%offset%)
 307                       (* tsnm
 308                          (f2cl-lib:fref c-%data%
 309                                         (m2 (f2cl-lib:int-add j 1))
 310                                         ((1 in) (1 *))
 311                                         c-%offset%)))
 312              label122))))
 313      label122
 314       (if (/= modn 0) (go end_label))
 315       (setf m2 (f2cl-lib:int-sub 1 im))
 316       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 317                     ((> i m) nil)
 318         (tagbody
 319           (setf m2 (f2cl-lib:int-add m2 im))
 320           (setf (f2cl-lib:fref c-%data% (m2 n) ((1 in) (1 *)) c-%offset%)
 321                   (* sn
 322                      (f2cl-lib:fref c-%data%
 323                                     (m2 n)
 324                                     ((1 in) (1 *))
 325                                     c-%offset%)))
 326          label123))
 327       (go end_label)
 328      end_label
 329       (return (values nil nil nil nil nil nil nil nil)))))
 330
 331 (in-package #:cl-user)
 332 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 333 (eval-when (:load-toplevel :compile-toplevel :execute)
 334   (setf (gethash 'fortran-to-lisp::mrftf1
 335                  fortran-to-lisp::*f2cl-function-info*)
 336           (fortran-to-lisp::make-f2cl-finfo
 337            :arg-types '((fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 338                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 339                         (array double-float (*)) (array double-float (*))
 340                         (array double-float (*)) (array double-float (*)))
 341            :return-values '(nil nil nil nil nil nil nil nil)
 342            :calls '(fortran-to-lisp::mradfg fortran-to-lisp::mradf5
 343                     fortran-to-lisp::mradf3 fortran-to-lisp::mradf2
 344                     fortran-to-lisp::mradf4))))
 345