/* DECK AI */
doublereal ai_(real *x)
{
/* Initialized data */
static real aifcs[9] = { -.0379713584966699975f,.05919188853726363857f,
9.8629280577279975e-4f,6.84884381907656e-6f,2.594202596219e-8f,
6.176612774e-11f,1.0092454e-13f,1.2014e-16f,1e-19f };
static real aigcs[8] = { .01815236558116127f,.02157256316601076f,
2.5678356987483e-4f,1.42652141197e-6f,4.57211492e-9f,9.52517e-12f,
1.392e-14f,1e-17f };
static logical first = TRUE_;
/* System generated locals */
real ret_val, r__1;
doublereal d__1;
/* Local variables */
static real z__, xm;
extern doublereal aie_(real *);
static integer naif, naig;
static real xmax, x3sml, theta;
extern doublereal csevl_(real *, real *, integer *);
extern integer inits_(real *, integer *, real *);
static real xmaxt;
extern doublereal r1mach_(integer *);
extern /* Subroutine */ int r9aimp_(real *, real *, real *), xermsg_(char
*, char *, char *, integer *, integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE AI */
/* ***PURPOSE Evaluate the Airy function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C10D */
/* ***TYPE SINGLE PRECISION (AI-S, DAI-D) */
/* ***KEYWORDS AIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* AI(X) computes the Airy function Ai(X) */
/* Series for AIF on the interval -1.00000D+00 to 1.00000D+00 */
/* with weighted error 1.09E-19 */
/* log weighted error 18.96 */
/* significant figures required 17.76 */
/* decimal places required 19.44 */
/* Series for AIG on the interval -1.00000D+00 to 1.00000D+00 */
/* with weighted error 1.51E-17 */
/* log weighted error 16.82 */
/* significant figures required 15.19 */
/* decimal places required 17.27 */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED AIE, CSEVL, INITS, R1MACH, R9AIMP, 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) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 920618 Removed space from variable names. (RWC, WRB) */
/* ***END PROLOGUE AI */
/* ***FIRST EXECUTABLE STATEMENT AI */
if (first) {
r__1 = r1mach_(&c__3) * .1f;
naif = inits_(aifcs, &c__9, &r__1);
r__1 = r1mach_(&c__3) * .1f;
naig = inits_(aigcs, &c__8, &r__1);
d__1 = (doublereal) r1mach_(&c__3);
x3sml = pow_dd(&d__1, &c_b7);
d__1 = (doublereal) (log(r1mach_(&c__1)) * -1.5f);
xmaxt = pow_dd(&d__1, &c_b9);
xmax = xmaxt - xmaxt * log(xmaxt) / (sqrt(xmaxt) * 4.f + 1.f) - .01f;
}
first = FALSE_;
if (*x >= -1.f) {
goto L20;
}
r9aimp_(x, &xm, &theta);
ret_val = xm * cos(theta);
return ret_val;
L20:
if (*x > 1.f) {
goto L30;
}
z__ = 0.f;
if (dabs(*x) > x3sml) {
/* Computing 3rd power */
r__1 = *x;
z__ = r__1 * (r__1 * r__1);
}
ret_val = csevl_(&z__, aifcs, &naif) - *x * (csevl_(&z__, aigcs, &naig) +
.25f) + .375f;
return ret_val;
L30:
if (*x > xmax) {
goto L40;
}
ret_val = aie_(x) * exp(*x * -2.f * sqrt(*x) / 3.f);
return ret_val;
L40:
ret_val = 0.f;
xermsg_("SLATEC", "AI", "X SO BIG AI UNDERFLOWS", &c__1, &c__1, (ftnlen)6,
(ftnlen)2, (ftnlen)22);
return ret_val;
} /* ai_ */
/* Main global setup function */
int init_globals(Tcl_Interp *interp) {
static int done_init = 0;
extern int gap_fatal_errors;
char *env;
if (done_init)
return 0;
else
done_init++;
/* lookup tables */
set_char_set(1); /* 1 == DNA */
set_dna_lookup(); /* general lookup and complementing */
set_iubc_lookup(); /* iubc codes for restriction enzymes */
#if 0
set_mask_lookup(); /* used to mask/mark consensus */
#endif
init_genetic_code();
#if 0
inits_(); /* fortran stuff */
initlu_(&idm); /* fortran stuff */
#endif
/* Init Tcl note database */
init_tcl_notes(interp);
if (NULL == (env = getenv("STADTABL")))
verror(ERR_FATAL, "init_globals",
"STADTABL environment variable is not set.");
else {
char buf[1024];
sprintf(buf, "%s/align_lib_nuc_matrix", env);
nt_matrix = create_matrix(buf, nt_order);
if (nt_matrix)
init_W128(nt_matrix, nt_order, 0);
else
verror(ERR_FATAL, "init_globals",
"%s: file not found", buf);
}
/*
* gap5_defs (a Tcl_Obj pointer)
*
* We keep this up to date by creating a write trace on the object and
* doing an ObjGetVar2 when it changes. This way the object is always
* valid.
* Firstly we have to create gap5_defs though as initially it doesn't
* exist.
*/
{
Tcl_Obj *val;
defs_name = Tcl_NewStringObj("gap5_defs", -1); /* global */
val = Tcl_ObjGetVar2(interp, defs_name, NULL, TCL_GLOBAL_ONLY);
if (NULL == val)
val = Tcl_NewStringObj("", -1);
gap5_defs = Tcl_ObjSetVar2(interp, defs_name, NULL, val,
TCL_GLOBAL_ONLY);
Tcl_TraceVar(interp, "gap5_defs", TCL_TRACE_WRITES | TCL_GLOBAL_ONLY,
gap5_defs_trace, NULL);
}
/* consensus_cutoff */
Tcl_TraceVar(interp, "consensus_cutoff", TCL_TRACE_WRITES|TCL_GLOBAL_ONLY,
change_consensus_cutoff, (ClientData)NULL);
/* quality_cutoff */
Tcl_LinkVar(interp, "quality_cutoff", (char *)&quality_cutoff,
TCL_LINK_INT);
/* chem_as_double */
Tcl_LinkVar(interp, "chem_as_double", (char *)&chem_as_double,
TCL_LINK_INT);
/* gap_fatal_errors */
Tcl_LinkVar(interp, "gap_fatal_errors", (char *)&gap_fatal_errors,
TCL_LINK_BOOLEAN);
#if 0
/* maxseq */
Tcl_LinkVar(interp, "maxseq", (char *)&maxseq,
TCL_LINK_INT);
/* maxdb */
Tcl_LinkVar(interp, "maxdb", (char *)&maxdb,
TCL_LINK_INT);
#endif
/* ignore_checkdb */
Tcl_LinkVar(interp, "ignore_checkdb", (char *)&ignore_checkdb,
TCL_LINK_INT);
/* consensus_mode */
Tcl_LinkVar(interp, "consensus_mode", (char *)&consensus_mode,
TCL_LINK_INT);
/* consensus_iub */
Tcl_LinkVar(interp, "consensus_iub", (char *)&consensus_iub,
TCL_LINK_INT);
/* exec_notes */
Tcl_LinkVar(interp, "exec_notes", (char *)&exec_notes,
TCL_LINK_INT);
/* rawdata_note */
Tcl_LinkVar(interp, "rawdata_note", (char *)&rawdata_note,
TCL_LINK_INT);
/* align_open_cost */
Tcl_LinkVar(interp, "align_open_cost", (char *)&gopenval,
TCL_LINK_INT);
/* align_extend_cost */
Tcl_LinkVar(interp, "align_extend_cost", (char *)&gextendval,
TCL_LINK_INT);
/* template_size_tolerance */
Tcl_LinkVar(interp, "template_size_tolerance",
(char *)&template_size_tolerance,
TCL_LINK_DOUBLE);
/* min_vector_len */
Tcl_LinkVar(interp, "min_vector_len", (char *)&min_vector_len,
TCL_LINK_INT);
/* template_check_flags */
Tcl_LinkVar(interp, "template_check_flags", (char *)&template_check_flags,
TCL_LINK_INT);
return TCL_OK;
}
/* DECK BESY1 */
doublereal besy1_(real *x)
{
/* Initialized data */
static real by1cs[14] = { .03208047100611908629f,1.26270789743350045f,
.006499961899923175f,-.08936164528860504117f,
.01325088122175709545f,-8.9790591196483523e-4f,
3.647361487958306e-5f,-1.001374381666e-6f,1.99453965739e-8f,
-3.0230656018e-10f,3.60987815e-12f,-3.487488e-14f,2.7838e-16f,
-1.86e-18f };
static real bm1cs[21] = { .1047362510931285f,.00442443893702345f,
-5.661639504035e-5f,2.31349417339e-6f,-1.7377182007e-7f,
1.89320993e-8f,-2.65416023e-9f,4.4740209e-10f,-8.691795e-11f,
1.891492e-11f,-4.51884e-12f,1.16765e-12f,-3.2265e-13f,9.45e-14f,
-2.913e-14f,9.39e-15f,-3.15e-15f,1.09e-15f,-3.9e-16f,1.4e-16f,
-5e-17f };
static real bth1cs[24] = { .7406014102631385f,-.00457175565963769f,
1.19818510964326e-4f,-6.964561891648e-6f,6.55495621447e-7f,
-8.4066228945e-8f,1.3376886564e-8f,-2.499565654e-9f,5.294951e-10f,
-1.24135944e-10f,3.1656485e-11f,-8.66864e-12f,2.523758e-12f,
-7.75085e-13f,2.49527e-13f,-8.3773e-14f,2.9205e-14f,-1.0534e-14f,
3.919e-15f,-1.5e-15f,5.89e-16f,-2.37e-16f,9.7e-17f,-4e-17f };
static real twodpi = .63661977236758134f;
static real pi4 = .78539816339744831f;
static logical first = TRUE_;
/* System generated locals */
real ret_val, r__1, r__2;
/* Local variables */
static real y, z__;
static integer ntm1, nty1;
static real ampl, xmin, xmax, xsml;
extern doublereal besj1_(real *);
static integer ntth1;
static real theta;
extern doublereal csevl_(real *, real *, integer *);
extern integer inits_(real *, integer *, real *);
extern doublereal r1mach_(integer *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE BESY1 */
/* ***PURPOSE Compute the Bessel function of the second kind of order */
/* one. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C10A1 */
/* ***TYPE SINGLE PRECISION (BESY1-S, DBESY1-D) */
/* ***KEYWORDS BESSEL FUNCTION, FNLIB, ORDER ONE, SECOND KIND, */
/* SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* BESY1(X) calculates the Bessel function of the second kind of */
/* order one for real argument X. */
/* Series for BY1 on the interval 0. to 1.60000D+01 */
/* with weighted error 1.87E-18 */
/* log weighted error 17.73 */
/* significant figures required 17.83 */
/* decimal places required 18.30 */
/* Series for BM1 on the interval 0. to 6.25000D-02 */
/* with weighted error 5.61E-17 */
/* log weighted error 16.25 */
/* significant figures required 14.97 */
/* decimal places required 16.91 */
/* Series for BTH1 on the interval 0. to 6.25000D-02 */
/* with weighted error 4.10E-17 */
/* log weighted error 16.39 */
/* significant figures required 15.96 */
/* decimal places required 17.08 */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED BESJ1, CSEVL, INITS, R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 770401 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) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* ***END PROLOGUE BESY1 */
/* ***FIRST EXECUTABLE STATEMENT BESY1 */
if (first) {
r__1 = r1mach_(&c__3) * .1f;
nty1 = inits_(by1cs, &c__14, &r__1);
r__1 = r1mach_(&c__3) * .1f;
ntm1 = inits_(bm1cs, &c__21, &r__1);
r__1 = r1mach_(&c__3) * .1f;
ntth1 = inits_(bth1cs, &c__24, &r__1);
/* Computing MAX */
r__1 = log(r1mach_(&c__1)), r__2 = -log(r1mach_(&c__2));
xmin = exp(dmax(r__1,r__2) + .01f) * 1.571f;
xsml = sqrt(r1mach_(&c__3) * 4.f);
xmax = 1.f / r1mach_(&c__4);
}
first = FALSE_;
if (*x <= 0.f) {
xermsg_("SLATEC", "BESY1", "X IS ZERO OR NEGATIVE", &c__1, &c__2, (
ftnlen)6, (ftnlen)5, (ftnlen)21);
}
if (*x > 4.f) {
goto L20;
}
if (*x < xmin) {
xermsg_("SLATEC", "BESY1", "X SO SMALL Y1 OVERFLOWS", &c__3, &c__2, (
ftnlen)6, (ftnlen)5, (ftnlen)23);
}
y = 0.f;
if (*x > xsml) {
y = *x * *x;
}
r__1 = y * .125f - 1.f;
ret_val = twodpi * log(*x * .5f) * besj1_(x) + (csevl_(&r__1, by1cs, &
nty1) + .5f) / *x;
return ret_val;
L20:
if (*x > xmax) {
xermsg_("SLATEC", "BESY1", "NO PRECISION BECAUSE X IS BIG", &c__2, &
c__2, (ftnlen)6, (ftnlen)5, (ftnlen)29);
}
/* Computing 2nd power */
r__1 = *x;
z__ = 32.f / (r__1 * r__1) - 1.f;
ampl = (csevl_(&z__, bm1cs, &ntm1) + .75f) / sqrt(*x);
theta = *x - pi4 * 3.f + csevl_(&z__, bth1cs, &ntth1) / *x;
ret_val = ampl * sin(theta);
return ret_val;
} /* besy1_ */
/* DECK BESI1 */
doublereal besi1_(real *x)
{
/* Initialized data */
static real bi1cs[11] = { -.001971713261099859f,.40734887667546481f,
.034838994299959456f,.001545394556300123f,4.1888521098377e-5f,
7.64902676483e-7f,1.0042493924e-8f,9.9322077e-11f,7.6638e-13f,
4.741e-15f,2.4e-17f };
static logical first = TRUE_;
/* System generated locals */
real ret_val, r__1;
/* Local variables */
static real y;
static integer nti1;
static real xmin, xmax, xsml;
extern doublereal csevl_(real *, real *, integer *);
extern integer inits_(real *, integer *, real *);
extern doublereal besi1e_(real *), r1mach_(integer *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE BESI1 */
/* ***PURPOSE Compute the modified (hyperbolic) Bessel function of the */
/* first kind of order one. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C10B1 */
/* ***TYPE SINGLE PRECISION (BESI1-S, DBESI1-D) */
/* ***KEYWORDS FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION, */
/* MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* BESI1(X) calculates the modified (hyperbolic) Bessel function */
/* of the first kind of order one for real argument X. */
/* Series for BI1 on the interval 0. to 9.00000D+00 */
/* with weighted error 2.40E-17 */
/* log weighted error 16.62 */
/* significant figures required 16.23 */
/* decimal places required 17.14 */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED BESI1E, CSEVL, INITS, R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 770401 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) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* ***END PROLOGUE BESI1 */
/* ***FIRST EXECUTABLE STATEMENT BESI1 */
if (first) {
r__1 = r1mach_(&c__3) * .1f;
nti1 = inits_(bi1cs, &c__11, &r__1);
xmin = r1mach_(&c__1) * 2.f;
xsml = sqrt(r1mach_(&c__3) * 4.5f);
xmax = log(r1mach_(&c__2));
}
first = FALSE_;
y = dabs(*x);
if (y > 3.f) {
goto L20;
}
ret_val = 0.f;
if (y == 0.f) {
return ret_val;
}
if (y <= xmin) {
xermsg_("SLATEC", "BESI1", "ABS(X) SO SMALL I1 UNDERFLOWS", &c__1, &
c__1, (ftnlen)6, (ftnlen)5, (ftnlen)29);
}
if (y > xmin) {
ret_val = *x * .5f;
}
if (y > xsml) {
r__1 = y * y / 4.5f - 1.f;
ret_val = *x * (csevl_(&r__1, bi1cs, &nti1) + .875f);
}
return ret_val;
L20:
if (y > xmax) {
xermsg_("SLATEC", "BESI1", "ABS(X) SO BIG I1 OVERFLOWS", &c__2, &c__2,
(ftnlen)6, (ftnlen)5, (ftnlen)26);
}
ret_val = exp(y) * besi1e_(x);
return ret_val;
} /* besi1_ */
/* DECK BESI1E */
doublereal besi1e_(real *x)
{
/* Initialized data */
static real bi1cs[11] = { -.001971713261099859f,.40734887667546481f,
.034838994299959456f,.001545394556300123f,4.1888521098377e-5f,
7.64902676483e-7f,1.0042493924e-8f,9.9322077e-11f,7.6638e-13f,
4.741e-15f,2.4e-17f };
static real ai1cs[21] = { -.02846744181881479f,-.01922953231443221f,
-6.1151858579437e-4f,-2.06997125335e-5f,8.58561914581e-6f,
1.04949824671e-6f,-2.9183389184e-7f,-1.559378146e-8f,
1.318012367e-8f,-1.44842341e-9f,-2.9085122e-10f,1.2663889e-10f,
-1.664947e-11f,-1.66665e-12f,1.2426e-12f,-2.7315e-13f,2.023e-14f,
7.3e-15f,-3.33e-15f,7.1e-16f,-6e-17f };
static real ai12cs[22] = { .02857623501828014f,-.00976109749136147f,
-1.1058893876263e-4f,-3.88256480887e-6f,-2.5122362377e-7f,
-2.631468847e-8f,-3.83538039e-9f,-5.5897433e-10f,-1.897495e-11f,
3.252602e-11f,1.41258e-11f,2.03564e-12f,-7.1985e-13f,-4.0836e-13f,
-2.101e-14f,4.273e-14f,1.041e-14f,-3.82e-15f,-1.86e-15f,3.3e-16f,
2.8e-16f,-3e-17f };
static logical first = TRUE_;
/* System generated locals */
real ret_val, r__1;
/* Local variables */
static real y;
static integer nti1;
static real xmin, xsml;
static integer ntai1, ntai12;
extern doublereal csevl_(real *, real *, integer *);
extern integer inits_(real *, integer *, real *);
extern doublereal r1mach_(integer *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE BESI1E */
/* ***PURPOSE Compute the exponentially scaled modified (hyperbolic) */
/* Bessel function of the first kind of order one. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C10B1 */
/* ***TYPE SINGLE PRECISION (BESI1E-S, DBSI1E-D) */
/* ***KEYWORDS EXPONENTIALLY SCALED, FIRST KIND, FNLIB, */
/* HYPERBOLIC BESSEL FUNCTION, MODIFIED BESSEL FUNCTION, */
/* ORDER ONE, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* BESI1E(X) calculates the exponentially scaled modified (hyperbolic) */
/* Bessel function of the first kind of order one for real argument X; */
/* i.e., EXP(-ABS(X))*I1(X). */
/* Series for BI1 on the interval 0. to 9.00000D+00 */
/* with weighted error 2.40E-17 */
/* log weighted error 16.62 */
/* significant figures required 16.23 */
/* decimal places required 17.14 */
/* Series for AI1 on the interval 1.25000D-01 to 3.33333D-01 */
/* with weighted error 6.98E-17 */
/* log weighted error 16.16 */
/* significant figures required 14.53 */
/* decimal places required 16.82 */
/* Series for AI12 on the interval 0. to 1.25000D-01 */
/* with weighted error 3.55E-17 */
/* log weighted error 16.45 */
/* significant figures required 14.69 */
/* decimal places required 17.12 */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 770401 DATE WRITTEN */
/* 890210 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) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 920618 Removed space from variable names. (RWC, WRB) */
/* ***END PROLOGUE BESI1E */
/* ***FIRST EXECUTABLE STATEMENT BESI1E */
if (first) {
r__1 = r1mach_(&c__3) * .1f;
nti1 = inits_(bi1cs, &c__11, &r__1);
r__1 = r1mach_(&c__3) * .1f;
ntai1 = inits_(ai1cs, &c__21, &r__1);
r__1 = r1mach_(&c__3) * .1f;
ntai12 = inits_(ai12cs, &c__22, &r__1);
xmin = r1mach_(&c__1) * 2.f;
xsml = sqrt(r1mach_(&c__3) * 4.5f);
}
first = FALSE_;
y = dabs(*x);
if (y > 3.f) {
goto L20;
}
ret_val = 0.f;
if (y == 0.f) {
return ret_val;
}
if (y <= xmin) {
xermsg_("SLATEC", "BESI1E", "ABS(X) SO SMALL I1 UNDERFLOWS", &c__1, &
c__1, (ftnlen)6, (ftnlen)6, (ftnlen)29);
}
if (y > xmin) {
ret_val = *x * .5f;
}
if (y > xsml) {
r__1 = y * y / 4.5f - 1.f;
ret_val = *x * (csevl_(&r__1, bi1cs, &nti1) + .875f);
}
ret_val = exp(-y) * ret_val;
return ret_val;
L20:
if (y <= 8.f) {
r__1 = (48.f / y - 11.f) / 5.f;
ret_val = (csevl_(&r__1, ai1cs, &ntai1) + .375f) / sqrt(y);
}
if (y > 8.f) {
r__1 = 16.f / y - 1.f;
ret_val = (csevl_(&r__1, ai12cs, &ntai12) + .375f) / sqrt(y);
}
ret_val = r_sign(&ret_val, x);
return ret_val;
} /* besi1e_ */
/* DECK BI */
doublereal bi_(real *x)
{
/* Initialized data */
static real bifcs[9] = { -.01673021647198664948f,.1025233583424944561f,
.00170830925073815165f,1.186254546774468e-5f,4.493290701779e-8f,
1.0698207143e-10f,1.7480643e-13f,2.081e-16f,1.8e-19f };
static real bigcs[8] = { .02246622324857452f,.03736477545301955f,
4.4476218957212e-4f,2.47080756363e-6f,7.91913533e-9f,
1.649807e-11f,2.411e-14f,2e-17f };
static real bif2cs[10] = { .09984572693816041f,.478624977863005538f,
.0251552119604330118f,5.820693885232645e-4f,7.4997659644377e-6f,
6.13460287034e-8f,3.462753885e-10f,1.428891e-12f,4.4962e-15f,
1.11e-17f };
static real big2cs[10] = { .03330566214551434f,.161309215123197068f,
.0063190073096134286f,1.187904568162517e-4f,1.30453458862e-6f,
9.3741259955e-9f,4.74580188e-11f,1.783107e-13f,5.167e-16f,
1.1e-18f };
static logical first = TRUE_;
/* System generated locals */
real ret_val, r__1;
doublereal d__1;
/* Local variables */
static real z__, xm;
extern doublereal bie_(real *);
static real eta;
static integer nbif, nbig;
static real xmax;
static integer nbif2, nbig2;
static real x3sml, theta;
extern doublereal csevl_(real *, real *, integer *);
extern integer inits_(real *, integer *, real *);
extern doublereal r1mach_(integer *);
extern /* Subroutine */ int r9aimp_(real *, real *, real *), xermsg_(char
*, char *, char *, integer *, integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE BI */
/* ***PURPOSE Evaluate the Bairy function (the Airy function of the */
/* second kind). */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C10D */
/* ***TYPE SINGLE PRECISION (BI-S, DBI-D) */
/* ***KEYWORDS BAIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* BI(X) calculates the Airy function of the second kind for real */
/* argument X. */
/* Series for BIF on the interval -1.00000D+00 to 1.00000D+00 */
/* with weighted error 1.88E-19 */
/* log weighted error 18.72 */
/* significant figures required 17.74 */
/* decimal places required 19.20 */
/* Series for BIG on the interval -1.00000D+00 to 1.00000D+00 */
/* with weighted error 2.61E-17 */
/* log weighted error 16.58 */
/* significant figures required 15.17 */
/* decimal places required 17.03 */
/* Series for BIF2 on the interval 1.00000D+00 to 8.00000D+00 */
/* with weighted error 1.11E-17 */
/* log weighted error 16.95 */
/* approx significant figures required 16.5 */
/* decimal places required 17.45 */
/* Series for BIG2 on the interval 1.00000D+00 to 8.00000D+00 */
/* with weighted error 1.19E-18 */
/* log weighted error 17.92 */
/* approx significant figures required 17.2 */
/* decimal places required 18.42 */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED BIE, CSEVL, INITS, R1MACH, R9AIMP, 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) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* ***END PROLOGUE BI */
/* ***FIRST EXECUTABLE STATEMENT BI */
if (first) {
eta = r1mach_(&c__3) * .1f;
nbif = inits_(bifcs, &c__9, &eta);
nbig = inits_(bigcs, &c__8, &eta);
nbif2 = inits_(bif2cs, &c__10, &eta);
nbig2 = inits_(big2cs, &c__10, &eta);
d__1 = (doublereal) eta;
x3sml = pow_dd(&d__1, &c_b7);
d__1 = (doublereal) (log(r1mach_(&c__2)) * 1.5f);
xmax = pow_dd(&d__1, &c_b9);
}
first = FALSE_;
if (*x >= -1.f) {
goto L20;
}
r9aimp_(x, &xm, &theta);
ret_val = xm * sin(theta);
return ret_val;
L20:
if (*x > 1.f) {
goto L30;
}
z__ = 0.f;
if (dabs(*x) > x3sml) {
/* Computing 3rd power */
r__1 = *x;
z__ = r__1 * (r__1 * r__1);
}
ret_val = csevl_(&z__, bifcs, &nbif) + .625f + *x * (csevl_(&z__, bigcs, &
nbig) + .4375f);
return ret_val;
L30:
if (*x > 2.f) {
goto L40;
}
/* Computing 3rd power */
r__1 = *x;
z__ = (r__1 * (r__1 * r__1) * 2.f - 9.f) / 7.f;
ret_val = csevl_(&z__, bif2cs, &nbif2) + 1.125f + *x * (csevl_(&z__,
big2cs, &nbig2) + .625f);
return ret_val;
L40:
if (*x > xmax) {
xermsg_("SLATEC", "BI", "X SO BIG THAT BI OVERFLOWS", &c__1, &c__2, (
ftnlen)6, (ftnlen)2, (ftnlen)26);
}
ret_val = bie_(x) * exp(*x * 2.f * sqrt(*x) / 3.f);
return ret_val;
} /* bi_ */
/* DECK ERF */
doublereal erf_(real *x)
{
/* Initialized data */
static real erfcs[13] = { -.049046121234691808f,-.14226120510371364f,
.010035582187599796f,-5.76876469976748e-4f,2.7419931252196e-5f,
-1.104317550734e-6f,3.848875542e-8f,-1.180858253e-9f,
3.2334215e-11f,-7.99101e-13f,1.799e-14f,-3.71e-16f,7e-18f };
static real sqrtpi = 1.772453850905516f;
static logical first = TRUE_;
/* System generated locals */
real ret_val, r__1, r__2;
/* Local variables */
static real y;
extern doublereal erfc_(real *);
static real xbig;
extern doublereal csevl_(real *, real *, integer *);
static integer nterf;
extern integer inits_(real *, integer *, real *);
static real sqeps;
extern doublereal r1mach_(integer *);
/* ***BEGIN PROLOGUE ERF */
/* ***PURPOSE Compute the error function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C8A, L5A1E */
/* ***TYPE SINGLE PRECISION (ERF-S, DERF-D) */
/* ***KEYWORDS ERF, ERROR FUNCTION, FNLIB, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* ERF(X) calculates the single precision error function for */
/* single precision argument X. */
/* Series for ERF on the interval 0. to 1.00000D+00 */
/* with weighted error 7.10E-18 */
/* log weighted error 17.15 */
/* significant figures required 16.31 */
/* decimal places required 17.71 */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED CSEVL, ERFC, INITS, R1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 770401 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) */
/* 920618 Removed space from variable name. (RWC, WRB) */
/* ***END PROLOGUE ERF */
/* ***FIRST EXECUTABLE STATEMENT ERF */
if (first) {
r__1 = r1mach_(&c__3) * .1f;
nterf = inits_(erfcs, &c__13, &r__1);
xbig = sqrt(-log(sqrtpi * r1mach_(&c__3)));
sqeps = sqrt(r1mach_(&c__3) * 2.f);
}
first = FALSE_;
y = dabs(*x);
if (y > 1.f) {
goto L20;
}
/* ERF(X) = 1. - ERFC(X) FOR -1. .LE. X .LE. 1. */
if (y <= sqeps) {
ret_val = *x * 2.f / sqrtpi;
}
if (y > sqeps) {
/* Computing 2nd power */
r__2 = *x;
r__1 = r__2 * r__2 * 2.f - 1.f;
ret_val = *x * (csevl_(&r__1, erfcs, &nterf) + 1.f);
}
return ret_val;
/* ERF(X) = 1. - ERFC(X) FOR ABS(X) .GT. 1. */
L20:
if (y <= xbig) {
r__1 = 1.f - erfc_(&y);
ret_val = r_sign(&r__1, x);
}
if (y > xbig) {
ret_val = r_sign(&c_b7, x);
}
return ret_val;
} /* erf_ */
