#include "fpreproc/library_names.h"
#include "fpreproc/f77_dcomplx.h"
#include "fpreproc/fp_const.h"
*DECK DGAMMA
       FUNCTION DGAMMA (X)
C***BEGIN PROLOGUE  DGAMMA
C***PURPOSE  Compute the complete Gamma function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7A
C***TYPE      REAL*8 (GAMMA-S, DGAMMA-D, CGAMMA-C)
C***KEYWORDS  COMPLETE GAMMA FUNCTION, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DGAMMA(X) calculates the double precision complete Gamma function
C for double precision argument X.
C
C Series for GAM        on the interval  0.          to  1.00000E+00
C                                        with weighted error   5.79E-32
C                                         log weighted error  31.24
C                               significant figures required  30.00
C                                    decimal places required  32.05
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, D9LGMC, DCSEVL, DGAMLM, INITDS, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   890911  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920618  Removed space from variable name.  (RWC, WRB)
C***END PROLOGUE  DGAMMA
C============
C idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER ngam,initds,n,i
C============
      REAL*8 DGAMMA
      REAL*8 X, GAMCS(42), DXREL, PI, SINPIY, SQ2PIL, XMAX,
     1  XMIN, Y, D9LGMC, DCSEVL, D1MACH
      LOGICAL FIRST
C
      SAVE GAMCS, PI, SQ2PIL, NGAM, XMIN, XMAX, DXREL, FIRST
      DATA GAMCS(  1) / +CONST(.8571195590989331421920062399942,-2)/
      DATA GAMCS(  2) / +CONST(.4415381324841006757191315771652,-2)/
      DATA GAMCS(  3) / +CONST(.5685043681599363378632664588789,-1)/
      DATA GAMCS(  4) / -CONST(.4219835396418560501012500186624,-2)/
      DATA GAMCS(  5) / +CONST(.1326808181212460220584006796352,-2)/
      DATA GAMCS(  6) / -CONST(.1893024529798880432523947023886,-3)/
      DATA GAMCS(  7) / +CONST(.3606925327441245256578082217225,-4)/
      DATA GAMCS(  8) / -CONST(.6056761904460864218485548290365,-5)/
      DATA GAMCS(  9) / +CONST(.1055829546302283344731823509093,-5)/
      DATA GAMCS( 10) / -CONST(.1811967365542384048291855891166,-6)/
      DATA GAMCS( 11) / +CONST(.3117724964715322277790254593169,-7)/
      DATA GAMCS( 12) / -CONST(.5354219639019687140874081024347,-8)/
      DATA GAMCS( 13) / +CONST(.9193275519859588946887786825940,-9)/
      DATA GAMCS( 14) / -CONST(.1577941280288339761767423273953,-9)/
      DATA GAMCS( 15) / +CONST(.2707980622934954543266540433089,-10)/
      DATA GAMCS( 16) / -CONST(.4646818653825730144081661058933,-11)/
      DATA GAMCS( 17) / +CONST(.7973350192007419656460767175359,-12)/
      DATA GAMCS( 18) / -CONST(.1368078209830916025799499172309,-12)/
      DATA GAMCS( 19) / +CONST(.2347319486563800657233471771688,-13)/
      DATA GAMCS( 20) / -CONST(.4027432614949066932766570534699,-14)/
      DATA GAMCS( 21) / +CONST(.6910051747372100912138336975257,-15)/
      DATA GAMCS( 22) / -CONST(.1185584500221992907052387126192,-15)/
      DATA GAMCS( 23) / +CONST(.2034148542496373955201026051932,-16)/
      DATA GAMCS( 24) / -CONST(.3490054341717405849274012949108,-17)/
      DATA GAMCS( 25) / +CONST(.5987993856485305567135051066026,-18)/
      DATA GAMCS( 26) / -CONST(.1027378057872228074490069778431,-18)/
      DATA GAMCS( 27) / +CONST(.1762702816060529824942759660748,-19)/
      DATA GAMCS( 28) / -CONST(.3024320653735306260958772112042,-20)/
      DATA GAMCS( 29) / +CONST(.5188914660218397839717833550506,-21)/
      DATA GAMCS( 30) / -CONST(.8902770842456576692449251601066,-22)/
      DATA GAMCS( 31) / +CONST(.1527474068493342602274596891306,-22)/
      DATA GAMCS( 32) / -CONST(.2620731256187362900257328332799,-23)/
      DATA GAMCS( 33) / +CONST(.4496464047830538670331046570666,-24)/
      DATA GAMCS( 34) / -CONST(.7714712731336877911703901525333,-25)/
      DATA GAMCS( 35) / +CONST(.1323635453126044036486572714666,-25)/
      DATA GAMCS( 36) / -CONST(.2270999412942928816702313813333,-26)/
      DATA GAMCS( 37) / +CONST(.3896418998003991449320816639999,-27)/
      DATA GAMCS( 38) / -CONST(.6685198115125953327792127999999,-28)/
      DATA GAMCS( 39) / +CONST(.1146998663140024384347613866666,-28)/
      DATA GAMCS( 40) / -CONST(.1967938586345134677295103999999,-29)/
      DATA GAMCS( 41) / +CONST(.3376448816585338090334890666666,-30)/
      DATA GAMCS( 42) / -CONST(.5793070335782135784625493333333,-31)/
      DATA PI / CONST(3.14159265358979323846264338327950,0)/
      DATA SQ2PIL / CONST(0.91893853320467274178032973640562,0)/
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DGAMMA
      IF (FIRST) THEN
         NGAM = INITDS (GAMCS, 42, CONST(0.1,0)*AREAL(D1MACH(3)) )
C
         CALL DGAMLM (XMIN, XMAX)
         DXREL = SQRT(D1MACH(4))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.CONST(10.,0)) GO TO 50
C
C COMPUTE GAMMA(X) FOR -XBND .LE. X .LE. XBND.  REDUCE INTERVAL AND FIND
C GAMMA(1+Y) FOR 0.0 .LE. Y .LT. 1.0 FIRST OF ALL.
C
      N = X
      IF (X.LT.CONST(0.,0)) N = N - 1
      Y = X - N
      N = N - 1
      DGAMMA = CONST(0.9375,0)+
     >   DCSEVL (CONST(2.,0)*Y-CONST(1.,0), GAMCS, NGAM)
      IF (N.EQ.0) RETURN
C
      IF (N.GT.0) GO TO 30
C
C COMPUTE GAMMA(X) FOR X .LT. 1.0
C
      N = -N
      IF (X .EQ. CONST(0.,0))
     +   CALL XERMSG ('SLATEC', 'DGAMMA', 'X IS 0', 4, 2)
      IF (X .LT. CONST(0.0,0).AND. X+N-2 .EQ. CONST(0.,0))
     +   CALL XERMSG ('SLATEC',
     +   'DGAMMA', 'X IS A NEGATIVE INTEGER', 4, 2)
      IF (X .LT. (-CONST(0.5,0)) .AND.
     +   ABS((X-AINT(X-CONST(0.5,0)))/X) .LT. DXREL)
     +   CALL XERMSG ('SLATEC', 'DGAMMA',
     +   'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER',
     +   1, 1)
C
      DO 20 I=1,N
        DGAMMA = DGAMMA/(X+I-1 )
 20   CONTINUE
      RETURN
C
C GAMMA(X) FOR X .GE. 2.0 AND X .LE. 10.0
C
 30   DO 40 I=1,N
        DGAMMA = (Y+I) * DGAMMA
 40   CONTINUE
      RETURN
C
C GAMMA(X) FOR ABS(X) .GT. 10.0.  RECALL Y = ABS(X).
C
 50   IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'DGAMMA',
     +   'X SO BIG GAMMA OVERFLOWS', 3, 2)
C
      DGAMMA = CONST(0.,0)
      IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'DGAMMA',
     +   'X SO SMALL GAMMA UNDERFLOWS', 2, 1)
      IF (X.LT.XMIN) RETURN
C
      DGAMMA = EXP ((Y-CONST(0.5,0))*LOG(Y) - Y + SQ2PIL + D9LGMC(Y) )
      IF (X.GT.CONST(0.,0)) RETURN
C
      IF (ABS((X-AINT(X-CONST(0.5,0)))/X) .LT. DXREL)
     +   CALL XERMSG ('SLATEC', 'DGAMMA',
     +   'ANSWER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER', 1, 1)
C
      SINPIY = SIN (PI*Y)
      IF (SINPIY .EQ. CONST(0.,0)) CALL XERMSG ('SLATEC', 'DGAMMA',
     +   'X IS A NEGATIVE INTEGER', 4, 2)
C
      DGAMMA = -PI/(Y*SINPIY*DGAMMA)
C
      RETURN
      END
! 22Jun2000 fgtok -s r8_precision.sub "r8con.csh conversion"
! 22Jun2000 fgtok
! 22Jun2000 fgtok
! 22Jun2000 fgtok
