src/numerical/slatec/zbesk.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 zbesk (zr zi fnu kode n cyr cyi nz ierr)
  21   (declare (type (simple-array double-float (*)) cyi cyr)
  22            (type (f2cl-lib:integer4) ierr nz n kode)
  23            (type (double-float) fnu zi zr))
  24   (prog ((k 0) (k1 0) (k2 0) (mr 0) (nn 0) (nuf 0) (nw 0) (aa 0.0) (alim 0.0)
  25          (aln 0.0) (arg 0.0) (az 0.0) (dig 0.0) (elim 0.0) (fn 0.0) (fnul 0.0)
  26          (rl 0.0) (r1m5 0.0) (tol 0.0) (ufl 0.0) (bb 0.0))
  27     (declare (type (double-float) bb ufl tol r1m5 rl fnul fn elim dig az arg
  28                                   aln alim aa)
  29              (type (f2cl-lib:integer4) nw nuf nn mr k2 k1 k))
  30     (setf ierr 0)
  31     (setf nz 0)
  32     (if (and (= zi 0.0f0) (= zr 0.0f0)) (setf ierr 1))
  33     (if (< fnu 0.0) (setf ierr 1))
  34     (if (or (< kode 1) (> kode 2)) (setf ierr 1))
  35     (if (< n 1) (setf ierr 1))
  36     (if (/= ierr 0) (go end_label))
  37     (setf nn n)
  38     (setf tol (max (f2cl-lib:d1mach 4) 1.0e-18))
  39     (setf k1 (f2cl-lib:i1mach 15))
  40     (setf k2 (f2cl-lib:i1mach 16))
  41     (setf r1m5 (f2cl-lib:d1mach 5))
  42     (setf k
  43             (min (the f2cl-lib:integer4 (abs k1))
  44                  (the f2cl-lib:integer4 (abs k2))))
  45     (setf elim (* 2.303 (- (* k r1m5) 3.0)))
  46     (setf k1 (f2cl-lib:int-sub (f2cl-lib:i1mach 14) 1))
  47     (setf aa (* r1m5 k1))
  48     (setf dig (min aa 18.0))
  49     (setf aa (* aa 2.303))
  50     (setf alim (+ elim (max (- aa) -41.45)))
  51     (setf fnul (+ 10.0 (* 6.0 (- dig 3.0))))
  52     (setf rl (+ (* 1.2 dig) 3.0))
  53     (setf az (coerce (realpart (zabs zr zi)) 'double-float))
  54     (setf fn (+ fnu (f2cl-lib:int-sub nn 1)))
  55     (setf aa (/ 0.5 tol))
  56     (setf bb (* (f2cl-lib:i1mach 9) 0.5))
  57     (setf aa (min aa bb))
  58     (if (> az aa) (go label260))
  59     (if (> fn aa) (go label260))
  60     (setf aa (f2cl-lib:fsqrt aa))
  61     (if (> az aa) (setf ierr 3))
  62     (if (> fn aa) (setf ierr 3))
  63     (setf ufl (* (f2cl-lib:d1mach 1) 1000.0))
  64     (if (< az ufl) (go label180))
  65     (if (> fnu fnul) (go label80))
  66     (if (<= fn 1.0) (go label60))
  67     (if (> fn 2.0) (go label50))
  68     (if (> az tol) (go label60))
  69     (setf arg (* 0.5 az))
  70     (setf aln (* (- fn) (f2cl-lib:flog arg)))
  71     (if (> aln elim) (go label180))
  72     (go label60)
  73    label50
  74     (multiple-value-bind
  75           (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  76            var-11)
  77         (zuoik zr zi fnu kode 2 nn cyr cyi nuf tol elim alim)
  78       (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-9
  79                        var-10 var-11))
  80       (setf nuf var-8))
  81     (if (< nuf 0) (go label180))
  82     (setf nz (f2cl-lib:int-add nz nuf))
  83     (setf nn (f2cl-lib:int-sub nn nuf))
  84     (if (= nn 0) (go label100))
  85    label60
  86     (if (< zr 0.0) (go label70))
  87     (multiple-value-bind
  88           (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10)
  89         (zbknu zr zi fnu kode nn cyr cyi nw tol elim alim)
  90       (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8 var-9
  91                        var-10))
  92       (setf nw var-7))
  93     (if (< nw 0) (go label200))
  94     (setf nz nw)
  95     (go end_label)
  96    label70
  97     (if (/= nz 0) (go label180))
  98     (setf mr 1)
  99     (if (< zi 0.0) (setf mr -1))
 100     (multiple-value-bind
 101           (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
 102            var-11 var-12 var-13)
 103         (zacon zr zi fnu kode mr nn cyr cyi nw rl fnul tol elim alim)
 104       (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-9
 105                        var-10 var-11 var-12 var-13))
 106       (setf nw var-8))
 107     (if (< nw 0) (go label200))
 108     (setf nz nw)
 109     (go end_label)
 110    label80
 111     (setf mr 0)
 112     (if (>= zr 0.0) (go label90))
 113     (setf mr 1)
 114     (if (< zi 0.0) (setf mr -1))
 115    label90
 116     (multiple-value-bind
 117           (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
 118            var-11)
 119         (zbunk zr zi fnu kode mr nn cyr cyi nw tol elim alim)
 120       (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-9
 121                        var-10 var-11))
 122       (setf nw var-8))
 123     (if (< nw 0) (go label200))
 124     (setf nz (f2cl-lib:int-add nz nw))
 125     (go end_label)
 126    label100
 127     (if (< zr 0.0) (go label180))
 128     (go end_label)
 129    label180
 130     (setf nz 0)
 131     (setf ierr 2)
 132     (go end_label)
 133    label200
 134     (if (= nw -1) (go label180))
 135     (setf nz 0)
 136     (setf ierr 5)
 137     (go end_label)
 138    label260
 139     (setf nz 0)
 140     (setf ierr 4)
 141     (go end_label)
 142    end_label
 143     (return (values nil nil nil nil nil nil nil nz ierr))))
 144
 145 (in-package #:cl-user)
 146 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 147 (eval-when (:load-toplevel :compile-toplevel :execute)
 148   (setf (gethash 'fortran-to-lisp::zbesk fortran-to-lisp::*f2cl-function-info*)
 149           (fortran-to-lisp::make-f2cl-finfo
 150            :arg-types '((double-float) (double-float) (double-float)
 151                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 152                         (simple-array double-float (*))
 153                         (simple-array double-float (*))
 154                         (fortran-to-lisp::integer4)
 155                         (fortran-to-lisp::integer4))
 156            :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::nz
 157                             fortran-to-lisp::ierr)
 158            :calls '(fortran-to-lisp::zbunk fortran-to-lisp::zacon
 159                     fortran-to-lisp::zbknu fortran-to-lisp::zuoik
 160                     fortran-to-lisp::zabs fortran-to-lisp::i1mach
 161                     fortran-to-lisp::d1mach))))
 162