share/fftpack5/lisp/msntb1.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 msntb1 (lot jump n inc x wsave dsum xh work ier)
  21   (declare (type (double-float) work)
  22            (type (array double-float (*)) xh dsum wsave x)
  23            (type (f2cl-lib:integer4) ier inc n jump lot))
  24   (f2cl-lib:with-multi-array-data
  25       ((x double-float x-%data% x-%offset%)
  26        (wsave double-float wsave-%data% wsave-%offset%)
  27        (dsum double-float dsum-%data% dsum-%offset%)
  28        (xh double-float xh-%data% xh-%offset%))
  29     (prog ((i 0) (fnp1s4 0.0d0) (ier1 0) (lnwk 0) (lnsv 0) (lnxh 0) (modn 0)
  30            (t2 0.0d0) (t1 0.0d0) (m1 0) (kc 0) (k 0) (ns2 0) (np1 0)
  31            (xhold 0.0d0) (m 0) (srt3s2 0.0d0) (lj 0))
  32       (declare (type (double-float) srt3s2 xhold t1 t2 fnp1s4)
  33                (type (f2cl-lib:integer4) lj m np1 ns2 k kc m1 modn lnxh lnsv
  34                                          lnwk ier1 i))
  35       (setf ier 0)
  36       (setf lj
  37               (f2cl-lib:int-add
  38                (f2cl-lib:int-mul (f2cl-lib:int-sub lot 1) jump)
  39                1))
  40       (f2cl-lib:arithmetic-if (f2cl-lib:int-sub n 2)
  41                               (go label200)
  42                               (go label102)
  43                               (go label103))
  44      label102
  45       (setf srt3s2 (/ (f2cl-lib:fsqrt 3.0d0) 2.0d0))
  46       (f2cl-lib:fdo (m 1 (f2cl-lib:int-add m jump))
  47                     ((> m lj) nil)
  48         (tagbody
  49           (setf xhold
  50                   (* srt3s2
  51                      (+
  52                       (f2cl-lib:fref x-%data% (m 1) ((1 inc) (1 *)) x-%offset%)
  53                       (f2cl-lib:fref x-%data%
  54                                      (m 2)
  55                                      ((1 inc) (1 *))
  56                                      x-%offset%))))
  57           (setf (f2cl-lib:fref x-%data% (m 2) ((1 inc) (1 *)) x-%offset%)
  58                   (* srt3s2
  59                      (-
  60                       (f2cl-lib:fref x-%data% (m 1) ((1 inc) (1 *)) x-%offset%)
  61                       (f2cl-lib:fref x-%data%
  62                                      (m 2)
  63                                      ((1 inc) (1 *))
  64                                      x-%offset%))))
  65           (setf (f2cl-lib:fref x-%data% (m 1) ((1 inc) (1 *)) x-%offset%)
  66                   xhold)
  67          label112))
  68       (go label200)
  69      label103
  70       (setf np1 (f2cl-lib:int-add n 1))
  71       (setf ns2 (the f2cl-lib:integer4 (truncate n 2)))
  72       (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
  73                     ((> k ns2) nil)
  74         (tagbody
  75           (setf kc (f2cl-lib:int-sub np1 k))
  76           (setf m1 0)
  77           (f2cl-lib:fdo (m 1 (f2cl-lib:int-add m jump))
  78                         ((> m lj) nil)
  79             (tagbody
  80               (setf m1 (f2cl-lib:int-add m1 1))
  81               (setf t1
  82                       (-
  83                        (f2cl-lib:fref x-%data%
  84                                       (m k)
  85                                       ((1 inc) (1 *))
  86                                       x-%offset%)
  87                        (f2cl-lib:fref x-%data%
  88                                       (m kc)
  89                                       ((1 inc) (1 *))
  90                                       x-%offset%)))
  91               (setf t2
  92                       (*
  93                        (f2cl-lib:fref wsave-%data% (k) ((1 *)) wsave-%offset%)
  94                        (+
  95                         (f2cl-lib:fref x-%data%
  96                                        (m k)
  97                                        ((1 inc) (1 *))
  98                                        x-%offset%)
  99                         (f2cl-lib:fref x-%data%
 100                                        (m kc)
 101                                        ((1 inc) (1 *))
 102                                        x-%offset%))))
 103               (setf (f2cl-lib:fref xh-%data%
 104                                    (m1 (f2cl-lib:int-add k 1))
 105                                    ((1 lot) (1 *))
 106                                    xh-%offset%)
 107                       (+ t1 t2))
 108               (setf (f2cl-lib:fref xh-%data%
 109                                    (m1 (f2cl-lib:int-add kc 1))
 110                                    ((1 lot) (1 *))
 111                                    xh-%offset%)
 112                       (- t2 t1))
 113              label114))
 114          label104))
 115       (setf modn (mod n 2))
 116       (if (= modn 0) (go label124))
 117       (setf m1 0)
 118       (f2cl-lib:fdo (m 1 (f2cl-lib:int-add m jump))
 119                     ((> m lj) nil)
 120         (tagbody
 121           (setf m1 (f2cl-lib:int-add m1 1))
 122           (setf (f2cl-lib:fref xh-%data%
 123                                (m1 (f2cl-lib:int-add ns2 2))
 124                                ((1 lot) (1 *))
 125                                xh-%offset%)
 126                   (* 4.0d0
 127                      (f2cl-lib:fref x-%data%
 128                                     (m (f2cl-lib:int-add ns2 1))
 129                                     ((1 inc) (1 *))
 130                                     x-%offset%)))
 131          label123))
 132      label124
 133       (f2cl-lib:fdo (m 1 (f2cl-lib:int-add m 1))
 134                     ((> m lot) nil)
 135         (tagbody
 136           (setf (f2cl-lib:fref xh-%data% (m 1) ((1 lot) (1 *)) xh-%offset%)
 137                   0.0d0)
 138          label127))
 139       (setf lnxh
 140               (f2cl-lib:int-add (f2cl-lib:int-sub lot 1)
 141                                 (f2cl-lib:int-mul lot (f2cl-lib:int-sub np1 1))
 142                                 1))
 143       (setf lnsv
 144               (f2cl-lib:int-add np1
 145                                 (f2cl-lib:int
 146                                  (/ (f2cl-lib:flog (f2cl-lib:freal np1))
 147                                     (f2cl-lib:flog 2.0d0)))
 148                                 4))
 149       (setf lnwk (f2cl-lib:int-mul lot np1))
 150       (multiple-value-bind
 151             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
 152              var-10)
 153           (rfftmf lot 1 np1 lot xh lnxh
 154            (f2cl-lib:array-slice wsave-%data%
 155                                  double-float
 156                                  ((+ ns2 1))
 157                                  ((1 *))
 158                                  wsave-%offset%)
 159            lnsv
 160            (make-array 1 :element-type (type-of work) :initial-element work)
 161            lnwk ier1)
 162         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
 163                          var-9))
 164         (setf ier1 var-10))
 165       (cond
 166         ((/= ier1 0)
 167          (setf ier 20)
 168          (xerfft "MSNTB1" -5)
 169          (go label200)))
 170       (if (/= (mod np1 2) 0) (go label30))
 171       (f2cl-lib:fdo (m 1 (f2cl-lib:int-add m 1))
 172                     ((> m lot) nil)
 173         (tagbody
 174           (setf (f2cl-lib:fref xh-%data% (m np1) ((1 lot) (1 *)) xh-%offset%)
 175                   (+
 176                    (f2cl-lib:fref xh-%data%
 177                                   (m np1)
 178                                   ((1 lot) (1 *))
 179                                   xh-%offset%)
 180                    (f2cl-lib:fref xh-%data%
 181                                   (m np1)
 182                                   ((1 lot) (1 *))
 183                                   xh-%offset%)))
 184          label20))
 185      label30
 186       (setf fnp1s4 (/ (f2cl-lib:ffloat np1) 4.0d0))
 187       (setf m1 0)
 188       (f2cl-lib:fdo (m 1 (f2cl-lib:int-add m jump))
 189                     ((> m lj) nil)
 190         (tagbody
 191           (setf m1 (f2cl-lib:int-add m1 1))
 192           (setf (f2cl-lib:fref x-%data% (m 1) ((1 inc) (1 *)) x-%offset%)
 193                   (* fnp1s4
 194                      (f2cl-lib:fref xh-%data%
 195                                     (m1 1)
 196                                     ((1 lot) (1 *))
 197                                     xh-%offset%)))
 198           (setf (f2cl-lib:fref dsum-%data% (m1) ((1 *)) dsum-%offset%)
 199                   (f2cl-lib:fref x-%data% (m 1) ((1 inc) (1 *)) x-%offset%))
 200          label125))
 201       (f2cl-lib:fdo (i 3 (f2cl-lib:int-add i 2))
 202                     ((> i n) nil)
 203         (tagbody
 204           (setf m1 0)
 205           (f2cl-lib:fdo (m 1 (f2cl-lib:int-add m jump))
 206                         ((> m lj) nil)
 207             (tagbody
 208               (setf m1 (f2cl-lib:int-add m1 1))
 209               (setf (f2cl-lib:fref x-%data%
 210                                    (m (f2cl-lib:int-sub i 1))
 211                                    ((1 inc) (1 *))
 212                                    x-%offset%)
 213                       (* fnp1s4
 214                          (f2cl-lib:fref xh-%data%
 215                                         (m1 i)
 216                                         ((1 lot) (1 *))
 217                                         xh-%offset%)))
 218               (setf (f2cl-lib:fref dsum-%data% (m1) ((1 *)) dsum-%offset%)
 219                       (+ (f2cl-lib:fref dsum-%data% (m1) ((1 *)) dsum-%offset%)
 220                          (* fnp1s4
 221                             (f2cl-lib:fref xh-%data%
 222                                            (m1 (f2cl-lib:int-sub i 1))
 223                                            ((1 lot) (1 *))
 224                                            xh-%offset%))))
 225               (setf (f2cl-lib:fref x-%data% (m i) ((1 inc) (1 *)) x-%offset%)
 226                       (f2cl-lib:fref dsum-%data% (m1) ((1 *)) dsum-%offset%))
 227              label115))
 228          label105))
 229       (if (/= modn 0) (go label200))
 230       (setf m1 0)
 231       (f2cl-lib:fdo (m 1 (f2cl-lib:int-add m jump))
 232                     ((> m lj) nil)
 233         (tagbody
 234           (setf m1 (f2cl-lib:int-add m1 1))
 235           (setf (f2cl-lib:fref x-%data% (m n) ((1 inc) (1 *)) x-%offset%)
 236                   (* fnp1s4
 237                      (f2cl-lib:fref xh-%data%
 238                                     (m1 (f2cl-lib:int-add n 1))
 239                                     ((1 lot) (1 *))
 240                                     xh-%offset%)))
 241          label116))
 242      label200
 243       (go end_label)
 244      end_label
 245       (return (values nil nil nil nil nil nil nil nil nil ier)))))
 246
 247 (in-package #:cl-user)
 248 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 249 (eval-when (:load-toplevel :compile-toplevel :execute)
 250   (setf (gethash 'fortran-to-lisp::msntb1
 251                  fortran-to-lisp::*f2cl-function-info*)
 252           (fortran-to-lisp::make-f2cl-finfo
 253            :arg-types '((fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 254                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 255                         (array double-float (*)) (array double-float (*))
 256                         (array double-float (*)) (array double-float (*))
 257                         (double-float) (fortran-to-lisp::integer4))
 258            :return-values '(nil nil nil nil nil nil nil nil nil
 259                             fortran-to-lisp::ier)
 260            :calls '(fortran-to-lisp::xerfft fortran-to-lisp::rfftmf))))
 261