home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / numerical / slatec / dbsk1e.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  9.0 KB  |  154 lines
  1. ;;; Compiled by f2cl version 2.0 beta 2002-05-06
  2. ;;; 
  3. ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  4. ;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
  5. ;;;           (:array-slicing nil) (:declare-common nil)
  6. ;;;           (:float-format double-float))
  7.  
  8. (in-package "SLATEC")
  9.  
  10.  
  11. (let ((ntk1 0)
  12.       (ntak1 0)
  13.       (ntak12 0)
  14.       (xmin 0.0)
  15.       (xsml 0.0)
  16.       (bk1cs (make-array 16 :element-type 'double-float))
  17.       (ak1cs (make-array 38 :element-type 'double-float))
  18.       (ak12cs (make-array 33 :element-type 'double-float))
  19.       (first nil))
  20.   (declare (type f2cl-lib:logical first)
  21.            (type (simple-array double-float (33)) ak12cs)
  22.            (type (simple-array double-float (38)) ak1cs)
  23.            (type (simple-array double-float (16)) bk1cs)
  24.            (type double-float xsml xmin)
  25.            (type f2cl-lib:integer4 ntak12 ntak1 ntk1))
  26.   (f2cl-lib:fset (f2cl-lib:fref bk1cs (1) ((1 16))) 0.025300227338947774)
  27.   (f2cl-lib:fset (f2cl-lib:fref bk1cs (2) ((1 16))) -0.3531559607765449)
  28.   (f2cl-lib:fset (f2cl-lib:fref bk1cs (3) ((1 16))) -0.12261118082265715)
  29.   (f2cl-lib:fset (f2cl-lib:fref bk1cs (4) ((1 16))) -0.006975723859639864)
  30.   (f2cl-lib:fset (f2cl-lib:fref bk1cs (5) ((1 16))) -1.7302889575130517e-4)
  31.   (f2cl-lib:fset (f2cl-lib:fref bk1cs (6) ((1 16))) -2.4334061415659683e-6)
  32.   (f2cl-lib:fset (f2cl-lib:fref bk1cs (7) ((1 16))) -2.2133876307347258e-8)
  33.   (f2cl-lib:fset (f2cl-lib:fref bk1cs (8) ((1 16))) -1.4114883926335278e-10)
  34.   (f2cl-lib:fset (f2cl-lib:fref bk1cs (9) ((1 16))) -6.666901694199329e-13)
  35.   (f2cl-lib:fset (f2cl-lib:fref bk1cs (10) ((1 16))) -2.427449850519366e-15)
  36.   (f2cl-lib:fset (f2cl-lib:fref bk1cs (11) ((1 16))) -7.023863479386289e-18)
  37.   (f2cl-lib:fset (f2cl-lib:fref bk1cs (12) ((1 16))) -1.6543275155100995e-20)
  38.   (f2cl-lib:fset (f2cl-lib:fref bk1cs (13) ((1 16))) -3.23383474599445e-23)
  39.   (f2cl-lib:fset (f2cl-lib:fref bk1cs (14) ((1 16))) -5.331275052926527e-26)
  40.   (f2cl-lib:fset (f2cl-lib:fref bk1cs (15) ((1 16))) -7.513040716215722e-29)
  41.   (f2cl-lib:fset (f2cl-lib:fref bk1cs (16) ((1 16))) -9.155085717654189e-32)
  42.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (1) ((1 38))) 0.2744313406973883)
  43.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (2) ((1 38))) 0.07571989953199368)
  44.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (3) ((1 38))) -0.0014410515564754062)
  45.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (4) ((1 38))) 6.650116955125748e-5)
  46.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (5) ((1 38))) -4.3699847095201405e-6)
  47.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (6) ((1 38))) 3.5402774997630526e-7)
  48.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (7) ((1 38))) -3.311163779293292e-8)
  49.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (8) ((1 38))) 3.4459775819010535e-9)
  50.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (9) ((1 38))) -3.898932347475427e-10)
  51.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (10) ((1 38))) 4.720819750465836e-11)
  52.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (11) ((1 38))) -6.047835662875356e-12)
  53.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (12) ((1 38))) 8.128494874865874e-13)
  54.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (13) ((1 38))) -1.1386945747147892e-13)
  55.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (14) ((1 38))) 1.6540358408462283e-14)
  56.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (15) ((1 38))) -2.4809025677068847e-15)
  57.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (16) ((1 38))) 3.82923789070241e-16)
  58.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (17) ((1 38))) -6.064734104001241e-17)
  59.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (18) ((1 38))) 9.832425623264862e-18)
  60.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (19) ((1 38))) -1.6284168738284382e-18)
  61.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (20) ((1 38))) 2.7501536496752627e-19)
  62.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (21) ((1 38))) -4.728966646395325e-20)
  63.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (22) ((1 38))) 8.268150002810992e-21)
  64.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (23) ((1 38))) -1.4681405136624953e-21)
  65.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (24) ((1 38))) 2.6447639269208245e-22)
  66.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (25) ((1 38))) -4.8290157564856395e-23)
  67.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (26) ((1 38))) 8.929302074361013e-24)
  68.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (27) ((1 38))) -1.6708397168972516e-24)
  69.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (28) ((1 38))) 3.161645603404069e-25)
  70.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (29) ((1 38))) -6.046205531227498e-26)
  71.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (30) ((1 38))) 1.1678798942042734e-26)
  72.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (31) ((1 38))) -2.2773741582653997e-27)
  73.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (32) ((1 38))) 4.481109730077368e-28)
  74.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (33) ((1 38))) -8.89328847690202e-29)
  75.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (34) ((1 38))) 1.7794680018850273e-29)
  76.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (35) ((1 38))) -3.588455596732909e-30)
  77.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (36) ((1 38))) 7.290629049269427e-31)
  78.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (37) ((1 38))) -1.4918449845546228e-31)
  79.   (f2cl-lib:fset (f2cl-lib:fref ak1cs (38) ((1 38))) 3.073657387293428e-32)
  80.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (1) ((1 33))) 0.06379308343739001)
  81.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (2) ((1 33))) 0.028328878130497212)
  82.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (3) ((1 33))) -2.4753706739052503e-4)
  83.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (4) ((1 33))) 5.77197245160725e-6)
  84.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (5) ((1 33))) -2.0689392195365483e-7)
  85.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (6) ((1 33))) 9.739983441381804e-9)
  86.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (7) ((1 33))) -5.585336140380625e-10)
  87.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (8) ((1 33))) 3.7329966340461856e-11)
  88.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (9) ((1 33))) -2.825051961023225e-12)
  89.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (10) ((1 33))) 2.3720190024841442e-13)
  90.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (11) ((1 33))) -2.176677387991754e-14)
  91.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (12) ((1 33))) 2.1579141616160324e-15)
  92.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (13) ((1 33))) -2.2901969307182696e-16)
  93.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (14) ((1 33))) 2.582885729823275e-17)
  94.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (15) ((1 33))) -3.076752641268463e-18)
  95.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (16) ((1 33))) 3.851487721280492e-19)
  96.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (17) ((1 33))) -5.044794897641529e-20)
  97.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (18) ((1 33))) 6.888673850418544e-21)
  98.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (19) ((1 33))) -9.775041541950117e-22)
  99.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (20) ((1 33))) 1.4374162185238362e-22)
  100.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (21) ((1 33))) -2.1850594973443474e-23)
  101.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (22) ((1 33))) 3.426245621809221e-24)
  102.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (23) ((1 33))) -5.531064394246407e-25)
  103.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (24) ((1 33))) 9.176601505685995e-26)
  104.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (25) ((1 33))) -1.562287203618025e-26)
  105.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (26) ((1 33))) 2.7254193754843337e-27)
  106.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (27) ((1 33))) -4.865674910074828e-28)
  107.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (28) ((1 33))) 8.879388552723503e-29)
  108.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (29) ((1 33))) -1.6545859180392575e-29)
  109.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (30) ((1 33))) 3.1451113213578485e-30)
  110.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (31) ((1 33))) -6.092998312193127e-31)
  111.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (32) ((1 33))) 1.2020219393698159e-31)
  112.   (f2cl-lib:fset (f2cl-lib:fref ak12cs (33) ((1 33))) -2.4129308014594092e-32)
  113.   (setq first f2cl-lib:%true%)
  114.   (defun dbsk1e (x)
  115.     (declare (type double-float x))
  116.     (prog ((y 0.0) (dbsk1e 0.0) (eta 0.0f0))
  117.       (declare (type single-float eta) (type double-float dbsk1e y))
  118.       (cond
  119.        (first (setf eta (* 0.1f0 (f2cl-lib:freal (f2cl-lib:d1mach 3))))
  120.               (setf ntk1 (initds bk1cs 16 eta))
  121.               (setf ntak1 (initds ak1cs 38 eta))
  122.               (setf ntak12 (initds ak12cs 33 eta))
  123.               (setf xmin
  124.                       (exp
  125.                        (+
  126.                         (max (f2cl-lib:flog (f2cl-lib:d1mach 1))
  127.                              (- (f2cl-lib:flog (f2cl-lib:d1mach 2))))
  128.                         0.01)))
  129.               (setf xsml (f2cl-lib:fsqrt (* 4.0 (f2cl-lib:d1mach 3))))))
  130.       (setf first f2cl-lib:%false%)
  131.       (if (<= x 0.0) (xermsg "SLATEC" "DBSK1E" "X IS ZERO OR NEGATIVE" 2 2))
  132.       (if (> x 2.0) (go label20))
  133.       (if (< x xmin) (xermsg "SLATEC" "DBSK1E" "X SO SMALL K1 OVERFLOWS" 3 2))
  134.       (setf y 0.0)
  135.       (if (> x xsml) (setf y (* x x)))
  136.       (setf dbsk1e
  137.               (* (exp x)
  138.                  (+ (* (f2cl-lib:flog (* 0.5 x)) (dbesi1 x))
  139.                     (/ (+ 0.75 (dcsevl (- (* 0.5 y) 1.0) bk1cs ntk1)) x))))
  140.       (go end_label)
  141.      label20
  142.       (if (<= x 8.0)
  143.           (setf dbsk1e
  144.                   (/ (+ 1.25 (dcsevl (/ (- (/ 16.0 x) 5.0) 3.0) ak1cs ntak1))
  145.                      (f2cl-lib:fsqrt x))))
  146.       (if (> x 8.0)
  147.           (setf dbsk1e
  148.                   (/ (+ 1.25 (dcsevl (- (/ 16.0 x) 1.0) ak12cs ntak12))
  149.                      (f2cl-lib:fsqrt x))))
  150.       (go end_label)
  151.      end_label
  152.       (return (values dbsk1e nil)))))
  153.  
  154.