/* $Procedure RQUAD ( Roots of a quadratic equation ) */
/* Subroutine */ int rquad_(doublereal *a, doublereal *b, doublereal *c__,
doublereal *root1, doublereal *root2)
{
/* System generated locals */
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal scale;
extern /* Subroutine */ int chkin_(char *, ftnlen), moved_(doublereal *,
integer *, doublereal *);
doublereal discrm;
logical zeroed;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen);
extern logical return_(void);
doublereal con, lin, sqr;
/* $ Abstract */
/* Find the roots of a quadratic equation. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* MATH */
/* POLYNOMIAL */
/* ROOT */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* A I Coefficient of quadratic term. */
/* B I Coefficient of linear term. */
/* C I Constant. */
/* ROOT1 O Root built from positive discriminant term. */
/* ROOT2 O Root built from negative discriminant term. */
/* $ Detailed_Input */
/* A, */
/* B, */
/* C are the coefficients of a quadratic polynomial */
/* 2 */
/* Ax + Bx + C. */
/* $ Detailed_Output */
/* ROOT1, */
/* ROOT2 are the roots of the equation, */
/* 2 */
/* Ax + Bx + C = 0. */
/* ROOT1 and ROOT2 are both arrays of length 2. The */
/* first element of each array is the real part of a */
/* root; the second element contains the complex part */
/* of the same root. */
/* When A is non-zero, ROOT1 represents the root */
/* _____________ */
/* / 2 */
/* - B + \/ B - 4AC */
/* --------------------------- */
/* 2A */
/* and ROOT2 represents the root */
/* _____________ */
/* / 2 */
/* - B - \/ B - 4AC */
/* --------------------------- . */
/* 2A */
/* When A is zero and B is non-zero, ROOT1 and ROOT2 */
/* both represent the root */
/* - C / B. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the input coefficients A and B are both zero, the error */
/* SPICE(DEGENERATECASE) is signalled. The output arguments */
/* are not modified. */
/* $ Files */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* 1) Humor us and suppose we want to compute the "golden ratio." */
/* The quantity r is defined by the equation */
/* 1/r = r/(1-r), */
/* which is equivalent to */
/* 2 */
/* r + r - 1 = 0. */
/* The following code frament does the job. */
/* C */
/* C Compute "golden ratio." The root we want, */
/* C */
/* C ___ */
/* C / */
/* C -1 + \/ 5 */
/* C -----------, */
/* C 2 */
/* C */
/* C */
/* C is contained in ROOT1. */
/* C */
/* CALL RQUAD ( 1.D0, 1.D0, -1.D0, ROOT1, ROOT2 ) */
/* PRINT *, 'The "golden ratio" is ', ROOT1(1) */
/* 2) The equation, */
/* 2 */
/* x + 1 = 0 */
/* can be solved by the code fragment */
/* C */
/* C Let's do one with imaginary roots just for fun. */
/* C */
/* CALL RQUAD ( 1.D0, 0.D0, 1.D0, ROOT1, ROOT2 ) */
/* PRINT *, 'ROOT1 is ', ROOT1 */
/* PRINT *, 'ROOT2 is ', ROOT2 */
/* The printed results will be something like: */
/* ROOT1 is 0.000000000000000 1.000000000000000 */
/* ROOT2 is 0.000000000000000 -1.000000000000000 */
/* $ Restrictions */
/* No checks for overflow of the roots are performed. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 10-JUL-1990 (NJB) */
/* -& */
/* $ Index_Entries */
/* roots of a quadratic equation */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("RQUAD", (ftnlen)5);
}
/* The degree of the equation is zero unless at least one of the */
/* second or first degree coefficients is non-zero. */
if (*a == 0. && *b == 0.) {
setmsg_("Both 1st and 2nd degree coefficients are zero.", (ftnlen)46);
sigerr_("SPICE(DEGENERATECASE)", (ftnlen)21);
chkout_("RQUAD", (ftnlen)5);
return 0;
}
/* If we can scale the coefficients without zeroing any of them out, */
/* we will do so, to help prevent overflow. */
/* Computing MAX */
d__1 = abs(*a), d__2 = abs(*b), d__1 = max(d__1,d__2), d__2 = abs(*c__);
scale = max(d__1,d__2);
zeroed = *a != 0. && *a / scale == 0. || *b != 0. && *b / scale == 0. || *
c__ != 0. && *c__ / scale == 0.;
if (! zeroed) {
sqr = *a / scale;
lin = *b / scale;
con = *c__ / scale;
} else {
sqr = *a;
lin = *b;
con = *c__;
}
/* If the second-degree coefficient is non-zero, we have a bona fide */
/* quadratic equation, as opposed to a linear equation. */
if (sqr != 0.) {
/* Compute the discriminant. */
/* Computing 2nd power */
d__1 = lin;
discrm = d__1 * d__1 - sqr * 4. * con;
/* A non-negative discriminant indicates that the roots are */
/* real. */
if (discrm >= 0.) {
/* The imaginary parts of both roots are zero. */
root1[1] = 0.;
root2[1] = 0.;
/* We can take advantage of the fact that CON/SQR is the */
/* product of the roots to improve the accuracy of the root */
/* having the smaller magnitude. We compute the larger root */
/* first and then divide CON/SQR by it to obtain the smaller */
/* root. */
if (lin < 0.) {
/* ROOT1 will contain the root of larger magnitude. */
root1[0] = (-lin + sqrt(discrm)) / (sqr * 2.);
root2[0] = con / sqr / root1[0];
} else if (lin > 0.) {
/* ROOT2 will contain the root of larger magnitude. */
root2[0] = (-lin - sqrt(discrm)) / (sqr * 2.);
root1[0] = con / sqr / root2[0];
} else {
/* The roots have the same magnitude. */
root1[0] = sqrt(discrm) / (sqr * 2.);
root2[0] = -root1[0];
}
/* The only other possibility is that the roots are complex. */
} else {
/* The roots are complex conjugates, so they have equal */
/* magnitudes. */
root1[0] = -lin / (sqr * 2.);
root1[1] = sqrt(-discrm) / (sqr * 2.);
root2[0] = root1[0];
root2[1] = -root1[1];
}
/* If the second-degree coefficient is zero, we actually have a */
/* linear equation. */
} else if (lin != 0.) {
root1[0] = -con / lin;
root1[1] = 0.;
/* We set the second root equal to the first, rather than */
/* leaving it undefined. */
moved_(root1, &c__2, root2);
}
chkout_("RQUAD", (ftnlen)5);
return 0;
} /* rquad_ */
/* $Procedure DAFB2A ( DAF, binary to ASCII ) */
/* Subroutine */ int dafb2a_(char *binary, char *ascii, ftnlen binary_len,
ftnlen ascii_len)
{
/* System generated locals */
cllist cl__1;
/* Builtin functions */
integer f_clos(cllist *);
/* Local variables */
integer unit;
extern /* Subroutine */ int chkin_(char *, ftnlen), dafb2t_(char *,
integer *, ftnlen);
extern logical failed_(void);
extern /* Subroutine */ int chkout_(char *, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int txtopn_(char *, integer *, ftnlen);
/* $ Abstract */
/* Convert a binary DAF to an equivalent ASCII (text) DAF. */
/* (Obsolete, maintained for backward compatibility only.) */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* DAF */
/* $ Keywords */
/* FILES */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* BINARY I Name of an existing binary DAF. */
/* ASCII I Name of an ASCII (text) DAF to be created. */
/* $ Detailed_Input */
/* BINARY is the name of an existing binary DAF. */
/* ASCII is the name of an ASCII (text) DAF to be created. */
/* The ASCII file contains the same data as the binary */
/* file, but in a form more suitable for transfer */
/* between heterogeneous computing environments. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Files */
/* See arguments BINARY, ASCII. */
/* $ Exceptions */
/* None. */
/* Errors are detected and signalled by routines called by this */
/* routine. */
/* $ Particulars */
/* This routine has been made obsolete by the new DAF binary to text */
/* conversion routine DAFBT. This routine remains available for */
/* reasons of backward compatibility. We strongly recommend that the */
/* conversion routine DAFBT be used for any new software development. */
/* Please see the header of the routine DAFBT for details. */
/* Note that the contents of reserved records in the binary file */
/* are not stored in the ASCII file. */
/* $ Examples */
/* DAFB2A and DAFA2B are typically used to transfer files. */
/* If file A.DAF is a binary DAF in environment 1, it can be */
/* transferred to environment 2 in three steps. */
/* 1) Convert it to ASCII, */
/* CALL DAFB2A ( 'A.DAF', 'A.ASCII' ) */
/* 2) Transfer the ASCII file, using FTP, Kermit, or some other */
/* file transfer utility, */
/* ftp> put a.ascii */
/* 3) Convert it to binary on the new machine, */
/* CALL DAFA2B ( 'A.ASCII', 'A.DAF', RESV ) */
/* Note that DAFB2A and DAFA2B work in any standard Fortran-77 */
/* environment. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* NAIF Document 167.0, "Double Precision Array Files (DAF) */
/* Specification and User's Guide" */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 2.1.0, 18-JUN-1999 (WLT) */
/* Fixed call to CHKOUT with wrong name. */
/* - SPICELIB Version 2.0.0, 04-OCT-1993 (KRG) */
/* This routine was completely rewritten to make use of the */
/* routines DAFB2T and TXTOPN, for converting a text file to */
/* binary and opening a text file. It now simply calls the */
/* routine DAFT2B after opening the text file with TXTOPN. */
/* Added a statement to the $ Particulars section to the effect */
/* that this routine has been made obsolete by the introduction of */
/* the routine DAFBT, and that we strongly recommend the use of */
/* the new routine. */
/* Modified the $ Abstract section to reflect the fact that this */
/* routine is obsolete. */
/* - SPICELIB Version 1.0.2, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.1, 22-MAR-1990 (HAN) */
/* Literature references added to the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) */
/* -& */
/* $ Index_Entries */
/* binary daf to ascii */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 04-OCT-1993 (KRG) */
/* This routine was completely rewritten to make use of the */
/* routines DAFB2T and TXTOPN, for converting a text file to */
/* binary and opening a text file. It now simply calls the */
/* routine DAFT2B after opening the text file with TXTOPN. */
/* Added a statement to the $ Particulars section to the effect */
/* that this routine has been made obsolete by the introduction of */
/* the routine DAFBT, and that we strongly recommend the use of */
/* the new routine. */
/* Modified the $ Abstract section to reflect the fact that this */
/* routine is obsolete. */
/* - SPICELIB Version 1.0.2, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.1, 22-MAR-1990 (HAN) */
/* Literature references added to the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("DAFB2A", (ftnlen)6);
}
/* Open the ASCII file for writing. If an error occurs, then check */
/* out and return. An appropriate error message will have already */
/* been set. */
txtopn_(ascii, &unit, ascii_len);
if (failed_()) {
chkout_("DAFB2A", (ftnlen)6);
return 0;
}
/* Attempt to perform the file conversion. If it fails, close the */
/* text file with STATUS = 'DELETE', check out and return, as an */
/* appropriate error message should have already been set. */
dafb2t_(binary, &unit, binary_len);
if (failed_()) {
cl__1.cerr = 0;
cl__1.cunit = unit;
cl__1.csta = "DELETE";
f_clos(&cl__1);
chkout_("DAFB2A", (ftnlen)6);
return 0;
}
/* Close the text file. */
cl__1.cerr = 0;
cl__1.cunit = unit;
cl__1.csta = 0;
f_clos(&cl__1);
chkout_("DAFB2A", (ftnlen)6);
return 0;
} /* dafb2a_ */
/* $Procedure SGFRVI ( Generic Segments: Fetch ref. value and index ) */
/* Subroutine */ int sgfrvi_(integer *handle, doublereal *descr, doublereal *
x, doublereal *value, integer *indx, logical *found)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
logical done;
integer i__, begin;
extern /* Subroutine */ int chkin_(char *, ftnlen);
logical myfnd;
extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen), dafgda_(
integer *, integer *, integer *, doublereal *);
extern logical failed_(void);
doublereal endref;
integer nfetch;
doublereal buffer[101];
integer bfindx, remain;
extern /* Subroutine */ int sgmeta_(integer *, doublereal *, integer *,
integer *);
doublereal dpimax;
integer myrefb;
extern integer lstled_(doublereal *, integer *, doublereal *);
doublereal dptemp;
integer fullrd, rdridx, myrdrb;
extern integer intmax_(void);
integer mynref;
logical isdirv;
integer myindx;
extern /* Subroutine */ int chkout_(char *, ftnlen), setmsg_(char *,
ftnlen);
integer mynrdr;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
doublereal myvalu;
extern logical return_(void);
extern /* Subroutine */ int sigerr_(char *, ftnlen);
integer myrdrt, mynpkt, end;
/* $ Abstract */
/* Given the handle of a DAF and the descriptor associated with */
/* a generic DAF segment in the file, find the reference value */
/* associated with the value X and it's index. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* DAF Required Reading. */
/* $ Keywords */
/* GENERIC SEGMENTS */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I The handle of a DAF open for reading. */
/* DESCR I The descriptor for a DAF generic segment. */
/* X I The key value used to find a reference and index. */
/* VALUE O The reference value associated with X. */
/* INDX O The index of VALUE within the reference values. */
/* FOUND O A flag indicating whether values for X were found. */
/* $ Detailed_Input */
/* HANDLE is the handle of a DAF open for reading */
/* DESCR is the descriptor of the generic segment that we are */
/* going to search for a reference value to associate with */
/* X. */
/* X a value for which the associated reference value */
/* and reference index is requested. */
/* $ Detailed_Output */
/* VALUE is the reference value associated with the input value */
/* X. */
/* INDX is the index of VALUE within the set of reference */
/* values for the generic segment. This value may be used */
/* to obtain a particular packet of data from the generic */
/* segment. */
/* FOUND is a logical flag indicating whether a reference value */
/* associated with X was found. If a reference value was */
/* found, FOUND will have a value of TRUE; otherwise it */
/* will have a value of FALSE. */
/* $ Parameters */
/* This subroutine makes use of parameters defined in the file */
/* 'sgparam.inc'. */
/* $ Files */
/* See the description of HANDLE above. */
/* $ Exceptions */
/* 1) The error SPICE(UNKNOWNREFDIR) will be signalled if */
/* the reference directory structure is unrecognized. The most */
/* likely cause of this error is that an upgrade to your */
/* version of the SPICE toolkit is needed. */
/* 2) If a value computed for the index of an implicitly indexed */
/* generic segment is too large to be represented as an integer, */
/* the error SPICE(INDEXTOOLARGE) will be signalled. */
/* $ Particulars */
/* This routine allows you to easily find the index and value */
/* of the reference item that should be associated with a */
/* value X. Given this information you can then easily retrieve */
/* the packet that should be associated with X. */
/* $ Examples */
/* Suppose that you have a generic segment that contains the */
/* following items. */
/* 1) Packets that model the motion of a body as a function */
/* of time over some interval of time. */
/* 2) Reference values that are the epochs corresponding */
/* to the beginning of the intervals for the packets. */
/* To retrieve the correct packet to use to compute the position */
/* and velocity of the body at a particular epoch, ET, you could */
/* use the following code. (Note this block of code assumes that */
/* you aren't going to run into any exceptional cases such as ET */
/* falling outside the range of times for which the packets can */
/* provide ephemeris data.) */
/* Find out the index of the time that should be associated */
/* with the ET we've been given */
/* CALL SGFRVI ( HANDLE, DESCR, ET, ETFND, INDX, FOUND ) */
/* Fetch the INDX'th ephemeris packet from the segment. */
/* CALL SGFPKT ( HANDLE, DESCR, INDX, EPHEM ) */
/* $ Restrictions */
/* The segment described by DESCR MUST be a generic segment, */
/* otherwise the results of this routine are not predictable. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* W.L. Taber (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.2.0, 07-SEP-2001 (EDW) */
/* Replaced DAFRDA call with DAFGDA. */
/* - SPICELIB Version 1.1.0, 08-MAY-1996 (WLT) */
/* A bug was found in the EXPCLS index case when the */
/* trying to retrieve the last value in a generic segment. */
/* This bug was discovered by the HP compiler complaining */
/* that an index used was not initialized. */
/* The offending line was */
/* MYVALU = BUFFER(I) */
/* The corrected line is: */
/* MYVALU = BUFFER(BFINDX) */
/* - SPICELIB Version 1.0.0, 28-Mar-1994 (KRG) (WLT) */
/* -& */
/* $ Index_Entries */
/* find the index of a reference value in a generic segment */
/* -& */
/* Spicelib Functions */
/* Local Parameters */
/* Include the mnemonic values for the generic segment declarations. */
/* $ Abstract */
/* Parameter declarations for the generic segments subroutines. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* DAF Required Reading */
/* $ Keywords */
/* GENERIC SEGMENTS */
/* $ Particulars */
/* This include file contains the parameters used by the generic */
/* segments subroutines, SGxxxx. A generic segment is a */
/* generalization of a DAF array which places a particular structure */
/* on the data contained in the array, as described below. */
/* This file defines the mnemonics that are used for the index types */
/* allowed in generic segments as well as mnemonics for the meta data */
/* items which are used to describe a generic segment. */
/* A DAF generic segment contains several logical data partitions: */
/* 1) A partition for constant values to be associated with each */
/* data packet in the segment. */
/* 2) A partition for the data packets. */
/* 3) A partition for reference values. */
/* 4) A partition for a packet directory, if the segment contains */
/* variable sized packets. */
/* 5) A partition for a reference value directory. */
/* 6) A reserved partition that is not currently used. This */
/* partition is only for the use of the NAIF group at the Jet */
/* Propulsion Laboratory (JPL). */
/* 7) A partition for the meta data which describes the locations */
/* and sizes of other partitions as well as providing some */
/* additional descriptive information about the generic */
/* segment. */
/* +============================+ */
/* | Constants | */
/* +============================+ */
/* | Packet 1 | */
/* |----------------------------| */
/* | Packet 2 | */
/* |----------------------------| */
/* | . | */
/* | . | */
/* | . | */
/* |----------------------------| */
/* | Packet N | */
/* +============================+ */
/* | Reference Values | */
/* +============================+ */
/* | Packet Directory | */
/* +============================+ */
/* | Reference Directory | */
/* +============================+ */
/* | Reserved Area | */
/* +============================+ */
/* | Segment Meta Data | */
/* +----------------------------+ */
/* Only the placement of the meta data at the end of a generic */
/* segment is required. The other data partitions may occur in any */
/* order in the generic segment because the meta data will contain */
/* pointers to their appropriate locations within the generic */
/* segment. */
/* The meta data for a generic segment should only be obtained */
/* through use of the subroutine SGMETA. The meta data should not be */
/* written through any mechanism other than the ending of a generic */
/* segment begun by SGBWFS or SGBWVS using SGWES. */
/* $ Restrictions */
/* 1) If new reference index types are added, the new type(s) should */
/* be defined to be the consecutive integer(s) after the last */
/* defined reference index type used. In this way a value for */
/* the maximum allowed index type may be maintained. This value */
/* must also be updated if new reference index types are added. */
/* 2) If new meta data items are needed, mnemonics for them must be */
/* added to the end of the current list of mnemonics and before */
/* the NMETA mnemonic. In this way compatibility with files having */
/* a different, but smaller, number of meta data items may be */
/* maintained. See the description and example below. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* K.R. Gehringer (JPL) */
/* W.L. Taber (JPL) */
/* F.S. Turner (JPL) */
/* $ Literature_References */
/* Generic Segments Required Reading. */
/* DAF Required Reading. */
/* $ Version */
/* - SPICELIB Version 1.1.1, 28-JAN-2004 (NJB) */
/* Header update: equations for comptutations of packet indices */
/* for the cases of index types 0 and 1 were corrected. */
/* - SPICELIB Version 1.1.0, 25-09-98 (FST) */
/* Added parameter MNMETA, the minimum number of meta data items */
/* that must be present in a generic DAF segment. */
/* - SPICELIB Version 1.0.0, 04-03-95 (KRG) (WLT) */
/* -& */
/* Mnemonics for the type of reference value index. */
/* Two forms of indexing are provided: */
/* 1) An implicit form of indexing based on using two values, a */
/* starting value, which will have an index of 1, and a step */
/* size between reference values, which are used to compute an */
/* index and a reference value associated with a specified key */
/* value. See the descriptions of the implicit types below for */
/* the particular formula used in each case. */
/* 2) An explicit form of indexing based on a reference value for */
/* each data packet. */
/* Reference Index Type 0 */
/* ---------------------- */
/* Implied index. The index and reference value of a data packet */
/* associated with a specified key value are computed from the two */
/* generic segment reference values using the formula below. The two */
/* generic segment reference values, REF(1) and REF(2), represent, */
/* respectively, a starting value and a step size between reference */
/* values. The index of the data packet associated with a key value */
/* of VALUE is given by: */
/* / VALUE - REF(1) \ */
/* INDEX = 1 + INT | -------------------- | */
/* \ REF(2) / */
/* and the reference value associated with VALUE is given by: */
/* REFVAL = REF(1) + DBLE (INDEX-1) * REF(2) */
/* Reference Index Type 1 */
/* ---------------------- */
/* Implied index. The index and reference value of a data packet */
/* associated with a specified key value are computed from the two */
/* generic segment reference values using the formula below. The two */
/* generic segment reference values, REF(1) and REF(2), represent, */
/* respectively, a starting value and a step size between reference */
/* values. The index of the data packet associated with a key value */
/* of VALUE is given by: */
/* / VALUE - REF(1) \ */
/* INDEX = 1 + INT | 0.5 + -------------------- | */
/* \ REF(2) / */
/* and the reference value associated with VALUE is given by: */
/* REFVAL = REF(1) + DBLE (INDEX-1) * REF(2) */
/* We get the larger index in the event that VALUE is halfway between */
/* X(I) and X(I+1), where X(I) = BUFFER(1) + DBLE (I-1) * REFDAT(2). */
/* Reference Index Type 2 */
/* ---------------------- */
/* Explicit index. In this case the number of packets must equal the */
/* number of reference values. The index of the packet associated */
/* with a key value of VALUE is the index of the last reference item */
/* that is strictly less than VALUE. The reference values must be in */
/* ascending order, REF(I) < REF(I+1). */
/* Reference Index Type 3 */
/* ---------------------- */
/* Explicit index. In this case the number of packets must equal the */
/* number of reference values. The index of the packet associated */
/* with a key value of VALUE is the index of the last reference item */
/* that is less than or equal to VALUE. The reference values must be */
/* in ascending order, REF(I) < REF(I+1). */
/* Reference Index Type 4 */
/* ---------------------- */
/* Explicit index. In this case the number of packets must equal the */
/* number of reference values. The index of the packet associated */
/* with a key value of VALUE is the index of the reference item */
/* that is closest to the value of VALUE. In the event of a "tie" */
/* the larger index is selected. The reference values must be in */
/* ascending order, REF(I) < REF(I+1). */
/* These parameters define the valid range for the index types. An */
/* index type code, MYTYPE, for a generic segment must satisfy the */
/* relation MNIDXT <= MYTYPE <= MXIDXT. */
/* The following meta data items will appear in all generic segments. */
/* Other meta data items may be added if a need arises. */
/* 1) CONBAS Base Address of the constants in a generic segment. */
/* 2) NCON Number of constants in a generic segment. */
/* 3) RDRBAS Base Address of the reference directory for a */
/* generic segment. */
/* 4) NRDR Number of items in the reference directory of a */
/* generic segment. */
/* 5) RDRTYP Type of the reference directory 0, 1, 2 ... for a */
/* generic segment. */
/* 6) REFBAS Base Address of the reference items for a generic */
/* segment. */
/* 7) NREF Number of reference items in a generic segment. */
/* 8) PDRBAS Base Address of the Packet Directory for a generic */
/* segment. */
/* 9) NPDR Number of items in the Packet Directory of a generic */
/* segment. */
/* 10) PDRTYP Type of the packet directory 0, 1, ... for a generic */
/* segment. */
/* 11) PKTBAS Base Address of the Packets for a generic segment. */
/* 12) NPKT Number of Packets in a generic segment. */
/* 13) RSVBAS Base Address of the Reserved Area in a generic */
/* segment. */
/* 14) NRSV Number of items in the reserved area of a generic */
/* segment. */
/* 15) PKTSZ Size of the packets for a segment with fixed width */
/* data packets or the size of the largest packet for a */
/* segment with variable width data packets. */
/* 16) PKTOFF Offset of the packet data from the start of a packet */
/* record. Each data packet is placed into a packet */
/* record which may have some bookkeeping information */
/* prepended to the data for use by the generic */
/* segments software. */
/* 17) NMETA Number of meta data items in a generic segment. */
/* Meta Data Item 1 */
/* ----------------- */
/* Meta Data Item 2 */
/* ----------------- */
/* Meta Data Item 3 */
/* ----------------- */
/* Meta Data Item 4 */
/* ----------------- */
/* Meta Data Item 5 */
/* ----------------- */
/* Meta Data Item 6 */
/* ----------------- */
/* Meta Data Item 7 */
/* ----------------- */
/* Meta Data Item 8 */
/* ----------------- */
/* Meta Data Item 9 */
/* ----------------- */
/* Meta Data Item 10 */
/* ----------------- */
/* Meta Data Item 11 */
/* ----------------- */
/* Meta Data Item 12 */
/* ----------------- */
/* Meta Data Item 13 */
/* ----------------- */
/* Meta Data Item 14 */
/* ----------------- */
/* Meta Data Item 15 */
/* ----------------- */
/* Meta Data Item 16 */
/* ----------------- */
/* If new meta data items are to be added to this list, they should */
/* be added above this comment block as described below. */
/* INTEGER NEW1 */
/* PARAMETER ( NEW1 = PKTOFF + 1 ) */
/* INTEGER NEW2 */
/* PARAMETER ( NEW2 = NEW1 + 1 ) */
/* INTEGER NEWEST */
/* PARAMETER ( NEWEST = NEW2 + 1 ) */
/* and then the value of NMETA must be changed as well to be: */
/* INTEGER NMETA */
/* PARAMETER ( NMETA = NEWEST + 1 ) */
/* Meta Data Item 17 */
/* ----------------- */
/* Maximum number of meta data items. This is always set equal to */
/* NMETA. */
/* Minimum number of meta data items that must be present in a DAF */
/* generic segment. This number is to remain fixed even if more */
/* meta data items are added for compatibility with old DAF files. */
/* Local Variables */
/* Saved Variables */
/* Initial Values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
chkin_("SGFRVI", (ftnlen)6);
/* Set the value for the maximum index as a double precision number, */
/* but only do it the first time into the subroutine. */
if (first) {
first = FALSE_;
dpimax = (doublereal) intmax_();
}
/* Collect the necessary meta data values common to all cases. */
sgmeta_(handle, descr, &c__12, &mynpkt);
sgmeta_(handle, descr, &c__7, &mynref);
sgmeta_(handle, descr, &c__5, &myrdrt);
sgmeta_(handle, descr, &c__6, &myrefb);
if (failed_()) {
chkout_("SGFRVI", (ftnlen)6);
return 0;
}
/* Check to be sure that we know how to deal with the type of index */
/* in the segment. The index type should be between the minimum */
/* allowed index type, MNIDXT, and the maximum allowed index type, */
/* MXIDXT, as specified in the file 'sgparam.inc'. */
if (myrdrt < 0 || myrdrt > 4) {
setmsg_("The generic DAF segment you attempted to read has an unsupp"
"orted reference directory structure. The integer code given "
"for this structure is #, and allowed codes are within the ra"
"nge # to #. The likely cause of this anamoly is your version"
" of SPICELIB needs updating. Contact your system administrat"
"or or NAIF for a toolkit update.", (ftnlen)331);
errint_("#", &myrdrt, (ftnlen)1);
errint_("#", &c__0, (ftnlen)1);
errint_("#", &c__4, (ftnlen)1);
sigerr_("SPICE(UNKNOWNREFDIR)", (ftnlen)20);
chkout_("SGFRVI", (ftnlen)6);
return 0;
}
/* We don't have an index yet and we initialize things to zero. */
myfnd = FALSE_;
myindx = 0;
myvalu = 0.;
/* We pass the idiot checks, so lets proceed. We have a IF block for */
/* each allowed reference directory type code. */
/* For implicitly indexed data packets, the interval */
/* [ BUFFER(1), BUFFER(1) + (N - 1) * BUFFER(2) ) */
/* is divided into subintervals as follows: */
/* (-infinity, r1), [r_1,r_2) [r_2, r_3), ..., [r_i, r_(i+1)), */
/* ..., [r_N, +infinity), */
/* where N = the number of packets in the segment, MYNPKT, and */
/* r_i = BUFFER(1) + (i-1) * BUFFER(2). */
/* If X is in [r_i, r_(i+1)), i = 1, N-1, then we found a value */
/* and the index returned will be i with the reference value */
/* returned will be r_i. */
/* If X is in [r_N, +infinity), then we found a value and the */
/* index returned will be N and the reference value returned will */
/* be r_N. */
/* If X is in (-infinity, r1), we have two possibilities: */
/* 1) If the index type is implicit closest, we found a value, */
/* the index returned will be 1 and the reference value */
/* returned will be r_1. */
/* 2) If the index type is implicit less than or equal, we do */
/* not find a value. */
/* For explicitly indexed packets we simply search the reference */
/* directory for an appropriate reference value. */
if (myrdrt != 0 && myrdrt != 1) {
/* In addition to the meta data items we already have, we also */
/* need these. */
sgmeta_(handle, descr, &c__4, &mynrdr);
sgmeta_(handle, descr, &c__3, &myrdrb);
if (failed_()) {
chkout_("SGFRVI", (ftnlen)6);
return 0;
}
/* We need to scan the reference directory (if there is one) to */
/* determine the appropriate block of reference values to read */
/* from the generic segment. Then we compute the number of */
/* reference values to fetch and examine. Finally, based on the */
/* index type we figure out whether we have found a reference */
/* value or not. It will take a little while to get there, so */
/* let's get going. */
/* We have not started yet, so we're not done and we cannot have a */
/* reference directory value yet. */
done = FALSE_;
isdirv = FALSE_;
/* We have not read any full buffers of reference directory values */
/* yet, all of the reference directory values remain to be read, */
/* and we have no index for a reference directory value. */
fullrd = 0;
remain = mynrdr;
rdridx = 0;
/* Search the reference directory values to select the appropriate */
/* block of reference values to read. */
while(! done && remain > 0) {
/* Read a buffer of reference directory items. */
nfetch = min(100,remain);
begin = myrdrb + fullrd * 100 + 1;
end = begin + nfetch - 1;
dafgda_(handle, &begin, &end, buffer);
if (failed_()) {
chkout_("SGFRVI", (ftnlen)6);
return 0;
}
/* See if X is in the current buffer. */
rdridx = lstled_(x, &nfetch, buffer);
if (rdridx == 0) {
/* If not, then X < BUFFER(1) and we're done. This indicates */
/* that the desired reference value is before, or in, the */
/* previous block of reference values. */
done = TRUE_;
} else if (rdridx == nfetch) {
/* If we get the last value of the buffer, then either we */
/* are done, X = BUFFER(NFETCH), or X > BUFFER(NFETCH). */
if (*x == buffer[(i__1 = nfetch - 1) < 101 && 0 <= i__1 ?
i__1 : s_rnge("buffer", i__1, "sgfrvi_", (ftnlen)417)]
) {
/* If X = BUFFER(NFETCH) we are done, we have a directory */
/* value, and it might be a value we want to return. */
done = TRUE_;
isdirv = TRUE_;
} else {
/* Otherwise, we might have more stuff to read, so update */
/* the remainder and the current number of full buffer */
/* reads and try the loop again. */
remain -= nfetch;
if (remain > 0) {
/* We don't want to increment FULLRD for a partial */
/* buffer read. The arithmetic for the index */
/* calculations below will use RDRIDX to deal with */
/* this. */
++fullrd;
}
}
} else {
/* BUFFER(1) <= X < BUFFER(NFETCH), i.e., we have something */
/* in the buffer. Check to see if X = BUFFER(RDRIDX). If so, */
/* we are done, we have a directory value, and it might be a */
/* value we want to return. Otherwise, we are just done. */
done = TRUE_;
if (*x == buffer[(i__1 = rdridx - 1) < 101 && 0 <= i__1 ?
i__1 : s_rnge("buffer", i__1, "sgfrvi_", (ftnlen)455)]
) {
isdirv = TRUE_;
}
}
}
rdridx = fullrd * 100 + rdridx;
/* There are three cases that we need to consider when X is not a */
/* reference directory value: */
/* Case 1: 0 < RDRIDX < MYNRDR (most common first) */
/* Case 2: RDRIDX = 0 */
/* Case 3: RDRIDX = MYNRDR */
if (! isdirv) {
if (rdridx > 0 && rdridx < mynrdr) {
/* If we were able to bracket X before reaching the end of */
/* the reference directory, then we KNOW that we have a */
/* candidate for a reference value in the reference data. */
/* All we need to do is read the reference data and find it */
/* in the buffer. We also read the reference directory */
/* values that bracket the desired reference value into */
/* BUFFER, so that they are there if we need them. */
/* Computing MIN */
i__1 = 101, i__2 = mynref - rdridx * 100 + 1;
nfetch = min(i__1,i__2);
begin = myrefb + rdridx * 100;
end = begin + nfetch - 1;
dafgda_(handle, &begin, &end, buffer);
if (failed_()) {
chkout_("SGFRVI", (ftnlen)6);
return 0;
}
bfindx = lstled_(x, &nfetch, buffer);
myindx = rdridx * 100 + bfindx - 1;
} else if (rdridx == 0) {
/* The reference value may be one of the reference values */
/* less than the first reference directory item. So we */
/* compute the beginning and ending addresses for the data, */
/* read it in, and try to find a reference value. */
nfetch = min(101,mynref);
begin = myrefb + 1;
end = begin + nfetch - 1;
dafgda_(handle, &begin, &end, buffer);
if (failed_()) {
chkout_("SGFRVI", (ftnlen)6);
return 0;
}
bfindx = lstled_(x, &nfetch, buffer);
myindx = bfindx;
} else if (rdridx == mynrdr) {
/* If we were not able to bracket X before reaching the end */
/* of the reference directory, then we might have a */
/* candidate for a reference value in the reference data */
/* after the last reference directory value. All we need to */
/* do is read the reference data and look. */
/* NOTE: NFETCH can never be zero or negative, so we can */
/* glibly use it. The reason for this is the NFETCH can only */
/* be zero if the desired reference value is a reference */
/* directory value, and we already know that the reference */
/* value we want is not a reference directory value, because */
/* we are here. For similar reasons, NFETCH can never be */
/* negative. */
begin = myrefb + rdridx * 100;
end = myrefb + mynref;
nfetch = end - begin + 1;
dafgda_(handle, &begin, &end, buffer);
if (failed_()) {
chkout_("SGFRVI", (ftnlen)6);
return 0;
}
bfindx = lstled_(x, &nfetch, buffer);
myindx = rdridx * 100 + bfindx - 1;
}
} else {
/* We have a reference directory value, whose index is easy to */
/* compute. */
myindx = rdridx * 100;
}
/* Now, if we have a candidate for a reference value, lets make */
/* sure, based onthe type of index we have. */
if (myrdrt == 2) {
/* We have a reference value only if X > some reference */
/* value. */
if (! isdirv) {
/* If the value is not a reference directory value, then */
/* we have two cases: */
/* Case 1: 0 < MYINDX <= MYNREF */
/* Case 2: MYINDX = 0 */
if (myindx > 0 && myindx <= mynref) {
/* We found a reference value. The reference value we */
/* want is either the value indicated by MYINDX or */
/* the reference value immediately preceding MYINDX, */
/* if there is such a value. To deal with this we */
/* split the test up into two cases. */
if (myindx > 1) {
/* If X > BUFFER(BFINDX) then we are done, so set the */
/* value. If not, then we want the reference value */
/* that is immediately before the current one. */
if (*x > buffer[(i__1 = bfindx - 1) < 101 && 0 <=
i__1 ? i__1 : s_rnge("buffer", i__1, "sgfrvi_"
, (ftnlen)595)]) {
myfnd = TRUE_;
myvalu = buffer[(i__1 = bfindx - 1) < 101 && 0 <=
i__1 ? i__1 : s_rnge("buffer", i__1,
"sgfrvi_", (ftnlen)598)];
} else {
myfnd = TRUE_;
myvalu = buffer[(i__1 = bfindx - 2) < 101 && 0 <=
i__1 ? i__1 : s_rnge("buffer", i__1,
"sgfrvi_", (ftnlen)603)];
--myindx;
}
} else {
/* Remember, MYINDX is 1 here. If we are greater */
/* than the first reference value in the segment, */
/* we are done. Otherwise there is no reference */
/* value to be associated with X. */
if (*x > buffer[(i__1 = myindx - 1) < 101 && 0 <=
i__1 ? i__1 : s_rnge("buffer", i__1, "sgfrvi_"
, (ftnlen)615)]) {
myfnd = TRUE_;
myvalu = buffer[(i__1 = myindx - 1) < 101 && 0 <=
i__1 ? i__1 : s_rnge("buffer", i__1,
"sgfrvi_", (ftnlen)618)];
} else {
/* We did not find a reference value. X was */
/* equal to the first reference value of the */
/* generic segment. */
myfnd = FALSE_;
}
}
} else if (myindx == 0) {
/* We did not find a reference value. X was < the */
/* first reference value for the generic segment. */
myfnd = FALSE_;
}
} else {
/* We have a reference directory value, and we are done. */
/* Either the reference directory value is the one we */
/* want or the reference value immediately preceeding it */
/* is the one we want. */
myfnd = TRUE_;
--myindx;
begin = myrefb + myindx;
end = begin;
dafgda_(handle, &begin, &end, &myvalu);
if (failed_()) {
chkout_("SGFRVI", (ftnlen)6);
return 0;
}
}
} else if (myrdrt == 3) {
/* We have a reference value only if X >= some reference */
/* value. At this point, either we have the value and index */
/* we want or X is before the first reference value of the */
/* generic segment. We consider two cases, the first when X */
/* is not a referecne directory value, and the second when */
/* it is. */
if (! isdirv) {
/* If X is not a directory value, then MYINDX is either */
/* equal to zero, implying that X is before the first */
/* reference value in the generic segment, or MYINDX > 0, */
/* implying that we have found a reference value. */
if (myindx > 0 && myindx <= mynref) {
myfnd = TRUE_;
myvalu = buffer[(i__1 = bfindx - 1) < 101 && 0 <= i__1 ?
i__1 : s_rnge("buffer", i__1, "sgfrvi_", (ftnlen)
684)];
} else if (myindx == 0) {
/* We did not find a reference value. X was < the */
/* first reference value for the generic segment. */
myfnd = FALSE_;
}
} else {
/* We have a reference directory value, and it is the one */
/* we want. */
myfnd = TRUE_;
myvalu = *x;
}
} else if (myrdrt == 4) {
/* We have a reference value for every value of X. If X < */
/* the first reference value of the generic segment, the */
/* closest value is the first reference value. If X > the */
/* last reference value of the generic segment, the closest */
/* value is the last reference value. For X between the */
/* first and last reference values we simple take the */
/* closest reference value to X, resolving a tie by */
/* accepting the larger reference value. */
if (! isdirv) {
/* If X is not a directory value, then MYINDX is either */
/* equal to zero, implying that X is before the first */
/* reference value in the generic segment, */
/* 0 < MYINDX < MYNPKT, implying X is between the first */
/* and last reference values in the generic segment, or */
/* MYINDX = MYNPKT implying that X is greater than or */
/* equal to the last reference value. */
if (myindx > 0 && myindx < mynref) {
i__ = bfindx;
/* Find the closest value to X, choosing the larger in */
/* the event of a tie. */
if (buffer[(i__1 = i__) < 101 && 0 <= i__1 ? i__1 :
s_rnge("buffer", i__1, "sgfrvi_", (ftnlen)734)] -
*x <= *x - buffer[(i__2 = i__ - 1) < 101 && 0 <=
i__2 ? i__2 : s_rnge("buffer", i__2, "sgfrvi_", (
ftnlen)734)]) {
++i__;
++myindx;
}
myfnd = TRUE_;
myvalu = buffer[(i__1 = i__ - 1) < 101 && 0 <= i__1 ?
i__1 : s_rnge("buffer", i__1, "sgfrvi_", (ftnlen)
742)];
} else if (myindx == 0) {
/* X is before the first reference value for the */
/* generic segment, so the closest reference value is */
/* the first one. */
myfnd = TRUE_;
myindx = 1;
myvalu = buffer[0];
} else if (myindx == mynref) {
/* X is at of after the last reference value for the */
/* generic segment, so the closest reference value is */
/* the last reference value, which will be in BUFFER. */
myfnd = TRUE_;
myvalu = buffer[(i__1 = bfindx - 1) < 101 && 0 <= i__1 ?
i__1 : s_rnge("buffer", i__1, "sgfrvi_", (ftnlen)
762)];
}
} else {
/* We have a reference directory value, and it is the one */
/* we want. */
myfnd = TRUE_;
myvalu = *x;
}
}
} else if (myrdrt == 0) {
/* Get the begin and end addresses from which to read the */
/* reference values and get the reference values. */
begin = myrefb + 1;
end = myrefb + 2;
dafgda_(handle, &begin, &end, buffer);
if (failed_()) {
chkout_("SGFRVI", (ftnlen)6);
return 0;
}
endref = buffer[0] + (doublereal) (mynpkt - 1) * buffer[1];
/* Compute the index if we can. */
if (*x < buffer[0]) {
/* If X is less than BUFFER(1), we do not have a reference */
/* value. */
myfnd = FALSE_;
} else if (*x > endref) {
/* If X is greater than ENDREF, then we have a reference */
/* value, ENDREF. */
myfnd = TRUE_;
myindx = mynpkt;
myvalu = endref;
} else {
/* r_1 < X < r_N, i.e., we found a value. Compute the index */
/* and the reference value. */
if (mynpkt > 1) {
myfnd = TRUE_;
/* Compute the index. */
dptemp = (*x - buffer[0]) / buffer[1] + 1.;
/* Test to see if we can safely convert the index to an */
/* integer. */
if (dptemp > dpimax) {
setmsg_("The computed index is too large to be represent"
"ed as an integer. The most likely problem is tha"
"t an incorrect value was stored for the step siz"
"e. The value found for the step was: #", (ftnlen)
181);
errdp_("#", &buffer[1], (ftnlen)1);
sigerr_("SPICE(INDEXTOOLARGE)", (ftnlen)20);
chkout_("SGFRVI", (ftnlen)6);
return 0;
}
myindx = (integer) dptemp;
myindx = min(myindx,mynpkt);
} else {
/* There is only one packet. */
myindx = 1;
}
/* Compute the reference value. */
myvalu = buffer[0] + (doublereal) (myindx - 1) * buffer[1];
}
} else if (myrdrt == 1) {
/* Get the begin and end addresses from which to read the */
/* reference values and get the reference values. */
begin = myrefb + 1;
end = myrefb + 2;
dafgda_(handle, &begin, &end, buffer);
if (failed_()) {
chkout_("SGFRVI", (ftnlen)6);
return 0;
}
endref = buffer[0] + (doublereal) (mynpkt - 1) * buffer[1];
/* Compute the index if we can. */
if (*x < buffer[0]) {
/* If X < BUFFER(1), then we found a value, the index */
/* returned will be 1 and the reference value returned will */
/* be BUFFER(1). */
myfnd = TRUE_;
myindx = 1;
myvalu = buffer[0];
} else if (*x > endref) {
/* If X > ENDREF, then we found a value, the index returned */
/* will be MYNPKT and the reference value returned will be */
/* ENDREF. */
myfnd = TRUE_;
myindx = mynpkt;
myvalu = endref;
} else {
/* r_1 < X < r_N, i.e., we found a value. Compute the index */
/* and the reference value. If X is closer to r_I, the index */
/* returned will be I with a reference value of r_I. If X is */
/* closer to r_(I+1), the index returned will be I+1 with a */
/* reference value of r_(I+1). */
if (mynpkt > 1) {
myfnd = TRUE_;
/* Compute the index. */
dptemp = (*x - buffer[0]) / buffer[1] + 1.5;
if (dptemp > dpimax + .5) {
setmsg_("The computed index is too large to be represent"
"ed as an integer. The most likely problem is tha"
"t an incorrect value was stored for the step siz"
"e. The value found for the step was: #", (ftnlen)
181);
errdp_("#", &buffer[1], (ftnlen)1);
sigerr_("SPICE(INDEXTOOLARGE)", (ftnlen)20);
chkout_("SGFRVI", (ftnlen)6);
return 0;
}
myindx = (integer) dptemp;
} else {
/* There is only one packet. */
myindx = 1;
}
/* Compute the reference value. */
myvalu = buffer[0] + (doublereal) (myindx - 1) * buffer[1];
}
}
/* At this point, we have either found a value or not. If so, then we */
/* need to set the index, value, and found flag for output. */
/* Otherwise, we simply set the found flag. */
if (myfnd) {
*indx = myindx;
*value = myvalu;
}
*found = myfnd;
chkout_("SGFRVI", (ftnlen)6);
return 0;
} /* sgfrvi_ */
/* $Procedure SPCT2B ( SPK and CK, text to binary ) */
/* Subroutine */ int spct2b_(integer *unit, char *binary, ftnlen binary_len)
{
/* System generated locals */
integer i__1;
cilist ci__1;
olist o__1;
cllist cl__1;
/* Builtin functions */
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
s_cmp(char *, char *, ftnlen, ftnlen), f_open(olist *), s_wsfe(
cilist *), e_wsfe(void), f_clos(cllist *);
/* Local variables */
char line[1000];
extern /* Subroutine */ int spcac_(integer *, integer *, char *, char *,
ftnlen, ftnlen), chkin_(char *, ftnlen);
extern integer ltrim_(char *, ftnlen), rtrim_(char *, ftnlen);
extern /* Subroutine */ int daft2b_(integer *, char *, integer *, ftnlen);
integer handle;
extern /* Subroutine */ int dafcls_(integer *), dafopw_(char *, integer *,
ftnlen);
integer scrtch;
extern /* Subroutine */ int errfnm_(char *, integer *, ftnlen), sigerr_(
char *, ftnlen), chkout_(char *, ftnlen), getlun_(integer *),
setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Reconstruct a binary SPK or CK file including comments */
/* from a text file opened by the calling program. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* SPC */
/* $ Keywords */
/* FILES */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* UNIT I Logical unit connected to the text format file. */
/* BINARY I Name of a binary SPK or CK file to be created. */
/* $ Detailed_Input */
/* UNIT is the logical unit connected to an existing text */
/* format SPK or CK file that may contain comments in */
/* the appropriate SPC format, as written by SPCB2A or */
/* SPCB2T. This file must be opened for read access */
/* using the routine TXTOPR. */
/* This file may contain text that precedes and */
/* follows the SPK or CK data and comments, however, */
/* when calling this routine, the file pointer must be */
/* in a position in the file such that the next line */
/* returned by a READ statement is */
/* ''NAIF/DAF'' */
/* which marks the beginning of the data. */
/* BINARY is the name of a binary SPK or CK file to be created. */
/* The binary file contains the same data and comments */
/* as the text file, but in the binary format required */
/* for use with the SPICELIB reader subroutines. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Files */
/* 1) See arguments UNIT and BINARY above. */
/* 2) This routine uses a Fortran scratch file to temporarily */
/* store the lines of comments if there are any. */
/* $ Exceptions */
/* 1) If there is a problem opening or writing to the binary */
/* file, a routine that SPCT2B calls diagnoses and signals */
/* an error. */
/* 2) If there is a problem reading from the text file, the */
/* error SPICE(FILEREADFAILED) is signalled. */
/* 3) If there is a problem opening a scratch file, the error */
/* SPICE(FILEOPENERROR) is signalled. */
/* 4) If there is a problem writing to the scratch file, the */
/* error SPICE(FILEWRITEFAILED) is signalled. */
/* $ Particulars */
/* The SPICELIB SPK and CK reader subroutines read binary files. */
/* However, because different computing environments have different */
/* binary representations of numbers, you must convert SPK and CK */
/* files to text format when porting from one system to another. */
/* After converting the file to text, you can transfer it using */
/* a transfer protocol program like Kermit or FTP. Then, convert */
/* the text file back to binary format. */
/* The following is a list of the SPICELIB routines that convert */
/* SPK and CK files between binary and text format: */
/* SPCA2B converts text to binary. It opens the text file, */
/* creates a new binary file, and closes both files. */
/* SPCB2A converts binary to text. It opens the binary file, */
/* creates a new text file, and closes both files. */
/* SPCT2B converts text to binary. It creates a new binary */
/* file and closes it. The text file is open on */
/* entrance and exit. */
/* SPCB2T converts binary to text. It opens the binary */
/* file and closes it. The text file is open on */
/* entrance and exit */
/* See the SPC required reading for more information */
/* about SPC routines and the SPK and CK file formats. */
/* $ Examples */
/* 1) The following code fragment creates a text file containing */
/* text format SPK data and comments preceded and followed */
/* by a standard label. */
/* The SPICELIB routine TXTOPN opens a new text file and TXTOPR */
/* opens an existing text file for read access. TEXT and */
/* BINARY are character strings that contain the names of the */
/* text and binary files. */
/* CALL TXTOPN ( TEXT, UNIT ) */
/* (Write header label to UNIT) */
/* CALL SPCB2T ( BINARY, UNIT ) */
/* (Write trailing label to UNIT) */
/* CLOSE ( UNIT ) */
/* The following code fragment reconverts the text format */
/* SPK data and comments back into binary format. */
/* CALL TXTOPR ( TEXT, UNIT ) */
/* (Read, or just read past, header label from UNIT) */
/* CALL SPCT2B ( UNIT, BINARY ) */
/* (Read trailing label from UNIT, if desired ) */
/* CLOSE ( UNIT ) */
/* 2) Suppose three text format SPK files have been appended */
/* together into one text file called THREE.TSP. The following */
/* code fragment converts each set of data and comments into */
/* its own binary file. */
/* CALL TXTOPR ( 'THREE.TSP', UNIT ) */
/* CALL SPCT2B ( UNIT, 'FIRST.BSP' ) */
/* CALL SPCT2B ( UNIT, 'SECOND.BSP' ) */
/* CALL SPCT2B ( UNIT, 'THIRD.BSP' ) */
/* CLOSE ( UNIT ) */
/* $ Restrictions */
/* 1) This routine assumes that the data and comments in the */
/* text format SPK or CK file come from a binary file */
/* and were written by one of the routines SPCB2A or SPCB2T. */
/* Data and/or comments written any other way may not be */
/* in the correct format and, therefore, may not be handled */
/* properly. */
/* 2) Older versions of SPK and CK files did not have a comment */
/* area. These files, in text format, may still be converted */
/* to binary using SPCT2B. However, upon exit, the file pointer */
/* will not be in position ready to read the first line of text */
/* after the data. Instead, the next READ statement after */
/* calling SPCT2B will return the second line of text after */
/* the data. Therefore, example 1 may not work as desired */
/* if the trailing label begins on the first line after the */
/* data. To solve this problem, use DAFT2B instead of SPCT2B. */
/* 3) UNIT must be obtained via TXTOPR. Use TXTOPR to open text */
/* files for read access and get the logical unit. System */
/* dependencies regarding opening text files have been isolated */
/* in the routines TXTOPN and TXTOPR. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* J.E. McLean (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 05-APR-1991 (JEM) */
/* -& */
/* $ Index_Entries */
/* text spk or ck to binary */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SPCT2B", (ftnlen)6);
}
/* DAFT2B creates the new binary file and writes the data to */
/* it. If the 'NAIF/DAF' keyword is not the first line that */
/* it reads from the text file, it will signal an error. */
/* Initially, no records are reserved. */
daft2b_(unit, binary, &c__0, binary_len);
/* The comments follow the data and are surrounded by markers. */
/* BMARK should be the next line that we read. If it isn't, */
/* then this is an old file, created before the comment area */
/* existed. In this case, we've read one line too far, but */
/* we can't backspace because the file was written using list- */
/* directed formatting (See the ANSI standard). All we can do */
/* is check out, leaving the file pointer where it is, but */
/* that's better than signalling an error. */
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = *unit;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
iostat = do_fio(&c__1, line, (ftnlen)1000);
if (iostat != 0) {
goto L100001;
}
iostat = e_rsfe();
L100001:
if (iostat > 0) {
setmsg_("Error reading the text file named FNM. Value of IOSTAT is "
"#.", (ftnlen)61);
errint_("#", &iostat, (ftnlen)1);
errfnm_("FNM", unit, (ftnlen)3);
sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
i__1 = ltrim_(line, (ftnlen)1000) - 1;
if (s_cmp(line + i__1, "~NAIF/SPC BEGIN COMMENTS~", 1000 - i__1, (ftnlen)
25) != 0 || iostat < 0) {
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
/* We're not at the end of the file, and the line we read */
/* is BMARK, so we write the comments to a scratch file. */
/* We do this because we have to use SPCAC to add the comments */
/* to the comment area of the binary file, and SPCAC rewinds */
/* the file. It's okay for SPCAC to rewind a scratch file, */
/* but it's not okay to rewind the file connected to UNIT -- */
/* we don't know the initial location of the file pointer. */
getlun_(&scrtch);
o__1.oerr = 1;
o__1.ounit = scrtch;
o__1.ofnm = 0;
o__1.orl = 0;
o__1.osta = "SCRATCH";
o__1.oacc = "SEQUENTIAL";
o__1.ofm = "FORMATTED";
o__1.oblnk = 0;
iostat = f_open(&o__1);
if (iostat != 0) {
setmsg_("Error opening a scratch file. File name was FNM. Value of"
" IOSTAT is #.", (ftnlen)72);
errint_("#", &iostat, (ftnlen)1);
errfnm_("FNM", &scrtch, (ftnlen)3);
sigerr_("SPICE(FILEOPENERROR)", (ftnlen)20);
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
ci__1.cierr = 1;
ci__1.ciunit = scrtch;
ci__1.cifmt = "(A)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100002;
}
iostat = do_fio(&c__1, line, rtrim_(line, (ftnlen)1000));
if (iostat != 0) {
goto L100002;
}
iostat = e_wsfe();
L100002:
if (iostat != 0) {
setmsg_("Error writing to scratch file. File name is FNM. Value of "
"IOSTAT is #.", (ftnlen)71);
errint_("#", &iostat, (ftnlen)1);
errfnm_("FNM", &scrtch, (ftnlen)3);
sigerr_("SPICE(FILEWRITEFAILED)", (ftnlen)22);
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
/* Continue reading lines from the text file and storing them */
/* in the scratch file until we get to the end marker. */
for(;;) { /* while(complicated condition) */
i__1 = ltrim_(line, (ftnlen)1000) - 1;
if (!(s_cmp(line + i__1, "~NAIF/SPC END COMMENTS~", 1000 - i__1, (
ftnlen)23) != 0))
break;
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = *unit;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100003;
}
iostat = do_fio(&c__1, line, (ftnlen)1000);
if (iostat != 0) {
goto L100003;
}
iostat = e_rsfe();
L100003:
if (iostat != 0) {
setmsg_("Error reading the text file named FNM. Value of IOSTAT"
" is #.", (ftnlen)61);
errint_("#", &iostat, (ftnlen)1);
errfnm_("FNM", unit, (ftnlen)3);
sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
ci__1.cierr = 1;
ci__1.ciunit = scrtch;
ci__1.cifmt = "(A)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100004;
}
iostat = do_fio(&c__1, line, rtrim_(line, (ftnlen)1000));
if (iostat != 0) {
goto L100004;
}
iostat = e_wsfe();
L100004:
if (iostat != 0) {
setmsg_("Error writing to scratch file. File name is FNM. Valu"
"e of IOSTAT is #.", (ftnlen)72);
errint_("#", &iostat, (ftnlen)1);
errfnm_("FNM", &scrtch, (ftnlen)3);
sigerr_("SPICE(FILEWRITEFAILED)", (ftnlen)22);
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
}
/* Open the new binary file and add the comments that have been */
/* stored temporarily in a scratch file. */
dafopw_(binary, &handle, binary_len);
spcac_(&handle, &scrtch, "~NAIF/SPC BEGIN COMMENTS~", "~NAIF/SPC END COM"
"MENTS~", (ftnlen)25, (ftnlen)23);
/* Close the files. The scratch file is automatically deleted. */
dafcls_(&handle);
cl__1.cerr = 0;
cl__1.cunit = scrtch;
cl__1.csta = 0;
f_clos(&cl__1);
chkout_("SPCT2B", (ftnlen)6);
return 0;
} /* spct2b_ */
/* $Procedure SEPOOL ( String from pool ) */
/* Subroutine */ int sepool_(char *item, integer *fidx, char *contin, char *
string, integer *size, integer *lidx, logical *found, ftnlen item_len,
ftnlen contin_len, ftnlen string_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen), s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer comp;
logical more;
char part[80];
integer room, n;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer clast, csize;
logical gotit;
extern integer rtrim_(char *, ftnlen);
integer putat;
extern /* Subroutine */ int gcpool_(char *, integer *, integer *, integer
*, char *, logical *, ftnlen, ftnlen);
integer cfirst;
extern /* Subroutine */ int chkout_(char *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Retrieve the string starting at the FIDX element of the kernel */
/* pool variable, where the string may be continued across several */
/* components of the kernel pool variable. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* POOL */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ITEM I name of the kernel pool variable */
/* FIDX I index of the first component of the string */
/* CONTIN I character sequence used to indicate continuation */
/* STRING O a full string concatenated across continuations */
/* SIZE O the number of character in the full string value */
/* LIDX O index of the last component of the string */
/* FOUND O flag indicating success or failure of request */
/* $ Detailed_Input */
/* ITEM is the name of a kernel pool variable for which */
/* the caller wants to retrieve a full (potentially */
/* continued) string. */
/* FIDX is the index of the first component (the start) of */
/* the string in ITEM. */
/* CONTIN is a sequence of characters which (if they appear as */
/* the last non-blank sequence of characters in a */
/* component of a value of a kernel pool variable) */
/* indicate that the string associated with the */
/* component is continued into the next literal */
/* component of the kernel pool variable. */
/* If CONTIN is blank, all of the components of ITEM */
/* will be retrieved as a single string. */
/* $ Detailed_Output */
/* STRING is the full string starting at the FIDX element of the */
/* kernel pool variable specified by ITEM. */
/* Note that if STRING is not sufficiently long to hold */
/* the fully continued string, the value will be */
/* truncated. You can determine if STRING has been */
/* truncated by examining the variable SIZE. */
/* SIZE is the index of last non-blank character of */
/* continued string as it is represented in the */
/* kernel pool. This is the actual number of characters */
/* needed to hold the requested string. If STRING */
/* contains a truncated portion of the full string, */
/* RTRIM(STRING) will be less than SIZE. */
/* If the value of STRING should be a blank, then */
/* SIZE will be set to 1. */
/* LIDX is the index of the last component (the end) of */
/* the retrieved string in ITEM. */
/* FOUND is a logical variable indicating success of the */
/* request to retrieve the string. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the variable specified by ITEM is not present in the */
/* kernel pool or is present but is not character valued, STRING */
/* will be returned as a blank, SIZE will be returned with the */
/* value 0 and FOUND will be set to .FALSE. In particular if NTH */
/* is less than 1, STRING will be returned as a blank, SIZE will */
/* be zero and FOUND will be FALSE. */
/* 2) If the variable specified has a blank string associated */
/* with its full string starting at FIDX, STRING will be blank, */
/* SIZE will be 1 and FOUND will be set to .TRUE. */
/* 3) If STRING is not long enough to hold all of the characters */
/* associated with the NTH string, it will be truncated on the */
/* right. */
/* 4) If the continuation character is a blank, every component */
/* of the variable specified by ITEM will be inserted into */
/* the output string. */
/* 5) If the continuation character is blank, then a blank component */
/* of a variable is treated as a component with no letters. */
/* For example: */
/* STRINGS = ( 'This is a variable' */
/* 'with a blank' */
/* ' ' */
/* 'component.' ) */
/* Is equivalent to */
/* STRINGS = ( 'This is a variable' */
/* 'with a blank' */
/* 'component.' ) */
/* from the point of view of SEPOOL if CONTIN is set to the */
/* blank character. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The SPICE Kernel Pool provides a very convenient interface */
/* for supplying both numeric and textual data to user application */
/* programs. However, any particular component of a character */
/* valued component of a kernel pool variable is limited to 80 */
/* or fewer characters in length. */
/* This routine allows you to overcome this limitation by */
/* "continuing" a character component of a kernel pool variable. */
/* To do this you need to select a continuation sequence */
/* of characters and then insert this sequence as the last non-blank */
/* set of characters that make up the portion of the component */
/* that should be continued. */
/* For example, you may decide to use the sequence '//' to indicate */
/* that a string should be continued to the next component of */
/* a kernel pool variable. Then set up the */
/* kernel pool variable as shown below */
/* LONG_STRINGS = ( 'This is part of the first component //' */
/* 'that needs more than one line when //' */
/* 'inserting it into the kernel pool.' */
/* 'This is the second string that is split //' */
/* 'up as several components of a kernel pool //' */
/* 'variable.' ) */
/* When loaded into the kernel pool, the variable LONG_STRINGS */
/* will have six literal components: */
/* COMPONENT (1) = 'This is part of the first component //' */
/* COMPONENT (2) = 'that needs more than one line when //' */
/* COMPONENT (3) = 'inserting it into the kernel pool.' */
/* COMPONENT (4) = 'This is the second string that is split //' */
/* COMPONENT (5) = 'up as several components of a kernel pool //' */
/* COMPONENT (6) = 'variable.' */
/* These are the components that would be retrieved by the call */
/* CALL GCPOOL ( 'LONG_STRINGS', 1, 6, N, COMPONENT, FOUND ) */
/* However, using the routine SEPOOL you can view the variable */
/* LONG_STRINGS as having two long components. */
/* STRING (1) = 'This is part of the first component that ' */
/* . // 'needs more than one line when inserting ' */
/* . // 'it into the kernel pool. ' */
/* STRING (2) = 'This is the second string that is split ' */
/* . // 'up as several components of a kernel pool ' */
/* . // 'variable. ' */
/* These string components would be retrieved by the following two */
/* calls. */
/* FIDX = 1 */
/* CALL SEPOOL ( 'LONG_STRINGS', FIDX, '//', */
/* . STRING(1), SIZE, LIDX, FOUND ) */
/* FIDX = LIDX+1 */
/* CALL SEPOOL ( 'LONG_STRINGS', FIDX, '//', */
/* . STRING(2), SIZE, LIDX, FOUND ) */
/* $ Examples */
/* Example 1. Retrieving file names. */
/* Suppose a you have used the kernel pool as a mechanism for */
/* specifying SPK files to load at startup but that the full */
/* names of the files are too long to be contained in a single */
/* text line of a kernel pool assignment. */
/* By selecting an appropriate continuation character ('*' for */
/* example) you can insert the full names of the SPK files */
/* into the kernel pool and then retrieve them using this */
/* routine. */
/* First set up the kernel pool specification of the strings */
/* as shown here: */
/* SPK_FILES = ( 'this_is_the_full_path_specification_*' */
/* 'of_a_file_with_a_long_name' */
/* 'this_is_the_full_path_specification_*' */
/* 'of_a_second_file_with_a_very_long_*' */
/* 'name' ) */
/* Now to retrieve and load the SPK_FILES one at a time, */
/* exercise the following loop. */
/* INTEGER FILSIZ */
/* PARAMETER ( FILSIZ = 255 ) */
/* CHARACTER*(FILSIZ) FILE */
/* INTEGER I */
/* INTEGER LIDX */
/* I = 1 */
/* CALL SEPOOL ( 'SPK_FILES', I, '*', FILE, SIZE, LIDX, FOUND ) */
/* DO WHILE ( FOUND .AND. RTRIM(FILE) .EQ. SIZE ) */
/* CALL SPKLEF ( FILE, HANDLE ) */
/* I = LIDX + 1 */
/* CALL SEPOOL ( 'SPK_FILES', I, '*', FILE, SIZE, LIDX, FOUND ) */
/* END DO */
/* IF ( FOUND .AND. RTRIM(FILE) .NE. SIZE ) THEN */
/* WRITE (*,*) 'The ', I, '''th file name was too long.' */
/* END IF */
/* Example 2. Retrieving all components as a string. */
/* Occasionally, it may be useful to retrieve the entire */
/* contents of a kernel pool variable as a single string. To */
/* do this you can use the blank character as the */
/* continuation character. For example if you place the */
/* following assignment in a text kernel */
/* COMMENT = ( 'This is a long note ' */
/* ' about the intended ' */
/* ' use of this text kernel that ' */
/* ' can be retrieved at run time.' ) */
/* you can retrieve COMMENT as single string via the call below. */
/* CALL SEPOOL ( 'COMMENT', 1, ' ', COMMNT, SIZE, LIDX, FOUND ) */
/* The result will be that COMMNT will have the following value. */
/* COMMNT = 'This is a long note about the intended use of ' */
/* . // 'this text kernel that can be retrieved at run ' */
/* . // 'time. ' */
/* Note that the leading blanks of each component of COMMENT are */
/* significant, trailing blanks are not significant. */
/* If COMMENT had been set as */
/* COMMENT = ( 'This is a long note ' */
/* 'about the intended ' */
/* 'use of this text kernel that ' */
/* 'can be retrieved at run time.' ) */
/* Then the call to SEPOOL above would have resulted in several */
/* words being run together as shown below. */
/* COMMNT = 'This is a long noteabout the intendeduse of ' */
/* . // 'this text kernel thatcan be retrieved at run ' */
/* . // 'time. ' */
/* resulted in several words being run together as shown below. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 12-APR-2012 (WLT)(BVS) */
/* -& */
/* $ Index_Entries */
/* Retrieve a continued string value from the kernel pool */
/* -& */
/* SPICELIB Variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
/* Return empty output if the input index is bad. */
if (*fidx < 1) {
*found = FALSE_;
s_copy(string, " ", string_len, (ftnlen)1);
*size = 0;
*lidx = 0;
return 0;
}
/* Check in. */
chkin_("SEPOOL", (ftnlen)6);
/* Check if the first component exists. Return empty output if not. */
gcpool_(item, fidx, &c__1, &n, part, &gotit, item_len, (ftnlen)80);
gotit = gotit && n > 0;
if (! gotit) {
*found = FALSE_;
s_copy(string, " ", string_len, (ftnlen)1);
*size = 0;
*lidx = 0;
chkout_("SEPOOL", (ftnlen)6);
return 0;
}
/* Fetch the string using Bill's algorithm from STPOOL 'as is'. */
room = i_len(string, string_len);
csize = rtrim_(contin, contin_len);
putat = 1;
comp = *fidx;
more = TRUE_;
s_copy(string, " ", string_len, (ftnlen)1);
n = 0;
while(more) {
gcpool_(item, &comp, &c__1, &n, part, &more, item_len, (ftnlen)80);
more = more && n > 0;
if (more) {
*found = TRUE_;
clast = rtrim_(part, (ftnlen)80);
cfirst = clast - csize + 1;
if (cfirst < 0) {
if (putat <= room) {
s_copy(string + (putat - 1), part, string_len - (putat -
1), clast);
}
putat += clast;
more = FALSE_;
} else if (s_cmp(part + (cfirst - 1), contin, clast - (cfirst - 1)
, contin_len) != 0) {
if (putat <= room) {
s_copy(string + (putat - 1), part, string_len - (putat -
1), clast);
}
putat += clast;
more = FALSE_;
} else if (cfirst > 1) {
if (putat <= room) {
s_copy(string + (putat - 1), part, string_len - (putat -
1), cfirst - 1);
}
putat = putat + cfirst - 1;
}
}
++comp;
}
/* We are done. Get the size of the full string and the index of its */
/* last component and checkout. */
*size = putat - 1;
*lidx = comp - 1;
chkout_("SEPOOL", (ftnlen)6);
return 0;
} /* sepool_ */
/* $Procedure PODBEC ( Pod, begin and end, character ) */
/* Subroutine */ int podbec_(char *pod, integer *begin, integer *end, ftnlen
pod_len)
{
extern /* Subroutine */ int chkin_(char *, ftnlen), podonc_(char *,
integer *, integer *, ftnlen);
integer offset, number;
extern /* Subroutine */ int chkout_(char *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Return the indices of the initial and final elements of the */
/* active group of a pod. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* PODS */
/* $ Keywords */
/* ARRAYS */
/* CELLS */
/* PODS */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* POD I Pod. */
/* BEGIN O Index of initial item of active group of POD. */
/* END O Index of final item of active group of POD. */
/* $ Detailed_Input */
/* POD is a pod. */
/* $ Detailed_Output */
/* BEGIN, */
/* END are the indices of the initial and final elements of */
/* the active group of POD. That is, the active group */
/* is located in POD(BEGIN), POD(BEGIN+1), ..., POD(END). */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the active group of the pod contains no elements, */
/* END is equal to (BEGIN - 1). */
/* $ Files */
/* None. */
/* $ Particulars */
/* PODBE (begin and end) and PODON (offset and number) provide */
/* equivalent ways to access the elements of the active group */
/* of a pod. Note that there is no way to access any group other */
/* than the active group. */
/* $ Examples */
/* PODBE is typically used to process the elements of the active */
/* group of a pod one at a time, e.g., */
/* CALL PODBEC ( POD, BEGIN, END ) */
/* DO I = BEGIN, END */
/* CALL PROCESS ( ..., POD(I), ... ) */
/* END DO */
/* Note that if the elements are to be correlated with the elements */
/* of other arrays, PODON may be more convenient: */
/* CALL PODONC ( POD, OFFSET, N ) */
/* DO I = 1, N */
/* CALL PROCESS ( ..., POD(OFFSET+I), ARRAY(I), ... ) */
/* END DO */
/* Either one may be used when the group is to be passed to a */
/* subprogram as an array: */
/* CALL SUBPROG ( ..., POD(BEGIN), END-BEGIN+1, ... ) */
/* CALL SUBPROG ( ..., POD(OFFSET+1), N, ... ) */
/* $ Restrictions */
/* 1) In any pod, only the active group should be accessed, */
/* and its location should always be determined by PODBE */
/* or PODON. Never assume that the active group begins */
/* at POD(1). */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - Beta Version 1.0.0, 15-JUL-1989 (WLT) (IMU) */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("PODBEC", (ftnlen)6);
}
/* We'll cheat: why write the same code twice? */
podonc_(pod, &offset, &number, pod_len);
*begin = offset + 1;
*end = offset + number;
chkout_("PODBEC", (ftnlen)6);
return 0;
} /* podbec_ */
/* $Procedure DAFECU( DAF extract comments to a logical unit ) */
/* Subroutine */ int dafecu_(integer *handle, integer *comlun, logical *
comnts)
{
/* System generated locals */
inlist ioin__1;
/* Builtin functions */
integer f_inqu(inlist *);
/* Local variables */
extern /* Subroutine */ int dafec_(integer *, integer *, integer *, char *
, logical *, ftnlen), chkin_(char *, ftnlen);
extern logical failed_(void);
extern /* Subroutine */ int dafsih_(integer *, char *, ftnlen);
logical opened;
char combuf[1000*22];
extern /* Subroutine */ int sigerr_(char *, ftnlen);
integer numcom;
extern /* Subroutine */ int chkout_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen), writla_(integer *, char *, integer *, ftnlen);
logical gotsom;
extern logical return_(void);
logical eoc;
/* $ Abstract */
/* Extract comments from a previously opened binary DAF file to a */
/* previously opened text file attached to a Fortran logical unit. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* None. */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle of a DAF file opened with read access. */
/* COMLUN I Logical unit of an opened text file. */
/* COMNTS O Logical flag, indicating comments were found. */
/* $ Detailed_Input */
/* HANDLE The file handle for a binary DAF file that has been */
/* opened with read access. */
/* COMLUN The Fortran logical unit of a previously opened text */
/* file to which the comments from a binary DAF file are */
/* to be written. */
/* The comments will be placed into the text file beginning */
/* at the current location in the file and continuing */
/* until all of the comments from the comment area of the */
/* DAF file have been written. */
/* $ Detailed_Output */
/* COMNTS A logical flag indicating whether or not any comments */
/* were found in the comment area of a DAF file. COMNTS will */
/* have the value .TRUE. if there were some comments, and */
/* the value .FALSE. otherwise. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the input logical unit COMLUN is not positive or there */
/* is not an opened file attached to it, the error */
/* SPICE(INVALIDARGUMENT) will be signalled. */
/* 2) If the INQUIRE on the logical unit to see if there is a */
/* file attached fails, the error SPICE(INQUIREFAILED) will */
/* be signalled. */
/* 3) If an error occurs while reading from the binary DAF file */
/* attached to HANDLE, a routine called by this routine will */
/* signal an error. */
/* 4) If an error occurs while writing to the text file attached */
/* to COMLUN, a routine called by this routine will signal an */
/* error. */
/* $ Files */
/* See parameters COMLUN and HANDLE in the $ Detailed_Inputs section. */
/* $ Particulars */
/* This routine will extract all of the comments from the comment */
/* area of a binary DAF file, placing them into a text file */
/* attached to COMLUN beginning at the current position in the */
/* text file. If there are no comments in the DAF file, nothing is */
/* written to the text file attached to COMLUN. */
/* $ Examples */
/* Let */
/* HANDLE be the DAF file handle of a previously opened binary */
/* DAF file. */
/* COMLUN be the Fortran logical unit of a previously opened */
/* text file that is to accept the comments from the */
/* DAF comment area. */
/* The subroutine call */
/* CALL DAFECU ( HANDLE, COMLUN, COMNTS ) */
/* will extract the comments from the comment area of the binary */
/* DAF file attached to HANDLE, if there are any, and write them */
/* to the logical unit COMLUN. Upon successful completion, the */
/* value of COMNTS will be .TRUE. if there were some comments */
/* in the comment area of the DAF file and .FALSE. otherwise. */
/* $ Restrictions */
/* The maximum length of a single comment line in the comment area is */
/* specified by the parameter LINLEN defined below. Currently this */
/* value is 1000 characters. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* $ Version */
/* - Beta Version 1.1.1, 08-MAY-2001 (BVS) */
/* Buffer line size (LINLEN) was increased from 255 to 1000 */
/* characters to make it consistent the line size in SPC */
/* routines. */
/* - Beta Version 1.1.0, 18-JAN-1996 (KRG) */
/* Added a test and errors for checking to see whether COMLUN */
/* was actually attached to an ASCII text file when this routine */
/* was called. */
/* - Beta Version 1.0.0, 23-SEP-1994 (KRG) */
/* -& */
/* $ Index_Entries */
/* extract comments from a DAF to a logical unit */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Set the value for the maximum length of a text line. */
/* Set the size of the comment buffer. */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("DAFECU", (ftnlen)6);
}
/* Verify that the DAF file attached to HANDLE is opened for reading. */
dafsih_(handle, "READ", (ftnlen)4);
if (failed_()) {
chkout_("DAFECU", (ftnlen)6);
return 0;
}
/* Logical units must be positive. If it is not, signal an error. */
if (*comlun <= 0) {
setmsg_("# is not a valid logical unit. Logical units must be positi"
"ve.", (ftnlen)62);
errint_("#", comlun, (ftnlen)1);
sigerr_("SPICE(INVALIDARGUMENT)", (ftnlen)22);
chkout_("DAFECU", (ftnlen)6);
return 0;
}
/* Verify that there is an open ASCII text file attached to COMLUN. */
ioin__1.inerr = 1;
ioin__1.inunit = *comlun;
ioin__1.infile = 0;
ioin__1.inex = 0;
ioin__1.inopen = &opened;
ioin__1.innum = 0;
ioin__1.innamed = 0;
ioin__1.inname = 0;
ioin__1.inacc = 0;
ioin__1.inseq = 0;
ioin__1.indir = 0;
ioin__1.infmt = 0;
ioin__1.inform = 0;
ioin__1.inunf = 0;
ioin__1.inrecl = 0;
ioin__1.innrec = 0;
ioin__1.inblank = 0;
iostat = f_inqu(&ioin__1);
if (iostat != 0) {
setmsg_("The INQUIRE on logical unit # failed. The value of IOSTAT w"
"as #.", (ftnlen)64);
errint_("#", comlun, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(INQUIREFAILED)", (ftnlen)20);
chkout_("DAFECU", (ftnlen)6);
return 0;
}
if (! opened) {
setmsg_("There is no open file attached to logical unit #, so no com"
"ments could be written.", (ftnlen)82);
errint_("#", comlun, (ftnlen)1);
sigerr_("SPICE(INVALIDARGUMENT)", (ftnlen)22);
chkout_("DAFECU", (ftnlen)6);
return 0;
}
/* Initialize some things before the loop. */
numcom = 0;
eoc = FALSE_;
gotsom = FALSE_;
while(! eoc) {
/* While we have not reached the end of the comments, get some */
/* more. */
dafec_(handle, &c__22, &numcom, combuf, &eoc, (ftnlen)1000);
if (failed_()) {
chkout_("DAFECU", (ftnlen)6);
return 0;
}
if (numcom > 0) {
/* If NUMCOM .GT. 0 then we did get some comments, and we need */
/* to write them out, but first, set the flag indicating that */
/* we got some comments. */
if (! gotsom) {
gotsom = TRUE_;
}
writla_(&numcom, combuf, comlun, (ftnlen)1000);
if (failed_()) {
chkout_("DAFECU", (ftnlen)6);
return 0;
}
}
}
/* Set the output flag indicating whether or not we got any comments. */
*comnts = gotsom;
chkout_("DAFECU", (ftnlen)6);
return 0;
} /* dafecu_ */
/* $Procedure PARSDO ( Parsing of DATA_ORDER string ) */
/* Subroutine */ int parsdo_(char *line, char *doval, integer *nval, integer *
param, integer *nparam, ftnlen line_len, ftnlen doval_len)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer i__, l;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
char value[12];
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen),
lastnb_(char *, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int nextwd_(char *, char *, char *, ftnlen,
ftnlen, ftnlen), setmsg_(char *, ftnlen), sigerr_(char *, ftnlen),
chkout_(char *, ftnlen);
/* $ Abstract */
/* This routine is a module of the MKSPK program. It parses the */
/* DATA_ORDER value provided in a setup file and forms an array */
/* of indexes of recognizable input parameters contaned in it. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* MKSPK User's Guide */
/* $ Keywords */
/* PARSING */
/* $ Declarations */
/* $ Abstract */
/* MKSPK Include File. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Author_and_Institution */
/* N.G. Khavenson (IKI RAS, Russia) */
/* B.V. Semenov (NAIF, JPL) */
/* $ Version */
/* - Version 1.2.0, 16-JAN-2008 (BVS). */
/* Added ETTMWR parameter */
/* - Version 1.1.0, 05-JUN-2001 (BVS). */
/* Added MAXDEG parameter. */
/* - Version 1.0.4, 21-MAR-2001 (BVS). */
/* Added parameter for command line flag '-append' indicating */
/* that appending to an existing output file was requested. */
/* Added corresponding setup file keyword ('APPEND_TO_OUTPUT'.) */
/* Added parameters for yes and no values of this keyword. */
/* - Version 1.0.3, 28-JAN-2000 (BVS). */
/* Added parameter specifying number of supported input data */
/* types and parameter specifying number of supported output SPK */
/* types */
/* - Version 1.0.2, 22-NOV-1999 (NGK). */
/* Added parameters for two-line elements processing. */
/* - Version 1.0.1, 18-MAR-1999 (BVS). */
/* Added usage, help and template displays. Corrected comments. */
/* - Version 1.0.0, 8-SEP-1998 (NGK). */
/* -& */
/* Begin Include Section: MKSPK generic parameters. */
/* Maximum number of states allowed per one segment. */
/* String size allocation parameters */
/* Length of buffer for input text processing */
/* Length of a input text line */
/* Length of file name and comment line */
/* Length of string for keyword value processing */
/* Length of string for word processing */
/* Length of data order parameters string */
/* Length of string reserved as delimiter */
/* Numbers of different parameters */
/* Maximum number of allowed comment lines. */
/* Reserved number of input parameters */
/* Full number of delimiters */
/* Number of delimiters that may appear in time string */
/* Command line flags */
/* Setup file keywords reserved values */
/* Standard YES and NO values for setup file keywords. */
/* Number of supported input data types and input DATA TYPE */
/* reserved values. */
/* Number of supported output SPK data types -- this version */
/* supports SPK types 5, 8, 9, 10, 12, 13, 15 and 17. */
/* End of input record marker */
/* Maximum allowed polynomial degree. The value of this parameter */
/* is consistent with the ones in SPKW* routines. */
/* Special time wrapper tag for input times given as ET seconds past */
/* J2000 */
/* End Include Section: MKSPK generic parameters. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- ---------------------------------------------- */
/* LINE I DATA_ORDER string */
/* DOVAL I Array of recognizable input parameter names */
/* NVAL I Number of recognizable input parameters */
/* PARAM O Array of parameter IDs present in DATA_ORDER */
/* NPARAM O Number of elements in PARAM */
/* $ Detailed_Input */
/* LINE is the DATA_ORDER value that will be parsed. */
/* DOVAL is an array containing complete set recognizable */
/* input parameters (see main module for the current */
/* list). */
/* NVAL is the total number of recognizable input parameters */
/* (number of elements in DOVAL). */
/* $ Detailed_Output */
/* PARAM is an integer array containing indexes of the */
/* recognizable input parameters present in the input */
/* DATA_ORDER value in the order in which they are */
/* provided in that value. */
/* NPARAM is the number of elements in PARAM. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If token in the data order is not recognized, then the */
/* error 'SPICE(BADDATAORDERTOKEN)' will be signalled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This subroutine parses DATA_ORDER string containing names of */
/* input data record parameters in the order in which they appear */
/* in the input records and returns an integer array of the indexes */
/* of the parameters that were found in the string. */
/* $ Examples */
/* Let DATA_ORDER has following value: */
/* LINE = 'EPOCH X Y Z SKIP VX VY VZ' */
/* and DOVAL array contains the following values: */
/* DOVAL(1) = 'EPOCH' */
/* DOVAL(2) = 'X' */
/* DOVAL(3) = 'Y' */
/* DOVAL(4) = 'Z' */
/* DOVAL(5) = 'VX' */
/* DOVAL(6) = 'VY' */
/* DOVAL(7) = 'VZ' */
/* ... */
/* DOVAL(30) = 'SKIP' */
/* Then after parsing we will have on the output: */
/* NPARAM = 8 */
/* PARAM = 1, 2, 3, 4, 30, 5, 6, 7 */
/* $ Restrictions */
/* Because search for a parameter in the DATA_ORDER value is case */
/* sensitive, the DATA_ORDER value and parameter names must be */
/* in the same case (nominally uppercase). */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.G. Khavenson (IKI RAS, Russia) */
/* B.V. Semenov (NAIF, JPL) */
/* $ Version */
/* - Version 1.0.3, 29-MAR-1999 (NGK). */
/* Corrected examples section. */
/* - Version 1.0.2, 18-MAR-1999 (BVS). */
/* Corrected comments. */
/* - Version 1.0.1, 13-JAN-1999 (BVS). */
/* Modified error messages. */
/* - Version 1.0.0, 08-SEP-1998 (NGK). */
/* -& */
/* $ Index_Entries */
/* Parse MKSPK setup DATA_ORDER string. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Size VALUEL declared in the include file. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("PARSDO", (ftnlen)6);
}
/* Assign zero to PARAM array. */
i__1 = *nval;
for (l = 1; l <= i__1; ++l) {
param[l - 1] = 0;
}
/* Reset counter of words on line. */
*nparam = 0;
while(lastnb_(line, line_len) != 0) {
/* Get next word from the line. Value is already uppercase. */
nextwd_(line, value, line, line_len, (ftnlen)12, line_len);
i__ = isrchc_(value, nval, doval, (ftnlen)12, doval_len);
/* Look whether this value is one of the reserved values. */
if (i__ != 0) {
/* This value is OK. Memorize it. */
++(*nparam);
param[*nparam - 1] = i__;
} else {
/* We can not recognize this value. */
setmsg_("Can not recognize token '#' in the value of the setup f"
"ile keyword '#'. Refer to the User's Guide for the progr"
"am for complete list of allowed tokens.", (ftnlen)150);
errch_("#", value, (ftnlen)1, (ftnlen)12);
errch_("#", "DATA_ORDER", (ftnlen)1, (ftnlen)10);
sigerr_("SPICE(BADDATAORDERTOKEN)", (ftnlen)24);
}
}
chkout_("PARSDO", (ftnlen)6);
return 0;
} /* parsdo_ */
/* $Procedure ZZEKCIX1 ( EK, create index, type 1 ) */
/* Subroutine */ int zzekcix1_(integer *handle, integer *coldsc)
{
extern /* Subroutine */ int zzekpgch_(integer *, char *, ftnlen),
zzektrit_(integer *, integer *), chkin_(char *, ftnlen);
extern logical failed_(void);
extern /* Subroutine */ int chkout_(char *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Create a new type 1 index for a specified EK column. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* PRIVATE */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Column Descriptor Parameters */
/* ekcoldsc.inc Version 6 23-AUG-1995 (NJB) */
/* Note: The column descriptor size parameter CDSCSZ is */
/* declared separately in the include section CDSIZE$INC.FOR. */
/* Offset of column descriptors, relative to start of segment */
/* integer address range. This number, when added to the last */
/* integer address preceding the segment, yields the DAS integer */
/* base address of the first column descriptor. Currently, this */
/* offset is exactly the size of a segment descriptor. The */
/* parameter SDSCSZ, which defines the size of a segment descriptor, */
/* is declared in the include file eksegdsc.inc. */
/* Size of column descriptor */
/* Indices of various pieces of column descriptors: */
/* CLSIDX is the index of the column's class code. (We use the */
/* word `class' to distinguish this item from the column's data */
/* type.) */
/* TYPIDX is the index of the column's data type code (CHR, INT, DP, */
/* or TIME). The type is actually implied by the class, but it */
/* will frequently be convenient to look up the type directly. */
/* LENIDX is the index of the column's string length value, if the */
/* column has character type. A value of IFALSE in this element of */
/* the descriptor indicates that the strings have variable length. */
/* SIZIDX is the index of the column's element size value. This */
/* descriptor element is meaningful for columns with fixed-size */
/* entries. For variable-sized columns, this value is IFALSE. */
/* NAMIDX is the index of the base address of the column's name. */
/* IXTIDX is the data type of the column's index. IXTIDX */
/* contains a type value only if the column is indexed. For columns */
/* that are not indexed, the location IXTIDX contains the boolean */
/* value IFALSE. */
/* IXPIDX is a pointer to the column's index. IXTPDX contains a */
/* meaningful value only if the column is indexed. The */
/* interpretation of the pointer depends on the data type of the */
/* index. */
/* NFLIDX is the index of a flag indicating whether nulls are */
/* permitted in the column. The value at location NFLIDX is */
/* ITRUE if nulls are permitted and IFALSE otherwise. */
/* ORDIDX is the index of the column's ordinal position in the */
/* list of columns belonging to the column's parent segment. */
/* METIDX is the index of the column's integer metadata pointer. */
/* This pointer is a DAS integer address. */
/* The last position in the column descriptor is reserved. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Column Descriptor Parameters */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I File handle. */
/* COLDSC I Column descriptor. */
/* $ Detailed_Input */
/* HANDLE is a file handle of an EK that is open for write */
/* access. */
/* COLDSC is the column descriptor of the column for */
/* which the index is to be created. */
/* $ Detailed_Output */
/* None. See $Particulars for a description of the effect of this */
/* routine. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If HANDLE is invalid, the error will be diagnosed by routines */
/* called by this routine. */
/* 2) If an I/O error occurs while reading or writing the indicated */
/* file, the error will be diagnosed by routines called by this */
/* routine. */
/* $ Files */
/* See the EK Required Reading for a discussion of the EK file */
/* format. */
/* $ Particulars */
/* This routine operates by side effects: it creates a new, empty */
/* type 1 index for a specified EK column. Though this routine */
/* does not require a segment to be specified, normally indexes */
/* are created for columns belonging to specific segments. */
/* Type 1 indexes are implemented as DAS B*-trees. The data */
/* pointers of an index tree contain record numbers. Therefore, the */
/* tree implements an abstract order vector. */
/* In order to support the capability of creating an index for a */
/* column that has already been populated with data, this routine */
/* does not check that the specified column is empty. The caller */
/* must populate the index appropriately to reflect the order of */
/* elements in the associated column. */
/* $ Examples */
/* See EKBSEG. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - Beta Version 1.0.0, 06-NOV-1995 (NJB) */
/* -& */
/* SPICELIB functions */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZEKCIX1", (ftnlen)8);
}
/* Before trying to actually write anything, do every error */
/* check we can. */
/* Is this file handle valid--is the file open for paged write */
/* access? Signal an error if not. */
zzekpgch_(handle, "WRITE", (ftnlen)5);
if (failed_()) {
chkout_("ZZEKCIX1", (ftnlen)8);
return 0;
}
/* An empty type 1 segment is just an empty B*-tree. The root */
/* page number of the tree serves as the index pointer. */
coldsc[5] = 1;
zzektrit_(handle, &coldsc[6]);
chkout_("ZZEKCIX1", (ftnlen)8);
return 0;
} /* zzekcix1_ */
/* $Procedure LS ( Return L_s, planetocentric longitude of the sun ) */
doublereal ls_(integer *body, doublereal *et, char *corr, ftnlen corr_len)
{
/* System generated locals */
integer i__1, i__2;
doublereal ret_val;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
doublereal tipm[9] /* was [3][3] */;
extern /* Subroutine */ int vequ_(doublereal *, doublereal *);
integer i__;
doublereal x[3], y[3], z__[3];
extern /* Subroutine */ int chkin_(char *, ftnlen);
doublereal uavel[3], npole[3], state[6], trans[9] /* was [3][3] */;
extern /* Subroutine */ int spkez_(integer *, doublereal *, char *, char *
, integer *, doublereal *, doublereal *, ftnlen, ftnlen), ucrss_(
doublereal *, doublereal *, doublereal *);
doublereal lt;
extern /* Subroutine */ int reclat_(doublereal *, doublereal *,
doublereal *, doublereal *), tipbod_(char *, integer *,
doublereal *, doublereal *, ftnlen);
doublereal radius;
extern /* Subroutine */ int chkout_(char *, ftnlen);
extern logical return_(void);
doublereal lat, pos[3];
extern /* Subroutine */ int mxv_(doublereal *, doublereal *, doublereal *)
;
/* $ Abstract */
/* Compute L_s, the planetocentric longitude of the sun, as seen */
/* from a specified body. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* GEOMETRY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* BODY I NAIF integer code of central body. */
/* ET I Epoch in ephemeris seconds past J2000. */
/* CORR I Aberration correction. */
/* The function returns the value of L_s for the specified body */
/* at the specified time. */
/* $ Detailed_Input */
/* BODY is the NAIF integer code of the central body, */
/* typically a planet. */
/* ET is the epoch in ephemeris seconds past J2000 at which */
/* the longitude of the sun (L_s) is to be computed. */
/* CORR indicates the aberration corrections to be applied */
/* when computing the longitude of the sun. CORR */
/* may be any of the following. */
/* 'NONE' Apply no correction. */
/* 'LT' Correct the position of the sun, */
/* relative to the central body, for */
/* planetary (light time) aberration. */
/* 'LT+S' Correct the position of the sun, */
/* relative to the central body, for */
/* planetary and stellar aberrations. */
/* $ Detailed_Output */
/* The function returns the value of L_s for the specified body */
/* at the specified time. This is the longitude of the Sun, */
/* relative to the central body, in a right-handed frame whose */
/* basis vectors are defined as follows: */
/* - The positive Z direction is given by the instantaneous */
/* angular velocity vector of the orbit of the body about */
/* the sun. */
/* - The positive X direction is that of the cross product of the */
/* instantaneous north spin axis of the body with the positive */
/* Z direction. */
/* - The positive Y direction is Z x X. */
/* Units are radians; the range is -pi to pi. Longitudes are */
/* positive east. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If no SPK (ephemeris) file has been loaded prior to calling */
/* this routine, or if the SPK data has insufficient coverage, an */
/* error will be diagnosed and signaled by a routine in the call */
/* tree of this routine. */
/* 2) If a PCK file containing rotational elements for the central */
/* body has not been loaded prior to calling this routine, an */
/* error will be diagnosed and signaled by a routine called by a */
/* routine in the call tree of this routine. */
/* 3) If the instantaneous angular velocity and spin axis of BODY */
/* are parallel, the return value is unspecified. */
/* $ Files */
/* 1) An SPK file (or file) containing ephemeris data sufficient to */
/* compute the geometric state of the central body relative to */
/* the sun at ET must be loaded before this routine is called. If */
/* light time correction is used, data must be available that */
/* enable computation of the state the sun relative to the solar */
/* system barycenter at the light-time corrected epoch. If */
/* stellar aberration correction is used, data must be available */
/* that enable computation of the state the central body relative */
/* to the solar system barycenter at ET. */
/* 2) A PCK file containing rotational elements for the central body */
/* must be loaded before this routine is called. */
/* $ Particulars */
/* The direction of the vernal equinox for the central body is */
/* determined from the instantaneous equatorial and orbital planes */
/* of the central body. This equinox definition is specified in */
/* reference [1]. The "instantaneous orbital plane" is interpreted */
/* in this routine as the plane normal to the cross product of the */
/* position and velocity of the central body relative to the sun. */
/* A geometric state is used for this normal vector computation. */
/* The "instantaneous equatorial plane" is that normal to the */
/* central body's north pole at the requested epoch. The pole */
/* direction is determined from rotational elements loaded via */
/* a PCK file. */
/* The result returned by this routine will depend on the */
/* ephemeris data and rotational elements used. The result may */
/* differ from that given in any particular version of the */
/* Astronomical Almanac, due to differences in these input data, */
/* and due to differences in precision of the computations. */
/* $ Examples */
/* 1) A simple program that computes L_s for Mars. The geometric */
/* state of the sun is used. */
/* PROGRAM MARS_LS */
/* IMPLICIT NONE */
/* DOUBLE PRECISION DPR */
/* INTEGER FILSIZ */
/* PARAMETER ( FILSIZ = 255 ) */
/* CHARACTER*(FILSIZ) PCK */
/* CHARACTER*(FILSIZ) SPK */
/* CHARACTER*(FILSIZ) LEAP */
/* CHARACTER*(30) UTC */
/* CHARACTER*(15) CORR */
/* DOUBLE PRECISION ET */
/* DOUBLE PRECISION LONG */
/* DOUBLE PRECISION LS */
/* INTEGER BODY */
/* INTEGER HANDLE */
/* DATA BODY / 499 / */
/* DATA CORR / 'NONE' / */
/* CALL PROMPT ( 'Enter name of leapseconds kernel > ', LEAP ) */
/* CALL PROMPT ( 'Enter name of PCK file > ', PCK ) */
/* CALL PROMPT ( 'Enter name of SPK file > ', SPK ) */
/* CALL FURNSH ( LEAP ) */
/* CALL FURNSH ( PCK ) */
/* CALL FURNSH ( SPK ) */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Kernels have been loaded.' */
/* WRITE (*,*) ' ' */
/* DO WHILE ( .TRUE. ) */
/* CALL PROMPT ( 'Enter UTC time > ', UTC ) */
/* CALL UTC2ET ( UTC, ET ) */
/* C */
/* C Convert longitude to degrees and move it into the range */
/* C [0, 360). */
/* C */
/* LONG = DPR() * LS ( BODY, ET, CORR ) */
/* IF ( LONG .LT. 0.D0 ) THEN */
/* LONG = LONG + 360.D0 */
/* END IF */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Mars L_s (deg.) = ', LONG */
/* WRITE (*,*) ' ' */
/* END DO */
/* END */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* [1] "The Astronomical Almanac for the Year 2005." U.S. Government */
/* Printing Office, Washington, D.C., 1984, page L9. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - Chronos Version 1.1.2, 02-OCT-2006 (BVS) */
/* Replaced LDPOOL and SPKELF with FURNSH in the Examples */
/* section. */
/* - Chronos Version 1.1.1, 07-JAN-2005 (NJB) */
/* Description of reference frame in Detailed_Output header */
/* section was corrected. Miscellaneous other header updates */
/* were made. */
/* - Beta Version 1.1.0, 14-DEC-1996 (NJB) */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
ret_val = 0.;
return ret_val;
} else {
chkin_("LS", (ftnlen)2);
}
/* Look up the direction of the North pole of the central body. */
tipbod_("J2000", body, et, tipm, (ftnlen)5);
for (i__ = 1; i__ <= 3; ++i__) {
npole[(i__1 = i__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge("npole", i__1,
"ls_", (ftnlen)302)] = tipm[(i__2 = i__ * 3 - 1) < 9 && 0 <=
i__2 ? i__2 : s_rnge("tipm", i__2, "ls_", (ftnlen)302)];
}
/* Get the geometric state of the body relative to the sun. */
spkez_(body, et, "J2000", "NONE", &c__10, state, <, (ftnlen)5, (ftnlen)
4);
/* Get the unit direction vector parallel to the angular velocity */
/* vector of the orbit. This is just the unitized cross product of */
/* position and velocity. */
ucrss_(state, &state[3], uavel);
/* We want to form a transformation matrix that maps vectors from */
/* basis REF to the following frame: */
/* Z = UAVEL */
/* X = NPOLE x UAVEL */
/* Y = Z x X */
/* We'll find the position of the Sun relative to this frame. In */
/* our computations, we want our basis vectors to have unit length. */
vequ_(uavel, z__);
ucrss_(npole, z__, x);
ucrss_(z__, x, y);
for (i__ = 1; i__ <= 3; ++i__) {
trans[(i__1 = i__ * 3 - 3) < 9 && 0 <= i__1 ? i__1 : s_rnge("trans",
i__1, "ls_", (ftnlen)335)] = x[(i__2 = i__ - 1) < 3 && 0 <=
i__2 ? i__2 : s_rnge("x", i__2, "ls_", (ftnlen)335)];
trans[(i__1 = i__ * 3 - 2) < 9 && 0 <= i__1 ? i__1 : s_rnge("trans",
i__1, "ls_", (ftnlen)336)] = y[(i__2 = i__ - 1) < 3 && 0 <=
i__2 ? i__2 : s_rnge("y", i__2, "ls_", (ftnlen)336)];
trans[(i__1 = i__ * 3 - 1) < 9 && 0 <= i__1 ? i__1 : s_rnge("trans",
i__1, "ls_", (ftnlen)337)] = z__[(i__2 = i__ - 1) < 3 && 0 <=
i__2 ? i__2 : s_rnge("z", i__2, "ls_", (ftnlen)337)];
}
/* Get the state of the sun in frame REF. Since we may be using */
/* aberration corrections, this is not necessarily the negative of */
/* the state we've just found. */
spkez_(&c__10, et, "J2000", corr, body, state, <, (ftnlen)5, corr_len);
/* Now transform the position of the Sun into the "equator and */
/* equinox" frame. */
mxv_(trans, state, pos);
/* Let RECLAT find the longitude LS for us. */
reclat_(pos, &radius, &ret_val, &lat);
chkout_("LS", (ftnlen)2);
return ret_val;
} /* ls_ */
/* $Procedure ZZEKREQI ( Private: EK, read from encoded query, integer ) */
/* Subroutine */ int zzekreqi_(integer *eqryi, char *name__, integer *value,
ftnlen name_len)
{
/* Initialized data */
static char namlst[32*15] = "ARCHITECTURE " "INITIALI"
"ZED " "PARSED "
"NAMES_RESOLVED " "TIMES_RESOLVED "
" " "SEM_CHECKED " "NUM_TABLES "
" " "NUM_CONJUNCTIONS " "NUM_CONSTRAINTS "
" " "NUM_SELECT_COLS " "NUM_ORDERB"
"Y_COLS " "NUM_BUF_SIZE " "FREE"
"_NUM " "CHR_BUF_SIZE "
"FREE_CHR ";
static integer namidx[15] = { 2,3,4,5,6,7,8,10,9,12,11,13,14,15,16 };
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
static integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen), errch_(char *, char *, ftnlen, ftnlen), ljust_(
char *, char *, ftnlen, ftnlen);
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
static char tmpnam[32];
extern /* Subroutine */ int setmsg_(char *, ftnlen), sigerr_(char *,
ftnlen), chkout_(char *, ftnlen);
/* $ Abstract */
/* SPICE Private routine intended solely for the support of SPICE */
/* routines. Users should not call this routine directly due */
/* to the volatile nature of this routine. */
/* Read scalar integer value from encoded EK query. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* EK */
/* $ Keywords */
/* EK */
/* PRIVATE */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Encoded Query Internal Parameters */
/* ekquery.inc Version 3 16-NOV-1995 (NJB) */
/* Updated to reflect increased value of MAXCON in */
/* ekqlimit.inc. */
/* ekquery.inc Version 2 03-AUG-1995 (NJB) */
/* Updated to support representation of the SELECT clause. */
/* ekquery.inc Version 1 12-JAN-1995 (NJB) */
/* An encoded EK query is an abstract data type implemented */
/* as an integer cell, along with a double precision cell and */
/* a character string. The d.p. cell and string contain numeric */
/* and string values from the query string represented by the */
/* encoded query. */
/* The parameters in this file are intended for use only by the */
/* EK encoded query access routines. Callers of EK routines should */
/* not use these parameters. */
/* The following parameters are indices of specified elements */
/* in the integer portion of the encoded query. */
/* Encoded query architecture type: */
/* `Name resolution' consists of: */
/* - Verifying existence of tables: any table names listed */
/* in the FROM clause of a query must be loaded. */
/* - Validating table aliases used to qualify column names. */
/* - Verifying existence of columns and obtaining data types */
/* for columns. */
/* - Setting data type codes for literal values in the encoded */
/* query. */
/* - Checking consistency of operators and operand data types. */
/* - Making sure unqualified column names are unambiguous. */
/* - For constraints, mapping the table names used to qualify */
/* column names to the ordinal position in the FROM clause */
/* of the corresponding table. */
/* Initialization status---this flag indicates whether the encoded */
/* query has been initialized. Values are ITRUE or IFALSE. See the */
/* include file ekbool.inc for parameter values. */
/* Parse status---this flag indicates whether the parsing operation */
/* that produced an encoded query has been completed. Values are */
/* ITRUE or IFALSE. */
/* Name resolution status---this flag indicates whether names */
/* have been resolved in an encoded query. Values are ITRUE or */
/* IFALSE. */
/* Time resolution status---this flag indicates whether time values */
/* have been resolved in an encoded query. Time resolution */
/* consists of converting strings representing time values to ET. */
/* Values of the status are ITRUE or IFALSE. */
/* Semantic check status---this flag indicates whether semantic */
/* checking of constraints has been performed. */
/* Number of tables specified in FROM clause: */
/* Number of constraints in query: */
/* A special value is used to indicate the `maximal' constraint--- */
/* one that logically cannot be satisfied. If the constraints */
/* are equivalent to the maximal constraint, the location EQNCNS */
/* is assigned the value EQMXML */
/* Number of constraint conjunctions: */
/* Number of order-by columns: */
/* Number of SELECT columns: */
/* Size of double precision buffer: */
/* `Free' pointer into double precision buffer: */
/* Size of character string buffer: */
/* `Free' pointer into character string buffer: */
/* The following four base pointers will be valid after a query */
/* has been parsed: */
/* Base pointer for SELECT column descriptors: */
/* Base pointer for constraint descriptors: */
/* Base pointer for conjunction sizes: */
/* Base pointer for order-by column descriptors: */
/* After the quantities named above, the integer array contains */
/* series of descriptors for tables, constraints, and order-by */
/* columns, as well as a list of `conjunction sizes'---that is, */
/* the sizes of the groups of constraints that form conjunctions, */
/* after the input query has been re-arranged as a disjunction of */
/* conjunctions of constraints. */
/* The offsets of specific elements within descriptors are */
/* parameterized. The base addresses of the descriptors themselves */
/* must be calculated using the counts and sizes of the items */
/* preceding them. */
/* A diagram of the structure of the variable-size portion of the */
/* integer array is shown below: */
/* +-------------------------------------+ */
/* | Fixed-size portion of encoded query | */
/* +-------------------------------------+ */
/* | Encoded FROM clause | */
/* +-------------------------------------+ */
/* | Encoded constraint clause | */
/* +-------------------------------------+ */
/* | Conjunction sizes | */
/* +-------------------------------------+ */
/* | Encoded ORDER BY clause | */
/* +-------------------------------------+ */
/* | Encoded SELECT clause | */
/* +-------------------------------------+ */
/* Value Descriptors */
/* ---------------- */
/* In order to discuss the various descriptors below, we'll make use */
/* of sub-structures called `value descriptors'. These descriptors */
/* come in two flavors: character and double precision. For */
/* strings, a descriptor is a set of begin and end pointers that */
/* indicate the location of the string in the character portion of an */
/* encoded query, along with the begin and end pointers for the */
/* corresponding lexeme in the original query. The pointers are set */
/* to zero when they are not in use, for example if they refer to an */
/* optional lexeme that did not appear in the input query. */
/* All value descriptors start with a data type indicator; values */
/* are from ektype.inc. Integer and time values are referred to */
/* by double precision descriptors. */
/* Parameters for string value descriptor elements: */
/* Numeric value descriptors are similar to those for string values, */
/* the difference being that they have only one pointer to the value */
/* they represent. This pointer is the index of the value in the */
/* encoded query's numeric buffer. */
/* All value descriptors have the same size. In order to allow */
/* table descriptors to have the same size as value descriptors, */
/* we include an extra element in the descriptor. */
/* Column Descriptors */
/* ----------------- */
/* Each column descriptor consists of a character descriptor for the */
/* name of the column, followed by an index, which gives the ordinal */
/* position of the column in the logical table to which the column */
/* belongs. The index element is filled in during name resolution. */
/* Table Descriptors */
/* ----------------- */
/* Each table descriptor consists of a character descriptor for the */
/* name of the table, followed by an index, which gives the ordinal */
/* position of the table in the FROM clause in the original query. */
/* The index element is filled in during name resolution. Aliases */
/* and table names have identical descriptor structures. */
/* Constraint descriptors */
/* ------------------ */
/* Each constraint is characterized by: */
/* - A code indicating whether the constraint compares values */
/* in two columns or the value in a column and a literal */
/* value. The values of this element are EQCOL and EQVAL. */
/* - A descriptor for the table used to qualify the */
/* column name on the left side of the constraint. */
/* - A character value descriptor for the column name on the left */
/* side of the query. */
/* - An operator code indicating the relational operator used */
/* in the constraint. */
/* If the constraint compares values from two columns, the */
/* next items are table and column name descriptors that apply to */
/* the column named on the right side of the relational operator. */
/* If the constraint has a literal value on the right side, the */
/* operator code is followed by... */
/* - a value descriptor. */
/* - Size of a constraint descriptor: */
/* Conjunction sizes */
/* ----------------- */
/* The size of each conjunction of constraints occupies a single */
/* integer. */
/* Order-by Column Descriptors */
/* --------------------------- */
/* Each order-by column descriptor contains descriptors for */
/* the table containing the column and for the name of the column */
/* itself; one additional element is used to indicate the direction */
/* of the ordering (ascending vs descending). */
/* - The last integer in the descriptor indicates whether the */
/* order direction is ascending or descending. */
/* - Size of an order-by column descriptor: */
/* Codes indicating sense of ordering (ascending vs descending): */
/* SELECT Column Descriptors */
/* --------------------------- */
/* Each SELECT column descriptor contains descriptors for */
/* the table containing the column and for the name of the column */
/* itself. */
/* - Size of a SELECT column descriptor: */
/* Miscellaneous parameters: */
/* EQIMIN is the minimum size of the integer portion of */
/* an encoded query. EQIMIN depends on the parameters */
/* MAXTAB */
/* MAXCON */
/* MAXORD */
/* MAXSEL */
/* all of which are declared in the include file ekqlimit.inc. */
/* The functional definition of EQIMIN is: */
/* INTEGER EQIMIN */
/* PARAMETER ( EQIMIN = EQVBAS */
/* . + MAXTAB * EQVDSZ * 2 */
/* . + MAXCON * EQCDSZ */
/* . + MAXCON */
/* . + MAXORD * EQODSZ */
/* . + MAXSEL * EQSDSZ ) */
/* End Include Section: EK Encoded Query Internal Parameters */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* EQRYI I Integer component of query. */
/* NAME I Name of scalar item to read. */
/* VALUE O Value of item. */
/* $ Detailed_Input */
/* EQRYI is the integer portion of an encoded EK query. */
/* NAME is the name of the item whose value is to be read. */
/* This item is some element of the integer portion */
/* of an encoded query. */
/* $ Detailed_Output */
/* VALUE is the integer value designated by NAME. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the input name is not recognized, the error */
/* SPICE(INVALIDNAME) is signalled. The encoded query is not */
/* modified. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine is the inverse of ZZEKWEQI. */
/* $ Examples */
/* See EKSRCH. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - Beta Version 1.0.0, 17-OCT-1995 (NJB) */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Saved variables */
/* Initial values */
/* Use discovery check-in. */
/* Find the location of the named item. */
ljust_(name__, tmpnam, name_len, (ftnlen)32);
ucase_(tmpnam, tmpnam, (ftnlen)32, (ftnlen)32);
i__ = isrchc_(tmpnam, &c__15, namlst, (ftnlen)32, (ftnlen)32);
if (i__ == 0) {
chkin_("ZZEKREQI", (ftnlen)8);
setmsg_("Item # not found.", (ftnlen)17);
errch_("#", name__, (ftnlen)1, name_len);
sigerr_("SPICE(INVALIDNAME)", (ftnlen)18);
chkout_("ZZEKREQI", (ftnlen)8);
return 0;
}
/* Do the deed. */
*value = eqryi[namidx[(i__1 = i__ - 1) < 15 && 0 <= i__1 ? i__1 : s_rnge(
"namidx", i__1, "zzekreqi_", (ftnlen)191)] + 5];
return 0;
} /* zzekreqi_ */
/* $Procedure ZZEKAC05 ( EK, add class 5 column to segment ) */
/* Subroutine */ int zzekac05_(integer *handle, integer *segdsc, integer *
coldsc, doublereal *dvals, integer *entszs, logical *nlflgs)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
doublereal page[128];
integer nelt, from, size;
extern /* Subroutine */ int zzekcnam_(integer *, integer *, char *,
ftnlen), zzekpgwd_(integer *, integer *, doublereal *), zzeksfwd_(
integer *, integer *, integer *, integer *), zzekspsh_(integer *,
integer *);
integer i__, n, p, ndata, pbase;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
integer class__, nlink, p2, nrows;
extern /* Subroutine */ int cleard_(integer *, doublereal *);
extern logical return_(void);
char column[32];
integer adrbuf[126], bufptr, colidx, cursiz, nulptr, remain, to;
logical cntinu, fixsiz, newreq, nullok;
extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen), sigerr_(char *, ftnlen), chkout_(char *,
ftnlen);
integer row;
extern /* Subroutine */ int zzekaps_(integer *, integer *, integer *,
logical *, integer *, integer *);
/* $ Abstract */
/* Add an entire class 5 column to an EK segment. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* EK */
/* $ Keywords */
/* EK */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Boolean Enumerated Type */
/* ekbool.inc Version 1 21-DEC-1994 (NJB) */
/* Within the EK system, boolean values sometimes must be */
/* represented by integer or character codes. The codes and their */
/* meanings are listed below. */
/* Integer code indicating `true': */
/* Integer code indicating `false': */
/* Character code indicating `true': */
/* Character code indicating `false': */
/* End Include Section: EK Boolean Enumerated Type */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Column Descriptor Parameters */
/* ekcoldsc.inc Version 6 23-AUG-1995 (NJB) */
/* Note: The column descriptor size parameter CDSCSZ is */
/* declared separately in the include section CDSIZE$INC.FOR. */
/* Offset of column descriptors, relative to start of segment */
/* integer address range. This number, when added to the last */
/* integer address preceding the segment, yields the DAS integer */
/* base address of the first column descriptor. Currently, this */
/* offset is exactly the size of a segment descriptor. The */
/* parameter SDSCSZ, which defines the size of a segment descriptor, */
/* is declared in the include file eksegdsc.inc. */
/* Size of column descriptor */
/* Indices of various pieces of column descriptors: */
/* CLSIDX is the index of the column's class code. (We use the */
/* word `class' to distinguish this item from the column's data */
/* type.) */
/* TYPIDX is the index of the column's data type code (CHR, INT, DP, */
/* or TIME). The type is actually implied by the class, but it */
/* will frequently be convenient to look up the type directly. */
/* LENIDX is the index of the column's string length value, if the */
/* column has character type. A value of IFALSE in this element of */
/* the descriptor indicates that the strings have variable length. */
/* SIZIDX is the index of the column's element size value. This */
/* descriptor element is meaningful for columns with fixed-size */
/* entries. For variable-sized columns, this value is IFALSE. */
/* NAMIDX is the index of the base address of the column's name. */
/* IXTIDX is the data type of the column's index. IXTIDX */
/* contains a type value only if the column is indexed. For columns */
/* that are not indexed, the location IXTIDX contains the boolean */
/* value IFALSE. */
/* IXPIDX is a pointer to the column's index. IXTPDX contains a */
/* meaningful value only if the column is indexed. The */
/* interpretation of the pointer depends on the data type of the */
/* index. */
/* NFLIDX is the index of a flag indicating whether nulls are */
/* permitted in the column. The value at location NFLIDX is */
/* ITRUE if nulls are permitted and IFALSE otherwise. */
/* ORDIDX is the index of the column's ordinal position in the */
/* list of columns belonging to the column's parent segment. */
/* METIDX is the index of the column's integer metadata pointer. */
/* This pointer is a DAS integer address. */
/* The last position in the column descriptor is reserved. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Column Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Column Name Size */
/* ekcnamsz.inc Version 1 17-JAN-1995 (NJB) */
/* Size of column name, in characters. */
/* End Include Section: EK Column Name Size */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Data Page Parameters */
/* ekfilpar.inc Version 1 03-APR-1995 (NJB) */
/* These parameters apply to EK files using architecture 4. */
/* These files use a paged DAS file as their underlying file */
/* structure. */
/* In paged DAS EK files, data pages are structured: they contain */
/* metadata as well as data. The metadata is located in the last */
/* few addresses of each page, so as to interfere as little as */
/* possible with calculation of data addresses. */
/* Each data page belongs to exactly one segment. Some bookkeeping */
/* information, such as record pointers, is also stored in data */
/* pages. */
/* Each page contains a forward pointer that allows rapid lookup */
/* of data items that span multiple pages. Each page also keeps */
/* track of the current number of links from its parent segment */
/* to the page. Link counts enable pages to `know' when they */
/* are no longer in use by a segment; unused pages are deallocated */
/* and returned to the free list. */
/* The parameters in this include file depend on the parameters */
/* declared in the include file ekpage.inc. If those parameters */
/* change, this file must be updated. The specified parameter */
/* declarations we need from that file are: */
/* INTEGER PGSIZC */
/* PARAMETER ( PGSIZC = 1024 ) */
/* INTEGER PGSIZD */
/* PARAMETER ( PGSIZD = 128 ) */
/* INTEGER PGSIZI */
/* PARAMETER ( PGSIZI = 256 ) */
/* Character pages use an encoding mechanism to represent integer */
/* metadata. Each integer is encoded in five consecutive */
/* characters. */
/* Character data page parameters: */
/* Size of encoded integer: */
/* Usable page size: */
/* Location of character forward pointer: */
/* Location of character link count: */
/* Double precision data page parameters: */
/* Usable page size: */
/* Location of d.p. forward pointer: */
/* Location of d.p. link count: */
/* Integer data page parameters: */
/* Usable page size: */
/* Location of integer forward pointer: */
/* Location of integer link count: */
/* End Include Section: EK Data Page Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Das Paging Parameters */
/* ekpage.inc Version 4 25-AUG-1995 (NJB) */
/* The EK DAS paging system makes use of the integer portion */
/* of an EK file's DAS address space to store the few numbers */
/* required to describe the system's state. The allocation */
/* of DAS integer addresses is shown below. */
/* DAS integer array */
/* +--------------------------------------------+ */
/* | EK architecture code | Address = 1 */
/* +--------------------------------------------+ */
/* | Character page size (in DAS words) | */
/* +--------------------------------------------+ */
/* | Character page base address | */
/* +--------------------------------------------+ */
/* | Number of character pages in file | */
/* +--------------------------------------------+ */
/* | Number of character pages on free list | */
/* +--------------------------------------------+ */
/* | Character free list head pointer | Address = 6 */
/* +--------------------------------------------+ */
/* | | Addresses = */
/* | Metadata for d.p. pages | 7--11 */
/* | | */
/* +--------------------------------------------+ */
/* | | Addresses = */
/* | Metadata for integer pages | 12--16 */
/* | | */
/* +--------------------------------------------+ */
/* . */
/* . */
/* . */
/* +--------------------------------------------+ */
/* | | End Address = */
/* | Unused space | integer page */
/* | | end */
/* +--------------------------------------------+ */
/* | | Start Address = */
/* | First integer page | integer page */
/* | | base */
/* +--------------------------------------------+ */
/* . */
/* . */
/* . */
/* +--------------------------------------------+ */
/* | | */
/* | Last integer page | */
/* | | */
/* +--------------------------------------------+ */
/* The following parameters indicate positions of elements in the */
/* paging system metadata array: */
/* Number of metadata items per data type: */
/* Character metadata indices: */
/* Double precision metadata indices: */
/* Integer metadata indices: */
/* Size of metadata area: */
/* Page sizes, in units of DAS words of the appropriate type: */
/* Default page base addresses: */
/* End Include Section: EK Das Paging Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Record Pointer Parameters */
/* ekrecptr.inc Version 2 18-JUL-1995 (NJB) */
/* This file declares parameters used in EK record pointers. */
/* Each segment references data in a given record via two levels */
/* of indirection: a record number points to a record pointer, */
/* which is a structured array of metadata and data pointers. */
/* Record pointers always occupy contiguous ranges of integer */
/* addresses. */
/* The parameter declarations in this file depend on the assumption */
/* that integer pages contain 256 DAS integer words and that the */
/* maximum number of columns in a segment is 100. Record pointers */
/* are stored in integer data pages, so they must fit within the */
/* usable data area afforded by these pages. The size of the usable */
/* data area is given by the parameter IPSIZE which is declared in */
/* ekdatpag.inc. The assumed value of IPSIZE is 254. */
/* The first element of each record pointer is a status indicator. */
/* The meanings of status indicators depend on whether the parent EK */
/* is shadowed or not. For shadowed EKs, allowed status values and */
/* their meanings are: */
/* OLD The record has not been modified since */
/* the EK containing the record was opened. */
/* UPDATE The record is an update of a previously existing */
/* record. The original record is now on the */
/* modified record list. */
/* NEW The record has been added since the EK containing the */
/* record was opened. The record is not an update */
/* of a previously existing record. */
/* DELOLD This status applies only to a backup record. */
/* DELOLD status indicates that the record corresponds */
/* to a deleted OLD record in the source segment. */
/* DELNEW This status applies only to a backup record. */
/* DELNEW status indicates that the record corresponds */
/* to a deleted NEW record in the source segment. */
/* DELUPD This status applies only to a backup record. */
/* DELUPD status indicates that the record corresponds */
/* to a deleted UPDATEd record in the source segment. */
/* In EKs that are not shadowed, all records have status OLD. */
/* The following parameters refer to indices within the record */
/* pointer structure: */
/* Index of status indicator: */
/* Each record pointer contains a pointer to its companion: for a */
/* record belonging to a shadowed EK, this is the backup counterpart, */
/* or if the parent EK is itself a backup EK, a pointer to the */
/* record's source record. The pointer is UNINIT (see below) if the */
/* record is unmodified. */
/* Record companion pointers contain record numbers, not record */
/* base addresses. */
/* Index of record's companion pointer: */
/* Each data item is referenced by an integer. The meaning of */
/* this integer depends on the representation of data in the */
/* column to which the data item belongs. Actual lookup of a */
/* data item must be done by subroutines appropriate to the class of */
/* the column to which the item belongs. Note that data items don't */
/* necessarily occupy contiguous ranges of DAS addresses. */
/* Base address of data pointers: */
/* Maximum record pointer size: */
/* Data pointers are given the value UNINIT to start with; this */
/* indicates that the data item is uninitialized. UNINIT is */
/* distinct from the value NULL. NOBACK indicates an uninitialized */
/* backup column entry. */
/* End Include Section: EK Record Pointer Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Segment Descriptor Parameters */
/* eksegdsc.inc Version 8 06-NOV-1995 (NJB) */
/* All `base addresses' referred to below are the addresses */
/* *preceding* the item the base applies to. This convention */
/* enables simplied address calculations in many cases. */
/* Size of segment descriptor. Note: the include file ekcoldsc.inc */
/* must be updated if this parameter is changed. The parameter */
/* CDOFF in that file should be kept equal to SDSCSZ. */
/* Index of the segment type code: */
/* Index of the segment's number. This number is the segment's */
/* index in the list of segments contained in the EK to which */
/* the segment belongs. */
/* Index of the DAS integer base address of the segment's integer */
/* meta-data: */
/* Index of the DAS character base address of the table name: */
/* Index of the segment's column count: */
/* Index of the segment's record count: */
/* Index of the root page number of the record tree: */
/* Index of the root page number of the character data page tree: */
/* Index of the root page number of the double precision data page */
/* tree: */
/* Index of the root page number of the integer data page tree: */
/* Index of the `modified' flag: */
/* Index of the `initialized' flag: */
/* Index of the shadowing flag: */
/* Index of the companion file handle: */
/* Index of the companion segment number: */
/* The next three items are, respectively, the page numbers of the */
/* last character, d.p., and integer data pages allocated by the */
/* segment: */
/* The next three items are, respectively, the page-relative */
/* indices of the last DAS word in use in the segment's */
/* last character, d.p., and integer data pages: */
/* Index of the DAS character base address of the column name list: */
/* The last descriptor element is reserved for future use. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Segment Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Data Types */
/* ektype.inc Version 1 27-DEC-1994 (NJB) */
/* Within the EK system, data types of EK column contents are */
/* represented by integer codes. The codes and their meanings */
/* are listed below. */
/* Integer codes are also used within the DAS system to indicate */
/* data types; the EK system makes no assumptions about compatibility */
/* between the codes used here and those used in the DAS system. */
/* Character type: */
/* Double precision type: */
/* Integer type: */
/* `Time' type: */
/* Within the EK system, time values are represented as ephemeris */
/* seconds past J2000 (TDB), and double precision numbers are used */
/* to store these values. However, since time values require special */
/* treatment both on input and output, and since the `TIME' column */
/* has a special role in the EK specification and code, time values */
/* are identified as a type distinct from double precision numbers. */
/* End Include Section: EK Data Types */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle attached to new EK file. */
/* SEGDSC I Segment descriptor. */
/* COLDSC I Column descriptor. */
/* DVALS I D.p. values to add to column. */
/* ENTSZS I Array of sizes of column entries. */
/* NLFLGS I Array of null flags for column entries. */
/* $ Detailed_Input */
/* HANDLE the handle of an EK file that is open for writing. */
/* A `begin segment for fast load' operation must */
/* have already been performed for the designated */
/* segment. */
/* SEGDSC is a descriptor for the segment to which data is */
/* to be added. The segment descriptor is not */
/* updated by this routine, but some fields in the */
/* descriptor will become invalid after this routine */
/* returns. */
/* COLDSC is a descriptor for the column to be added. The */
/* column attributes must be filled in, but any */
/* pointers may be uninitialized. */
/* ENTSZS is an array containing sizes of column entries. */
/* The Ith element of ENTSZS gives the size of the */
/* Ith column entry. ENTSZS is used only for columns */
/* having variable-size entries. For such columns, */
/* the dimension of ENTSZS must be at least NROWS. */
/* The size of null entries should be set to zero. */
/* For columns having fixed-size entries, the */
/* dimension of this array may be any positive value. */
/* DVALS is an array containing the entire set of column */
/* entries for the specified column. The entries */
/* are listed in row-order: the column entry for the */
/* first row of the segment is first, followed by the */
/* column entry for the second row, and so on. The */
/* number of column entries must match the declared */
/* number of rows in the segment. For columns having */
/* fixed-size entries, a null entry must be allocated */
/* the same amount of space occupied by a non-null */
/* entry in the array DVALS. For columns having */
/* variable-size entries, null entries do not require */
/* any space in the DVALS array, but in any case must */
/* have their allocated space described correctly by */
/* the corresponding element of the ENTSZS array */
/* (described below). */
/* ENTSZS is an array containing sizes of column entries. */
/* The Ith element of ENTSZS gives the size of the */
/* Ith column entry. ENTSZS is used only for columns */
/* having variable-size entries. For such columns, */
/* the dimension of ENTSZS must be at least NROWS. */
/* The size of null entries should be set to zero. */
/* For columns having fixed-size entries, the */
/* dimension of this array may be any positive value. */
/* NLFLGS is an array of logical flags indicating whether */
/* the corresponding entries are null. If the Ith */
/* element of NLFLGS is .FALSE., the Ith column entry */
/* defined by DVALS is added to the specified segment */
/* in the specified kernel file. */
/* If the Ith element of NLFGLS is .TRUE., the */
/* contents of the Ith column entry are undefined. */
/* NLFLGS is used only for columns that allow null */
/* values; it's ignored for other columns. */
/* $ Detailed_Output */
/* None. See $Particulars for a description of the effect of this */
/* routine. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If HANDLE is invalid, the error will be diagnosed by routines */
/* called by this routine. */
/* 2) If an I/O error occurs while reading or writing the indicated */
/* file, the error will be diagnosed by routines called by this */
/* routine. */
/* $ Files */
/* See the EK Required Reading for a discussion of the EK file */
/* format. */
/* $ Particulars */
/* This routine operates by side effects: it modifies the named */
/* EK file by adding data to the specified column. This routine */
/* writes the entire contents of the specified column in one shot. */
/* This routine creates columns much more efficiently than can be */
/* done by sequential calls to EKACED, but has the drawback that */
/* the caller must use more memory for the routine's inputs. This */
/* routine cannot be used to add data to a partially completed */
/* column. */
/* $ Examples */
/* See EKACLD. */
/* $ Restrictions */
/* 1) This routine assumes the EK scratch area has been set up */
/* properly for a fast load operation. This routine writes */
/* to the EK scratch area as well. */
/* 2) Only one segment can be created at a time using the fast */
/* load routines. */
/* 3) No other EK operation may interrupt a fast load. For */
/* example, it is not valid to issue a query while a fast load */
/* is in progress. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.0, 22-JUL-1996 (NJB) */
/* Bug fix: case of 100% null data values is now handled */
/* correctly. Previous version line was changed from "Beta" */
/* to "SPICELIB." */
/* - SPICELIB Version 1.0.0, 23-SEP-1995 (NJB) */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.1.0, 22-JUL-1996 (NJB) */
/* Bug fix: case of 100% null data values is now handled */
/* correctly. The test to determine when to write a page */
/* was fixed to handle this case. */
/* Previous version line was changed from "Beta" */
/* to "SPICELIB." */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZEKAC05", (ftnlen)8);
}
/* Grab the column's attributes. */
class__ = coldsc[0];
nulptr = coldsc[7];
colidx = coldsc[8];
size = coldsc[3];
nullok = nulptr != -1;
fixsiz = size != -1;
/* This column had better be class 5. */
if (class__ != 5) {
zzekcnam_(handle, coldsc, column, (ftnlen)32);
setmsg_("Column class code # found in descriptor for column #. Clas"
"s should be 5.", (ftnlen)73);
errint_("#", &class__, (ftnlen)1);
errch_("#", column, (ftnlen)1, (ftnlen)32);
sigerr_("SPICE(NOCLASS)", (ftnlen)14);
chkout_("ZZEKAC05", (ftnlen)8);
return 0;
}
/* Push the column's ordinal index on the stack. This allows us */
/* to identify the column the addresses belong to. */
zzekspsh_(&c__1, &colidx);
/* Find the number of rows in the segment. */
nrows = segdsc[5];
/* Record the number of data values to write. */
if (nullok) {
/* Sum the sizes of the non-null column entries; these are the */
/* ones that will take up space. */
ndata = 0;
i__1 = nrows;
for (i__ = 1; i__ <= i__1; ++i__) {
if (! nlflgs[i__ - 1]) {
if (fixsiz) {
ndata += size;
} else {
ndata += entszs[i__ - 1];
}
}
}
} else {
if (fixsiz) {
ndata = nrows * size;
} else {
ndata = 0;
i__1 = nrows;
for (i__ = 1; i__ <= i__1; ++i__) {
ndata += entszs[i__ - 1];
}
}
}
if (ndata > 0) {
/* There's some data to write, so allocate a page. Also */
/* prepare a data buffer to be written out as a page. */
zzekaps_(handle, segdsc, &c__2, &c_false, &p, &pbase);
cleard_(&c__128, page);
}
/* Write the input data out to the target file a page at a time. */
/* Null values don't get written. */
/* While we're at it, we'll push onto the EK stack the addresses */
/* of the column entries. We use the constant NULL rather than an */
/* address to represent null entries. */
/* We'll use FROM to indicate the element of DVALS we're */
/* considering, TO to indicate the element of PAGE to write */
/* to, and BUFPTR to indicate the element of ADRBUF to write */
/* addresses to. The variable NELT is the count of the column entry */
/* elements written for the current entry. The variable N indicates */
/* the number of d.p. numbers written to the current page. */
remain = ndata;
from = 1;
to = 1;
bufptr = 1;
row = 1;
nelt = 1;
n = 0;
nlink = 0;
while(row <= nrows) {
/* NEWREQ is set to TRUE if we discover that the next column */
/* entry must start on a new page. */
newreq = FALSE_;
if (nullok && nlflgs[row - 1]) {
if (fixsiz) {
cursiz = size;
} else {
cursiz = entszs[row - 1];
}
from += cursiz;
adrbuf[(i__1 = bufptr - 1) < 126 && 0 <= i__1 ? i__1 : s_rnge(
"adrbuf", i__1, "zzekac05_", (ftnlen)417)] = -2;
++bufptr;
++row;
nelt = 1;
cntinu = FALSE_;
} else {
if (nelt == 1) {
/* We're about to write out a new column entry. We must */
/* insert the element count into the page before writing the */
/* data. The link count for the current page must be */
/* incremented to account for this new entry. */
/* At this point, we're guaranteed at least two free */
/* spaces in the current page. */
if (fixsiz) {
cursiz = size;
} else {
cursiz = entszs[row - 1];
}
adrbuf[(i__1 = bufptr - 1) < 126 && 0 <= i__1 ? i__1 : s_rnge(
"adrbuf", i__1, "zzekac05_", (ftnlen)443)] = to +
pbase;
++bufptr;
page[(i__1 = to - 1) < 128 && 0 <= i__1 ? i__1 : s_rnge("page"
, i__1, "zzekac05_", (ftnlen)445)] = (doublereal)
cursiz;
++to;
++n;
++nlink;
}
/* At this point, there's at least one free space in the */
/* current page. */
page[(i__1 = to - 1) < 128 && 0 <= i__1 ? i__1 : s_rnge("page",
i__1, "zzekac05_", (ftnlen)456)] = dvals[from - 1];
++to;
++n;
++from;
--remain;
/* Decide whether we must continue the current entry on another */
/* data page. */
cntinu = nelt < cursiz && n == 126;
if (nelt == cursiz) {
/* The current element is the last of the current column */
/* entry. */
/* Determine whether we must start the next column entry on */
/* a new page. To start a column entry on the current page, */
/* we must have enough room for the element count and at */
/* least the first entry element. */
if (remain > 0) {
newreq = n > 124;
}
nelt = 1;
++row;
} else {
++nelt;
}
}
if (bufptr > 126 || row > nrows) {
/* The address buffer is full or we're out of input values */
/* to look at, so push the buffer contents on the stack. */
i__1 = bufptr - 1;
zzekspsh_(&i__1, adrbuf);
bufptr = 1;
}
if (cntinu || newreq || row > nrows && ndata > 0) {
/* It's time to write out the current page. First set the link */
/* count. */
page[127] = (doublereal) nlink;
/* Write out the data page. */
zzekpgwd_(handle, &p, page);
/* If there's more data to write, allocate another page. */
if (remain > 0) {
zzekaps_(handle, segdsc, &c__2, &c_false, &p2, &pbase);
cleard_(&c__128, page);
n = 0;
nlink = 0;
to = 1;
/* If we're continuing an element from the previous page, */
/* link the previous page to the current one. */
if (cntinu) {
zzeksfwd_(handle, &c__2, &p, &p2);
}
p = p2;
}
/* We've allocated a new data page if we needed one. */
}
/* We've written out the last completed data page. */
}
/* We've processed all entries of the input array. */
chkout_("ZZEKAC05", (ftnlen)8);
return 0;
} /* zzekac05_ */
/* $Procedure BODMAT ( Return transformation matrix for a body ) */
/* Subroutine */ int bodmat_(integer *body, doublereal *et, doublereal *tipm)
{
/* Initialized data */
static logical first = TRUE_;
static logical found = FALSE_;
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_dnnt(doublereal *);
double sin(doublereal), cos(doublereal), d_mod(doublereal *, doublereal *)
;
/* Local variables */
integer cent;
char item[32];
doublereal j2ref[9] /* was [3][3] */;
extern integer zzbodbry_(integer *);
extern /* Subroutine */ int eul2m_(doublereal *, doublereal *, doublereal
*, integer *, integer *, integer *, doublereal *);
doublereal d__;
integer i__, j;
doublereal dcoef[3], t, w;
extern /* Subroutine */ int etcal_(doublereal *, char *, ftnlen);
integer refid;
doublereal delta;
extern /* Subroutine */ int chkin_(char *, ftnlen);
doublereal epoch, rcoef[3], tcoef[200] /* was [2][100] */, wcoef[3];
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen);
doublereal theta;
extern /* Subroutine */ int moved_(doublereal *, integer *, doublereal *),
repmi_(char *, char *, integer *, char *, ftnlen, ftnlen, ftnlen)
, errdp_(char *, doublereal *, ftnlen);
doublereal costh[100];
extern doublereal vdotg_(doublereal *, doublereal *, integer *);
char dtype[1];
doublereal sinth[100], tsipm[36] /* was [6][6] */;
extern doublereal twopi_(void);
static integer j2code;
doublereal ac[100], dc[100];
integer na, nd;
doublereal ra, wc[100];
extern /* Subroutine */ int cleard_(integer *, doublereal *);
extern logical bodfnd_(integer *, char *, ftnlen);
extern /* Subroutine */ int bodvcd_(integer *, char *, integer *, integer
*, doublereal *, ftnlen);
integer frcode;
extern doublereal halfpi_(void);
extern /* Subroutine */ int ccifrm_(integer *, integer *, integer *, char
*, integer *, logical *, ftnlen);
integer nw;
doublereal conepc, conref;
extern /* Subroutine */ int pckmat_(integer *, doublereal *, integer *,
doublereal *, logical *);
integer ntheta;
extern /* Subroutine */ int gdpool_(char *, integer *, integer *, integer
*, doublereal *, logical *, ftnlen);
char fixfrm[32], errmsg[1840];
extern /* Subroutine */ int irfnum_(char *, integer *, ftnlen), dtpool_(
char *, logical *, integer *, char *, ftnlen, ftnlen);
doublereal tmpmat[9] /* was [3][3] */;
extern /* Subroutine */ int setmsg_(char *, ftnlen), suffix_(char *,
integer *, char *, ftnlen, ftnlen), errint_(char *, integer *,
ftnlen), sigerr_(char *, ftnlen), chkout_(char *, ftnlen),
irfrot_(integer *, integer *, doublereal *);
extern logical return_(void);
char timstr[35];
extern doublereal j2000_(void);
doublereal dec;
integer dim, ref;
doublereal phi;
extern doublereal rpd_(void), spd_(void);
extern /* Subroutine */ int mxm_(doublereal *, doublereal *, doublereal *)
;
/* $ Abstract */
/* Return the J2000 to body Equator and Prime Meridian coordinate */
/* transformation matrix for a specified body. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* PCK */
/* NAIF_IDS */
/* TIME */
/* $ Keywords */
/* CONSTANTS */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include File: SPICELIB Error Handling Parameters */
/* errhnd.inc Version 2 18-JUN-1997 (WLT) */
/* The size of the long error message was */
/* reduced from 25*80 to 23*80 so that it */
/* will be accepted by the Microsoft Power Station */
/* FORTRAN compiler which has an upper bound */
/* of 1900 for the length of a character string. */
/* errhnd.inc Version 1 29-JUL-1997 (NJB) */
/* Maximum length of the long error message: */
/* Maximum length of the short error message: */
/* End Include File: SPICELIB Error Handling Parameters */
/* $ Abstract */
/* The parameters below form an enumerated list of the recognized */
/* frame types. They are: INERTL, PCK, CK, TK, DYN. The meanings */
/* are outlined below. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Parameters */
/* INERTL an inertial frame that is listed in the routine */
/* CHGIRF and that requires no external file to */
/* compute the transformation from or to any other */
/* inertial frame. */
/* PCK is a frame that is specified relative to some */
/* INERTL frame and that has an IAU model that */
/* may be retrieved from the PCK system via a call */
/* to the routine TISBOD. */
/* CK is a frame defined by a C-kernel. */
/* TK is a "text kernel" frame. These frames are offset */
/* from their associated "relative" frames by a */
/* constant rotation. */
/* DYN is a "dynamic" frame. These currently are */
/* parameterized, built-in frames where the full frame */
/* definition depends on parameters supplied via a */
/* frame kernel. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 3.0.0, 28-MAY-2004 (NJB) */
/* The parameter DYN was added to support the dynamic frame class. */
/* - SPICELIB Version 2.0.0, 12-DEC-1996 (WLT) */
/* Various unused frames types were removed and the */
/* frame time TK was added. */
/* - SPICELIB Version 1.0.0, 10-DEC-1995 (WLT) */
/* -& */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* BODY I ID code of body. */
/* ET I Epoch of transformation. */
/* TIPM O Transformation from Inertial to PM for BODY at ET. */
/* $ Detailed_Input */
/* BODY is the integer ID code of the body for which the */
/* transformation is requested. Bodies are numbered */
/* according to the standard NAIF numbering scheme. */
/* ET is the epoch at which the transformation is */
/* requested. (This is typically the epoch of */
/* observation minus the one-way light time from */
/* the observer to the body at the epoch of */
/* observation.) */
/* $ Detailed_Output */
/* TIPM is the transformation matrix from Inertial to body */
/* Equator and Prime Meridian. The X axis of the PM */
/* system is directed to the intersection of the */
/* equator and prime meridian. The Z axis points north. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If data required to define the body-fixed frame associated */
/* with BODY are not found in the binary PCK system or the kernel */
/* pool, the error SPICE(FRAMEDATANOTFOUND) is signaled. In */
/* the case of IAU style body-fixed frames, the absence of */
/* prime meridian polynomial data (which are required) is used */
/* as an indicator of missing data. */
/* 2) If the test for exception (1) passes, but in fact requested */
/* data are not available in the kernel pool, the error will be */
/* signaled by routines in the call tree of this routine. */
/* 3) If the kernel pool does not contain all of the data required */
/* to define the number of nutation precession angles */
/* corresponding to the available nutation precession */
/* coefficients, the error SPICE(INSUFFICIENTANGLES) is */
/* signaled. */
/* 4) If the reference frame REF is not recognized, a routine */
/* called by BODMAT will diagnose the condition and invoke the */
/* SPICE error handling system. */
/* 5) If the specified body code BODY is not recognized, the */
/* error is diagnosed by a routine called by BODMAT. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine is related to the more general routine TIPBOD */
/* which returns a matrix that transforms vectors from a */
/* specified inertial reference frame to body equator and */
/* prime meridian coordinates. TIPBOD accepts an input argument */
/* REF that allows the caller to specify an inertial reference */
/* frame. */
/* The transformation represented by BODMAT's output argument TIPM */
/* is defined as follows: */
/* TIPM = [W] [DELTA] [PHI] */
/* 3 1 3 */
/* If there exists high-precision binary PCK kernel information */
/* for the body at the requested time, these angles, W, DELTA */
/* and PHI are computed directly from that file. The most */
/* recently loaded binary PCK file has first priority followed */
/* by previously loaded binary PCK files in backward time order. */
/* If no binary PCK file has been loaded, the text P_constants */
/* kernel file is used. */
/* If there is only text PCK kernel information, it is */
/* expressed in terms of RA, DEC and W (same W as above), where */
/* RA = PHI - HALFPI() */
/* DEC = HALFPI() - DELTA */
/* RA, DEC, and W are defined as follows in the text PCK file: */
/* RA = RA0 + RA1*T + RA2*T*T + a sin theta */
/* i i */
/* DEC = DEC0 + DEC1*T + DEC2*T*T + d cos theta */
/* i i */
/* W = W0 + W1*d + W2*d*d + w sin theta */
/* i i */
/* where: */
/* d = days past J2000. */
/* T = Julian centuries past J2000. */
/* a , d , and w arrays apply to satellites only. */
/* i i i */
/* theta = THETA0 * THETA1*T are specific to each planet. */
/* i */
/* These angles -- typically nodal rates -- vary in number and */
/* definition from one planetary system to the next. */
/* $ Examples */
/* In the following code fragment, BODMAT is used to rotate */
/* the position vector (POS) from a target body (BODY) to a */
/* spacecraft from inertial coordinates to body-fixed coordinates */
/* at a specific epoch (ET), in order to compute the planetocentric */
/* longitude (PCLONG) of the spacecraft. */
/* CALL BODMAT ( BODY, ET, TIPM ) */
/* CALL MXV ( TIPM, POS, POS ) */
/* CALL RECLAT ( POS, RADIUS, PCLONG, LAT ) */
/* To compute the equivalent planetographic longitude (PGLONG), */
/* it is necessary to know the direction of rotation of the target */
/* body, as shown below. */
/* CALL BODVCD ( BODY, 'PM', 3, DIM, VALUES ) */
/* IF ( VALUES(2) .GT. 0.D0 ) THEN */
/* PGLONG = PCLONG */
/* ELSE */
/* PGLONG = TWOPI() - PCLONG */
/* END IF */
/* Note that the items necessary to compute the transformation */
/* TIPM must have been loaded into the kernel pool (by one or more */
/* previous calls to FURNSH). */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* 1) Refer to the NAIF_IDS required reading file for a complete */
/* list of the NAIF integer ID codes for bodies. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* K.S. Zukor (JPL) */
/* $ Version */
/* - SPICELIB Version 4.1.1, 01-FEB-2008 (NJB) */
/* The routine was updated to improve the error messages created */
/* when required PCK data are not found. Now in most cases the */
/* messages are created locally rather than by the kernel pool */
/* access routines. In particular missing binary PCK data will */
/* be indicated with a reasonable error message. */
/* - SPICELIB Version 4.1.0, 25-AUG-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in MXM call. */
/* Calls to ZZBODVCD have been replaced with calls to */
/* BODVCD. */
/* - SPICELIB Version 4.0.0, 12-FEB-2004 (NJB) */
/* Code has been updated to support satellite ID codes in the */
/* range 10000 to 99999 and to allow nutation precession angles */
/* to be associated with any object. */
/* Implementation changes were made to improve robustness */
/* of the code. */
/* - SPICELIB Version 3.2.0, 22-MAR-1995 (KSZ) */
/* Gets TSIPM matrix from PCKMAT (instead of Euler angles */
/* from PCKEUL.) */
/* - SPICELIB Version 3.0.0, 10-MAR-1994 (KSZ) */
/* Ability to get Euler angles from binary PCK file added. */
/* This uses the new routine PCKEUL. */
/* - SPICELIB Version 2.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 2.0.0, 04-SEP-1991 (NJB) */
/* Updated to handle P_constants referenced to different epochs */
/* and inertial reference frames. */
/* The header was updated to specify that the inertial reference */
/* frame used by BODMAT is restricted to be J2000. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* fetch transformation matrix for a body */
/* transformation from j2000 position to bodyfixed */
/* transformation from j2000 to bodyfixed coordinates */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 4.1.0, 25-AUG-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in MXM call. */
/* Calls to ZZBODVCD have been replaced with calls to */
/* BODVCD. */
/* - SPICELIB Version 4.0.0, 12-FEB-2004 (NJB) */
/* Code has been updated to support satellite ID codes in the */
/* range 10000 to 99999 and to allow nutation precession angles */
/* to be associated with any object. */
/* Calls to deprecated kernel pool access routine RTPOOL */
/* were replaced by calls to GDPOOL. */
/* Calls to BODVAR have been replaced with calls to */
/* ZZBODVCD. */
/* - SPICELIB Version 3.2.0, 22-MAR-1995 (KSZ) */
/* BODMAT now get the TSIPM matrix from PCKMAT, and */
/* unpacks TIPM from it. Also the calculated but unused */
/* variable LAMBDA was removed. */
/* - SPICELIB Version 3.0.0, 10-MAR-1994 (KSZ) */
/* BODMAT now uses new software to check for the */
/* existence of binary PCK files, search the for */
/* data corresponding to the requested body and time, */
/* and return the appropriate Euler angles, using the */
/* new routine PCKEUL. Otherwise the code calculates */
/* the Euler angles from the P_constants kernel file. */
/* - SPICELIB Version 2.0.0, 04-SEP-1991 (NJB) */
/* Updated to handle P_constants referenced to different epochs */
/* and inertial reference frames. */
/* The header was updated to specify that the inertial reference */
/* frame used by BODMAT is restricted to be J2000. */
/* BODMAT now checks the kernel pool for presence of the */
/* variables */
/* BODY#_CONSTANTS_REF_FRAME */
/* and */
/* BODY#_CONSTANTS_JED_EPOCH */
/* where # is the NAIF integer code of the barycenter of a */
/* planetary system or of a body other than a planet or */
/* satellite. If either or both of these variables are */
/* present, the P_constants for BODY are presumed to be */
/* referenced to the specified inertial frame or epoch. */
/* If the epoch of the constants is not J2000, the input */
/* time ET is converted to seconds past the reference epoch. */
/* If the frame of the constants is not J2000, the rotation from */
/* the P_constants' frame to body-fixed coordinates is */
/* transformed to the rotation from J2000 coordinates to */
/* body-fixed coordinates. */
/* For efficiency reasons, this routine now duplicates much */
/* of the code of BODEUL so that it doesn't have to call BODEUL. */
/* In some cases, BODEUL must covert Euler angles to a matrix, */
/* rotate the matrix, and convert the result back to Euler */
/* angles. If this routine called BODEUL, then in such cases */
/* this routine would convert the transformed angles back to */
/* a matrix. That would be a bit much.... */
/* - Beta Version 1.1.0, 16-FEB-1989 (IMU) (NJB) */
/* Examples section completed. Declaration of unused variable */
/* FOUND removed. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Saved variables */
/* Initial values */
/* Standard SPICE Error handling. */
if (return_()) {
return 0;
} else {
chkin_("BODMAT", (ftnlen)6);
}
/* Get the code for the J2000 frame, if we don't have it yet. */
if (first) {
irfnum_("J2000", &j2code, (ftnlen)5);
first = FALSE_;
}
/* Get Euler angles from high precision data file. */
pckmat_(body, et, &ref, tsipm, &found);
if (found) {
for (i__ = 1; i__ <= 3; ++i__) {
for (j = 1; j <= 3; ++j) {
tipm[(i__1 = i__ + j * 3 - 4) < 9 && 0 <= i__1 ? i__1 :
s_rnge("tipm", i__1, "bodmat_", (ftnlen)485)] = tsipm[
(i__2 = i__ + j * 6 - 7) < 36 && 0 <= i__2 ? i__2 :
s_rnge("tsipm", i__2, "bodmat_", (ftnlen)485)];
}
}
} else {
/* The data for the frame of interest are not available in a */
/* loaded binary PCK file. This is not an error: the data may be */
/* present in the kernel pool. */
/* Conduct a non-error-signaling check for the presence of a */
/* kernel variable that is required to implement an IAU style */
/* body-fixed reference frame. If the data aren't available, we */
/* don't want BODVCD to signal a SPICE(KERNELVARNOTFOUND) error; */
/* we want to issue the error signal locally, with a better error */
/* message. */
s_copy(item, "BODY#_PM", (ftnlen)32, (ftnlen)8);
repmi_(item, "#", body, item, (ftnlen)32, (ftnlen)1, (ftnlen)32);
dtpool_(item, &found, &nw, dtype, (ftnlen)32, (ftnlen)1);
if (! found) {
/* Now we do have an error. */
/* We don't have the data we'll need to produced the requested */
/* state transformation matrix. In order to create an error */
/* message understandable to the user, find, if possible, the */
/* name of the reference frame associated with the input body. */
/* Note that the body is really identified by a PCK frame class */
/* ID code, though most of the documentation just calls it a */
/* body ID code. */
ccifrm_(&c__2, body, &frcode, fixfrm, ¢, &found, (ftnlen)32);
etcal_(et, timstr, (ftnlen)35);
s_copy(errmsg, "PCK data required to compute the orientation of "
"the # # for epoch # TDB were not found. If these data we"
"re to be provided by a binary PCK file, then it is possi"
"ble that the PCK file does not have coverage for the spe"
"cified body-fixed frame at the time of interest. If the "
"data were to be provided by a text PCK file, then possib"
"ly the file does not contain data for the specified body"
"-fixed frame. In either case it is possible that a requi"
"red PCK file was not loaded at all.", (ftnlen)1840, (
ftnlen)475);
/* Fill in the variable data in the error message. */
if (found) {
/* The frame system knows the name of the body-fixed frame. */
setmsg_(errmsg, (ftnlen)1840);
errch_("#", "body-fixed frame", (ftnlen)1, (ftnlen)16);
errch_("#", fixfrm, (ftnlen)1, (ftnlen)32);
errch_("#", timstr, (ftnlen)1, (ftnlen)35);
} else {
/* The frame system doesn't know the name of the */
/* body-fixed frame, most likely due to a missing */
/* frame kernel. */
suffix_("#", &c__1, errmsg, (ftnlen)1, (ftnlen)1840);
setmsg_(errmsg, (ftnlen)1840);
errch_("#", "body-fixed frame associated with the ID code", (
ftnlen)1, (ftnlen)44);
errint_("#", body, (ftnlen)1);
errch_("#", timstr, (ftnlen)1, (ftnlen)35);
errch_("#", "Also, a frame kernel defining the body-fixed fr"
"ame associated with body # may need to be loaded.", (
ftnlen)1, (ftnlen)96);
errint_("#", body, (ftnlen)1);
}
sigerr_("SPICE(FRAMEDATANOTFOUND)", (ftnlen)24);
chkout_("BODMAT", (ftnlen)6);
return 0;
}
/* Find the body code used to label the reference frame and epoch */
/* specifiers for the orientation constants for BODY. */
/* For planetary systems, the reference frame and epoch for the */
/* orientation constants is associated with the system */
/* barycenter, not with individual bodies in the system. For any */
/* other bodies, (the Sun or asteroids, for example) the body's */
/* own code is used as the label. */
refid = zzbodbry_(body);
/* Look up the epoch of the constants. The epoch is specified */
/* as a Julian ephemeris date. The epoch defaults to J2000. */
s_copy(item, "BODY#_CONSTANTS_JED_EPOCH", (ftnlen)32, (ftnlen)25);
repmi_(item, "#", &refid, item, (ftnlen)32, (ftnlen)1, (ftnlen)32);
gdpool_(item, &c__1, &c__1, &dim, &conepc, &found, (ftnlen)32);
if (found) {
/* The reference epoch is returned as a JED. Convert to */
/* ephemeris seconds past J2000. Then convert the input ET to */
/* seconds past the reference epoch. */
conepc = spd_() * (conepc - j2000_());
epoch = *et - conepc;
} else {
epoch = *et;
}
/* Look up the reference frame of the constants. The reference */
/* frame is specified by a code recognized by CHGIRF. The */
/* default frame is J2000, symbolized by the code J2CODE. */
s_copy(item, "BODY#_CONSTANTS_REF_FRAME", (ftnlen)32, (ftnlen)25);
repmi_(item, "#", &refid, item, (ftnlen)32, (ftnlen)1, (ftnlen)32);
gdpool_(item, &c__1, &c__1, &dim, &conref, &found, (ftnlen)32);
if (found) {
ref = i_dnnt(&conref);
} else {
ref = j2code;
}
/* Whatever the body, it has quadratic time polynomials for */
/* the RA and Dec of the pole, and for the rotation of the */
/* Prime Meridian. */
s_copy(item, "POLE_RA", (ftnlen)32, (ftnlen)7);
cleard_(&c__3, rcoef);
bodvcd_(body, item, &c__3, &na, rcoef, (ftnlen)32);
s_copy(item, "POLE_DEC", (ftnlen)32, (ftnlen)8);
cleard_(&c__3, dcoef);
bodvcd_(body, item, &c__3, &nd, dcoef, (ftnlen)32);
s_copy(item, "PM", (ftnlen)32, (ftnlen)2);
cleard_(&c__3, wcoef);
bodvcd_(body, item, &c__3, &nw, wcoef, (ftnlen)32);
/* There may be additional nutation and libration (THETA) terms. */
ntheta = 0;
na = 0;
nd = 0;
nw = 0;
s_copy(item, "NUT_PREC_ANGLES", (ftnlen)32, (ftnlen)15);
if (bodfnd_(&refid, item, (ftnlen)32)) {
bodvcd_(&refid, item, &c__100, &ntheta, tcoef, (ftnlen)32);
ntheta /= 2;
}
s_copy(item, "NUT_PREC_RA", (ftnlen)32, (ftnlen)11);
if (bodfnd_(body, item, (ftnlen)32)) {
bodvcd_(body, item, &c__100, &na, ac, (ftnlen)32);
}
s_copy(item, "NUT_PREC_DEC", (ftnlen)32, (ftnlen)12);
if (bodfnd_(body, item, (ftnlen)32)) {
bodvcd_(body, item, &c__100, &nd, dc, (ftnlen)32);
}
s_copy(item, "NUT_PREC_PM", (ftnlen)32, (ftnlen)11);
if (bodfnd_(body, item, (ftnlen)32)) {
bodvcd_(body, item, &c__100, &nw, wc, (ftnlen)32);
}
/* Computing MAX */
i__1 = max(na,nd);
if (max(i__1,nw) > ntheta) {
setmsg_("Insufficient number of nutation/precession angles for b"
"ody * at time #.", (ftnlen)71);
errint_("*", body, (ftnlen)1);
errdp_("#", et, (ftnlen)1);
sigerr_("SPICE(KERNELVARNOTFOUND)", (ftnlen)24);
chkout_("BODMAT", (ftnlen)6);
return 0;
}
/* Evaluate the time polynomials at EPOCH. */
d__ = epoch / spd_();
t = d__ / 36525.;
ra = rcoef[0] + t * (rcoef[1] + t * rcoef[2]);
dec = dcoef[0] + t * (dcoef[1] + t * dcoef[2]);
w = wcoef[0] + d__ * (wcoef[1] + d__ * wcoef[2]);
/* Add nutation and libration as appropriate. */
i__1 = ntheta;
for (i__ = 1; i__ <= i__1; ++i__) {
theta = (tcoef[(i__2 = (i__ << 1) - 2) < 200 && 0 <= i__2 ? i__2 :
s_rnge("tcoef", i__2, "bodmat_", (ftnlen)700)] + t *
tcoef[(i__3 = (i__ << 1) - 1) < 200 && 0 <= i__3 ? i__3 :
s_rnge("tcoef", i__3, "bodmat_", (ftnlen)700)]) * rpd_();
sinth[(i__2 = i__ - 1) < 100 && 0 <= i__2 ? i__2 : s_rnge("sinth",
i__2, "bodmat_", (ftnlen)702)] = sin(theta);
costh[(i__2 = i__ - 1) < 100 && 0 <= i__2 ? i__2 : s_rnge("costh",
i__2, "bodmat_", (ftnlen)703)] = cos(theta);
}
ra += vdotg_(ac, sinth, &na);
dec += vdotg_(dc, costh, &nd);
w += vdotg_(wc, sinth, &nw);
/* Convert from degrees to radians and mod by two pi. */
ra *= rpd_();
dec *= rpd_();
w *= rpd_();
d__1 = twopi_();
ra = d_mod(&ra, &d__1);
d__1 = twopi_();
dec = d_mod(&dec, &d__1);
d__1 = twopi_();
w = d_mod(&w, &d__1);
/* Convert to Euler angles. */
phi = ra + halfpi_();
delta = halfpi_() - dec;
/* Produce the rotation matrix defined by the Euler angles. */
eul2m_(&w, &delta, &phi, &c__3, &c__1, &c__3, tipm);
}
/* Convert TIPM to the J2000-to-bodyfixed rotation, if is is not */
/* already referenced to J2000. */
if (ref != j2code) {
/* Find the transformation from the J2000 frame to the frame */
/* designated by REF. Form the transformation from `REF' */
/* coordinates to body-fixed coordinates. Compose the */
/* transformations to obtain the J2000-to-body-fixed */
/* transformation. */
irfrot_(&j2code, &ref, j2ref);
mxm_(tipm, j2ref, tmpmat);
moved_(tmpmat, &c__9, tipm);
}
/* TIPM now gives the transformation from J2000 to */
/* body-fixed coordinates at epoch ET seconds past J2000, */
/* regardless of the epoch and frame of the orientation constants */
/* for the specified body. */
chkout_("BODMAT", (ftnlen)6);
return 0;
} /* bodmat_ */
/* $Procedure RECGEO ( Rectangular to geodetic ) */
/* Subroutine */ int recgeo_(doublereal *rectan, doublereal *re, doublereal *
f, doublereal *long__, doublereal *lat, doublereal *alt)
{
doublereal base[3], a, b, c__;
extern /* Subroutine */ int chkin_(char *, ftnlen), errdp_(char *,
doublereal *, ftnlen), reclat_(doublereal *, doublereal *,
doublereal *, doublereal *);
doublereal radius, normal[3];
extern /* Subroutine */ int nearpt_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), sigerr_(
char *, ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen),
surfnm_(doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
extern logical return_(void);
/* $ Abstract */
/* Convert from rectangular coordinates to geodetic coordinates. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* CONVERSION, COORDINATES */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* RECTAN I Rectangular coordinates of a point. */
/* RE I Equatorial radius of the reference spheroid. */
/* F I Flattening coefficient. */
/* LONG O Geodetic longitude of the point (radians). */
/* LAT O Geodetic latitude of the point (radians). */
/* ALT O Altitude of the point above reference spheroid. */
/* $ Detailed_Input */
/* RECTAN The rectangular coordinates of a point. */
/* RE Equatorial radius of a reference spheroid. This */
/* spheroid is a volume of revolution: its horizontal */
/* cross sections are circular. The shape of the */
/* spheroid is defined by an equatorial radius RE and */
/* a polar radius RP. */
/* F Flattening coefficient = (RE-RP) / RE, where RP is */
/* the polar radius of the spheroid. */
/* $ Detailed_Output */
/* LONG Geodetic longitude of the input point. This is the */
/* angle between the prime meridian and the meridian */
/* containing RECTAN. The direction of increasing */
/* longitude is from the +X axis towards the +Y axis. */
/* LONG is output in radians. The range of LONG is */
/* [-pi, pi]. */
/* LAT Geodetic latitude of the input point. For a point P */
/* on the reference spheroid, this is the angle between */
/* the XY plane and the outward normal vector at P. */
/* For a point P not on the reference spheroid, the */
/* geodetic latitude is that of the closest point to P on */
/* the spheroid. */
/* LAT is output in radians. The range of LAT is */
/* [-pi/2, pi/2]. */
/* ALT Altitude of point above the reference spheroid. */
/* The units associated with ALT are those associated */
/* with the input RECTAN. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the equatorial radius is non-positive, the error */
/* SPICE(VALUEOUTOFRANGE) is signaled. */
/* 2) If the flattening coefficient is greater than or equal to */
/* one, the error SPICE(VALUEOUTOFRANGE) is signaled. */
/* 3) For points inside the reference ellipsoid, the nearest */
/* point on the ellipsoid to RECTAN may not be unique, so */
/* latitude may not be well-defined. */
/* $ Files */
/* None. */
/* $ Particulars */
/* Given the body-fixed rectangular coordinates of a point, and the */
/* constants describing the reference spheroid, this routine */
/* returns the geodetic coordinates of the point. The body-fixed */
/* rectangular frame is that having the x-axis pass through the */
/* 0 degree latitude 0 degree longitude point. The y-axis passes */
/* through the 0 degree latitude 90 degree longitude. The z-axis */
/* passes through the 90 degree latitude point. For some bodies */
/* this coordinate system may not be a right-handed coordinate */
/* system. */
/* $ Examples */
/* This routine can be used to convert body fixed rectangular */
/* coordinates (such as the Satellite Tracking and Data Network */
/* of 1973) to geodetic coordinates such as those used by the */
/* United States Geological Survey topographic maps. */
/* The code would look something like this */
/* C */
/* C Shift the STDN-73 coordinates to line up with the center */
/* C of the Clark66 reference system. */
/* C */
/* CALL VSUB ( STDNX, OFFSET, X ) */
/* C */
/* C Using the equatorial radius of the Clark66 spheroid */
/* C (CLARKR = 6378.2064 km) and the Clark 66 flattening */
/* C factor (CLARKF = 1.0D0 / 294.9787D0 ) convert to */
/* C geodetic coordinates of the North American Datum of 1927. */
/* C */
/* CALL RECGEO ( X, CLARKR, CLARKF, LONG, LAT, ALT ) */
/* Below are two tables. */
/* Listed in the first table (under X(1), X(2) and X(3)) are a */
/* number of points whose rectangular coordinates are */
/* taken from the set {-1, 0, 1}. */
/* The results of the code fragment */
/* CALL RECGEO ( X, CLARKR, CLARKF, LONG, LAT, ALT ) */
/* Use the SPICELIB routine CONVRT to convert the angular */
/* quantities to degrees */
/* CALL CONVRT ( LAT, 'RADIANS', 'DEGREES', LAT ) */
/* CALL CONVRT ( LONG, 'RADIANS', 'DEGREES', LONG ) */
/* are listed to 4 decimal places in the second parallel table under */
/* LONG (longitude), LAT (latitude), and ALT (altitude). */
/* X(1) X(2) X(3) LONG LAT ALT */
/* -------------------------- ---------------------------- */
/* 0.0000 0.0000 0.0000 0.0000 90.0000 -6356.5838 */
/* 1.0000 0.0000 0.0000 0.0000 0.0000 -6377.2063 */
/* 0.0000 1.0000 0.0000 90.0000 0.0000 -6377.2063 */
/* 0.0000 0.0000 1.0000 0.0000 90.0000 -6355.5838 */
/* -1.0000 0.0000 0.0000 180.0000 0.0000 -6377.2063 */
/* 0.0000 -1.0000 0.0000 -90.0000 0.0000 -6377.2063 */
/* 0.0000 0.0000 -1.0000 0.0000 -90.0000 -6355.5838 */
/* 1.0000 1.0000 0.0000 45.0000 0.0000 -6376.7921 */
/* 1.0000 0.0000 1.0000 0.0000 88.7070 -6355.5725 */
/* 0.0000 1.0000 1.0000 90.0000 88.7070 -6355.5725 */
/* 1.0000 1.0000 1.0000 45.0000 88.1713 -6355.5612 */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* See FUNDAMENTALS OF ASTRODYNAMICS, Bate, Mueller, White */
/* published by Dover for a description of geodetic coordinates. */
/* $ Author_and_Institution */
/* C.H. Acton (JPL) */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.3, 02-JUL-2007 (NJB) */
/* In Examples section of header, description of right-hand */
/* table was updated to use correct names of columns. Term */
/* "bodyfixed" is now hyphenated. */
/* - SPICELIB Version 1.0.2, 30-JUL-2003 (NJB) (CHA) */
/* Various header changes were made to improve clarity. Some */
/* minor header corrections were made. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (WLT) */
/* -& */
/* $ Index_Entries */
/* rectangular to geodetic */
/* -& */
/* $ Revisions */
/* - Beta Version 3.0.1, 9-JUN-1989 (HAN) */
/* Error handling was added to detect and equatorial radius */
/* whose value is less than or equal to zero. */
/* - Beta Version 2.0.0, 21-DEC-1988 (HAN) */
/* Error handling to detect invalid flattening coefficients */
/* was added. Because the flattening coefficient is used to */
/* compute the length of an axis, it must be checked so that */
/* the length is greater than zero. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("RECGEO", (ftnlen)6);
}
/* The equatorial radius must be positive. If not, signal an error */
/* and check out. */
if (*re <= 0.) {
setmsg_("Equatorial radius was *.", (ftnlen)24);
errdp_("*", re, (ftnlen)1);
sigerr_("SPICE(VALUEOUTOFRANGE)", (ftnlen)22);
chkout_("RECGEO", (ftnlen)6);
return 0;
}
/* If the flattening coefficient is greater than one, the length */
/* of the 'C' axis computed below is negative. If it's equal to one, */
/* the length of the axis is zero. Either case is a problem, so */
/* signal an error and check out. */
if (*f >= 1.) {
setmsg_("Flattening coefficient was *.", (ftnlen)29);
errdp_("*", f, (ftnlen)1);
sigerr_("SPICE(VALUEOUTOFRANGE)", (ftnlen)22);
chkout_("RECGEO", (ftnlen)6);
return 0;
}
/* Determine the lengths of the axes of the reference ellipsoid. */
a = *re;
b = *re;
c__ = *re - *f * *re;
/* Find the point on the reference spheroid closes to the input point */
nearpt_(rectan, &a, &b, &c__, base, alt);
/* From this closest point determine the surface normal */
surfnm_(&a, &b, &c__, base, normal);
/* Using the surface normal, determine the latitude and longitude */
/* of the input point. */
reclat_(normal, &radius, long__, lat);
chkout_("RECGEO", (ftnlen)6);
return 0;
} /* recgeo_ */
/* $Procedure LGRIND (Lagrange polynomial interpolation with derivative) */
/* Subroutine */ int lgrind_(integer *n, doublereal *xvals, doublereal *yvals,
doublereal *work, doublereal *x, doublereal *p, doublereal *dp)
{
/* System generated locals */
integer xvals_dim1, yvals_dim1, work_dim1, work_offset, i__1, i__2, i__3,
i__4, i__5, i__6, i__7;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
integer i__, j;
extern /* Subroutine */ int chkin_(char *, ftnlen);
doublereal denom;
extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen);
doublereal c1, c2;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Evaluate a Lagrange interpolating polynomial for a specified */
/* set of coordinate pairs, at a specified abcissisa value. */
/* Return the value of both polynomial and derivative. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* INTERPOLATION */
/* POLYNOMIAL */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* N I Number of points defining the polynomial. */
/* XVALS I Abscissa values. */
/* YVALS I Ordinate values. */
/* WORK I-O Work space array. */
/* X I Point at which to interpolate the polynomial. */
/* P O Polynomial value at X. */
/* DP O Polynomial derivative at X. */
/* $ Detailed_Input */
/* N is the number of points defining the polynomial. */
/* The arrays XVALS and YVALS contain N elements. */
/* XVALS, */
/* YVALS are arrays of abscissa and ordinate values that */
/* together define N ordered pairs. The set of points */
/* ( XVALS(I), YVALS(I) ) */
/* define the Lagrange polynomial used for */
/* interpolation. The elements of XVALS must be */
/* distinct and in increasing order. */
/* WORK is an N x 2 work space array, where N is the same */
/* dimension as that of XVALS and YVALS. It is used */
/* by this routine as a scratch area to hold */
/* intermediate results. WORK is permitted to */
/* coincide with YVALS. */
/* X is the abscissa value at which the interpolating */
/* polynomial is to be evaluated. */
/* $ Detailed_Output */
/* P is the value at X of the unique polynomial of */
/* degree N-1 that fits the points in the plane */
/* defined by XVALS and YVALS. */
/* DP is the derivative at X of the interpolating */
/* polynomial described above. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If any two elements of the array XVALS are equal the error */
/* SPICE(DIVIDEBYZERO) will be signaled. */
/* 2) If N is less than 1, the error SPICE(INVALIDSIZE) is */
/* signaled. */
/* 3) This routine does not attempt to ward off or diagnose */
/* arithmetic overflows. */
/* $ Files */
/* None. */
/* $ Particulars */
/* Given a set of N distinct abscissa values and corresponding */
/* ordinate values, there is a unique polynomial of degree N-1, often */
/* called the `Lagrange polynomial', that fits the graph defined by */
/* these values. The Lagrange polynomial can be used to interpolate */
/* the value of a function at a specified point, given a discrete */
/* set of values of the function. */
/* Users of this routine must choose the number of points to use */
/* in their interpolation method. The authors of Reference [1] have */
/* this to say on the topic: */
/* Unless there is solid evidence that the interpolating function */
/* is close in form to the true function f, it is a good idea to */
/* be cautious about high-order interpolation. We */
/* enthusiastically endorse interpolations with 3 or 4 points, we */
/* are perhaps tolerant of 5 or 6; but we rarely go higher than */
/* that unless there is quite rigorous monitoring of estimated */
/* errors. */
/* The same authors offer this warning on the use of the */
/* interpolating function for extrapolation: */
/* ...the dangers of extrapolation cannot be overemphasized: */
/* An interpolating function, which is perforce an extrapolating */
/* function, will typically go berserk when the argument x is */
/* outside the range of tabulated values by more than the typical */
/* spacing of tabulated points. */
/* $ Examples */
/* 1) Fit a cubic polynomial through the points */
/* ( -1, -2 ) */
/* ( 0, -7 ) */
/* ( 1, -8 ) */
/* ( 3, 26 ) */
/* and evaluate this polynomial at x = 2. */
/* PROGRAM TEST_LGRIND */
/* DOUBLE PRECISION P */
/* DOUBLE PRECISION DP */
/* DOUBLE PRECISION XVALS (4) */
/* DOUBLE PRECISION YVALS (4) */
/* DOUBLE PRECISION WORK (4,2) */
/* INTEGER N */
/* N = 4 */
/* XVALS(1) = -1 */
/* XVALS(2) = 0 */
/* XVALS(3) = 1 */
/* XVALS(4) = 3 */
/* YVALS(1) = -2 */
/* YVALS(2) = -7 */
/* YVALS(3) = -8 */
/* YVALS(4) = 26 */
/* CALL LGRIND ( N, XVALS, YVALS, WORK, 2.D0, P, DP ) */
/* WRITE (*,*) 'P, DP = ', P, DP */
/* END */
/* The returned value of P should be 1.D0, since the */
/* unique cubic polynomial that fits these points is */
/* 3 2 */
/* f(x) = x + 2x - 4x - 7 */
/* The returned value of DP should be 1.6D1, since the */
/* derivative of f(x) is */
/* ' 2 */
/* f (x) = 3x + 4x - 4 */
/* We also could have invoked LGRIND with the reference */
/* CALL LGRIND ( N, XVALS, YVALS, YVALS, 2.D0, P, DP ) */
/* if we wished to; in this case YVALS would have been */
/* modified on output. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* [1] "Numerical Recipes---The Art of Scientific Computing" by */
/* William H. Press, Brian P. Flannery, Saul A. Teukolsky, */
/* William T. Vetterling (see sections 3.0 and 3.1). */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 20-AUG-2002 (NJB) */
/* -& */
/* $ Index_Entries */
/* interpolate function using Lagrange polynomial */
/* Lagrange interpolation */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Check in only if an error is detected. */
/* Parameter adjustments */
work_dim1 = *n;
work_offset = work_dim1 + 1;
yvals_dim1 = *n;
xvals_dim1 = *n;
/* Function Body */
if (return_()) {
return 0;
}
/* No data, no interpolation. */
if (*n < 1) {
chkin_("LGRIND", (ftnlen)6);
setmsg_("Array size must be positive; was #.", (ftnlen)35);
errint_("#", n, (ftnlen)1);
sigerr_("SPICE(INVALIDSIZE)", (ftnlen)18);
chkout_("LGRIND", (ftnlen)6);
return 0;
}
/* We're going to compute the value of our interpolating polynomial */
/* at X by taking advantage of a recursion relation between */
/* Lagrange polynomials of order n+1 and order n. The method works */
/* as follows: */
/* Define */
/* P (x) */
/* i(i+1)...(i+j) */
/* to be the unique Lagrange polynomial that interpolates our */
/* input function at the abscissa values */
/* x , x , ... x . */
/* i i+1 i+j */
/* Then we have the recursion relation */
/* P (x) = */
/* i(i+1)...(i+j) */
/* x - x */
/* i */
/* ----------- * P (x) */
/* x - x (i+1)...(i+j) */
/* i i+j */
/* x - x */
/* i+j */
/* + ----------- * P (x) */
/* x - x i(i+1)...(i+j-1) */
/* i i+j */
/* Repeated application of this relation allows us to build */
/* successive columns, in left-to-right order, of the */
/* triangular table */
/* P (x) */
/* 1 */
/* P (x) */
/* 12 */
/* P (x) P (x) */
/* 2 123 */
/* P (x) */
/* 23 . */
/* P (x) */
/* . 234 . */
/* . */
/* . . . */
/* . */
/* . . P (x) */
/* . . 12...N */
/* . */
/* . */
/* . */
/* P (x) */
/* (N-2)(N-1)N */
/* P (x) */
/* (N-1)N */
/* P (x) */
/* N */
/* and after N-1 steps arrive at our desired result, */
/* P (x). */
/* 12...N */
/* The computation is easier to do than to describe. */
/* We'll use the scratch array WORK to contain the current column of */
/* our interpolation table. To start out with, WORK(I) will contain */
/* P (x). */
/* I */
/* For columns 2...N of the table, we'll also carry along the */
/* derivative at X of each interpolating polynomial. This will */
/* allow us to find the derivative of the Lagrange polynomial */
/* at X. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[(i__2 = i__ + work_dim1 - work_offset) < work_dim1 << 1 && 0 <=
i__2 ? i__2 : s_rnge("work", i__2, "lgrind_", (ftnlen)374)] =
yvals[(i__3 = i__ - 1) < yvals_dim1 && 0 <= i__3 ? i__3 :
s_rnge("yvals", i__3, "lgrind_", (ftnlen)374)];
work[(i__2 = i__ + (work_dim1 << 1) - work_offset) < work_dim1 << 1 &&
0 <= i__2 ? i__2 : s_rnge("work", i__2, "lgrind_", (ftnlen)
375)] = 0.;
}
/* Compute columns 2 through N of the table. Note that DENOM must */
/* be non-zero, or else a divide-by-zero error will occur. */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
for (i__ = 1; i__ <= i__2; ++i__) {
denom = xvals[(i__3 = i__ - 1) < xvals_dim1 && 0 <= i__3 ? i__3 :
s_rnge("xvals", i__3, "lgrind_", (ftnlen)387)] - xvals[(
i__4 = i__ + j - 1) < xvals_dim1 && 0 <= i__4 ? i__4 :
s_rnge("xvals", i__4, "lgrind_", (ftnlen)387)];
if (denom == 0.) {
chkin_("LGRIND", (ftnlen)6);
setmsg_("XVALS(#) = XVALS(#) = #", (ftnlen)23);
errint_("#", &i__, (ftnlen)1);
i__3 = i__ + j;
errint_("#", &i__3, (ftnlen)1);
errdp_("#", &xvals[(i__3 = i__ - 1) < xvals_dim1 && 0 <= i__3
? i__3 : s_rnge("xvals", i__3, "lgrind_", (ftnlen)395)
], (ftnlen)1);
sigerr_("SPICE(DIVIDEBYZERO)", (ftnlen)19);
chkout_("LGRIND", (ftnlen)6);
return 0;
}
c1 = *x - xvals[(i__3 = i__ + j - 1) < xvals_dim1 && 0 <= i__3 ?
i__3 : s_rnge("xvals", i__3, "lgrind_", (ftnlen)402)];
c2 = xvals[(i__3 = i__ - 1) < xvals_dim1 && 0 <= i__3 ? i__3 :
s_rnge("xvals", i__3, "lgrind_", (ftnlen)403)] - *x;
/* Use the chain rule to compute the derivatives. Do this */
/* before computing the function value, because the latter */
/* computation will overwrite the first column of WORK. */
work[(i__3 = i__ + (work_dim1 << 1) - work_offset) < work_dim1 <<
1 && 0 <= i__3 ? i__3 : s_rnge("work", i__3, "lgrind_", (
ftnlen)410)] = (c1 * work[(i__4 = i__ + (work_dim1 << 1)
- work_offset) < work_dim1 << 1 && 0 <= i__4 ? i__4 :
s_rnge("work", i__4, "lgrind_", (ftnlen)410)] + c2 * work[
(i__5 = i__ + 1 + (work_dim1 << 1) - work_offset) <
work_dim1 << 1 && 0 <= i__5 ? i__5 : s_rnge("work", i__5,
"lgrind_", (ftnlen)410)] + (work[(i__6 = i__ + work_dim1
- work_offset) < work_dim1 << 1 && 0 <= i__6 ? i__6 :
s_rnge("work", i__6, "lgrind_", (ftnlen)410)] - work[(
i__7 = i__ + 1 + work_dim1 - work_offset) < work_dim1 <<
1 && 0 <= i__7 ? i__7 : s_rnge("work", i__7, "lgrind_", (
ftnlen)410)])) / denom;
/* Compute the Ith entry in the Jth column. */
work[(i__3 = i__ + work_dim1 - work_offset) < work_dim1 << 1 && 0
<= i__3 ? i__3 : s_rnge("work", i__3, "lgrind_", (ftnlen)
416)] = (c1 * work[(i__4 = i__ + work_dim1 - work_offset)
< work_dim1 << 1 && 0 <= i__4 ? i__4 : s_rnge("work",
i__4, "lgrind_", (ftnlen)416)] + c2 * work[(i__5 = i__ +
1 + work_dim1 - work_offset) < work_dim1 << 1 && 0 <=
i__5 ? i__5 : s_rnge("work", i__5, "lgrind_", (ftnlen)416)
]) / denom;
}
}
/* Our results are sitting in WORK(1,1) and WORK(1,2) at this point. */
*p = work[(i__1 = work_dim1 + 1 - work_offset) < work_dim1 << 1 && 0 <=
i__1 ? i__1 : s_rnge("work", i__1, "lgrind_", (ftnlen)425)];
*dp = work[(i__1 = (work_dim1 << 1) + 1 - work_offset) < work_dim1 << 1 &&
0 <= i__1 ? i__1 : s_rnge("work", i__1, "lgrind_", (ftnlen)426)];
return 0;
} /* lgrind_ */
/* $Procedure ZZEKRD03 ( EK, read class 3 column entry elements ) */
/* Subroutine */ int zzekrd03_(integer *handle, integer *segdsc, integer *
coldsc, integer *recptr, integer *cvlen, char *cval, logical *isnull,
ftnlen cval_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer nrec, bpos;
extern integer zzekrp2n_(integer *, integer *, integer *);
integer epos, unit;
extern /* Subroutine */ int zzekcnam_(integer *, integer *, char *,
ftnlen), zzekpgbs_(integer *, integer *, integer *), zzekpgpg_(
integer *, integer *, integer *, integer *);
integer b, e, l, n, p, pbase, avail;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
integer recno, ncols;
extern /* Subroutine */ int dasrdc_(integer *, integer *, integer *,
integer *, integer *, char *, ftnlen), dasrdi_(integer *, integer
*, integer *, integer *);
char column[32];
integer colidx, datptr, relptr, ptrloc;
extern /* Subroutine */ int dashlu_(integer *, integer *), setmsg_(char *,
ftnlen), errint_(char *, integer *, ftnlen), errfnm_(char *,
integer *, ftnlen), sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), zzekgei_(integer *, integer *, integer *);
/* $ Abstract */
/* Read a column entry from a specified record in a class 3 column. */
/* Class 3 columns contain scalar character values. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* EK */
/* $ Keywords */
/* EK */
/* PRIVATE */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Boolean Enumerated Type */
/* ekbool.inc Version 1 21-DEC-1994 (NJB) */
/* Within the EK system, boolean values sometimes must be */
/* represented by integer or character codes. The codes and their */
/* meanings are listed below. */
/* Integer code indicating `true': */
/* Integer code indicating `false': */
/* Character code indicating `true': */
/* Character code indicating `false': */
/* End Include Section: EK Boolean Enumerated Type */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Column Descriptor Parameters */
/* ekcoldsc.inc Version 6 23-AUG-1995 (NJB) */
/* Note: The column descriptor size parameter CDSCSZ is */
/* declared separately in the include section CDSIZE$INC.FOR. */
/* Offset of column descriptors, relative to start of segment */
/* integer address range. This number, when added to the last */
/* integer address preceding the segment, yields the DAS integer */
/* base address of the first column descriptor. Currently, this */
/* offset is exactly the size of a segment descriptor. The */
/* parameter SDSCSZ, which defines the size of a segment descriptor, */
/* is declared in the include file eksegdsc.inc. */
/* Size of column descriptor */
/* Indices of various pieces of column descriptors: */
/* CLSIDX is the index of the column's class code. (We use the */
/* word `class' to distinguish this item from the column's data */
/* type.) */
/* TYPIDX is the index of the column's data type code (CHR, INT, DP, */
/* or TIME). The type is actually implied by the class, but it */
/* will frequently be convenient to look up the type directly. */
/* LENIDX is the index of the column's string length value, if the */
/* column has character type. A value of IFALSE in this element of */
/* the descriptor indicates that the strings have variable length. */
/* SIZIDX is the index of the column's element size value. This */
/* descriptor element is meaningful for columns with fixed-size */
/* entries. For variable-sized columns, this value is IFALSE. */
/* NAMIDX is the index of the base address of the column's name. */
/* IXTIDX is the data type of the column's index. IXTIDX */
/* contains a type value only if the column is indexed. For columns */
/* that are not indexed, the location IXTIDX contains the boolean */
/* value IFALSE. */
/* IXPIDX is a pointer to the column's index. IXTPDX contains a */
/* meaningful value only if the column is indexed. The */
/* interpretation of the pointer depends on the data type of the */
/* index. */
/* NFLIDX is the index of a flag indicating whether nulls are */
/* permitted in the column. The value at location NFLIDX is */
/* ITRUE if nulls are permitted and IFALSE otherwise. */
/* ORDIDX is the index of the column's ordinal position in the */
/* list of columns belonging to the column's parent segment. */
/* METIDX is the index of the column's integer metadata pointer. */
/* This pointer is a DAS integer address. */
/* The last position in the column descriptor is reserved. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Column Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Column Name Size */
/* ekcnamsz.inc Version 1 17-JAN-1995 (NJB) */
/* Size of column name, in characters. */
/* End Include Section: EK Column Name Size */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Data Page Parameters */
/* ekfilpar.inc Version 1 03-APR-1995 (NJB) */
/* These parameters apply to EK files using architecture 4. */
/* These files use a paged DAS file as their underlying file */
/* structure. */
/* In paged DAS EK files, data pages are structured: they contain */
/* metadata as well as data. The metadata is located in the last */
/* few addresses of each page, so as to interfere as little as */
/* possible with calculation of data addresses. */
/* Each data page belongs to exactly one segment. Some bookkeeping */
/* information, such as record pointers, is also stored in data */
/* pages. */
/* Each page contains a forward pointer that allows rapid lookup */
/* of data items that span multiple pages. Each page also keeps */
/* track of the current number of links from its parent segment */
/* to the page. Link counts enable pages to `know' when they */
/* are no longer in use by a segment; unused pages are deallocated */
/* and returned to the free list. */
/* The parameters in this include file depend on the parameters */
/* declared in the include file ekpage.inc. If those parameters */
/* change, this file must be updated. The specified parameter */
/* declarations we need from that file are: */
/* INTEGER PGSIZC */
/* PARAMETER ( PGSIZC = 1024 ) */
/* INTEGER PGSIZD */
/* PARAMETER ( PGSIZD = 128 ) */
/* INTEGER PGSIZI */
/* PARAMETER ( PGSIZI = 256 ) */
/* Character pages use an encoding mechanism to represent integer */
/* metadata. Each integer is encoded in five consecutive */
/* characters. */
/* Character data page parameters: */
/* Size of encoded integer: */
/* Usable page size: */
/* Location of character forward pointer: */
/* Location of character link count: */
/* Double precision data page parameters: */
/* Usable page size: */
/* Location of d.p. forward pointer: */
/* Location of d.p. link count: */
/* Integer data page parameters: */
/* Usable page size: */
/* Location of integer forward pointer: */
/* Location of integer link count: */
/* End Include Section: EK Data Page Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Record Pointer Parameters */
/* ekrecptr.inc Version 2 18-JUL-1995 (NJB) */
/* This file declares parameters used in EK record pointers. */
/* Each segment references data in a given record via two levels */
/* of indirection: a record number points to a record pointer, */
/* which is a structured array of metadata and data pointers. */
/* Record pointers always occupy contiguous ranges of integer */
/* addresses. */
/* The parameter declarations in this file depend on the assumption */
/* that integer pages contain 256 DAS integer words and that the */
/* maximum number of columns in a segment is 100. Record pointers */
/* are stored in integer data pages, so they must fit within the */
/* usable data area afforded by these pages. The size of the usable */
/* data area is given by the parameter IPSIZE which is declared in */
/* ekdatpag.inc. The assumed value of IPSIZE is 254. */
/* The first element of each record pointer is a status indicator. */
/* The meanings of status indicators depend on whether the parent EK */
/* is shadowed or not. For shadowed EKs, allowed status values and */
/* their meanings are: */
/* OLD The record has not been modified since */
/* the EK containing the record was opened. */
/* UPDATE The record is an update of a previously existing */
/* record. The original record is now on the */
/* modified record list. */
/* NEW The record has been added since the EK containing the */
/* record was opened. The record is not an update */
/* of a previously existing record. */
/* DELOLD This status applies only to a backup record. */
/* DELOLD status indicates that the record corresponds */
/* to a deleted OLD record in the source segment. */
/* DELNEW This status applies only to a backup record. */
/* DELNEW status indicates that the record corresponds */
/* to a deleted NEW record in the source segment. */
/* DELUPD This status applies only to a backup record. */
/* DELUPD status indicates that the record corresponds */
/* to a deleted UPDATEd record in the source segment. */
/* In EKs that are not shadowed, all records have status OLD. */
/* The following parameters refer to indices within the record */
/* pointer structure: */
/* Index of status indicator: */
/* Each record pointer contains a pointer to its companion: for a */
/* record belonging to a shadowed EK, this is the backup counterpart, */
/* or if the parent EK is itself a backup EK, a pointer to the */
/* record's source record. The pointer is UNINIT (see below) if the */
/* record is unmodified. */
/* Record companion pointers contain record numbers, not record */
/* base addresses. */
/* Index of record's companion pointer: */
/* Each data item is referenced by an integer. The meaning of */
/* this integer depends on the representation of data in the */
/* column to which the data item belongs. Actual lookup of a */
/* data item must be done by subroutines appropriate to the class of */
/* the column to which the item belongs. Note that data items don't */
/* necessarily occupy contiguous ranges of DAS addresses. */
/* Base address of data pointers: */
/* Maximum record pointer size: */
/* Data pointers are given the value UNINIT to start with; this */
/* indicates that the data item is uninitialized. UNINIT is */
/* distinct from the value NULL. NOBACK indicates an uninitialized */
/* backup column entry. */
/* End Include Section: EK Record Pointer Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Segment Descriptor Parameters */
/* eksegdsc.inc Version 8 06-NOV-1995 (NJB) */
/* All `base addresses' referred to below are the addresses */
/* *preceding* the item the base applies to. This convention */
/* enables simplied address calculations in many cases. */
/* Size of segment descriptor. Note: the include file ekcoldsc.inc */
/* must be updated if this parameter is changed. The parameter */
/* CDOFF in that file should be kept equal to SDSCSZ. */
/* Index of the segment type code: */
/* Index of the segment's number. This number is the segment's */
/* index in the list of segments contained in the EK to which */
/* the segment belongs. */
/* Index of the DAS integer base address of the segment's integer */
/* meta-data: */
/* Index of the DAS character base address of the table name: */
/* Index of the segment's column count: */
/* Index of the segment's record count: */
/* Index of the root page number of the record tree: */
/* Index of the root page number of the character data page tree: */
/* Index of the root page number of the double precision data page */
/* tree: */
/* Index of the root page number of the integer data page tree: */
/* Index of the `modified' flag: */
/* Index of the `initialized' flag: */
/* Index of the shadowing flag: */
/* Index of the companion file handle: */
/* Index of the companion segment number: */
/* The next three items are, respectively, the page numbers of the */
/* last character, d.p., and integer data pages allocated by the */
/* segment: */
/* The next three items are, respectively, the page-relative */
/* indices of the last DAS word in use in the segment's */
/* last character, d.p., and integer data pages: */
/* Index of the DAS character base address of the column name list: */
/* The last descriptor element is reserved for future use. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Segment Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Data Types */
/* ektype.inc Version 1 27-DEC-1994 (NJB) */
/* Within the EK system, data types of EK column contents are */
/* represented by integer codes. The codes and their meanings */
/* are listed below. */
/* Integer codes are also used within the DAS system to indicate */
/* data types; the EK system makes no assumptions about compatibility */
/* between the codes used here and those used in the DAS system. */
/* Character type: */
/* Double precision type: */
/* Integer type: */
/* `Time' type: */
/* Within the EK system, time values are represented as ephemeris */
/* seconds past J2000 (TDB), and double precision numbers are used */
/* to store these values. However, since time values require special */
/* treatment both on input and output, and since the `TIME' column */
/* has a special role in the EK specification and code, time values */
/* are identified as a type distinct from double precision numbers. */
/* End Include Section: EK Data Types */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle attached to EK file. */
/* SEGDSC I Segment descriptor. */
/* COLDSC I Column descriptor. */
/* RECPTR I Record pointer. */
/* CVLEN O Length of returned character value. */
/* CVAL O Character value in column entry. */
/* ISNULL O Flag indicating whether column entry is null. */
/* $ Detailed_Input */
/* HANDLE is an EK file handle. */
/* SEGDSC is the descriptor of the segment from which data is */
/* to be read. */
/* COLDSC is the descriptor of the column from which data is */
/* to be read. */
/* RECPTR is a pointer to the record containing the column */
/* entry to be written. */
/* $ Detailed_Output */
/* CVLEN is the length of the returned string value. This */
/* is the index of the last non-blank character of */
/* the string. This definition applies to both fixed- */
/* and variable-length strings. */
/* CVLEN is set to 1 if the column entry is null. */
/* CVAL is the value read from the specified column entry. */
/* If CVAL has insufficient length to hold the */
/* returned string value, the output value is */
/* truncated on the right. Entries that are shorter */
/* than the string length of CVAL are padded with */
/* trailing blanks. */
/* ISNULL is a logical flag indicating whether the entry is */
/* null. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If HANDLE is invalid, the error will be diagnosed by routines */
/* called by this routine. */
/* 2) If the specified column entry has not been initialized, the */
/* error SPICE(UNINITIALIZED) is signaled. */
/* 3) If the ordinal position of the column specified by COLDSC */
/* is out of range, the error SPICE(INVALIDINDEX) is signaled. */
/* 4) If the output string CVAL is too short to accommodate the */
/* returned string value, the output value is truncated on the */
/* right. No error is signaled. */
/* 5) If an I/O error occurs while reading the indicated file, */
/* the error will be diagnosed by routines called by this */
/* routine. */
/* $ Files */
/* See the EK Required Reading for a discussion of the EK file */
/* format. */
/* $ Particulars */
/* This routine is a utility for reading data from class 3 columns. */
/* $ Examples */
/* See EKRCEC. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.3.0, 31-MAY-2010 (NJB) */
/* Bug fix: call to DASRDI was overwriting local memory. This */
/* problem did not affect operation of the routine except on */
/* the Mac/Intel/OSX/ifort/32-bit platform, on which it caused */
/* a segmentation fault when this routine was compiled with */
/* default optimization. */
/* - SPICELIB Version 1.2.0, 23-JUL-1999 (NJB) */
/* Error check for string truncation on output was removed. */
/* This error check interfered with the use of this routine */
/* (via a call to ZZEKRSC) within ZZEKJSRT, which relies on */
/* being able to read into a buffer initial substrings of scalar */
/* data. */
/* - SPICELIB Version 1.1.0, 28-JUL-1997 (NJB) */
/* Error check for string truncation on output was added. */
/* SHORT error message SPICE(UNINITIALIZEDVALUE) was shortened */
/* to SPICE(UNINITIALIZED). Error messages were enhanced so */
/* as to use column names rather than indices. Miscellaneous */
/* header fixes were made. */
/* - SPICELIB Version 1.0.0, 18-OCT-1995 (NJB) */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.2.0, 23-JUL-1999 (NJB) */
/* Error check for string truncation on output was removed. */
/* This error check interfered with the use of this routine */
/* (via a call to ZZEKRSC) within ZZEKJSRT, which relies on */
/* being able to read into a buffer initial substrings of scalar */
/* data. */
/* - SPICELIB Version 1.1.0, 25-JUL-1997 (NJB) */
/* Error check for string truncation on output was added. */
/* SHORT error message SPICE(UNINITIALIZEDVALUE) was shortened */
/* to SPICE(UNINITIALIZED), since the previous string exceeded */
/* the maximum allowed length for the short error message. */
/* Error messages were enhanced so as to use column names rather */
/* than indices. */
/* -& */
/* Non-SPICELIB functions */
/* Local variables */
/* Use discovery check-in. */
/* Make sure the column exists. */
ncols = segdsc[4];
colidx = coldsc[8];
if (colidx < 1 || colidx > ncols) {
recno = zzekrp2n_(handle, &segdsc[1], recptr);
dashlu_(handle, &unit);
chkin_("ZZEKRD03", (ftnlen)8);
setmsg_("Column index = #; valid range is 1:#.SEGNO = #; RECNO = #; "
"EK = #", (ftnlen)65);
errint_("#", &colidx, (ftnlen)1);
errint_("#", &nrec, (ftnlen)1);
errint_("#", &segdsc[1], (ftnlen)1);
errint_("#", &recno, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(INVALIDINDEX)", (ftnlen)19);
chkout_("ZZEKRD03", (ftnlen)8);
return 0;
}
/* Compute the data pointer location, and read both the pointer */
/* and the stored string size. */
ptrloc = *recptr + 2 + colidx;
dasrdi_(handle, &ptrloc, &ptrloc, &datptr);
if (datptr > 0) {
/* Read the value. This is slightly more complicated than */
/* the numeric cases, because the value may be spread across */
/* multiple pages. Also, we must not write past the end of the */
/* output string. */
/* We'll need the number of the page at which the first character */
/* of the string is stored. This page contains at least one */
/* character of the data value. */
zzekgei_(handle, &datptr, cvlen);
/* Set the data pointer to the start of the string data, skipping */
/* over the encoded string length. */
datptr += 5;
/* Computing MIN */
i__1 = *cvlen, i__2 = i_len(cval, cval_len);
n = min(i__1,i__2);
/* Read the available data from the page under consideration. */
zzekpgpg_(&c__1, &datptr, &p, &pbase);
relptr = datptr - pbase;
/* Computing MIN */
i__1 = n, i__2 = 1014 - relptr + 1;
avail = min(i__1,i__2);
b = datptr;
e = datptr + avail - 1;
bpos = 1;
epos = avail;
l = epos - bpos + 1;
dasrdc_(handle, &b, &e, &bpos, &epos, cval, cval_len);
n -= l;
while(n > 0) {
/* Read the forward page pointer from the current page; find */
/* the base address of the referenced page. */
i__1 = pbase + 1015;
zzekgei_(handle, &i__1, &p);
zzekpgbs_(&c__1, &p, &pbase);
avail = min(n,1014);
b = pbase + 1;
e = pbase + avail;
bpos = epos + 1;
epos += avail;
dasrdc_(handle, &b, &e, &bpos, &epos, cval, cval_len);
n -= avail;
bpos = epos + 1;
}
/* Blank-pad CVAL if required. */
if (i_len(cval, cval_len) > epos) {
i__1 = epos;
s_copy(cval + i__1, " ", cval_len - i__1, (ftnlen)1);
}
*isnull = FALSE_;
} else if (datptr == -2) {
/* The value is null. */
*isnull = TRUE_;
*cvlen = 1;
} else if (datptr == -1 || datptr == -3) {
/* The data value is absent. This is an error. */
recno = zzekrp2n_(handle, &segdsc[1], recptr);
dashlu_(handle, &unit);
zzekcnam_(handle, coldsc, column, (ftnlen)32);
chkin_("ZZEKRD03", (ftnlen)8);
setmsg_("Attempted to read uninitialized column entry. SEGNO = #; C"
"OLUMN = #; RECNO = #; EK = #", (ftnlen)87);
errint_("#", &segdsc[1], (ftnlen)1);
errch_("#", column, (ftnlen)1, (ftnlen)32);
errint_("#", &recno, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(UNINITIALIZED)", (ftnlen)20);
chkout_("ZZEKRD03", (ftnlen)8);
return 0;
} else {
/* The data pointer is corrupted. */
recno = zzekrp2n_(handle, &segdsc[1], recptr);
dashlu_(handle, &unit);
zzekcnam_(handle, coldsc, column, (ftnlen)32);
chkin_("ZZEKRD03", (ftnlen)8);
setmsg_("Data pointer is corrupted. SEGNO = #; COLUMN = #; RECNO = "
"#; EK = #", (ftnlen)68);
errint_("#", &segdsc[1], (ftnlen)1);
errch_("#", column, (ftnlen)1, (ftnlen)32);
errint_("#", &recno, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZEKRD03", (ftnlen)8);
return 0;
}
return 0;
} /* zzekrd03_ */
/* $Procedure EKOPN ( EK, open new file ) */
/* Subroutine */ int ekopn_(char *fname, char *ifname, integer *ncomch,
integer *handle, ftnlen fname_len, ftnlen ifname_len)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
integer base;
extern /* Subroutine */ int zzekpgan_(integer *, integer *, integer *,
integer *), zzekpgin_(integer *), zzektrit_(integer *, integer *);
integer p;
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern logical failed_(void);
extern /* Subroutine */ int dasudi_(integer *, integer *, integer *,
integer *), sigerr_(char *, ftnlen), dasonw_(char *, char *, char
*, integer *, integer *, ftnlen, ftnlen, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
extern logical return_(void);
integer ncr;
/* $ Abstract */
/* Open a new E-kernel file and prepare the file for writing. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* EK */
/* NAIF_IDS */
/* TIME */
/* $ Keywords */
/* EK */
/* FILES */
/* UTILITY */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Data Types */
/* ektype.inc Version 1 27-DEC-1994 (NJB) */
/* Within the EK system, data types of EK column contents are */
/* represented by integer codes. The codes and their meanings */
/* are listed below. */
/* Integer codes are also used within the DAS system to indicate */
/* data types; the EK system makes no assumptions about compatibility */
/* between the codes used here and those used in the DAS system. */
/* Character type: */
/* Double precision type: */
/* Integer type: */
/* `Time' type: */
/* Within the EK system, time values are represented as ephemeris */
/* seconds past J2000 (TDB), and double precision numbers are used */
/* to store these values. However, since time values require special */
/* treatment both on input and output, and since the `TIME' column */
/* has a special role in the EK specification and code, time values */
/* are identified as a type distinct from double precision numbers. */
/* End Include Section: EK Data Types */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK File Metadata Parameters */
/* ekfilpar.inc Version 1 28-MAR-1995 (NJB) */
/* These parameters apply to EK files using architecture 4. */
/* These files use a paged DAS file as their underlying file */
/* structure. */
/* The metadata for an architecture 4 EK file is very simple: it */
/* consists of a single integer, which is a pointer to a tree */
/* that in turn points to the segments in the EK. However, in the */
/* interest of upward compatibility, one integer page is reserved */
/* for the file's metadata. */
/* Size of file parameter block: */
/* All offsets shown below are relative to the beginning of the */
/* first integer page in the EK. */
/* Index of the segment pointer tree---this location contains the */
/* root page number of the tree: */
/* End Include Section: EK File Metadata Parameters */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* FNAME I Name of EK file. */
/* IFNAME I Internal file name. */
/* NCOMCH I The number of characters to reserve for comments. */
/* HANDLE O Handle attached to new EK file. */
/* $ Detailed_Input */
/* FNAME is the name of a new E-kernel file to be created. */
/* IFNAME is the internal file name of a new E-kernel. The */
/* internal file name may be up to 60 characters in */
/* length. */
/* NCOMCH is the amount of space, measured in characters, to */
/* be allocated in the comment area when the new EK */
/* file is created. It is not necessary to allocate */
/* space in advance in order to add comments, but */
/* doing so may greatly increase the efficiency with */
/* which comments may be added. Making room for */
/* comments after data has already been added to the */
/* file involves moving the data, and thus is slower. */
/* NCOMCH must be greater than or equal to zero. */
/* $ Detailed_Output */
/* HANDLE is the EK handle of the file designated by FNAME. */
/* This handle is used to identify the file to other */
/* EK routines. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If NCOMCH is less than zero, the error SPICE(INVALIDCOUNT) */
/* will be signalled. No file will be created. */
/* 2) If IFNAME is invalid, the error will be diagnosed by routines */
/* called by this routine. */
/* 3) If the indicated file cannot be opened, the error will be */
/* diagnosed by routines called by this routine. The new file */
/* will be deleted. */
/* 4) If an I/O error occurs while reading or writing the indicated */
/* file, the error will be diagnosed by routines called by this */
/* routine. */
/* $ Files */
/* See the EK Required Reading for a discussion of the EK file */
/* format. */
/* $ Particulars */
/* This routine operates by side effects: it opens and prepares */
/* an EK for addition of data. */
/* $ Examples */
/* 1) Open a new EK file with name 'my.ek' and internal file */
/* name 'test ek/1995-JUL-17': */
/* CALL EKOPN ( 'my.ek', 'test ek/1995-JUL-17', HANDLE ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - Beta Version 1.0.0, 26-SEP-1995 (NJB) */
/* -& */
/* $ Index_Entries */
/* open new E-kernel */
/* open new EK */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("EKOPN", (ftnlen)5);
}
/* Check the comment character count. */
if (*ncomch < 0) {
setmsg_("The number of reserved comment characters must be non-negat"
"ive but was #.", (ftnlen)73);
errint_("#", ncomch, (ftnlen)1);
sigerr_("SPICE(INVALIDCOUNT)", (ftnlen)19);
chkout_("EKOPN", (ftnlen)5);
return 0;
}
/* A new DAS file is a must. The file type is EK. */
/* Reserve enough comment records to accommodate the requested */
/* number of comment characters. */
ncr = (*ncomch + 1023) / 1024;
dasonw_(fname, "EK", ifname, &ncr, handle, fname_len, (ftnlen)2,
ifname_len);
if (failed_()) {
chkout_("EKOPN", (ftnlen)5);
return 0;
}
/* Initialize the file for paged access. The EK architecture */
/* code is automatically set by the paging initialization routine. */
zzekpgin_(handle);
if (failed_()) {
chkout_("EKOPN", (ftnlen)5);
return 0;
}
/* Allocate the first integer page for the file's metadata. We */
/* don't need to examine the page number; it's 1. */
zzekpgan_(handle, &c__3, &p, &base);
/* Initialize a new tree. This tree will point to the file's */
/* segments. */
zzektrit_(handle, &p);
/* Save the segment pointer's root page number. */
i__1 = base + 1;
i__2 = base + 1;
dasudi_(handle, &i__1, &i__2, &p);
/* That's it. We're ready to add data to the file. */
chkout_("EKOPN", (ftnlen)5);
return 0;
} /* ekopn_ */
/* $Procedure SSIZEC ( Set the size of a character cell ) */
/* Subroutine */ int ssizec_(integer *size, char *cell, ftnlen cell_len)
{
integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), enchar_(integer *,
char *, ftnlen), sigerr_(char *, ftnlen), chkout_(char *, ftnlen),
setmsg_(char *, ftnlen), errint_(char *, integer *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Set the size (maximum cardinality) of a character cell. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* CELLS */
/* $ Keywords */
/* CELLS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* SIZE I Size (maximum cardinality) of the cell. */
/* CELL O The cell. */
/* $ Detailed_Input */
/* SIZE is the size (maximum number of elements) of the cell. */
/* $ Detailed_Output */
/* CELL is a cell. */
/* On output, the size of the cell is SIZE. The */
/* cardinality of the cell is 0. The rest of the */
/* control area is zeroed out. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* The set cardinality (SCARDC, SCARDD, and SCARDI) and set size */
/* (SSIZEC, SSIZED, and SSIZEI) routines are typically used to */
/* initialize cells for subsequent use. Since all cell routines */
/* expect to find the size and cardinality of a cell in place, */
/* no cell can be used until both have been set. */
/* $ Examples */
/* In the example below, the size and cardinality of the character */
/* cell FRED are set in the main module of the program FLNSTN. */
/* Both are subsequently retrieved, and the cardinality changed, */
/* in one of its subroutines, WILMA. */
/* PROGRAM FLNSTN */
/* CHARACTER*30 FRED ( LBCELL:100 ) */
/* . */
/* . */
/* CALL SSIZEC ( 100, FRED ) */
/* . */
/* . */
/* CALL WILMA ( FRED ) */
/* . */
/* . */
/* STOP */
/* END */
/* SUBROUTINE WILMA ( FRED ) */
/* CHARACTER*(*) FRED ( LBCELL:* ) */
/* INTEGER SIZE */
/* INTEGER CARD */
/* INTEGER CARDC */
/* INTEGER SIZEC */
/* . */
/* . */
/* SIZE = SIZEC ( FRED ) */
/* CARD = CARDC ( FRED ) */
/* . */
/* . */
/* CALL SCARDC ( MIN ( SIZE, CARD ), FRED ) */
/* CALL EXCESS ( CARD-SIZE, 'cell' ) */
/* . */
/* . */
/* RETURN */
/* END */
/* $ Restrictions */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Files */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* C.A. Curzon (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (CAC) (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* set the size of a character cell */
/* -& */
/* $ Revisions */
/* - Beta Version 2.0.0, 13-MAR-1989 (NJB) */
/* Check for invalid size value added. An error */
/* is signalled if the value is out of range. The cardinality */
/* is now automatically reset to 0. The rest of the control */
/* area is now zeroed out. */
/* The examples have been updated to illustrate set initialization */
/* without the use of the EMPTYx routines, which have been */
/* removed from the library. Errors in the examples have been */
/* removed, also. */
/* -& */
/* SPICELIB functions */
/* Local variables */
if (return_()) {
return 0;
} else {
chkin_("SSIZEC", (ftnlen)6);
}
/* The size must be non-negative. Other values will be snubbed. */
if (*size < 0) {
setmsg_("Attempt to set size of cell to invalid value. The value wa"
"s #.", (ftnlen)63);
errint_("#", size, (ftnlen)1);
sigerr_("SPICE(INVALIDSIZE)", (ftnlen)18);
chkout_("SSIZEC", (ftnlen)6);
return 0;
}
/* Not much to this. */
enchar_(size, cell + (cell_len << 2), cell_len);
enchar_(&c__0, cell + cell_len * 5, cell_len);
for (i__ = -5; i__ <= -2; ++i__) {
enchar_(&c__0, cell + (i__ + 5) * cell_len, cell_len);
}
chkout_("SSIZEC", (ftnlen)6);
return 0;
} /* ssizec_ */
/* $Procedure ZZBODKER ( Private --- Process Body-Name Kernel Pool Maps ) */
/* Subroutine */ int zzbodker_(char *names, char *nornam, integer *codes,
integer *nvals, integer *ordnom, integer *ordcod, integer *nocds,
logical *extker, ftnlen names_len, ftnlen nornam_len)
{
/* Initialized data */
static char nbc[32] = "NAIF_BODY_CODE ";
static char nbn[32] = "NAIF_BODY_NAME ";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
logical drop[2000];
char type__[1*2];
integer nsiz[2];
extern /* Subroutine */ int zzbodini_(char *, char *, integer *, integer *
, integer *, integer *, integer *, ftnlen, ftnlen);
integer i__, j;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen), errch_(char *, char *, ftnlen, ftnlen);
logical found;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
logical plfind[2];
extern /* Subroutine */ int orderc_(char *, integer *, integer *, ftnlen),
gcpool_(char *, integer *, integer *, integer *, char *, logical
*, ftnlen, ftnlen), gipool_(char *, integer *, integer *, integer
*, integer *, logical *, ftnlen), sigerr_(char *, ftnlen);
logical remdup;
extern /* Subroutine */ int chkout_(char *, ftnlen), dtpool_(char *,
logical *, integer *, char *, ftnlen, ftnlen), setmsg_(char *,
ftnlen), errint_(char *, integer *, ftnlen), cmprss_(char *,
integer *, char *, char *, ftnlen, ftnlen, ftnlen);
extern logical return_(void);
integer num[2];
/* $ Abstract */
/* SPICE Private routine intended solely for the support of SPICE */
/* routines. Users should not call this routine directly due */
/* to the volatile nature of this routine. */
/* This routine processes the kernel pool vectors NAIF_BODY_NAME */
/* and NAIF_BODY_CODE into the formatted lists required by ZZBODTRN */
/* to successfully compute code-name mappings. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* NAIF_IDS */
/* $ Keywords */
/* BODY */
/* $ Declarations */
/* $ Abstract */
/* This include file lists the parameter collection */
/* defining the number of SPICE ID -> NAME mappings. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* naif_ids.req */
/* $ Keywords */
/* Body mappings. */
/* $ Author_and_Institution */
/* E.D. Wright (JPL) */
/* $ Version */
/* SPICELIB 1.0.0 Thu May 20 07:57:58 2010 (EDW) */
/* A script generates this file. Do not edit by hand. */
/* Edit the creation script to modify the contents of */
/* ZZBODTRN.INC. */
/* Maximum size of a NAME string */
/* Count of default SPICE mapping assignments. */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* NAMES O Array of kernel pool assigned names. */
/* NORNAM O Array of normalized kernel pool assigned names. */
/* CODES O Array of ID codes for NAMES/NORNAM. */
/* NVALS O Length of NAMES, NORNAM, CODES, and ORDNOM arrays. */
/* ORDNOM O Order vector for NORNAM. */
/* ORDCOD O Modified order vector for CODES. */
/* NOCDS O Length of ORDCOD array. */
/* EXTKER O Logical indicating presence of kernel pool names. */
/* MAXL P Maximum length of body name strings. */
/* NROOM P Maximum length of kernel pool data vectors. */
/* $ Detailed_Input */
/* None. */
/* $ Detailed_Output */
/* NAMES the array of highest precedent names extracted */
/* from the kernel pool vector NAIF_BODY_NAME. This */
/* array is parallel to NORNAM and CODES. */
/* NORNAM the array of highest precedent names extracted */
/* from the kernel pool vector NAIF_BODY_NAME. After */
/* extraction, each entry is converted to uppercase, */
/* and groups of spaces are compressed to a single */
/* space. This represents the canonical member of the */
/* equivalence class each parallel entry in NAMES */
/* belongs. */
/* CODES the array of highest precedent codes extracted */
/* from the kernel pool vector NAIF_BODY_CODE. This */
/* array is parallel to NAMES and NORNAM. */
/* NVALS the number of items contained in NAMES, NORNAM, */
/* CODES and ORDNOM. */
/* ORDNOM the order vector of indexes for NORNAM. The set */
/* of values NORNAM( ORDNOM(1) ), NORNAM( ORDNOM(2) ), */
/* ... forms an increasing list of name values. */
/* ORDCOD the modified ordering vector of indexes into */
/* CODES. The list CODES( ORDCOD(1) ), */
/* CODES( ORDCOD(2) ), ... , CODES( ORDCOD(NOCDS) ) */
/* forms an increasing non-repeating list of integers. */
/* Moreover, every value in CODES is listed exactly */
/* once in this sequence. */
/* NOCDS the number of indexes listed in ORDCOD. This */
/* value will never exceed NVALS. */
/* EXTKER is a logical that indicates to the caller whether */
/* any kernel pool name-code maps have been defined. */
/* If EXTKER is .FALSE., then the kernel pool variables */
/* NAIF_BODY_CODE and NAIF_BODY_NAME are empty and */
/* only the built-in and ZZBODDEF code-name mappings */
/* need consideration. If .TRUE., then the values */
/* returned by this module need consideration. */
/* $ Parameters */
/* MAXL is the maximum length of a body name. Defined in */
/* the include file 'zzbodtrn.inc'. */
/* NROOM is the maximum number of kernel pool data items */
/* that can be processed from the NAIF_BODY_CODE */
/* and NAIF_BODY_NAME lists. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* 1) The error SPICE(MISSINGKPV) is signaled when one of the */
/* NAIF_BODY_CODE and NAIF_BODY_NAME keywords is present in the */
/* kernel pool and the other is not. */
/* 2) The error SPICE(KERVARTOOBIG) is signaled if one or both of */
/* the NAIF_BODY_CODE and NAIF_BODY_NAME kernel pool vectors */
/* have a cardinality that exceeds NROOM. */
/* 3) The error SPICE(BADDIMENSIONS) is signaled if the cardinality */
/* of the NAIF_BODY_CODE and NAIF_BODY_NAME kernel pool vectors do */
/* not match. */
/* 4) The error SPICE(BLANKNAMEASSIGNED) is signaled if an entry */
/* in the NAIF_BODY_NAME kernel pool vector is a blank string. */
/* ID codes may not be assigned to a blank string. */
/* $ Particulars */
/* This routine examines the contents of the kernel pool, ingests */
/* the contents of the NAIF_BODY_CODE and NAIF_BODY_NAME keywords, */
/* and produces the order vectors and name/code lists that ZZBODTRN */
/* requires to resolve code to name and name to code mappings. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* E.D. Wright (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 23-AUG-2002 (EDW) (FST) */
/* -& */
/* SPICELIB Functions */
/* Local Parameters */
/* Local Variables */
/* Saved Variables */
/* Data Statements */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZBODKER", (ftnlen)8);
}
/* Until the code below proves otherwise, we shall assume */
/* we lack kernel pool name/code mappings. */
*extker = FALSE_;
/* Check for the external body ID variables in the kernel pool. */
gcpool_(nbn, &c__1, &c__2000, num, names, plfind, (ftnlen)32, (ftnlen)36);
gipool_(nbc, &c__1, &c__2000, &num[1], codes, &plfind[1], (ftnlen)32);
/* Examine PLFIND(1) and PLFIND(2) for problems. */
if (plfind[0] != plfind[1]) {
/* If they are not both present or absent, signal an error. */
setmsg_("The kernel pool vector, #, used in mapping between names an"
"d ID-codes is absent, while # is not. This is often due to "
"an improperly constructed text kernel. Check loaded kernels"
" for these keywords.", (ftnlen)199);
if (plfind[0]) {
errch_("#", nbc, (ftnlen)1, (ftnlen)32);
errch_("#", nbn, (ftnlen)1, (ftnlen)32);
} else {
errch_("#", nbn, (ftnlen)1, (ftnlen)32);
errch_("#", nbc, (ftnlen)1, (ftnlen)32);
}
sigerr_("SPICE(MISSINGKPV)", (ftnlen)17);
chkout_("ZZBODKER", (ftnlen)8);
return 0;
} else if (! plfind[0]) {
/* Return if both keywords are absent. */
chkout_("ZZBODKER", (ftnlen)8);
return 0;
}
/* If we reach here, then both kernel pool variables are present. */
/* Perform some simple sanity checks on their lengths. */
dtpool_(nbn, &found, nsiz, type__, (ftnlen)32, (ftnlen)1);
dtpool_(nbc, &found, &nsiz[1], type__ + 1, (ftnlen)32, (ftnlen)1);
if (nsiz[0] > 2000 || nsiz[1] > 2000) {
setmsg_("The kernel pool vectors used to define the names/ID-codes m"
"appingexceeds the max size. The size of the NAME vector is #"
"1. The size of the CODE vector is #2. The max number allowed"
" of elements is #3.", (ftnlen)198);
errint_("#1", nsiz, (ftnlen)2);
errint_("#2", &nsiz[1], (ftnlen)2);
errint_("#3", &c__2000, (ftnlen)2);
sigerr_("SPICE(KERVARTOOBIG)", (ftnlen)19);
chkout_("ZZBODKER", (ftnlen)8);
return 0;
} else if (nsiz[0] != nsiz[1]) {
setmsg_("The kernel pool vectors used for mapping between names and "
"ID-codes are not the same size. The size of the name vector"
", NAIF_BODY_NAME is #. The size of the ID-code vector, NAIF_"
"BODY_CODE is #. You need to examine the ID-code kernel you l"
"oaded and correct the mismatch.", (ftnlen)270);
errint_("#", nsiz, (ftnlen)1);
errint_("#", &nsiz[1], (ftnlen)1);
sigerr_("SPICE(BADDIMENSIONS)", (ftnlen)20);
chkout_("ZZBODKER", (ftnlen)8);
return 0;
}
/* Compute the canonical member of the equivalence class of NAMES, */
/* NORNAM. This normalization compresses groups of spaces into a */
/* single space, left justifies the string, and uppercases the */
/* contents. While passing through the NAMES array, look for any */
/* blank strings and signal an appropriate error. */
*nvals = num[0];
i__1 = *nvals;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Check for blank strings. */
if (s_cmp(names + ((i__2 = i__ - 1) < 2000 && 0 <= i__2 ? i__2 :
s_rnge("names", i__2, "zzbodker_", (ftnlen)345)) * 36, " ", (
ftnlen)36, (ftnlen)1) == 0) {
setmsg_("An attempt to assign the code, #, to a blank string was"
" made. Check loaded text kernels for a blank string in "
"the NAIF_BODY_NAME array.", (ftnlen)136);
errint_("#", &i__, (ftnlen)1);
sigerr_("SPICE(BLANKNAMEASSIGNED)", (ftnlen)24);
chkout_("ZZBODKER", (ftnlen)8);
return 0;
}
/* Compute the canonical member of the equivalence class. */
ljust_(names + ((i__2 = i__ - 1) < 2000 && 0 <= i__2 ? i__2 : s_rnge(
"names", i__2, "zzbodker_", (ftnlen)361)) * 36, nornam + ((
i__3 = i__ - 1) < 2000 && 0 <= i__3 ? i__3 : s_rnge("nornam",
i__3, "zzbodker_", (ftnlen)361)) * 36, (ftnlen)36, (ftnlen)36)
;
ucase_(nornam + ((i__2 = i__ - 1) < 2000 && 0 <= i__2 ? i__2 : s_rnge(
"nornam", i__2, "zzbodker_", (ftnlen)362)) * 36, nornam + ((
i__3 = i__ - 1) < 2000 && 0 <= i__3 ? i__3 : s_rnge("nornam",
i__3, "zzbodker_", (ftnlen)362)) * 36, (ftnlen)36, (ftnlen)36)
;
cmprss_(" ", &c__1, nornam + ((i__2 = i__ - 1) < 2000 && 0 <= i__2 ?
i__2 : s_rnge("nornam", i__2, "zzbodker_", (ftnlen)363)) * 36,
nornam + ((i__3 = i__ - 1) < 2000 && 0 <= i__3 ? i__3 :
s_rnge("nornam", i__3, "zzbodker_", (ftnlen)363)) * 36, (
ftnlen)1, (ftnlen)36, (ftnlen)36);
}
/* Determine a preliminary order vector for NORNAM. */
orderc_(nornam, nvals, ordnom, (ftnlen)36);
/* We are about to remove duplicates. Make some initial */
/* assumptions, no duplicates exist in NORNAM. */
i__1 = *nvals;
for (i__ = 1; i__ <= i__1; ++i__) {
drop[(i__2 = i__ - 1) < 2000 && 0 <= i__2 ? i__2 : s_rnge("drop",
i__2, "zzbodker_", (ftnlen)377)] = FALSE_;
}
remdup = FALSE_;
/* ORDERC clusters duplicate entries in NORNAM together. */
/* Use this fact to locate duplicates on one pass through */
/* NORNAM. */
i__1 = *nvals - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s_cmp(nornam + ((i__3 = ordnom[(i__2 = i__ - 1) < 2000 && 0 <=
i__2 ? i__2 : s_rnge("ordnom", i__2, "zzbodker_", (ftnlen)389)
] - 1) < 2000 && 0 <= i__3 ? i__3 : s_rnge("nornam", i__3,
"zzbodker_", (ftnlen)389)) * 36, nornam + ((i__5 = ordnom[(
i__4 = i__) < 2000 && 0 <= i__4 ? i__4 : s_rnge("ordnom",
i__4, "zzbodker_", (ftnlen)389)] - 1) < 2000 && 0 <= i__5 ?
i__5 : s_rnge("nornam", i__5, "zzbodker_", (ftnlen)389)) * 36,
(ftnlen)36, (ftnlen)36) == 0) {
/* We have at least one duplicate to remove. */
remdup = TRUE_;
/* If the normalized entries are equal, drop the one with */
/* the lower index in the NAMES array. Entries defined */
/* later in the kernel pool have higher precedence. */
if (ordnom[(i__2 = i__ - 1) < 2000 && 0 <= i__2 ? i__2 : s_rnge(
"ordnom", i__2, "zzbodker_", (ftnlen)401)] < ordnom[(i__3
= i__) < 2000 && 0 <= i__3 ? i__3 : s_rnge("ordnom", i__3,
"zzbodker_", (ftnlen)401)]) {
drop[(i__3 = ordnom[(i__2 = i__ - 1) < 2000 && 0 <= i__2 ?
i__2 : s_rnge("ordnom", i__2, "zzbodker_", (ftnlen)
402)] - 1) < 2000 && 0 <= i__3 ? i__3 : s_rnge("drop",
i__3, "zzbodker_", (ftnlen)402)] = TRUE_;
} else {
drop[(i__3 = ordnom[(i__2 = i__) < 2000 && 0 <= i__2 ? i__2 :
s_rnge("ordnom", i__2, "zzbodker_", (ftnlen)404)] - 1)
< 2000 && 0 <= i__3 ? i__3 : s_rnge("drop", i__3,
"zzbodker_", (ftnlen)404)] = TRUE_;
}
}
}
/* If necessary, remove duplicates. */
if (remdup) {
/* Sweep through the DROP array, compressing off any elements */
/* that are to be dropped. */
j = 0;
i__1 = *nvals;
for (i__ = 1; i__ <= i__1; ++i__) {
if (! drop[(i__2 = i__ - 1) < 2000 && 0 <= i__2 ? i__2 : s_rnge(
"drop", i__2, "zzbodker_", (ftnlen)423)]) {
++j;
s_copy(names + ((i__2 = j - 1) < 2000 && 0 <= i__2 ? i__2 :
s_rnge("names", i__2, "zzbodker_", (ftnlen)425)) * 36,
names + ((i__3 = i__ - 1) < 2000 && 0 <= i__3 ? i__3
: s_rnge("names", i__3, "zzbodker_", (ftnlen)425)) *
36, (ftnlen)36, (ftnlen)36);
s_copy(nornam + ((i__2 = j - 1) < 2000 && 0 <= i__2 ? i__2 :
s_rnge("nornam", i__2, "zzbodker_", (ftnlen)426)) *
36, nornam + ((i__3 = i__ - 1) < 2000 && 0 <= i__3 ?
i__3 : s_rnge("nornam", i__3, "zzbodker_", (ftnlen)
426)) * 36, (ftnlen)36, (ftnlen)36);
codes[(i__2 = j - 1) < 2000 && 0 <= i__2 ? i__2 : s_rnge(
"codes", i__2, "zzbodker_", (ftnlen)427)] = codes[(
i__3 = i__ - 1) < 2000 && 0 <= i__3 ? i__3 : s_rnge(
"codes", i__3, "zzbodker_", (ftnlen)427)];
}
}
/* Adjust NVALS to compensate for the number of elements that */
/* were compressed off the list. */
*nvals = j;
}
/* Compute the order vectors that ZZBODTRN requires. */
zzbodini_(names, nornam, codes, nvals, ordnom, ordcod, nocds, (ftnlen)36,
(ftnlen)36);
/* We're on the home stretch if we make it to this point. */
/* Set EXTKER to .TRUE., check out and return. */
*extker = TRUE_;
chkout_("ZZBODKER", (ftnlen)8);
return 0;
} /* zzbodker_ */
/* $Procedure ZZDAFGFR ( Private --- DAF Get Data Record ) */
/* Subroutine */ int zzdafgfr_(integer *handle, char *idword, integer *nd,
integer *ni, char *ifname, integer *fward, integer *bward, integer *
free, logical *found, ftnlen idword_len, ftnlen ifname_len)
{
/* Initialized data */
static logical first = TRUE_;
static integer natbff = 0;
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), s_rdue(cilist *),
do_uio(integer *, char *, ftnlen), e_rdue(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer ibff, iamh;
extern /* Subroutine */ int zzddhgsd_(char *, integer *, char *, ftnlen,
ftnlen), zzddhnfo_(integer *, char *, integer *, integer *,
integer *, logical *, ftnlen), zzddhhlu_(integer *, char *,
logical *, integer *, ftnlen), zzplatfm_(char *, char *, ftnlen,
ftnlen), zzxlatei_(integer *, char *, integer *, integer *,
ftnlen);
integer i__;
char fname[255];
integer iarch;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer locnd;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
integer locni;
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen);
extern logical failed_(void);
logical locfnd;
char chrbuf[1024], locifn[60];
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
integer cindex, locbwd;
char locidw[8];
integer locfre;
static char strbff[8*4];
integer locfwd;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
extern logical return_(void);
char tmpstr[8];
integer lun;
/* Fortran I/O blocks */
static cilist io___13 = { 1, 0, 1, 0, 1 };
static cilist io___21 = { 1, 0, 1, 0, 1 };
/* $ Abstract */
/* SPICE Private routine intended solely for the support of SPICE */
/* routines. Users should not call this routine directly due */
/* to the volatile nature of this routine. */
/* Read the contents of the file record of a DAF. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* PRIVATE */
/* $ Declarations */
/* $ Abstract */
/* Parameter declarations for the DAF/DAS handle manager. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* DAF, DAS */
/* $ Keywords */
/* PRIVATE */
/* $ Particulars */
/* This include file contains parameters defining limits and */
/* integer codes that are utilized in the DAF/DAS handle manager */
/* routines. */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 2.5.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 2.4.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 2.3.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 2.2.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 2.1.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 2.0.0, 12-APR-2012 (BVS) */
/* Increased FTSIZE (from 1000 to 5000). */
/* - SPICELIB Version 1.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 1.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 1.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 1.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 1.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 1.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 1.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 1.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 1.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 1.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 1.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 1.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 1.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 1.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 1.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 1.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 1.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 1.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 1.0.1, 17-JUL-2002 */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 1.0.0, 07-NOV-2001 */
/* -& */
/* Unit and file table size parameters. */
/* FTSIZE is the maximum number of files (DAS and DAF) that a */
/* user may have open simultaneously. */
/* RSVUNT is the number of units protected from being locked */
/* to a particular handle by ZZDDHHLU. */
/* SCRUNT is the number of units protected for use by scratch */
/* files. */
/* UTSIZE is the maximum number of logical units this manager */
/* will utilize at one time. */
/* Access method enumeration. These parameters are used to */
/* identify which access method is associated with a particular */
/* handle. They need to be synchronized with the STRAMH array */
/* defined in ZZDDHGSD in the following fashion: */
/* STRAMH ( READ ) = 'READ' */
/* STRAMH ( WRITE ) = 'WRITE' */
/* STRAMH ( SCRTCH ) = 'SCRATCH' */
/* STRAMH ( NEW ) = 'NEW' */
/* These values are used in the file table variable FTAMH. */
/* Binary file format enumeration. These parameters are used to */
/* identify which binary file format is associated with a */
/* particular handle. They need to be synchronized with the STRBFF */
/* array defined in ZZDDHGSD in the following fashion: */
/* STRBFF ( BIGI3E ) = 'BIG-IEEE' */
/* STRBFF ( LTLI3E ) = 'LTL-IEEE' */
/* STRBFF ( VAXGFL ) = 'VAX-GFLT' */
/* STRBFF ( VAXDFL ) = 'VAX-DFLT' */
/* These values are used in the file table variable FTBFF. */
/* Some random string lengths... more documentation required. */
/* For now this will have to suffice. */
/* Architecture enumeration. These parameters are used to identify */
/* which file architecture is associated with a particular handle. */
/* They need to be synchronized with the STRARC array defined in */
/* ZZDDHGSD in the following fashion: */
/* STRARC ( DAF ) = 'DAF' */
/* STRARC ( DAS ) = 'DAS' */
/* These values will be used in the file table variable FTARC. */
/* For the following environments, record length is measured in */
/* characters (bytes) with eight characters per double precision */
/* number. */
/* Environment: Sun, Sun FORTRAN */
/* Source: Sun Fortran Programmer's Guide */
/* Environment: PC, MS FORTRAN */
/* Source: Microsoft Fortran Optimizing Compiler User's Guide */
/* Environment: Macintosh, Language Systems FORTRAN */
/* Source: Language Systems FORTRAN Reference Manual, */
/* Version 1.2, page 12-7 */
/* Environment: PC/Linux, g77 */
/* Source: Determined by experiment. */
/* Environment: PC, Lahey F77 EM/32 Version 4.0 */
/* Source: Lahey F77 EM/32 Language Reference Manual, */
/* page 144 */
/* Environment: HP-UX 9000/750, FORTRAN/9000 Series 700 computers */
/* Source: FORTRAN/9000 Reference-Series 700 Computers, */
/* page 5-110 */
/* Environment: NeXT Mach OS (Black Hardware), */
/* Absoft Fortran Version 3.2 */
/* Source: NAIF Program */
/* The following parameter defines the size of a string used */
/* to store a filenames on this target platform. */
/* The following parameter controls the size of the character record */
/* buffer used to read data from non-native files. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle of the DAF. */
/* IDWORD O DAF ID Word that indicates file type. */
/* ND O Number of double precision components in summaries. */
/* NI O Number of integer components in summaries. */
/* IFNAME O Internal file name. */
/* FWARD O Forward list pointer. */
/* BWARD O Backward list pointer. */
/* FREE O Free address pointer. */
/* FOUND O Logical indicating whether the record was found. */
/* $ Detailed_Input */
/* HANDLE is the handle associated with the DAF. */
/* $ Detailed_Output */
/* IDWORD is a character string identifying the architecture */
/* and type of a SPICE binary kernel. In this case */
/* it will be a string identifying the type of DAF. */
/* ND, */
/* NI are the number of double precision and integer */
/* components, respectively, in each array summary in */
/* the specified file. */
/* IFNAME is the internal file name stored in the first */
/* (or file) record of the specified file. */
/* FWARD is the forward list pointer. This points to the */
/* first summary record in the file. (Records between */
/* the first record and the first summary record are */
/* reserved when the file is created, and are invisible */
/* to DAF routines.) */
/* BWARD is the backward list pointer. This points */
/* to the final summary record in the file. */
/* FREE is the free address pointer. This contains the */
/* first free address in the file. (That is, the */
/* initial address of the next array to be added */
/* to the file.) */
/* FOUND is TRUE when the file record is found, and is */
/* FALSE otherwise. */
/* $ Parameters */
/* None. */
/* $ Files */
/* This routine reads data from the DAF associated with HANDLE. */
/* This action may result in connecting a logical unit to the */
/* file, if the handle manager has rotated the file out of the */
/* unit table. */
/* $ Exceptions */
/* 1) SPICE(HANDLENOTFOUND) is signaled if HANDLE can not be */
/* found in the set of loaded handles. The output arguments */
/* are unmodified when this error occurs. */
/* 2) Routines in the call tree of this routine may trap and */
/* signal errors. The output arguments are unmodified in */
/* these cases. */
/* $ Particulars */
/* This routine reads the publically available components of */
/* file records from native and supported non-native DAFs. */
/* The size of the character buffer and the number of records */
/* read may have to change to support new environments. As of */
/* the original release of this routine, all systems currently */
/* supported have a 1 kilobyte record length. */
/* $ Examples */
/* See DAFRFR for sample usage. */
/* $ Restrictions */
/* 1) Numeric data when read as characters from a file preserves */
/* the bit patterns present in the file in memory. */
/* 2) A record of double precision data is at most 1024 characters */
/* in length. */
/* 3) Future updates to this module must preserve the fact that */
/* FOUND is returned as FALSE whenever an error occurs. An */
/* incompletely translated or extracted file record is NOT */
/* FOUND. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 12-NOV-2001 (FST) */
/* -& */
/* SPICELIB Functions */
/* Local Parameters */
/* Record Number of the file record in a DAF. */
/* Length of the IDWORD string. */
/* Length of the internal filename string. */
/* Starting location in bytes of the internal filename in the */
/* file record. */
/* Size of an integer in bytes. */
/* Local Variables */
/* Saved Variables */
/* Data Statements */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZDAFGFR", (ftnlen)8);
}
/* Perform some initialization tasks. */
if (first) {
/* Populate STRBFF, the buffer that contains the labels */
/* for each binary file format. */
for (i__ = 1; i__ <= 4; ++i__) {
zzddhgsd_("BFF", &i__, strbff + (((i__1 = i__ - 1) < 4 && 0 <=
i__1 ? i__1 : s_rnge("strbff", i__1, "zzdafgfr_", (ftnlen)
275)) << 3), (ftnlen)3, (ftnlen)8);
}
/* Fetch the native binary file format and determine its */
/* integer code. */
zzplatfm_("FILE_FORMAT", tmpstr, (ftnlen)11, (ftnlen)8);
ucase_(tmpstr, tmpstr, (ftnlen)8, (ftnlen)8);
natbff = isrchc_(tmpstr, &c__4, strbff, (ftnlen)8, (ftnlen)8);
if (natbff == 0) {
setmsg_("The binary file format, '#', is not supported by this v"
"ersion of the toolkit. This is a serious problem, contac"
"t NAIF.", (ftnlen)118);
errch_("#", tmpstr, (ftnlen)1, (ftnlen)8);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZDAFGFR", (ftnlen)8);
return 0;
}
/* Do not perform initialization tasks again. */
first = FALSE_;
}
/* Assume the data record will not be found, until it has been read */
/* from the file, and if necessary, successfully translated. */
*found = FALSE_;
/* Retrieve information regarding the file from the handle manager. */
/* The value of IARCH is not a concern, since this is a DAF routine */
/* all values passed into handle manager entry points will have */
/* 'DAF' as their architecture arguments. */
zzddhnfo_(handle, fname, &iarch, &ibff, &iamh, &locfnd, (ftnlen)255);
if (! locfnd) {
setmsg_("Unable to locate file associated with HANDLE, #. The most "
"likely cause of this is the file that you are trying to read"
" has been closed.", (ftnlen)136);
errint_("#", handle, (ftnlen)1);
sigerr_("SPICE(HANDLENOTFOUND)", (ftnlen)21);
chkout_("ZZDAFGFR", (ftnlen)8);
return 0;
}
/* Now get a logical unit for the handle. Check FAILED() in */
/* case an error occurs. */
zzddhhlu_(handle, "DAF", &c_false, &lun, (ftnlen)3);
if (failed_()) {
chkout_("ZZDAFGFR", (ftnlen)8);
return 0;
}
/* Branch based on whether the binary file format is native */
/* or not. Only supported formats can be opened by ZZDDHOPN, */
/* so no check of IBFF is required. */
if (ibff == natbff) {
/* In the native case, just read the components of the file */
/* record from the file. */
io___13.ciunit = lun;
iostat = s_rdue(&io___13);
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, locidw, (ftnlen)8);
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, (char *)&locnd, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, (char *)&locni, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, locifn, (ftnlen)60);
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, (char *)&locfwd, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, (char *)&locbwd, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, (char *)&locfre, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100001;
}
iostat = e_rdue();
L100001:
/* Since this routine does not signal any IOSTAT based */
/* errors, return if a non-zero value is assigned to IOSTAT. */
if (iostat != 0) {
chkout_("ZZDAFGFR", (ftnlen)8);
return 0;
}
/* Process the non-native binary file format case. */
} else {
/* Read the data record as characters. */
io___21.ciunit = lun;
iostat = s_rdue(&io___21);
if (iostat != 0) {
goto L100002;
}
iostat = do_uio(&c__1, chrbuf, (ftnlen)1024);
if (iostat != 0) {
goto L100002;
}
iostat = e_rdue();
L100002:
/* Again, since this routine does not signal any IOSTAT */
/* based errors, return if one occurs. */
if (iostat != 0) {
chkout_("ZZDAFGFR", (ftnlen)8);
return 0;
}
/* Assign the character components of the file record. */
s_copy(locidw, chrbuf, (ftnlen)8, (ftnlen)8);
s_copy(locifn, chrbuf + 16, (ftnlen)60, (ftnlen)60);
/* Convert the integer components. */
cindex = 9;
zzxlatei_(&ibff, chrbuf + (cindex - 1), &c__1, &locnd, (ftnlen)4);
cindex += 4;
zzxlatei_(&ibff, chrbuf + (cindex - 1), &c__1, &locni, (ftnlen)4);
cindex = 77;
zzxlatei_(&ibff, chrbuf + (cindex - 1), &c__1, &locfwd, (ftnlen)4);
cindex += 4;
zzxlatei_(&ibff, chrbuf + (cindex - 1), &c__1, &locbwd, (ftnlen)4);
cindex += 4;
zzxlatei_(&ibff, chrbuf + (cindex - 1), &c__1, &locfre, (ftnlen)4);
if (failed_()) {
chkout_("ZZDAFGFR", (ftnlen)8);
return 0;
}
}
/* Transfer the contents of the record to the output arguments */
/* and return to the caller. */
*found = TRUE_;
s_copy(idword, locidw, idword_len, (ftnlen)8);
*nd = locnd;
*ni = locni;
s_copy(ifname, locifn, ifname_len, (ftnlen)60);
*fward = locfwd;
*bward = locbwd;
*free = locfre;
chkout_("ZZDAFGFR", (ftnlen)8);
return 0;
} /* zzdafgfr_ */
/* $Procedure ZZEKLLEI ( EK, last less than or equal to, integer ) */
/* Subroutine */ int zzekllei_(integer *handle, integer *segdsc, integer *
coldsc, integer *ikey, integer *prvloc, integer *prvptr)
{
extern /* Subroutine */ int zzekcnam_(integer *, integer *, char *,
ftnlen);
extern logical zzekscmp_(integer *, integer *, integer *, integer *,
integer *, integer *, integer *, char *, doublereal *, integer *,
logical *, ftnlen);
extern /* Subroutine */ int zzekixlk_(integer *, integer *, integer *,
integer *);
integer begin;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
integer dtype, nrows, middle;
logical indexd;
char column[32];
integer begptr, endptr, midptr;
extern /* Subroutine */ int setmsg_(char *, ftnlen), sigerr_(char *,
ftnlen), chkout_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
integer end;
/* $ Abstract */
/* Find the last column value less than or equal to a specified key, */
/* for a specified, indexed integer EK column. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* EK */
/* $ Keywords */
/* EK */
/* PRIVATE */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Boolean Enumerated Type */
/* ekbool.inc Version 1 21-DEC-1994 (NJB) */
/* Within the EK system, boolean values sometimes must be */
/* represented by integer or character codes. The codes and their */
/* meanings are listed below. */
/* Integer code indicating `true': */
/* Integer code indicating `false': */
/* Character code indicating `true': */
/* Character code indicating `false': */
/* End Include Section: EK Boolean Enumerated Type */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Column Name Size */
/* ekcnamsz.inc Version 1 17-JAN-1995 (NJB) */
/* Size of column name, in characters. */
/* End Include Section: EK Column Name Size */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Column Descriptor Parameters */
/* ekcoldsc.inc Version 6 23-AUG-1995 (NJB) */
/* Note: The column descriptor size parameter CDSCSZ is */
/* declared separately in the include section CDSIZE$INC.FOR. */
/* Offset of column descriptors, relative to start of segment */
/* integer address range. This number, when added to the last */
/* integer address preceding the segment, yields the DAS integer */
/* base address of the first column descriptor. Currently, this */
/* offset is exactly the size of a segment descriptor. The */
/* parameter SDSCSZ, which defines the size of a segment descriptor, */
/* is declared in the include file eksegdsc.inc. */
/* Size of column descriptor */
/* Indices of various pieces of column descriptors: */
/* CLSIDX is the index of the column's class code. (We use the */
/* word `class' to distinguish this item from the column's data */
/* type.) */
/* TYPIDX is the index of the column's data type code (CHR, INT, DP, */
/* or TIME). The type is actually implied by the class, but it */
/* will frequently be convenient to look up the type directly. */
/* LENIDX is the index of the column's string length value, if the */
/* column has character type. A value of IFALSE in this element of */
/* the descriptor indicates that the strings have variable length. */
/* SIZIDX is the index of the column's element size value. This */
/* descriptor element is meaningful for columns with fixed-size */
/* entries. For variable-sized columns, this value is IFALSE. */
/* NAMIDX is the index of the base address of the column's name. */
/* IXTIDX is the data type of the column's index. IXTIDX */
/* contains a type value only if the column is indexed. For columns */
/* that are not indexed, the location IXTIDX contains the boolean */
/* value IFALSE. */
/* IXPIDX is a pointer to the column's index. IXTPDX contains a */
/* meaningful value only if the column is indexed. The */
/* interpretation of the pointer depends on the data type of the */
/* index. */
/* NFLIDX is the index of a flag indicating whether nulls are */
/* permitted in the column. The value at location NFLIDX is */
/* ITRUE if nulls are permitted and IFALSE otherwise. */
/* ORDIDX is the index of the column's ordinal position in the */
/* list of columns belonging to the column's parent segment. */
/* METIDX is the index of the column's integer metadata pointer. */
/* This pointer is a DAS integer address. */
/* The last position in the column descriptor is reserved. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Column Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Operator Codes */
/* ekopcd.inc Version 1 30-DEC-1994 (NJB) */
/* Within the EK system, operators used in EK queries are */
/* represented by integer codes. The codes and their meanings are */
/* listed below. */
/* Relational expressions in EK queries have the form */
/* <column name> <operator> <value> */
/* For columns containing numeric values, the operators */
/* EQ, GE, GT, LE, LT, NE */
/* may be used; these operators have the same meanings as their */
/* Fortran counterparts. For columns containing character values, */
/* the list of allowed operators includes those in the above list, */
/* and in addition includes the operators */
/* LIKE, UNLIKE */
/* which are used to compare strings to a template. In the character */
/* case, the meanings of the parameters */
/* GE, GT, LE, LT */
/* match those of the Fortran lexical functions */
/* LGE, LGT, LLE, LLT */
/* The additional unary operators */
/* ISNULL, NOTNUL */
/* are used to test whether a value of any type is null. */
/* End Include Section: EK Operator Codes */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Segment Descriptor Parameters */
/* eksegdsc.inc Version 8 06-NOV-1995 (NJB) */
/* All `base addresses' referred to below are the addresses */
/* *preceding* the item the base applies to. This convention */
/* enables simplied address calculations in many cases. */
/* Size of segment descriptor. Note: the include file ekcoldsc.inc */
/* must be updated if this parameter is changed. The parameter */
/* CDOFF in that file should be kept equal to SDSCSZ. */
/* Index of the segment type code: */
/* Index of the segment's number. This number is the segment's */
/* index in the list of segments contained in the EK to which */
/* the segment belongs. */
/* Index of the DAS integer base address of the segment's integer */
/* meta-data: */
/* Index of the DAS character base address of the table name: */
/* Index of the segment's column count: */
/* Index of the segment's record count: */
/* Index of the root page number of the record tree: */
/* Index of the root page number of the character data page tree: */
/* Index of the root page number of the double precision data page */
/* tree: */
/* Index of the root page number of the integer data page tree: */
/* Index of the `modified' flag: */
/* Index of the `initialized' flag: */
/* Index of the shadowing flag: */
/* Index of the companion file handle: */
/* Index of the companion segment number: */
/* The next three items are, respectively, the page numbers of the */
/* last character, d.p., and integer data pages allocated by the */
/* segment: */
/* The next three items are, respectively, the page-relative */
/* indices of the last DAS word in use in the segment's */
/* last character, d.p., and integer data pages: */
/* Index of the DAS character base address of the column name list: */
/* The last descriptor element is reserved for future use. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Segment Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Data Types */
/* ektype.inc Version 1 27-DEC-1994 (NJB) */
/* Within the EK system, data types of EK column contents are */
/* represented by integer codes. The codes and their meanings */
/* are listed below. */
/* Integer codes are also used within the DAS system to indicate */
/* data types; the EK system makes no assumptions about compatibility */
/* between the codes used here and those used in the DAS system. */
/* Character type: */
/* Double precision type: */
/* Integer type: */
/* `Time' type: */
/* Within the EK system, time values are represented as ephemeris */
/* seconds past J2000 (TDB), and double precision numbers are used */
/* to store these values. However, since time values require special */
/* treatment both on input and output, and since the `TIME' column */
/* has a special role in the EK specification and code, time values */
/* are identified as a type distinct from double precision numbers. */
/* End Include Section: EK Data Types */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I File handle. */
/* SEGDSC I Segment descriptor. */
/* COLDSC I Column descriptor. */
/* IKEY I Integer key. */
/* PRVLOC O Ordinal position of predecessor of IKEY. */
/* PRVPTR O Pointer to a record containing predecessor of IKEY. */
/* $ Detailed_Input */
/* HANDLE is an EK file handle. The file may be open for */
/* reading or writing. */
/* SEGDSC is the segment descriptor of the segment */
/* containing the column specified by COLDSC. */
/* COLDSC is the column descriptor of the column to be */
/* searched. */
/* IKEY is an integer key. The last column entry */
/* less than or equal to this key is sought. */
/* $ Detailed_Output */
/* PRVLOC is the ordinal position, according to the order */
/* relation implied by the column's index, of the */
/* record containing the last element less than or */
/* equal to IKEY. If the column contains elements */
/* equal to IKEY, PRVLOC is the index of the last */
/* such element. */
/* If all elements of the column are greater than */
/* IKEY, PRVLOC is set to zero. */
/* PRVPTR is a pointer to the record containing the element */
/* whose ordinal position is PRVLOC. */
/* If all elements of the column are greater than */
/* IKEY, PRVPTR is set to zero. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If HANDLE is invalid, the error will be diagnosed by routines */
/* called by this routine. */
/* 2) If the data type of the input column is not character, */
/* the error SPICE(INVALIDTYPE) is signalled. */
/* 3) If the input column is not indexed, the error */
/* SPICE(NOTINDEXED) is signalled. */
/* 4) If the index type of the input column is not recognized, */
/* the error will be diagnosed by routines called by this */
/* routine. */
/* 5) If an I/O error occurs while reading or writing the indicated */
/* file, the error will be diagnosed by routines called by this */
/* routine. */
/* $ Files */
/* See the EK Required Reading for a discussion of the EK file */
/* format. */
/* $ Particulars */
/* This routine finds the last column element less than or equal */
/* to a specified integer key, within a specified segment and */
/* column. */
/* In order to support the capability of creating an index for a */
/* column that has already been populated with data, this routine */
/* does not require that number of elements referenced by the */
/* input column's index match the number of elements in the column; */
/* the index is allowed to reference fewer elements. However, */
/* every record referenced by the index must be populated with data. */
/* $ Examples */
/* See ZZEKILLE. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - Beta Version 1.0.0, 09-NOV-1995 (NJB) */
/* -& */
/* Non-SPICELIB functions */
/* Local variables */
/* Use discovery check-in. */
/* If the column's not indexed, we have no business being here. */
indexd = coldsc[5] != -1;
if (! indexd) {
zzekcnam_(handle, coldsc, column, (ftnlen)32);
chkin_("ZZEKLLEI", (ftnlen)8);
setmsg_("Column # is not indexed.", (ftnlen)24);
errch_("#", column, (ftnlen)1, (ftnlen)32);
sigerr_("SPICE(NOTINDEXED)", (ftnlen)17);
chkout_("ZZEKLLEI", (ftnlen)8);
return 0;
}
/* Check the column's data type. */
dtype = coldsc[1];
if (dtype != 3) {
zzekcnam_(handle, coldsc, column, (ftnlen)32);
chkin_("ZZEKLLEI", (ftnlen)8);
setmsg_("Column # should be INT but has type #.", (ftnlen)38);
errch_("#", column, (ftnlen)1, (ftnlen)32);
errint_("#", &dtype, (ftnlen)1);
sigerr_("SPICE(INVALIDTYPE)", (ftnlen)18);
chkout_("ZZEKLLEI", (ftnlen)8);
return 0;
}
/* Handle the case of an empty segment gracefully. */
nrows = segdsc[5];
if (nrows == 0) {
*prvloc = 0;
*prvptr = 0;
return 0;
}
/* The algorithm used here is very like unto that used in LSTLED. */
begin = 1;
end = nrows;
/* Get the record pointers BEGPTR and ENDPTR of the least and */
/* greatest elements in the column. */
zzekixlk_(handle, coldsc, &begin, &begptr);
zzekixlk_(handle, coldsc, &end, &endptr);
if (zzekscmp_(&c__3, handle, segdsc, coldsc, &begptr, &c__1, &c__3, " ", &
c_b17, ikey, &c_false, (ftnlen)1)) {
/* The smallest entry of the column is greater than */
/* the input value, so none of the entries */
/* are less than or equal to the input value. */
*prvloc = 0;
*prvptr = 0;
} else if (zzekscmp_(&c__4, handle, segdsc, coldsc, &endptr, &c__1, &c__3,
" ", &c_b17, ikey, &c_false, (ftnlen)1)) {
/* The last element of the array is less than or equal to the */
/* input value. */
*prvloc = nrows;
zzekixlk_(handle, coldsc, prvloc, prvptr);
} else {
/* The input value lies between some pair of column entries. */
/* The value is greater than or equal to the smallest column entry */
/* and less than the greatest entry. */
while(end > begin + 1) {
/* Find the address of the element whose ordinal position */
/* is halfway between BEGIN and END. */
middle = (begin + end) / 2;
zzekixlk_(handle, coldsc, &middle, &midptr);
if (zzekscmp_(&c__4, handle, segdsc, coldsc, &midptr, &c__1, &
c__3, " ", &c_b17, ikey, &c_false, (ftnlen)1)) {
/* The middle value is less than or equal to the input */
/* value. */
begin = middle;
} else {
end = middle;
}
/* The input value is greater than or equal to the element */
/* having ordinal position BEGIN and strictly less than the */
/* element having ordinal position END. */
}
*prvloc = begin;
zzekixlk_(handle, coldsc, prvloc, prvptr);
}
return 0;
} /* zzekllei_ */
/* $Procedure SPKS02 ( S/P Kernel, subset, type 2 ) */
/* Subroutine */ int spks02_(integer *handle, integer *baddr, integer *eaddr,
doublereal *begin, doublereal *end)
{
/* System generated locals */
integer i__1;
/* Local variables */
doublereal data[50];
integer addr__, nrec;
doublereal init;
integer last, move;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer first;
extern /* Subroutine */ int dafada_(doublereal *, integer *), dafgda_(
integer *, integer *, integer *, doublereal *);
integer remain;
doublereal intlen;
extern /* Subroutine */ int chkout_(char *, ftnlen);
integer recsiz;
extern logical return_(void);
/* $ Abstract */
/* Extract a subset of the data in a SPK segment of type 2 */
/* into a new segment. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* SPK */
/* $ Keywords */
/* EPHEMERIS */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle of source segment. */
/* BADDR I Beginning address of source segment. */
/* EADDR I Ending address of source segment. */
/* BEGIN I Beginning (initial epoch) of subset. */
/* END I End (final epoch) of subset. */
/* $ Detailed_Input */
/* HANDLE, */
/* BADDR, */
/* EADDR are the file handle assigned to a SPK file, and the */
/* beginning and ending addresses of a segment within */
/* the file. Together they determine a complete set of */
/* ephemeris data, from which a subset is to be */
/* extracted. */
/* BEGIN, */
/* END are the initial and final epochs (ephemeris time) */
/* of the subset to be extracted. */
/* $ Detailed_Output */
/* None. This routine writes data to the SPK file currently */
/* open for write access. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) Any errors that occur while reading data from the source SPK */
/* file will be diagnosed by routines in the call tree of this */
/* routine. */
/* 2) Any errors that occur while writing data to the output SPK */
/* file will be diagnosed by routines in the call tree of this */
/* routine. */
/* $ Files */
/* See argument HANDLE. */
/* $ Particulars */
/* The exact structure of a segment of data type 2 is detailed in */
/* the SPK Required Reading file. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* NAIF Document 168.0, "S- and P- Kernel (SPK) Specification and */
/* User's Guide" */
/* $ Author_and_Institution */
/* R.E. Thurman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.1, 30-DEC-2013 (NJB) */
/* Enhanced header documentation. */
/* - SPICELIB Version 1.1.0, 07-SEP-2001 (EDW) */
/* Replaced DAFRDA call with DAFGDA. */
/* Added IMPLICIT NONE. */
/* - SPICELIB Version 1.0.3, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.2, 23-AUG-1991 (HAN) */
/* SPK02 was removed from the Required_Reading section of the */
/* header. The information in the SPK02 Required Reading file */
/* is now part of the SPK Required Reading file. */
/* - SPICELIB Version 1.0.1, 22-MAR-1990 (HAN) */
/* Literature references added to the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (RET) */
/* -& */
/* $ Index_Entries */
/* subset type_2 spk segment */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SPKS02", (ftnlen)6);
}
/* The segment is made up of a number of logical records, each */
/* having the same size, and covering the same length of time. */
/* We can determine which records to extract by comparing the input */
/* epochs with the initial time of the segment and the length of the */
/* interval covered by each record. These final two constants are */
/* located at the end of the segment, along with the size of each */
/* logical record and the total number of records. */
i__1 = *eaddr - 3;
dafgda_(handle, &i__1, eaddr, data);
init = data[0];
intlen = data[1];
recsiz = (integer) data[2];
nrec = (integer) data[3];
first = (integer) ((*begin - init) / intlen) + 1;
first = min(first,nrec);
last = (integer) ((*end - init) / intlen) + 1;
last = min(last,nrec);
/* The number of records to be moved. */
nrec = last - first + 1;
/* We're going to move the data in chunks of 50 d.p. words. Compute */
/* the number of words left to move, the address of the beginning */
/* of the records to move, and the number to move this time. */
remain = nrec * recsiz;
addr__ = *baddr + (first - 1) * recsiz;
move = min(50,remain);
while(remain > 0) {
i__1 = addr__ + move - 1;
dafgda_(handle, &addr__, &i__1, data);
dafada_(data, &move);
remain -= move;
addr__ += move;
move = min(50,remain);
}
/* That's all the records we have to move. But there are still four */
/* final numbers left to write: */
/* 1) The initial time for the polynomials (INIT). */
/* 2) The time interval length for each polynomial (INTLEN). */
/* 3) The record size (RECSIZ). */
/* 4) The number of records (NREC). */
/* INIT and NREC will probably be different for the new segment (in */
/* fact, NREC has already been changed), the other two will not. */
init += (first - 1) * intlen;
data[0] = init;
data[1] = intlen;
data[2] = (doublereal) recsiz;
data[3] = (doublereal) nrec;
dafada_(data, &c__4);
chkout_("SPKS02", (ftnlen)6);
return 0;
} /* spks02_ */
/* $Procedure SYPOPD ( Pop a value from a particular symbol ) */
/* Subroutine */ int sypopd_(char *name__, char *tabsym, integer *tabptr,
doublereal *tabval, doublereal *value, logical *found, ftnlen
name_len, ftnlen tabsym_len)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer nval, nptr, nsym;
extern integer cardc_(char *, ftnlen), cardd_(doublereal *), cardi_(
integer *);
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern integer sumai_(integer *, integer *);
extern /* Subroutine */ int scardc_(integer *, char *, ftnlen), scardd_(
integer *, doublereal *), remlac_(integer *, integer *, char *,
integer *, ftnlen);
extern integer bsrchc_(char *, integer *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int remlad_(integer *, integer *, doublereal *,
integer *), scardi_(integer *, integer *), remlai_(integer *,
integer *, integer *, integer *);
integer locval;
extern /* Subroutine */ int chkout_(char *, ftnlen);
integer locsym;
extern logical return_(void);
/* $ Abstract */
/* Pop a value associated with a particular symbol in a double */
/* precision symbol table. The first value associated with the */
/* symbol is removed, and subsequent values are moved forward. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* SYMBOLS */
/* $ Keywords */
/* SYMBOLS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* NAME I Name of the symbol whose associated value is to be */
/* popped. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL I/O Components of the symbol table. */
/* VALUE O Value that was popped. */
/* FOUND O True if the symbol exists, false if it does not. */
/* $ Detailed_Input */
/* NAME is the name of the symbol whose associated value is to */
/* be popped. If NAME is not in the symbol table, FOUND is */
/* false. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL are the components of a double precision symbol table. */
/* $ Detailed_Output */
/* TABSYM, */
/* TABPTR, */
/* TABVAL are the components of a double precision symbol table. */
/* The value is removed from the symbol table, and the */
/* remaining values associated with the symbol are moved */
/* forward in the value table. If no other values are */
/* associated with the symbol, the symbol is removed from */
/* the symbol table. */
/* VALUE is the value that was popped. This value was the first */
/* value in the symbol table that was associated with the */
/* symbol NAME. */
/* FOUND is true if NAME is in the symbol table, otherwise */
/* it is false. */
/* $ Parameters */
/* None. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Particulars */
/* If there are no remaining values associated with the symbol */
/* after VALUE has been popped, the symbol is removed from the */
/* symbol table. */
/* $ Examples */
/* The contents of the symbol table are: */
/* BODY4_POLE_RA --> 3.17681D2 */
/* 1.08D-1 */
/* 0.0D0 */
/* DELTA_T_A --> 3.2184D1 */
/* K --> 1.657D-3 */
/* MEAN_ANOM --> 6.239996D0 */
/* 1.99096871D-7 */
/* ORBIT_ECC --> 1.671D-2 */
/* The call, */
/* CALL SYPOPD ( 'MEAN_ANOM', TABSYM, TABPTR, TABVAL, VALUE, FOUND ) */
/* modifies the contents of the symbol table to be: */
/* BODY4_POLE_RA --> 3.17681D2 */
/* 1.08D-1 */
/* 0.0D0C */
/* DELTA_T_A --> 3.2184D1 */
/* K --> 1.657D-3 */
/* MEAN_ANOM --> 1.99096871D-7 */
/* ORBIT_ECC --> 1.671D-2 */
/* FOUND is TRUE, and VALUE is 6.239996D0. */
/* The next call, */
/* CALL SYPOPD ( 'K', TABSYM, TABPTR, TABVAL, VALUE, FOUND ) */
/* modifies the contents of the symbol table to be: */
/* BODY4_POLE_RA --> 3.17681D2 */
/* 1.08D-1 */
/* 0.0D0C */
/* DELTA_T_A --> 3.2184D1 */
/* MEAN_ANOM --> 1.99096871D-7 */
/* ORBIT_ECC --> 1.671D-2 */
/* FOUND is TRUE, and VALUE is 1.657D-3. Note that because */
/* "K" had only one value associated with it, it was removed */
/* from the symbol table. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) (HAN) */
/* -& */
/* $ Index_Entries */
/* pop a value from a particular symbol */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SYPOPD", (ftnlen)6);
}
/* How many symbols to start with? */
nsym = cardc_(tabsym, tabsym_len);
nptr = cardi_(tabptr);
nval = cardd_(tabval);
/* Is this symbol even in the table? */
locsym = bsrchc_(name__, &nsym, tabsym + tabsym_len * 6, name_len,
tabsym_len);
/* If it's not in the table, it's definitely a problem. */
if (locsym == 0) {
*found = FALSE_;
/* If it is in the table, we can proceed without fear of overflow. */
} else {
*found = TRUE_;
/* Begin by saving and removing the initial value for this */
/* symbol from the value table. */
i__1 = locsym - 1;
locval = sumai_(&tabptr[6], &i__1) + 1;
*value = tabval[locval + 5];
remlad_(&c__1, &locval, &tabval[6], &nval);
scardd_(&nval, tabval);
/* If this was the sole value for the symbol, remove the */
/* symbol from the name and pointer tables. Otherwise just */
/* decrement the dimension. */
if (tabptr[locsym + 5] == 1) {
remlac_(&c__1, &locsym, tabsym + tabsym_len * 6, &nsym,
tabsym_len);
scardc_(&nsym, tabsym, tabsym_len);
remlai_(&c__1, &locsym, &tabptr[6], &nptr);
scardi_(&nptr, tabptr);
} else {
--tabptr[locsym + 5];
}
}
chkout_("SYPOPD", (ftnlen)6);
return 0;
} /* sypopd_ */
/* $Procedure SYTRNI (Transpose two values associated with a symbol) */
/* Subroutine */ int sytrni_(char *name__, integer *i__, integer *j, char *
tabsym, integer *tabptr, integer *tabval, ftnlen name_len, ftnlen
tabsym_len)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer nsym;
extern integer cardc_(char *, ftnlen);
integer n;
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern integer sumai_(integer *, integer *);
extern /* Subroutine */ int swapi_(integer *, integer *);
extern integer bsrchc_(char *, integer *, char *, ftnlen, ftnlen);
integer locval;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
integer locsym;
extern logical return_(void);
/* $ Abstract */
/* Transpose two values associated with a particular symbol in an */
/* integer symbol table. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* SYMBOLS */
/* $ Keywords */
/* SYMBOLS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* NAME I Name of the symbol whose associated values are to */
/* be transposed. */
/* I I Index of the first associated value to be */
/* transposed. */
/* J I Index of the second associated value to be */
/* transposed. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL I/O Components of the symbol table. */
/* $ Detailed_Input */
/* NAME is the name of the symbol whose associated values are */
/* to be transposed. If NAME is not in the symbol table, */
/* the symbol tables are not modified. */
/* I is the index of the first associated value to be */
/* transposed. */
/* J is the index of the second associated value to be */
/* transposed. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL are components of the integer symbol table. */
/* $ Detailed_Output */
/* TABSYM, */
/* TABPTR, */
/* TABVAL are components of the integer symbol table. */
/* If the symbol NAME is not in the symbol table */
/* the symbol tables are not modified. Otherwise, */
/* the values that I and J refer to are transposed */
/* in the value table. */
/* $ Parameters */
/* None. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* 1) If I < 1, J < 1, I > the dimension of NAME, or J > the */
/* dimension of NAME, the error SPICE(INVALIDINDEX) is signaled. */
/* 2) If NAME is not in the symbol table, the symbol tables are not */
/* modified. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* The contents of the symbol table are: */
/* books --> 5 */
/* erasers --> 6 */
/* pencils --> 12 */
/* 18 */
/* 24 */
/* pens --> 10 */
/* 20 */
/* 30 */
/* 40 */
/* The call, */
/* CALL SYTRNI ( 'pens', 2, 3, TABSYM, TABPTR, TABVAL ) */
/* modifies the contents of the symbol table to be: */
/* books --> 5 */
/* erasers --> 6 */
/* pencils --> 12 */
/* 18 */
/* 24 */
/* pens --> 10 */
/* 30 */
/* 20 */
/* 40 */
/* The next call, */
/* CALL SYTRNI ( 'pencils', 2, 4, TABSYM, TABPTR, TABVAL ) */
/* causes the error SPICE(INVALIDINDEX) to be signaled. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.0, 09-SEP-2005 (NJB) */
/* Updated so no "exchange" occurs if I equals J. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) (HAN) */
/* -& */
/* $ Index_Entries */
/* transpose two values associated with a symbol */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.1.0, 09-SEP-2005 (NJB) */
/* Updated so no "exchange" occurs if I equals J. */
/* - Beta Version 2.0.0, 16-JAN-1989 (HAN) */
/* If one of the indices of the values to be transposed is */
/* invalid, an error is signaled and the symbol table is */
/* not modified. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SYTRNI", (ftnlen)6);
}
/* How many symbols? */
nsym = cardc_(tabsym, tabsym_len);
/* Is this symbol even in the table? */
locsym = bsrchc_(name__, &nsym, tabsym + tabsym_len * 6, name_len,
tabsym_len);
if (locsym > 0) {
/* Are there enough values associated with the symbol? */
n = tabptr[locsym + 5];
/* Are the indices valid? */
if (*i__ >= 1 && *i__ <= n && *j >= 1 && *j <= n) {
/* Exchange the values in place. */
if (*i__ != *j) {
i__1 = locsym - 1;
locval = sumai_(&tabptr[6], &i__1) + 1;
swapi_(&tabval[locval + *i__ + 4], &tabval[locval + *j + 4]);
}
} else {
setmsg_("The first index was *. The second index was *.", (ftnlen)
46);
errint_("*", i__, (ftnlen)1);
errint_("*", j, (ftnlen)1);
sigerr_("SPICE(INVALIDINDEX)", (ftnlen)19);
}
}
chkout_("SYTRNI", (ftnlen)6);
return 0;
} /* sytrni_ */
/* $Procedure ZZEKCDSC ( Private: EK, return column descriptor ) */
/* Subroutine */ int zzekcdsc_(integer *handle, integer *segdsc, char *column,
integer *coldsc, ftnlen column_len)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
integer unit, i__;
char cname[32];
integer mbase;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
logical found;
integer ncols;
extern logical eqstr_(char *, char *, ftnlen, ftnlen);
integer dscbas;
extern /* Subroutine */ int dasrdc_(integer *, integer *, integer *,
integer *, integer *, char *, ftnlen);
integer nambas;
extern /* Subroutine */ int dasrdi_(integer *, integer *, integer *,
integer *), dashlu_(integer *, integer *), setmsg_(char *, ftnlen)
, errint_(char *, integer *, ftnlen), errfnm_(char *, integer *,
ftnlen), sigerr_(char *, ftnlen), chkout_(char *, ftnlen);
/* $ Abstract */
/* SPICE Private routine intended solely for the support of SPICE */
/* routines. Users should not call this routine directly due */
/* to the volatile nature of this routine. */
/* Look up the column descriptor for a column of a given name */
/* in a specified segment. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* EK */
/* $ Keywords */
/* EK */
/* PRIVATE */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Column Name Size */
/* ekcnamsz.inc Version 1 17-JAN-1995 (NJB) */
/* Size of column name, in characters. */
/* End Include Section: EK Column Name Size */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Column Descriptor Parameters */
/* ekcoldsc.inc Version 6 23-AUG-1995 (NJB) */
/* Note: The column descriptor size parameter CDSCSZ is */
/* declared separately in the include section CDSIZE$INC.FOR. */
/* Offset of column descriptors, relative to start of segment */
/* integer address range. This number, when added to the last */
/* integer address preceding the segment, yields the DAS integer */
/* base address of the first column descriptor. Currently, this */
/* offset is exactly the size of a segment descriptor. The */
/* parameter SDSCSZ, which defines the size of a segment descriptor, */
/* is declared in the include file eksegdsc.inc. */
/* Size of column descriptor */
/* Indices of various pieces of column descriptors: */
/* CLSIDX is the index of the column's class code. (We use the */
/* word `class' to distinguish this item from the column's data */
/* type.) */
/* TYPIDX is the index of the column's data type code (CHR, INT, DP, */
/* or TIME). The type is actually implied by the class, but it */
/* will frequently be convenient to look up the type directly. */
/* LENIDX is the index of the column's string length value, if the */
/* column has character type. A value of IFALSE in this element of */
/* the descriptor indicates that the strings have variable length. */
/* SIZIDX is the index of the column's element size value. This */
/* descriptor element is meaningful for columns with fixed-size */
/* entries. For variable-sized columns, this value is IFALSE. */
/* NAMIDX is the index of the base address of the column's name. */
/* IXTIDX is the data type of the column's index. IXTIDX */
/* contains a type value only if the column is indexed. For columns */
/* that are not indexed, the location IXTIDX contains the boolean */
/* value IFALSE. */
/* IXPIDX is a pointer to the column's index. IXTPDX contains a */
/* meaningful value only if the column is indexed. The */
/* interpretation of the pointer depends on the data type of the */
/* index. */
/* NFLIDX is the index of a flag indicating whether nulls are */
/* permitted in the column. The value at location NFLIDX is */
/* ITRUE if nulls are permitted and IFALSE otherwise. */
/* ORDIDX is the index of the column's ordinal position in the */
/* list of columns belonging to the column's parent segment. */
/* METIDX is the index of the column's integer metadata pointer. */
/* This pointer is a DAS integer address. */
/* The last position in the column descriptor is reserved. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Column Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Segment Descriptor Parameters */
/* eksegdsc.inc Version 8 06-NOV-1995 (NJB) */
/* All `base addresses' referred to below are the addresses */
/* *preceding* the item the base applies to. This convention */
/* enables simplied address calculations in many cases. */
/* Size of segment descriptor. Note: the include file ekcoldsc.inc */
/* must be updated if this parameter is changed. The parameter */
/* CDOFF in that file should be kept equal to SDSCSZ. */
/* Index of the segment type code: */
/* Index of the segment's number. This number is the segment's */
/* index in the list of segments contained in the EK to which */
/* the segment belongs. */
/* Index of the DAS integer base address of the segment's integer */
/* meta-data: */
/* Index of the DAS character base address of the table name: */
/* Index of the segment's column count: */
/* Index of the segment's record count: */
/* Index of the root page number of the record tree: */
/* Index of the root page number of the character data page tree: */
/* Index of the root page number of the double precision data page */
/* tree: */
/* Index of the root page number of the integer data page tree: */
/* Index of the `modified' flag: */
/* Index of the `initialized' flag: */
/* Index of the shadowing flag: */
/* Index of the companion file handle: */
/* Index of the companion segment number: */
/* The next three items are, respectively, the page numbers of the */
/* last character, d.p., and integer data pages allocated by the */
/* segment: */
/* The next three items are, respectively, the page-relative */
/* indices of the last DAS word in use in the segment's */
/* last character, d.p., and integer data pages: */
/* Index of the DAS character base address of the column name list: */
/* The last descriptor element is reserved for future use. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Segment Descriptor Parameters */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle attached to an EK file. */
/* SEGDSC I Segment descriptor. */
/* COLUMN I Name of column. */
/* COLDSC O Descriptor for specified column. */
/* $ Detailed_Input */
/* HANDLE is an EK file handle for the file containing the */
/* column of interest. The EK may be open for read */
/* or write access. */
/* SEGDSC is the descriptor of the segment containing the */
/* column for which a descriptor is desired. */
/* COLUMN is the name of the column whose descriptor is */
/* desired. Case and white space are not significant. */
/* $ Detailed_Output */
/* COLDSC is the descriptor of the column belonging to the */
/* specified file and segment and having name COLUMN. */
/* See the include file ekcoldsc.inc for details */
/* regarding the structure of EK column descriptors. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the input column name does not match any column in the */
/* designated segment, the error SPICE(BUG) is signalled. It */
/* is the caller's responsibility to call this routine with */
/* valid input arguments. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine exists for the sole purpose of centralizing code */
/* used to perform column descriptor look-ups. */
/* $ Examples */
/* See the EKACEx routines. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - Beta Version 1.0.0, 27-SEP-1995 (NJB) */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Use discovery check-in. */
/* Get the segment's integer metadata's base address. */
mbase = segdsc[2];
/* Get the number of columns. */
ncols = segdsc[4];
/* Search linearly through the column descriptors, looking for */
/* a column name match. It's an error if we don't find the input */
/* name. */
found = FALSE_;
i__ = 1;
while(i__ <= ncols && ! found) {
dscbas = mbase + 24 + (i__ - 1) * 11;
/* Get the character base address of the column name from the */
/* current descriptor. */
i__1 = dscbas + 1;
i__2 = dscbas + 11;
dasrdi_(handle, &i__1, &i__2, coldsc);
nambas = coldsc[4];
/* Look up the name and compare. */
i__1 = nambas + 1;
i__2 = nambas + 32;
dasrdc_(handle, &i__1, &i__2, &c__1, &c__32, cname, (ftnlen)32);
if (eqstr_(cname, column, (ftnlen)32, column_len)) {
found = TRUE_;
} else {
++i__;
}
}
if (! found) {
dashlu_(handle, &unit);
chkin_("ZZEKCDSC", (ftnlen)8);
setmsg_("Descriptor for column # was not found. Segment base = #; fi"
"le = #.", (ftnlen)66);
errch_("#", column, (ftnlen)1, column_len);
errint_("#", &mbase, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZEKCDSC", (ftnlen)8);
return 0;
}
return 0;
} /* zzekcdsc_ */
/* $Procedure DAFRFR ( DAF, read file record ) */
/* Subroutine */ int dafrfr_(integer *handle, integer *nd, integer *ni, char *
ifname, integer *fward, integer *bward, integer *free, ftnlen
ifname_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int zzdafgfr_(integer *, char *, integer *,
integer *, char *, integer *, integer *, integer *, logical *,
ftnlen, ftnlen), chkin_(char *, ftnlen);
logical found;
extern logical failed_(void);
extern /* Subroutine */ int dafsih_(integer *, char *, ftnlen);
char idword[8];
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Read the contents of the file record of a DAF. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* DAF */
/* $ Keywords */
/* FILES */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle of an open DAF file. */
/* ND O Number of double precision components in summaries. */
/* NI O Number of integer components in summaries. */
/* IFNAME O Internal file name. */
/* FWARD O Forward list pointer. */
/* BWARD O Backward list pointer. */
/* FREE O Free address pointer. */
/* $ Detailed_Input */
/* HANDLE is the handle assigned to a DAF file opened for */
/* reading. */
/* $ Detailed_Output */
/* ND, */
/* NI are the numbers of double precision and integer */
/* components, respectively, in each array summary in */
/* the specified file. */
/* IFNAME is the internal file name stored in the first */
/* (or file) record of the specified file. */
/* FWARD is the forward list pointer. This points to the */
/* first summary record in the file. (Records between */
/* the first record and the first summary record are */
/* reserved when the file is created, and are invisible */
/* to DAF routines.) */
/* BWARD is the backward list pointer. This points */
/* to the final summary record in the file. */
/* FREE is the free address pointer. This contains the */
/* first free address in the file. (That is, the */
/* initial address of the next array to be added */
/* to the file.) */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the handle passed to this routine is not the handle of an */
/* open DAF file, the error will be signaled by a routine called */
/* by this routine. */
/* 2) If the specified DAF file is not open for read access, the */
/* error will be diagnosed by a routine called by this routine. */
/* 3) If the specified record cannot (for some reason) be read, */
/* the error SPICE(DAFFRNOTFOUND) is signaled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The file record of a DAF is the only record that contains */
/* any global information about the file. This record is created */
/* when the file is created, and is updated only when new arrays */
/* are added. */
/* Like character records, file records are not buffered. */
/* $ Examples */
/* In the following example, the value of the forward list */
/* pointer is examined in order to determine the number of */
/* reserved records in the DAF. These records are then read */
/* and the contents printed to the screen. */
/* CALL DAFRFR ( HANDLE, ND, NI, IFNAME, FWARD, BWARD, FREE ) */
/* CALL DAFHLU ( HANDLE, UNIT ) */
/* DO I = 2, FWARD - 1 */
/* READ (UNIT,REC=I) PRIVATE(1:1000) */
/* WRITE (*,*) PRIVATE(1:1000) */
/* END DO */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* NAIF Document 167.0, "Double Precision Array Files (DAF) */
/* Specification and User's Guide" */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 3.1.0, 30-DEC-2009 (EDW) */
/* Expanded DAFFRNOTFOUND error message to identify the file */
/* handle corresponding to the error condition. */
/* Reordered header sections to conform to SPICE format. */
/* Merged the Revisions sections, now deleted, with Version. */
/* - SPICELIB Version 3.0.0, 16-NOV-2001 (FST) */
/* Updated this routine to utilize interfaces built on */
/* the new handle manager to perform I/O operations. */
/* This routine now utilizes ZZDAFGFR to retrieve information */
/* from the file record. As this private interface takes a */
/* handle and performs the necessary logical unit to handle */
/* mapping, the call to DAFHLU was removed. The DAFSIH call */
/* remains, since this insures that HANDLE is known to DAFAH. */
/* C */
/* - SPICELIB Version 2.0.0, 04-OCT-1993 (KRG) */
/* The error SPICE(DAFNOIDWORD) is no longer signaled by this */
/* routine. The reason for this is that if DAFSIH returns OK then */
/* the handle passed to this routine is indeed a valid DAF file */
/* handle, otherwise the error is diagnosed by DAFSIH. */
/* Added a call to DAFSIH to signal an invalid handle and a test */
/* of FAILED () after it. This is to make sure that the DAF file */
/* is open for reading. If this call succeeds, we know that we */
/* have a valid DAF handle, so there is no need to check FAILED */
/* after the call to DAFHLU. */
/* The variable name DAFWRD was changed to IDWORD. */
/* Added two new exceptions to the $ Exceptions section: 1 and 2. */
/* The remaining exception (3) was already present. The exceptions */
/* that were added are not new, but are being documented for the */
/* first time. */
/* - SPICELIB Version 1.0.3, 6-OCT-1992 (HAN) */
/* Corrected a typo in the Brief_I/O section. ND was listed */
/* twice as an input, and NI was not listed. */
/* - SPICELIB Version 1.0.2, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.1, 22-MAR-1990 (HAN) */
/* Literature references added to the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) */
/* -& */
/* $ Index_Entries */
/* read daf file record */
/* -& */
/* SPICELIB functions */
/* Local Parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("DAFRFR", (ftnlen)6);
}
/* Do some initializations */
s_copy(idword, " ", (ftnlen)8, (ftnlen)1);
/* Check to be sure that HANDLE is attached to a file that is open */
/* with read access. If the call fails, check out and return. */
dafsih_(handle, "READ", (ftnlen)4);
if (failed_()) {
chkout_("DAFRFR", (ftnlen)6);
return 0;
}
/* Retrieve all but the internal file name directly from the */
/* file record. Read the internal file name into a temporary */
/* string, to be sure of the length. Check FOUND. */
zzdafgfr_(handle, idword, nd, ni, ifname, fward, bward, free, &found, (
ftnlen)8, ifname_len);
if (! found) {
setmsg_("File record not found for file handle #1. Check if program "
"code uses handle #2 for a read or write operation.", (ftnlen)
109);
errint_("#1", handle, (ftnlen)2);
errint_("#2", handle, (ftnlen)2);
sigerr_("SPICE(DAFFRNOTFOUND)", (ftnlen)20);
chkout_("DAFRFR", (ftnlen)6);
return 0;
}
chkout_("DAFRFR", (ftnlen)6);
return 0;
} /* dafrfr_ */
/* $Procedure KPLFRM ( Kernel pool frame IDs ) */
/* Subroutine */ int kplfrm_(integer *frmcls, integer *idset)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
integer i__, l, m, n, w;
extern /* Subroutine */ int chkin_(char *, ftnlen), repmc_(char *, char *,
char *, char *, ftnlen, ftnlen, ftnlen, ftnlen);
logical found;
extern /* Subroutine */ int repmi_(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
extern integer sizei_(integer *);
integer idcode, to;
extern /* Subroutine */ int scardi_(integer *, integer *);
char frname[32];
extern /* Subroutine */ int validi_(integer *, integer *, integer *);
char kvcode[32];
integer fclass;
char kvname[32], kvbuff[32*100], kvclas[32];
extern /* Subroutine */ int gcpool_(char *, integer *, integer *, integer
*, char *, logical *, ftnlen, ftnlen), gipool_(char *, integer *,
integer *, integer *, integer *, logical *, ftnlen);
char tmpnam[32];
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
char kvtemp[32];
extern /* Subroutine */ int gnpool_(char *, integer *, integer *, integer
*, char *, logical *, ftnlen, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Return a SPICE set containing the frame IDs of all reference */
/* frames of a given class having specifications in the kernel pool. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* CELLS */
/* FRAMES */
/* KERNEL */
/* NAIF_IDS */
/* SETS */
/* $ Keywords */
/* FRAME */
/* SET */
/* UTILITY */
/* $ Declarations */
/* $ Abstract */
/* The parameters below form an enumerated list of the recognized */
/* frame types. They are: INERTL, PCK, CK, TK, DYN. The meanings */
/* are outlined below. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Parameters */
/* INERTL an inertial frame that is listed in the routine */
/* CHGIRF and that requires no external file to */
/* compute the transformation from or to any other */
/* inertial frame. */
/* PCK is a frame that is specified relative to some */
/* INERTL frame and that has an IAU model that */
/* may be retrieved from the PCK system via a call */
/* to the routine TISBOD. */
/* CK is a frame defined by a C-kernel. */
/* TK is a "text kernel" frame. These frames are offset */
/* from their associated "relative" frames by a */
/* constant rotation. */
/* DYN is a "dynamic" frame. These currently are */
/* parameterized, built-in frames where the full frame */
/* definition depends on parameters supplied via a */
/* frame kernel. */
/* ALL indicates any of the above classes. This parameter */
/* is used in APIs that fetch information about frames */
/* of a specified class. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 4.0.0, 08-MAY-2012 (NJB) */
/* The parameter ALL was added to support frame fetch APIs. */
/* - SPICELIB Version 3.0.0, 28-MAY-2004 (NJB) */
/* The parameter DYN was added to support the dynamic frame class. */
/* - SPICELIB Version 2.0.0, 12-DEC-1996 (WLT) */
/* Various unused frames types were removed and the */
/* frame time TK was added. */
/* - SPICELIB Version 1.0.0, 10-DEC-1995 (WLT) */
/* -& */
/* End of INCLUDE file frmtyp.inc */
/* $ Abstract */
/* This file contains the number of inertial reference */
/* frames that are currently known by the SPICE toolkit */
/* software. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* FRAMES */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* NINERT P Number of known inertial reference frames. */
/* $ Parameters */
/* NINERT is the number of recognized inertial reference */
/* frames. This value is needed by both CHGIRF */
/* ZZFDAT, and FRAMEX. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 10-OCT-1996 (WLT) */
/* -& */
/* $ Abstract */
/* This file contains the number of non-inertial reference */
/* frames that are currently built into the SPICE toolkit */
/* software. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* FRAMES */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* NINERT P Number of built-in non-inertial reference frames. */
/* $ Parameters */
/* NINERT is the number of built-in non-inertial reference */
/* frames. This value is needed by both ZZFDAT, and */
/* FRAMEX. */
/* $ Author_and_Institution */
/* B.V. Semenov (JPL) */
/* W.L. Taber (JPL) */
/* F.S. Turner (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.5.0, 11-OCT-2011 (BVS) */
/* Increased the number of non-inertial frames from 100 to 105 */
/* in order to accomodate the following PCK based frames: */
/* IAU_CERES */
/* IAU_PALLAS */
/* IAU_LUTETIA */
/* IAU_DAVIDA */
/* IAU_STEINS */
/* - SPICELIB Version 1.4.0, 11-MAY-2010 (BVS) */
/* Increased the number of non-inertial frames from 96 to 100 */
/* in order to accomodate the following PCK based frames: */
/* IAU_BORRELLY */
/* IAU_TEMPEL_1 */
/* IAU_VESTA */
/* IAU_ITOKAWA */
/* - SPICELIB Version 1.3.0, 12-DEC-2002 (BVS) */
/* Increased the number of non-inertial frames from 85 to 96 */
/* in order to accomodate the following PCK based frames: */
/* IAU_CALLIRRHOE */
/* IAU_THEMISTO */
/* IAU_MAGACLITE */
/* IAU_TAYGETE */
/* IAU_CHALDENE */
/* IAU_HARPALYKE */
/* IAU_KALYKE */
/* IAU_IOCASTE */
/* IAU_ERINOME */
/* IAU_ISONOE */
/* IAU_PRAXIDIKE */
/* - SPICELIB Version 1.2.0, 02-AUG-2002 (FST) */
/* Increased the number of non-inertial frames from 81 to 85 */
/* in order to accomodate the following PCK based frames: */
/* IAU_PAN */
/* IAU_GASPRA */
/* IAU_IDA */
/* IAU_EROS */
/* - SPICELIB Version 1.1.0, 20-FEB-1997 (WLT) */
/* Increased the number of non-inertial frames from 79 to 81 */
/* in order to accomodate the following earth rotation */
/* models: */
/* ITRF93 */
/* EARTH_FIXED */
/* - SPICELIB Version 1.0.0, 10-OCT-1996 (WLT) */
/* -& */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* FRMCLS I Frame class. */
/* IDSET O Set of ID codes of frames of the specified class. */
/* $ Detailed_Input */
/* FRMCLS is an integer code specifying the frame class or */
/* classes for which frame ID codes are requested. */
/* The applicable reference frames are those having */
/* specifications present in the kernel pool. */
/* FRMCLS may designate a single class or "all */
/* classes." */
/* The include file frmtyp.inc declares parameters */
/* identifying frame classes. The supported values */
/* and corresponding meanings of FRMCLS are */
/* Parameter Value Meaning */
/* ========= ===== ================= */
/* ALL -1 All frame classes */
/* specified in the */
/* kernel pool. Class 1 */
/* is not included. */
/* INERTL 1 Built-in inertial. */
/* No frames will be */
/* returned in the */
/* output set. */
/* PCK 2 PCK-based frame */
/* CK 3 CK-based frame */
/* TK 4 Fixed rotational */
/* offset ("text */
/* kernel") frame */
/* DYN 5 Dynamic frame */
/* $ Detailed_Output */
/* IDSET is a SPICE set containing the ID codes of all */
/* reference frames having specifications present in */
/* the kernel pool and belonging to the specified */
/* class or classes. */
/* Note that if FRMCLS is set to INERTL, IDSET */
/* will be empty on output. */
/* $ Parameters */
/* See the INCLUDE file frmtyp.inc. */
/* $ Exceptions */
/* 1) If the input frame class argument is not defined in */
/* frmtyp.inc, the error SPICE(BADFRAMECLASS) is signaled. */
/* 2) If the size of IDSET is too small to hold the requested frame */
/* ID set, the error SPICE(SETTOOSMALL) is signaled. */
/* 3) Frames of class 1 may not be specified in the kernel pool. */
/* However, for the convenience of users, this routine does not */
/* signal an error if the input class is set to INERTL. In this */
/* case the output set will be empty. */
/* 4) This routine relies on the presence of just three kernel */
/* variable assignments for a reference frame in order to */
/* determine that that reference frame has been specified: */
/* FRAME_<frame name> = <ID code> */
/* FRAME_<ID code>_NAME = <frame name> */
/* and either */
/* FRAME_<ID code>_CLASS = <class> */
/* or */
/* FRAME_<frame name>_CLASS = <class> */
/* It is possible for the presence of an incomplete frame */
/* specification to trick this routine into incorrectly */
/* deciding that a frame has been specified. This routine */
/* does not attempt to diagnose this problem. */
/* $ Files */
/* 1) Reference frame specifications for frames that are not */
/* built in are typically established by loading frame kernels. */
/* $ Particulars */
/* This routine enables SPICE-based applications to conveniently */
/* find the frame ID codes of reference frames having specifications */
/* present in the kernel pool. Such frame specifications are */
/* introduced into the kernel pool either by loading frame kernels */
/* or by means of calls to the kernel pool "put" API routines */
/* PCPOOL */
/* PDPOOL */
/* PIPOOL */
/* Given a reference frame's ID code, other attributes of the */
/* frame can be obtained via calls to entry points of the */
/* umbrella routine FRAMEX: */
/* FRMNAM {Return a frame's name} */
/* FRINFO {Return a frame's center, class, and class ID} */
/* This routine has a counterpart */
/* BLTFRM */
/* which fetches the frame IDs of all built-in reference frames. */
/* $ Examples */
/* 1) Display the IDs and names of all reference frames having */
/* specifications present in the kernel pool. Group the outputs */
/* by frame class. Also fetch and display the entire set of IDs */
/* and names using the parameter ALL. */
/* The meta-kernel used for this example is shown below. The */
/* Rosetta kernels referenced by the meta-kernel are available */
/* in the path */
/* pub/naif/ROSETTA/kernels/fk */
/* on the NAIF server. Older, but officially archived versions */
/* of these kernels are available in the path */
/* pub/naif/pds/data/ros-e_m_a_c-spice-6-v1.0/ */
/* rossp_1000/DATA/FK */
/* The referenced PCK is available from the pck path under the */
/* generic_kernels path on the same server. */
/* KPL/MK */
/* \begindata */
/* KERNELS_TO_LOAD = ( 'pck00010.tpc' */
/* 'EARTHFIXEDITRF93.TF' */
/* 'ROS_LUTETIA_RSOC_V03.TF' */
/* 'ROS_V18.TF' */
/* 'RSSD0002.TF' ) */
/* \begintext */
/* Program source code: */
/* PROGRAM EX1 */
/* IMPLICIT NONE */
/* INCLUDE 'frmtyp.inc' */
/* C */
/* C SPICELIB functions */
/* C */
/* INTEGER CARDI */
/* C */
/* C Local parameters */
/* C */
/* CHARACTER*(*) META */
/* PARAMETER ( META = 'kplfrm.tm' ) */
/* INTEGER NFRAME */
/* PARAMETER ( NFRAME = 1000 ) */
/* INTEGER LBCELL */
/* PARAMETER ( LBCELL = -5 ) */
/* INTEGER LNSIZE */
/* PARAMETER ( LNSIZE = 80 ) */
/* INTEGER FRNMLN */
/* PARAMETER ( FRNMLN = 32 ) */
/* C */
/* C Local variables */
/* C */
/* CHARACTER*(FRNMLN) FRNAME */
/* CHARACTER*(LNSIZE) OUTLIN */
/* INTEGER I */
/* INTEGER IDSET ( LBCELL : NFRAME ) */
/* INTEGER J */
/* C */
/* C Initialize the frame set. */
/* C */
/* CALL SSIZEI ( NFRAME, IDSET ) */
/* C */
/* C Load kernels that contain frame specifications. */
/* C */
/* CALL FURNSH ( META ) */
/* C */
/* C Fetch and display the frames of each class. */
/* C */
/* DO I = 1, 6 */
/* IF ( I .LT. 6 ) THEN */
/* C */
/* C Fetch the frames of class I. */
/* C */
/* CALL KPLFRM ( I, IDSET ) */
/* OUTLIN = 'Number of frames of class #: #' */
/* CALL REPMI ( OUTLIN, '#', I, OUTLIN ) */
/* CALL REPMI ( OUTLIN, '#', CARDI(IDSET), OUTLIN ) */
/* ELSE */
/* C */
/* C Fetch IDs of all frames specified in the kernel */
/* C pool. */
/* C */
/* CALL KPLFRM ( ALL, IDSET ) */
/* OUTLIN = 'Number of frames in the kernel pool: #' */
/* CALL REPMI ( OUTLIN, '#', CARDI(IDSET), OUTLIN ) */
/* END IF */
/* CALL TOSTDO ( ' ' ) */
/* CALL TOSTDO ( OUTLIN ) */
/* CALL TOSTDO ( ' Frame IDs and names' ) */
/* DO J = 1, CARDI(IDSET) */
/* CALL FRMNAM ( IDSET(J), FRNAME ) */
/* WRITE (*,*) IDSET(J), ' ', FRNAME */
/* END DO */
/* END DO */
/* END */
/* The output from the program, when the program was linked */
/* against the N0064 SPICE Toolkit, is shown below. The output */
/* shown here has been abbreviated. */
/* Number of frames of class 1: 0 */
/* Frame IDs and names */
/* Number of frames of class 2: 3 */
/* Frame IDs and names */
/* 1000012 67P/C-G_FIXED */
/* 2000021 LUTETIA_FIXED */
/* 2002867 STEINS_FIXED */
/* Number of frames of class 3: 7 */
/* Frame IDs and names */
/* -226570 ROS_RPC_BOOM2 */
/* -226215 ROS_VIRTIS-M_SCAN */
/* -226072 ROS_HGA_AZ */
/* -226071 ROS_HGA_EL */
/* -226025 ROS_SA-Y */
/* -226015 ROS_SA+Y */
/* -226000 ROS_SPACECRAFT */
/* Number of frames of class 4: 64 */
/* Frame IDs and names */
/* -2260021 ROS_LUTETIA */
/* -226999 ROSLND_LOCAL_LEVEL */
/* -226900 ROSLND_LANDER */
/* -226560 ROS_RPC_BOOM1 */
/* ... */
/* -226030 ROS_MGA-S */
/* -226020 ROS_SA-Y_ZERO */
/* -226010 ROS_SA+Y_ZERO */
/* 1502010 HCI */
/* 1502301 LME2000 */
/* 1503299 VME2000 */
/* 1503499 MME2000 */
/* Number of frames of class 5: 19 */
/* Frame IDs and names */
/* -226967 2867/STEINS_CSO */
/* -226945 45P/H-M-P_CSO */
/* -226921 21/LUTETIA_CSO */
/* -226920 21/LUTETIA_CSEQ */
/* -226912 67P/C-G_CSO */
/* -226910 67P/C-G_CSEQ */
/* 1500010 HEE */
/* 1500299 VSO */
/* 1500301 LSE */
/* 1500399 GSE */
/* 1500499 MME */
/* 1501010 HEEQ */
/* 1501299 VME */
/* 1501301 LME */
/* 1501399 EME */
/* 1501499 MME_IAU2000 */
/* 1502399 GSEQ */
/* 1502499 MSO */
/* 1503399 ECLIPDATE */
/* Number of frames in the kernel pool: 93 */
/* Frame IDs and names */
/* -2260021 ROS_LUTETIA */
/* -226999 ROSLND_LOCAL_LEVEL */
/* -226967 2867/STEINS_CSO */
/* -226945 45P/H-M-P_CSO */
/* -226921 21/LUTETIA_CSO */
/* ... */
/* 1503299 VME2000 */
/* 1503399 ECLIPDATE */
/* 1503499 MME2000 */
/* 2000021 LUTETIA_FIXED */
/* 2002867 STEINS_FIXED */
/* $ Restrictions */
/* 1) This routine will work correctly if the kernel pool */
/* contains no invalid frame specifications. See the */
/* description of exception 4 above. Users must ensure */
/* that no invalid frame specifications are introduced */
/* into the kernel pool, either by loaded kernels or */
/* by means of the kernel pool "put" APIs. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 22-MAY-2012 (NJB) */
/* -& */
/* $ Index_Entries */
/* fetch IDs of reference_frames from the kernel_pool */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
if (return_()) {
return 0;
}
chkin_("KPLFRM", (ftnlen)6);
/* The output set starts out empty. */
scardi_(&c__0, idset);
/* Check the input frame class. */
/* This block of code must be kept in sync with frmtyp.inc. */
if (*frmcls > 5 || *frmcls == 0 || *frmcls < -1) {
setmsg_("Frame class specifier FRMCLS was #; this value is not suppo"
"rted.", (ftnlen)64);
errint_("#", frmcls, (ftnlen)1);
sigerr_("SPICE(BADFRAMECLASS)", (ftnlen)20);
chkout_("KPLFRM", (ftnlen)6);
return 0;
}
/* Initialize the output buffer index. The */
/* index is to be incremented prior to each */
/* write to the buffer. */
to = 0;
/* Find all of the kernel variables having names */
/* that could correspond to frame name assignments. */
/* We expect that all frame specifications will */
/* include assignments of the form */
/* FRAME_<ID code>_NAME = <frame name> */
/* We may pick up some additional assignments that are not part of */
/* frame specifications; we plan to filter out as many as possible */
/* by looking the corresponding frame ID and frame class */
/* assignments. */
s_copy(kvtemp, "FRAME_*_NAME", (ftnlen)32, (ftnlen)12);
gnpool_(kvtemp, &c__1, &c__100, &n, kvbuff, &found, (ftnlen)32, (ftnlen)
32);
while(n > 0) {
/* At least one kernel variable was found by the last */
/* GNPOOL call. Each of these variables is a possible */
/* frame name. Look up each of these candidate names. */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Attempt to fetch the right hand side value for */
/* the Ith kernel variable found on the previous */
/* GNPOOL call. */
gcpool_(kvbuff + (((i__2 = i__ - 1) < 100 && 0 <= i__2 ? i__2 :
s_rnge("kvbuff", i__2, "kplfrm_", (ftnlen)523)) << 5), &
c__1, &c__1, &m, frname, &found, (ftnlen)32, (ftnlen)32);
if (found) {
/* We found a possible frame name. Attempt to look */
/* up an ID code variable for the name. The assignment */
/* for the ID code, if present, will have the form */
/* FRAME_<name> = <ID code> */
/* Create the kernel variable name on the left hand */
/* side of the assignment. */
s_copy(kvcode, "FRAME_<name>", (ftnlen)32, (ftnlen)12);
repmc_(kvcode, "<name>", frname, kvcode, (ftnlen)32, (ftnlen)
6, (ftnlen)32, (ftnlen)32);
/* Try to fetch the ID code. */
gipool_(kvcode, &c__1, &c__1, &l, &idcode, &found, (ftnlen)32)
;
if (found) {
/* We found an integer on the right hand side */
/* of the assignment. We probably have a */
/* frame specification at this point. Check that */
/* the variable */
/* FRAME_<ID code>_NAME */
/* is present in the kernel pool and maps to */
/* the name FRNAME. */
s_copy(kvname, "FRAME_<code>_NAME", (ftnlen)32, (ftnlen)
17);
repmi_(kvname, "<code>", &idcode, kvname, (ftnlen)32, (
ftnlen)6, (ftnlen)32);
gcpool_(kvname, &c__1, &c__1, &w, tmpnam, &found, (ftnlen)
32, (ftnlen)32);
if (found) {
/* Try to look up the frame class using a */
/* kernel variable name of the form */
/* FRAME_<integer ID code>_CLASS */
/* Create the kernel variable name on the left */
/* hand side of the frame class assignment. */
s_copy(kvclas, "FRAME_<integer>_CLASS", (ftnlen)32, (
ftnlen)21);
repmi_(kvclas, "<integer>", &idcode, kvclas, (ftnlen)
32, (ftnlen)9, (ftnlen)32);
/* Look for the frame class. */
gipool_(kvclas, &c__1, &c__1, &w, &fclass, &found, (
ftnlen)32);
if (! found) {
/* Try to look up the frame class using a kernel */
/* variable name of the form */
/* FRAME_<frame name>_CLASS */
s_copy(kvclas, "FRAME_<name>_CLASS", (ftnlen)32, (
ftnlen)18);
repmc_(kvclas, "<name>", frname, kvclas, (ftnlen)
32, (ftnlen)6, (ftnlen)32, (ftnlen)32);
gipool_(kvclas, &c__1, &c__1, &w, &fclass, &found,
(ftnlen)32);
}
/* At this point FOUND indicates whether we found */
/* the frame class. */
if (found) {
/* Check whether the frame class is one */
/* we want. */
if (*frmcls == -1 || *frmcls == fclass) {
/* We have a winner. Add it to the output set. */
/* First make sure the set is large enough to */
/* hold another element. */
if (to == sizei_(idset)) {
setmsg_("Frame ID set argument IDSET has"
" size #; required size is at lea"
"st #. Make sure that the caller "
"of this routine has initialized "
"IDSET via SSIZEI.", (ftnlen)144);
i__2 = sizei_(idset);
errint_("#", &i__2, (ftnlen)1);
i__2 = to + 1;
errint_("#", &i__2, (ftnlen)1);
sigerr_("SPICE(SETTOOSMALL)", (ftnlen)18);
chkout_("KPLFRM", (ftnlen)6);
return 0;
}
++to;
idset[to + 5] = idcode;
}
/* End of IF block for processing a frame having */
/* a frame class matching the request. */
}
/* End of IF block for finding the frame class. */
}
/* End of IF block for finding the frame name. */
}
/* End of IF block for finding the frame ID. */
}
/* End of IF block for finding string value corresponding to */
/* the Ith kernel variable matching the name template. */
}
/* End of loop for processing last batch of potential */
/* frame names. */
/* Fetch next batch of potential frame names. */
i__1 = n + 1;
gnpool_(kvtemp, &i__1, &c__100, &n, kvbuff, &found, (ftnlen)32, (
ftnlen)32);
}
/* At this point all kernel variables that matched the frame name */
/* keyword template have been processed. All frames of the specified */
/* class or classes have had their ID codes appended to IDSET. In */
/* general IDSET is not yet a SPICELIB set, since it's not sorted */
/* and it may contain duplicate values. */
/* Turn IDSET into a set. VALIDI sorts and removes duplicates. */
i__1 = sizei_(idset);
validi_(&i__1, &to, idset);
chkout_("KPLFRM", (ftnlen)6);
return 0;
} /* kplfrm_ */
/* $Procedure CHCKDO ( Check presence of required input parameters ) */
/* Subroutine */ int chckdo_(char *indtvl, integer *outtvl, integer *param,
integer *nparam, char *doval, ftnlen indtvl_len, ftnlen doval_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer l;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen), repmc_(char *, char *, char *, char *, ftnlen,
ftnlen, ftnlen, ftnlen);
logical found;
extern integer rtrim_(char *, ftnlen), isrchi_(integer *, integer *,
integer *);
extern logical return_(void);
char errlin[512];
extern /* Subroutine */ int setmsg_(char *, ftnlen), sigerr_(char *,
ftnlen), inssub_(char *, char *, integer *, char *, ftnlen,
ftnlen, ftnlen), chkout_(char *, ftnlen);
/* $ Abstract */
/* This routine is a module of the MKSPK program. It checks whether */
/* set of input parameters specified in the DATA_ORDER value */
/* contains all parameters required for a given input data type and */
/* output SPK type. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* MKSPK User's Guide */
/* $ Keywords */
/* None. */
/* $ Declarations */
/* $ Abstract */
/* MKSPK Include File. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Author_and_Institution */
/* N.G. Khavenson (IKI RAS, Russia) */
/* B.V. Semenov (NAIF, JPL) */
/* $ Version */
/* - Version 1.3.0, 08-FEB-2012 (BVS). */
/* Added TLE coverage and ID keywords. Added default TLE pad */
/* parameter. */
/* - Version 1.2.0, 16-JAN-2008 (BVS). */
/* Added ETTMWR parameter */
/* - Version 1.1.0, 05-JUN-2001 (BVS). */
/* Added MAXDEG parameter. */
/* - Version 1.0.4, 21-MAR-2001 (BVS). */
/* Added parameter for command line flag '-append' indicating */
/* that appending to an existing output file was requested. */
/* Added corresponding setup file keyword ('APPEND_TO_OUTPUT'.) */
/* Added parameters for yes and no values of this keyword. */
/* - Version 1.0.3, 28-JAN-2000 (BVS). */
/* Added parameter specifying number of supported input data */
/* types and parameter specifying number of supported output SPK */
/* types */
/* - Version 1.0.2, 22-NOV-1999 (NGK). */
/* Added parameters for two-line elements processing. */
/* - Version 1.0.1, 18-MAR-1999 (BVS). */
/* Added usage, help and template displays. Corrected comments. */
/* - Version 1.0.0, 8-SEP-1998 (NGK). */
/* -& */
/* Begin Include Section: MKSPK generic parameters. */
/* Maximum number of states allowed per one segment. */
/* String size allocation parameters */
/* Length of buffer for input text processing */
/* Length of a input text line */
/* Length of file name and comment line */
/* Length of string for keyword value processing */
/* Length of string for word processing */
/* Length of data order parameters string */
/* Length of string reserved as delimiter */
/* Numbers of different parameters */
/* Maximum number of allowed comment lines. */
/* Reserved number of input parameters */
/* Full number of delimiters */
/* Number of delimiters that may appear in time string */
/* Command line flags */
/* Setup file keywords reserved values */
/* Standard YES and NO values for setup file keywords. */
/* Number of supported input data types and input DATA TYPE */
/* reserved values. */
/* Number of supported output SPK data types -- this version */
/* supports SPK types 5, 8, 9, 10, 12, 13, 15 and 17. */
/* End of input record marker */
/* Maximum allowed polynomial degree. The value of this parameter */
/* is consistent with the ones in SPKW* routines. */
/* Special time wrapper tag for input times given as ET seconds past */
/* J2000 */
/* Default TLE pad, 1/2 day in seconds. */
/* End Include Section: MKSPK generic parameters. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* INDTVL I Input data type. */
/* OUTTVL I Output spk type. */
/* PARAM I Array of DATA_ORDER parameter IDs */
/* NPARAM I Number of not zero parameter IDs in PARAM */
/* DOVAL I Array of parameter values acceptable in DATA_ORDER */
/* $ Detailed_Input */
/* INDTVL is the input data type. See MKSPK.INC for the */
/* current list of supported input data types. */
/* OUTTVL is the output SPK type. Currently supported output */
/* SPK types are 5, 8, 9, 12, 13, 15 and 17. */
/* PARAM is an integer array containing indexes of the */
/* recognizable input parameters present in the */
/* DATA_ORDER keyword value in the order in which they */
/* were provided in that value. */
/* NPARAM is the number of elements in PARAM. */
/* DOVAL is an array containing complete set recognizable */
/* input parameters. (see main module for the current */
/* list) */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* If the set of input parameters does not contain some of the */
/* required tokens, then the error 'SPICE(MISSINGDATAORDERTK)' */
/* will be signalled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.G. Khavenson (IKI RAS, Russia) */
/* B.V. Semenov (NAIF, JPL) */
/* $ Version */
/* - Version 1.0.3, 29-MAR-1999 (NGK). */
/* Added comments. */
/* - Version 1.0.2, 18-MAR-1999 (BVS). */
/* Corrected comments. */
/* - Version 1.0.1, 13-JAN-1999 (BVS). */
/* Modified error messages. */
/* - Version 1.0.0, 08-SEP-1998 (NGK). */
/* -& */
/* $ Index_Entries */
/* Check adequacy of the DATA_ORDER defined in MKSPK setup */
/* -& */
/* SPICELIB functions */
/* Parameters INELTP, INSTTP, INEQTP containing supported */
/* input data type names and keyword parameter KDATOR are declared */
/* in the include file. */
/* Local variables */
/* Error line variable. Size LINLEN declared in the include file. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("CHCKDO", (ftnlen)6);
}
/* Check if EPOCH is present among specified input parameters. */
if (isrchi_(&c__1, nparam, param) == 0) {
setmsg_("Set of input data parameters specified in the setup file ke"
"yword '#' must contain token '#' designating epoch position "
"in the input data records.", (ftnlen)145);
errch_("#", "DATA_ORDER", (ftnlen)1, (ftnlen)10);
errch_("#", doval, (ftnlen)1, doval_len);
sigerr_("SPICE(MISSINGEPOCHTOKEN)", (ftnlen)24);
}
/* Check whether all necessary input parameters are present */
/* according to the input data type. */
found = TRUE_;
s_copy(errlin, "The following token(s) designating input parameter(s) re"
"quired when input data type is '#' is(are) missing in the value "
"of the setup file keyword '#':", (ftnlen)512, (ftnlen)150);
if (s_cmp(indtvl, "ELEMENTS", rtrim_(indtvl, indtvl_len), (ftnlen)8) == 0)
{
/* Input type is ELEMENTS. Check whether eccentricity, */
/* inclination, argument of periapsis and longitude of ascending */
/* node are present in the input data. */
repmc_(errlin, "#", "ELEMENTS", errlin, (ftnlen)512, (ftnlen)1, (
ftnlen)8, (ftnlen)512);
repmc_(errlin, "#", "DATA_ORDER", errlin, (ftnlen)512, (ftnlen)1, (
ftnlen)10, (ftnlen)512);
if (isrchi_(&c__9, nparam, param) == 0) {
i__1 = rtrim_(errlin, (ftnlen)512) + 1;
inssub_(errlin, " '#',", &i__1, errlin, (ftnlen)512, (ftnlen)5, (
ftnlen)512);
repmc_(errlin, "#", doval + (doval_len << 3), errlin, (ftnlen)512,
(ftnlen)1, doval_len, (ftnlen)512);
found = FALSE_;
}
for (l = 13; l <= 15; ++l) {
if (isrchi_(&l, nparam, param) == 0) {
i__1 = rtrim_(errlin, (ftnlen)512) + 1;
inssub_(errlin, " '#',", &i__1, errlin, (ftnlen)512, (ftnlen)
5, (ftnlen)512);
repmc_(errlin, "#", doval + (l - 1) * doval_len, errlin, (
ftnlen)512, (ftnlen)1, doval_len, (ftnlen)512);
found = FALSE_;
}
}
} else if (s_cmp(indtvl, "STATES", rtrim_(indtvl, indtvl_len), (ftnlen)6)
== 0) {
/* Input type is STATES. Check whether all state vector */
/* components are present in the input data. */
repmc_(errlin, "#", "STATES", errlin, (ftnlen)512, (ftnlen)1, (ftnlen)
6, (ftnlen)512);
repmc_(errlin, "#", "DATA_ORDER", errlin, (ftnlen)512, (ftnlen)1, (
ftnlen)10, (ftnlen)512);
for (l = 2; l <= 7; ++l) {
if (isrchi_(&l, nparam, param) == 0) {
i__1 = rtrim_(errlin, (ftnlen)512) + 1;
inssub_(errlin, " '#',", &i__1, errlin, (ftnlen)512, (ftnlen)
5, (ftnlen)512);
repmc_(errlin, "#", doval + (l - 1) * doval_len, errlin, (
ftnlen)512, (ftnlen)1, doval_len, (ftnlen)512);
found = FALSE_;
}
}
} else if (s_cmp(indtvl, "EQ_ELEMENTS", rtrim_(indtvl, indtvl_len), (
ftnlen)11) == 0) {
/* Input type is EQ_ELEMENTS. Check whether all equinoctial */
/* elements are present in the input data. */
repmc_(errlin, "#", "EQ_ELEMENTS", errlin, (ftnlen)512, (ftnlen)1, (
ftnlen)11, (ftnlen)512);
repmc_(errlin, "#", "DATA_ORDER", errlin, (ftnlen)512, (ftnlen)1, (
ftnlen)10, (ftnlen)512);
for (l = 21; l <= 29; ++l) {
if (isrchi_(&l, nparam, param) == 0) {
i__1 = rtrim_(errlin, (ftnlen)512) + 1;
inssub_(errlin, " '#',", &i__1, errlin, (ftnlen)512, (ftnlen)
5, (ftnlen)512);
repmc_(errlin, "#", doval + (l - 1) * doval_len, errlin, (
ftnlen)512, (ftnlen)1, doval_len, (ftnlen)512);
found = FALSE_;
}
}
}
/* Signal the error if any of the required parameters wasn't found. */
if (! found) {
i__1 = rtrim_(errlin, (ftnlen)512) - 1;
s_copy(errlin + i__1, ".", rtrim_(errlin, (ftnlen)512) - i__1, (
ftnlen)1);
setmsg_(errlin, (ftnlen)512);
sigerr_("SPICE(MISSINGDATAORDERTK)", (ftnlen)25);
}
/* Check whether all necessary input parameters are present */
/* according to the output SPK type. */
found = TRUE_;
if (*outtvl == 17) {
/* Output type is 17. Verify if dM/dt, dNOD/dt, dPER/dt */
/* exist in input data. */
s_copy(errlin, "The following token(s) designating input parameter(s"
") required when output SPK type is 17 is(are) missing in the"
" value of the setup file keyword '#':", (ftnlen)512, (ftnlen)
149);
for (l = 27; l <= 29; ++l) {
if (isrchi_(&l, nparam, param) == 0) {
i__1 = rtrim_(errlin, (ftnlen)512) + 1;
inssub_(errlin, " '#',", &i__1, errlin, (ftnlen)512, (ftnlen)
5, (ftnlen)512);
repmc_(errlin, "#", doval + (l - 1) * doval_len, errlin, (
ftnlen)512, (ftnlen)1, doval_len, (ftnlen)512);
found = FALSE_;
}
}
}
/* Signal the error if any of the required parameters wasn't found. */
if (! found) {
i__1 = rtrim_(errlin, (ftnlen)512) - 1;
s_copy(errlin + i__1, ".", rtrim_(errlin, (ftnlen)512) - i__1, (
ftnlen)1);
setmsg_(errlin, (ftnlen)512);
sigerr_("SPICE(MISSINGDATAORDERTK)", (ftnlen)25);
}
chkout_("CHCKDO", (ftnlen)6);
return 0;
} /* chckdo_ */
/* $Procedure ZZSPKAP1 ( S/P Kernel, apparent state ) */
/* Subroutine */ int zzspkap1_(integer *targ, doublereal *et, char *ref,
doublereal *sobs, char *abcorr, doublereal *starg, doublereal *lt,
ftnlen ref_len, ftnlen abcorr_len)
{
/* Initialized data */
static logical first = TRUE_;
static char flags[5*9] = "NONE " "LT " "LT+S " "CN " "CN+S " "XLT "
"XLT+S" "XCN " "XCN+S";
static char prvcor[5] = " ";
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char corr[5];
extern /* Subroutine */ int zzspksb1_(integer *, doublereal *, char *,
doublereal *, ftnlen);
static logical xmit;
extern /* Subroutine */ int vequ_(doublereal *, doublereal *);
integer i__, refid;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen), moved_(doublereal *, integer *, doublereal *);
static logical usecn;
doublereal sapos[3];
extern /* Subroutine */ int vsubg_(doublereal *, doublereal *, integer *,
doublereal *);
static logical uselt;
extern doublereal vnorm_(doublereal *), clight_(void);
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int stelab_(doublereal *, doublereal *,
doublereal *), sigerr_(char *, ftnlen), chkout_(char *, ftnlen),
stlabx_(doublereal *, doublereal *, doublereal *);
integer ltsign;
extern /* Subroutine */ int ljucrs_(integer *, char *, char *, ftnlen,
ftnlen), setmsg_(char *, ftnlen);
doublereal tstate[6];
integer maxitr;
extern /* Subroutine */ int irfnum_(char *, integer *, ftnlen);
extern logical return_(void);
static logical usestl;
extern logical odd_(integer *);
/* $ Abstract */
/* Deprecated: This routine has been superseded by SPKAPS. This */
/* routine is supported for purposes of backward compatibility only. */
/* Return the state (position and velocity) of a target body */
/* relative to an observer, optionally corrected for light time and */
/* stellar aberration. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* SPK */
/* $ Keywords */
/* EPHEMERIS */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* TARG I Target body. */
/* ET I Observer epoch. */
/* REF I Inertial reference frame of observer's state. */
/* SOBS I State of observer wrt. solar system barycenter. */
/* ABCORR I Aberration correction flag. */
/* STARG O State of target. */
/* LT O One way light time between observer and target. */
/* $ Detailed_Input */
/* TARG is the NAIF ID code for a target body. The target */
/* and observer define a state vector whose position */
/* component points from the observer to the target. */
/* ET is the ephemeris time, expressed as seconds past J2000 */
/* TDB, at which the state of the target body relative to */
/* the observer is to be computed. ET refers to time at */
/* the observer's location. */
/* REF is the inertial reference frame with respect to which */
/* the observer's state SOBS is expressed. REF must be */
/* recognized by the SPICE Toolkit. The acceptable */
/* frames are listed in the Frames Required Reading, as */
/* well as in the SPICELIB routine CHGIRF. */
/* Case and blanks are not significant in the string REF. */
/* SOBS is the geometric (uncorrected) state of the observer */
/* relative to the solar system barycenter at epoch ET. */
/* SOBS is a 6-vector: the first three components of */
/* SOBS represent a Cartesian position vector; the last */
/* three components represent the corresponding velocity */
/* vector. SOBS is expressed relative to the inertial */
/* reference frame designated by REF. */
/* Units are always km and km/sec. */
/* ABCORR indicates the aberration corrections to be applied */
/* to the state of the target body to account for one-way */
/* light time and stellar aberration. See the discussion */
/* in the Particulars section for recommendations on */
/* how to choose aberration corrections. */
/* ABCORR may be any of the following: */
/* 'NONE' Apply no correction. Return the */
/* geometric state of the target body */
/* relative to the observer. */
/* The following values of ABCORR apply to the */
/* "reception" case in which photons depart from the */
/* target's location at the light-time corrected epoch */
/* ET-LT and *arrive* at the observer's location at ET: */
/* 'LT' Correct for one-way light time (also */
/* called "planetary aberration") using a */
/* Newtonian formulation. This correction */
/* yields the state of the target at the */
/* moment it emitted photons arriving at */
/* the observer at ET. */
/* The light time correction involves */
/* iterative solution of the light time */
/* equation (see Particulars for details). */
/* The solution invoked by the 'LT' option */
/* uses one iteration. */
/* 'LT+S' Correct for one-way light time and */
/* stellar aberration using a Newtonian */
/* formulation. This option modifies the */
/* state obtained with the 'LT' option to */
/* account for the observer's velocity */
/* relative to the solar system */
/* barycenter. The result is the apparent */
/* state of the target---the position and */
/* velocity of the target as seen by the */
/* observer. */
/* 'CN' Converged Newtonian light time */
/* correction. In solving the light time */
/* equation, the 'CN' correction iterates */
/* until the solution converges (three */
/* iterations on all supported platforms). */
/* Whether the 'CN+S' solution is */
/* substantially more accurate than the */
/* 'LT' solution depends on the geometry */
/* of the participating objects and on the */
/* accuracy of the input data. In all */
/* cases this routine will execute more */
/* slowly when a converged solution is */
/* computed. See the Particulars section */
/* of SPKEZR for a discussion of precision */
/* of light time corrections. */
/* 'CN+S' Converged Newtonian light time */
/* correction and stellar aberration */
/* correction. */
/* The following values of ABCORR apply to the */
/* "transmission" case in which photons *depart* from */
/* the observer's location at ET and arrive at the */
/* target's location at the light-time corrected epoch */
/* ET+LT: */
/* 'XLT' "Transmission" case: correct for */
/* one-way light time using a Newtonian */
/* formulation. This correction yields the */
/* state of the target at the moment it */
/* receives photons emitted from the */
/* observer's location at ET. */
/* 'XLT+S' "Transmission" case: correct for */
/* one-way light time and stellar */
/* aberration using a Newtonian */
/* formulation This option modifies the */
/* state obtained with the 'XLT' option to */
/* account for the observer's velocity */
/* relative to the solar system */
/* barycenter. The position component of */
/* the computed target state indicates the */
/* direction that photons emitted from the */
/* observer's location must be "aimed" to */
/* hit the target. */
/* 'XCN' "Transmission" case: converged */
/* Newtonian light time correction. */
/* 'XCN+S' "Transmission" case: converged */
/* Newtonian light time correction and */
/* stellar aberration correction. */
/* Neither special nor general relativistic effects are */
/* accounted for in the aberration corrections applied */
/* by this routine. */
/* Case and blanks are not significant in the string */
/* ABCORR. */
/* $ Detailed_Output */
/* STARG is a Cartesian state vector representing the position */
/* and velocity of the target body relative to the */
/* specified observer. STARG is corrected for the */
/* specified aberrations, and is expressed with respect */
/* to the specified inertial reference frame. The first */
/* three components of STARG represent the x-, y- and */
/* z-components of the target's position; last three */
/* components form the corresponding velocity vector. */
/* The position component of STARG points from the */
/* observer's location at ET to the aberration-corrected */
/* location of the target. Note that the sense of the */
/* position vector is independent of the direction of */
/* radiation travel implied by the aberration */
/* correction. */
/* The velocity component of STARG is obtained by */
/* evaluating the target's geometric state at the light */
/* time corrected epoch, so for aberration-corrected */
/* states, the velocity is not precisely equal to the */
/* time derivative of the position. */
/* Units are always km and km/sec. */
/* LT is the one-way light time between the observer and */
/* target in seconds. If the target state is corrected */
/* for aberrations, then LT is the one-way light time */
/* between the observer and the light time corrected */
/* target location. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the value of ABCORR is not recognized, the error */
/* 'SPICE(SPKINVALIDOPTION)' is signaled. */
/* 2) If the reference frame requested is not a recognized */
/* inertial reference frame, the error 'SPICE(BADFRAME)' */
/* is signaled. */
/* 3) If the state of the target relative to the solar system */
/* barycenter cannot be computed, the error will be diagnosed */
/* by routines in the call tree of this routine. */
/* $ Files */
/* This routine computes states using SPK files that have been */
/* loaded into the SPICE system, normally via the kernel loading */
/* interface routine FURNSH. Application programs typically load */
/* kernels once before this routine is called, for example during */
/* program initialization; kernels need not be loaded repeatedly. */
/* See the routine FURNSH and the SPK and KERNEL Required Reading */
/* for further information on loading (and unloading) kernels. */
/* If any of the ephemeris data used to compute STARG are expressed */
/* relative to a non-inertial frame in the SPK files providing those */
/* data, additional kernels may be needed to enable the reference */
/* frame transformations required to compute the state. Normally */
/* these additional kernels are PCK files or frame kernels. Any */
/* such kernels must already be loaded at the time this routine is */
/* called. */
/* $ Particulars */
/* In space science or engineering applications one frequently */
/* wishes to know where to point a remote sensing instrument, such */
/* as an optical camera or radio antenna, in order to observe or */
/* otherwise receive radiation from a target. This pointing problem */
/* is complicated by the finite speed of light: one needs to point */
/* to where the target appears to be as opposed to where it actually */
/* is at the epoch of observation. We use the adjectives */
/* "geometric," "uncorrected," or "true" to refer to an actual */
/* position or state of a target at a specified epoch. When a */
/* geometric position or state vector is modified to reflect how it */
/* appears to an observer, we describe that vector by any of the */
/* terms "apparent," "corrected," "aberration corrected," or "light */
/* time and stellar aberration corrected." */
/* The SPICE Toolkit can correct for two phenomena affecting the */
/* apparent location of an object: one-way light time (also called */
/* "planetary aberration") and stellar aberration. Correcting for */
/* one-way light time is done by computing, given an observer and */
/* observation epoch, where a target was when the observed photons */
/* departed the target's location. The vector from the observer to */
/* this computed target location is called a "light time corrected" */
/* vector. The light time correction depends on the motion of the */
/* target, but it is independent of the velocity of the observer */
/* relative to the solar system barycenter. Relativistic effects */
/* such as light bending and gravitational delay are not accounted */
/* for in the light time correction performed by this routine. */
/* The velocity of the observer also affects the apparent location */
/* of a target: photons arriving at the observer are subject to a */
/* "raindrop effect" whereby their velocity relative to the observer */
/* is, using a Newtonian approximation, the photons' velocity */
/* relative to the solar system barycenter minus the velocity of the */
/* observer relative to the solar system barycenter. This effect is */
/* called "stellar aberration." Stellar aberration is independent */
/* of the velocity of the target. The stellar aberration formula */
/* used by this routine is non-relativistic. */
/* Stellar aberration corrections are applied after light time */
/* corrections: the light time corrected target position vector is */
/* used as an input to the stellar aberration correction. */
/* When light time and stellar aberration corrections are both */
/* applied to a geometric position vector, the resulting position */
/* vector indicates where the target "appears to be" from the */
/* observer's location. */
/* As opposed to computing the apparent position of a target, one */
/* may wish to compute the pointing direction required for */
/* transmission of photons to the target. This requires correction */
/* of the geometric target position for the effects of light time and */
/* stellar aberration, but in this case the corrections are computed */
/* for radiation traveling from the observer to the target. */
/* The "transmission" light time correction yields the target's */
/* location as it will be when photons emitted from the observer's */
/* location at ET arrive at the target. The transmission stellar */
/* aberration correction is the inverse of the traditional stellar */
/* aberration correction: it indicates the direction in which */
/* radiation should be emitted so that, using a Newtonian */
/* approximation, the sum of the velocity of the radiation relative */
/* to the observer and of the observer's velocity, relative to the */
/* solar system barycenter, yields a velocity vector that points in */
/* the direction of the light time corrected position of the target. */
/* The traditional aberration corrections applicable to observation */
/* and those applicable to transmission are related in a simple way: */
/* one may picture the geometry of the "transmission" case by */
/* imagining the "observation" case running in reverse time order, */
/* and vice versa. */
/* One may reasonably object to using the term "observer" in the */
/* transmission case, in which radiation is emitted from the */
/* observer's location. The terminology was retained for */
/* consistency with earlier documentation. */
/* Below, we indicate the aberration corrections to use for some */
/* common applications: */
/* 1) Find the apparent direction of a target for a remote-sensing */
/* observation. */
/* Use 'LT+S' or 'CN+S: apply both light time and stellar */
/* aberration corrections. */
/* Note that using light time corrections alone ('LT' or 'CN') */
/* is generally not a good way to obtain an approximation to */
/* an apparent target vector: since light time and stellar */
/* aberration corrections often partially cancel each other, */
/* it may be more accurate to use no correction at all than to */
/* use light time alone. */
/* 2) Find the corrected pointing direction to radiate a signal */
/* to a target. This computation is often applicable for */
/* implementing communications sessions. */
/* Use 'XLT+S' or 'XCN+S: apply both light time and stellar */
/* aberration corrections for transmission. */
/* 3) Compute the apparent position of a target body relative */
/* to a star or other distant object. */
/* Use 'LT', 'CN', 'LT+S', or 'CN+S' as needed to match the */
/* correction applied to the position of the distant */
/* object. For example, if a star position is obtained from */
/* a catalog, the position vector may not be corrected for */
/* stellar aberration. In this case, to find the angular */
/* separation of the star and the limb of a planet, the */
/* vector from the observer to the planet should be */
/* corrected for light time but not stellar aberration. */
/* 4) Obtain an uncorrected state vector derived directly from */
/* data in an SPK file. */
/* Use 'NONE'. */
/* C */
/* 5) Use a geometric state vector as a low-accuracy estimate */
/* of the apparent state for an application where execution */
/* speed is critical: */
/* Use 'NONE'. */
/* 6) While this routine cannot perform the relativistic */
/* aberration corrections required to compute states */
/* with the highest possible accuracy, it can supply the */
/* geometric states required as inputs to these computations: */
/* Use 'NONE', then apply high-accuracy aberration */
/* corrections (not available in the SPICE Toolkit). */
/* Below, we discuss in more detail how the aberration corrections */
/* applied by this routine are computed. */
/* Geometric case */
/* ============== */
/* SPKAPP begins by computing the geometric position T(ET) of the */
/* target body relative to the solar system barycenter (SSB). */
/* Subtracting the geometric position of the observer O(ET) gives */
/* the geometric position of the target body relative to the */
/* observer. The one-way light time, LT, is given by */
/* | T(ET) - O(ET) | */
/* LT = ------------------- */
/* c */
/* The geometric relationship between the observer, target, and */
/* solar system barycenter is as shown: */
/* SSB ---> O(ET) */
/* | / */
/* | / */
/* | / */
/* | / T(ET) - O(ET) */
/* V V */
/* T(ET) */
/* The returned state consists of the position vector */
/* T(ET) - O(ET) */
/* and a velocity obtained by taking the difference of the */
/* corresponding velocities. In the geometric case, the */
/* returned velocity is actually the time derivative of the */
/* position. */
/* Reception case */
/* ============== */
/* When any of the options 'LT', 'CN', 'LT+S', 'CN+S' is */
/* selected, SPKAPP computes the position of the target body at */
/* epoch ET-LT, where LT is the one-way light time. Let T(t) and */
/* O(t) represent the positions of the target and observer */
/* relative to the solar system barycenter at time t; then LT is */
/* the solution of the light-time equation */
/* | T(ET-LT) - O(ET) | */
/* LT = ------------------------ (1) */
/* c */
/* The ratio */
/* | T(ET) - O(ET) | */
/* --------------------- (2) */
/* c */
/* is used as a first approximation to LT; inserting (2) into the */
/* RHS of the light-time equation (1) yields the "one-iteration" */
/* estimate of the one-way light time. Repeating the process */
/* until the estimates of LT converge yields the "converged */
/* Newtonian" light time estimate. */
/* Subtracting the geometric position of the observer O(ET) gives */
/* the position of the target body relative to the observer: */
/* T(ET-LT) - O(ET). */
/* SSB ---> O(ET) */
/* | \ | */
/* | \ | */
/* | \ | T(ET-LT) - O(ET) */
/* | \ | */
/* V V V */
/* T(ET) T(ET-LT) */
/* The position component of the light-time corrected state */
/* is the vector */
/* T(ET-LT) - O(ET) */
/* The velocity component of the light-time corrected state */
/* is the difference */
/* T_vel(ET-LT) - O_vel(ET) */
/* where T_vel and O_vel are, respectively, the velocities of */
/* the target and observer relative to the solar system */
/* barycenter at the epochs ET-LT and ET. */
/* If correction for stellar aberration is requested, the target */
/* position is rotated toward the solar system barycenter- */
/* relative velocity vector of the observer. The rotation is */
/* computed as follows: */
/* Let r be the light time corrected vector from the observer */
/* to the object, and v be the velocity of the observer with */
/* respect to the solar system barycenter. Let w be the angle */
/* between them. The aberration angle phi is given by */
/* sin(phi) = v sin(w) / c */
/* Let h be the vector given by the cross product */
/* h = r X v */
/* Rotate r by phi radians about h to obtain the apparent */
/* position of the object. */
/* The velocity component of the output state STARG is */
/* not corrected for stellar aberration. */
/* Transmission case */
/* ================== */
/* When any of the options 'XLT', 'XCN', 'XLT+S', 'XCN+S' are */
/* selected, SPKAPP computes the position of the target body T at */
/* epoch ET+LT, where LT is the one-way light time. LT is the */
/* solution of the light-time equation */
/* | T(ET+LT) - O(ET) | */
/* LT = ------------------------ (3) */
/* c */
/* Subtracting the geometric position of the observer, O(ET), */
/* gives the position of the target body relative to the */
/* observer: T(ET-LT) - O(ET). */
/* SSB --> O(ET) */
/* / | * */
/* / | * T(ET+LT) - O(ET) */
/* / |* */
/* / *| */
/* V V V */
/* T(ET+LT) T(ET) */
/* The position component of the light-time corrected state */
/* is the vector */
/* T(ET+LT) - O(ET) */
/* The velocity component of the light-time corrected state */
/* is the difference */
/* T_vel(ET+LT) - O_vel(ET) */
/* where T_vel and O_vel are, respectively, the velocities of */
/* the target and observer relative to the solar system */
/* barycenter at the epochs ET+LT and ET. */
/* If correction for stellar aberration is requested, the target */
/* position is rotated away from the solar system barycenter- */
/* relative velocity vector of the observer. The rotation is */
/* computed as in the reception case, but the sign of the */
/* rotation angle is negated. */
/* The velocity component of the output state STARG is */
/* not corrected for stellar aberration. */
/* Neither special nor general relativistic effects are accounted */
/* for in the aberration corrections performed by this routine. */
/* $ Examples */
/* In the following code fragment, SPKSSB and SPKAPP are used */
/* to display the position of Io (body 501) as seen from the */
/* Voyager 2 spacecraft (Body -32) at a series of epochs. */
/* Normally, one would call the high-level reader SPKEZR to obtain */
/* state vectors. The example below illustrates the interface */
/* of this routine but is not intended as a recommendation on */
/* how to use the SPICE SPK subsystem. */
/* The use of integer ID codes is necessitated by the low-level */
/* interface of this routine. */
/* IO = 501 */
/* VGR2 = -32 */
/* DO WHILE ( EPOCH .LE. END ) */
/* CALL SPKSSB ( VGR2, EPOCH, 'J2000', STVGR2 ) */
/* CALL SPKAPP ( IO, EPOCH, 'J2000', STVGR2, */
/* . 'LT+S', STIO, LT ) */
/* CALL RECRAD ( STIO, RANGE, RA, DEC ) */
/* WRITE (*,*) RA * DPR(), DEC * DPR() */
/* EPOCH = EPOCH + DELTA */
/* END DO */
/* $ Restrictions */
/* 1) The kernel files to be used by SPKAPP must be loaded */
/* (normally by the SPICELIB kernel loader FURNSH) before */
/* this routine is called. */
/* 2) Unlike most other SPK state computation routines, this */
/* routine requires that the input state be relative to an */
/* inertial reference frame. Non-inertial frames are not */
/* supported by this routine. */
/* 3) In a future version of this routine, the implementation */
/* of the aberration corrections may be enhanced to improve */
/* accuracy. */
/* $ Literature_References */
/* SPK Required Reading. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* B.V. Semenov (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 3.1.0, 04-JUL-2014 (NJB) (BVS) */
/* Discussion of light time corrections was updated. Assertions */
/* that converged light time corrections are unlikely to be */
/* useful were removed. */
/* Last update was 21-SEP-2013 (BVS) */
/* Updated to call LJUCRS instead of CMPRSS/UCASE. */
/* - SPICELIB Version 3.0.3, 18-MAY-2010 (BVS) */
/* Index lines now state that this routine is deprecated. */
/* - SPICELIB Version 3.0.2, 08-JAN-2008 (NJB) */
/* The Abstract section of the header was updated to */
/* indicate that this routine has been deprecated. */
/* - SPICELIB Version 3.0.1, 20-OCT-2003 (EDW) */
/* Added mention that LT returns in seconds. */
/* Corrected spelling errors. */
/* - SPICELIB Version 3.0.0, 18-DEC-2001 (NJB) */
/* Updated to handle aberration corrections for transmission */
/* of radiation. Formerly, only the reception case was */
/* supported. The header was revised and expanded to explain */
/* the functionality of this routine in more detail. */
/* - SPICELIB Version 2.1.0, 09-JUL-1996 (WLT) */
/* Corrected the description of LT in the Detailed Output */
/* section of the header. */
/* - SPICELIB Version 2.0.0, 22-MAY-1995 (WLT) */
/* The routine was modified to support the options 'CN' and */
/* 'CN+S' aberration corrections. Moreover, diagnostics were */
/* added to check for reference frames that are not recognized */
/* inertial frames. */
/* - SPICELIB Version 1.1.2, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.1.1, 06-MAR-1991 (JML) */
/* In the example program, the calling sequence of SPKAPP */
/* was corrected. */
/* - SPICELIB Version 1.1.0, 25-MAY-1990 (HAN) */
/* The local variable CORR was added to eliminate a */
/* run-time error that occurred when SPKAPP was determining */
/* what corrections to apply to the state. */
/* - SPICELIB Version 1.0.1, 22-MAR-1990 (HAN) */
/* Literature references added to the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) */
/* -& */
/* $ Index_Entries */
/* DEPRECATED low-level aberration correction */
/* DEPRECATED apparent state from spk file */
/* DEPRECATED get apparent state */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 22-MAY-1995 (WLT) */
/* The routine was modified to support the options 'CN' and */
/* 'CN+S' aberration corrections. Moreover, diagnostics were */
/* added to check for reference frames that are not recognized */
/* inertial frames. */
/* - SPICELIB Version 1.1.1, 06-MAR-1991 (JML) */
/* In the example program, the calling sequence of SPKAPP */
/* was corrected. */
/* - SPICELIB Version 1.1.0, 25-MAY-1990 (HAN) */
/* The local variable CORR was added to eliminate a run-time */
/* error that occurred when SPKAPP was determining what */
/* corrections to apply to the state. If the literal string */
/* 'LT' was assigned to ABCORR, SPKAPP attempted to look at */
/* ABCORR(3:4). Because ABCORR is a passed length argument, its */
/* length is not guaranteed, and those positions may not exist. */
/* Searching beyond the bounds of a string resulted in a */
/* run-time error at NAIF because NAIF compiles SPICELIB using the */
/* CHECK=BOUNDS option for the DEC VAX/VMX DCL FORTRAN command. */
/* Also, without the local variable CORR, SPKAPP would have to */
/* modify the value of a passed argument, ABCORR. That's a no no. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Indices of flags in the FLAGS array: */
/* Local variables */
/* Saved variables */
/* Initial values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZSPKAP1", (ftnlen)8);
}
if (first || s_cmp(abcorr, prvcor, abcorr_len, (ftnlen)5) != 0) {
/* The aberration correction flag differs from the value it */
/* had on the previous call, if any. Analyze the new flag. */
/* Remove leading and embedded white space from the aberration */
/* correction flag and convert to upper case. */
ljucrs_(&c__0, abcorr, corr, abcorr_len, (ftnlen)5);
/* Locate the flag in our list of flags. */
i__ = isrchc_(corr, &c__9, flags, (ftnlen)5, (ftnlen)5);
if (i__ == 0) {
setmsg_("Requested aberration correction # is not supported.", (
ftnlen)51);
errch_("#", abcorr, (ftnlen)1, abcorr_len);
sigerr_("SPICE(SPKINVALIDOPTION)", (ftnlen)23);
chkout_("ZZSPKAP1", (ftnlen)8);
return 0;
}
/* The aberration correction flag is recognized; save it. */
s_copy(prvcor, abcorr, (ftnlen)5, abcorr_len);
/* Set logical flags indicating the attributes of the requested */
/* correction. */
xmit = i__ > 5;
uselt = i__ == 2 || i__ == 3 || i__ == 6 || i__ == 7;
usestl = i__ > 1 && odd_(&i__);
usecn = i__ == 4 || i__ == 5 || i__ == 8 || i__ == 9;
first = FALSE_;
}
/* See if the reference frame is a recognized inertial frame. */
irfnum_(ref, &refid, ref_len);
if (refid == 0) {
setmsg_("The requested frame '#' is not a recognized inertial frame. "
, (ftnlen)60);
errch_("#", ref, (ftnlen)1, ref_len);
sigerr_("SPICE(BADFRAME)", (ftnlen)15);
chkout_("ZZSPKAP1", (ftnlen)8);
return 0;
}
/* Determine the sign of the light time offset. */
if (xmit) {
ltsign = 1;
} else {
ltsign = -1;
}
/* Find the geometric state of the target body with respect to the */
/* solar system barycenter. Subtract the state of the observer */
/* to get the relative state. Use this to compute the one-way */
/* light time. */
zzspksb1_(targ, et, ref, starg, ref_len);
vsubg_(starg, sobs, &c__6, tstate);
moved_(tstate, &c__6, starg);
*lt = vnorm_(starg) / clight_();
/* To correct for light time, find the state of the target body */
/* at the current epoch minus the one-way light time. Note that */
/* the observer remains where he is. */
if (uselt) {
maxitr = 1;
} else if (usecn) {
maxitr = 3;
} else {
maxitr = 0;
}
i__1 = maxitr;
for (i__ = 1; i__ <= i__1; ++i__) {
d__1 = *et + ltsign * *lt;
zzspksb1_(targ, &d__1, ref, starg, ref_len);
vsubg_(starg, sobs, &c__6, tstate);
moved_(tstate, &c__6, starg);
*lt = vnorm_(starg) / clight_();
}
/* At this point, STARG contains the light time corrected */
/* state of the target relative to the observer. */
/* If stellar aberration correction is requested, perform it now. */
/* Stellar aberration corrections are not applied to the target's */
/* velocity. */
if (usestl) {
if (xmit) {
/* This is the transmission case. */
/* Compute the position vector obtained by applying */
/* "reception" stellar aberration to STARG. */
stlabx_(starg, &sobs[3], sapos);
vequ_(sapos, starg);
} else {
/* This is the reception case. */
/* Compute the position vector obtained by applying */
/* "reception" stellar aberration to STARG. */
stelab_(starg, &sobs[3], sapos);
vequ_(sapos, starg);
}
}
chkout_("ZZSPKAP1", (ftnlen)8);
return 0;
} /* zzspkap1_ */
/* $Procedure SYDIMI ( Return the dimension of a symbol ) */
integer sydimi_(char *name__, char *tabsym, integer *tabptr, integer *tabval,
ftnlen name_len, ftnlen tabsym_len)
{
/* System generated locals */
integer ret_val;
/* Local variables */
integer nsym;
extern integer cardc_(char *, ftnlen);
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern integer bsrchc_(char *, integer *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int chkout_(char *, ftnlen);
integer locsym;
extern logical return_(void);
/* $ Abstract */
/* Return the dimension of a particular symbol in an integer symbol */
/* table. If the symbol is not found, the function returns the */
/* value zero. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* SYMBOLS */
/* $ Keywords */
/* SYMBOLS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* NAME I Name of the symbol whose dimension is desired. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL I/O Components of the symbol table. */
/* The function returns the dimension of the symbol NAME. If NAME is */
/* not in the symbol table, the function returns the value zero. */
/* $ Detailed_Input */
/* NAME is the name of the symbol whose dimension is to be */
/* returned. If the symbol is not in the symbol table, the */
/* function returns the value zero. This function is case */
/* sensitive, NAME must match a symbol exactly. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL are the components of an integer symbol table. */
/* The table may or may not contain the symbol NAME. */
/* $ Detailed_Output */
/* The function returns the dimension of the symbol NAME. The */
/* dimension of a symbol is the number of values associated with */
/* that symbol. If NAME is not in the symbol table, the function */
/* returns the value zero. */
/* $ Parameters */
/* None. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* The contents of the symbol table are: */
/* books --> 5 */
/* 8 */
/* erasers --> 6 */
/* pencils --> 12 */
/* pens --> 10 */
/* 12 */
/* 24 */
/* Let NUMVAL be equal to the dimension of the symbols in the table. */
/* The following code returns the values of NUMVAL indicated in the */
/* table. */
/* NUMVAL = SYDIMI ( 'books', TABSYM, TABPTR, TABVAL ) */
/* NUMVAL = SYDIMI ( 'pencils', TABSYM, TABPTR, TABVAL ) */
/* NUMVAL = SYDIMI ( 'pens', TABSYM, TABPTR, TABVAL ) */
/* NUMVAL = SYDIMI ( 'erasers', TABSYM, TABPTR, TABVAL ) */
/* NUMVAL = SYDIMI ( 'tablets', TABSYM, TABPTR, TABVAL ) */
/* ----SYMBOL----------NUMVAL------ */
/* | books | 2 | */
/* | pencils | 1 | */
/* | pens | 3 | */
/* | erasers | 1 | */
/* | tablets | 0 | */
/* -------------------------------- */
/* Note that the dimension of "tablets" is zero. This is due to the */
/* fact that "tablets" is not in the symbol table. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.0, 17-MAY-1994 (HAN) */
/* If the value of the function RETURN is TRUE upon execution of */
/* this module, this function is assigned a default value of */
/* either 0, 0.0D0, .FALSE., or blank depending on the type of */
/* the function. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) (HAN) */
/* -& */
/* $ Index_Entries */
/* fetch the dimension of a symbol */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling */
if (return_()) {
ret_val = 0;
return ret_val;
} else {
chkin_("SYDIMI", (ftnlen)6);
}
/* How many symbols to start with? */
nsym = cardc_(tabsym, tabsym_len);
/* Is this symbol even in the table? */
locsym = bsrchc_(name__, &nsym, tabsym + tabsym_len * 6, name_len,
tabsym_len);
/* If it's not in the table, return zero. Otherwise, look up */
/* the dimension directly. */
if (locsym == 0) {
ret_val = 0;
} else {
ret_val = tabptr[locsym + 5];
}
chkout_("SYDIMI", (ftnlen)6);
return ret_val;
} /* sydimi_ */
