src/numerical/slatec/zwrsk.lisp

   1 ;;; Compiled by f2cl version:
   2 ;;; ("f2cl1.l,v 46c1f6a93b0d 2012/05/03 04:40:28 toy $"
   3 ;;;  "f2cl2.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
   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 46c1f6a93b0d 2012/05/03 04:40:28 toy $"
   7 ;;;  "f2cl6.l,v 1d5cbacbb977 2008/08/24 00:56:27 rtoy $"
   8 ;;;  "macros.l,v fceac530ef0c 2011/11/26 04:02:26 toy $")
   9
  10 ;;; Using Lisp CMU Common Lisp snapshot-2012-04 (20C Unicode)
  11 ;;;
  12 ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  13 ;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
  14 ;;;           (:array-slicing nil) (:declare-common nil)
  15 ;;;           (:float-format double-float))
  16
  17 (in-package :slatec)
  18
  19
  20 (defun zwrsk (zrr zri fnu kode n yr yi nz cwr cwi tol elim alim)
  21   (declare (type (simple-array double-float (*)) cwi cwr)
  22            (type (simple-array double-float (*)) yi yr)
  23            (type (f2cl-lib:integer4) nz n kode)
  24            (type (double-float) alim elim tol fnu zri zrr))
  25   (prog ((i 0) (nw 0) (act 0.0) (acw 0.0) (ascle 0.0) (cinui 0.0) (cinur 0.0)
  26          (csclr 0.0) (cti 0.0) (ctr 0.0) (c1i 0.0) (c1r 0.0) (c2i 0.0)
  27          (c2r 0.0) (pti 0.0) (ptr 0.0) (ract 0.0) (sti 0.0) (str 0.0))
  28     (declare (type (double-float) str sti ract ptr pti c2r c2i c1r c1i ctr cti
  29                                   csclr cinur cinui ascle acw act)
  30              (type (f2cl-lib:integer4) nw i))
  31     (setf nz 0)
  32     (multiple-value-bind
  33           (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10)
  34         (zbknu zrr zri fnu kode 2 cwr cwi nw tol elim alim)
  35       (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8 var-9
  36                        var-10))
  37       (setf nw var-7))
  38     (if (/= nw 0) (go label50))
  39     (zrati zrr zri fnu n yr yi tol)
  40     (setf cinur 1.0)
  41     (setf cinui 0.0)
  42     (if (= kode 1) (go label10))
  43     (setf cinur (cos zri))
  44     (setf cinui (sin zri))
  45    label10
  46     (setf acw
  47             (coerce
  48              (realpart
  49               (zabs (f2cl-lib:fref cwr (2) ((1 2)))
  50                (f2cl-lib:fref cwi (2) ((1 2)))))
  51              'double-float))
  52     (setf ascle (/ (* 1000.0 (f2cl-lib:d1mach 1)) tol))
  53     (setf csclr 1.0)
  54     (if (> acw ascle) (go label20))
  55     (setf csclr (/ 1.0 tol))
  56     (go label30)
  57    label20
  58     (setf ascle (/ 1.0 ascle))
  59     (if (< acw ascle) (go label30))
  60     (setf csclr tol)
  61    label30
  62     (setf c1r (* (f2cl-lib:fref cwr (1) ((1 2))) csclr))
  63     (setf c1i (* (f2cl-lib:fref cwi (1) ((1 2))) csclr))
  64     (setf c2r (* (f2cl-lib:fref cwr (2) ((1 2))) csclr))
  65     (setf c2i (* (f2cl-lib:fref cwi (2) ((1 2))) csclr))
  66     (setf str (f2cl-lib:fref yr (1) ((1 n))))
  67     (setf sti (f2cl-lib:fref yi (1) ((1 n))))
  68     (setf ptr (- (* str c1r) (* sti c1i)))
  69     (setf pti (+ (* str c1i) (* sti c1r)))
  70     (setf ptr (+ ptr c2r))
  71     (setf pti (+ pti c2i))
  72     (setf ctr (- (* zrr ptr) (* zri pti)))
  73     (setf cti (+ (* zrr pti) (* zri ptr)))
  74     (setf act (coerce (realpart (zabs ctr cti)) 'double-float))
  75     (setf ract (/ 1.0 act))
  76     (setf ctr (* ctr ract))
  77     (setf cti (* (- cti) ract))
  78     (setf ptr (* cinur ract))
  79     (setf pti (* cinui ract))
  80     (setf cinur (- (* ptr ctr) (* pti cti)))
  81     (setf cinui (+ (* ptr cti) (* pti ctr)))
  82     (setf (f2cl-lib:fref yr (1) ((1 n))) (* cinur csclr))
  83     (setf (f2cl-lib:fref yi (1) ((1 n))) (* cinui csclr))
  84     (if (= n 1) (go end_label))
  85     (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1))
  86                   ((> i n) nil)
  87       (tagbody
  88         (setf ptr (- (* str cinur) (* sti cinui)))
  89         (setf cinui (+ (* str cinui) (* sti cinur)))
  90         (setf cinur ptr)
  91         (setf str (f2cl-lib:fref yr (i) ((1 n))))
  92         (setf sti (f2cl-lib:fref yi (i) ((1 n))))
  93         (setf (f2cl-lib:fref yr (i) ((1 n))) (* cinur csclr))
  94         (setf (f2cl-lib:fref yi (i) ((1 n))) (* cinui csclr))
  95        label40))
  96     (go end_label)
  97    label50
  98     (setf nz -1)
  99     (if (= nw -2) (setf nz -2))
 100     (go end_label)
 101    end_label
 102     (return (values nil nil nil nil nil nil nil nz nil nil nil nil nil))))
 103
 104 (in-package #:cl-user)
 105 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 106 (eval-when (:load-toplevel :compile-toplevel :execute)
 107   (setf (gethash 'fortran-to-lisp::zwrsk fortran-to-lisp::*f2cl-function-info*)
 108           (fortran-to-lisp::make-f2cl-finfo
 109            :arg-types '((double-float) (double-float) (double-float)
 110                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 111                         (simple-array double-float (*))
 112                         (simple-array double-float (*))
 113                         (fortran-to-lisp::integer4)
 114                         (simple-array double-float (*))
 115                         (simple-array double-float (*)) (double-float)
 116                         (double-float) (double-float))
 117            :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::nz nil
 118                             nil nil nil nil)
 119            :calls '(fortran-to-lisp::d1mach fortran-to-lisp::zabs
 120                     fortran-to-lisp::zrati fortran-to-lisp::zbknu))))
 121