/* DECK DGAMR */
doublereal dgamr_(doublereal *x)
{
/* System generated locals */
doublereal ret_val;
/* Builtin functions */
double d_int(doublereal *), exp(doublereal);
/* Local variables */
doublereal alngx;
// integer irold;
// extern /* Subroutine */ int xgetf_(integer *);
doublereal sgngx;
// extern /* Subroutine */ int xsetf_(integer *);
extern doublereal dgamma_(doublereal *);
extern /* Subroutine */ int dlgams_(doublereal *, doublereal *,
doublereal *), xerclr_(void);
/* ***BEGIN PROLOGUE DGAMR */
/* ***PURPOSE Compute the reciprocal of the Gamma function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C7A */
/* ***TYPE DOUBLE PRECISION (GAMR-S, DGAMR-D, CGAMR-C) */
/* ***KEYWORDS FNLIB, RECIPROCAL GAMMA FUNCTION, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* DGAMR(X) calculates the double precision reciprocal of the */
/* complete Gamma function for double precision argument X. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED DGAMMA, DLGAMS, XERCLR, XGETF, XSETF */
/* ***REVISION HISTORY (YYMMDD) */
/* 770701 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890531 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900727 Added EXTERNAL statement. (WRB) */
/* ***END PROLOGUE DGAMR */
/* ***FIRST EXECUTABLE STATEMENT DGAMR */
ret_val = 0.;
if (*x <= 0. && d_int(x) == *x) {
return ret_val;
}
// xgetf_(&irold);
// xsetf_(&c__1);
if (abs(*x) > 10.) {
goto L10;
}
ret_val = 1. / dgamma_(x);
// xerclr_();
// xsetf_(&irold);
return ret_val;
L10:
dlgams_(x, &alngx, &sgngx);
// xerclr_();
// xsetf_(&irold);
ret_val = sgngx * exp(-alngx);
return ret_val;
} /* dgamr_ */
/* DECK DGAMIC */
doublereal dgamic_(doublereal *a, doublereal *x)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
doublereal ret_val, d__1;
/* Local variables */
static doublereal e, h__, t, sga, alx, bot, eps, aeps, sgng, ainta, alngs,
gstar, sgngs;
static integer izero;
static doublereal sqeps;
extern doublereal d1mach_(integer *);
static doublereal algap1;
extern doublereal d9lgic_(doublereal *, doublereal *, doublereal *),
d9gmic_(doublereal *, doublereal *, doublereal *), d9lgit_(
doublereal *, doublereal *, doublereal *), d9gmit_(doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), dlngam_(
doublereal *);
extern /* Subroutine */ int dlgams_(doublereal *, doublereal *,
doublereal *);
static doublereal sgngam, alneps;
extern /* Subroutine */ int xerclr_(void), xermsg_(char *, char *, char *,
integer *, integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE DGAMIC */
/* ***PURPOSE Calculate the complementary incomplete Gamma function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C7E */
/* ***TYPE DOUBLE PRECISION (GAMIC-S, DGAMIC-D) */
/* ***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, */
/* SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* Evaluate the complementary incomplete Gamma function */
/* DGAMIC = integral from X to infinity of EXP(-T) * T**(A-1.) . */
/* DGAMIC is evaluated for arbitrary real values of A and for non- */
/* negative values of X (even though DGAMIC is defined for X .LT. */
/* 0.0), except that for X = 0 and A .LE. 0.0, DGAMIC is undefined. */
/* DGAMIC, A, and X are DOUBLE PRECISION. */
/* A slight deterioration of 2 or 3 digits accuracy will occur when */
/* DGAMIC is very large or very small in absolute value, because log- */
/* arithmic variables are used. Also, if the parameter A is very close */
/* to a negative INTEGER (but not a negative integer), there is a loss */
/* of accuracy, which is reported if the result is less than half */
/* machine precision. */
/* ***REFERENCES W. Gautschi, A computational procedure for incomplete */
/* gamma functions, ACM Transactions on Mathematical */
/* Software 5, 4 (December 1979), pp. 466-481. */
/* W. Gautschi, Incomplete gamma functions, Algorithm 542, */
/* ACM Transactions on Mathematical Software 5, 4 */
/* (December 1979), pp. 482-489. */
/* ***ROUTINES CALLED D1MACH, D9GMIC, D9GMIT, D9LGIC, D9LGIT, DLGAMS, */
/* DLNGAM, XERCLR, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 770701 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890531 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 920528 DESCRIPTION and REFERENCES sections revised. (WRB) */
/* ***END PROLOGUE DGAMIC */
/* ***FIRST EXECUTABLE STATEMENT DGAMIC */
if (first) {
eps = d1mach_(&c__3) * .5;
sqeps = sqrt(d1mach_(&c__4));
alneps = -log(d1mach_(&c__3));
bot = log(d1mach_(&c__1));
}
first = FALSE_;
if (*x < 0.) {
xermsg_("SLATEC", "DGAMIC", "X IS NEGATIVE", &c__2, &c__2, (ftnlen)6,
(ftnlen)6, (ftnlen)13);
}
if (*x > 0.) {
goto L20;
}
if (*a <= 0.) {
xermsg_("SLATEC", "DGAMIC", "X = 0 AND A LE 0 SO DGAMIC IS UNDEFINED",
&c__3, &c__2, (ftnlen)6, (ftnlen)6, (ftnlen)39);
}
d__1 = *a + 1.;
ret_val = exp(dlngam_(&d__1) - log(*a));
return ret_val;
L20:
alx = log(*x);
sga = 1.;
if (*a != 0.) {
sga = d_sign(&c_b17, a);
}
d__1 = *a + sga * .5;
ainta = d_int(&d__1);
aeps = *a - ainta;
izero = 0;
if (*x >= 1.) {
goto L40;
}
if (*a > .5 || abs(aeps) > .001) {
goto L30;
}
e = 2.;
if (-ainta > 1.) {
e = (-ainta + 2.) * 2. / (ainta * ainta - 1.);
}
e -= alx * pow_dd(x, &c_b20);
if (e * abs(aeps) > eps) {
goto L30;
}
ret_val = d9gmic_(a, x, &alx);
return ret_val;
L30:
d__1 = *a + 1.;
dlgams_(&d__1, &algap1, &sgngam);
gstar = d9gmit_(a, x, &algap1, &sgngam, &alx);
if (gstar == 0.) {
izero = 1;
}
if (gstar != 0.) {
alngs = log((abs(gstar)));
}
if (gstar != 0.) {
sgngs = d_sign(&c_b17, &gstar);
}
goto L50;
L40:
if (*a < *x) {
ret_val = exp(d9lgic_(a, x, &alx));
}
if (*a < *x) {
return ret_val;
}
sgngam = 1.;
d__1 = *a + 1.;
algap1 = dlngam_(&d__1);
sgngs = 1.;
alngs = d9lgit_(a, x, &algap1);
/* EVALUATION OF DGAMIC(A,X) IN TERMS OF TRICOMI-S INCOMPLETE GAMMA FN. */
L50:
h__ = 1.;
if (izero == 1) {
goto L60;
}
t = *a * alx + alngs;
if (t > alneps) {
goto L70;
}
if (t > -alneps) {
h__ = 1. - sgngs * exp(t);
}
if (abs(h__) < sqeps) {
xerclr_();
}
if (abs(h__) < sqeps) {
xermsg_("SLATEC", "DGAMIC", "RESULT LT HALF PRECISION", &c__1, &c__1,
(ftnlen)6, (ftnlen)6, (ftnlen)24);
}
L60:
sgng = d_sign(&c_b17, &h__) * sga * sgngam;
t = log((abs(h__))) + algap1 - log((abs(*a)));
if (t < bot) {
xerclr_();
}
ret_val = sgng * exp(t);
return ret_val;
L70:
sgng = -sgngs * sga * sgngam;
t = t + algap1 - log((abs(*a)));
if (t < bot) {
xerclr_();
}
ret_val = sgng * exp(t);
return ret_val;
} /* dgamic_ */
