src/numerical/slatec/zacai.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 (let ((pi$ 3.141592653589793))
  21   (declare (type (double-float) pi$))
  22   (defun zacai (zr zi fnu kode mr n yr yi nz rl tol elim alim)
  23     (declare (type (simple-array double-float (*)) yi yr)
  24              (type (f2cl-lib:integer4) nz n mr kode)
  25              (type (double-float) alim elim tol rl fnu zi zr))
  26     (prog ((cyr (make-array 2 :element-type 'double-float))
  27            (cyi (make-array 2 :element-type 'double-float)) (inu 0) (iuf 0)
  28            (nn 0) (nw 0) (arg 0.0) (ascle 0.0) (az 0.0) (csgnr 0.0) (csgni 0.0)
  29            (cspnr 0.0) (cspni 0.0) (c1r 0.0) (c1i 0.0) (c2r 0.0) (c2i 0.0)
  30            (dfnu 0.0) (fmr 0.0) (sgn 0.0) (yy 0.0) (znr 0.0) (zni 0.0))
  31       (declare (type (simple-array double-float (2)) cyi cyr)
  32                (type (double-float) zni znr yy sgn fmr dfnu c2i c2r c1i c1r
  33                                     cspni cspnr csgni csgnr az ascle arg)
  34                (type (f2cl-lib:integer4) nw nn iuf inu))
  35       (setf nz 0)
  36       (setf znr (- zr))
  37       (setf zni (- zi))
  38       (setf az (coerce (realpart (zabs zr zi)) 'double-float))
  39       (setf nn n)
  40       (setf dfnu (+ fnu (f2cl-lib:int-sub n 1)))
  41       (if (<= az 2.0) (go label10))
  42       (if (> (* az az 0.25) (+ dfnu 1.0)) (go label20))
  43      label10
  44       (multiple-value-bind
  45             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
  46              var-10)
  47           (zseri znr zni fnu kode nn yr yi nw tol elim alim)
  48         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8 var-9
  49                          var-10))
  50         (setf nw var-7))
  51       (go label40)
  52      label20
  53       (if (< az rl) (go label30))
  54       (multiple-value-bind
  55             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  56              var-11)
  57           (zasyi znr zni fnu kode nn yr yi nw rl tol elim alim)
  58         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8 var-9
  59                          var-10 var-11))
  60         (setf nw var-7))
  61       (if (< nw 0) (go label80))
  62       (go label40)
  63      label30
  64       (multiple-value-bind
  65             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)
  66           (zmlri znr zni fnu kode nn yr yi nw tol)
  67         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8))
  68         (setf nw var-7))
  69       (if (< nw 0) (go label80))
  70      label40
  71       (multiple-value-bind
  72             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
  73              var-10)
  74           (zbknu znr zni fnu kode 1 cyr cyi nw tol elim alim)
  75         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8 var-9
  76                          var-10))
  77         (setf nw var-7))
  78       (if (/= nw 0) (go label80))
  79       (setf fmr (coerce (the f2cl-lib:integer4 mr) 'double-float))
  80       (setf sgn (coerce (- (f2cl-lib:dsign pi$ fmr)) 'double-float))
  81       (setf csgnr 0.0)
  82       (setf csgni sgn)
  83       (if (= kode 1) (go label50))
  84       (setf yy (- zni))
  85       (setf csgnr (* (- csgni) (sin yy)))
  86       (setf csgni (* csgni (cos yy)))
  87      label50
  88       (setf inu (f2cl-lib:int fnu))
  89       (setf arg (* (- fnu inu) sgn))
  90       (setf cspnr (cos arg))
  91       (setf cspni (sin arg))
  92       (if (= (mod inu 2) 0) (go label60))
  93       (setf cspnr (- cspnr))
  94       (setf cspni (- cspni))
  95      label60
  96       (setf c1r (f2cl-lib:fref cyr (1) ((1 2))))
  97       (setf c1i (f2cl-lib:fref cyi (1) ((1 2))))
  98       (setf c2r (f2cl-lib:fref yr (1) ((1 n))))
  99       (setf c2i (f2cl-lib:fref yi (1) ((1 n))))
 100       (if (= kode 1) (go label70))
 101       (setf iuf 0)
 102       (setf ascle (/ (* 1000.0 (f2cl-lib:d1mach 1)) tol))
 103       (multiple-value-bind
 104             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9)
 105           (zs1s2 znr zni c1r c1i c2r c2i nw ascle alim iuf)
 106         (declare (ignore var-0 var-1 var-7 var-8))
 107         (setf c1r var-2)
 108         (setf c1i var-3)
 109         (setf c2r var-4)
 110         (setf c2i var-5)
 111         (setf nw var-6)
 112         (setf iuf var-9))
 113       (setf nz (f2cl-lib:int-add nz nw))
 114      label70
 115       (setf (f2cl-lib:fref yr (1) ((1 n)))
 116               (- (+ (- (* cspnr c1r) (* cspni c1i)) (* csgnr c2r))
 117                  (* csgni c2i)))
 118       (setf (f2cl-lib:fref yi (1) ((1 n)))
 119               (+ (* cspnr c1i) (* cspni c1r) (* csgnr c2i) (* csgni c2r)))
 120       (go end_label)
 121      label80
 122       (setf nz -1)
 123       (if (= nw -2) (setf nz -2))
 124       (go end_label)
 125      end_label
 126       (return (values nil nil nil nil nil nil nil nil nz nil nil nil nil)))))
 127
 128 (in-package #:cl-user)
 129 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 130 (eval-when (:load-toplevel :compile-toplevel :execute)
 131   (setf (gethash 'fortran-to-lisp::zacai fortran-to-lisp::*f2cl-function-info*)
 132           (fortran-to-lisp::make-f2cl-finfo
 133            :arg-types '((double-float) (double-float) (double-float)
 134                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 135                         (fortran-to-lisp::integer4)
 136                         (simple-array double-float (*))
 137                         (simple-array double-float (*))
 138                         (fortran-to-lisp::integer4) (double-float)
 139                         (double-float) (double-float) (double-float))
 140            :return-values '(nil nil nil nil nil nil nil nil fortran-to-lisp::nz
 141                             nil nil nil nil)
 142            :calls '(fortran-to-lisp::zs1s2 fortran-to-lisp::d1mach
 143                     fortran-to-lisp::zbknu fortran-to-lisp::zmlri
 144                     fortran-to-lisp::zasyi fortran-to-lisp::zseri
 145                     fortran-to-lisp::zabs))))
 146