void palUnpcd( double disco, double * x, double *y ) {
const double THIRD = 1.0/3.0;
double rp,q,r,d,w,s,t,f,c,t3,f1,f2,f3,w1,w2,w3;
double c2;
/* Distance of the point from the origin. */
rp = sqrt( (*x)*(*x)+(*y)*(*y));
/* If zero, or if no distortion, no action is necessary. */
if (rp != 0.0 && disco != 0.0) {
/* Begin algebraic solution. */
q = 1.0/(3.0*disco);
r = rp/(2.0*disco);
w = q*q*q+r*r;
/* Continue if one real root, or three of which only one is positive. */
if (w > 0.0) {
d = sqrt(w);
w = r+d;
s = COPYSIGN(pow(fabs(w),THIRD),w);
w = r-d;
t = COPYSIGN(pow(fabs(w),THIRD),w);
f = s+t;
} else {
/* Three different real roots: use geometrical method instead. */
w = 2.0/sqrt(-3.0*disco);
c = 4.0*rp/(disco*w*w*w);
c2 = c*c;
s = sqrt(1.0-DMIN(c2,1.0));
t3 = atan2(s,c);
/* The three solutions. */
f1 = w*cos((PAL__D2PI-t3)/3.0);
f2 = w*cos((t3)/3.0);
f3 = w*cos((PAL__D2PI+t3)/3.0);
/* Pick the one that moves [X,Y] least. */
w1 = fabs(f1-rp);
w2 = fabs(f2-rp);
w3 = fabs(f3-rp);
if (w1 < w2) {
f = ( w1 < w3 ? f1 : f3 );
} else {
f = ( w2 < w3 ? f2 : f3 );
}
}
/* Remove the distortion. */
f = f/rp;
*x *= f;
*y *= f;
}
}
/* ********************************************************************** */
static TBL_REAL interpol8(TBL_REAL xlo, TBL_REAL xhi, TBL_REAL x,
TBL_REAL ylo, TBL_REAL yhi,
TBL_REAL zlo, TBL_REAL zhi) {
TBL_REAL alpha, y, z;
alpha = (x - xlo) / (xhi - xlo);
y = ylo + alpha*(yhi - ylo);
z = zlo + alpha*(zhi - zlo);
/* average */
/* return(0.5*(y+z)); */
/* uniform distribution */
/* return(y + drand48()*(z-y)); */
/* equal area */
return((y+z) - COPYSIGN(SQRT(0.5*(y*y+z*z)), y));
}
double SO3_beta(const int m1, const int m2, const int j)
{
if (j < 0)
return K(0.0);
else if (j < MAX(ABS(m1),ABS(m2)))
return K(0.5);
else if (m1 == 0 || m2 == 0)
return K(0.0);
else
{
const R m1a = FABS((R)m1), m2a = FABS((R)m2);
return -COPYSIGN(
((SQRT(m1a)*SQRT(m2a))/((R)j))
* SQRT(m1a/((R)(j+1-m1)))
* SQRT(((R)(2*j+1))/((R)(j+1+m1)))
* SQRT(m2a/((R)(j+1-m2)))
* SQRT(((R)(2*j+1))/((R)(j+1+m2))),
SIGNF((R)m1)*SIGNF((R)m2));
}
}
/*---------------------------------------------------------------------*//**
四捨五入 ⇒ math_round
**//*---------------------------------------------------------------------*/
bool EsMath::EsMathClass::callRound(EsContext* ctx, EsObject* objThis, EsValue* valCallee, EsValue* valThis, EsValue* vaArg, u32 numArg, EsValue* valRet, const EsCallExtParam* exprm)
{
if(numArg <= 0)
{
valRet->setValue(TypeUtils::getF64NaN()); // ⇒ *vp = DOUBLE_TO_JSVAL(cx->runtime->jsNaN);
return true;
}
f64 a, r;
vaArg[0].toNumber(&a, &vaArg[0], ctx);
if(vaArg[0].isNull())
{
return false;
}
r = COPYSIGN(::floor(a + 0.5), a);
valRet->setNumber(r);
return true;
}
/*---------------------------------------------------------------------*//**
最小値 ⇒ math_min
**//*---------------------------------------------------------------------*/
bool EsMath::EsMathClass::callMin(EsContext* ctx, EsObject* objThis, EsValue* valCallee, EsValue* valThis, EsValue* vaArg, u32 numArg, EsValue* valRet, const EsCallExtParam* exprm)
{
if(numArg <= 0)
{
valRet->setValue(TypeUtils::getF64PositiveInfinity()); // ⇒ *vp = DOUBLE_TO_JSVAL(cx->runtime->jsPositiveInfinity);
return true;
}
f64 a, r;
r = TypeUtils::getF64PositiveInfinity();
for(u32 i = 0; i < numArg; i++)
{
vaArg[i].toNumber(&a, &vaArg[i], ctx);
if(vaArg[i].isNull())
{
return false;
}
if(TFW_F64_IS_NAN(a))
{
valRet->setValue(TypeUtils::getF64NaN()); // ⇒ *vp = DOUBLE_TO_JSVAL(cx->runtime->jsNaN);
return true;
}
if((a == 0.0) && (a == r))
{
if(COPYSIGN(1.0, r) == -1)
{
r = a;
}
}
else if(a < r)
{
r = a;
}
}
valRet->setNumber(r);
return true;
}
KCtype
__mulkc3 (KFtype a, KFtype b, KFtype c, KFtype d)
{
KFtype ac, bd, ad, bc, x, y;
KCtype res;
ac = a * c;
bd = b * d;
ad = a * d;
bc = b * c;
x = ac - bd;
y = ad + bc;
if (isnan (x) && isnan (y))
{
/* Recover infinities that computed as NaN + iNaN. */
_Bool recalc = 0;
if (isinf (a) || isinf (b))
{
/* z is infinite. "Box" the infinity and change NaNs in
the other factor to 0. */
a = COPYSIGN (isinf (a) ? 1 : 0, a);
b = COPYSIGN (isinf (b) ? 1 : 0, b);
if (isnan (c)) c = COPYSIGN (0, c);
if (isnan (d)) d = COPYSIGN (0, d);
recalc = 1;
}
if (isinf (c) || isinf (d))
{
/* w is infinite. "Box" the infinity and change NaNs in
the other factor to 0. */
c = COPYSIGN (isinf (c) ? 1 : 0, c);
d = COPYSIGN (isinf (d) ? 1 : 0, d);
if (isnan (a)) a = COPYSIGN (0, a);
if (isnan (b)) b = COPYSIGN (0, b);
recalc = 1;
}
if (!recalc
&& (isinf (ac) || isinf (bd)
|| isinf (ad) || isinf (bc)))
{
/* Recover infinities from overflow by changing NaNs to 0. */
if (isnan (a)) a = COPYSIGN (0, a);
if (isnan (b)) b = COPYSIGN (0, b);
if (isnan (c)) c = COPYSIGN (0, c);
if (isnan (d)) d = COPYSIGN (0, d);
recalc = 1;
}
if (recalc)
{
x = INFINITY * (a * c - b * d);
y = INFINITY * (a * d + b * c);
}
}
__real__ res = x;
__imag__ res = y;
return res;
}
int nice_output_1(char *output, double val, double err, int len)
/* Generates a string in "output" of length len with "val" rounded */
/* to the appropriate decimal place and the error in parenthesis */
/* as in scientific journals. The error has 1 decimal place. */
/* Note: len should be ~ 20 to show full double precision */
/* if the base 10 exponent of the error needs to be shown. */
/* If len == 0, left-justified minimum length string is returned. */
/* If len > 0, the string returned has is right justified. */
{
int nint, nfrac, totprec;
int errexp, errval, outexp;
double rndval, outmant;
char temp[50];
sprintf(temp, "There is a problem with 'nice_output()'.\n");
if (fabs(err) == 0.0) {
errexp = 0;
} else {
errexp = (int) floor(log10(fabs(err)));
}
/* 1 digit error value: */
errval = (int) floor(fabs(err) * pow(10.0, (double) (-errexp)) +
DBLCORRECT + 0.5);
if (errval == 10) {
errval = 1;
errexp++;
}
/* val rounded to the appropriate decimal place due to err: */
rndval = pow(10.0, (double) errexp) *
floor(val * pow(10.0, (double) (-errexp)) + 0.5);
/* Space needed for integer part: */
if (fabs(val) == 0.0) {
nint = 1;
} else {
nint = (int) (ceil(log10(fabs(val))));
if (nint == 0)
nint++;
}
/* Space needed for fractional part: */
nfrac = -errexp;
/* Total number of digits of precision in output value: */
totprec = nint + nfrac;
/* Base 10 exponent of output value: */
if (fabs(rndval) == 0.0) {
outexp = 0;
} else {
outexp = (int) floor(log10(fabs(rndval)));
}
/* Unsigned base 10 mantissa of output value: */
outmant = rndval * pow(10.0, (double) (-outexp));
if (fabs(1.0 - outmant) < DBLCORRECT || fabs(-1.0 - outmant) < DBLCORRECT)
totprec++;
/* Use scientific notation: */
if ((outexp >= 0 && errexp > 0) && outexp > errexp)
sprintf(temp, "% .*f(%d)x10^%d", totprec - 1,
COPYSIGN(outmant, rndval), errval, outexp);
/* Use scientific notation but with integer mantissa */
else if ((outexp >= 0 && errexp > 0) && outexp == errexp)
sprintf(temp, "% d(%d)x10^%d",
(int) (COPYSIGN(outmant, rndval)), errval, outexp);
/* Use scientific notation for real small numbers: */
else if (outexp < -4 && outexp >= errexp)
sprintf(temp, "% .*f(%d)x10^%d", totprec - 1,
COPYSIGN(outmant, rndval), errval, outexp);
/* Use scientific notation but with integer mantissa */
else if (outexp < errexp && errexp != 0)
sprintf(temp, "% d(%d)x10^%d",
(int) (COPYSIGN(outmant, rndval) + DBLCORRECT),
errval, errexp);
/* Use regular notation: */
else if (nfrac == 0 && fabs(rndval) < 1.0e-15)
sprintf(temp, "% d(%d)", (int) fabs(rndval), errval);
else if (fabs(rndval) <= DBLCORRECT && errexp < -5)
sprintf(temp, "0.0(%d)x10^%d", errval, errexp + 1);
else
sprintf(temp, "% .*f(%d)", nfrac, rndval, errval);
if (len == 0) { /* Left-justify */
sprintf(output, "%s", temp);
} else { /* Right-justify with a length of len */
sprintf(output, "%*s", len, temp);
}
return strlen(output);
}
void palPertue( double date, double u[13], int *jstat ) {
/* Distance from EMB at which Earth and Moon are treated separately */
const double RNE=1.0;
/* Coincidence with major planet distance */
const double COINC=0.0001;
/* Coefficient relating timestep to perturbing force */
const double TSC=1e-4;
/* Minimum and maximum timestep (days) */
const double TSMIN = 0.01;
const double TSMAX = 10.0;
/* Age limit for major-planet state vector (days) */
const double AGEPMO=5.0;
/* Age limit for major-planet mean elements (days) */
const double AGEPEL=50.0;
/* Margin for error when deciding whether to renew the planetary data */
const double TINY=1e-6;
/* Age limit for the body's osculating elements (before rectification) */
const double AGEBEL=100.0;
/* Gaussian gravitational constant squared */
const double GCON2 = PAL__GCON * PAL__GCON;
/* The final epoch */
double TFINAL;
/* The body's current universal elements */
double UL[13];
/* Current reference epoch */
double T0;
/* Timespan from latest orbit rectification to final epoch (days) */
double TSPAN;
/* Time left to go before integration is complete */
double TLEFT;
/* Time direction flag: +1=forwards, -1=backwards */
double FB;
/* First-time flag */
int FIRST = 0;
/*
* The current perturbations
*/
/* Epoch (days relative to current reference epoch) */
double RTN;
/* Position (AU) */
double PERP[3];
/* Velocity (AU/d) */
double PERV[3];
/* Acceleration (AU/d/d) */
double PERA[3];
/* Length of current timestep (days), and half that */
double TS,HTS;
/* Epoch of middle of timestep */
double T;
/* Epoch of planetary mean elements */
double TPEL = 0.0;
/* Planet number (1=Mercury, 2=Venus, 3=EMB...8=Neptune) */
int NP;
/* Planetary universal orbital elements */
double UP[8][13];
/* Epoch of planetary state vectors */
double TPMO = 0.0;
/* State vectors for the major planets (AU,AU/s) */
double PVIN[8][6];
/* Earth velocity and position vectors (AU,AU/s) */
double VB[3],PB[3],VH[3],PE[3];
/* Moon geocentric state vector (AU,AU/s) and position part */
double PVM[6],PM[3];
/* Date to J2000 de-precession matrix */
double PMAT[3][3];
/*
* Correction terms for extrapolated major planet vectors
*/
/* Sun-to-planet distances squared multiplied by 3 */
double R2X3[8];
/* Sunward acceleration terms, G/2R^3 */
double GC[8];
/* Tangential-to-circular correction factor */
double FC;
/* Radial correction factor due to Sunwards acceleration */
double FG;
/* The body's unperturbed and perturbed state vectors (AU,AU/s) */
double PV0[6],PV[6];
/* The body's perturbed and unperturbed heliocentric distances (AU) cubed */
double R03,R3;
/* The perturbating accelerations, indirect and direct */
double FI[3],FD[3];
/* Sun-to-planet vector, and distance cubed */
double RHO[3],RHO3;
/* Body-to-planet vector, and distance cubed */
double DELTA[3],DELTA3;
/* Miscellaneous */
int I,J;
double R2,W,DT,DT2,R,FT;
int NE;
/* Planetary inverse masses, Mercury through Neptune then Earth and Moon */
const double AMAS[10] = {
6023600., 408523.5, 328900.5, 3098710.,
1047.355, 3498.5, 22869., 19314.,
332946.038, 27068709.
};
/* Preset the status to OK. */
*jstat = 0;
/* Copy the final epoch. */
TFINAL = date;
/* Copy the elements (which will be periodically updated). */
for (I=0; I<13; I++) {
UL[I] = u[I];
}
/* Initialize the working reference epoch. */
T0=UL[2];
/* Total timespan (days) and hence time left. */
TSPAN = TFINAL-T0;
TLEFT = TSPAN;
/* Warn if excessive. */
if (fabs(TSPAN) > 36525.0) *jstat=101;
/* Time direction: +1 for forwards, -1 for backwards. */
FB = COPYSIGN(1.0,TSPAN);
/* Initialize relative epoch for start of current timestep. */
RTN = 0.0;
/* Reset the perturbations (position, velocity, acceleration). */
for (I=0; I<3; I++) {
PERP[I] = 0.0;
PERV[I] = 0.0;
PERA[I] = 0.0;
}
/* Set "first iteration" flag. */
FIRST = 1;
/* Step through the time left. */
while (FB*TLEFT > 0.0) {
/* Magnitude of current acceleration due to planetary attractions. */
if (FIRST) {
TS = TSMIN;
} else {
R2 = 0.0;
for (I=0; I<3; I++) {
W = FD[I];
R2 = R2+W*W;
}
W = sqrt(R2);
/* Use the acceleration to decide how big a timestep can be tolerated. */
if (W != 0.0) {
TS = DMIN(TSMAX,DMAX(TSMIN,TSC/W));
} else {
TS = TSMAX;
}
}
TS = TS*FB;
/* Override if final epoch is imminent. */
TLEFT = TSPAN-RTN;
if (fabs(TS) > fabs(TLEFT)) TS=TLEFT;
/* Epoch of middle of timestep. */
HTS = TS/2.0;
T = T0+RTN+HTS;
/* Is it time to recompute the major-planet elements? */
if (FIRST || fabs(T-TPEL)-AGEPEL >= TINY) {
/* Yes: go forward in time by just under the maximum allowed. */
TPEL = T+FB*AGEPEL;
/* Compute the state vector for the new epoch. */
for (NP=1; NP<=8; NP++) {
palPlanet(TPEL,NP,PV,&J);
/* Warning if remote epoch, abort if error. */
if (J == 1) {
*jstat = 102;
} else if (J != 0) {
goto ABORT;
}
/* Transform the vector into universal elements. */
palPv2ue(PV,TPEL,0.0,&(UP[NP-1][0]),&J);
if (J != 0) goto ABORT;
}
}
/* Is it time to recompute the major-planet motions? */
if (FIRST || fabs(T-TPMO)-AGEPMO >= TINY) {
/* Yes: look ahead. */
TPMO = T+FB*AGEPMO;
/* Compute the motions of each planet (AU,AU/d). */
for (NP=1; NP<=8; NP++) {
/* The planet's position and velocity (AU,AU/s). */
palUe2pv(TPMO,&(UP[NP-1][0]),&(PVIN[NP-1][0]),&J);
if (J != 0) goto ABORT;
/* Scale velocity to AU/d. */
for (J=3; J<6; J++) {
PVIN[NP-1][J] = PVIN[NP-1][J]*PAL__SPD;
}
/* Precompute also the extrapolation correction terms. */
R2 = 0.0;
for (I=0; I<3; I++) {
W = PVIN[NP-1][I];
R2 = R2+W*W;
}
R2X3[NP-1] = R2*3.0;
GC[NP-1] = GCON2/(2.0*R2*sqrt(R2));
}
}
/* Reset the first-time flag. */
FIRST = 0;
/* Unperturbed motion of the body at middle of timestep (AU,AU/s). */
palUe2pv(T,UL,PV0,&J);
if (J != 0) goto ABORT;
/* Perturbed position of the body (AU) and heliocentric distance cubed. */
R2 = 0.0;
for (I=0; I<3; I++) {
W = PV0[I]+PERP[I]+(PERV[I]+PERA[I]*HTS/2.0)*HTS;
PV[I] = W;
R2 = R2+W*W;
}
R3 = R2*sqrt(R2);
/* The body's unperturbed heliocentric distance cubed. */
R2 = 0.0;
for (I=0; I<3; I++) {
W = PV0[I];
R2 = R2+W*W;
}
R03 = R2*sqrt(R2);
/* Compute indirect and initialize direct parts of the perturbation. */
for (I=0; I<3; I++) {
FI[I] = PV0[I]/R03-PV[I]/R3;
FD[I] = 0.0;
}
/* Ready to compute the direct planetary effects. */
/* Reset the "near-Earth" flag. */
NE = 0;
/* Interval from state-vector epoch to middle of current timestep. */
DT = T-TPMO;
DT2 = DT*DT;
/* Planet by planet, including separate Earth and Moon. */
for (NP=1; NP<10; NP++) {
/* Which perturbing body? */
if (NP <= 8) {
/* Planet: compute the extrapolation in longitude (squared). */
R2 = 0.0;
for (J=3; J<6; J++) {
W = PVIN[NP-1][J]*DT;
R2 = R2+W*W;
}
/* Hence the tangential-to-circular correction factor. */
FC = 1.0+R2/R2X3[NP-1];
/* The radial correction factor due to the inwards acceleration. */
FG = 1.0-GC[NP-1]*DT2;
/* Planet's position. */
for (I=0; I<3; I++) {
RHO[I] = FG*(PVIN[NP-1][I]+FC*PVIN[NP-1][I+3]*DT);
}
} else if (NE) {
/* Near-Earth and either Earth or Moon. */
if (NP == 9) {
/* Earth: position. */
palEpv(T,PE,VH,PB,VB);
for (I=0; I<3; I++) {
RHO[I] = PE[I];
}
} else {
/* Moon: position. */
palPrec(palEpj(T),2000.0,PMAT);
palDmoon(T,PVM);
eraRxp(PMAT,PVM,PM);
for (I=0; I<3; I++) {
RHO[I] = PM[I]+PE[I];
}
}
}
/* Proceed unless Earth or Moon and not the near-Earth case. */
if (NP <= 8 || NE) {
/* Heliocentric distance cubed. */
R2 = 0.0;
for (I=0; I<3; I++) {
W = RHO[I];
R2 = R2+W*W;
}
R = sqrt(R2);
RHO3 = R2*R;
/* Body-to-planet vector, and distance. */
R2 = 0.0;
for (I=0; I<3; I++) {
W = RHO[I]-PV[I];
DELTA[I] = W;
R2 = R2+W*W;
}
R = sqrt(R2);
/* If this is the EMB, set the near-Earth flag appropriately. */
if (NP == 3 && R < RNE) NE = 1;
/* Proceed unless EMB and this is the near-Earth case. */
if ( ! (NE && NP == 3) ) {
/* If too close, ignore this planet and set a warning. */
if (R < COINC) {
*jstat = NP;
} else {
/* Accumulate "direct" part of perturbation acceleration. */
DELTA3 = R2*R;
W = AMAS[NP-1];
for (I=0; I<3; I++) {
FD[I] = FD[I]+(DELTA[I]/DELTA3-RHO[I]/RHO3)/W;
}
}
}
}
}
/* Update the perturbations to the end of the timestep. */
RTN += TS;
for (I=0; I<3; I++) {
W = (FI[I]+FD[I])*GCON2;
FT = W*TS;
PERP[I] = PERP[I]+(PERV[I]+FT/2.0)*TS;
PERV[I] = PERV[I]+FT;
PERA[I] = W;
}
/* Time still to go. */
TLEFT = TSPAN-RTN;
/* Is it either time to rectify the orbit or the last time through? */
if (fabs(RTN) >= AGEBEL || FB*TLEFT <= 0.0) {
/* Yes: update to the end of the current timestep. */
T0 += RTN;
RTN = 0.0;
/* The body's unperturbed motion (AU,AU/s). */
palUe2pv(T0,UL,PV0,&J);
if (J != 0) goto ABORT;
/* Add and re-initialize the perturbations. */
for (I=0; I<3; I++) {
J = I+3;
PV[I] = PV0[I]+PERP[I];
PV[J] = PV0[J]+PERV[I]/PAL__SPD;
PERP[I] = 0.0;
PERV[I] = 0.0;
PERA[I] = FD[I]*GCON2;
}
/* Use the position and velocity to set up new universal elements. */
palPv2ue(PV,T0,0.0,UL,&J);
if (J != 0) goto ABORT;
/* Adjust the timespan and time left. */
TSPAN = TFINAL-T0;
TLEFT = TSPAN;
}
/* Next timestep. */
}
/* Return the updated universal-element set. */
for (I=0; I<13; I++) {
u[I] = UL[I];
}
/* Finished. */
return;
/* Miscellaneous numerical error. */
ABORT:
*jstat = -1;
return;
}