;;; Compiled by f2cl version 2.0 beta 2002-05-06
;;; 
;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
;;;           (:array-slicing nil) (:declare-common nil)
;;;           (:float-format double-float))

(in-package "SLATEC")


(let ((ngam 0)
      (xmin 0.0)
      (xmax 0.0)
      (dxrel 0.0)
      (gamcs (make-array 42 :element-type 'double-float))
      (pi_ 3.141592653589793)
      (sq2pil 0.9189385332046728)
      (first nil))
  (declare (type f2cl-lib:logical first)
           (type (simple-array double-float (42)) gamcs)
           (type double-float sq2pil pi_ dxrel xmax xmin)
           (type f2cl-lib:integer4 ngam))
  (f2cl-lib:fset (f2cl-lib:fref gamcs (1) ((1 42))) 0.00857119559098933)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (2) ((1 42))) 0.004415381324841007)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (3) ((1 42))) 0.05685043681599364)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (4) ((1 42))) -0.00421983539641856)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (5) ((1 42))) 0.0013268081812124603)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (6) ((1 42))) -1.8930245297988807e-4)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (7) ((1 42))) 3.606925327441246e-5)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (8) ((1 42))) -6.056761904460864e-6)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (9) ((1 42))) 1.0558295463022833e-6)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (10) ((1 42))) -1.811967365542384e-7)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (11) ((1 42))) 3.117724964715322e-8)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (12) ((1 42))) -5.354219639019687e-9)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (13) ((1 42))) 9.193275519859591e-10)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (14) ((1 42))) -1.57794128028834e-10)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (15) ((1 42))) 2.7079806229349546e-11)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (16) ((1 42))) -4.64681865382573e-12)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (17) ((1 42))) 7.97335019200742e-13)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (18) ((1 42))) -1.368078209830916e-13)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (19) ((1 42))) 2.3473194865638006e-14)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (20) ((1 42))) -4.027432614949067e-15)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (21) ((1 42))) 6.910051747372101e-16)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (22) ((1 42))) -1.185584500221993e-16)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (23) ((1 42))) 2.034148542496374e-17)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (24) ((1 42))) -3.490054341717406e-18)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (25) ((1 42))) 5.987993856485305e-19)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (26) ((1 42))) -1.027378057872228e-19)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (27) ((1 42))) 1.76270281606053e-20)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (28) ((1 42))) -3.0243206537353057e-21)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (29) ((1 42))) 5.188914660218398e-22)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (30) ((1 42))) -8.902770842456577e-23)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (31) ((1 42))) 1.527474068493343e-23)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (32) ((1 42))) -2.620731256187363e-24)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (33) ((1 42))) 4.496464047830538e-25)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (34) ((1 42))) -7.714712731336878e-26)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (35) ((1 42))) 1.3236354531260444e-26)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (36) ((1 42))) -2.2709994129429292e-27)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (37) ((1 42))) 3.896418998003992e-28)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (38) ((1 42))) -6.685198115125953e-29)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (39) ((1 42))) 1.1469986631400242e-29)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (40) ((1 42))) -1.9679385863451343e-30)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (41) ((1 42))) 3.3764488165853374e-31)
  (f2cl-lib:fset (f2cl-lib:fref gamcs (42) ((1 42))) -5.793070335782136e-32)
  (setq first f2cl-lib:%true%)
  (defun dgamma (x)
    (declare (type double-float x))
    (prog ((sinpiy 0.0) (y 0.0) (dgamma 0.0) (i 0) (n 0))
      (declare (type f2cl-lib:integer4 n i)
               (type double-float dgamma y sinpiy))
      (cond
       (first
        (setf ngam
                (initds gamcs 42
                 (* 0.1f0 (f2cl-lib:freal (f2cl-lib:d1mach 3)))))
        (multiple-value-bind
            (var-0 var-1)
            (dgamlm xmin xmax)
          (declare (ignore))
          (setf xmin var-0)
          (setf xmax var-1))
        (setf dxrel (f2cl-lib:fsqrt (f2cl-lib:d1mach 4)))))
      (setf first f2cl-lib:%false%)
      (setf y (coerce (abs x) 'double-float))
      (if (> y 10.0) (go label50))
      (setf n (f2cl-lib:int x))
      (if (< x 0.0) (setf n (f2cl-lib:int-sub n 1)))
      (setf y (- x n))
      (setf n (f2cl-lib:int-sub n 1))
      (setf dgamma (+ 0.9375 (dcsevl (- (* 2.0 y) 1.0) gamcs ngam)))
      (if (= n 0) (go end_label))
      (if (> n 0) (go label30))
      (setf n (f2cl-lib:int-sub n))
      (if (= x 0.0) (xermsg "SLATEC" "DGAMMA" "X IS 0" 4 2))
      (if (and (< x 0.0f0) (= (- (+ x n) 2) 0.0))
          (xermsg "SLATEC" "DGAMMA" "X IS A NEGATIVE INTEGER" 4 2))
      (if
       (and (< x -0.5) (< (abs (/ (- x (f2cl-lib:aint (- x 0.5))) x)) dxrel))
       (xermsg "SLATEC" "DGAMMA"
        "ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER" 1 1))
      (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
                    ((> i n) nil)
        (tagbody (setf dgamma (/ dgamma (- (+ x i) 1))) label20))
      (go end_label)
     label30
      (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
                    ((> i n) nil)
        (tagbody (setf dgamma (* (+ y i) dgamma)) label40))
      (go end_label)
     label50
      (if (> x xmax) (xermsg "SLATEC" "DGAMMA" "X SO BIG GAMMA OVERFLOWS" 3 2))
      (setf dgamma 0.0)
      (if (< x xmin)
          (xermsg "SLATEC" "DGAMMA" "X SO SMALL GAMMA UNDERFLOWS" 2 1))
      (if (< x xmin) (go end_label))
      (setf dgamma
              (exp
               (+ (- (* (- y 0.5) (f2cl-lib:flog y)) y) sq2pil (d9lgmc y))))
      (if (> x 0.0) (go end_label))
      (if (< (abs (/ (- x (f2cl-lib:aint (- x 0.5))) x)) dxrel)
          (xermsg "SLATEC" "DGAMMA"
           "ANSWER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER" 1 1))
      (setf sinpiy (sin (* pi_ y)))
      (if (= sinpiy 0.0)
          (xermsg "SLATEC" "DGAMMA" "X IS A NEGATIVE INTEGER" 4 2))
      (setf dgamma (/ (- pi_) (* y sinpiy dgamma)))
      (go end_label)
     end_label
      (return (values dgamma nil)))))

