Beispiel #1
0
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;
  }
}
Beispiel #2
0
/* ********************************************************************** */
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));
}
Beispiel #3
0
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;
}
Beispiel #6
0
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;
}
Beispiel #7
0
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);
}
Beispiel #8
0
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;
}