src/numerical/slatec/dbesj1.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 ((ntj1 0)
  21       (xsml 0.0)
  22       (xmin 0.0)
  23       (bj1cs
  24        (make-array 19
  25                    :element-type 'double-float
  26                    :initial-contents '(-0.11726141513332787 -0.2536152183079064
  27                                        0.050127080984469566
  28                                        -0.004631514809625082
  29                                        2.47996229415914e-4
  30                                        -8.678948686278825e-6
  31                                        2.1429391714379368e-7
  32                                        -3.93609307918318e-9
  33                                        5.59118231794688e-11
  34                                        -6.327616404661393e-13
  35                                        5.840991610857247e-15
  36                                        -4.4825338187012584e-17
  37                                        2.9053844926250247e-19
  38                                        -1.6117321978414417e-21
  39                                        7.739478819392746e-24
  40                                        -3.2486937821119987e-26
  41                                        1.2022376772274103e-28
  42                                        -3.952012212651349e-31
  43                                        1.1616780822664534e-33)))
  44       (first$ nil))
  45   (declare (type (f2cl-lib:integer4) ntj1)
  46            (type (double-float) xsml xmin)
  47            (type (simple-array double-float (19)) bj1cs)
  48            (type f2cl-lib:logical first$))
  49   (setq first$ f2cl-lib:%true%)
  50   (defun dbesj1 (x)
  51     (declare (type (double-float) x))
  52     (prog ((ampl 0.0) (theta 0.0) (y 0.0) (dbesj1 0.0))
  53       (declare (type (double-float) dbesj1 y theta ampl))
  54       (cond
  55         (first$
  56          (setf ntj1
  57                  (initds bj1cs 19
  58                   (* 0.1f0 (f2cl-lib:freal (f2cl-lib:d1mach 3)))))
  59          (setf xsml (f2cl-lib:fsqrt (* 8.0 (f2cl-lib:d1mach 3))))
  60          (setf xmin (* 2.0 (f2cl-lib:d1mach 1)))))
  61       (setf first$ f2cl-lib:%false%)
  62       (setf y (abs x))
  63       (if (> y 4.0) (go label20))
  64       (setf dbesj1 0.0)
  65       (if (= y 0.0) (go end_label))
  66       (if (<= y xmin)
  67           (xermsg "SLATEC" "DBESJ1" "ABS(X) SO SMALL J1 UNDERFLOWS" 1 1))
  68       (if (> y xmin) (setf dbesj1 (* 0.5 x)))
  69       (if (> y xsml)
  70           (setf dbesj1
  71                   (* x (+ 0.25 (dcsevl (- (* 0.125 y y) 1.0) bj1cs ntj1)))))
  72       (go end_label)
  73      label20
  74       (multiple-value-bind (var-0 var-1 var-2)
  75           (d9b1mp y ampl theta)
  76         (declare (ignore var-0))
  77         (setf ampl var-1)
  78         (setf theta var-2))
  79       (setf dbesj1 (* (f2cl-lib:sign ampl x) (cos theta)))
  80       (go end_label)
  81      end_label
  82       (return (values dbesj1 nil)))))
  83
  84 (in-package #:cl-user)
  85 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
  86 (eval-when (:load-toplevel :compile-toplevel :execute)
  87   (setf (gethash 'fortran-to-lisp::dbesj1
  88                  fortran-to-lisp::*f2cl-function-info*)
  89           (fortran-to-lisp::make-f2cl-finfo :arg-types '((double-float))
  90                                             :return-values '(nil)
  91                                             :calls '(fortran-to-lisp::d9b1mp
  92                                                      fortran-to-lisp::dcsevl
  93                                                      fortran-to-lisp::xermsg
  94                                                      fortran-to-lisp::initds
  95                                                      fortran-to-lisp::d1mach))))
  96