src/numerical/slatec/dbesi1.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 ((nti1 0)
  21       (xmin 0.0)
  22       (xsml 0.0)
  23       (xmax 0.0)
  24       (bi1cs
  25        (make-array 17
  26                    :element-type 'double-float
  27                    :initial-contents '(-0.0019717132610998596
  28                                        0.4073488766754648 0.03483899429995946
  29                                        0.0015453945563001237
  30                                        4.188852109837778e-5
  31                                        7.649026764836211e-7
  32                                        1.0042493924741179e-8
  33                                        9.93220779192381e-11
  34                                        7.663801791844764e-13
  35                                        4.741418923816739e-15
  36                                        2.404114404074518e-17
  37                                        1.0171505007093713e-19
  38                                        3.6450935657866947e-22
  39                                        1.1205749502562039e-24
  40                                        2.987544193446809e-27
  41                                        6.973231093919471e-30
  42                                        1.43679482206208e-32)))
  43       (first$ nil))
  44   (declare (type (f2cl-lib:integer4) nti1)
  45            (type (double-float) xmin xsml xmax)
  46            (type (simple-array double-float (17)) bi1cs)
  47            (type f2cl-lib:logical first$))
  48   (setq first$ f2cl-lib:%true%)
  49   (defun dbesi1 (x)
  50     (declare (type (double-float) x))
  51     (prog ((y 0.0) (dbesi1 0.0))
  52       (declare (type (double-float) dbesi1 y))
  53       (cond
  54         (first$
  55          (setf nti1
  56                  (initds bi1cs 17
  57                   (* 0.1f0 (f2cl-lib:freal (f2cl-lib:d1mach 3)))))
  58          (setf xmin (* 2.0 (f2cl-lib:d1mach 1)))
  59          (setf xsml (f2cl-lib:fsqrt (* 4.5 (f2cl-lib:d1mach 3))))
  60          (setf xmax (f2cl-lib:flog (f2cl-lib:d1mach 2)))))
  61       (setf first$ f2cl-lib:%false%)
  62       (setf y (abs x))
  63       (if (> y 3.0) (go label20))
  64       (setf dbesi1 0.0)
  65       (if (= y 0.0) (go end_label))
  66       (if (<= y xmin)
  67           (xermsg "SLATEC" "DBESI1" "ABS(X) SO SMALL I1 UNDERFLOWS" 1 1))
  68       (if (> y xmin) (setf dbesi1 (* 0.5 x)))
  69       (if (> y xsml)
  70           (setf dbesi1
  71                   (* x (+ 0.875 (dcsevl (- (/ (* y y) 4.5) 1.0) bi1cs nti1)))))
  72       (go end_label)
  73      label20
  74       (if (> y xmax)
  75           (xermsg "SLATEC" "DBESI1" "ABS(X) SO BIG I1 OVERFLOWS" 2 2))
  76       (setf dbesi1 (* (exp y) (dbsi1e x)))
  77       (go end_label)
  78      end_label
  79       (return (values dbesi1 nil)))))
  80
  81 (in-package #:cl-user)
  82 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
  83 (eval-when (:load-toplevel :compile-toplevel :execute)
  84   (setf (gethash 'fortran-to-lisp::dbesi1
  85                  fortran-to-lisp::*f2cl-function-info*)
  86           (fortran-to-lisp::make-f2cl-finfo :arg-types '((double-float))
  87                                             :return-values '(nil)
  88                                             :calls '(fortran-to-lisp::dbsi1e
  89                                                      fortran-to-lisp::dcsevl
  90                                                      fortran-to-lisp::xermsg
  91                                                      fortran-to-lisp::initds
  92                                                      fortran-to-lisp::d1mach))))
  93