swe4r 0.0.0

data/ext/swe4r/swejpl.c

@@ -0,0 +1,937 @@
+
+/* 
+ | $Header: /home/dieter/sweph/RCS/swejpl.c,v 1.76 2008/08/26 13:55:36 dieter Exp $
+ |
+ | Subroutines for reading JPL ephemerides.
+ | derived from testeph.f as contained in DE403 distribution July 1995.
+ | works with DE200, DE102, DE403, DE404, DE405, DE406. 
+ | (attention, DE102 has 1950 reference frame and also DE4* has slightly
+ | different reference frame from DE200. With DE4*, use routine 
+ | IERS_FK5().)
+
+  Authors: Dieter Koch and Alois Treindl, Astrodienst Zurich
+
+************************************************************/
+/* Copyright (C) 1997 - 2008 Astrodienst AG, Switzerland.  All rights reserved.
+  
+  License conditions
+  ------------------
+
+  This file is part of Swiss Ephemeris.
+
+  Swiss Ephemeris is distributed with NO WARRANTY OF ANY KIND.  No author
+  or distributor accepts any responsibility for the consequences of using it,
+  or for whether it serves any particular purpose or works at all, unless he
+  or she says so in writing.  
+
+  Swiss Ephemeris is made available by its authors under a dual licensing
+  system. The software developer, who uses any part of Swiss Ephemeris
+  in his or her software, must choose between one of the two license models,
+  which are
+  a) GNU public license version 2 or later
+  b) Swiss Ephemeris Professional License
+
+  The choice must be made before the software developer distributes software
+  containing parts of Swiss Ephemeris to others, and before any public
+  service using the developed software is activated.
+
+  If the developer choses the GNU GPL software license, he or she must fulfill
+  the conditions of that license, which includes the obligation to place his
+  or her whole software project under the GNU GPL or a compatible license.
+  See http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+
+  If the developer choses the Swiss Ephemeris Professional license,
+  he must follow the instructions as found in http://www.astro.com/swisseph/ 
+  and purchase the Swiss Ephemeris Professional Edition from Astrodienst
+  and sign the corresponding license contract.
+
+  The License grants you the right to use, copy, modify and redistribute
+  Swiss Ephemeris, but only under certain conditions described in the License.
+  Among other things, the License requires that the copyright notices and
+  this notice be preserved on all copies.
+
+  Authors of the Swiss Ephemeris: Dieter Koch and Alois Treindl
+
+  The authors of Swiss Ephemeris have no control or influence over any of
+  the derived works, i.e. over software or services created by other
+  programmers which use Swiss Ephemeris functions.
+
+  The names of the authors or of the copyright holder (Astrodienst) must not
+  be used for promoting any software, product or service which uses or contains
+  the Swiss Ephemeris. This copyright notice is the ONLY place where the
+  names of the authors can legally appear, except in cases where they have
+  given special permission in writing.
+
+  The trademarks 'Swiss Ephemeris' and 'Swiss Ephemeris inside' may be used
+  for promoting such software, products or services.
+*/
+
+
+#include <string.h>
+#include "swephexp.h"
+#include "sweph.h"
+#include "swejpl.h"
+
+#define DEBUG_DO_SHOW	FALSE
+
+#ifndef NO_JPL
+/*
+ * local globals
+ */
+struct jpl_save {
+  char *jplfname;
+  char *jplfpath;
+  FILE *jplfptr;
+  short do_reorder;
+  double eh_cval[400]; 
+  double eh_ss[3], eh_au, eh_emrat;
+  int32 eh_denum, eh_ncon, eh_ipt[39];
+  char ch_cnam[6*400];
+  double pv[78];
+  double pvsun[6];
+  double buf[1500];
+  double pc[18], vc[18], ac[18], jc[18];
+  short do_km;
+};
+
+static struct jpl_save *FAR js;
+
+static int state (double et, int32 *list, int do_bary, 
+		  double *pv, double *pvsun, double *nut, char *serr);
+static int interp(double FAR *buf, double t, double intv, int32 ncfin, 
+		  int32 ncmin, int32 nain, int32 ifl, double *pv);
+static int32 fsizer(char *serr);
+static void reorder(char *x, int size, int number);
+static int read_const_jpl(double *ss, char *serr);
+
+/* information about eh_ipt[] and buf[]
+DE200	DE102		  	DE403
+3	3	  ipt[0] 	3	body 0 (mercury) starts at buf[2]
+12	15	  ipt[1]	14	body 0, ncf = coefficients per component
+4	2	  ipt[2]	4		na = nintervals, tot 14*4*3=168
+147	93	  ipt[3]	171	body 1 (venus) starts at buf[170]
+12	15	  ipt[4]	10		ncf = coefficients per component
+1	1	  ipt[5]	2		total 10*2*3=60
+183	138	  ipt[6]	231	body 2 (earth) starts at buf[230]
+15	15	  ipt[7]	13		ncf = coefficients per component
+2	2	  ipt[8]	2		total 13*2*3=78
+273	228	  ipt[9]	309	body 3 (mars) starts at buf[308]
+10	10	  ipt[10]	11		ncf = coefficients per component
+1	1	  ipt[11]	1		total 11*1*3=33
+303	258	  ipt[12]	342	body 4 (jupiter) at buf[341]
+9	9	  ipt[13]	8		total 8 * 1 * 3 = 24
+1	1	  ipt[14]	1
+330	285	  ipt[15]	366	body 5 (saturn) at buf[365]
+8	8	  ipt[16]	7		total 7 * 1 * 3 = 21
+1	1	  ipt[17]	1
+354	309	  ipt[18]	387	body 6 (uranus) at buf[386]
+8	8	  ipt[19]	6		total 6 * 1 * 3 = 18
+1	1	  ipt[20]	1
+378	333	  ipt[21]	405	body 7 (neptune) at buf[404]
+6	6	  ipt[22]	6		total 18
+1	1	  ipt[23]	1
+396	351	  ipt[24]	423	body 8 (pluto) at buf[422]
+6	6	  ipt[25]	6		total 18
+1	1	  ipt[26]	1
+414	369	  ipt[27]	441	body 9 (moon) at buf[440]
+12	15	  ipt[28]	13		total 13 * 8 * 3 = 312
+8	8	  ipt[29]	8
+702	729	  ipt[30]	753	SBARY SUN, starts at buf[752]
+15	15	  ipt[31]	11	SBARY SUN, ncf = coeff per component
+1	1	  ipt[32]	2		   total 11*2*3=66
+747	774	  ipt[33]	819	nutations, starts at buf[818]
+10	0	  ipt[34]	10		total 10 * 4 * 2 = 80
+4	0	  ipt[35]	4	(nutation only two coordinates)
+0	0	  ipt[36]	899	librations, start at buf[898]
+0	0	  ipt[37]	10		total 10 * 4 * 3 = 120
+0	0	  ipt[38]	4
+		
+					last element of buf[1017]
+  buf[0] contains start jd and buf[1] end jd of segment;
+  each segment is 32 days in de403, 64 days in DE102, 32 days in  DE200
+
+  Length of blocks: DE406 = 1456*4=5824 bytes = 728 double
+                    DE405 = 2036*4=8144 bytes = 1018 double
+		    DE404 = 1456*4=5824 bytes = 728 double
+                    DE403 = 2036*4=8144 bytes = 1018 double
+		    DE200 = 1652*4=6608 bytes = 826 double
+		    DE102 = 1546*4=6184 bytes = 773 double
+		    each DE102 record has 53*8=424 fill bytes so that
+		    the records have the same length as DE200.
+*/
+
+/*
+ * This subroutine opens the file jplfname, with a phony record length, 
+ * reads the first record, and uses the info to compute ksize, 
+ * the number of single precision words in a record. 
+ * RETURN: ksize (record size of ephemeris data)
+ * jplfptr is opened on return.
+ * note 26-aug-2008: now record size is computed by fsizer(), not 
+ * set to a fixed value depending as in previous releases. The caller of
+ * fsizer() will verify by data comparison whether it computed correctly.
+ */
+static int32 fsizer(char *serr)
+{
+  /* Local variables */
+  int32 ncon; 
+  double emrat;
+  int32 numde;
+  double au, ss[3];
+  int i, kmx, khi, nd;
+  int32 ksize, lpt[3];
+  char ttl[6*14*3];	
+  if ((js->jplfptr = swi_fopen(SEI_FILE_PLANET, js->jplfname, js->jplfpath, serr)) == NULL) {
+    return NOT_AVAILABLE;
+  }
+  /* ttl = ephemeris title, e.g.
+   * "JPL Planetary Ephemeris DE404/LE404
+   *  Start Epoch: JED=   625296.5-3001 DEC 21 00:00:00
+   *  Final Epoch: JED=  2817168.5 3001 JAN 17 00:00:00c */
+  fread((void *) &ttl[0], 1, 252, js->jplfptr);
+  /* cnam = names of constants */
+  fread((void *) js->ch_cnam, 1, 6*400, js->jplfptr);
+  /* ss[0] = start epoch of ephemeris
+   * ss[1] = end epoch
+   * ss[2] = segment size in days */
+  fread((void *) &ss[0], sizeof(double), 3, js->jplfptr);
+  /* reorder ? */
+  if (ss[2] < 1 || ss[2] > 200) 
+    js->do_reorder = TRUE;
+  else 
+    js->do_reorder = 0;
+  for (i = 0; i < 3; i++)
+    js->eh_ss[i] = ss[i];
+  if (js->do_reorder)
+    reorder((char *) &js->eh_ss[0], sizeof(double), 3);
+  /* plausibility test of these constants. Start and end date must be
+   * between -20000 and +20000, segment size >= 1 and <= 200 */
+  if (js->eh_ss[0] < -5583942 || js->eh_ss[1] > 9025909 || js->eh_ss[2] < 1 || js->eh_ss[2] > 200) {
+    if (serr != NULL)
+      sprintf(serr, "alleged ephemeris file (%s) has invalid format.", js->jplfname);
+    return(NOT_AVAILABLE);
+  }
+  /* ncon = number of constants */
+  fread((void *) &ncon, sizeof(int32), 1, js->jplfptr);
+  if (js->do_reorder)
+    reorder((char *) &ncon, sizeof(int32), 1);
+  /* au = astronomical unit */
+  fread((void *) &au, sizeof(double), 1, js->jplfptr);
+  if (js->do_reorder)
+    reorder((char *) &au, sizeof(double), 1);
+  /* emrat = earth moon mass ratio */
+  fread((void *) &emrat, sizeof(double), 1, js->jplfptr);
+  if (js->do_reorder)
+    reorder((char *) &emrat, sizeof(double), 1);
+  /* ipt[i+0]: coefficients of planet i start at buf[ipt[i+0]-1] 
+   * ipt[i+1]: number of coefficients (interpolation order - 1)
+   * ipt[i+2]: number of intervals in segment */
+  fread((void *) &js->eh_ipt[0], sizeof(int32), 36, js->jplfptr);
+  if (js->do_reorder)
+    reorder((char *) &js->eh_ipt[0], sizeof(int32), 36);
+  /* numde = number of jpl ephemeris "404" with de404 */
+  fread((void *) &numde, sizeof(int32), 1, js->jplfptr);
+  if (js->do_reorder)
+    reorder((char *) &numde, sizeof(int32), 1);
+  /* read librations */
+  fread(&lpt[0], sizeof(int32), 3, js->jplfptr);
+  if (js->do_reorder)
+    reorder((char *) &lpt[0], sizeof(int32), 3);
+  /* fill librations into eh_ipt[36]..[38] */
+  for (i = 0; i < 3; ++i) 
+    js->eh_ipt[i + 36] = lpt[i];
+  rewind(js->jplfptr);
+  /*  find the number of ephemeris coefficients from the pointers */
+  /* re-activated this code on 26-aug-2008 */
+  kmx = 0;
+  khi = 0;
+  for (i = 0; i < 13; i++) {
+    if (js->eh_ipt[i * 3] > kmx) {
+      kmx = js->eh_ipt[i * 3];
+      khi = i + 1;
+    }
+  }
+  if (khi == 12) 
+    nd = 2;
+  else
+    nd = 3;
+  ksize = (js->eh_ipt[khi * 3 - 3] + nd * js->eh_ipt[khi * 3 - 2] * js->eh_ipt[khi * 3 - 1] - 1L) * 2L;
+  /*
+   * de102 files give wrong ksize, because they contain 424 empty bytes 
+   * per record. Fixed by hand!
+   */
+  if (ksize == 1546) 
+    ksize = 1652;
+#if 0		/* we prefer to compute ksize to be comaptible
+                   with new DE releases */
+  switch (numde) {
+    case 403:
+    case 405:
+    case 410:
+    case 413:
+    case 414:
+    case 418:
+    case 421:
+      ksize = 2036;
+      break;
+    case 404:
+    case 406:
+      ksize = 1456;
+      break;
+    case 200:
+      ksize = 1652;
+      break;
+    case 102:
+      ksize = 1652;     /* de102 is filled with blanks to length of de200 */
+      break;
+    default:
+      if (serr != NULL)
+	sprintf(serr,"unknown numde value %d;", numde);
+      return ERR;
+  }
+#endif
+  if (ksize < 1000 || ksize > 5000) {
+    if (serr != NULL)
+      sprintf(serr, "JPL ephemeris file does not provide valid ksize (%d)", ksize);/**/
+    return NOT_AVAILABLE;
+  }
+  return ksize;
+} 
+
+/*
+ *     This subroutine reads the jpl planetary ephemeris 
+ *     and gives the position and velocity of the point 'ntarg' 
+ *     with respect to 'ncent'. 
+ *     calling sequence parameters: 
+ *       et = d.p. julian ephemeris date at which interpolation 
+ *            is wanted. 
+ *       ** note the entry dpleph for a doubly-dimensioned time ** 
+ *          the reason for this option is discussed in the 
+ *          subroutine state 
+ *     ntarg = integer number of 'target' point. 
+ *     ncent = integer number of center point. 
+ *            the numbering convention for 'ntarg' and 'ncent' is: 
+ *                0 = mercury           7 = neptune 
+ *                1 = venus             8 = pluto 
+ *                2 = earth             9 = moon 
+ *                3 = mars             10 = sun 
+ *                4 = jupiter          11 = solar-system barycenter 
+ *                5 = saturn           12 = earth-moon barycenter 
+ *                6 = uranus           13 = nutations (longitude and obliq) 
+ *                                     14 = librations, if on eph file 
+ *             (if nutations are wanted, set ntarg = 13. for librations, 
+ *              set ntarg = 14. set ncent=0.) 
+ *      rrd = output 6-word d.p. array containing position and velocity 
+ *            of point 'ntarg' relative to 'ncent'. the units are au and 
+ *            au/day. for librations the units are radians and radians 
+ *            per day. in the case of nutations the first four words of 
+ *            rrd will be set to nutations and rates, having units of 
+ *            radians and radians/day. 
+ *            The option is available to have the units in km and km/sec. 
+ *            For this, set do_km=TRUE (default FALSE). 
+ */
+int swi_pleph(double et, int ntarg, int ncent, double *rrd, char *serr)
+{
+  int i, retc;
+  int32 list[12];
+  double FAR *pv = js->pv;
+  double FAR *pvsun = js->pvsun;
+  for (i = 0; i < 6; ++i) 
+    rrd[i] = 0.0;
+  if (ntarg == ncent) 
+      return 0;
+  for (i = 0; i < 12; ++i) 
+    list[i] = 0;
+  /*     check for nutation call */
+  if (ntarg == J_NUT) {
+    if (js->eh_ipt[34] > 0) {
+      list[10] = 2;
+      return(state(et, list, FALSE, pv, pvsun, rrd, serr));
+    } else {
+      if (serr != NULL) 
+	sprintf(serr,"No nutations on the JPL ephemeris file;");
+      return (NOT_AVAILABLE);
+    }
+  }
+  if (ntarg == J_LIB) {
+    if (js->eh_ipt[37] > 0) {
+      list[11] = 2;
+      if ((retc = state(et, list, FALSE, pv, pvsun, rrd, serr)) != OK)
+	return (retc);
+      for (i = 0; i < 6; ++i) 
+	rrd[i] = pv[i + 60];
+      return 0;
+    } else {
+      if (serr != NULL) 
+	sprintf(serr,"No librations on the ephemeris file;");
+      return (NOT_AVAILABLE);
+    }
+  }
+  /* set up proper entries in 'list' array for state call */
+  if (ntarg < J_SUN) 
+    list[ntarg] = 2;
+  if (ntarg == J_MOON) 	/* Mooon needs Earth */
+    list[J_EARTH] = 2;
+  if (ntarg == J_EARTH) 	/* Earth needs Moon */
+    list[J_MOON] = 2;
+  if (ntarg == J_EMB) 	/* EMB needs Earth */
+    list[J_EARTH] = 2;
+  if (ncent < J_SUN) 
+    list[ncent] = 2;
+  if (ncent == J_MOON) 	/* Mooon needs Earth */
+    list[J_EARTH] = 2;
+  if (ncent == J_EARTH) 	/* Earth needs Moon */
+    list[J_MOON] = 2;
+  if (ncent == J_EMB) 	/* EMB needs Earth */
+    list[J_EARTH] = 2;
+  if ((retc = state(et, list, TRUE, pv, pvsun, rrd, serr)) != OK)
+    return (retc);
+  if (ntarg == J_SUN || ncent == J_SUN) {
+    for (i = 0; i < 6; ++i) 
+      pv[i + 6*J_SUN] = pvsun[i];
+  }
+  if (ntarg == J_SBARY || ncent == J_SBARY) {
+    for (i = 0; i < 6; ++i) {
+      pv[i + 6*J_SBARY] = 0.;
+    }
+  }
+  if (ntarg == J_EMB || ncent == J_EMB) {
+    for (i = 0; i < 6; ++i) 
+      pv[i + 6*J_EMB] = pv[i + 6*J_EARTH];
+  }
+  if ((ntarg==J_EARTH && ncent==J_MOON) || (ntarg == J_MOON && ncent==J_EARTH)){
+    for (i = 0; i < 6; ++i) 
+      pv[i + 6*J_EARTH] = 0.;
+    
+  } else {
+    if (list[J_EARTH] == 2) {
+      for (i = 0; i < 6; ++i) 
+	pv[i + 6*J_EARTH] -= pv[i + 6*J_MOON] / (js->eh_emrat + 1.);
+    }
+    if (list[J_MOON] == 2) {
+      for (i = 0; i < 6; ++i) {
+	pv[i + 6*J_MOON] += pv[i + 6*J_EARTH];
+      }
+    }
+  }
+  for (i = 0; i < 6; ++i) 
+    rrd[i] = pv[i + ntarg * 6] - pv[i + ncent * 6];
+  return OK;
+} 
+
+/*
+ *  This subroutine differentiates and interpolates a 
+ *  set of chebyshev coefficients to give pos, vel, acc, and jerk 
+ *  calling sequence parameters: 
+ *    input: 
+ *     buf   1st location of array of d.p. chebyshev coefficients of position
+ *        t   is dp fractional time in interval covered by 
+ *            coefficients at which interpolation is wanted, 0 <= t <= 1 
+ *     intv   is dp length of whole interval in input time units. 
+ *      ncf   number of coefficients per component 
+ *      ncm   number of components per set of coefficients 
+ *       na   number of sets of coefficients in full array 
+ *            (i.e., number of sub-intervals in full interval) 
+ *       ifl   int flag: =1 for positions only 
+ *                      =2 for pos and vel 
+ *                      =3 for pos, vel, and acc 
+ *                      =4 for pos, vel, acc, and jerk 
+ *    output: 
+ *      pv   d.p. interpolated quantities requested. 
+ *           assumed dimension is pv(ncm,fl). 
+ */
+static int interp(double FAR *buf, double t, double intv, int32 ncfin, 
+		  int32 ncmin, int32 nain, int32 ifl, double *pv)
+{
+  /* Initialized data */
+  static int FAR np, nv;
+  static int FAR nac;
+  static int FAR njk;
+  static double FAR twot = 0.;
+  double FAR *pc = js->pc;
+  double FAR *vc = js->vc;
+  double FAR *ac = js->ac;
+  double FAR *jc = js->jc;
+  int ncf = (int) ncfin;
+  int ncm = (int) ncmin;
+  int na = (int) nain;
+  /* Local variables */
+  double temp;
+  int i, j, ni;
+  double tc;
+  double dt1, bma;
+  double bma2, bma3;
+  /*
+   | get correct sub-interval number for this set of coefficients and then
+   | get normalized chebyshev time within that subinterval. 
+   */
+  if (t >= 0)
+    dt1 = floor(t);
+  else
+    dt1 = -floor(-t);
+  temp = na * t;
+  ni = (int) (temp - dt1);
+  /* tc is the normalized chebyshev time (-1 <= tc <= 1) */
+  tc = (fmod(temp, 1.0) + dt1) * 2. - 1.;
+  /*
+   *  check to see whether chebyshev time has changed, 
+   *  and compute new polynomial values if it has. 
+   *  (the element pc(2) is the value of t1(tc) and hence 
+   *  contains the value of tc on the previous call.) 
+   */
+  if (tc != pc[1]) {
+    np = 2;
+    nv = 3;
+    nac = 4;
+    njk = 5;
+    pc[1] = tc;
+    twot = tc + tc;
+  }
+  /*
+   *  be sure that at least 'ncf' polynomials have been evaluated 
+   *  and are stored in the array 'pc'. 
+   */
+  if (np < ncf) {
+    for (i = np; i < ncf; ++i) 
+      pc[i] = twot * pc[i - 1] - pc[i - 2];
+    np = ncf;
+  }
+  /*  interpolate to get position for each component */
+  for (i = 0; i < ncm; ++i) {
+    pv[i] = 0.;
+    for (j = ncf-1; j >= 0; --j) 
+      pv[i] += pc[j] * buf[j + (i + ni * ncm) * ncf];
+  }
+  if (ifl <= 1) 
+    return 0;
+  /*
+   *       if velocity interpolation is wanted, be sure enough 
+   *       derivative polynomials have been generated and stored. 
+   */
+  bma = (na + na) / intv;
+  vc[2] = twot + twot;
+  if (nv < ncf) {
+    for (i = nv; i < ncf; ++i) 
+      vc[i] = twot * vc[i - 1] + pc[i - 1] + pc[i - 1] - vc[i - 2];
+    nv = ncf;
+  }
+  /*       interpolate to get velocity for each component */
+  for (i = 0; i < ncm; ++i) {
+    pv[i + ncm] = 0.;
+    for (j = ncf-1; j >= 1; --j) 
+      pv[i + ncm] += vc[j] * buf[j + (i + ni * ncm) * ncf];
+    pv[i + ncm] *= bma;
+  }
+  if (ifl == 2) 
+    return 0;
+  /*       check acceleration polynomial values, and */
+  /*       re-do if necessary */
+  bma2 = bma * bma;
+  ac[3] = pc[1] * 24.;
+  if (nac < ncf) {
+    nac = ncf;
+    for (i = nac; i < ncf; ++i) 
+      ac[i] = twot * ac[i - 1] + vc[i - 1] * 4. - ac[i - 2];
+  }
+  /*       get acceleration for each component */
+  for (i = 0; i < ncm; ++i) {
+    pv[i + ncm * 2] = 0.;
+    for (j = ncf-1; j >= 2; --j) 
+      pv[i + ncm * 2] += ac[j] * buf[j + (i + ni * ncm) * ncf];
+    pv[i + ncm * 2] *= bma2;
+  }
+  if (ifl == 3) 
+      return 0;
+  /*       check jerk polynomial values, and */
+  /*       re-do if necessary */
+  bma3 = bma * bma2;
+  jc[4] = pc[1] * 192.;
+  if (njk < ncf) {
+    njk = ncf;
+    for (i = njk; i < ncf; ++i) 
+      jc[i] = twot * jc[i - 1] + ac[i - 1] * 6. - jc[i - 2];
+  }
+  /*       get jerk for each component */
+  for (i = 0; i < ncm; ++i) {
+    pv[i + ncm * 3] = 0.;
+    for (j = ncf-1; j >= 3; --j) 
+      pv[i + ncm * 3] += jc[j] * buf[j + (i + ni * ncm) * ncf];
+    pv[i + ncm * 3] *= bma3;
+  }
+  return 0;
+}
+
+/*
+ | ********** state ********************
+ | this subroutine reads and interpolates the jpl planetary ephemeris file 
+ |  calling sequence parameters: 
+ |  input: 
+ |     et    dp julian ephemeris epoch at which interpolation is wanted.
+ |     list  12-word integer array specifying what interpolation 
+ |           is wanted for each of the bodies on the file. 
+ |                      list(i)=0, no interpolation for body i 
+ |                             =1, position only 
+ |                             =2, position and velocity 
+ |            the designation of the astronomical bodies by i is: 
+ |                      i = 0: mercury 
+ |                        = 1: venus 
+ |                        = 2: earth-moon barycenter, NOT earth! 
+ |                        = 3: mars 
+ |                        = 4: jupiter 
+ |                        = 5: saturn 
+ |                        = 6: uranus 
+ |                        = 7: neptune 
+ |                        = 8: pluto 
+ |                        = 9: geocentric moon 
+ |                        =10: nutations in longitude and obliquity 
+ |                        =11: lunar librations (if on file) 
+ |            If called with list = NULL, only the header records are read and
+ |            stored in the global areas.
+ |  do_bary   short, if true, barycentric, if false, heliocentric.
+ |              only the 9 planets 0..8 are affected by it.
+ |  output: 
+ |       pv   dp 6 x 11 array that will contain requested interpolated 
+ |            quantities.  the body specified by list(i) will have its 
+ |            state in the array starting at pv(1,i).  (on any given 
+ |            call, only those words in 'pv' which are affected by the 
+ |            first 10 'list' entries (and by list(11) if librations are 
+ |            on the file) are set.  the rest of the 'pv' array 
+ |            is untouched.)  the order of components starting in 
+ |            pv is: x,y,z,dx,dy,dz. 
+ |            all output vectors are referenced to the earth mean 
+ |            equator and equinox of epoch. the moon state is always 
+ |            geocentric; the other nine states are either heliocentric 
+ |            or solar-system barycentric, depending on the setting of 
+ |            common flags (see below). 
+ |            lunar librations, if on file, are put into pv(k,10) if 
+ |            list(11) is 1 or 2. 
+ |    pvsun   dp 6-word array containing the barycentric position and 
+ |            velocity of the sun.
+ |      nut   dp 4-word array that will contain nutations and rates, 
+ |            depending on the setting of list(10).  the order of 
+ |            quantities in nut is: 
+ |                     d psi  (nutation in longitude) 
+ |                     d epsilon (nutation in obliquity) 
+ |                     d psi dot 
+ |                     d epsilon dot 
+ |  globals used:
+ |    do_km   logical flag defining physical units of the output states. 
+ |            TRUE = return km and km/sec, FALSE = return au and au/day 
+ |            default value = FALSE  (km determines time unit 
+ |            for nutations and librations.  angle unit is always radians.)
+ */
+static int state(double et, int32 *list, int do_bary, 
+	  double *pv, double *pvsun, double *nut, char *serr)
+{
+  int i, j, k;
+  int32 flen, nseg, nb;
+  double FAR *buf = js->buf;
+  double aufac, s, t, intv, ts[4];
+  int32 nrecl, ksize;
+  int32 nr;
+  double et_mn, et_fr;
+  int32 FAR *ipt = js->eh_ipt;
+  char ch_ttl[252];
+  static int32 irecsz;
+  static int32 nrl, lpt[3], ncoeffs;
+  if (js->jplfptr == NULL) {
+    ksize = fsizer(serr); /* the number of single precision words in a record */
+    nrecl = 4;
+    if (ksize == NOT_AVAILABLE)
+      return NOT_AVAILABLE;
+    irecsz = nrecl * ksize; 	/* record size in bytes */
+    ncoeffs = ksize / 2;	/* # of coefficients, doubles */
+    /* ttl = ephemeris title, e.g.
+     * "JPL Planetary Ephemeris DE404/LE404
+     *  Start Epoch: JED=   625296.5-3001 DEC 21 00:00:00
+     *  Final Epoch: JED=  2817168.5 3001 JAN 17 00:00:00c */
+    fread((void *) ch_ttl, 1, 252, js->jplfptr);
+    /* cnam = names of constants */
+    fread((void *) js->ch_cnam, 1, 2400, js->jplfptr);
+    /* ss[0] = start epoch of ephemeris
+     * ss[1] = end epoch
+     * ss[2] = segment size in days */
+    fread((void *) &js->eh_ss[0], sizeof(double), 3, js->jplfptr);
+    if (js->do_reorder)
+      reorder((char *) &js->eh_ss[0], sizeof(double), 3);
+    /* ncon = number of constants */
+    fread((void *) &js->eh_ncon, sizeof(int32), 1, js->jplfptr);
+    if (js->do_reorder)
+      reorder((char *) &js->eh_ncon, sizeof(int32), 1);
+    /* au = astronomical unit */
+    fread((void *) &js->eh_au, sizeof(double), 1, js->jplfptr);
+    if (js->do_reorder)
+      reorder((char *) &js->eh_au, sizeof(double), 1);
+    /* emrat = earth moon mass ratio */
+    fread((void *) &js->eh_emrat, sizeof(double), 1, js->jplfptr);
+    if (js->do_reorder)
+      reorder((char *) &js->eh_emrat, sizeof(double), 1);
+    /* ipt[i+0]: coefficients of planet i start at buf[ipt[i+0]-1] 
+     * ipt[i+1]: number of coefficients (interpolation order - 1)
+     * ipt[i+2]: number of intervals in segment */
+    fread((void *) &ipt[0], sizeof(int32), 36, js->jplfptr);
+    if (js->do_reorder)
+      reorder((char *) &ipt[0], sizeof(int32), 36);
+    /* numde = number of jpl ephemeris "404" with de404 */
+    fread((void *) &js->eh_denum, sizeof(int32), 1, js->jplfptr);
+    if (js->do_reorder)
+      reorder((char *) &js->eh_denum, sizeof(int32), 1);
+    fread((void *) &lpt[0], sizeof(int32), 3, js->jplfptr);
+    if (js->do_reorder)
+      reorder((char *) &lpt[0], sizeof(int32), 3);
+    /* cval[]:  other constants in next record */
+    fseek(js->jplfptr, 1L * irecsz, 0);
+    fread((void *) &js->eh_cval[0], sizeof(double), 400, js->jplfptr);
+    if (js->do_reorder)
+      reorder((char *) &js->eh_cval[0], sizeof(double), 400);
+    /* new 26-aug-2008: verify correct block size */
+#if 0
+    sp = strstr(js->ch_cnam, "EMRAT ");
+    if (sp == NULL) {
+      if (serr != NULL) 
+	sprintf(serr, "JPL ephemeris file strange, constant name 'EMRAT' missing");
+      return ERR;
+    }
+    i = (sp - js->ch_cnam);
+    if (i % 6 != 0) {
+      if (serr != NULL) 
+	sprintf(serr, "JPL ephemeris file strange, constant name 'EMRAT' not at multiple of 6");
+      return ERR;
+    }
+    i = i / 6;	/* position of EMRAT in constant array eh_cval */
+    if (js->eh_cval[i] != js->eh_emrat) {
+      if (serr != NULL) 
+	sprintf(serr, "JPL ephemeris file error, record size failed EMRAT check");
+      return ERR;
+    }
+#endif
+    for (i = 0; i < 3; ++i) 
+      ipt[i + 36] = lpt[i];
+    nrl = 0;
+    /* is file length correct? */
+    /* file length */
+    fseek(js->jplfptr, 0L, SEEK_END);
+    flen = ftell(js->jplfptr);
+    /* # of segments in file */
+    nseg = (int32) ((js->eh_ss[1] - js->eh_ss[0]) / js->eh_ss[2]);	
+    /* sum of all cheby coeffs of all planets and segments */
+    for(i = 0, nb = 0; i < 13; i++) {		
+      k = 3;
+      if (i == 11)
+	k = 2;
+      nb += (ipt[i*3+1] * ipt[i*3+2]) * k * nseg;
+    }
+    /* add start and end epochs of segments */
+    nb += 2 * nseg; 
+    /* doubles to bytes */
+    nb *= 8;
+    /* add size of header and constants section */
+    nb += 2 * ksize * nrecl;
+#if 0
+    printf("hallo %d %d\n", nb, flen);
+    printf("hallo %d %d\n", nb-flen, ksize);
+#endif
+    if (flen != nb 
+      /* some of our files are one record too long */
+      && flen - nb != ksize * nrecl) {
+      if (serr != NULL) {
+	sprintf(serr, "JPL ephemeris file is mutilated; length = %d instead of %d.", flen, nb);
+	if (strlen(serr) + strlen(js->jplfname) < AS_MAXCH - 1)
+	  sprintf(serr, "JPL ephemeris file %s is mutilated; length = %d instead of %d.", js->jplfname, flen, nb);
+      }
+      return(NOT_AVAILABLE);
+    }
+    /* check if start and end dates in segments are the same as in 
+     * file header */
+    fseek(js->jplfptr, 2L * irecsz, 0);
+    fread((void *) &ts[0], sizeof(double), 2, js->jplfptr);
+    if (js->do_reorder)
+      reorder((char *) &ts[0], sizeof(double), 2);
+    fseek(js->jplfptr, (nseg + 2 - 1) * irecsz, 0);
+    fread((void *) &ts[2], sizeof(double), 2, js->jplfptr);
+    if (js->do_reorder)
+      reorder((char *) &ts[2], sizeof(double), 2);
+    if (ts[0] != js->eh_ss[0] || ts[3] != js->eh_ss[1]) {
+      if (serr != NULL)
+	strcpy(serr, "JPL ephemeris file is corrupt; start/end date check failed.");
+      return NOT_AVAILABLE;
+    }
+  }
+  if (list == NULL) 
+    return 0;
+  s = et - .5;
+  et_mn = floor(s);
+  et_fr = s - et_mn;	/* fraction of days since previous midnight */
+  et_mn += .5;	/* midnight before epoch */
+  /*       error return for epoch out of range */
+  if (et < js->eh_ss[0] || et > js->eh_ss[1]) {
+    if (serr != NULL) 
+      sprintf(serr,"jd %f outside JPL eph. range %.2f .. %.2f;", et, js->eh_ss[0], js->eh_ss[1]);
+    return BEYOND_EPH_LIMITS;
+  }
+  /*       calculate record # and relative time in interval */
+  nr = (int32) ((et_mn - js->eh_ss[0]) / js->eh_ss[2]) + 2;
+  if (et_mn == js->eh_ss[1]) 
+    --nr;	/* end point of ephemeris, use last record */
+  t = (et_mn - ((nr - 2) * js->eh_ss[2] + js->eh_ss[0]) + et_fr) / js->eh_ss[2];
+  /* read correct record if not in core */
+  if (nr != nrl) {
+    nrl = nr;
+    if (fseek(js->jplfptr, nr * irecsz, 0) != 0) {
+      if (serr != NULL) 
+	sprintf(serr, "Read error in JPL eph. at %f\n", et);
+      return NOT_AVAILABLE;
+    }
+    for (k = 1; k <= ncoeffs; ++k) {
+      if ( fread((void *) &buf[k - 1], sizeof(double), 1, js->jplfptr) != 1) {
+	if (serr != NULL) 
+	  sprintf(serr, "Read error in JPL eph. at %f\n", et);
+	return NOT_AVAILABLE;
+      }
+      if (js->do_reorder)
+	reorder((char *) &buf[k-1], sizeof(double), 1);
+    }
+  }
+  if (js->do_km) {
+    intv = js->eh_ss[2] * 86400.;
+    aufac = 1.;
+  } else {
+    intv = js->eh_ss[2];
+    aufac = 1. / js->eh_au;
+  }
+  /*   interpolate ssbary sun */
+  interp(&buf[(int) ipt[30] - 1], t, intv, ipt[31], 3L, ipt[32], 2L, pvsun);
+  for (i = 0; i < 6; ++i) {
+    pvsun[i] *= aufac;
+  }
+  /*   check and interpolate whichever bodies are requested */
+  for (i = 0; i < 10; ++i) {
+    if (list[i] > 0) {
+      interp(&buf[(int) ipt[i * 3] - 1], t, intv, ipt[i * 3 + 1], 3L,
+	     ipt[i * 3 + 2], list[i], &pv[i * 6]);
+      for (j = 0; j < 6; ++j) {
+	if (i < 9 && ! do_bary) {
+	  pv[j + i * 6] = pv[j + i * 6] * aufac - pvsun[j];
+	} else {
+	  pv[j + i * 6] *= aufac;
+	}
+      }
+    }
+  }
+  /*       do nutations if requested (and if on file) */
+  if (list[10] > 0 && ipt[34] > 0) {
+    interp(&buf[(int) ipt[33] - 1], t, intv, ipt[34], 2L, ipt[35],
+	     list[10], nut);
+  }
+  /*       get librations if requested (and if on file) */
+  if (list[11] > 0 && ipt[37] > 0) {
+    interp(&buf[(int) ipt[36] - 1], t, intv, ipt[37], 3L, ipt[38], list[1],
+	    &pv[60]);
+  }
+  return OK;
+} 
+
+/* 
+ *  this entry obtains the constants from the ephemeris file 
+ *  call state to initialize the ephemeris and read in the constants 
+ */
+static int read_const_jpl(double *ss,  char *serr)
+{
+  int i, retc;
+  retc = state(0.0, NULL, FALSE, NULL, NULL, NULL, serr);
+  if (retc != OK)
+    return (retc);
+  for (i = 0; i < 3; i++)
+    ss[i] = js->eh_ss[i];
+#if DEBUG_DO_SHOW
+  {
+    static char FAR *bname[] = {
+	"Mercury", "Venus", "EMB", "Mars", "Jupiter", "Saturn", 
+	"Uranus", "Neptune", "Pluto", "Moon", "SunBary", "Nut", "Libr"};
+    int j, k;
+    int32 nb, nc;
+    printf(" JPL TEST-EPHEMERIS program.  Version October 1995.\n");
+    for (i = 0; i < 13; i++) {
+      j = i * 3;
+      k = 3;
+      if (i == 11) k = 2;
+      nb = js->eh_ipt[j+1] * js->eh_ipt[j+2] * k; 
+      nc = (int32) (nb * 36525L / js->eh_ss[2] * 8L);
+      printf("%s\t%d\tipt[%d]\t%3ld %2ld %2ld,\t",
+	bname[i], i, j, js->eh_ipt[j], js->eh_ipt[j+1], js->eh_ipt[j+2]);
+      printf("%3ld double, bytes per century = %6ld\n", nb, nc);
+      fflush(stdout);
+    }
+    printf("%16.2f %16.2f %16.2f\n", js->eh_ss[0], js->eh_ss[1], js->eh_ss[2]);
+    for (i = 0; i < js->eh_ncon; ++i) 
+      printf("%.6s\t%24.16f\n", js->ch_cnam + i * 6, js->eh_cval[i]);
+    fflush(stdout);
+  }
+#endif
+  return OK;
+} 
+
+static void reorder(char *x, int size, int number) 
+{
+  int i, j;
+  char s[8];
+  char *sp1 = x;
+  char *sp2 = &s[0];
+  for (i = 0; i < number; i++) {
+    for (j = 0; j < size; j++) 
+      *(sp2 + j) = *(sp1 + size - j - 1);
+    for (j = 0; j < size; j++) 
+      *(sp1 + j) = *(sp2 + j);
+    sp1 += size;
+  }
+}
+
+void swi_close_jpl_file(void)
+{
+  if (js != NULL) {
+    if (js->jplfptr != NULL)
+      fclose(js->jplfptr);
+    if (js->jplfname != NULL) 
+      FREE((void *) js->jplfname);
+    if (js->jplfpath != NULL) 
+      FREE((void *) js->jplfpath);
+    FREE((void *) js);
+    js = NULL;
+  }
+}
+
+int swi_open_jpl_file(double *ss, char *fname, char *fpath, char *serr)
+{
+  int retc = OK;
+  /* if open, return */
+  if (js != NULL && js->jplfptr != NULL)
+    return OK;
+  if ((js = (struct jpl_save *) CALLOC(1, sizeof(struct jpl_save))) == NULL
+    || (js->jplfname = MALLOC(strlen(fname)+1)) == NULL
+    || (js->jplfpath = MALLOC(strlen(fpath)+1)) == NULL
+    ) {
+    if (serr != NULL)
+      strcpy(serr, "error in malloc() with JPL ephemeris.");
+    return ERR;
+  }
+  strcpy(js->jplfname, fname);
+  strcpy(js->jplfpath, fpath);
+  retc = read_const_jpl(ss, serr);
+  if (retc != OK) 
+    swi_close_jpl_file();
+  else {
+    /* intializations for function interpol() */
+    js->pc[0] = 1;
+    js->pc[1] = 2;
+    js->vc[1] = 1;
+    js->ac[2] = 4;
+    js->jc[3] = 24;
+  }
+  return retc;
+}
+
+int32 swi_get_jpl_denum()
+{
+  return js->eh_denum;
+}
+#endif	/* NO_JPL */
+