← Back to branch summary

~ubuntu-branches/debian/squeeze/maxima/squeeze

« back to all changes in this revision

Viewing changes to src/numerical/slatec/dgamma.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2006-10-18 14:52:42 UTC
  • mto: (1.1.5 upstream)
  • mto: This revision was merged to the branch mainline in revision 4.
  • Revision ID: james.westby@ubuntu.com-20061018145242-vzyrm5hmxr8kiosf
Import upstream version 5.10.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/numerical/slatec/dgamma.lisp
1
 
;;; Compiled by f2cl version 2.0 beta 2002-05-06
 
1
;;; Compiled by f2cl version 2.0 beta Date: 2006/01/31 15:11:05 
 
2
;;; Using Lisp CMU Common Lisp Snapshot 2006-01 (19C)
2
3
;;; 
3
4
;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
4
5
;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
5
6
;;;           (:array-slicing nil) (:declare-common nil)
6
7
;;;           (:float-format double-float))
7
8
 
8
 
(in-package "SLATEC")
 
9
(in-package :slatec)
9
10
 
10
11
 
11
12
(let ((ngam 0)
12
13
      (xmin 0.0)
13
14
      (xmax 0.0)
14
15
      (dxrel 0.0)
15
 
      (gamcs (make-array 42 :element-type 'double-float))
16
 
      (pi_ 3.141592653589793)
 
16
      (gamcs
 
17
       (make-array 42
 
18
                   :element-type 'double-float
 
19
                   :initial-contents '(0.00857119559098933 0.004415381324841007
 
20
                                       0.05685043681599363 -0.00421983539641856
 
21
                                       0.0013268081812124603
 
22
                                       -1.8930245297988805e-4
 
23
                                       3.606925327441245e-5
 
24
                                       -6.056761904460864e-6
 
25
                                       1.0558295463022833e-6
 
26
                                       -1.811967365542384e-7
 
27
                                       3.117724964715322e-8
 
28
                                       -5.354219639019687e-9
 
29
                                       9.193275519859589e-10
 
30
                                       -1.5779412802883398e-10
 
31
                                       2.7079806229349544e-11
 
32
                                       -4.64681865382573e-12
 
33
                                       7.97335019200742e-13
 
34
                                       -1.368078209830916e-13
 
35
                                       2.3473194865638007e-14
 
36
                                       -4.027432614949067e-15
 
37
                                       6.910051747372101e-16
 
38
                                       -1.185584500221993e-16
 
39
                                       2.034148542496374e-17
 
40
                                       -3.490054341717406e-18
 
41
                                       5.987993856485306e-19
 
42
                                       -1.027378057872228e-19
 
43
                                       1.7627028160605298e-20
 
44
                                       -3.024320653735306e-21
 
45
                                       5.188914660218398e-22
 
46
                                       -8.902770842456576e-23
 
47
                                       1.5274740684933426e-23
 
48
                                       -2.620731256187363e-24
 
49
                                       4.496464047830539e-25
 
50
                                       -7.714712731336878e-26
 
51
                                       1.323635453126044e-26
 
52
                                       -2.2709994129429287e-27
 
53
                                       3.8964189980039913e-28
 
54
                                       -6.685198115125953e-29
 
55
                                       1.1469986631400244e-29
 
56
                                       -1.9679385863451348e-30
 
57
                                       3.376448816585338e-31
 
58
                                       -5.793070335782136e-32)))
 
59
      (pi$ 3.141592653589793)
17
60
      (sq2pil 0.9189385332046728)
18
 
      (first nil))
19
 
  (declare (type f2cl-lib:logical first)
 
61
      (first$ nil))
 
62
  (declare (type f2cl-lib:logical first$)
20
63
           (type (simple-array double-float (42)) gamcs)
21
 
           (type double-float sq2pil pi_ dxrel xmax xmin)
 
64
           (type double-float sq2pil pi$ dxrel xmax xmin)
22
65
           (type f2cl-lib:integer4 ngam))
23
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (1) ((1 42))) 0.00857119559098933)
24
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (2) ((1 42))) 0.004415381324841007)
25
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (3) ((1 42))) 0.05685043681599364)
26
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (4) ((1 42))) -0.00421983539641856)
27
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (5) ((1 42))) 0.0013268081812124603)
28
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (6) ((1 42))) -1.8930245297988807e-4)
29
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (7) ((1 42))) 3.606925327441246e-5)
30
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (8) ((1 42))) -6.056761904460864e-6)
31
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (9) ((1 42))) 1.0558295463022833e-6)
32
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (10) ((1 42))) -1.811967365542384e-7)
33
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (11) ((1 42))) 3.117724964715322e-8)
34
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (12) ((1 42))) -5.354219639019687e-9)
35
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (13) ((1 42))) 9.193275519859591e-10)
36
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (14) ((1 42))) -1.57794128028834e-10)
37
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (15) ((1 42))) 2.7079806229349546e-11)
38
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (16) ((1 42))) -4.64681865382573e-12)
39
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (17) ((1 42))) 7.97335019200742e-13)
40
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (18) ((1 42))) -1.368078209830916e-13)
41
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (19) ((1 42))) 2.3473194865638006e-14)
42
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (20) ((1 42))) -4.027432614949067e-15)
43
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (21) ((1 42))) 6.910051747372101e-16)
44
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (22) ((1 42))) -1.185584500221993e-16)
45
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (23) ((1 42))) 2.034148542496374e-17)
46
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (24) ((1 42))) -3.490054341717406e-18)
47
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (25) ((1 42))) 5.987993856485305e-19)
48
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (26) ((1 42))) -1.027378057872228e-19)
49
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (27) ((1 42))) 1.76270281606053e-20)
50
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (28) ((1 42))) -3.0243206537353057e-21)
51
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (29) ((1 42))) 5.188914660218398e-22)
52
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (30) ((1 42))) -8.902770842456577e-23)
53
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (31) ((1 42))) 1.527474068493343e-23)
54
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (32) ((1 42))) -2.620731256187363e-24)
55
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (33) ((1 42))) 4.496464047830538e-25)
56
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (34) ((1 42))) -7.714712731336878e-26)
57
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (35) ((1 42))) 1.3236354531260444e-26)
58
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (36) ((1 42))) -2.2709994129429292e-27)
59
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (37) ((1 42))) 3.896418998003992e-28)
60
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (38) ((1 42))) -6.685198115125953e-29)
61
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (39) ((1 42))) 1.1469986631400242e-29)
62
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (40) ((1 42))) -1.9679385863451343e-30)
63
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (41) ((1 42))) 3.3764488165853374e-31)
64
 
  (f2cl-lib:fset (f2cl-lib:fref gamcs (42) ((1 42))) -5.793070335782136e-32)
65
 
  (setq first f2cl-lib:%true%)
 
66
  (setq first$ f2cl-lib:%true%)
66
67
  (defun dgamma (x)
67
68
    (declare (type double-float x))
68
 
    (prog ((sinpiy 0.0) (y 0.0) (dgamma 0.0) (i 0) (n 0))
69
 
      (declare (type f2cl-lib:integer4 n i)
 
69
    (prog ((sinpiy 0.0) (y 0.0) (dgamma 0.0) (i 0) (n 0) (abs$ 0.0f0))
 
70
      (declare (type single-float abs$)
 
71
               (type f2cl-lib:integer4 n i)
70
72
               (type double-float dgamma y sinpiy))
71
73
      (cond
72
 
       (first
73
 
        (setf ngam
74
 
                (initds gamcs 42
75
 
                 (* 0.1f0 (f2cl-lib:freal (f2cl-lib:d1mach 3)))))
76
 
        (multiple-value-bind
77
 
            (var-0 var-1)
78
 
            (dgamlm xmin xmax)
79
 
          (declare (ignore))
80
 
          (setf xmin var-0)
81
 
          (setf xmax var-1))
82
 
        (setf dxrel (f2cl-lib:fsqrt (f2cl-lib:d1mach 4)))))
83
 
      (setf first f2cl-lib:%false%)
 
74
        (first$
 
75
         (setf ngam
 
76
                 (initds gamcs 42
 
77
                  (* 0.1f0 (f2cl-lib:freal (f2cl-lib:d1mach 3)))))
 
78
         (multiple-value-bind (var-0 var-1)
 
79
             (dgamlm xmin xmax)
 
80
           (declare (ignore))
 
81
           (setf xmin var-0)
 
82
           (setf xmax var-1))
 
83
         (setf dxrel (f2cl-lib:fsqrt (f2cl-lib:d1mach 4)))))
 
84
      (setf first$ f2cl-lib:%false%)
84
85
      (setf y (coerce (abs x) 'double-float))
85
86
      (if (> y 10.0) (go label50))
86
87
      (setf n (f2cl-lib:int x))
120
121
      (if (< (abs (/ (- x (f2cl-lib:aint (- x 0.5))) x)) dxrel)
121
122
          (xermsg "SLATEC" "DGAMMA"
122
123
           "ANSWER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER" 1 1))
123
 
      (setf sinpiy (sin (* pi_ y)))
 
124
      (setf sinpiy (sin (* pi$ y)))
124
125
      (if (= sinpiy 0.0)
125
126
          (xermsg "SLATEC" "DGAMMA" "X IS A NEGATIVE INTEGER" 4 2))
126
 
      (setf dgamma (/ (- pi_) (* y sinpiy dgamma)))
 
127
      (setf dgamma (/ (- pi$) (* y sinpiy dgamma)))
127
128
      (go end_label)
128
129
     end_label
129
130
      (return (values dgamma nil)))))