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 / dbsi1e.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  12.3 KB  |  197 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 ((nti1 0)
  12.       (ntai1 0)
  13.       (ntai12 0)
  14.       (xmin 0.0)
  15.       (xsml 0.0)
  16.       (bi1cs (make-array 17 :element-type 'double-float))
  17.       (ai1cs (make-array 46 :element-type 'double-float))
  18.       (ai12cs (make-array 69 :element-type 'double-float))
  19.       (first nil))
  20.   (declare (type f2cl-lib:logical first)
  21.            (type (simple-array double-float (69)) ai12cs)
  22.            (type (simple-array double-float (46)) ai1cs)
  23.            (type (simple-array double-float (17)) bi1cs)
  24.            (type double-float xsml xmin)
  25.            (type f2cl-lib:integer4 ntai12 ntai1 nti1))
  26.   (f2cl-lib:fset (f2cl-lib:fref bi1cs (1) ((1 17))) -0.0019717132610998596)
  27.   (f2cl-lib:fset (f2cl-lib:fref bi1cs (2) ((1 17))) 0.4073488766754648)
  28.   (f2cl-lib:fset (f2cl-lib:fref bi1cs (3) ((1 17))) 0.03483899429995946)
  29.   (f2cl-lib:fset (f2cl-lib:fref bi1cs (4) ((1 17))) 0.0015453945563001237)
  30.   (f2cl-lib:fset (f2cl-lib:fref bi1cs (5) ((1 17))) 4.188852109837779e-5)
  31.   (f2cl-lib:fset (f2cl-lib:fref bi1cs (6) ((1 17))) 7.649026764836211e-7)
  32.   (f2cl-lib:fset (f2cl-lib:fref bi1cs (7) ((1 17))) 1.0042493924741178e-8)
  33.   (f2cl-lib:fset (f2cl-lib:fref bi1cs (8) ((1 17))) 9.932207791923812e-11)
  34.   (f2cl-lib:fset (f2cl-lib:fref bi1cs (9) ((1 17))) 7.663801791844763e-13)
  35.   (f2cl-lib:fset (f2cl-lib:fref bi1cs (10) ((1 17))) 4.741418923816739e-15)
  36.   (f2cl-lib:fset (f2cl-lib:fref bi1cs (11) ((1 17))) 2.4041144040745183e-17)
  37.   (f2cl-lib:fset (f2cl-lib:fref bi1cs (12) ((1 17))) 1.0171505007093713e-19)
  38.   (f2cl-lib:fset (f2cl-lib:fref bi1cs (13) ((1 17))) 3.645093565786695e-22)
  39.   (f2cl-lib:fset (f2cl-lib:fref bi1cs (14) ((1 17))) 1.1205749502562039e-24)
  40.   (f2cl-lib:fset (f2cl-lib:fref bi1cs (15) ((1 17))) 2.987544193446809e-27)
  41.   (f2cl-lib:fset (f2cl-lib:fref bi1cs (16) ((1 17))) 6.973231093919469e-30)
  42.   (f2cl-lib:fset (f2cl-lib:fref bi1cs (17) ((1 17))) 1.43679482206208e-32)
  43.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (1) ((1 46))) -0.02846744181881479)
  44.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (2) ((1 46))) -0.01922953231443221)
  45.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (3) ((1 46))) -6.115185857943789e-4)
  46.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (4) ((1 46))) -2.0699712533502276e-5)
  47.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (5) ((1 46))) 8.585619145810726e-6)
  48.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (6) ((1 46))) 1.049498246711591e-6)
  49.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (7) ((1 46))) -2.918338918447902e-7)
  50.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (8) ((1 46))) -1.5593781466317388e-8)
  51.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (9) ((1 46))) 1.3180123671449445e-8)
  52.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (10) ((1 46))) -1.4484234181830785e-9)
  53.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (11) ((1 46))) -2.9085122439931427e-10)
  54.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (12) ((1 46))) 1.2663889178753823e-10)
  55.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (13) ((1 46))) -1.6649477729192208e-11)
  56.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (14) ((1 46))) -1.666653644609433e-12)
  57.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (15) ((1 46))) 1.2426024142907681e-12)
  58.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (16) ((1 46))) -2.731549379672432e-13)
  59.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (17) ((1 46))) 2.0239478816458037e-14)
  60.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (18) ((1 46))) 7.307950018116883e-15)
  61.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (19) ((1 46))) -3.332905634404675e-15)
  62.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (20) ((1 46))) 7.175346558512954e-16)
  63.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (21) ((1 46))) -6.982530324796256e-17)
  64.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (22) ((1 46))) -1.2999442015627607e-17)
  65.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (23) ((1 46))) 8.120942864242799e-18)
  66.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (24) ((1 46))) -2.1940162074107372e-18)
  67.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (25) ((1 46))) 3.630516170029655e-19)
  68.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (26) ((1 46))) -1.695139772439104e-20)
  69.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (27) ((1 46))) -1.2881848298979076e-20)
  70.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (28) ((1 46))) 5.694428604967052e-21)
  71.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (29) ((1 46))) -1.45959700909048e-21)
  72.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (30) ((1 46))) 2.514546010675717e-22)
  73.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (31) ((1 46))) -1.8447588831391248e-23)
  74.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (32) ((1 46))) -6.339760596227949e-24)
  75.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (33) ((1 46))) 3.461441102031011e-24)
  76.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (34) ((1 46))) -1.0170623353713933e-24)
  77.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (35) ((1 46))) 2.149877147090431e-25)
  78.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (36) ((1 46))) -3.045252425238677e-26)
  79.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (37) ((1 46))) 5.238082144721287e-28)
  80.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (38) ((1 46))) 1.4435831070893826e-27)
  81.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (39) ((1 46))) -6.121302074890043e-28)
  82.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (40) ((1 46))) 1.7000111174678184e-28)
  83.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (41) ((1 46))) -3.596589107984245e-29)
  84.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (42) ((1 46))) 5.448178578948417e-30)
  85.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (43) ((1 46))) -2.731831789689085e-31)
  86.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (44) ((1 46))) -1.858905021708601e-31)
  87.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (45) ((1 46))) 9.212682974513935e-32)
  88.   (f2cl-lib:fset (f2cl-lib:fref ai1cs (46) ((1 46))) -2.813835155653562e-32)
  89.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (1) ((1 69))) 0.028576235018280122)
  90.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (2) ((1 69))) -0.009761097491361469)
  91.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (3) ((1 69))) -1.1058893876262373e-4)
  92.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (4) ((1 69))) -3.882564808877691e-6)
  93.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (5) ((1 69))) -2.512236237870209e-7)
  94.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (6) ((1 69))) -2.63146884688952e-8)
  95.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (7) ((1 69))) -3.835380385964237e-9)
  96.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (8) ((1 69))) -5.589743462196584e-10)
  97.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (9) ((1 69))) -1.8974958123505412e-11)
  98.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (10) ((1 69))) 3.252603583015488e-11)
  99.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (11) ((1 69))) 1.4125807436613785e-11)
  100.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (12) ((1 69))) 2.0356285441470898e-12)
  101.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (13) ((1 69))) -7.198551776245908e-13)
  102.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (14) ((1 69))) -4.0835511110921974e-13)
  103.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (15) ((1 69))) -2.1015418427726643e-14)
  104.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (16) ((1 69))) 4.272440016711952e-14)
  105.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (17) ((1 69))) 1.0420276984128803e-14)
  106.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (18) ((1 69))) -3.8144030724370076e-15)
  107.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (19) ((1 69))) -1.8803547755107825e-15)
  108.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (20) ((1 69))) 3.308202310920929e-16)
  109.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (21) ((1 69))) 2.962628997645951e-16)
  110.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (22) ((1 69))) -3.2095259219934236e-17)
  111.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (23) ((1 69))) -4.650305368489358e-17)
  112.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (24) ((1 69))) 4.4143483230717084e-18)
  113.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (25) ((1 69))) 7.517296310842105e-18)
  114.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (26) ((1 69))) -9.314178867326885e-19)
  115.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (27) ((1 69))) -1.242193275194891e-18)
  116.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (28) ((1 69))) 2.4142767194548487e-19)
  117.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (29) ((1 69))) 2.026944384053285e-19)
  118.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (30) ((1 69))) -6.394267188269097e-20)
  119.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (31) ((1 69))) -3.049812452373096e-20)
  120.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (32) ((1 69))) 1.6128418516514803e-20)
  121.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (33) ((1 69))) 3.5609139643099247e-21)
  122.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (34) ((1 69))) -3.7520179479364385e-21)
  123.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (35) ((1 69))) -5.7870374270748e-23)
  124.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (36) ((1 69))) 7.759997511648161e-22)
  125.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (37) ((1 69))) -1.452790897202233e-22)
  126.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (38) ((1 69))) -1.3182252867390365e-22)
  127.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (39) ((1 69))) 6.11665486290307e-23)
  128.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (40) ((1 69))) 1.3762797624271267e-23)
  129.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (41) ((1 69))) -1.690837689959348e-23)
  130.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (42) ((1 69))) 1.4305960885954327e-24)
  131.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (43) ((1 69))) 3.409557828090594e-24)
  132.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (44) ((1 69))) -1.30945766627076e-24)
  133.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (45) ((1 69))) -3.940706411240257e-25)
  134.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (46) ((1 69))) 4.2771374269808754e-25)
  135.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (47) ((1 69))) -4.424634830982606e-26)
  136.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (48) ((1 69))) -8.734113196230716e-26)
  137.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (49) ((1 69))) 4.0454013356835333e-26)
  138.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (50) ((1 69))) 7.06710065809469e-27)
  139.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (51) ((1 69))) -1.2494633445651053e-26)
  140.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (52) ((1 69))) 2.867392244403438e-27)
  141.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (53) ((1 69))) 2.0442928925042927e-27)
  142.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (54) ((1 69))) -1.5186366338204627e-27)
  143.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (55) ((1 69))) 8.110181098187574e-29)
  144.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (56) ((1 69))) 3.580379354773587e-28)
  145.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (57) ((1 69))) -1.6929290189279028e-28)
  146.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (58) ((1 69))) -2.2229024997024274e-29)
  147.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (59) ((1 69))) 5.42453512714597e-29)
  148.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (60) ((1 69))) -1.7870684015780186e-29)
  149.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (61) ((1 69))) -6.565479068722815e-30)
  150.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (62) ((1 69))) 7.807013165061145e-30)
  151.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (63) ((1 69))) -1.8165952606689797e-30)
  152.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (64) ((1 69))) -1.2877049526600845e-30)
  153.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (65) ((1 69))) 1.1145481729881643e-30)
  154.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (66) ((1 69))) -1.8083431450393372e-31)
  155.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (67) ((1 69))) -2.231677718203772e-31)
  156.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (68) ((1 69))) 1.619029596080342e-31)
  157.   (f2cl-lib:fset (f2cl-lib:fref ai12cs (69) ((1 69))) -1.8340799088049414e-32)
  158.   (setq first f2cl-lib:%true%)
  159.   (defun dbsi1e (x)
  160.     (declare (type double-float x))
  161.     (prog ((y 0.0) (dbsi1e 0.0) (eta 0.0f0))
  162.       (declare (type single-float eta) (type double-float dbsi1e y))
  163.       (cond
  164.        (first (setf eta (* 0.1f0 (f2cl-lib:freal (f2cl-lib:d1mach 3))))
  165.               (setf nti1 (initds bi1cs 17 eta))
  166.               (setf ntai1 (initds ai1cs 46 eta))
  167.               (setf ntai12 (initds ai12cs 69 eta))
  168.               (setf xmin (* 2.0 (f2cl-lib:d1mach 1)))
  169.               (setf xsml (f2cl-lib:fsqrt (* 4.5 (f2cl-lib:d1mach 3))))))
  170.       (setf first f2cl-lib:%false%)
  171.       (setf y (coerce (abs x) 'double-float))
  172.       (if (> y 3.0) (go label20))
  173.       (setf dbsi1e 0.0)
  174.       (if (= y 0.0) (go end_label))
  175.       (if (<= y xmin)
  176.           (xermsg "SLATEC" "DBSI1E" "ABS(X) SO SMALL I1 UNDERFLOWS" 1 1))
  177.       (if (> y xmin) (setf dbsi1e (* 0.5 x)))
  178.       (if (> y xsml)
  179.           (setf dbsi1e
  180.                   (* x (+ 0.875 (dcsevl (- (/ (* y y) 4.5) 1.0) bi1cs nti1)))))
  181.       (setf dbsi1e (* (exp (- y)) dbsi1e))
  182.       (go end_label)
  183.      label20
  184.       (if (<= y 8.0)
  185.           (setf dbsi1e
  186.                   (/ (+ 0.375 (dcsevl (/ (- (/ 48.0 y) 11.0) 5.0) ai1cs ntai1))
  187.                      (f2cl-lib:fsqrt y))))
  188.       (if (> y 8.0)
  189.           (setf dbsi1e
  190.                   (/ (+ 0.375 (dcsevl (- (/ 16.0 y) 1.0) ai12cs ntai12))
  191.                      (f2cl-lib:fsqrt y))))
  192.       (setf dbsi1e (f2cl-lib:sign dbsi1e x))
  193.       (go end_label)
  194.      end_label
  195.       (return (values dbsi1e nil)))))
  196.  
  197.