/* 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_ */