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 / dbsk0e.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  8.7 KB  |  146 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 ((ntk0 0)
  12.       (ntak0 0)
  13.       (ntak02 0)
  14.       (xsml 0.0)
  15.       (bk0cs (make-array 16 :element-type 'double-float))
  16.       (ak0cs (make-array 38 :element-type 'double-float))
  17.       (ak02cs (make-array 33 :element-type 'double-float))
  18.       (first nil))
  19.   (declare (type f2cl-lib:logical first)
  20.            (type (simple-array double-float (33)) ak02cs)
  21.            (type (simple-array double-float (38)) ak0cs)
  22.            (type (simple-array double-float (16)) bk0cs)
  23.            (type double-float xsml)
  24.            (type f2cl-lib:integer4 ntak02 ntak0 ntk0))
  25.   (f2cl-lib:fset (f2cl-lib:fref bk0cs (1) ((1 16))) -0.03532739323390277)
  26.   (f2cl-lib:fset (f2cl-lib:fref bk0cs (2) ((1 16))) 0.3442898999246285)
  27.   (f2cl-lib:fset (f2cl-lib:fref bk0cs (3) ((1 16))) 0.0359799365153615)
  28.   (f2cl-lib:fset (f2cl-lib:fref bk0cs (4) ((1 16))) 0.001264615411446926)
  29.   (f2cl-lib:fset (f2cl-lib:fref bk0cs (5) ((1 16))) 2.286212103119452e-5)
  30.   (f2cl-lib:fset (f2cl-lib:fref bk0cs (6) ((1 16))) 2.5347910790261496e-7)
  31.   (f2cl-lib:fset (f2cl-lib:fref bk0cs (7) ((1 16))) 1.9045163772202092e-9)
  32.   (f2cl-lib:fset (f2cl-lib:fref bk0cs (8) ((1 16))) 1.0349695257633626e-11)
  33.   (f2cl-lib:fset (f2cl-lib:fref bk0cs (9) ((1 16))) 4.2598161427910824e-14)
  34.   (f2cl-lib:fset (f2cl-lib:fref bk0cs (10) ((1 16))) 1.3744654358807512e-16)
  35.   (f2cl-lib:fset (f2cl-lib:fref bk0cs (11) ((1 16))) 3.570896528508374e-19)
  36.   (f2cl-lib:fset (f2cl-lib:fref bk0cs (12) ((1 16))) 7.631643660116437e-22)
  37.   (f2cl-lib:fset (f2cl-lib:fref bk0cs (13) ((1 16))) 1.3654249884407815e-24)
  38.   (f2cl-lib:fset (f2cl-lib:fref bk0cs (14) ((1 16))) 2.0752752669066685e-27)
  39.   (f2cl-lib:fset (f2cl-lib:fref bk0cs (15) ((1 16))) 2.7128142180729853e-30)
  40.   (f2cl-lib:fset (f2cl-lib:fref bk0cs (16) ((1 16))) 3.082593887914667e-33)
  41.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (1) ((1 38))) -0.07643947903327941)
  42.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (2) ((1 38))) -0.022356526056998192)
  43.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (3) ((1 38))) 7.734181154693858e-4)
  44.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (4) ((1 38))) -4.281006688886099e-5)
  45.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (5) ((1 38))) 3.0817001738629746e-6)
  46.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (6) ((1 38))) -2.639367222009664e-7)
  47.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (7) ((1 38))) 2.5637130364034694e-8)
  48.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (8) ((1 38))) -2.742705549900201e-9)
  49.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (9) ((1 38))) 3.1694296580975e-10)
  50.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (10) ((1 38))) -3.902353286962184e-11)
  51.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (11) ((1 38))) 5.068040698188575e-12)
  52.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (12) ((1 38))) -6.889574741007871e-13)
  53.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (13) ((1 38))) 9.744978497825918e-14)
  54.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (14) ((1 38))) -1.4273328418845485e-14)
  55.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (15) ((1 38))) 2.156412571021463e-15)
  56.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (16) ((1 38))) -3.349654255149563e-16)
  57.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (17) ((1 38))) 5.335260216952911e-17)
  58.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (18) ((1 38))) -8.693669980890755e-18)
  59.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (19) ((1 38))) 1.4464043478622124e-18)
  60.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (20) ((1 38))) -2.4528898255001294e-19)
  61.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (21) ((1 38))) 4.2337545262321713e-20)
  62.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (22) ((1 38))) -7.427946526454463e-21)
  63.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (23) ((1 38))) 1.3231505293926665e-21)
  64.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (24) ((1 38))) -2.3905871647396496e-22)
  65.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (25) ((1 38))) 4.376827585923227e-23)
  66.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (26) ((1 38))) -8.113700607345117e-24)
  67.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (27) ((1 38))) 1.5218199138321725e-24)
  68.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (28) ((1 38))) -2.8860419414833977e-25)
  69.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (29) ((1 38))) 5.530620667054719e-26)
  70.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (30) ((1 38))) -1.0703773292498989e-26)
  71.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (31) ((1 38))) 2.0910868931423843e-27)
  72.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (32) ((1 38))) -4.121713723646204e-28)
  73.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (33) ((1 38))) 8.193483971121308e-29)
  74.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (34) ((1 38))) -1.6420002754592977e-29)
  75.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (35) ((1 38))) 3.3161432814802266e-30)
  76.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (36) ((1 38))) -6.746863644145296e-31)
  77.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (37) ((1 38))) 1.382429146318425e-31)
  78.   (f2cl-lib:fset (f2cl-lib:fref ak0cs (38) ((1 38))) -2.8518741673598325e-32)
  79.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (1) ((1 33))) -0.012018698263075923)
  80.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (2) ((1 33))) -0.009174852691025696)
  81.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (3) ((1 33))) 1.4445509317750058e-4)
  82.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (4) ((1 33))) -4.0136141754357096e-6)
  83.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (5) ((1 33))) 1.5678318108523104e-7)
  84.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (6) ((1 33))) -7.770110438521739e-9)
  85.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (7) ((1 33))) 4.611182576179717e-10)
  86.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (8) ((1 33))) -3.158592997860566e-11)
  87.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (9) ((1 33))) 2.4350180393650409e-12)
  88.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (10) ((1 33))) -2.0743313873983477e-13)
  89.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (11) ((1 33))) 1.925787280589917e-14)
  90.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (12) ((1 33))) -1.927554805838956e-15)
  91.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (13) ((1 33))) 2.0621980291978187e-16)
  92.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (14) ((1 33))) -2.3416851175792425e-17)
  93.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (15) ((1 33))) 2.805902810643042e-18)
  94.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (16) ((1 33))) -3.5305076311618083e-19)
  95.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (17) ((1 33))) 4.645295422935108e-20)
  96.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (18) ((1 33))) -6.368625941344266e-21)
  97.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (19) ((1 33))) 9.069521310986515e-22)
  98.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (20) ((1 33))) -1.3379747854236906e-22)
  99.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (21) ((1 33))) 2.0398360218599526e-23)
  100.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (22) ((1 33))) -3.20702748136784e-24)
  101.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (23) ((1 33))) 5.189744413662308e-25)
  102.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (24) ((1 33))) -8.629501497540571e-26)
  103.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (25) ((1 33))) 1.47216118310256e-26)
  104.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (26) ((1 33))) -2.573069023867011e-27)
  105.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (27) ((1 33))) 4.601774086643517e-28)
  106.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (28) ((1 33))) -8.411555324201094e-29)
  107.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (29) ((1 33))) 1.569806306635369e-29)
  108.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (30) ((1 33))) -2.988226453005758e-30)
  109.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (31) ((1 33))) 5.796831375216838e-31)
  110.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (32) ((1 33))) -1.1450359943476814e-31)
  111.   (f2cl-lib:fset (f2cl-lib:fref ak02cs (33) ((1 33))) 2.301266594249683e-32)
  112.   (setq first f2cl-lib:%true%)
  113.   (defun dbsk0e (x)
  114.     (declare (type double-float x))
  115.     (prog ((y 0.0) (dbsk0e 0.0) (eta 0.0f0))
  116.       (declare (type single-float eta) (type double-float dbsk0e y))
  117.       (cond
  118.        (first (setf eta (* 0.1f0 (f2cl-lib:freal (f2cl-lib:d1mach 3))))
  119.               (setf ntk0 (initds bk0cs 16 eta))
  120.               (setf ntak0 (initds ak0cs 38 eta))
  121.               (setf ntak02 (initds ak02cs 33 eta))
  122.               (setf xsml (f2cl-lib:fsqrt (* 4.0 (f2cl-lib:d1mach 3))))))
  123.       (setf first f2cl-lib:%false%)
  124.       (if (<= x 0.0) (xermsg "SLATEC" "DBSK0E" "X IS ZERO OR NEGATIVE" 2 2))
  125.       (if (> x 2.0) (go label20))
  126.       (setf y 0.0)
  127.       (if (> x xsml) (setf y (* x x)))
  128.       (setf dbsk0e
  129.               (* (exp x)
  130.                  (+ (- (* (- (f2cl-lib:flog (* 0.5 x))) (dbesi0 x)) 0.25)
  131.                     (dcsevl (- (* 0.5 y) 1.0) bk0cs ntk0))))
  132.       (go end_label)
  133.      label20
  134.       (if (<= x 8.0)
  135.           (setf dbsk0e
  136.                   (/ (+ 1.25 (dcsevl (/ (- (/ 16.0 x) 5.0) 3.0) ak0cs ntak0))
  137.                      (f2cl-lib:fsqrt x))))
  138.       (if (> x 8.0)
  139.           (setf dbsk0e
  140.                   (/ (+ 1.25 (dcsevl (- (/ 16.0 x) 1.0) ak02cs ntak02))
  141.                      (f2cl-lib:fsqrt x))))
  142.       (go end_label)
  143.      end_label
  144.       (return (values dbsk0e nil)))))
  145.  
  146.