/* $Procedure MTXMG ( Matrix transpose times matrix, general dimension ) */
/* Subroutine */ int mtxmg_(doublereal *m1, doublereal *m2, integer *nc1,
integer *nr1r2, integer *nc2, doublereal *mout)
{
/* System generated locals */
integer m1_dim1, m1_dim2, m1_offset, m2_dim1, m2_dim2, m2_offset,
mout_dim1, mout_dim2, mout_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, k;
/* $ Abstract */
/* Multiply the transpose of a matrix with another matrix, */
/* both of arbitrary size. (The dimensions of the matrices must be */
/* compatible with this multiplication.) */
/* $ 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 */
/* MATRIX */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* M1 I Left-hand matrix whose transpose is to be */
/* multiplied. */
/* M2 I Right-hand matrix to be multiplied. */
/* NC1 I Column dimension of M1 and row dimension of */
/* MOUT. */
/* NR1R2 I Row dimension of M1 and row dimension of M2. */
/* NC2 I Column dimension of M2 and column dimension of */
/* MOUT. */
/* MOUT O Product matrix M1**T * M2. */
/* MOUT must NOT overwrite either M1 or M2. */
/* $ Detailed_Input */
/* M1 This is an double precision matrix of arbitrary dimension */
/* whose transpose is the left hand multiplier of a matrix */
/* multiplication. */
/* M2 This is an double precision matrix of arbitrary dimension */
/* whose transpose is the left hand multiplier of a matrix */
/* multiplication. */
/* NC1 This is the column dimension of M1 and row dimension of */
/* MOUT. */
/* NR1R2 This is the row dimension of both M1 and M2. */
/* NC2 This is the column dimension of both M2 and MOUT. */
/* $ Detailed_Output */
/* MOUT is a double precision matrix containing the product */
/* T */
/* MOUT = (M1) x (M2) */
/* where the superscript T denotes the transpose of M1. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* The code reflects precisely the following mathematical expression */
/* For each value of the subscript I from 1 to NC1, and J from 1 */
/* to NC2: */
/* MOUT(I,J) = Summation from K=1 to NR1R2 of ( M1(K,I) * M2(K,J) ) */
/* Note that the reversal of the K and I subscripts in the left-hand */
/* matrix M1 is what makes MOUT the product of the TRANSPOSE of M1 */
/* and not simply of M1 itself. */
/* Since this subroutine operates on matrices of arbitrary size, it */
/* is not possible to buffer intermediate results. Thus, MOUT */
/* should NOT overwrite either M1 or M2. */
/* $ Examples */
/* Suppose that M1 = | 1 2 3 0 | */
/* | 1 1 1 1 | */
/* and that M2 = | 1 2 3 | */
/* | 0 0 0 | */
/* Then calling MTXMG according to the following calling sequence */
/* CALL MTXMG (M1, M2, 4, 2, 3, MOUT) */
/* will yield the following value for MOUT */
/* | 1 2 3 | */
/* MOUT = | 2 4 6 | */
/* | 3 6 9 | */
/* | 0 0 0 | */
/* $ Restrictions */
/* 1) The user is responsible for checking the magnitudes of the */
/* elements of M1 and M2 so that a floating point overflow does */
/* not occur. */
/* 2) MOUT must not overwrite M1 or M2 or else the intermediate */
/* will affect the final result. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.M. Owen (JPL) */
/* $ Literature_References */
/* None */
/* $ 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 (WMO) */
/* -& */
/* $ Index_Entries */
/* matrix_transpose times matrix n-dimensional_case */
/* -& */
/* $ Revisions */
/* - Beta Version 1.1.0, 16-FEB-1989 (NJB) */
/* Contents of the Exceptions section was changed */
/* to "error free" to reflect the decision that the */
/* module will never participate in error handling. */
/* Declaration of unused variable SUM removed. */
/* -& */
/* Perform the matrix multiplication */
/* Parameter adjustments */
m1_dim1 = *nr1r2;
m1_dim2 = *nc1;
m1_offset = m1_dim1 + 1;
mout_dim1 = *nc1;
mout_dim2 = *nc2;
mout_offset = mout_dim1 + 1;
m2_dim1 = *nr1r2;
m2_dim2 = *nc2;
m2_offset = m2_dim1 + 1;
/* Function Body */
i__1 = *nc1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *nc2;
for (j = 1; j <= i__2; ++j) {
mout[(i__3 = i__ + j * mout_dim1 - mout_offset) < mout_dim1 *
mout_dim2 && 0 <= i__3 ? i__3 : s_rnge("mout", i__3,
"mtxmg_", (ftnlen)196)] = 0.;
i__3 = *nr1r2;
for (k = 1; k <= i__3; ++k) {
mout[(i__4 = i__ + j * mout_dim1 - mout_offset) < mout_dim1 *
mout_dim2 && 0 <= i__4 ? i__4 : s_rnge("mout", i__4,
"mtxmg_", (ftnlen)198)] = mout[(i__5 = i__ + j *
mout_dim1 - mout_offset) < mout_dim1 * mout_dim2 && 0
<= i__5 ? i__5 : s_rnge("mout", i__5, "mtxmg_", (
ftnlen)198)] + m1[(i__6 = k + i__ * m1_dim1 -
m1_offset) < m1_dim1 * m1_dim2 && 0 <= i__6 ? i__6 :
s_rnge("m1", i__6, "mtxmg_", (ftnlen)198)] * m2[(i__7
= k + j * m2_dim1 - m2_offset) < m2_dim1 * m2_dim2 &&
0 <= i__7 ? i__7 : s_rnge("m2", i__7, "mtxmg_", (
ftnlen)198)];
}
}
}
return 0;
} /* mtxmg_ */
/* $Procedure M2YEAR ( Determine whether or not a word is a year ) */
logical m2year_(char *word, ftnlen word_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer i__1, i__2, i__3, i__4;
logical ret_val;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
static integer i__, value;
extern integer ltrim_(char *, ftnlen);
static integer i1, i2, i3, i4, length, values[256];
extern integer qrtrim_(char *, ftnlen);
/* $ Abstract */
/* This function is true if the input string is a year in the */
/* sense of META/2. */
/* $ 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 */
/* META/2 a language specification language. */
/* $ Keywords */
/* ALPHANUMERIC */
/* ASCII */
/* PARSING */
/* UTILITY */
/* WORD */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* WORD I A character string word */
/* The function is returned as .TRUE. if word is a META/2 year. */
/* $ Detailed_Input */
/* WORD is a character string that is assumed to have no */
/* spaces between the first and last non-blank characters. */
/* $ Detailed_Output */
/* M2YEAR returns as .TRUE. if WORD is a META/2 year. */
/* Otherwise it is returned .FALSE. */
/* $ Error_Handling */
/* None. */
/* C */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Particulars */
/* This is a utility routine for the subroutine META2. It */
/* determines whether or not a word is a year in the sense */
/* of the language META/2. */
/* $ Examples */
/* WORD M2YEAR */
/* ------- ------ */
/* SPAM .FALSE. */
/* 1 .TRUE. */
/* 0.289E19 .FALSE. */
/* 0.2728D12 .FALSE. */
/* -12.1892e-5 .FALSE. */
/* 12.E29 .FALSE. */
/* 12.E291 .FALSE. */
/* 1.2E10 .TRUE. */
/* .E12 .FALSE. */
/* 1.2E.12 .FALSE. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - META/2 Configured Version 2.1.0, 29-DEC-1994 (WLT) */
/* The computation of the length of the input string */
/* was incorrect. It has been fixed. It used to be */
/* LENGTH = I3 - I1 + 1 */
/* Now it is */
/* LENGTH = I4 - I1 + 1 */
/* - META/2 Configured Version 2.0.0, 9-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 9, 1994 */
/* - META/2 Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of META/2 */
/* software as of May 3, 1994 */
/* Version B1.0.0, 22-MAR-1988 (WLT) (IMU) */
/* -& */
/* SPICELIB functions */
/* Local variables */
if (first) {
first = FALSE_;
/* We will construct a value for the string by taking */
/* the non-blank portion and computing the value assuming */
/* that the first non-blank is a digit with the appropriate */
/* power of 10 attached. Since all non-digit characters */
/* will have values of 1000, we will get a value greater */
/* than 1000 if any non-digit characters are present. */
for (i__ = 0; i__ <= 255; ++i__) {
values[(i__1 = i__) < 256 && 0 <= i__1 ? i__1 : s_rnge("values",
i__1, "m2year_", (ftnlen)182)] = 10000;
}
values[(i__1 = '0') < 256 && 0 <= i__1 ? i__1 : s_rnge("values", i__1,
"m2year_", (ftnlen)185)] = 0;
values[(i__1 = '1') < 256 && 0 <= i__1 ? i__1 : s_rnge("values", i__1,
"m2year_", (ftnlen)186)] = 1;
values[(i__1 = '2') < 256 && 0 <= i__1 ? i__1 : s_rnge("values", i__1,
"m2year_", (ftnlen)187)] = 2;
values[(i__1 = '3') < 256 && 0 <= i__1 ? i__1 : s_rnge("values", i__1,
"m2year_", (ftnlen)188)] = 3;
values[(i__1 = '4') < 256 && 0 <= i__1 ? i__1 : s_rnge("values", i__1,
"m2year_", (ftnlen)189)] = 4;
values[(i__1 = '5') < 256 && 0 <= i__1 ? i__1 : s_rnge("values", i__1,
"m2year_", (ftnlen)190)] = 5;
values[(i__1 = '6') < 256 && 0 <= i__1 ? i__1 : s_rnge("values", i__1,
"m2year_", (ftnlen)191)] = 6;
values[(i__1 = '7') < 256 && 0 <= i__1 ? i__1 : s_rnge("values", i__1,
"m2year_", (ftnlen)192)] = 7;
values[(i__1 = '8') < 256 && 0 <= i__1 ? i__1 : s_rnge("values", i__1,
"m2year_", (ftnlen)193)] = 8;
values[(i__1 = '9') < 256 && 0 <= i__1 ? i__1 : s_rnge("values", i__1,
"m2year_", (ftnlen)194)] = 9;
}
/* Make sure the string has the right length. */
i1 = ltrim_(word, word_len);
i4 = qrtrim_(word, word_len);
length = i4 - i1 + 1;
/* Rule out the goofy cases that NPARSD will allow. */
if (length != 4) {
value = 10000;
} else {
i2 = i1 + 1;
i3 = i2 + 1;
value = values[(i__1 = *(unsigned char *)&word[i1 - 1]) < 256 && 0 <=
i__1 ? i__1 : s_rnge("values", i__1, "m2year_", (ftnlen)218)]
* 1000 + values[(i__2 = *(unsigned char *)&word[i2 - 1]) <
256 && 0 <= i__2 ? i__2 : s_rnge("values", i__2, "m2year_", (
ftnlen)218)] * 100 + values[(i__3 = *(unsigned char *)&word[
i3 - 1]) < 256 && 0 <= i__3 ? i__3 : s_rnge("values", i__3,
"m2year_", (ftnlen)218)] * 10 + values[(i__4 = *(unsigned
char *)&word[i4 - 1]) < 256 && 0 <= i__4 ? i__4 : s_rnge(
"values", i__4, "m2year_", (ftnlen)218)];
}
/* That's all just make sure that the value is within the */
/* bound required of a year. */
ret_val = value >= 1000 && value <= 3000;
return ret_val;
} /* m2year_ */
/* $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 VTMVG ( Vector transpose times matrix times vector ) */
doublereal vtmvg_(doublereal *v1, doublereal *matrix, doublereal *v2, integer
*nrow, integer *ncol)
{
/* System generated locals */
integer v1_dim1, matrix_dim1, matrix_dim2, matrix_offset, v2_dim1, i__1,
i__2, i__3, i__4, i__5;
doublereal ret_val;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
integer k, l;
/* $ Abstract */
/* Multiply the transpose of a n-dimensional column vector, */
/* a nxm matrix, and a m-dimensional column vector. */
/* $ 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 */
/* MATRIX, VECTOR */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* V1 I N-dimensional double precision column vector. */
/* MATRIX I NxM double precision matrix. */
/* V2 I M-dimensional double porecision column vector. */
/* NROW I Number of rows in MATRIX (number of rows in V1.) */
/* NCOL I Number of columns in MATRIX (number of rows in */
/* V2.) */
/* The function returns the result of (V1**T * MATRIX * V2 ). */
/* $ Detailed_Input */
/* V1 is an n-dimensional double precision vector. */
/* MATRIX is an n x m double precision matrix. */
/* V2 is an m-dimensional double precision vector. */
/* NROW is the number of rows in MATRIX. This is also */
/* equivalent to the number of rows in the vector V1. */
/* NCOL is the number of columns in MATRIX. This is also */
/* equivalent to the number of rows in the vector V2. */
/* $ Detailed_Output */
/* The function returns the double precision value of the equation */
/* (V1**T * MATRIX * V2 ). */
/* Notice that VTMVG is actually the dot product of the vector */
/* resulting from multiplying the transpose of V1 and MATRIX and the */
/* vector V2. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* This routine implements the following vector/matrix/vector */
/* multiplication: */
/* T */
/* VTMVG = [ V1 ] | | | | */
/* | MATRIX | |V2| */
/* | | | | */
/* by calculating over all values of the indices K and L from 1 to */
/* NROW and 1 to NCOL, respectively, the expression */
/* VTMVG = Summation of ( V1(K)*MATRIX(K,L)*V2(L) ) . */
/* V1 is a column vector which becomes a row vector when transposed. */
/* V2 is a column vector. */
/* No checking is performed to determine whether floating point */
/* overflow has occurred. */
/* $ Examples */
/* If V1 = | 1.0D0 | MATRIX = | 2.0D0 0.0D0 | V2 = | 1.0D0 | */
/* | | | | | | */
/* | 2.0D0 | | 1.0D0 2.0D0 | | 2.0D0 | */
/* | | | | */
/* | 3.0D0 | | 1.0D0 1.0D0 | */
/* NROW = 3 */
/* NCOL = 2 */
/* then the value of the function is 21.0D0. */
/* $ Restrictions */
/* Since no error detection or recovery is implemented, the */
/* programmer is required to insure that the inputs to this routine */
/* are both valid and within the proper range. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Author_and_Institution */
/* W.M. Owen (JPL) */
/* $ Literature_References */
/* None. */
/* $ 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 (WMO) */
/* -& */
/* $ Index_Entries */
/* n-dimensional vector_transpose times matrix times vector */
/* -& */
/* Perform the multiplication */
/* Parameter adjustments */
v1_dim1 = *nrow;
v2_dim1 = *ncol;
matrix_dim1 = *nrow;
matrix_dim2 = *ncol;
matrix_offset = matrix_dim1 + 1;
/* Function Body */
ret_val = 0.;
i__1 = *nrow;
for (k = 1; k <= i__1; ++k) {
i__2 = *ncol;
for (l = 1; l <= i__2; ++l) {
ret_val += v1[(i__3 = k - 1) < v1_dim1 && 0 <= i__3 ? i__3 :
s_rnge("v1", i__3, "vtmvg_", (ftnlen)171)] * matrix[(i__4
= k + l * matrix_dim1 - matrix_offset) < matrix_dim1 *
matrix_dim2 && 0 <= i__4 ? i__4 : s_rnge("matrix", i__4,
"vtmvg_", (ftnlen)171)] * v2[(i__5 = l - 1) < v2_dim1 &&
0 <= i__5 ? i__5 : s_rnge("v2", i__5, "vtmvg_", (ftnlen)
171)];
}
}
return ret_val;
} /* vtmvg_ */
/* $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 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 ETCAL ( Convert ET to Calendar format ) */
/* Subroutine */ int etcal_(doublereal *et, char *string, ftnlen string_len)
{
/* Initialized data */
static logical first = TRUE_;
static integer extra[12] = { 0,0,1,1,1,1,1,1,1,1,1,1 };
static integer dpjan0[12] = { 0,31,59,90,120,151,181,212,243,273,304,334 }
;
static integer dpbegl[12] = { 0,31,60,91,121,152,182,213,244,274,305,335 }
;
static char months[3*12] = "JAN" "FEB" "MAR" "APR" "MAY" "JUN" "JUL"
"AUG" "SEP" "OCT" "NOV" "DEC";
/* System generated locals */
address a__1[12];
integer i__1, i__2, i__3[12];
doublereal d__1;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
double d_int(doublereal *);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
/* Local variables */
static integer dn2000;
static doublereal dp2000, frac;
static char date[180];
static doublereal remd, secs;
static integer year, mins;
static char dstr[16], hstr[16], mstr[16], sstr[16], ystr[16];
static doublereal halfd, q;
static integer tsecs, dofyr, month, hours;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
static doublereal mynum;
static integer bh, bm, iq;
static doublereal secspd;
static char messge[16];
static integer offset;
static doublereal dmnint;
static logical adjust;
static integer daynum;
extern integer intmin_(void), intmax_(void);
extern /* Subroutine */ int dpstrf_(doublereal *, integer *, char *, char
*, ftnlen, ftnlen);
static doublereal dmxint, mydnom;
extern /* Subroutine */ int cmprss_(char *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen);
extern integer lstlti_(integer *, integer *, integer *);
extern /* Subroutine */ int intstr_(integer *, char *, ftnlen);
static integer yr1, yr4;
static char era[16];
static integer day, rem;
extern doublereal spd_(void);
static integer yr100, yr400;
/* $ Abstract */
/* Convert from an ephemeris epoch measured in seconds past */
/* the epoch of J2000 to a calendar string format using a */
/* formal calendar free of leapseconds. */
/* $ 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 */
/* TIME */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* ET I Ephemeris time measured in seconds past J2000. */
/* STRING O A standard calendar representation of ET. */
/* $ Detailed_Input */
/* ET is an epoch measured in ephemeris seconds */
/* past the epoch of J2000. */
/* $ Detailed_Output */
/* STRING is a calendar string representing the input ephemeris */
/* epoch. This string is based upon extending the */
/* Gregorian Calendar backward and forward indefinitely */
/* keeping the same rules for determining leap years. */
/* Moreover, there is no accounting for leapseconds. */
/* To be sure that all of the date can be stored in */
/* STRING, it should be declared to have length at */
/* least 48 characters. */
/* The string will have the following format */
/* year (era) mon day hr:mn:sc.sss */
/* Where: */
/* year --- is the year */
/* era --- is the chronological era associated with */
/* the date. For years after 999 A.D. */
/* the era is omitted. For years */
/* between 1 A.D. and 999 A.D. (inclusive) */
/* era is the string 'A.D.' For epochs */
/* before 1 A.D. Jan 1 00:00:00, era is */
/* given as 'B.C.' and the year is converted */
/* to years before the "Christian Era". */
/* The last B.C. epoch is */
/* 1 B.C. DEC 31 23:59:59.999 */
/* The first A.D. epoch (which occurs .001 */
/* seconds after the last B.C. epoch) is: */
/* 1 A.D. JAN 1 00:00:00.000 */
/* Note: there is no year 0 A.D. or 0 B.C. */
/* mon --- is a 3-letter abbreviation for the month */
/* in all capital letters. */
/* day --- is the day of the month */
/* hr --- is the hour of the day (between 0 and 23) */
/* leading zeros are added to hr if the */
/* numeric value is less than 10. */
/* mn --- is the minute of the hour (0 to 59) */
/* leading zeros are added to mn if the */
/* numeric value is less than 10. */
/* sc.sss is the second of the minute to 3 decimal */
/* places ( 0 to 59.999). Leading zeros */
/* are added if the numeric value is less */
/* than 10. Seconds are truncated, not */
/* rounded. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* 1) If the input ET is so large that the corresponding */
/* number of days since 1 A.D. Jan 1, 00:00:00 is */
/* within 1 of overflowing or underflowing an integer, */
/* ET will not be converted to the correct string */
/* representation rather, the string returned will */
/* state that the epoch was before or after the day */
/* that is INTMIN +1 or INTMAX - 1 days after */
/* 1 A.D. Jan 1, 00:00:00. */
/* 2) If the output string is not sufficiently long to hold */
/* the full date, it will be truncated on the right. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This is an error free routine for converting ephemeris epochs */
/* represented as seconds past the J2000 epoch to formal */
/* calendar strings based upon the Gregorian Calendar. This formal */
/* time is often useful when one needs a human recognizable */
/* form of an ephemeris epoch. There is no accounting for leap */
/* seconds in the output times produced. */
/* Note: The calendar epochs produced are not the same as the */
/* UTC calendar epochs that correspond to ET. The strings */
/* produced by this routine may vary from the corresponding */
/* UTC epochs by more than 1 minute. */
/* This routine can be used in creating error messages or */
/* in routines and programs in which one prefers to report */
/* times without employing leapseconds to produce exact UTC */
/* epochs. */
/* $ Examples */
/* Suppose you wish to report that no data is */
/* available at a particular ephemeris epoch ET. The following */
/* code shows how you might accomplish this task. */
/* CALL DPSTRF ( ET, 6, 'F', ETSTR ) */
/* CALL ETCAL ( ET, STRING ) */
/* E1 = RTRIM ( STRING ) */
/* E2 = RTRIM ( ETSTR ) */
/* WRITE (*,*) 'There is no data available for the body ' */
/* WRITE (*,*) 'at requested time: ' */
/* WRITE (*,*) ' ', STRING(1:E1), ' (', ETSTR(1:E2), ')' */
/* $ Restrictions */
/* One must keep in mind when using this routine that */
/* ancient times are not based upon the Gregorian */
/* calendar. For example the 0 point of the Julian */
/* Date system is 4713 B.C. Jan 1, 12:00:00 on the Julian */
/* Calendar. If one formalized the Gregorian calendar */
/* and extended it indefinitely, the zero point of the Julian */
/* date system corresponds to 4714 B.C. NOV 24 12:00:00 on */
/* the Gregorian calendar. There are several reasons for this. */
/* Leap years in the Julian calendar occur every */
/* 4 years (including *all* centuries). Moreover, the */
/* Gregorian calendar "effectively" begins on 15 Oct, 1582 A.D. */
/* which is 5 Oct, 1582 A.D. in the Julian Calendar. */
/* Therefore you must be careful in your interpretation */
/* of ancient dates produced by this routine. */
/* $ Literature_References */
/* 1. "From Sundial to Atomic Clocks---Understanding Time and */
/* Frequency" by James Jespersen and Jane Fitz-Randolph */
/* Dover Publications, Inc. New York (1982). */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* K.R. Gehringer (JPL) */
/* $ Version */
/* - SPICELIB Version 2.2.0, 05-MAR-1998 (WLT) */
/* The documentation concerning the appearance of the output */
/* time string was corrected so that it does not suggest */
/* a comma is inserted after the day of the month. The */
/* comma was removed from the output string in Version 2.0.0 */
/* (see the note below) but the documentation was not upgraded */
/* accordingly. */
/* - SPICELIB Version 2.1.0, 20-MAY-1996 (WLT) */
/* Two arrays that were initialized but never used were */
/* removed. */
/* - SPICELIB Version 2.0.0, 16-AUG-1995 (KRG) */
/* If the day number was less than 10, the spacing was off for */
/* the rest of the time by one space, that for the "tens" digit. */
/* This has been fixed by using a leading zero when the number of */
/* days is < 10. */
/* Also, the comma that appeared between the month/day/year */
/* and the hour:minute:seconds tokens has been removed. This was */
/* done in order to make the calendar date format of ETCAL */
/* consistent with the calendar date format of ET2UTC. */
/* - SPICELIB Version 1.0.0, 14-DEC-1993 (WLT) */
/* -& */
/* $ Index_Entries */
/* Convert ephemeris time to a formal calendar date */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.1.0, 20-MAY-1996 (WLT) */
/* Two arrays that were initialized but never used were */
/* removed. */
/* - SPICELIB Version 2.0.0, 16-AUG-1995 (KRG) */
/* If the day number was less than 10, the spacing was off for */
/* the rest of the time by one space, that for the "tens" digit. */
/* This has been fixed byusing a leading zero when the number of */
/* days is < 10. */
/* Also, the comma that appeared between the month/day/year */
/* and the hour:minute:seconds tokens has been removed. This was */
/* done in order to make the calendar date format of ETCAL */
/* consistent with the calendar date format of ET2UTC. */
/* - SPICELIB Version 1.0.0, 14-DEC-1993 (WLT) */
/* -& */
/* Spicelib Functions. */
/* We declare the variables that contain the number of days in */
/* 400 years, 100 years, 4 years and 1 year. */
/* The following integers give the number of days during the */
/* associated month of a non-leap year. */
/* The integers that follow give the number of days in a normal */
/* year that precede the first of the month. */
/* The integers that follow give the number of days in a leap */
/* year that precede the first of the month. */
/* The variables below hold the components of the output string */
/* before they are put together. */
/* We will construct our string using the local variable DATE */
/* and transfer the results to the output STRING when we are */
/* done. */
/* MONTHS contains 3-letter abbreviations for the months of the year */
/* The array EXTRA contains the number of additional days that */
/* appear before the first of a month during a leap year (as opposed */
/* to a non-leap year). */
/* DPJAN0(I) gives the number of days that occur before the I'th */
/* month of a normal year. */
/* Definitions of statement functions. */
/* The number of days elapsed since Jan 1, of year 1 A.D. to */
/* Jan 1 of YEAR is given by: */
/* The number of leap days in a year is given by: */
/* To compute the day of the year we */
/* look up the number of days to the beginning of the month, */
/* add on the number leap days that occurred prior to that */
/* time */
/* add on the number of days into the month */
/* The number of days since 1 Jan 1 A.D. is given by: */
if (first) {
first = FALSE_;
halfd = spd_() / 2.;
secspd = spd_();
dn2000 = (c__2000 - 1) * 365 + (c__2000 - 1) / 4 - (c__2000 - 1) /
100 + (c__2000 - 1) / 400 + (dpjan0[(i__1 = c__1 - 1) < 12 &&
0 <= i__1 ? i__1 : s_rnge("dpjan0", i__1, "etcal_", (ftnlen)
571)] + extra[(i__2 = c__1 - 1) < 12 && 0 <= i__2 ? i__2 :
s_rnge("extra", i__2, "etcal_", (ftnlen)571)] * ((c__2000 / 4
<< 2) / c__2000 - c__2000 / 100 * 100 / c__2000 + c__2000 /
400 * 400 / c__2000) + c__1) - 1;
dmxint = (doublereal) intmax_();
dmnint = (doublereal) intmin_();
}
/* Now we "in-line" compute the following call. */
/* call rmaind ( et + halfd, secspd, dp2000, secs ) */
/* because we can't make a call to rmaind. */
/* The reader may wonder why we use et + halfd. The value */
/* et is seconds past the ephemeris epoch of J2000 which */
/* is at 2000 Jan 1, 12:00:00. We want to compute days past */
/* 2000 Jan 1, 00:00:00. The seconds past THAT epoch is et + halfd. */
/* We add on 0.0005 seconds so that the string produced will be */
/* rounded to the nearest millisecond. */
mydnom = secspd;
mynum = *et + halfd;
d__1 = mynum / mydnom;
q = d_int(&d__1);
remd = mynum - q * mydnom;
if (remd < 0.) {
q += -1.;
remd += mydnom;
}
secs = remd;
dp2000 = q;
/* Do something about the problem when ET is vastly */
/* out of range. (Day number outside MAX and MIN integer). */
if (dp2000 + dn2000 < dmnint + 1) {
dp2000 = dmnint - dn2000 + 1;
s_copy(messge, "Epoch before ", (ftnlen)16, (ftnlen)13);
secs = 0.;
} else if (dp2000 + dn2000 > dmxint - 1) {
dp2000 = dmxint - dn2000 - 1;
s_copy(messge, "Epoch after ", (ftnlen)16, (ftnlen)12);
secs = 0.;
} else {
s_copy(messge, " ", (ftnlen)16, (ftnlen)1);
}
/* Compute the number of days since 1 .A.D. Jan 1, 00:00:00. */
/* From the tests in the previous IF-ELSE IF-ELSE block this */
/* addition is guaranteed not to overflow. */
daynum = (integer) (dp2000 + (doublereal) dn2000);
/* If the number of days is negative, we need to do a little */
/* work so that we can represent the date in the B.C. era. */
/* We add enough multiples of 400 years so that the year will */
/* be positive and then we subtract off the appropriate multiple */
/* of 400 years later. */
if (daynum < 0) {
/* Since we can't make the call below and remain */
/* error free, we compute it ourselves. */
/* call rmaini ( daynum, dp400y, offset, daynum ) */
iq = daynum / 146097;
rem = daynum - iq * 146097;
if (rem < 0) {
--iq;
rem += 146097;
}
offset = iq;
daynum = rem;
adjust = TRUE_;
} else {
adjust = FALSE_;
}
/* Next we compute the year. Divide out multiples of 400, 100 */
/* 4 and 1 year. Finally combine these to get the correct */
/* value for year. (Note this is all integer arithmetic.) */
/* Recall that DP1Y = 365 */
/* DP4Y = 4*DPY + 1 */
/* DP100Y = 25*DP4Y - 1 */
/* DP400Y = 4*DP100Y + 1 */
yr400 = daynum / 146097;
rem = daynum - yr400 * 146097;
/* Computing MIN */
i__1 = 3, i__2 = rem / 36524;
yr100 = min(i__1,i__2);
rem -= yr100 * 36524;
/* Computing MIN */
i__1 = 24, i__2 = rem / 1461;
yr4 = min(i__1,i__2);
rem -= yr4 * 1461;
/* Computing MIN */
i__1 = 3, i__2 = rem / 365;
yr1 = min(i__1,i__2);
rem -= yr1 * 365;
dofyr = rem + 1;
year = yr400 * 400 + yr100 * 100 + (yr4 << 2) + yr1 + 1;
/* Get the month, and day of month (depending upon whether */
/* we have a leap year or not). */
if ((year / 4 << 2) / year - year / 100 * 100 / year + year / 400 * 400 /
year == 0) {
month = lstlti_(&dofyr, &c__12, dpjan0);
day = dofyr - dpjan0[(i__1 = month - 1) < 12 && 0 <= i__1 ? i__1 :
s_rnge("dpjan0", i__1, "etcal_", (ftnlen)698)];
} else {
month = lstlti_(&dofyr, &c__12, dpbegl);
day = dofyr - dpbegl[(i__1 = month - 1) < 12 && 0 <= i__1 ? i__1 :
s_rnge("dpbegl", i__1, "etcal_", (ftnlen)701)];
}
/* If we had to adjust the year to make it positive, we now */
/* need to correct it and then convert it to a B.C. year. */
if (adjust) {
year += offset * 400;
year = -year + 1;
s_copy(era, " B.C. ", (ftnlen)16, (ftnlen)6);
} else {
/* If the year is less than 1000, we can't just write it */
/* out. We need to add the era. If we don't do this */
/* the dates look very confusing. */
if (year < 1000) {
s_copy(era, " A.D. ", (ftnlen)16, (ftnlen)6);
} else {
s_copy(era, " ", (ftnlen)16, (ftnlen)1);
}
}
/* Convert Seconds to Hours, Minute and Seconds. */
/* We work with thousandths of a second in integer arithmetic */
/* so that all of the truncation work with seconds will already */
/* be done. (Note that we already know that SECS is greater than */
/* or equal to zero so we'll have no problems with HOURS, MINS */
/* or SECS becoming negative.) */
tsecs = (integer) (secs * 1e3);
frac = secs - (doublereal) tsecs;
hours = tsecs / 3600000;
tsecs -= hours * 3600000;
mins = tsecs / 60000;
tsecs -= mins * 60000;
secs = (doublereal) tsecs / 1e3;
/* We round seconds if we can do so without getting seconds to be */
/* bigger than 60. */
if (secs + 5e-4 < 60.) {
secs += 5e-4;
}
/* Finally, get the components of our date string. */
intstr_(&year, ystr, (ftnlen)16);
if (day >= 10) {
intstr_(&day, dstr, (ftnlen)16);
} else {
s_copy(dstr, "0", (ftnlen)16, (ftnlen)1);
intstr_(&day, dstr + 1, (ftnlen)15);
}
/* We want to zero pad the hours minutes and seconds. */
if (hours < 10) {
bh = 2;
} else {
bh = 1;
}
if (mins < 10) {
bm = 2;
} else {
bm = 1;
}
s_copy(mstr, "00", (ftnlen)16, (ftnlen)2);
s_copy(hstr, "00", (ftnlen)16, (ftnlen)2);
s_copy(sstr, " ", (ftnlen)16, (ftnlen)1);
/* Now construct the string components for hours, minutes and */
/* seconds. */
secs = (integer) (secs * 1e3) / 1e3;
intstr_(&hours, hstr + (bh - 1), 16 - (bh - 1));
intstr_(&mins, mstr + (bm - 1), 16 - (bm - 1));
dpstrf_(&secs, &c__6, "F", sstr, (ftnlen)1, (ftnlen)16);
/* The form of the output for SSTR has a leading blank followed by */
/* the first significant digit. If a decimal point is in the */
/* third slot, then SSTR is of the form ' x.xxxxx' and we need */
/* to insert a leading zero. */
if (*(unsigned char *)&sstr[2] == '.') {
*(unsigned char *)sstr = '0';
}
/* We don't want any leading spaces in SSTR, (HSTR and MSTR don't */
/* have leading spaces by construction. */
ljust_(sstr, sstr, (ftnlen)16, (ftnlen)16);
/* Now form the date string, squeeze out extra spaces and */
/* left justify the whole thing. */
/* Writing concatenation */
i__3[0] = 16, a__1[0] = messge;
i__3[1] = 16, a__1[1] = ystr;
i__3[2] = 16, a__1[2] = era;
i__3[3] = 3, a__1[3] = months + ((i__1 = month - 1) < 12 && 0 <= i__1 ?
i__1 : s_rnge("months", i__1, "etcal_", (ftnlen)810)) * 3;
i__3[4] = 1, a__1[4] = " ";
i__3[5] = 3, a__1[5] = dstr;
i__3[6] = 1, a__1[6] = " ";
i__3[7] = 2, a__1[7] = hstr;
i__3[8] = 1, a__1[8] = ":";
i__3[9] = 2, a__1[9] = mstr;
i__3[10] = 1, a__1[10] = ":";
i__3[11] = 6, a__1[11] = sstr;
s_cat(date, a__1, i__3, &c__12, (ftnlen)180);
cmprss_(" ", &c__1, date, date, (ftnlen)1, (ftnlen)180, (ftnlen)180);
ljust_(date, date, (ftnlen)180, (ftnlen)180);
s_copy(string, date, string_len, (ftnlen)180);
return 0;
} /* etcal_ */
/* $Procedure DELTET ( Delta ET, ET - UTC ) */
/* Subroutine */ int deltet_(doublereal *epoch, char *eptype, doublereal *
delta, ftnlen eptype_len)
{
/* Initialized data */
static char missed[20*5] = "DELTET/DELTA_T_A, # " "DELTET/K, # "
"DELTET/EB, # " "DELTET/M, # " "DELTET/DELTA_AT, "
"# ";
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
double d_nint(doublereal *), sin(doublereal);
/* Local variables */
char type__[4];
integer i__;
doublereal k, m[2];
integer n;
doublereal dleap[400] /* was [2][200] */;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer nleap;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen),
errch_(char *, char *, ftnlen, ftnlen);
doublereal leaps, ettai;
logical found[5];
char dtype[1];
doublereal ea, eb, ma, et;
extern /* Subroutine */ int gdpool_(char *, integer *, integer *, integer
*, doublereal *, logical *, ftnlen), sigerr_(char *, ftnlen),
chkout_(char *, ftnlen), dtpool_(char *, logical *, integer *,
char *, ftnlen, ftnlen), setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen);
extern logical return_(void);
doublereal dta, aet;
/* $ Abstract */
/* Return the value of Delta ET (ET-UTC) for an input epoch. */
/* $ 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 */
/* TIME */
/* KERNEL */
/* $ Keywords */
/* TIME */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* EPOCH I Input epoch (seconds past J2000). */
/* EPTYPE I Type of input epoch ('UTC' or 'ET'). */
/* DELTA O Delta ET (ET-UTC) at input epoch. */
/* $ Detailed_Input */
/* EPOCH is the epoch at which Delta ET is to be computed. */
/* This may be either UTC or ephemeris seconds past */
/* J2000, as specified by EPTYPE. */
/* EPTYPE indicates the type of input epoch. It may be either */
/* of the following: */
/* 'UTC' input is UTC seconds past J2000. */
/* 'ET' input is ephemeris seconds past J2000. */
/* $ Detailed_Output */
/* DELTA is the value of */
/* Delta ET = ET - UTC */
/* at the input epoch. This is added to UTC to give */
/* ET, or subtracted from ET to give UTC. The routine */
/* is reversible: that is, given the following calls, */
/* CALL DELTET ( UTC, 'UTC', DEL1 ) */
/* CALL DELTET ( UTC+DEL1, 'ET', DEL2 ) */
/* the expression */
/* ( DEL1 .EQ. DEL2 ) */
/* is always true. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the input epoch is not recognized, the error */
/* SPICE(INVALIDEPOCH) is signaled. */
/* 2) If the variables necessary for the computation of DELTA */
/* have not been loaded into the kernel pool, the error */
/* SPICE(KERNELVARNOTFOUND) is signaled. */
/* 3) If the number of leapseconds in the pool is greater than */
/* the local leapseconds buffer size, the error */
/* SPICE(BUFFEROVERFLOW) is signaled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The constants necessary for computing the offset are taken */
/* from the kernel pool, where they are assumed to have been */
/* loaded from a kernel file. */
/* The tables are consulted to determine the number of leap seconds */
/* preceding the input epoch. Also, an approximation to the periodic */
/* yearly variation (which has an amplitude of just under two */
/* milliseconds) in the difference between ET and TAI (Atomic Time) */
/* is computed. The final value of Delta ET is given by */
/* Delta ET = ( ET - TAI ) + leap seconds */
/* $ Examples */
/* The following example shows how DELTET may be used to convert */
/* from UTC seconds past J2000 to ephemeris seconds past J2000. */
/* CALL DELTET ( UTCSEC, 'UTC', DELTA ) */
/* ET = UTCSEC + DELTA */
/* The following example shows how DELTET may be used to convert */
/* from ephemeris seconds past J2000 to UTC seconds past J2000. */
/* CALL DELTET ( ET, 'ET', DELTA ) */
/* UTCSEC = ET - DELTA */
/* See the TIME required reading for further examples. */
/* $ Restrictions */
/* The routines UTC2ET and ET2UTC are preferred for conversions */
/* between UTC and ET. This routine is provided mainly as a utility */
/* for UTC2ET and ET2UTC. */
/* The kernel pool containing leapseconds and relativistic terms */
/* MUST be loaded prior to calling this subroutine. Examples */
/* demonstrating how to load a kernel pool are included in the */
/* Required Reading file time.req and in the "Examples" */
/* section of this header. For more general information about */
/* kernel pools, please consult the Required Reading file */
/* kernel.req. */
/* $ Literature_References */
/* Astronomical Almanac. */
/* $ Author_and_Institution */
/* W.M. Owen (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.2.2, 18-APR-2014 (BVS) */
/* Minor header edits. */
/* - SPICELIB Version 1.2.1, 18-MAY-2010 (BVS) */
/* Removed "C$" marker from text in the header. */
/* - SPICELIB Version 1.2.0, 24-AUG-1998 (WLT) */
/* The previous upgrade introduced an error in the fetch */
/* of the variable DELTET/M from the kernel pool. This */
/* error was corrected. */
/* - SPICELIB Version 1.1.0, 20-APR-1998 (NJB) */
/* Calls to RTPOOL were replaced with calls to GDPOOL, which */
/* does more robust error checking. Check for buffer overflow */
/* was added. Local declarations were re-organized. */
/* - 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 (WMO) (IMU) */
/* -& */
/* $ Index_Entries */
/* difference between ephemeris time and utc */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.2.0, 24-AUG-1998 (WLT) */
/* The previous upgrade introduced an error in the fetch */
/* of the variable DELTET/M from the kernel pool. This */
/* error was corrected. */
/* - SPICELIB Version 1.1.0, 20-APR-1998 (NJB) */
/* Calls to RTPOOL were replaced with calls to GDPOOL, which */
/* does more robust error checking. */
/* - Beta Version 1.1.0, 06-OCT-1988 (IMU) */
/* Tim Colvin of Rand noticed that times returned by UTC2ET */
/* and TPARSE differed by one second. Upon closer inspection, */
/* crack NAIF staff members deduced that in fact Mr. Colvin */
/* had not loaded the kernel pool, and were surprised to learn */
/* that no error had occurred. */
/* Multiple FOUND flags and a bevy of new error messages were */
/* implemented to cope with this unfortunate oversight. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Saved variables */
/* Initial values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("DELTET", (ftnlen)6);
}
/* Convert the epoch type to uppercase, to simplify comparisons. */
ucase_(eptype, type__, eptype_len, (ftnlen)4);
/* Extract the necessary constants from the kernel pool. */
/* Leap seconds and their epochs are interleaved in DELTA_AT. */
/* DLEAP(1,i) is the number of leap seconds at DLEAP(2,i) UTC */
/* seconds past J2000. */
gdpool_("DELTET/DELTA_T_A", &c__1, &c__1, &n, &dta, found, (ftnlen)16);
gdpool_("DELTET/K", &c__1, &c__1, &n, &k, &found[1], (ftnlen)8);
gdpool_("DELTET/EB", &c__1, &c__1, &n, &eb, &found[2], (ftnlen)9);
gdpool_("DELTET/M", &c__1, &c__2, &n, m, &found[3], (ftnlen)8);
/* Check that the number of leapseconds is not too great for our */
/* buffer size (not likely). */
dtpool_("DELTET/DELTA_AT", &found[4], &nleap, dtype, (ftnlen)15, (ftnlen)
1);
if (nleap > 400) {
setmsg_("Number of leapseconds, #, is greater than the number that c"
"an be buffered, #.", (ftnlen)77);
i__1 = nleap / 2;
errint_("#", &i__1, (ftnlen)1);
errint_("#", &c__200, (ftnlen)1);
sigerr_("SPICE(BUFFERTOOSMALL)", (ftnlen)21);
chkout_("DELTET", (ftnlen)6);
return 0;
}
gdpool_("DELTET/DELTA_AT", &c__1, &c__400, &nleap, dleap, &found[4], (
ftnlen)15);
nleap /= 2;
if (! (found[0] && found[1] && found[2] && found[3] && found[4])) {
setmsg_("The following, needed to compute Delta ET (ET - UTC), could"
" not be found in the kernel pool: #", (ftnlen)94);
for (i__ = 1; i__ <= 5; ++i__) {
if (! found[(i__1 = i__ - 1) < 5 && 0 <= i__1 ? i__1 : s_rnge(
"found", i__1, "deltet_", (ftnlen)341)]) {
errch_("#", missed + ((i__1 = i__ - 1) < 5 && 0 <= i__1 ?
i__1 : s_rnge("missed", i__1, "deltet_", (ftnlen)342))
* 20, (ftnlen)1, (ftnlen)20);
}
}
errch_(", #", ".", (ftnlen)3, (ftnlen)1);
sigerr_("SPICE(KERNELVARNOTFOUND)", (ftnlen)24);
chkout_("DELTET", (ftnlen)6);
return 0;
}
/* There are two separate quantities to be determined. First, */
/* the appropriate number of leap seconds. Second, the size of */
/* the periodic term ET-TAI. */
/* For epochs before the first leap second, return Delta ET at */
/* the epoch of the leap second minus one second. */
leaps = dleap[0] - 1;
/* When counting leap seconds for UTC epochs, we can compare */
/* directly against the values in DLEAP. */
if (s_cmp(type__, "UTC", (ftnlen)4, (ftnlen)3) == 0) {
i__1 = nleap;
for (i__ = 1; i__ <= i__1; ++i__) {
if (*epoch >= dleap[(i__2 = (i__ << 1) - 1) < 400 && 0 <= i__2 ?
i__2 : s_rnge("dleap", i__2, "deltet_", (ftnlen)375)]) {
leaps = dleap[(i__2 = (i__ << 1) - 2) < 400 && 0 <= i__2 ?
i__2 : s_rnge("dleap", i__2, "deltet_", (ftnlen)376)];
}
}
/* For ET epochs, things are a little tougher. In order to compare */
/* the input epoch against the epochs of the leap seconds, we need */
/* to compute ET-TAI at each of the leap epochs. To make sure that */
/* the computation is reversible, it is always done at the nearest */
/* ET second (the "approximate ET", or AET). */
/* There must be a hundred ways to do this more efficiently. */
/* For now, we'll settle for one that works. */
} else if (s_cmp(type__, "ET", (ftnlen)4, (ftnlen)2) == 0) {
i__1 = nleap;
for (i__ = 1; i__ <= i__1; ++i__) {
if (*epoch > dleap[(i__2 = (i__ << 1) - 1) < 400 && 0 <= i__2 ?
i__2 : s_rnge("dleap", i__2, "deltet_", (ftnlen)393)]) {
d__1 = dleap[(i__2 = (i__ << 1) - 1) < 400 && 0 <= i__2 ?
i__2 : s_rnge("dleap", i__2, "deltet_", (ftnlen)395)]
+ dta + dleap[(i__3 = (i__ << 1) - 2) < 400 && 0 <=
i__3 ? i__3 : s_rnge("dleap", i__3, "deltet_", (
ftnlen)395)];
aet = d_nint(&d__1);
ma = m[0] + m[1] * aet;
ea = ma + eb * sin(ma);
ettai = k * sin(ea);
et = dleap[(i__2 = (i__ << 1) - 1) < 400 && 0 <= i__2 ? i__2 :
s_rnge("dleap", i__2, "deltet_", (ftnlen)401)] + dta
+ dleap[(i__3 = (i__ << 1) - 2) < 400 && 0 <= i__3 ?
i__3 : s_rnge("dleap", i__3, "deltet_", (ftnlen)401)]
+ ettai;
if (*epoch >= et) {
leaps = dleap[(i__2 = (i__ << 1) - 2) < 400 && 0 <= i__2 ?
i__2 : s_rnge("dleap", i__2, "deltet_", (ftnlen)
404)];
}
}
}
/* Uh, those are the only choices. */
} else {
setmsg_("Epoch type was #", (ftnlen)16);
errch_("#", type__, (ftnlen)1, (ftnlen)4);
sigerr_("SPICE(INVALIDEPOCH)", (ftnlen)19);
chkout_("DELTET", (ftnlen)6);
return 0;
}
/* Add the constant offset, leap seconds, and the relativistic term */
/* (as before, computed at the nearest ET second). */
if (s_cmp(type__, "ET", (ftnlen)4, (ftnlen)2) == 0) {
aet = d_nint(epoch);
} else if (s_cmp(type__, "UTC", (ftnlen)4, (ftnlen)3) == 0) {
d__1 = *epoch + dta + leaps;
aet = d_nint(&d__1);
}
ma = m[0] + m[1] * aet;
ea = ma + eb * sin(ma);
ettai = k * sin(ea);
*delta = dta + leaps + ettai;
chkout_("DELTET", (ftnlen)6);
return 0;
} /* deltet_ */
/* $Procedure ZZEKNRES ( Private: EK, resolve names in encoded query ) */
/* Subroutine */ int zzeknres_(char *query, integer *eqryi, char *eqryc,
logical *error, char *errmsg, integer *errptr, ftnlen query_len,
ftnlen eqryc_len, ftnlen errmsg_len)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Local variables */
integer base, ntab, ncnj, ncns, nord, nsel;
extern /* Subroutine */ int zzekcchk_(char *, integer *, char *, integer *
, char *, char *, integer *, logical *, char *, integer *, ftnlen,
ftnlen, ftnlen, ftnlen, ftnlen), zzekqtab_(integer *, char *,
integer *, char *, char *, ftnlen, ftnlen, ftnlen), zzekreqi_(
integer *, char *, integer *, ftnlen), zzekweqi_(char *, integer *
, integer *, ftnlen);
integer i__, j;
char table[64*10], alias[64*10];
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer nload;
extern /* Subroutine */ int repmc_(char *, char *, char *, char *, ftnlen,
ftnlen, ftnlen, ftnlen);
integer cc[10];
extern logical failed_(void);
char ltable[64];
extern /* Subroutine */ int ekntab_(integer *);
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
integer cnstyp, iparse;
extern /* Subroutine */ int setmsg_(char *, ftnlen), sigerr_(char *,
ftnlen), chkout_(char *, ftnlen), ektnam_(integer *, char *,
ftnlen), ekccnt_(char *, integer *, ftnlen);
logical fnd;
integer lxb, lxe;
/* $ 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. */
/* Resolve and semantically check table names, aliases, and column */
/* names in an 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 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 Query Limit Parameters */
/* ekqlimit.inc Version 3 16-NOV-1995 (NJB) */
/* Parameter MAXCON increased to 1000. */
/* ekqlimit.inc Version 2 01-AUG-1995 (NJB) */
/* Updated to support SELECT clause. */
/* ekqlimit.inc Version 1 07-FEB-1995 (NJB) */
/* These limits apply to character string queries input to the */
/* EK scanner. This limits are part of the EK system's user */
/* interface: the values should be advertised in the EK required */
/* reading document. */
/* Maximum length of an input query: MAXQRY. This value is */
/* currently set to twenty-five 80-character lines. */
/* Maximum number of columns that may be listed in the */
/* `order-by clause' of a query: MAXSEL. MAXSEL = 50. */
/* Maximum number of tables that may be listed in the `FROM */
/* clause' of a query: MAXTAB. */
/* Maximum number of relational expressions that may be listed */
/* in the `constraint clause' of a query: MAXCON. */
/* This limit applies to a query when it is represented in */
/* `normalized form': that is, the constraints have been */
/* expressed as a disjunction of conjunctions of relational */
/* expressions. The number of relational expressions in a query */
/* that has been expanded in this fashion may be greater than */
/* the number of relations in the query as orginally written. */
/* For example, the expression */
/* ( ( A LT 1 ) OR ( B GT 2 ) ) */
/* AND */
/* ( ( C NE 3 ) OR ( D EQ 4 ) ) */
/* which contains 4 relational expressions, expands to the */
/* equivalent normalized constraint */
/* ( ( A LT 1 ) AND ( C NE 3 ) ) */
/* OR */
/* ( ( A LT 1 ) AND ( D EQ 4 ) ) */
/* OR */
/* ( ( B GT 2 ) AND ( C NE 3 ) ) */
/* OR */
/* ( ( B GT 2 ) AND ( D EQ 4 ) ) */
/* which contains eight relational expressions. */
/* MXJOIN is the maximum number of tables that can be joined. */
/* MXJCON is the maximum number of join constraints allowed. */
/* Maximum number of order-by columns that may be used in the */
/* `order-by clause' of a query: MAXORD. MAXORD = 10. */
/* Maximum number of tokens in a query: 500. Tokens are reserved */
/* words, column names, parentheses, and values. Literal strings */
/* and time values count as single tokens. */
/* Maximum number of numeric tokens in a query: */
/* Maximum total length of character tokens in a query: */
/* Maximum length of literal string values allowed in queries: */
/* MAXSTR. */
/* End Include Section: EK Query Limit 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 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 */
/* $ 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 Table Name Size */
/* ektnamsz.inc Version 1 17-JAN-1995 (NJB) */
/* Size of table name, in characters. */
/* End Include Section: EK Table Name Size */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* EQRYI I-O Integer component of query. */
/* EQRYC I-O Character component of query. */
/* ERROR O Error flag. */
/* ERRMSG O Error message. */
/* ERRPTR O Position in query where error was detected. */
/* $ Detailed_Input */
/* QUERY is the original query from which EQRYI and EQRYC */
/* were obtained. QUERY is used only for */
/* construction of error messages. */
/* EQRYI is the integer portion of an encoded EK query. */
/* The query must have been parsed. */
/* EQRYC is the character portion of an encoded EK query. */
/* $ Detailed_Output */
/* EQRYI is the integer portion of an encoded EK query. */
/* On output, all names have been resolved, and */
/* table names, aliases, and column names have */
/* been semantically checked. */
/* EQRYC is the character portion of an encoded EK query. */
/* ERROR is a logical flag indicating whether an error was */
/* detected. The error could be a name resolution */
/* error or a semantic error. */
/* ERRMSG is an error message describing an error in the */
/* input query, if one was detected. If ERROR is */
/* returned .FALSE., then ERRPTR is undefined. */
/* ERRPTR is the character position in the original query */
/* at which an error was detected, if an error was */
/* found. This index refers to the offending lexeme's */
/* position in the original query represented by the */
/* input encoded query. If ERROR is returned .FALSE., */
/* ERRPTR is undefined. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the input query is not initialized, the error will be */
/* diagnosed by routines called by this routine. The outputs */
/* will not be modified. */
/* 2) If the input query has not been parsed, the error */
/* SPICE(QUERYNOTPARSED) will be signalled. The outputs */
/* will not be modified. */
/* 3) If any sort of name resolution error or semantic error is */
/* detected in the input query, the output flag ERROR is set, */
/* and an error message is returned. The checks performed by */
/* this routine are listed below: */
/* - All tables named in the FROM clause must be loaded */
/* in the EK system. */
/* - All aliases in the FROM clause must be distinct. */
/* - No alias may be the name of a table in the FROM clause, */
/* unless it is identical to the name of the table it is */
/* associated with. */
/* - No column name may be qualified with a name that is not */
/* the name or alias of a table in the FROM clause. */
/* - Each qualified column must be present in the table */
/* indicated by its qualifying name. */
/* - Each unqualified column name must be the name of a */
/* column present in exactly one of the tables listed in the */
/* FROM clause. */
/* $ Files */
/* None. */
/* $ Particulars */
/* Resolution of table names involves finding each table's ordinal */
/* position in the FROM clause, and setting the table's descriptor */
/* to record that position. The same is done for column descriptors. */
/* $ Examples */
/* See EKFIND. */
/* $ 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 */
/* No error to start with. */
*error = FALSE_;
s_copy(errmsg, " ", errmsg_len, (ftnlen)1);
*errptr = 0;
/* The query must have been parsed at this point, or it's no go. */
zzekreqi_(eqryi, "PARSED", &iparse, (ftnlen)6);
if (failed_()) {
return 0;
}
if (iparse == -1) {
chkin_("ZZEKNRES", (ftnlen)8);
setmsg_("Encoded query has not been parsed.", (ftnlen)34);
sigerr_("SPICE(QUERYNOTPARSED)", (ftnlen)21);
chkout_("ZZEKNRES", (ftnlen)8);
return 0;
}
/* Get the important counts from the query. */
zzekreqi_(eqryi, "NUM_TABLES", &ntab, (ftnlen)10);
zzekreqi_(eqryi, "NUM_CONSTRAINTS", &ncns, (ftnlen)15);
zzekreqi_(eqryi, "NUM_CONJUNCTIONS", &ncnj, (ftnlen)16);
zzekreqi_(eqryi, "NUM_ORDERBY_COLS", &nord, (ftnlen)16);
zzekreqi_(eqryi, "NUM_SELECT_COLS", &nsel, (ftnlen)15);
/* Start out by fetching the table names and their aliases. */
i__1 = ntab;
for (i__ = 1; i__ <= i__1; ++i__) {
zzekqtab_(eqryi, eqryc, &i__, table + (((i__2 = i__ - 1) < 10 && 0 <=
i__2 ? i__2 : s_rnge("table", i__2, "zzeknres_", (ftnlen)254))
<< 6), alias + (((i__3 = i__ - 1) < 10 && 0 <= i__3 ? i__3 :
s_rnge("alias", i__3, "zzeknres_", (ftnlen)254)) << 6),
eqryc_len, (ftnlen)64, (ftnlen)64);
}
/* Make sure that the aliases are distinct. Rather than sorting */
/* them, we'll check them in left-to-right order. */
i__1 = ntab - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = ntab;
for (j = i__ + 1; j <= i__2; ++j) {
if (s_cmp(alias + (((i__3 = i__ - 1) < 10 && 0 <= i__3 ? i__3 :
s_rnge("alias", i__3, "zzeknres_", (ftnlen)265)) << 6),
alias + (((i__4 = j - 1) < 10 && 0 <= i__4 ? i__4 :
s_rnge("alias", i__4, "zzeknres_", (ftnlen)265)) << 6), (
ftnlen)64, (ftnlen)64) == 0 && s_cmp(alias + (((i__5 =
i__ - 1) < 10 && 0 <= i__5 ? i__5 : s_rnge("alias", i__5,
"zzeknres_", (ftnlen)265)) << 6), " ", (ftnlen)64, (
ftnlen)1) != 0) {
*error = TRUE_;
s_copy(errmsg, "Non-distinct alias <#> was found.",
errmsg_len, (ftnlen)33);
base = ((j - 1 << 1) + 1) * 6 + 19;
lxb = eqryi[base + 7];
lxe = eqryi[base + 8];
repmc_(errmsg, "#", query + (lxb - 1), errmsg, errmsg_len, (
ftnlen)1, lxe - (lxb - 1), errmsg_len);
*errptr = lxb;
return 0;
}
/* We've checked the Jth alias for a match. */
}
}
/* Make sure that no alias matches a table name other than that of */
/* the table it corresponds to. */
i__1 = ntab;
for (i__ = 1; i__ <= i__1; ++i__) {
j = isrchc_(alias + (((i__2 = i__ - 1) < 10 && 0 <= i__2 ? i__2 :
s_rnge("alias", i__2, "zzeknres_", (ftnlen)295)) << 6), &ntab,
table, (ftnlen)64, (ftnlen)64);
if (j != 0) {
if (j != i__) {
*error = TRUE_;
s_copy(errmsg, "Alias <#> conflicts with table name.",
errmsg_len, (ftnlen)36);
base = ((i__ - 1 << 1) + 1) * 6 + 19;
lxb = eqryi[base + 7];
lxe = eqryi[base + 8];
repmc_(errmsg, "#", query + (lxb - 1), errmsg, errmsg_len, (
ftnlen)1, lxe - (lxb - 1), errmsg_len);
*errptr = lxb;
return 0;
}
}
}
/* Make sure that all of the tables are loaded in the EK system. */
ekntab_(&nload);
i__1 = ntab;
for (i__ = 1; i__ <= i__1; ++i__) {
fnd = FALSE_;
j = 1;
while(j <= nload && ! fnd) {
ektnam_(&j, ltable, (ftnlen)64);
if (s_cmp(table + (((i__2 = i__ - 1) < 10 && 0 <= i__2 ? i__2 :
s_rnge("table", i__2, "zzeknres_", (ftnlen)336)) << 6),
ltable, (ftnlen)64, (ftnlen)64) == 0) {
/* When we find a loaded table, save the column count for */
/* that table. */
fnd = TRUE_;
ekccnt_(table, &cc[(i__2 = i__ - 1) < 10 && 0 <= i__2 ? i__2 :
s_rnge("cc", i__2, "zzeknres_", (ftnlen)342)], (
ftnlen)64);
} else {
++j;
}
}
if (! fnd) {
*error = TRUE_;
s_copy(errmsg, "Table <#> is not currently loaded.", errmsg_len, (
ftnlen)34);
/* In order to set the error pointer, we'll need the */
/* lexeme begin value for the offending table. */
base = (i__ - 1) * 12 + 19;
lxb = eqryi[base + 7];
lxe = eqryi[base + 8];
repmc_(errmsg, "#", query + (lxb - 1), errmsg, errmsg_len, (
ftnlen)1, lxe - (lxb - 1), errmsg_len);
*errptr = lxb;
return 0;
}
}
/* At this point, the tables and aliases are deemed correct. For */
/* safety, fill in each table and alias descriptor with its */
/* ordinal position. */
i__1 = ntab;
for (i__ = 1; i__ <= i__1; ++i__) {
base = (i__ - 1) * 12 + 19;
eqryi[base + 11] = i__;
eqryi[base + 17] = i__;
}
/* Check the column names used in the constraints. */
i__1 = ncns;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Calculate the base address of the constraint. */
base = ntab * 12 + 19 + (i__ - 1) * 26;
/* Obtain the constraint type. */
cnstyp = eqryi[base + 6];
/* Check the column and table on the LHS of the constraint. */
i__2 = base + 1;
zzekcchk_(query, eqryi, eqryc, &ntab, table, alias, &i__2, error,
errmsg, errptr, query_len, eqryc_len, (ftnlen)64, (ftnlen)64,
errmsg_len);
if (*error) {
return 0;
}
if (cnstyp == 1) {
/* Check the column and table on the RHS of the constraint. */
i__2 = base + 14;
zzekcchk_(query, eqryi, eqryc, &ntab, table, alias, &i__2, error,
errmsg, errptr, query_len, eqryc_len, (ftnlen)64, (ftnlen)
64, errmsg_len);
if (*error) {
return 0;
}
}
}
/* Do the same checks and assignments for the SELECT columns. */
i__1 = nsel;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Calculate the base address of the SELECT column descriptor. */
base = ntab * 12 + 19 + ncnj + ncns * 26 + nord * 13 + (i__ - 1) * 12;
zzekcchk_(query, eqryi, eqryc, &ntab, table, alias, &base, error,
errmsg, errptr, query_len, eqryc_len, (ftnlen)64, (ftnlen)64,
errmsg_len);
if (*error) {
return 0;
}
}
/* Do the same checks and assignments for the order-by columns. */
i__1 = nord;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Calculate the base address of the order-by column descriptor. */
base = ntab * 12 + 19 + ncnj + ncns * 26 + (i__ - 1) * 13;
zzekcchk_(query, eqryi, eqryc, &ntab, table, alias, &base, error,
errmsg, errptr, query_len, eqryc_len, (ftnlen)64, (ftnlen)64,
errmsg_len);
if (*error) {
return 0;
}
}
/* Indicate completion of name resolution. */
zzekweqi_("NAMES_RESOLVED", &c__1, eqryi, (ftnlen)14);
return 0;
} /* zzeknres_ */
/* $Procedure VERSION ( Print library version information ) */
/* Main program */ MAIN__(void)
{
/* System generated locals */
address a__1[2], a__2[4];
integer i__1[2], i__2, i__3[4], i__4;
doublereal d__1;
char ch__1[25], ch__2[99];
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen),
s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
char line[80], vrsn[6];
extern /* Subroutine */ int zzplatfm_(char *, char *, ftnlen, ftnlen);
integer i__;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
extern doublereal dpmin_(void);
extern /* Subroutine */ int repmd_(char *, char *, doublereal *, integer *
, char *, ftnlen, ftnlen, ftnlen);
extern doublereal dpmax_(void);
char fform[80];
extern /* Subroutine */ int repmi_(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
char cmplr[80];
extern integer wdcnt_(char *, ftnlen);
char tform[80];
extern integer rtrim_(char *, ftnlen);
char os[80];
extern /* Subroutine */ int getcml_(char *, ftnlen), byebye_(char *,
ftnlen);
extern integer intmin_(void), intmax_(void);
char linout[80*6];
extern /* Subroutine */ int tostdo_(char *, ftnlen), tkvrsn_(char *, char
*, ftnlen, ftnlen);
extern integer pos_(char *, char *, integer *, ftnlen, ftnlen);
char sys[80];
/* $ Abstract */
/* This program prints to standard output the current SPICE */
/* distribution version number, hardware system ID, operating */
/* system ID, compiler name, the format of double precision */
/* numbers for the hardware architecture, and the max and min */
/* values for double precision and integer numbers. */
/* $ 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. */
/* $ Keyword */
/* VERSION */
/* UTILITY */
/* $ Parameters */
/* LINELN length of line output string, set to 80. */
/* DATEID update version time string, set to 20. */
/* $ Exceptions */
/* None. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The version utility may use 3 different command line arguments. */
/* The default (no arguments) returns the Toolkit version string. */
/* Usage: $ version [OPTION] */
/* $ Description */
/* None. */
/* $ Examples */
/* Default behavior: */
/* $ version */
/* N0051 */
/* Display all (-a) information: */
/* $version -a */
/* Toolkit version : N0051 */
/* System : PC */
/* Operating System : LINUX */
/* Compiler : LINUX G77 */
/* File Format : LTL-IEEE */
/* MAX DP : 1.7976931348623E+308 */
/* MIN DP : -1.7976931348623E+308 */
/* MAX INT : 2147483647 */
/* MIN INT : -2147483647 */
/* Display version (-v) information: */
/* $version -v */
/* Version Utility for SPICE Toolkit edition N0051, */
/* last update: 1.1.0, 05-OCT-2001 */
/* Display help (-h) information: */
/* $version -h */
/* Usage: version [OPTION] */
/* no arguments output only the SPICE toolkit version string. */
/* -a(ll) output all environment variables; SPICE toolkit */
/* version, system ID, operating system, compiler, */
/* binary file format, max and min values for */
/* double precision and integer numbers. */
/* -v(ersion) output the version of the utility. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* F.S. Turner (JPL) */
/* E.D. Wright (JPL) */
/* $ Version */
/* SPICELIB Version 1.1.0 26-SEP-2001 (FST) (EDW) */
/* Added TEXT_FORMAT output. */
/* Included options for SYSTEM, O/S, COMPILER, FILE_FORMAT, */
/* max/min DPs & integers, outputs, version, and help. */
/* Added proper SPICE header. */
/* SPICELIB Version 1.0.0 13-NOV-2001 (WLT) */
/* First version, Thu NOV 13 10:04:41 PST 1997 W.L. Taber */
/* -& */
/* SPICELIB functions. */
/* Local Parameters. */
/* Local Variables. */
/* Get command line. */
getcml_(line, (ftnlen)80);
ucase_(line, line, (ftnlen)80, (ftnlen)80);
tkvrsn_("TOOLKIT", vrsn, (ftnlen)7, (ftnlen)6);
/* Parse the command line for arguments. Appropriately respond. */
if (wdcnt_(line, (ftnlen)80) == 0) {
/* No arguments, default to the toolkit version string. */
tostdo_(vrsn, rtrim_(vrsn, (ftnlen)6));
} else if (pos_(line, "-A", &c__1, (ftnlen)80, (ftnlen)2) == 1) {
/* All. Output everything. */
tostdo_(" ", (ftnlen)1);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "Toolkit version : ";
i__1[1] = 6, a__1[1] = vrsn;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)25);
tostdo_(ch__1, (ftnlen)25);
zzplatfm_("SYSTEM", sys, (ftnlen)6, (ftnlen)80);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "System : ";
i__1[1] = 80, a__1[1] = sys;
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)99);
tostdo_(ch__2, (ftnlen)99);
zzplatfm_("O/S", os, (ftnlen)3, (ftnlen)80);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "Operating System : ";
i__1[1] = 80, a__1[1] = os;
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)99);
tostdo_(ch__2, (ftnlen)99);
zzplatfm_("COMPILER", cmplr, (ftnlen)8, (ftnlen)80);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "Compiler : ";
i__1[1] = 80, a__1[1] = cmplr;
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)99);
tostdo_(ch__2, (ftnlen)99);
zzplatfm_("FILE_FORMAT", fform, (ftnlen)11, (ftnlen)80);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "File Format : ";
i__1[1] = 80, a__1[1] = fform;
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)99);
tostdo_(ch__2, (ftnlen)99);
zzplatfm_("TEXT_FORMAT", tform, (ftnlen)11, (ftnlen)80);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "Text File Format : ";
i__1[1] = 80, a__1[1] = tform;
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)99);
tostdo_(ch__2, (ftnlen)99);
s_copy(linout, "MAX DP : #", (ftnlen)80, (ftnlen)21);
d__1 = dpmax_();
repmd_(linout, "#", &d__1, &c__23, linout, (ftnlen)80, (ftnlen)1, (
ftnlen)80);
tostdo_(linout, (ftnlen)80);
s_copy(linout + 80, "MIN DP : #", (ftnlen)80, (ftnlen)20);
d__1 = dpmin_();
repmd_(linout + 80, "#", &d__1, &c__23, linout + 80, (ftnlen)80, (
ftnlen)1, (ftnlen)80);
tostdo_(linout + 80, (ftnlen)80);
s_copy(linout + 160, "MAX INT : #", (ftnlen)80, (ftnlen)21);
i__2 = intmax_();
repmi_(linout + 160, "#", &i__2, linout + 160, (ftnlen)80, (ftnlen)1,
(ftnlen)80);
tostdo_(linout + 160, (ftnlen)80);
s_copy(linout + 240, "MIN INT : #", (ftnlen)80, (ftnlen)20);
i__2 = intmin_();
repmi_(linout + 240, "#", &i__2, linout + 240, (ftnlen)80, (ftnlen)1,
(ftnlen)80);
tostdo_(linout + 240, (ftnlen)80);
tostdo_(" ", (ftnlen)1);
} else if (pos_(line, "-V", &c__1, (ftnlen)80, (ftnlen)2) == 1) {
/* Version. Output the utility version string. */
/* Writing concatenation */
i__3[0] = 42, a__2[0] = "Version Utility for SPICE Toolkit edition ";
i__3[1] = rtrim_(vrsn, (ftnlen)6), a__2[1] = vrsn;
i__3[2] = 15, a__2[2] = ", last update: ";
i__3[3] = 18, a__2[3] = "1.1.0, 07-JAN-2002 ";
s_cat(linout, a__2, i__3, &c__4, (ftnlen)80);
tostdo_(" ", (ftnlen)1);
tostdo_(linout, (ftnlen)80);
tostdo_(" ", (ftnlen)1);
} else if (pos_(line, "-H", &c__1, (ftnlen)80, (ftnlen)2) == 1) {
/* Help. How does does one use this perplexing routine? */
s_copy(linout, "Usage: version [OPTION]", (ftnlen)80, (ftnlen)23);
s_copy(linout + 80, " no arguments output only the SPICE toolkit v"
"ersion string.", (ftnlen)80, (ftnlen)61);
s_copy(linout + 160, " -a(ll) output all environment variabl"
"es; SPICE toolkit version, system", (ftnlen)80, (ftnlen)79);
s_copy(linout + 240, " ID, operating system, compiler"
", and binary file format, ", (ftnlen)80, (ftnlen)72);
s_copy(linout + 320, " max and min values for double "
"precision and integer numbers.", (ftnlen)80, (ftnlen)76);
s_copy(linout + 400, " -v(ersion) output the version of the util"
"ity.", (ftnlen)80, (ftnlen)50);
tostdo_(" ", (ftnlen)1);
for (i__ = 1; i__ <= 6; ++i__) {
tostdo_(linout + ((i__2 = i__ - 1) < 6 && 0 <= i__2 ? i__2 :
s_rnge("linout", i__2, "version_", (ftnlen)272)) * 80,
rtrim_(linout + ((i__4 = i__ - 1) < 6 && 0 <= i__4 ? i__4
: s_rnge("linout", i__4, "version_", (ftnlen)272)) * 80, (
ftnlen)80));
}
tostdo_(" ", (ftnlen)1);
} else {
/* The user put something on the command line, but nothing */
/* known. Return the toolkit version string. */
tostdo_(vrsn, rtrim_(vrsn, (ftnlen)6));
}
/* Done. Indicate as much. Say bye. */
byebye_("SUCCESS", (ftnlen)7);
s_stop("", (ftnlen)0);
return 0;
} /* MAIN__ */
/* $Procedure ANA ( AN or A ? ) */
/* Character */ VOID ana_(char *ret_val, ftnlen ret_val_len, char *word, char
*case__, ftnlen word_len, ftnlen case_len)
{
/* Initialized data */
static char a[2*3] = "A " "A " "a ";
static char an[2*3] = "AN" "An" "an";
static char anword[8*22] = "HEIR " "HONEST " "HONOR " "H "
"HOUR " "HORS " "HOMBRE " "F " "L " "M "
"N " "R " "S " "X " "UNIN " "UNIM "
"ONEI " "ONER " "SPK " "EK " "IK " "SCLK ";
static char aword[8*33] = "HORSE " "ONE " "ONE- " "ONCE "
"ONENESS " "UIG " "UIN " "UKA " "UKE " "UKO "
"UKI " "UKU " "ULOT " "UNANI " "UNI " "UNINU "
"UPA " "URA " "URE " "URO " "USA " "USE "
"USU " "UTE " "UTI " "UTO " "UVA " "UVE "
"UVU " "EU " "EWE " "UTRI " "U ";
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_indx(char *, char *, ftnlen, ftnlen), s_rnge(char *, integer,
char *, integer);
/* Local variables */
static integer caps, i__;
static char begin[1];
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
static char start[32*7];
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int replch_(char *, char *, char *, char *,
ftnlen, ftnlen, ftnlen, ftnlen);
static char mycase[1], myword[32];
/* $ Abstract */
/* Return the correct article "a" or "an" used to modify a word */
/* and return it capitalized, lower case, or upper case. */
/* $ 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 */
/* WORD */
/* $ Keywords */
/* UTILITY */
/* WORD */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* WORD I is a word that should be modified by "a" or "an" */
/* CASE I 'U', 'L', or 'C' to specify capitalization of ANA. */
/* ANA O 'A' or 'AN' appropriately capitalized. */
/* $ Detailed_Input */
/* WORD is any english word for which you want to write the */
/* correct phrase "a(an) response(answer)". The case */
/* of the letters of word do not matter. */
/* Leading white space in word is ignored. The characters */
/* " and ' are ignored. Thus ''' apple '' ' and */
/* '"apple"' and ' apple' and 'apple' are all treated as */
/* the same word. */
/* CASE is a character that describes how the value returned */
/* in ANA should be capitalized. The rules are: */
/* 'U' --- ANA is returned in all caps ( A, AN ) */
/* 'C' --- ANA is returned capitalized ( A, An ) */
/* 'L' --- ANA is returned lower case ( a, an ) */
/* The case of CASE does not matter. Any value other */
/* than those specified result in ANA being returned */
/* in all lower case. */
/* $ Detailed_Output */
/* ANA is a character function an will return the correct */
/* indefinite article needed to modify the word contained */
/* in WORD. ANA should be declared to be CHARACTER*(2) */
/* (or CHARACTER*(N) where N > 1) in the calling */
/* program. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error Free */
/* 1) If the uppercase value of CASE is not 'U', 'C' or 'L', it shall */
/* be treated as 'L'. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine allows you to construct grammatically correct phrases */
/* when you need to modify a word by an indefinite article. Using */
/* the pronunciations contained in the Webster's Ninth Collegiate */
/* Dictionary, the phrase */
/* ANA(WORD, CASE) // ' ' // WORD */
/* will be grammatically correct. */
/* $ Examples */
/* Suppose you wished to construct one of the messages */
/* 'a new file' */
/* 'an existing file' */
/* and that the NEW/EXISTING word was in the variable WORD. Then */
/* you could write */
/* MESSAGE = ANA( WORD, 'L' ) // ' ' // WORD // ' file ' */
/* CALL CMPRSS ( ' ', 1, MESSAGE, MESSAGE ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* Webster's Ninth Collegiate Dictionary. */
/* $ Author_and_Institution */
/* B.V. Semenov (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.2, 28-FEB-2008 (BVS) */
/* Corrected the contents of the Required_Reading section. */
/* - SPICELIB Version 1.1.1, 22-SEP-2004 (EDW) */
/* Added Copyright section. */
/* - SPICELIB Version 1.1.0, 18-JAN-2001 (WLT) */
/* Made SCLK and "an" word. */
/* - SPICELIB Version 1.0.0, 29-NOV-1995 (WLT) */
/* -& */
/* $ Index_Entries */
/* GET THE CORRECT INDEFINITE ARTICLE */
/* -& */
ucase_(word, myword, word_len, (ftnlen)32);
replch_(myword, "'", " ", myword, (ftnlen)32, (ftnlen)1, (ftnlen)1, (
ftnlen)32);
replch_(myword, "\"", " ", myword, (ftnlen)32, (ftnlen)1, (ftnlen)1, (
ftnlen)32);
ljust_(myword, myword, (ftnlen)32, (ftnlen)32);
ucase_(case__, mycase, case_len, (ftnlen)1);
s_copy(ret_val, " ", ret_val_len, (ftnlen)1);
if (*(unsigned char *)mycase == 'U') {
caps = 1;
} else if (*(unsigned char *)mycase == 'C') {
caps = 2;
} else {
caps = 3;
}
/* Handle the obvious things first. */
*(unsigned char *)begin = *(unsigned char *)myword;
if (i_indx("AI", begin, (ftnlen)2, (ftnlen)1) > 0) {
s_copy(ret_val, an + (((i__1 = caps - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("an", i__1, "ana_", (ftnlen)235)) << 1), ret_val_len, (
ftnlen)2);
return ;
} else if (i_indx("BCDGJKPQTVWYZ", begin, (ftnlen)13, (ftnlen)1) > 0) {
s_copy(ret_val, a + (((i__1 = caps - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("a", i__1, "ana_", (ftnlen)240)) << 1), ret_val_len, (
ftnlen)2);
return ;
}
/* If we are still here, we need to be a bit more careful */
/* in our determination of ANA. */
/* Get the beginnings of the input word. */
for (i__ = 1; i__ <= 7; ++i__) {
s_copy(start + (((i__1 = i__ - 1) < 7 && 0 <= i__1 ? i__1 : s_rnge(
"start", i__1, "ana_", (ftnlen)252)) << 5), myword, (ftnlen)
32, i__);
}
/* Now see if the start of the input word belongs to */
/* one of the special collections. */
for (i__ = 7; i__ >= 2; --i__) {
if (isrchc_(start + (((i__1 = i__ - 1) < 7 && 0 <= i__1 ? i__1 :
s_rnge("start", i__1, "ana_", (ftnlen)261)) << 5), &c__33,
aword, (ftnlen)32, (ftnlen)8) != 0) {
s_copy(ret_val, a + (((i__1 = caps - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("a", i__1, "ana_", (ftnlen)263)) << 1),
ret_val_len, (ftnlen)2);
return ;
}
if (isrchc_(start + (((i__1 = i__ - 1) < 7 && 0 <= i__1 ? i__1 :
s_rnge("start", i__1, "ana_", (ftnlen)268)) << 5), &c__22,
anword, (ftnlen)32, (ftnlen)8) != 0) {
s_copy(ret_val, an + (((i__1 = caps - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("an", i__1, "ana_", (ftnlen)270)) << 1),
ret_val_len, (ftnlen)2);
return ;
}
}
/* If we got this far we can determine the ANAe by */
/* just looking at the beginning of the string. */
if (i_indx("AEIOU", myword, (ftnlen)5, (ftnlen)1) > 0) {
s_copy(ret_val, an + (((i__1 = caps - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("an", i__1, "ana_", (ftnlen)282)) << 1), ret_val_len, (
ftnlen)2);
} else {
s_copy(ret_val, a + (((i__1 = caps - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("a", i__1, "ana_", (ftnlen)286)) << 1), ret_val_len, (
ftnlen)2);
}
return ;
} /* ana_ */
/* $Procedure STRAN */
/* Subroutine */ int stran_0_(int n__, char *input, char *output, logical *
tran, ftnlen input_len, ftnlen output_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen), i_indx(char *, char *,
ftnlen, ftnlen), s_rnge(char *, integer, char *, integer), i_len(
char *, ftnlen);
/* Local variables */
static integer ldef, leno, vdim, slot, lout, lsym, ptrs[810], i__, j;
extern integer cardc_(char *, ftnlen);
static integer l, n;
static logical check[200];
extern logical batch_(void);
static integer place;
extern /* Subroutine */ int lcase_(char *, char *, ftnlen, ftnlen);
static char delim[1];
extern /* Subroutine */ int chkin_(char *, ftnlen);
static integer nname;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
static char names[32*206];
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen),
geteq_(char *, ftnlen);
extern integer ncpos_(char *, char *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int nthwd_(char *, integer *, char *, integer *,
ftnlen, ftnlen);
static char symbl[33];
static integer psize;
extern integer rtrim_(char *, ftnlen);
static logical checkd[200];
extern logical failed_(void);
static char alphab[32];
extern /* Subroutine */ int getdel_(char *, ftnlen);
extern logical matchm_(char *, char *, char *, char *, char *, char *,
ftnlen, ftnlen, ftnlen, ftnlen, ftnlen, ftnlen);
static char buffer[256*52];
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen),
lastnb_(char *, ftnlen);
static logical gotone;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), repsub_(char *, integer *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen);
static char equote[1];
extern /* Subroutine */ int setmsg_(char *, ftnlen);
static char resvrd[32*12], symbol[33], pattrn[80];
static integer nxtchr;
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen), rdstmn_(char *, char *, char *, ftnlen, ftnlen, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int sbget_1__(char *, char *, integer *, char *,
char *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), nthuqw_(char *
, integer *, char *, char *, integer *, ftnlen, ftnlen, ftnlen);
static char myprmt[80];
extern /* Subroutine */ int sbrem_1__(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
static integer lsttry;
extern /* Subroutine */ int sbset_1__(char *, char *, char *, integer *,
char *, ftnlen, ftnlen, ftnlen, ftnlen);
static char def[1024];
static integer loc;
static char key[32];
static logical new__;
extern /* Subroutine */ int sbinit_1__(integer *, integer *, integer *,
char *, integer *, char *, ftnlen, ftnlen);
/* $ Abstract */
/* Translate the symbols in an input string. */
/* $ 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. */
/* $ Keywords */
/* PARSE */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* INPUT I Input string containing symbols to be translated. */
/* OUTPUT O Output string, with all symbols translated. */
/* $ Detailed_Input */
/* INPUT is the input string to be translated. INPUT may contain */
/* any number of known symbols. */
/* $ Detailed_Output */
/* OUTPUT is the translation of the input string. The first */
/* of the symbols in INPUT will have been translated. */
/* When INPUT is either a DEFINE or an UNDEFINE command, */
/* OUTPUT is blank. */
/* OUTPUT may overwrite INPUT. */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* None. */
/* $ Exceptions */
/* The following exceptions are detected by this routine: */
/* 1) Attempt to define or undefine a symbol that does */
/* not begin with a letter. */
/* 2) Attempt to define or undefine a symbol that ends with */
/* a question mark '?' . */
/* 3) Failure to specify a symbol to define or undefine. */
/* 4) Attempting to define a reserved word. The reserved */
/* words are: */
/* 'START' */
/* 'STOP' */
/* 'EXIT' */
/* 'INQUIRE' */
/* 'SHOW' */
/* 'DEFINE' */
/* 'SHOW' */
/* 'UNDEFINE' */
/* 'HELP' */
/* In all of the above cases OUTPUT is set to blank and TRAN to */
/* FALSE. No new symbol is placed in the table of symbol */
/* definitions. */
/* In all of these cases the error BAD_SYMBOL_SPC is signalled. */
/* 5) Recursive symbol definitions are detected and disallowed. */
/* A long error message diagnosing the problem is set and */
/* the error RECURSIVE_SYMBOL is signalled. */
/* 5) Overflow of the input command caused by symbol resolution. */
/* In this case the OUTPUT is left at the state it had reached */
/* prior to the overflow condition and TRAN is returned as */
/* FALSE. The error SYMBOL_OVERFLOW is signalled. */
/* $ Detailed_Description */
/* A new symbol may be defined with the DEFINE command. The */
/* syntax is: */
/* DEFINE <symbol> <definition> */
/* where <symbol> is a valid symbol name and <definition> is any */
/* valid definition. The DEFINE command, the symbol name, and the */
/* definition are delimited by blanks. */
/* When a symbol is defined, the symbol and definition are inserted */
/* into the symbol table. */
/* An existing symbol may be removed from the table with the */
/* UNDEFINE command. The syntax is: */
/* UNDEFINE <symbol> */
/* where <symbol> is the name of an existing symbol. The UNDEFINE */
/* command and the symbol name are delimited by blanks. */
/* If the input string does not contain a definition statement, */
/* STRANS searches the input string for potential symbol names. */
/* When a valid symbol is encountered, it is removed from the */
/* string and replaced by the corresponding definition. This */
/* continues until no untranslated symbols remain. */
/* $ Examples */
/* Suppose that we are given the following definitions: */
/* DEFINE BODIES PLANET AND SATS */
/* DEFINE EUROPA 502 */
/* DEFINE GANYMEDE 503 */
/* DEFINE IO 501 */
/* DEFINE JUPITER 599 */
/* DEFINE PLANET JUPITER */
/* DEFINE CALLISTO 504 */
/* DEFINE SATS IO EUROPA GANYMEDE CALLISTO */
/* Then the string 'BODIES AND SOULS' would translate, */
/* at various stages, to: */
/* 'PLANET AND SATS AND SOULS' */
/* 'JUPITER AND SATS AND SOULS' */
/* '599 AND SATS AND SOULS' */
/* '599 AND IO EUROPA GANYMEDE CALLISTO AND SOULS' */
/* '599 AND 501 EUROPA GANYMEDE CALLISTO AND SOULS' */
/* '599 AND 501 502 GANYMEDE CALLISTO AND SOULS' */
/* '599 AND 501 502 503 CALLISTO AND SOULS' */
/* '599 AND 501 502 503 504 AND SOULS' */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* I. M. Underwood (JPL) */
/* $ Version_and_Date */
/* Version 1.2.0 29-Aug-1996 (WLT) */
/* Fixed the error message for the case in which someone */
/* tries to create a symbol that is more than 32 characters */
/* in length. */
/* Version 1.1, 14-SEP-1995 */
/* Reference to unused variable WORD deleted. */
/* Version 1, 8-SEP-1986 */
/* -& */
/* SPICELIB Functions */
/* Other supporting functions */
/* The following parameters are used to define our table */
/* of symbol translations. */
/* Longest allowed symbol name is given by WDSIZE */
/* Maximum number of allowed symbols is MAXN */
/* The longest we expect any symbol to be is MAXL characters */
/* The average number of characters per symbol is AVGL */
/* Finally, here are the arrays used to hold the symbol translations. */
/* Here's the storage we need for the reserved words. */
switch(n__) {
case 1: goto L_sympat;
case 2: goto L_symget;
}
/* Set up all of the data structures and special strings in */
/* the first pass through the routine. */
if (return_()) {
return 0;
}
chkin_("STRAN", (ftnlen)5);
if (first) {
first = FALSE_;
vdim = 51;
psize = 804;
nname = 200;
sbinit_1__(&nname, &psize, &vdim, names, ptrs, buffer, (ftnlen)32, (
ftnlen)256);
s_copy(resvrd, "START", (ftnlen)32, (ftnlen)5);
s_copy(resvrd + 32, "STOP", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 64, "EXIT", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 96, "INQUIRE", (ftnlen)32, (ftnlen)7);
s_copy(resvrd + 128, "SHOW", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 160, "DEFINE", (ftnlen)32, (ftnlen)6);
s_copy(resvrd + 192, "SHOW", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 224, "UNDEFINE", (ftnlen)32, (ftnlen)8);
s_copy(resvrd + 256, "HELP", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 288, "RECALL", (ftnlen)32, (ftnlen)6);
s_copy(resvrd + 320, "DO", (ftnlen)32, (ftnlen)2);
s_copy(resvrd + 352, "EDIT", (ftnlen)32, (ftnlen)4);
s_copy(alphab, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", (ftnlen)32, (ftnlen)26);
}
/* Find out what the special marker character is for suppressing */
/* symbol evaluation. */
geteq_(equote, (ftnlen)1);
/* Is this a definition statement? The presence of DEFINE, INQUIRE or */
/* UNDEFINE at the beginning of the string will confirm this. */
nthwd_(input, &c__1, key, &loc, input_len, (ftnlen)32);
ucase_(key, key, (ftnlen)32, (ftnlen)32);
/* The keyword must be followed by a valid symbol name. */
if (s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0 || s_cmp(key, "INQU"
"IRE", (ftnlen)32, (ftnlen)7) == 0 || s_cmp(key, "UNDEFINE", (
ftnlen)32, (ftnlen)8) == 0) {
nthwd_(input, &c__2, symbl, &loc, input_len, (ftnlen)33);
ucase_(symbl, symbol, (ftnlen)33, (ftnlen)33);
l = rtrim_(symbol, (ftnlen)33);
if (s_cmp(symbol, " ", (ftnlen)33, (ftnlen)1) == 0) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
setmsg_("The \"#\" command must be followed by the name of the s"
"ymbol that you want to #. ", (ftnlen)79);
errch_("#", key, (ftnlen)1, (ftnlen)32);
lcase_(key, key, (ftnlen)32, (ftnlen)32);
errch_("#", key, (ftnlen)1, (ftnlen)32);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (i_indx(alphab, symbol, (ftnlen)32, (ftnlen)1) == 0) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
lcase_(key, key, (ftnlen)32, (ftnlen)32);
setmsg_("You cannot # \"#\". Symbols must begin with a letter ("
"A-Z) ", (ftnlen)58);
errch_("#", key, (ftnlen)1, (ftnlen)32);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (l > 32) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
lcase_(key, key, (ftnlen)32, (ftnlen)32);
setmsg_("You cannot # \"#...\". Symbols may not be longer than "
"32 characters in length.", (ftnlen)77);
errch_("#", key, (ftnlen)1, (ftnlen)32);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (*(unsigned char *)&symbol[l - 1] == '?') {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
lcase_(key, key, (ftnlen)32, (ftnlen)32);
setmsg_("You cannot # \"#\". Symbols may not end with a questio"
"n mark '?'. ", (ftnlen)65);
errch_("#", key, (ftnlen)1, (ftnlen)32);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if ((s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0 || s_cmp(
key, "INQUIRE", (ftnlen)32, (ftnlen)7) == 0) && isrchc_(
symbol, &c__12, resvrd, (ftnlen)33, (ftnlen)32) > 0) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
setmsg_("The word '#' is a reserved word. You may not redefine i"
"t. ", (ftnlen)58);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
}
}
if (s_cmp(key, "INQUIRE", (ftnlen)32, (ftnlen)7) == 0) {
/* First of all we, can only INQUIRE for symbol definitions */
/* if the program is not running in "batch" mode. */
if (batch_()) {
setmsg_("You've attempted to INQUIRE for the value of a symbol w"
"hile the program is running in \"batch\" mode. You can I"
"NQUIRE for a symbol value only if you are running in INT"
"ERACTIVE mode. ", (ftnlen)180);
sigerr_("WRONG_MODE", (ftnlen)10);
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* See if there is anything following the symbol that is */
/* to be defined. This will be used as our prompt value. */
/* Computing MAX */
i__3 = loc + l;
i__1 = loc + l, i__2 = ncpos_(input, " ", &i__3, input_len, (ftnlen)1)
;
nxtchr = max(i__1,i__2);
if (s_cmp(input + (nxtchr - 1), " ", input_len - (nxtchr - 1), (
ftnlen)1) != 0) {
s_copy(myprmt, input + (nxtchr - 1), (ftnlen)80, input_len - (
nxtchr - 1));
} else {
s_copy(myprmt, "Enter definition for", (ftnlen)80, (ftnlen)20);
suffix_(symbol, &c__1, myprmt, (ftnlen)33, (ftnlen)80);
suffix_(">", &c__1, myprmt, (ftnlen)1, (ftnlen)80);
}
getdel_(delim, (ftnlen)1);
rdstmn_(myprmt, delim, def, (ftnlen)80, (ftnlen)1, (ftnlen)1024);
sbset_1__(symbol, def, names, ptrs, buffer, (ftnlen)33, (ftnlen)1024,
(ftnlen)32, (ftnlen)256);
}
/* If this is a definition, and the symbol already exists in the */
/* symbol table, simply replace the existing definition with the */
/* string following the symbol name. If this is a new symbol, */
/* find the first symbol in the list that should follow the new */
/* one. Move the rest of the symbols back, and insert the new one */
/* at this point. */
if (s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0) {
/* Computing MAX */
i__3 = loc + l;
i__1 = loc + l, i__2 = ncpos_(input, " ", &i__3, input_len, (ftnlen)1)
;
nxtchr = max(i__1,i__2);
sbset_1__(symbol, input + (nxtchr - 1), names, ptrs, buffer, (ftnlen)
33, input_len - (nxtchr - 1), (ftnlen)32, (ftnlen)256);
}
if (s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0 || s_cmp(key, "INQU"
"IRE", (ftnlen)32, (ftnlen)7) == 0) {
if (failed_()) {
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* Now check for a recursive definition. To do this we have */
/* two parallel arrays to the NAMES array of the string */
/* buffer. The first array CHECK is used to indicate that */
/* in the course of the definition resolution of the */
/* new symbol, another symbol shows up. The second array */
/* called CHECKD indicats whether or not we have examined this */
/* existing symbol to see if contains the newly created */
/* symbol as part of its definition. */
/* So far we have nothing to check and haven't checked anything. */
n = cardc_(names, (ftnlen)32);
i__1 = n;
for (j = 1; j <= i__1; ++j) {
check[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge("check",
i__2, "stran_", (ftnlen)545)] = FALSE_;
checkd[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge("checkd",
i__2, "stran_", (ftnlen)546)] = FALSE_;
}
/* Find the location of our new symbol in the NAMES cell. */
place = isrchc_(symbol, &n, names + 192, (ftnlen)33, (ftnlen)32);
new__ = TRUE_;
while(new__) {
/* Look up the definition currently associated with */
/* the symbol we are checking. */
sbget_1__(symbol, names, ptrs, buffer, def, &i__, (ftnlen)33, (
ftnlen)32, (ftnlen)256, (ftnlen)1024);
j = 1;
nthuqw_(def, &j, equote, symbol, &loc, (ftnlen)1024, (ftnlen)1, (
ftnlen)33);
while(loc > 0) {
ucase_(symbol, symbol, (ftnlen)33, (ftnlen)33);
slot = isrchc_(symbol, &n, names + 192, (ftnlen)33, (ftnlen)
32);
/* If the word is located in the same place as the */
/* symbol we've just defined, we've introduced */
/* a recursive symbol definition. Remove this */
/* symbol and diagnose the error. */
if (slot == place) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
s_copy(symbol, names + (((i__1 = place + 5) < 206 && 0 <=
i__1 ? i__1 : s_rnge("names", i__1, "stran_", (
ftnlen)582)) << 5), (ftnlen)33, (ftnlen)32);
sbrem_1__(symbol, names, ptrs, buffer, (ftnlen)33, (
ftnlen)32, (ftnlen)256);
setmsg_("The definition of '#' is recursive. Recursivel"
"y defined symbol definitions are not allowed. ", (
ftnlen)93);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("RECURSIVE_SYMBOL", (ftnlen)16);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (slot > 0) {
/* Otherwise if this word is in the names list */
/* we may need to check this symbol to see if */
/* it lists the just defined symbol in its definition. */
if (checkd[(i__1 = slot - 1) < 200 && 0 <= i__1 ? i__1 :
s_rnge("checkd", i__1, "stran_", (ftnlen)602)]) {
check[(i__1 = slot - 1) < 200 && 0 <= i__1 ? i__1 :
s_rnge("check", i__1, "stran_", (ftnlen)603)]
= FALSE_;
} else {
check[(i__1 = slot - 1) < 200 && 0 <= i__1 ? i__1 :
s_rnge("check", i__1, "stran_", (ftnlen)605)]
= TRUE_;
}
}
/* Locate the next unquoted word in the definition. */
++j;
nthuqw_(def, &j, equote, symbol, &loc, (ftnlen)1024, (ftnlen)
1, (ftnlen)33);
}
/* See if there are any new items to check. If there */
/* are create a new value for symbol, and mark the */
/* new item as being checked. */
new__ = FALSE_;
i__1 = n;
for (j = 1; j <= i__1; ++j) {
if (check[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge(
"check", i__2, "stran_", (ftnlen)625)] && ! new__) {
s_copy(symbol, names + (((i__2 = j + 5) < 206 && 0 <=
i__2 ? i__2 : s_rnge("names", i__2, "stran_", (
ftnlen)626)) << 5), (ftnlen)33, (ftnlen)32);
check[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge(
"check", i__2, "stran_", (ftnlen)627)] = FALSE_;
checkd[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge(
"checkd", i__2, "stran_", (ftnlen)628)] = TRUE_;
new__ = TRUE_;
}
}
}
/* If we get to this point, we have a new non-recursively */
/* defined symbol. */
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* If this is a deletion, and the symbol already exists in the */
/* symbol table, simply move the symbols that follow toward the */
/* front of the table. */
if (s_cmp(key, "UNDEFINE", (ftnlen)32, (ftnlen)8) == 0) {
sbrem_1__(symbol, names, ptrs, buffer, (ftnlen)33, (ftnlen)32, (
ftnlen)256);
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* This is not a definition statement. Look for potential symbols. */
/* Try to resolve the first symbol in the string by substituting the */
/* corresponding definition for the existing symbol. */
s_copy(output, input, output_len, input_len);
*tran = FALSE_;
j = 1;
nthuqw_(output, &j, equote, symbol, &loc, output_len, (ftnlen)1, (ftnlen)
33);
while(! (*tran) && s_cmp(symbol, " ", (ftnlen)33, (ftnlen)1) != 0) {
ucase_(symbol, symbol, (ftnlen)33, (ftnlen)33);
sbget_1__(symbol, names, ptrs, buffer, def, &i__, (ftnlen)33, (ftnlen)
32, (ftnlen)256, (ftnlen)1024);
if (i__ > 0) {
lsym = lastnb_(symbol, (ftnlen)33);
ldef = lastnb_(def, (ftnlen)1024) + 1;
lout = lastnb_(output, output_len);
leno = i_len(output, output_len);
if (lout - lsym + ldef > leno) {
*tran = FALSE_;
setmsg_("As a result of attempting to resolve the symbols in"
" the input command, the command has overflowed the a"
"llocated memory. This is may be due to unintentional"
"ly using symbols that you had not intended to use. "
"You may protect portions of your string from symbol "
"evaluation by enclosing that portion of your string "
"between the character # as in 'DO #THIS PART WITHOUT"
" SYMBOLS#' . ", (ftnlen)376);
errch_("#", equote, (ftnlen)1, (ftnlen)1);
errch_("#", equote, (ftnlen)1, (ftnlen)1);
errch_("#", equote, (ftnlen)1, (ftnlen)1);
sigerr_("SYMBOL_OVERFLOW", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
}
i__1 = loc + lsym - 1;
repsub_(output, &loc, &i__1, def, output, output_len, ldef,
output_len);
*tran = TRUE_;
} else {
++j;
}
nthuqw_(output, &j, equote, symbol, &loc, output_len, (ftnlen)1, (
ftnlen)33);
}
chkout_("STRAN", (ftnlen)5);
return 0;
/* The following entry point allows us to set up a search */
/* of defined symbols that match a wild-card pattern. It must */
/* be called prior to getting any symbol definitions. */
L_sympat:
lsttry = 0;
s_copy(pattrn, input, (ftnlen)80, input_len);
return 0;
/* The following entry point fetches the next symbol and its */
/* definition for the next SYMBOL whose name */
/* matches a previously supplied template via the entry point */
/* above --- SYMPAT. */
/* If there is no matching symbol, we get back blanks. Note */
/* that no translation of the definition is performed. */
L_symget:
s_copy(input, " ", input_len, (ftnlen)1);
s_copy(output, " ", output_len, (ftnlen)1);
n = cardc_(names, (ftnlen)32);
while(lsttry < n) {
++lsttry;
gotone = matchm_(names + (((i__1 = lsttry + 5) < 206 && 0 <= i__1 ?
i__1 : s_rnge("names", i__1, "stran_", (ftnlen)767)) << 5),
pattrn, "*", "%", "~", "|", (ftnlen)32, (ftnlen)80, (ftnlen)1,
(ftnlen)1, (ftnlen)1, (ftnlen)1);
if (gotone) {
s_copy(symbol, names + (((i__1 = lsttry + 5) < 206 && 0 <= i__1 ?
i__1 : s_rnge("names", i__1, "stran_", (ftnlen)771)) << 5)
, (ftnlen)33, (ftnlen)32);
s_copy(input, names + (((i__1 = lsttry + 5) < 206 && 0 <= i__1 ?
i__1 : s_rnge("names", i__1, "stran_", (ftnlen)772)) << 5)
, input_len, (ftnlen)32);
sbget_1__(symbol, names, ptrs, buffer, output, &i__, (ftnlen)33, (
ftnlen)32, (ftnlen)256, output_len);
return 0;
}
}
return 0;
} /* stran_ */
/* $Procedure ZZFTPSTR ( Private --- Fetch FTP Validation String ) */
/* Subroutine */ int zzftpstr_(char *tstcom, char *lend, char *rend, char *
delim, ftnlen tstcom_len, ftnlen lend_len, ftnlen rend_len, ftnlen
delim_len)
{
/* Initialized data */
static logical first = TRUE_;
static char locdlm[1] = ":";
static char loclnd[6] = "FTPSTR";
static char locrnd[6] = "ENDFTP";
/* System generated locals */
address a__1[3], a__2[2];
integer i__1[3], i__2[2], i__3;
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen),
s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
char asc000[1], asc010[1], asc013[1], asc016[1], asc206[1], asc129[1];
integer i__;
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen);
static char locstr[16];
char testsq[5*6];
/* $ Abstract */
/* Retrieve the components of the FTP validation string. */
/* $ 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 */
/* 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: Private FTP Validation String Parameters */
/* zzftprms.inc Version 1 01-MAR-1999 (FST) */
/* This include file centralizes the definition of string sizes */
/* and other parameters that are necessary to properly implement */
/* the FTP error detection scheme for binary kernels. */
/* Before making any alterations to the contents of this file, */
/* refer to the header of ZZFTPSTR for a detailed discussion of */
/* the FTP validation string. */
/* Size of FTP Test String Component: */
/* Size of Maximum Expanded FTP Validation String: */
/* (This indicates the size of a buffer to hold the test */
/* string sequence from a possibly corrupt file. Empirical */
/* evidence strongly indicates that expansion due to FTP */
/* corruption at worst doubles the number of characters. */
/* So take 3*SIZSTR to be on the safe side.) */
/* Size of FTP Validation String Brackets: */
/* Size of FTP Validation String: */
/* Size of DELIM. */
/* Number of character clusters present in the validation string. */
/* End Include Section: Private FTP Validation String Parameters */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* TSTCOM O The FTP test component string. */
/* LEND O String that brackets TSTCOM on the left in a file. */
/* REND O String that brackets TSTCOM on the right in a file. */
/* DELIM O Delimiter that separates the pieces of TSTCOM. */
/* $ Detailed_Input */
/* None. */
/* $ Detailed_Output */
/* TSTCOM is a string composed of clusters of characters that */
/* are susceptible to FTP ASCII mode transfer corruption, */
/* separated by the DELIM character. For example: */
/* :<CLUSTR(1)>:<CLUSTR(2):... */
/* ...<CLUSTR(N)>: */
/* where <CLUSTR(I)> is one cluster of characters that */
/* is subject to improper FTP corruption. The string */
/* that is to receive this value should be SIZSTR */
/* characters in length. */
/* LEND, are the two sequences of printing characters that */
/* REND bracket TSTCOM in the binary file. Their purpose is */
/* to permit proper detection of TSTCOM in the event */
/* of compression or expansion, due to improper FTP */
/* transfer. The variables which are to receive these */
/* values should be SIZEND characters in length. */
/* DELIM is the printing character delimiter that separates the */
/* test character clusters from one another, as well as */
/* LEND and REND. Since it is often the case that pairs */
/* or triples of non-printing characters will trigger */
/* FTP corruption, this delimiter blocks any unintended */
/* interaction. */
/* $ Parameters */
/* 1) See include file zzftprms.inc */
/* 2) Since inserting non-printing characters into strings is a */
/* somewhat arduous task requiring extensive use of the intrinsic */
/* CHAR, integer parameters that map to the needed ASCII codes are */
/* defined with variable names INT###, where ### is replaced with */
/* the three digit ASCII integer code. For each such integer */
/* code, there is a corresponding character parameter whose name */
/* is of the form ASC###. For example: */
/* INT010 = 10 -> ASC010 = <10> or <LF> */
/* INT206 = 206 -> ASC206 = <206> */
/* where <#> refers to CHAR(#) or CHAR(ICHAR('#')) in the case of */
/* LF(line feed). */
/* These naming conventions should be preserved when the FTP */
/* validation string is updated. */
/* $ Files */
/* While this routine is designed to aid in the detection of */
/* improper FTP transfers, it simply returns the candidate */
/* string for validation and does not interact with any */
/* files directly. */
/* $ Exceptions */
/* Error Free. */
/* $ Particulars */
/* To minimize code alterations in the event of a string update, */
/* the calling routine that declares the variables to receive */
/* the strings stored here should include zzftprms.inc and utilize */
/* the size parameters defined there as recommended in the Detailed */
/* I/O sections above. */
/* This private SPICELIB routine is designed to centralize the */
/* definition of the FTP validation string present in binary */
/* SPICE kernels. If in the process of FTP'ing a binary */
/* file from one platform to another, the user neglects to */
/* invoke the IMAGE (BINARY) transfer mode, an ASCII mode */
/* transfer may occur. As this at the very least may substitute */
/* one set of line terminators for another, corruption of the */
/* binary file is likely. By placing a string that encapsulates */
/* a representative set of these character sequences that are */
/* susceptible to corruption in the file record, it is possible */
/* to trap and report any problems to the user when corrupted */
/* kernels are loaded at run time. */
/* To that end, analysis of evidence obtained by moving test binary */
/* files from one platform to another indicates the following */
/* clusters of ASCII codes are likely candidates for corruption: */
/* Test Clusters: */
/* <13> - Text line terminator on Macintosh-based platforms. */
/* <10> - Text line terminator on UNIX-based platforms. */
/* <13><10> - Text line terminator on Microsoft platforms. */
/* <13><0> - Sequence of characters that maps into <13> on some */
/* UNIX-based systems. (HP, SGI, NEXT) */
/* <129> - Macintosh based systems permute ASCII values whose */
/* parity bit is set. Codes in excess of ASCII */
/* 127 are altered. */
/* <16><206> - Some ancient FTP servers on PC's convert this */
/* sequence of ASCII characters to <16><16><206>. */
/* The examples above show that substitution of one set of line */
/* terminators for another can result in expansion or compression of */
/* certain sequences of bytes. If the clusters were juxtaposed, new */
/* sequences of adjacent bytes, themselves subject to transformation, */
/* might be formed. So the FTP test string present in the binary */
/* file should have some mechanism for preventing interaction between */
/* the clusters. The test string should also be constructed so that */
/* it can be easily located in the event compression or expansion, */
/* either internally or elsewhere in the file record, shifts it away */
/* from its default location. */
/* So by separating these clusters with a printable delimiter, then */
/* bracketing the entire test string with start and stop identifiers, */
/* we have a reasonable mechanism for locating and analyzing any */
/* potential FTP corruption. Then the sequence of characters to be */
/* inserted into the file will appear as: */
/* FTPSTR:<13>:<10>:<13><10>:<13><0>:<129>:<16><206>:ENDFTP */
/* where 'FTPSTR' and 'ENDFTP' are the bracketing substrings and */
/* ':' is the delimiting character. */
/* By no means do we claim that these are the complete set of */
/* clusters that are corruptible through an improper FTP transfer. */
/* An update procedure is provided in the Revisions section just */
/* after the routine header. Following this procedure will require */
/* the least amount of effort to prevent older files from falsely */
/* indicating corruption under new Toolkits, as well as newer files */
/* failing on old Toolkits. */
/* $ Examples */
/* This routine just fetches the components of the FTP validation */
/* string. */
/* $ Restrictions */
/* 1) TSTCOM, LEND, REND, and DELIM must be large enough to hold */
/* the entire values returned by this routine, otherwise */
/* truncation will occur. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 21-MAR-1999 (FST) */
/* -& */
/* $ Index_Entries */
/* fetch the ftp validation string components */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.0.0, 21-MAR-1999 (FST) */
/* FTP validation string update procedure: */
/* (1) Leave 'FTPSTR', 'ENDFTP', and ':' alone, as */
/* their alteration will require special */
/* consideration for older files. */
/* (2) Leave the existing test clusters in the */
/* existing order, and place any new clusters */
/* between the last ':' and the E in 'ENDFTP'. */
/* Make certain these are ':' delimited as well. */
/* (3) Modify the contents of zzftprms.inc to */
/* indicate the new sizes of the various string */
/* components. Routines that include this must */
/* then be recompiled. */
/* -& */
/* Local Parameters */
/* Maximum size of an individual test cluster component */
/* including the ':'. */
/* Integer codes of characters appearing in test clusters. */
/* Local Variables */
/* Non-printing character values. */
/* Saved Variables */
/* Data Statements */
/* Set up the components of the FTP validation string that */
/* are not supposed to change for forward and backward */
/* compatibility. */
/* On the first invocation initialize the string values. */
if (first) {
/* Convert the integer parameters to their non-printing ASCII */
/* equivalents. */
*(unsigned char *)asc000 = '\0';
*(unsigned char *)asc010 = '\n';
*(unsigned char *)asc013 = '\r';
*(unsigned char *)asc016 = '\20';
*(unsigned char *)asc129 = 129;
*(unsigned char *)asc206 = 206;
/* Now build the individual components of the test clusters. */
/* Make certain the first component begins and ends with a ':', */
/* and that the remaining pieces end in ':'. If you intend to */
/* add some clusters, then append them to the end of the */
/* sequence so as not to break the existing detection code. */
/* Cluster #1 : <CR> - <13> - Macintosh Line Terminator */
/* Writing concatenation */
i__1[0] = 1, a__1[0] = locdlm;
i__1[1] = 1, a__1[1] = asc013;
i__1[2] = 1, a__1[2] = locdlm;
s_cat(testsq, a__1, i__1, &c__3, (ftnlen)5);
/* Cluster #2 : <LF> - <10> - Unix Line Terminator */
/* Writing concatenation */
i__2[0] = 1, a__2[0] = asc010;
i__2[1] = 1, a__2[1] = locdlm;
s_cat(testsq + 5, a__2, i__2, &c__2, (ftnlen)5);
/* Cluster #3 : <CR><LF> - <10><13> - Microsoft Line Terminator */
/* Writing concatenation */
i__1[0] = 1, a__1[0] = asc013;
i__1[1] = 1, a__1[1] = asc010;
i__1[2] = 1, a__1[2] = locdlm;
s_cat(testsq + 10, a__1, i__1, &c__3, (ftnlen)5);
/* Cluster #4 : <13><0> */
/* Writing concatenation */
i__1[0] = 1, a__1[0] = asc013;
i__1[1] = 1, a__1[1] = asc000;
i__1[2] = 1, a__1[2] = locdlm;
s_cat(testsq + 15, a__1, i__1, &c__3, (ftnlen)5);
/* Cluster #5 : <129> - Macintosh Permutation of Parity Codes */
/* Writing concatenation */
i__2[0] = 1, a__2[0] = asc129;
i__2[1] = 1, a__2[1] = locdlm;
s_cat(testsq + 20, a__2, i__2, &c__2, (ftnlen)5);
/* Cluster #6 : <16><206> */
/* Writing concatenation */
i__1[0] = 1, a__1[0] = asc016;
i__1[1] = 1, a__1[1] = asc206;
i__1[2] = 1, a__1[2] = locdlm;
s_cat(testsq + 25, a__1, i__1, &c__3, (ftnlen)5);
/* Sample cluster addition code follows */
/* Cluster #7 : <xxx> - Description */
/* TESTSQ(7) = ASCxxx // ... // LOCDLM */
/* Now build the local copy of TSTCOM, LOCSTR. First clear the */
/* uninitialized contents. */
s_copy(locstr, " ", (ftnlen)16, (ftnlen)1);
for (i__ = 1; i__ <= 6; ++i__) {
/* Append TESTSQ(I) to LOCSTR to properly construct the */
/* test component of the FTP validation string. */
suffix_(testsq + ((i__3 = i__ - 1) < 6 && 0 <= i__3 ? i__3 :
s_rnge("testsq", i__3, "zzftpstr_", (ftnlen)399)) * 5, &
c__0, locstr, (ftnlen)5, (ftnlen)16);
}
/* Prevent execution of this initialization code after first pass. */
first = FALSE_;
}
/* Copy the local copies of the FTP string components to the */
/* arguments passed in from the caller. */
s_copy(tstcom, locstr, tstcom_len, (ftnlen)16);
s_copy(lend, loclnd, lend_len, (ftnlen)6);
s_copy(rend, locrnd, rend_len, (ftnlen)6);
s_copy(delim, locdlm, delim_len, (ftnlen)1);
return 0;
} /* zzftpstr_ */
/* $Procedure SAELGV ( Semi-axes of ellipse from generating vectors ) */
/* Subroutine */ int saelgv_(doublereal *vec1, doublereal *vec2, doublereal *
smajor, doublereal *sminor)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
extern doublereal vdot_(doublereal *, doublereal *);
doublereal c__[4] /* was [2][2] */;
integer i__;
doublereal s[4] /* was [2][2] */, scale;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer major;
extern /* Subroutine */ int moved_(doublereal *, integer *, doublereal *),
vlcom_(doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
integer minor;
extern doublereal vnorm_(doublereal *);
extern /* Subroutine */ int diags2_(doublereal *, doublereal *,
doublereal *);
doublereal tmpvc1[3], tmpvc2[3];
extern /* Subroutine */ int cleard_(integer *, doublereal *);
doublereal eigval[4] /* was [2][2] */;
extern /* Subroutine */ int chkout_(char *, ftnlen), vsclip_(doublereal *,
doublereal *);
extern logical return_(void);
/* $ Abstract */
/* Find semi-axis vectors of an ellipse generated by two arbitrary */
/* three-dimensional vectors. */
/* $ 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 */
/* ELLIPSES */
/* $ Keywords */
/* ELLIPSE */
/* GEOMETRY */
/* MATH */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* VEC1, */
/* VEC2 I Two vectors used to generate an ellipse. */
/* SMAJOR O Semi-major axis of ellipse. */
/* SMINOR O Semi-minor axis of ellipse. */
/* $ Detailed_Input */
/* VEC1, */
/* VEC2 are two vectors that define an ellipse. */
/* The ellipse is the set of points in 3-space */
/* CENTER + cos(theta) VEC1 + sin(theta) VEC2 */
/* where theta is in the interval ( -pi, pi ] and */
/* CENTER is an arbitrary point at which the ellipse */
/* is centered. An ellipse's semi-axes are */
/* independent of its center, so the vector CENTER */
/* shown above is not an input to this routine. */
/* VEC2 and VEC1 need not be linearly independent; */
/* degenerate input ellipses are allowed. */
/* $ Detailed_Output */
/* SMAJOR */
/* SMINOR are semi-major and semi-minor axes of the ellipse, */
/* respectively. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If one or more semi-axes of the ellipse is found to be the */
/* zero vector, the input ellipse is degenerate. This case is */
/* not treated as an error; the calling program must determine */
/* whether the semi-axes are suitable for the program's intended */
/* use. */
/* $ Files */
/* None. */
/* $ Particulars */
/* Two linearly independent but not necessarily orthogonal vectors */
/* VEC1 and VEC2 can define an ellipse centered at the origin: the */
/* ellipse is the set of points in 3-space */
/* CENTER + cos(theta) VEC1 + sin(theta) VEC2 */
/* where theta is in the interval (-pi, pi] and CENTER is an */
/* arbitrary point at which the ellipse is centered. */
/* This routine finds vectors that constitute semi-axes of an */
/* ellipse that is defined, except for the location of its center, */
/* by VEC1 and VEC2. The semi-major axis is a vector of largest */
/* possible magnitude in the set */
/* cos(theta) VEC1 + sin(theta) VEC2 */
/* There are two such vectors; they are additive inverses of each */
/* other. The semi-minor axis is an analogous vector of smallest */
/* possible magnitude. The semi-major and semi-minor axes are */
/* orthogonal to each other. If SMAJOR and SMINOR are choices of */
/* semi-major and semi-minor axes, then the input ellipse can also */
/* be represented as the set of points */
/* CENTER + cos(theta) SMAJOR + sin(theta) SMINOR */
/* where theta is in the interval (-pi, pi]. */
/* The capability of finding the axes of an ellipse is useful in */
/* finding the image of an ellipse under a linear transformation. */
/* Finding this image is useful for determining the orthogonal and */
/* gnomonic projections of an ellipse, and also for finding the limb */
/* and terminator of an ellipsoidal body. */
/* $ Examples */
/* 1) An example using inputs that can be readily checked by */
/* hand calculation. */
/* Let */
/* VEC1 = ( 1.D0, 1.D0, 1.D0 ) */
/* VEC2 = ( 1.D0, -1.D0, 1.D0 ) */
/* The subroutine call */
/* CALL SAELGV ( VEC1, VEC2, SMAJOR, SMINOR ) */
/* returns */
/* SMAJOR = ( -1.414213562373095D0, */
/* 0.0D0, */
/* -1.414213562373095D0 ) */
/* and */
/* SMINOR = ( -2.4037033579794549D-17 */
/* 1.414213562373095D0, */
/* -2.4037033579794549D-17 ) */
/* 2) This example is taken from the code of the SPICELIB routine */
/* PJELPL, which finds the orthogonal projection of an ellipse */
/* onto a plane. The code listed below is the portion used to */
/* find the semi-axes of the projected ellipse. */
/* C */
/* C Project vectors defining axes of ellipse onto plane. */
/* C */
/* CALL VPERP ( VEC1, NORMAL, PROJ1 ) */
/* CALL VPERP ( VEC2, NORMAL, PROJ2 ) */
/* . */
/* . */
/* . */
/* CALL SAELGV ( PROJ1, PROJ2, SMAJOR, SMINOR ) */
/* The call to SAELGV determines the required semi-axes. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* [1] Calculus, Vol. II. Tom Apostol. John Wiley & Sons, 1969. */
/* See Chapter 5, `Eigenvalues of Operators Acting on Euclidean */
/* Spaces'. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.1, 22-APR-2010 (NJB) */
/* Header correction: assertions that the output */
/* can overwrite the input have been removed. */
/* - SPICELIB Version 1.1.0, 02-SEP-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in VSCL calls. */
/* - 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, 02-NOV-1990 (NJB) (WLT) */
/* -& */
/* $ Index_Entries */
/* semi-axes of ellipse from generating vectors */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.1.0, 02-SEP-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in VSCL calls. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SAELGV", (ftnlen)6);
}
/* Let the notation */
/* < a, b > */
/* indicate the inner product of the vectors a and b. */
/* The semi-major and semi-minor axes of the input ellipse are */
/* vectors of maximum and minimum norm in the set */
/* cos(x) VEC1 + sin(x) VEC2 */
/* where x is in the interval (-pi, pi]. */
/* The square of the norm of a vector in this set is */
/* 2 */
/* || cos(x) VEC1 + sin(x) VEC2 || */
/* = < cos(x)VEC1 + sin(x)VEC2, cos(x)VEC1 + sin(x)VEC2 > ; */
/* this last expression can be written as the matrix product */
/* T */
/* X S X, (1) */
/* where X is the unit vector */
/* +- -+ */
/* | cos(x) | */
/* | | */
/* | sin(x) | */
/* +- -+ */
/* and S is the symmetric matrix */
/* +- -+ */
/* | < VEC1, VEC1 > < VEC1, VEC2 > | */
/* | |. */
/* | < VEC1, VEC2 > < VEC2, VEC2 > | */
/* +- -+ */
/* Because the 2x2 matrix above is symmetric, there exists a */
/* rotation matrix that allows us to diagonalize it: */
/* T */
/* C S C = D, */
/* where D is a diagonal matrix. Since rotation matrices are */
/* orthogonal, we have */
/* T */
/* C C = I. */
/* If the unit vector U is defined by */
/* T */
/* U = C X, */
/* then */
/* T T T T T */
/* X S X = ( U C ) C D C ( C U ) = U D U. */
/* So, letting */
/* +- -+ */
/* | u | */
/* | | = U, */
/* | v | */
/* +- -+ */
/* we may re-write the original quadratic expression (1) as */
/* +- -+ +- -+ +- -+ */
/* | u v | | D1 0 | | u |, */
/* +- -+ | | | | */
/* | | | v | */
/* | 0 D2 | +- -+ */
/* +- -+ */
/* or */
/* 2 2 */
/* D1 u + D2 v, */
/* where the diagonal matrix above is D. The eigenvalues D1 and */
/* D2 are non-negative because they are eigenvalues of a positive */
/* semi-definite matrix of the form */
/* T */
/* M M. */
/* We may require that */
/* D1 > D2; */
/* - */
/* then the maximum and minimum values of */
/* 2 2 */
/* D1 u + D2 v (2) */
/* are D1 and D2 respectively. These values are the squares */
/* of the lengths of the semi-major and semi-minor axes of the */
/* ellipse, since the expression (2) is the square of the norm */
/* of the point */
/* cos(x) VEC1 + sin(x) VEC2. */
/* Now we must find some eigenvectors. Since the extrema of (2) */
/* occur when */
/* +- -+ +- -+ */
/* | 1 | | 0 | */
/* U = | | or U = | |, */
/* | 0 | | 1 | */
/* +- -+ +- -+ */
/* and since */
/* X = C U, */
/* we conclude that the extrema occur when X = C1 or X = C2, where */
/* C1 and C2 are the first and second columns of C. Looking at */
/* the definition of X, we see that the extrema occur when */
/* cos(x) = C1(1) */
/* sin(x) = C1(2) */
/* and when */
/* cos(x) = C2(1), */
/* sin(x) = C2(2) */
/* So the semi-major and semi-minor axes of the ellipse are */
/* C(1,1) VEC1 + C(2,1) VEC2 */
/* and */
/* C(1,2) VEC1 + C(2,2) VEC2 */
/* (the negatives of these vectors are also semi-axes). */
/* Copy the input vectors. */
moved_(vec1, &c__3, tmpvc1);
moved_(vec2, &c__3, tmpvc2);
/* Scale the vectors to try to prevent arithmetic unpleasantness. */
/* We avoid using the quotient 1/SCALE, as this value may overflow. */
/* No need to go further if SCALE turns out to be zero. */
/* Computing MAX */
d__1 = vnorm_(tmpvc1), d__2 = vnorm_(tmpvc2);
scale = max(d__1,d__2);
if (scale == 0.) {
cleard_(&c__3, smajor);
cleard_(&c__3, sminor);
chkout_("SAELGV", (ftnlen)6);
return 0;
}
for (i__ = 1; i__ <= 3; ++i__) {
tmpvc1[(i__1 = i__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge("tmpvc1",
i__1, "saelgv_", (ftnlen)435)] = tmpvc1[(i__2 = i__ - 1) < 3
&& 0 <= i__2 ? i__2 : s_rnge("tmpvc1", i__2, "saelgv_", (
ftnlen)435)] / scale;
tmpvc2[(i__1 = i__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge("tmpvc2",
i__1, "saelgv_", (ftnlen)436)] = tmpvc2[(i__2 = i__ - 1) < 3
&& 0 <= i__2 ? i__2 : s_rnge("tmpvc2", i__2, "saelgv_", (
ftnlen)436)] / scale;
}
/* Compute S and diagonalize it: */
s[0] = vdot_(tmpvc1, tmpvc1);
s[1] = vdot_(tmpvc1, tmpvc2);
s[2] = s[1];
s[3] = vdot_(tmpvc2, tmpvc2);
diags2_(s, eigval, c__);
/* Find the semi-axes. */
if (abs(eigval[0]) >= abs(eigval[3])) {
/* The first eigenvector ( first column of C ) corresponds */
/* to the semi-major axis of the ellipse. */
major = 1;
minor = 2;
} else {
/* The second eigenvector corresponds to the semi-major axis. */
major = 2;
minor = 1;
}
vlcom_(&c__[(i__1 = (major << 1) - 2) < 4 && 0 <= i__1 ? i__1 : s_rnge(
"c", i__1, "saelgv_", (ftnlen)469)], tmpvc1, &c__[(i__2 = (major
<< 1) - 1) < 4 && 0 <= i__2 ? i__2 : s_rnge("c", i__2, "saelgv_",
(ftnlen)469)], tmpvc2, smajor);
vlcom_(&c__[(i__1 = (minor << 1) - 2) < 4 && 0 <= i__1 ? i__1 : s_rnge(
"c", i__1, "saelgv_", (ftnlen)470)], tmpvc1, &c__[(i__2 = (minor
<< 1) - 1) < 4 && 0 <= i__2 ? i__2 : s_rnge("c", i__2, "saelgv_",
(ftnlen)470)], tmpvc2, sminor);
/* Undo the initial scaling. */
vsclip_(&scale, smajor);
vsclip_(&scale, sminor);
chkout_("SAELGV", (ftnlen)6);
return 0;
} /* saelgv_ */
/* $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 DASSDR ( DAS, segregate data records ) */
/* Subroutine */ int dassdr_(integer *handle)
{
/* Initialized data */
static integer next[3] = { 2,3,1 };
static integer prev[3] = { 3,1,2 };
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
integer base;
char crec[1024];
doublereal drec[128];
integer free, irec[256], lrec, dest;
logical more;
integer unit, type__, i__, j, n;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer ncomc;
extern /* Subroutine */ int maxai_(integer *, integer *, integer *,
integer *);
char savec[1024];
doublereal saved[128];
integer recno, savei[256];
extern integer sumai_(integer *, integer *);
integer ncomr, total, lword, count[4], ltype, start;
extern logical failed_(void);
extern /* Subroutine */ int dasadi_(integer *, integer *, integer *),
cleari_(integer *, integer *);
integer drbase;
extern /* Subroutine */ int dasioc_(char *, integer *, integer *, char *,
ftnlen, ftnlen), dasiod_(char *, integer *, integer *, doublereal
*, ftnlen), dasllc_(integer *), dasrdi_(integer *, integer *,
integer *, integer *), dashfs_(integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *),
dasudi_(integer *, integer *, integer *, integer *);
integer minadr, maxadr, scrhan, lastla[3];
extern /* Subroutine */ int dassih_(integer *, char *, ftnlen), dashlu_(
integer *, integer *), daswbr_(integer *), dasrri_(integer *,
integer *, integer *, integer *, integer *);
integer offset;
extern /* Subroutine */ int dasioi_(char *, integer *, integer *, integer
*, ftnlen);
integer lastrc[3];
extern /* Subroutine */ int dasops_(integer *), dasufs_(integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *), chkout_(char *, ftnlen);
integer lastwd[3], nresvc;
extern logical return_(void);
integer nresvr, savtyp, prvtyp, loc, pos;
/* $ Abstract */
/* Segregate the data records in a DAS file into clusters, using */
/* one cluster per data type present in the 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. */
/* $ Required_Reading */
/* DAS */
/* $ Keywords */
/* DAS */
/* FILES */
/* ORDER */
/* SORT */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I DAS file handle. */
/* $ Detailed_Input */
/* HANDLE is a file handle of a DAS file opened for writing. */
/* $ Detailed_Output */
/* None. See $Particulars for a description of the effect of this */
/* routine. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the input file handle is invalid, the error will be */
/* diagnosed by routines called by this routine. */
/* 2) If a Fortran read attempted by this routine fails, the */
/* error will be diagnosed by routines called by this routine. */
/* The state of the DAS file undergoing re-ordering will be */
/* indeterminate. */
/* 3) If a Fortran write attempted by this routine fails, the */
/* error will be diagnosed by routines called by this routine. */
/* The state of the DAS file undergoing re-ordering will be */
/* indeterminate. */
/* 4) If any other I/O error occurs during the re-arrangement of */
/* the records in the indicated DAS file, the error will be */
/* diagnosed by routines called by this routine. */
/* $ Files */
/* See the description of the argument HANDLE in $Detailed_Input. */
/* $ Particulars */
/* Normally, there should be no need for routines outside of */
/* SPICELIB to call this routine. */
/* The effect of this routine is to re-arrange the data records */
/* in a DAS file so that the file contains a single cluster for */
/* each data type present in the file: in the general case, there */
/* will be a single cluster of each of the integer, double */
/* precision, and character data types. */
/* The relative order of data records of a given type is not */
/* affected by this re-ordering. After the re-ordering, the DAS */
/* file contains a single directory record that has one descriptor */
/* for each cluster. After that point, the order in the file of the */
/* sets of data records of the various data types will be: */
/* +-------+ */
/* | CHAR | */
/* +-------+ */
/* | DP | */
/* +-------+ */
/* | INT | */
/* +-------+ */
/* Files that contain multiple directory records will have all but */
/* the first directory record moved to the end of the file when the */
/* re-ordering is complete. These records are not visible to the */
/* DAS system and will be overwritten if data is subsequently added */
/* to the DAS file. */
/* The purpose of segregating a DAS file's data records into three */
/* clusters is to make read access more efficient: when a DAS file */
/* contains a single directory with at most three cluster type */
/* descriptors, mapping logical to physical addresses can be done */
/* in constant time. */
/* $ Examples */
/* 1) Segregate data records in a DAS file designated by */
/* HANDLE: */
/* CALL DASSDR ( HANDLE ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 2.0.1 19-DEC-1995 (NJB) */
/* Corrected title of permuted index entry section. */
/* - EKLIB Version 2.0.0, 17-NOV-1993 (KRG) */
/* Added test of FAILED after each DAS call, or sequence of calls, */
/* which returns immediately if FAILED is true. This fixes a bug */
/* where DASOPS signals an error and then DASSDR has a */
/* segmentation fault. */
/* Removed references to specific DAS file open routines in the */
/* $ Detailed_Input section of the header. This was done in order */
/* to minimize documentation changes if the DAS open routines ever */
/* change. */
/* - EKLIB Version 1.2.0, 07-OCT-1993 (NJB) (HAN) (MJS) */
/* Bug fix: call to CLEARD replaced with call to */
/* CLEARI. */
/* - EKLIB Version 1.1.0, 08-JUL-1993 (NJB) (MJS) */
/* Bug fix: extraneous commas removed from argument lists */
/* in calls to DASADI. */
/* - SPICELIB Version 1.0.0, 11-NOV-1992 (NJB) (WLT) */
/* -& */
/* $ Index_Entries */
/* segregate the data records in a DAS file */
/* -& */
/* $ Revisions */
/* - EKLIB Version 2.0.0, 17-NOV-1993 (KRG) */
/* Added test of failed after each DAS call, or sequence of calls, */
/* which returns immediately if FAILED is true. This fixes a bug */
/* where DASOPS signals an error and then DASSDR has a */
/* segmentation fault. */
/* Removed references to specific DAS file open routines in the */
/* $ Detailed_Input section of the header. This was done in order */
/* to minimize documentation changes if the DAS open routines ever */
/* change. */
/* - EKLIB Version 1.2.0, 07-OCT-1993 (NJB) (HAN) (MJS) */
/* Bug fix: call to CLEARD replaced with call to */
/* CLEARI. */
/* - EKLIB Version 1.1.0, 08-JUL-1993 (NJB) */
/* Bug fix: extraneous commas removed from argument lists */
/* in calls to DASADI. This bug had no visible effect on */
/* VAX and Sun systems, but generated a compile error under */
/* Lahey Fortran. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Data type parameters */
/* Directory pointer locations (backward and forward): */
/* Directory address range location base */
/* Location of first type descriptor */
/* Local variables */
/* Saved variables */
/* NEXT and PREV map the DAS data type codes to their */
/* successors and predecessors, respectively. */
/* Initial values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("DASSDR", (ftnlen)6);
}
/* Before starting, make sure that this DAS file is open for */
/* writing. */
dassih_(handle, "WRITE", (ftnlen)5);
/* Get the logical unit for this file. */
dashlu_(handle, &unit);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
/* Write out any buffered records that belong to the file. */
daswbr_(handle);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
/* We're going to re-order the physical records in the DAS file, */
/* starting with the first record after the first directory. */
/* The other directory records are moved to the end of the file */
/* as a result of the re-ordering. */
/* The re-ordering algorithm is based on that used in the REORDx */
/* routines. To use this algorithm, we'll build an order vector */
/* for the records to be ordered; we'll construct this order vector */
/* in a scratch DAS file. First, we'll traverse the directories */
/* to build up a sort of inverse order vector that tells us the */
/* final destination and data type of each data record; from this */
/* inverse vector we can easily build a true order vector. The */
/* cycles of the true order vector can be traversed without */
/* repetitive searching, and with a minimum of assignment of the */
/* contents of data records to temporary variables. */
/* Allocate a scratch DAS file to keep our vectors in. */
dasops_(&scrhan);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
/* Now build up our `inverse order vector'. This array is an */
/* inverse order vector only in loose sense: it actually consists */
/* of an integer array that contains a sequence of pairs of integers, */
/* the first of which indicates a data type, and the second of which */
/* is an ordinal number. There is one pair for each data record in */
/* the file. The ordinal number gives the ordinal position of the */
/* record described by the number pair, relative to the other records */
/* of the same type. Directory records are considered to have type */
/* `directory', which is represented by the code DIR. */
/* We also must maintain a count of records of each type. */
cleari_(&c__4, count);
/* Get the file summary for the DAS file to be segregated. */
dashfs_(handle, &nresvr, &nresvc, &ncomr, &ncomc, &free, lastla, lastrc,
lastwd);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
/* Find the record and word positions LREC and LWORD of the last */
/* descriptor in the file, and also find the type of the descriptor */
/* LTYPE. */
maxai_(lastrc, &c__3, &lrec, &loc);
lword = 0;
for (i__ = 1; i__ <= 3; ++i__) {
if (lastrc[(i__1 = i__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge("lastrc",
i__1, "dassdr_", (ftnlen)451)] == lrec && lastwd[(i__2 = i__
- 1) < 3 && 0 <= i__2 ? i__2 : s_rnge("lastwd", i__2, "dassd"
"r_", (ftnlen)451)] > lword) {
lword = lastwd[(i__1 = i__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
"lastwd", i__1, "dassdr_", (ftnlen)454)];
ltype = i__;
}
}
/* The first directory starts after the last comment record. */
recno = nresvr + ncomr + 2;
while(recno <= lrec && recno > 0) {
/* Read the directory record. */
dasrri_(handle, &recno, &c__1, &c__256, irec);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
/* Increment the directory count. */
++count[3];
/* Add the data type (`directory') and count (1) of the current */
/* record to the inverse order vector. */
dasadi_(&scrhan, &c__1, &c__4);
dasadi_(&scrhan, &c__1, &count[3]);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
/* Set up our `finite state machine' that tells us the data */
/* types of the records described by the last read directory. */
type__ = irec[8];
prvtyp = prev[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
"prev", i__1, "dassdr_", (ftnlen)498)];
/* Now traverse the directory and update the inverse order */
/* vector based on the descriptors we find. */
more = TRUE_;
i__ = 10;
while(more) {
/* Obtain the count for the current descriptor. */
n = (i__2 = irec[(i__1 = i__ - 1) < 256 && 0 <= i__1 ? i__1 :
s_rnge("irec", i__1, "dassdr_", (ftnlen)512)], abs(i__2));
/* Update our inverse order vector to describe the positions */
/* of the N records described by the current descriptor. */
i__1 = n;
for (j = 1; j <= i__1; ++j) {
dasadi_(&scrhan, &c__1, &type__);
i__3 = count[(i__2 = type__ - 1) < 4 && 0 <= i__2 ? i__2 :
s_rnge("count", i__2, "dassdr_", (ftnlen)521)] + j;
dasadi_(&scrhan, &c__1, &i__3);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
}
/* Adjust the count of records of data type TYPE. */
count[(i__1 = type__ - 1) < 4 && 0 <= i__1 ? i__1 : s_rnge("count"
, i__1, "dassdr_", (ftnlen)533)] = count[(i__2 = type__ -
1) < 4 && 0 <= i__2 ? i__2 : s_rnge("count", i__2, "dass"
"dr_", (ftnlen)533)] + n;
/* Find the next type. */
++i__;
if (i__ > 256 || recno == lrec && i__ > lword) {
more = FALSE_;
} else {
if (irec[(i__1 = i__ - 1) < 256 && 0 <= i__1 ? i__1 : s_rnge(
"irec", i__1, "dassdr_", (ftnlen)547)] > 0) {
type__ = next[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1
: s_rnge("next", i__1, "dassdr_", (ftnlen)548)];
} else if (irec[(i__1 = i__ - 1) < 256 && 0 <= i__1 ? i__1 :
s_rnge("irec", i__1, "dassdr_", (ftnlen)550)] < 0) {
type__ = prev[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1
: s_rnge("prev", i__1, "dassdr_", (ftnlen)551)];
} else {
more = FALSE_;
}
}
}
/* The forward pointer in this directory tells us where the */
/* next directory record is. When there are no more directory */
/* records, this pointer will be zero. */
recno = irec[1];
}
/* At this point, the inverse order vector is set up. The array */
/* COUNT contains counts of the number of records of each type we've */
/* seen. Set TOTAL to the total number of records that we've going */
/* to permute. */
total = sumai_(count, &c__4);
/* The next step is to build a true order vector. Let BASE be */
/* the base address for the order vector; this address is the */
/* last logical address of the inverse order vector. */
base = total << 1;
/* We'll store the actual order vector in locations BASE + 1 */
/* through BASE + TOTAL. In addition, we'll build a parallel array */
/* that contains, for each element of the order vector, the type of */
/* data corresponding to that element. This type vector will */
/* reside in locations BASE + TOTAL + 1 through BASE + 2*TOTAL. */
/* Before setting the values of the order vector and its parallel */
/* type vector, we'll allocate space in the scratch DAS file by */
/* zeroing out the locations we plan to use. After this, locations */
/* BASE+1 through BASE + 2*TOTAL can be written to in random access */
/* fashion using DASUDI. */
i__1 = total << 1;
for (i__ = 1; i__ <= i__1; ++i__) {
dasadi_(&scrhan, &c__1, &c__0);
}
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
/* We note that the way to construct the inverse of a permutation */
/* SIGMA in a single loop is suggested by the relation */
/* -1 */
/* SIGMA ( SIGMA(I) ) = I */
/* We'll use this method. In our case, our order vector plays */
/* the role of */
/* -1 */
/* SIGMA */
/* and the `inverse order vector' plays the role of SIGMA. We'll */
/* exclude the first directory from the order vector, since it's */
/* an exception: we wish to reserve this record. Since the first */
/* element of the order vector (logically) contains the index 1, we */
/* can ignore it. */
i__1 = total;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = (i__ << 1) - 1;
i__3 = (i__ << 1) - 1;
dasrdi_(&scrhan, &i__2, &i__3, &type__);
i__2 = i__ << 1;
i__3 = i__ << 1;
dasrdi_(&scrhan, &i__2, &i__3, &dest);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
/* Set DEST to the destination location, measured as an offset */
/* from the last comment record, of the Ith record by adding */
/* on the count of the predecessors of the block of records of */
/* TYPE. */
for (j = 1; j <= 3; ++j) {
if (type__ > j) {
dest += count[(i__2 = j - 1) < 4 && 0 <= i__2 ? i__2 : s_rnge(
"count", i__2, "dassdr_", (ftnlen)648)];
}
}
/* The destination offset of each record should be incremented to */
/* allow room for the first directory record. However, we don't */
/* need to do this for directory records; they'll already have */
/* this offset accounted for. */
if (type__ != 4) {
++dest;
}
/* The value of element DEST of the order vector is I. */
/* Write this value to location BASE + DEST. */
i__2 = base + dest;
i__3 = base + dest;
dasudi_(&scrhan, &i__2, &i__3, &i__);
/* We want the ith element of the order vector to give us the */
/* number of the record to move to position i (offset from the */
/* last comment record), but we want the corresponding element */
/* of the type array to give us the type of the record currently */
/* occupying position i. */
i__2 = base + i__ + total;
i__3 = base + i__ + total;
dasudi_(&scrhan, &i__2, &i__3, &type__);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
}
/* Ok, here's what we've got in the scratch file that's still of */
/* interest: */
/* -- In integer logical addresses BASE + 1 : BASE + TOTAL, */
/* we have an order vector. The Ith element of this */
/* vector indicates the record that should be moved to */
/* location DRBASE + I in the DAS file we're re-ordering, */
/* where DRBASE is the base address of the data records */
/* (the first directory record follows the record having this */
/* index). */
/* -- In integer logical addresses BASE + TOTAL + 1 : BASE + */
/* 2*TOTAL, we have data type indicators for the records to */
/* be re-ordered. The type for the Ith record in the file, */
/* counted from the last comment record, is located in logical */
/* address BASE + TOTAL + I. */
drbase = nresvr + ncomr + 1;
/* As we traverse the order vector, we flip the sign of elements */
/* we've accessed, so that we can tell when we encounter an element */
/* of a cycle that we've already traversed. */
/* Traverse the order vector. The variable START indicates the */
/* first element to look at. Ignore the first element; it's a */
/* singleton cycle. */
start = 2;
while(start < total) {
/* Traverse the current cycle of the order vector. */
/* We `make a hole' in the file by saving the record in position */
/* START, then we traverse the cycle in reverse order, filling in */
/* the hole at the ith position with the record whose number is */
/* the ith element of the order vector. At the end, we deposit */
/* the saved record into the `hole' left behind by the last */
/* record we moved. */
/* We're going to read and write records to and from the DAS file */
/* directly, rather than going through the buffering system. */
/* This will allow us to avoid any untoward interactions between */
/* the buffers for different data types. */
i__1 = base + total + start;
i__2 = base + total + start;
dasrdi_(&scrhan, &i__1, &i__2, &savtyp);
i__1 = base + start;
i__2 = base + start;
dasrdi_(&scrhan, &i__1, &i__2, &offset);
/* Save the record at the location DRBASE + START. */
if (savtyp == 1) {
i__1 = drbase + start;
dasioc_("READ", &unit, &i__1, savec, (ftnlen)4, (ftnlen)1024);
} else if (savtyp == 2) {
i__1 = drbase + start;
dasiod_("READ", &unit, &i__1, saved, (ftnlen)4);
} else {
i__1 = drbase + start;
dasioi_("READ", &unit, &i__1, savei, (ftnlen)4);
}
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
/* Let I be the index of the record that we are going to move */
/* data into next. I is an offset from the last comment record. */
i__ = start;
while(offset != start) {
/* Mark the order vector element by writing its negative */
/* back to the location it came from. */
i__1 = base + i__;
i__2 = base + i__;
i__3 = -offset;
dasudi_(&scrhan, &i__1, &i__2, &i__3);
/* Move the record at location */
/* DRBASE + OFFSET */
/* to location */
/* DRBASE + I */
/* There is no need to do anything about the corresponding */
/* elements of the type vector; we won't need them again. */
/* The read and write operations, as well as the temporary */
/* record required to perform the move, are dependent on the */
/* data type of the record to be moved. */
i__1 = base + total + offset;
i__2 = base + total + offset;
dasrdi_(&scrhan, &i__1, &i__2, &type__);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
/* Only pick records up if we're going to put them down in */
/* a location other than their original one. */
if (i__ != offset) {
if (type__ == 1) {
i__1 = drbase + offset;
dasioc_("READ", &unit, &i__1, crec, (ftnlen)4, (ftnlen)
1024);
i__1 = drbase + i__;
dasioc_("WRITE", &unit, &i__1, crec, (ftnlen)5, (ftnlen)
1024);
} else if (type__ == 2) {
i__1 = drbase + offset;
dasiod_("READ", &unit, &i__1, drec, (ftnlen)4);
i__1 = drbase + i__;
dasiod_("WRITE", &unit, &i__1, drec, (ftnlen)5);
} else {
i__1 = drbase + offset;
dasioi_("READ", &unit, &i__1, irec, (ftnlen)4);
i__1 = drbase + i__;
dasioi_("WRITE", &unit, &i__1, irec, (ftnlen)5);
}
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
}
/* OFFSET is the index of the next order vector element to */
/* look at. */
i__ = offset;
i__1 = base + i__;
i__2 = base + i__;
dasrdi_(&scrhan, &i__1, &i__2, &offset);
i__1 = base + i__ + total;
i__2 = base + i__ + total;
dasrdi_(&scrhan, &i__1, &i__2, &type__);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
}
/* The last value of I is the location in the cycle that element */
/* START followed. Therefore, the saved record corresponding */
/* to index START should be written to this location. */
if (savtyp == 1) {
i__1 = drbase + i__;
dasioc_("WRITE", &unit, &i__1, savec, (ftnlen)5, (ftnlen)1024);
} else if (savtyp == 2) {
i__1 = drbase + i__;
dasiod_("WRITE", &unit, &i__1, saved, (ftnlen)5);
} else {
i__1 = drbase + i__;
dasioi_("WRITE", &unit, &i__1, savei, (ftnlen)5);
}
/* Mark the order vector element by writing its negative */
/* back to the location it came from. */
i__1 = base + i__;
i__2 = base + i__;
i__3 = -start;
dasudi_(&scrhan, &i__1, &i__2, &i__3);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
/* Update START so that it points to the first element of a cycle */
/* of the order vector that has not yet been traversed. This will */
/* be the first positive element of the order vector in a location */
/* indexed higher than the current value of START. Note that */
/* this way of updating START guarantees that we don't have to */
/* backtrack to find an element in the next cycle. */
offset = -1;
while(offset < 0 && start < total) {
++start;
i__1 = base + start;
i__2 = base + start;
dasrdi_(&scrhan, &i__1, &i__2, &offset);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
}
/* At this point, START is the index of an element in the order */
/* vector that belongs to a cycle where no routine has gone */
/* before, or else START is the last index in the order vector, */
/* in which case we're done. */
}
/* At this point, the records in the DAS are organized as follows: */
/* +----------------------------------+ */
/* | File record | ( 1 ) */
/* +----------------------------------+ */
/* | Reserved records | ( 0 or more ) */
/* | | */
/* +----------------------------------+ */
/* | Comment records | ( 0 or more ) */
/* | | */
/* | | */
/* +----------------------------------+ */
/* | First directory record | ( 1 ) */
/* +----------------------------------+ */
/* | Character data records | ( 0 or more ) */
/* | | */
/* +----------------------------------+ */
/* | Double precision data records | ( 0 or more ) */
/* | | */
/* +----------------------------------+ */
/* | Integer data records | ( 0 or more ) */
/* | | */
/* +----------------------------------+ */
/* | Additional directory records | ( 0 or more ) */
/* | | */
/* +----------------------------------+ */
/* Not all of the indicated components must be present; only the */
/* file record and first directory record will exist in all cases. */
/* The `additional directory records' at the end of the file serve */
/* no purpose; if more data is appended to the file, they will be */
/* overwritten. */
/* The last step in preparing the file is to fill in the first */
/* directory record with the correct information, and to update */
/* the file summary. */
recno = drbase + 1;
cleari_(&c__256, irec);
/* Set the logical address ranges in the directory record, for each */
/* data type. */
for (type__ = 1; type__ <= 3; ++type__) {
maxadr = lastla[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
"lastla", i__1, "dassdr_", (ftnlen)957)];
if (maxadr > 0) {
minadr = 1;
} else {
minadr = 0;
}
irec[(i__1 = type__ << 1) < 256 && 0 <= i__1 ? i__1 : s_rnge("irec",
i__1, "dassdr_", (ftnlen)965)] = minadr;
irec[(i__1 = (type__ << 1) + 1) < 256 && 0 <= i__1 ? i__1 : s_rnge(
"irec", i__1, "dassdr_", (ftnlen)966)] = maxadr;
}
/* Set the descriptors in the directory. Determine which type */
/* comes first: the order of priority is character, double */
/* precision, integer. */
pos = 9;
for (type__ = 1; type__ <= 3; ++type__) {
if (lastla[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge("las"
"tla", i__1, "dassdr_", (ftnlen)979)] > 0) {
if (pos == 9) {
/* This is the first type for which any data is present. */
/* We must enter a type code at position BEGDSC in the */
/* directory, and we must enter a count at position */
/* BEGDSC+1. */
irec[8] = type__;
irec[9] = count[(i__1 = type__ - 1) < 4 && 0 <= i__1 ? i__1 :
s_rnge("count", i__1, "dassdr_", (ftnlen)989)];
lastrc[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
"lastrc", i__1, "dassdr_", (ftnlen)990)] = recno;
lastwd[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
"lastwd", i__1, "dassdr_", (ftnlen)991)] = 10;
pos += 2;
prvtyp = type__;
} else {
/* Place an appropriately signed count at location POS in */
/* the directory. */
if (type__ == next[(i__1 = prvtyp - 1) < 3 && 0 <= i__1 ?
i__1 : s_rnge("next", i__1, "dassdr_", (ftnlen)1000)])
{
irec[(i__1 = pos - 1) < 256 && 0 <= i__1 ? i__1 : s_rnge(
"irec", i__1, "dassdr_", (ftnlen)1001)] = count[(
i__2 = type__ - 1) < 4 && 0 <= i__2 ? i__2 :
s_rnge("count", i__2, "dassdr_", (ftnlen)1001)];
} else {
irec[(i__1 = pos - 1) < 256 && 0 <= i__1 ? i__1 : s_rnge(
"irec", i__1, "dassdr_", (ftnlen)1003)] = -count[(
i__2 = type__ - 1) < 4 && 0 <= i__2 ? i__2 :
s_rnge("count", i__2, "dassdr_", (ftnlen)1003)];
}
lastrc[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
"lastrc", i__1, "dassdr_", (ftnlen)1006)] = recno;
lastwd[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
"lastwd", i__1, "dassdr_", (ftnlen)1007)] = pos;
++pos;
prvtyp = type__;
}
}
}
/* Since we've done away with all but the first directory, the first */
/* free record is decremented by 1 less than the directory count. */
free = free - count[3] + 1;
/* Write out the new directory record. Don't use the DAS buffered */
/* write mechanism; this could trash the file by dumping buffered */
/* records in the wrong places. */
dasioi_("WRITE", &unit, &recno, irec, (ftnlen)5);
/* Write out the updated file summary. */
dasufs_(handle, &nresvr, &nresvc, &ncomr, &ncomc, &free, lastla, lastrc,
lastwd);
/* Clean up the DAS data buffers: we don't want buffered scratch */
/* file records hanging around there. Then get rid of the scratch */
/* file. */
daswbr_(&scrhan);
dasllc_(&scrhan);
chkout_("DASSDR", (ftnlen)6);
return 0;
} /* dassdr_ */
/* $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_ */
/* Subroutine */ int flgrpt_(integer *nitems, char *names, char *values, U_fp
myio, ftnlen names_len, ftnlen values_len)
{
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), i_len(char *, ftnlen),
s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char hard[1];
logical free[129];
integer i__, j, k, l;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer width;
extern integer rtrim_(char *, ftnlen);
char style[200];
extern /* Subroutine */ int chkout_(char *, ftnlen);
char letter[1];
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen), nspmrg_(char *, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int nicepr_1__(char *, char *, U_fp, ftnlen,
ftnlen);
/* This routine takes an array of names and an array of associated */
/* value strings and produces a flagged set of outputs. This */
/* routine signals no errors. */
/* The routine MYIO is a routine that is supplied by the user */
/* that can handle io of text lines without any action by the */
/* routine that calls it. */
/* $ Version */
/* Inspekt Routine version 2.0.0, 7-APR-1995 (WLT) */
/* Unused variables LEFT and RIGHT were removed. */
/* Spicelib functions */
if (return_()) {
return 0;
}
chkin_("FLGRPT", (ftnlen)6);
/* First find the widest of the names: */
width = 0;
i__1 = *nitems;
for (i__ = 1; i__ <= i__1; ++i__) {
if (rtrim_(names + (i__ - 1) * names_len, names_len) > width) {
width = rtrim_(names + (i__ - 1) * names_len, names_len);
}
}
/* Now for each of the NAME/VALUE pairs construct a style */
/* string using NAMES and run the VALUES through NICEPR_1. */
i__1 = *nitems;
for (i__ = 1; i__ <= i__1; ++i__) {
/* First we need to find a character that is not used */
/* in the NAMES(I)/VALUES(I) pair. We will use this as */
/* a hardspace in our style string. */
for (j = 33; j <= 127; ++j) {
free[(i__2 = j) < 129 && 0 <= i__2 ? i__2 : s_rnge("free", i__2,
"flgrpt_", (ftnlen)102)] = TRUE_;
}
i__2 = width;
for (j = 1; j <= i__2; ++j) {
free[(i__3 = *(unsigned char *)&names[(i__ - 1) * names_len + (j
- 1)]) < 129 && 0 <= i__3 ? i__3 : s_rnge("free", i__3,
"flgrpt_", (ftnlen)106)] = FALSE_;
}
i__2 = i_len(values, values_len);
for (j = 1; j <= i__2; ++j) {
free[(i__3 = *(unsigned char *)&values[(i__ - 1) * values_len + (
j - 1)]) < 129 && 0 <= i__3 ? i__3 : s_rnge("free", i__3,
"flgrpt_", (ftnlen)110)] = FALSE_;
}
j = 33;
while(! free[(i__2 = j) < 129 && 0 <= i__2 ? i__2 : s_rnge("free",
i__2, "flgrpt_", (ftnlen)114)] && j < 127) {
++j;
}
*(unsigned char *)hard = (char) j;
/* Set up the style we are going to use for this */
/* value */
nspmrg_(style, (ftnlen)200);
suffix_("HARDSPACE", &c__1, style, (ftnlen)9, (ftnlen)200);
suffix_(hard, &c__1, style, (ftnlen)1, (ftnlen)200);
suffix_("FLAG", &c__1, style, (ftnlen)4, (ftnlen)200);
l = rtrim_(style, (ftnlen)200) + 2;
i__2 = width;
for (k = 1; k <= i__2; ++k) {
*(unsigned char *)letter = *(unsigned char *)&names[(i__ - 1) *
names_len + (k - 1)];
if (*(unsigned char *)letter == ' ') {
*(unsigned char *)&style[l - 1] = *(unsigned char *)hard;
} else {
*(unsigned char *)&style[l - 1] = *(unsigned char *)letter;
}
++l;
}
*(unsigned char *)&style[l - 1] = ':';
++l;
*(unsigned char *)&style[l - 1] = *(unsigned char *)hard;
/* Ok. Now just ship the stuff to the output routines. */
if (s_cmp(names + (i__ - 1) * names_len, " ", names_len, (ftnlen)1) ==
0 && s_cmp(values + (i__ - 1) * values_len, " ", values_len,
(ftnlen)1) == 0) {
i__2 = l - 2;
s_copy(style + i__2, hard, l - 1 - i__2, (ftnlen)1);
nicepr_1__(hard, style, (U_fp)myio, (ftnlen)1, l);
} else if (s_cmp(values + (i__ - 1) * values_len, " ", values_len, (
ftnlen)1) == 0) {
i__2 = l - 2;
s_copy(style + i__2, hard, l - 1 - i__2, (ftnlen)1);
nicepr_1__(hard, style, (U_fp)myio, (ftnlen)1, l);
} else {
nicepr_1__(values + (i__ - 1) * values_len, style, (U_fp)myio,
values_len, l);
}
}
chkout_("FLGRPT", (ftnlen)6);
return 0;
} /* flgrpt_ */
/* $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 TKFRAM (Text kernel frame transformation ) */
/* Subroutine */ int tkfram_(integer *id, doublereal *rot, integer *frame,
logical *found)
{
/* Initialized data */
static integer at = 0;
static logical first = TRUE_;
/* System generated locals */
address a__1[2];
integer i__1, i__2[2], i__3;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static char name__[32];
static integer tail;
static char spec[32], item[32*14];
static integer idnt[1], axes[3];
static logical full;
static integer pool[52] /* was [2][26] */;
extern doublereal vdot_(doublereal *, doublereal *);
static char type__[1];
static doublereal qtmp[4];
extern /* Subroutine */ int eul2m_(doublereal *, doublereal *, doublereal
*, integer *, integer *, integer *, doublereal *);
static integer i__, n, r__;
static doublereal buffd[180] /* was [9][20] */;
static integer buffi[20] /* was [1][20] */, oldid;
extern /* Subroutine */ int chkin_(char *, ftnlen);
static char agent[32];
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen),
ident_(doublereal *), errch_(char *, char *, ftnlen, ftnlen);
static doublereal tempd;
extern /* Subroutine */ int moved_(doublereal *, integer *, doublereal *),
repmi_(char *, char *, integer *, char *, ftnlen, ftnlen, ftnlen)
, vhatg_(doublereal *, integer *, doublereal *);
extern integer lnktl_(integer *, integer *);
static char idstr[32];
extern integer rtrim_(char *, ftnlen);
static char versn[8], units[32];
static integer ar;
extern logical failed_(void), badkpv_(char *, char *, char *, integer *,
integer *, char *, ftnlen, ftnlen, ftnlen, ftnlen);
static char frname[32];
static doublereal angles[3];
static char oldagt[32];
static logical buffrd;
extern /* Subroutine */ int locati_(integer *, integer *, integer *,
integer *, integer *, logical *), frmnam_(integer *, char *,
ftnlen), namfrm_(char *, integer *, ftnlen);
static logical update;
static char altnat[32];
extern /* Subroutine */ int lnkini_(integer *, integer *);
extern integer lnknfn_(integer *);
static integer idents[20] /* was [1][20] */;
extern /* Subroutine */ int gcpool_(char *, integer *, integer *, integer
*, char *, logical *, ftnlen, ftnlen), gdpool_(char *, integer *,
integer *, integer *, doublereal *, logical *, ftnlen), sigerr_(
char *, ftnlen), gipool_(char *, integer *, integer *, integer *,
integer *, logical *, ftnlen), chkout_(char *, ftnlen), sharpr_(
doublereal *), dtpool_(char *, logical *, integer *, char *,
ftnlen, ftnlen), setmsg_(char *, ftnlen);
static doublereal matrix[9] /* was [3][3] */;
extern /* Subroutine */ int cvpool_(char *, logical *, ftnlen), dwpool_(
char *, ftnlen), errint_(char *, integer *, ftnlen), vsclip_(
doublereal *, doublereal *);
static doublereal quatrn[4];
extern /* Subroutine */ int convrt_(doublereal *, char *, char *,
doublereal *, ftnlen, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int q2m_(doublereal *, doublereal *), intstr_(
integer *, char *, ftnlen), swpool_(char *, integer *, char *,
ftnlen, ftnlen);
static logical fnd;
static char alt[32*14];
/* $ Abstract */
/* This routine returns the rotation from the input frame */
/* specified by ID to the associated frame given by FRAME. */
/* $ 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 */
/* FRAMES */
/* $ Keywords */
/* POINTING */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- ---------------------------------------------- */
/* ID I Class identification code for the instrument */
/* ROT O The rotation from ID to FRAME. */
/* FRAME O The integer code of some reference frame. */
/* FOUND O TRUE if the rotation could be determined. */
/* $ Detailed_Input */
/* ID The identification code used to specify an */
/* instrument in the SPICE system. */
/* $ Detailed_Output */
/* ROT is a rotation matrix that gives the transformation */
/* from the frame specified by ID to the frame */
/* specified by FRAME. */
/* FRAME is the id code of the frame used to define the */
/* orientation of the frame given by ID. ROT gives */
/* the transformation from the IF frame to */
/* the frame specified by FRAME. */
/* FOUND is a logical indicating whether or not a frame */
/* definition for frame ID was constructed from */
/* kernel pool data. If ROT and FRAME were constructed */
/* FOUND will be returned with the value TRUE. */
/* Otherwise it will be returned with the value FALSE. */
/* $ Parameters */
/* BUFSIZ is the number of rotation, frame id pairs that */
/* can have their instance data buffered for the */
/* sake of improving run-time performance. This */
/* value MUST be positive and should probably be */
/* at least 10. */
/* $ Exceptions */
/* 1) If some instance value associated with this frame */
/* cannot be located, or does not have the proper type */
/* or dimension, the error will be diagnosed by the */
/* routine BADKPV. In such a case FOUND will be set to .FALSE. */
/* 2) If the input ID has the value 0, the error */
/* SPICE(ZEROFRAMEID) will be signaled. FOUND will be set */
/* to FALSE. */
/* 3) If the name of the frame corresponding to ID cannot be */
/* determined, the error 'SPICE(INCOMPLETEFRAME)' is signaled. */
/* 4) If the frame given by ID is defined relative to a frame */
/* that is unrecognized, the error SPICE(BADFRAMESPEC) */
/* will be signaled. FOUND will be set to FALSE. */
/* 5) If the kernel pool specification for ID is not one of */
/* MATRIX, ANGLES, or QUATERNION, then the error */
/* SPICE(UNKNOWNFRAMESPEC) will be signaled. FOUND will be */
/* set to FALSE. */
/* $ Files */
/* This routine makes use of the loaded text kernels to */
/* determine the rotation from a constant offset frame */
/* to its defining frame. */
/* $ Particulars */
/* This routine is used to construct the rotation from some frame */
/* that is a constant rotation offset from some other reference */
/* frame. This rotation is derived from data stored in the kernel */
/* pool. */
/* It is considered to be an low level routine that */
/* will need to be called directly only by persons performing */
/* high volume processing. */
/* $ Examples */
/* This is intended to be used as a low level routine by */
/* the frame system software. However, you could use this */
/* routine to directly retrieve the rotation from an offset */
/* frame to its relative frame. One instance in which you */
/* might do this is if you have a properly specified topocentric */
/* frame for some site on earth and you wish to determine */
/* the geodetic latitude and longitude of the site. Here's how. */
/* Suppose the name of the topocentric frame is: 'MYTOPO'. */
/* First we get the id-code of the topocentric frame. */
/* CALL NAMFRM ( 'MYTOPO', FRCODE ) */
/* Next get the rotation from the topocentric frame to */
/* the bodyfixed frame. */
/* CALL TKFRAM ( FRCODE, ROT, FRAME, FOUND ) */
/* Make sure the topoframe is relative to one of the earth */
/* fixed frames. */
/* CALL FRMNAM( FRAME, TEST ) */
/* IF ( TEST .NE. 'IAU_EARTH' */
/* . .AND. TEST .NE. 'EARTH_FIXED' */
/* . .AND. TEST .NE. 'ITRF93' ) THEN */
/* WRITE (*,*) 'The frame MYTOPO does not appear to be ' */
/* WRITE (*,*) 'defined relative to an earth fixed frame.' */
/* STOP */
/* END IF */
/* Things look ok. Get the location of the Z-axis in the */
/* topocentric frame. */
/* Z(1) = ROT(1,3) */
/* Z(2) = ROT(2,3) */
/* Z(3) = ROT(3,3) */
/* Convert the Z vector to latitude longitude and radius. */
/* CALL RECLAT ( Z, LAT, LONG, RAD ) */
/* WRITE (*,*) 'The geodetic coordinates of the center of' */
/* WRITE (*,*) 'the topographic frame are: ' */
/* WRITE (*,*) */
/* WRITE (*,*) 'Latitude (deg): ', LAT *DPR() */
/* WRITE (*,*) 'Longitude (deg): ', LONG*DPR() */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 2.1.0, 23-APR-2009 (NJB) */
/* Bug fix: watch is deleted only for frames */
/* that are deleted from the buffer. */
/* - SPICELIB Version 2.0.0, 19-MAR-2009 (NJB) */
/* Bug fix: this routine now deletes watches set on */
/* kernel variables of frames that are discarded from */
/* the local buffering system. */
/* - SPICELIB Version 1.2.0, 09-SEP-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in CONVRT, UCRSS, VHATG and VSCL calls. */
/* - SPICELIB Version 1.1.0, 21-NOV-2001 (FST) */
/* Updated this routine to dump the buffer of frame ID codes */
/* it saves when it or one of the modules in its call tree signals */
/* an error. This fixes a bug where a frame's ID code is */
/* buffered, but the matrix and kernel pool watcher were not set */
/* properly. */
/* - SPICELIB Version 1.0.0, 18-NOV-1996 (WLT) */
/* -& */
/* $ Index_Entries */
/* Fetch the rotation and frame of a text kernel frame */
/* Fetch the rotation and frame of a constant offset frame */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.2.0, 09-SEP-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in CONVRT, UCRSS, VHATG and VSCL calls. */
/* -& */
/* Spicelib Functions */
/* Local Parameters */
/* Local Variables */
/* Saved variables */
/* Initial values */
/* Programmer's note: this routine makes use of the *implementation* */
/* of LOCATI. If that routine is changed, the logic this routine */
/* uses to locate buffered, old frame IDs may need to change as well. */
/* Before we even check in, if N is less than 1 we can */
/* just return. */
/* Perform any initializations that might be needed for this */
/* routine. */
if (first) {
first = FALSE_;
s_copy(versn, "1.0.0", (ftnlen)8, (ftnlen)5);
lnkini_(&c__20, pool);
}
/* Now do the standard SPICE error handling. Sure this is */
/* a bit unconventional, but nothing will be hurt by doing */
/* the stuff above first. */
if (return_()) {
return 0;
}
chkin_("TKFRAM", (ftnlen)6);
/* So far, we've not FOUND the rotation to the specified frame. */
*found = FALSE_;
/* Check the ID to make sure it is non-zero. */
if (*id == 0) {
lnkini_(&c__20, pool);
setmsg_("Frame identification codes are required to be non-zero. Yo"
"u've specified a frame with ID value zero. ", (ftnlen)102);
sigerr_("SPICE(ZEROFRAMEID)", (ftnlen)18);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* Find out whether our linked list pool is already full. */
/* We'll use this information later to decide whether we're */
/* going to have to delete a watcher. */
full = lnknfn_(pool) == 0;
if (full) {
/* If the input frame ID is not buffered, we'll need to */
/* overwrite an existing buffer entry. In this case */
/* the call to LOCATI we're about to make will overwrite */
/* the ID code in the slot we're about to use. We need */
/* this ID code, so extract it now while we have the */
/* opportunity. The old ID sits at the tail of the list */
/* whose head node is AT. */
tail = lnktl_(&at, pool);
oldid = idents[(i__1 = tail - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge(
"idents", i__1, "tkfram_", (ftnlen)413)];
/* Create the name of the agent associated with the old */
/* frame. */
s_copy(oldagt, "TKFRAME_#", (ftnlen)32, (ftnlen)9);
repmi_(oldagt, "#", &oldid, oldagt, (ftnlen)32, (ftnlen)1, (ftnlen)32)
;
}
/* Look up the address of the instance data. */
idnt[0] = *id;
locati_(idnt, &c__1, idents, pool, &at, &buffrd);
if (full && ! buffrd) {
/* Since the buffer is already full, we'll delete the watcher for */
/* the kernel variables associated with OLDID, since there's no */
/* longer a need for that watcher. */
/* First clear the update status of the old agent; DWPOOL won't */
/* delete an agent with a unchecked update. */
cvpool_(oldagt, &update, (ftnlen)32);
dwpool_(oldagt, (ftnlen)32);
}
/* Until we have better information we put the identity matrix */
/* into the output rotation and set FRAME to zero. */
ident_(rot);
*frame = 0;
/* If we have to look up the data for our frame, we do */
/* it now and perform any conversions and computations that */
/* will be needed when it's time to convert coordinates to */
/* directions. */
/* Construct the name of the agent associated with the */
/* requested frame. (Each frame has its own agent). */
intstr_(id, idstr, (ftnlen)32);
frmnam_(id, frname, (ftnlen)32);
if (s_cmp(frname, " ", (ftnlen)32, (ftnlen)1) == 0) {
lnkini_(&c__20, pool);
setmsg_("The Text Kernel (TK) frame with id-code # does not have a r"
"ecognized name. ", (ftnlen)75);
errint_("#", id, (ftnlen)1);
sigerr_("SPICE(INCOMPLETFRAME)", (ftnlen)21);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* Writing concatenation */
i__2[0] = 8, a__1[0] = "TKFRAME_";
i__2[1] = 32, a__1[1] = idstr;
s_cat(agent, a__1, i__2, &c__2, (ftnlen)32);
r__ = rtrim_(agent, (ftnlen)32);
/* Writing concatenation */
i__2[0] = 8, a__1[0] = "TKFRAME_";
i__2[1] = 32, a__1[1] = frname;
s_cat(altnat, a__1, i__2, &c__2, (ftnlen)32);
ar = rtrim_(altnat, (ftnlen)32);
/* If the frame is buffered, we check the kernel pool to */
/* see if there has been an update to this frame. */
if (buffrd) {
cvpool_(agent, &update, r__);
} else {
/* If the frame is not buffered we definitely need to update */
/* things. */
update = TRUE_;
}
if (! update) {
/* Just look up the rotation matrix and relative-to */
/* information from the local buffer. */
rot[0] = buffd[(i__1 = at * 9 - 9) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)506)];
rot[1] = buffd[(i__1 = at * 9 - 8) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)507)];
rot[2] = buffd[(i__1 = at * 9 - 7) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)508)];
rot[3] = buffd[(i__1 = at * 9 - 6) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)509)];
rot[4] = buffd[(i__1 = at * 9 - 5) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)510)];
rot[5] = buffd[(i__1 = at * 9 - 4) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)511)];
rot[6] = buffd[(i__1 = at * 9 - 3) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)512)];
rot[7] = buffd[(i__1 = at * 9 - 2) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)513)];
rot[8] = buffd[(i__1 = at * 9 - 1) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)514)];
*frame = buffi[(i__1 = at - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge(
"buffi", i__1, "tkfram_", (ftnlen)516)];
} else {
/* Determine how the frame is specified and what it */
/* is relative to. The variables that specify */
/* how the frame is represented and what it is relative to */
/* are TKFRAME_#_SPEC and TKFRAME_#_RELATIVE where # is */
/* replaced by the text value of ID or the frame name. */
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 5, a__1[1] = "_SPEC";
s_cat(item, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 9, a__1[1] = "_RELATIVE";
s_cat(item + 32, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 5, a__1[1] = "_SPEC";
s_cat(alt, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 9, a__1[1] = "_RELATIVE";
s_cat(alt + 32, a__1, i__2, &c__2, (ftnlen)32);
/* See if the friendlier version of the kernel pool variables */
/* are available. */
for (i__ = 1; i__ <= 2; ++i__) {
dtpool_(alt + (((i__1 = i__ - 1) < 14 && 0 <= i__1 ? i__1 :
s_rnge("alt", i__1, "tkfram_", (ftnlen)537)) << 5), found,
&n, type__, (ftnlen)32, (ftnlen)1);
if (*found) {
s_copy(item + (((i__1 = i__ - 1) < 14 && 0 <= i__1 ? i__1 :
s_rnge("item", i__1, "tkfram_", (ftnlen)540)) << 5),
alt + (((i__3 = i__ - 1) < 14 && 0 <= i__3 ? i__3 :
s_rnge("alt", i__3, "tkfram_", (ftnlen)540)) << 5), (
ftnlen)32, (ftnlen)32);
}
}
/* If either the SPEC or RELATIVE frame are missing from */
/* the kernel pool, we simply return. */
if (badkpv_("TKFRAM", item, "=", &c__1, &c__1, "C", (ftnlen)6, (
ftnlen)32, (ftnlen)1, (ftnlen)1) || badkpv_("TKFRAM", item +
32, "=", &c__1, &c__1, "C", (ftnlen)6, (ftnlen)32, (ftnlen)1,
(ftnlen)1)) {
lnkini_(&c__20, pool);
*frame = 0;
ident_(rot);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* If we make it this far, look up the SPEC and RELATIVE frame. */
gcpool_(item, &c__1, &c__1, &n, spec, &fnd, (ftnlen)32, (ftnlen)32);
gcpool_(item + 32, &c__1, &c__1, &n, name__, &fnd, (ftnlen)32, (
ftnlen)32);
/* Look up the id-code for this frame. */
namfrm_(name__, frame, (ftnlen)32);
if (*frame == 0) {
lnkini_(&c__20, pool);
setmsg_("The frame to which frame # is relatively defined is not"
" recognized. The kernel pool specification of the relati"
"ve frame is '#'. This is not a recognized frame. ", (
ftnlen)161);
errint_("#", id, (ftnlen)1);
errch_("#", name__, (ftnlen)1, (ftnlen)32);
sigerr_("SPICE(BADFRAMESPEC)", (ftnlen)19);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* Convert SPEC to upper case so that we can easily check */
/* to see if this is one of the expected specification types. */
ucase_(spec, spec, (ftnlen)32, (ftnlen)32);
if (s_cmp(spec, "MATRIX", (ftnlen)32, (ftnlen)6) == 0) {
/* This is the easiest case. Just grab the matrix */
/* from the kernel pool (and polish it up a bit just */
/* to make sure we have a rotation matrix). */
/* We give preference to the kernel pool variable */
/* TKFRAME_<name>_MATRIX if it is available. */
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 7, a__1[1] = "_MATRIX";
s_cat(item + 64, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 7, a__1[1] = "_MATRIX";
s_cat(alt + 64, a__1, i__2, &c__2, (ftnlen)32);
dtpool_(alt + 64, found, &n, type__, (ftnlen)32, (ftnlen)1);
if (*found) {
s_copy(item + 64, alt + 64, (ftnlen)32, (ftnlen)32);
}
if (badkpv_("TKFRAM", item + 64, "=", &c__9, &c__1, "N", (ftnlen)
6, (ftnlen)32, (ftnlen)1, (ftnlen)1)) {
lnkini_(&c__20, pool);
*frame = 0;
ident_(rot);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* The variable meets current expectations, look it up */
/* from the kernel pool. */
gdpool_(item + 64, &c__1, &c__9, &n, matrix, &fnd, (ftnlen)32);
/* In this case the full transformation matrix has been */
/* specified. We simply polish it up a bit. */
moved_(matrix, &c__9, rot);
sharpr_(rot);
/* The matrix might not be right-handed, so correct */
/* the sense of the second and third columns if necessary. */
if (vdot_(&rot[3], &matrix[3]) < 0.) {
vsclip_(&c_b95, &rot[3]);
}
if (vdot_(&rot[6], &matrix[6]) < 0.) {
vsclip_(&c_b95, &rot[6]);
}
} else if (s_cmp(spec, "ANGLES", (ftnlen)32, (ftnlen)6) == 0) {
/* Look up the angles, their units and axes for the */
/* frame specified by ID. (Note that UNITS are optional). */
/* As in the previous case we give preference to the */
/* form TKFRAME_<name>_<item> over TKFRAME_<id>_<item>. */
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 7, a__1[1] = "_ANGLES";
s_cat(item + 64, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 5, a__1[1] = "_AXES";
s_cat(item + 96, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 6, a__1[1] = "_UNITS";
s_cat(item + 128, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 7, a__1[1] = "_ANGLES";
s_cat(alt + 64, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 5, a__1[1] = "_AXES";
s_cat(alt + 96, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 6, a__1[1] = "_UNITS";
s_cat(alt + 128, a__1, i__2, &c__2, (ftnlen)32);
/* Again, we give preference to the more friendly form */
/* of TKFRAME specification. */
for (i__ = 3; i__ <= 5; ++i__) {
dtpool_(alt + (((i__1 = i__ - 1) < 14 && 0 <= i__1 ? i__1 :
s_rnge("alt", i__1, "tkfram_", (ftnlen)668)) << 5),
found, &n, type__, (ftnlen)32, (ftnlen)1);
if (*found) {
s_copy(item + (((i__1 = i__ - 1) < 14 && 0 <= i__1 ? i__1
: s_rnge("item", i__1, "tkfram_", (ftnlen)671)) <<
5), alt + (((i__3 = i__ - 1) < 14 && 0 <= i__3 ?
i__3 : s_rnge("alt", i__3, "tkfram_", (ftnlen)671)
) << 5), (ftnlen)32, (ftnlen)32);
}
}
if (badkpv_("TKFRAM", item + 64, "=", &c__3, &c__1, "N", (ftnlen)
6, (ftnlen)32, (ftnlen)1, (ftnlen)1) || badkpv_("TKFRAM",
item + 96, "=", &c__3, &c__1, "N", (ftnlen)6, (ftnlen)32,
(ftnlen)1, (ftnlen)1)) {
lnkini_(&c__20, pool);
*frame = 0;
ident_(rot);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
s_copy(units, "RADIANS", (ftnlen)32, (ftnlen)7);
gdpool_(item + 64, &c__1, &c__3, &n, angles, &fnd, (ftnlen)32);
gipool_(item + 96, &c__1, &c__3, &n, axes, &fnd, (ftnlen)32);
gcpool_(item + 128, &c__1, &c__1, &n, units, &fnd, (ftnlen)32, (
ftnlen)32);
/* Convert angles to radians. */
for (i__ = 1; i__ <= 3; ++i__) {
convrt_(&angles[(i__1 = i__ - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("angles", i__1, "tkfram_", (ftnlen)700)],
units, "RADIANS", &tempd, (ftnlen)32, (ftnlen)7);
angles[(i__1 = i__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
"angles", i__1, "tkfram_", (ftnlen)701)] = tempd;
}
if (failed_()) {
lnkini_(&c__20, pool);
*frame = 0;
ident_(rot);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* Compute the rotation from instrument frame to CK frame. */
eul2m_(angles, &angles[1], &angles[2], axes, &axes[1], &axes[2],
rot);
} else if (s_cmp(spec, "QUATERNION", (ftnlen)32, (ftnlen)10) == 0) {
/* Look up the quaternion and convert it to a rotation */
/* matrix. Again there are two possible variables that */
/* may point to the quaternion. We give preference to */
/* the form TKFRAME_<name>_Q over the form TKFRAME_<id>_Q. */
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 2, a__1[1] = "_Q";
s_cat(item + 64, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 2, a__1[1] = "_Q";
s_cat(alt + 64, a__1, i__2, &c__2, (ftnlen)32);
dtpool_(alt + 64, found, &n, type__, (ftnlen)32, (ftnlen)1);
if (*found) {
s_copy(item + 64, alt + 64, (ftnlen)32, (ftnlen)32);
}
if (badkpv_("TKFRAM", item + 64, "=", &c__4, &c__1, "N", (ftnlen)
6, (ftnlen)32, (ftnlen)1, (ftnlen)1)) {
lnkini_(&c__20, pool);
*frame = 0;
ident_(rot);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* In this case we have the quaternion representation. */
/* Again, we do a small amount of polishing of the input. */
gdpool_(item + 64, &c__1, &c__4, &n, quatrn, &fnd, (ftnlen)32);
vhatg_(quatrn, &c__4, qtmp);
q2m_(qtmp, rot);
} else {
/* We don't recognize the SPEC for this frame. Say */
/* so. Also note that perhaps the user needs to upgrade */
/* the toolkit. */
lnkini_(&c__20, pool);
setmsg_("The frame specification \"# = '#'\" is not one of the r"
"econized means of specifying a text-kernel constant offs"
"et frame (as of version # of the routine TKFRAM). This m"
"ay reflect a typographical error or may indicate that yo"
"u need to consider updating your version of the SPICE to"
"olkit. ", (ftnlen)284);
errch_("#", item, (ftnlen)1, (ftnlen)32);
errch_("#", spec, (ftnlen)1, (ftnlen)32);
errch_("#", versn, (ftnlen)1, (ftnlen)8);
sigerr_("SPICE(UNKNOWNFRAMESPEC)", (ftnlen)23);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* Buffer the identifier, relative frame and rotation matrix. */
buffd[(i__1 = at * 9 - 9) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)784)] = rot[0];
buffd[(i__1 = at * 9 - 8) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)785)] = rot[1];
buffd[(i__1 = at * 9 - 7) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)786)] = rot[2];
buffd[(i__1 = at * 9 - 6) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)787)] = rot[3];
buffd[(i__1 = at * 9 - 5) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)788)] = rot[4];
buffd[(i__1 = at * 9 - 4) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)789)] = rot[5];
buffd[(i__1 = at * 9 - 3) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)790)] = rot[6];
buffd[(i__1 = at * 9 - 2) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)791)] = rot[7];
buffd[(i__1 = at * 9 - 1) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)792)] = rot[8];
buffi[(i__1 = at - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge("buffi", i__1,
"tkfram_", (ftnlen)794)] = *frame;
/* If these were not previously buffered, we need to set */
/* a watch on the various items that might be used to define */
/* this frame. */
if (! buffrd) {
/* Immediately check for an update so that we will */
/* not redundantly look for this item the next time this */
/* routine is called. */
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 9, a__1[1] = "_RELATIVE";
s_cat(item, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 5, a__1[1] = "_SPEC";
s_cat(item + 32, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 5, a__1[1] = "_AXES";
s_cat(item + 64, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 7, a__1[1] = "_MATRIX";
s_cat(item + 96, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 2, a__1[1] = "_Q";
s_cat(item + 128, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 7, a__1[1] = "_ANGLES";
s_cat(item + 160, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 6, a__1[1] = "_UNITS";
s_cat(item + 192, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 9, a__1[1] = "_RELATIVE";
s_cat(item + 224, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 5, a__1[1] = "_SPEC";
s_cat(item + 256, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 5, a__1[1] = "_AXES";
s_cat(item + 288, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 7, a__1[1] = "_MATRIX";
s_cat(item + 320, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 2, a__1[1] = "_Q";
s_cat(item + 352, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 7, a__1[1] = "_ANGLES";
s_cat(item + 384, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 6, a__1[1] = "_UNITS";
s_cat(item + 416, a__1, i__2, &c__2, (ftnlen)32);
swpool_(agent, &c__14, item, (ftnlen)32, (ftnlen)32);
cvpool_(agent, &update, (ftnlen)32);
}
}
if (failed_()) {
lnkini_(&c__20, pool);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* All errors cause the routine to exit before we get to this */
/* point. If we reach this point we didn't have an error and */
/* hence did find the rotation from ID to FRAME. */
*found = TRUE_;
/* That's it */
chkout_("TKFRAM", (ftnlen)6);
return 0;
} /* tkfram_ */
/* $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 SPKE08 ( S/P Kernel, evaluate, type 8 ) */
/* Subroutine */ int spke08_(doublereal *et, doublereal *record, doublereal *
state)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer i_dnnt(doublereal *), s_rnge(char *, integer, char *, integer);
/* Local variables */
integer i__, n;
extern /* Subroutine */ int moved_(doublereal *, integer *, doublereal *);
doublereal locrec[129];
extern doublereal lgresp_(integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
extern /* Subroutine */ int xposeg_(doublereal *, integer *, integer *,
doublereal *);
extern logical return_(void);
integer ystart;
/* $ Abstract */
/* Evaluate a single SPK data record from a segment of type 8 */
/* (equally spaced discrete states, interpolated by Lagrange */
/* polynomials). */
/* $ 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 */
/* TIME */
/* $ Keywords */
/* EPHEMERIS */
/* $ Declarations */
/* $ Abstract */
/* Declare SPK data record size. This record is declared in */
/* SPKPVN and is passed to SPK reader (SPKRxx) and evaluator */
/* (SPKExx) routines. */
/* $ 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 */
/* SPK */
/* $ Restrictions */
/* 1) If new SPK types are added, it may be necessary to */
/* increase the size of this record. The header of SPKPVN */
/* should be updated as well to show the record size */
/* requirement for each data type. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 16-AUG-2002 (NJB) */
/* -& */
/* End include file spkrec.inc */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* ET I Target epoch. */
/* RECORD I-O Data record. */
/* STATE O State (position and velocity). */
/* $ Detailed_Input */
/* ET is a target epoch, at which a state vector is to */
/* be computed. */
/* RECORD is a data record which, when evaluated at epoch ET, */
/* will give the state (position and velocity) of some */
/* body, relative to some center, in some inertial */
/* reference frame. Normally, the caller of this routine */
/* will obtain RECORD by calling SPKR08. */
/* The structure of the record is as follows: */
/* +----------------------+ */
/* | number of states (n) | */
/* +----------------------+ */
/* | start epoch | */
/* +----------------------+ */
/* | step size | */
/* +----------------------+ */
/* | state 1 (6 elts.) | */
/* +----------------------+ */
/* | state 2 (6 elts.) | */
/* +----------------------+ */
/* . */
/* . */
/* . */
/* +----------------------+ */
/* | state n (6 elts.) | */
/* +----------------------+ */
/* $ Detailed_Output */
/* RECORD is the input record, modified by use as a work area. */
/* On output, RECORD no longer contains useful */
/* information. */
/* STATE is the state. In order, the elements are */
/* X, Y, Z, X', Y', and Z' */
/* Units are km and km/sec. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) The caller of this routine must ensure that the input record */
/* is appropriate for the supplied ET value. Otherwise, */
/* arithmetic overflow may result. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The exact format and structure of type 8 (equally spaced discrete */
/* states, interpolated by Lagrange polynomials) segments are */
/* described in the SPK Required Reading file. */
/* $ Examples */
/* The SPKEnn routines are almost always used in conjunction with */
/* the corresponding SPKRnn routines, which read the records from */
/* SPK files. */
/* The data returned by the SPKRnn routine is in its rawest form, */
/* taken directly from the segment. As such, it will be meaningless */
/* to a user unless he/she understands the structure of the data type */
/* completely. Given that understanding, however, the SPKRnn */
/* routines might be used to examine raw segment data before */
/* evaluating it with the SPKEnn routines. */
/* C */
/* C Get a segment applicable to a specified body and epoch. */
/* C */
/* CALL SPKSFS ( BODY, ET, HANDLE, DESCR, IDENT, FOUND ) */
/* C */
/* C Look at parts of the descriptor. */
/* C */
/* CALL DAFUS ( DESCR, 2, 6, DCD, ICD ) */
/* CENTER = ICD( 2 ) */
/* REF = ICD( 3 ) */
/* TYPE = ICD( 4 ) */
/* IF ( TYPE .EQ. 8 ) THEN */
/* CALL SPKR08 ( HANDLE, DESCR, ET, RECORD ) */
/* . */
/* . Look at the RECORD data. */
/* . */
/* CALL SPKE08 ( ET, RECORD, STATE ) */
/* . */
/* . Check out the evaluated state. */
/* . */
/* END IF */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.0, 25-AUG-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in XPOSEG and LGRESP calls. */
/* - SPICELIB Version 1.0.0, 14-AUG-1993 (NJB) */
/* -& */
/* $ Index_Entries */
/* evaluate type_8 spk segment */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.1.0, 25-AUG-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in XPOSEG and LGRESP calls. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Size of a state vector: */
/* Indices of input record elements: */
/* -- size */
/* -- start epoch */
/* -- step size */
/* -- start of state information */
/* Local variables */
/* Use discovery check-in. */
if (return_()) {
return 0;
}
/* We'll transpose the state information in the input record */
/* so that contiguous pieces of it can be shoved directly into the */
/* interpolation routine LGRESP. */
n = i_dnnt(record);
xposeg_(&record[3], &c__6, &n, locrec);
i__1 = n * 6;
moved_(locrec, &i__1, &record[3]);
/* We interpolate each state component in turn. */
for (i__ = 1; i__ <= 6; ++i__) {
ystart = n * (i__ - 1) + 4;
state[(i__1 = i__ - 1) < 6 && 0 <= i__1 ? i__1 : s_rnge("state", i__1,
"spke08_", (ftnlen)274)] = lgresp_(&n, &record[1], &record[2]
, &record[ystart - 1], locrec, et);
}
return 0;
} /* spke08_ */
/* $Procedure MXMG ( Matrix times matrix, general dimension ) */
/* Subroutine */ int mxmg_(doublereal *m1, doublereal *m2, integer *row1,
integer *col1, integer *col2, doublereal *mout)
{
/* System generated locals */
integer m1_dim1, m1_dim2, m1_offset, m2_dim1, m2_dim2, m2_offset,
mout_dim1, mout_dim2, mout_offset, i__1, i__2, i__3, i__4, i__5;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
integer i__, j, k;
doublereal sum;
/* $ Abstract */
/* Multiply two double precision matrices of arbitrary 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. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* MATRIX */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* M1 I ROW1xCOL1 double precision matrix. */
/* M2 I COL1xCOL2 double precision matrix. */
/* ROW1 I Row dimension of M1 (and also MOUT). */
/* COL1 I Column dimension of M1 and row dimension of M2. */
/* COL2 I Column dimension of M2 (and also MOUT). */
/* MOUT O ROW1xCOL2 double precision matrix. */
/* $ Detailed_Input */
/* M1 is any double precision matrix of arbitrary size. */
/* M2 is any double precision matrix of arbitrary size. */
/* The number of rows in M2 must match the number of */
/* columns in M1. */
/* ROW1 is the number of rows in both M1 and MOUT. */
/* COL1 is the number of columns in M1 and (by necessity) */
/* the number of rows of M2. */
/* COL2 is the number of columns in both M2 and MOUT. */
/* $ Detailed_Output */
/* MOUT is a a double precision matrix of dimension */
/* ROW1 x COL2. MOUT is the product matrix given */
/* by MOUT = (M1) x (M2). MOUT must not overwrite */
/* M1 or M2. */
/* $ Parameters */
/* None. */
/* $ Examples */
/* Let M1 = | 1.0D0 4.0D0 | and M2 = | 1.0D0 3.0D0 5.0D0 | */
/* | | | | */
/* | 2.0D0 5.0D0 | | 2.0D0 4.0D0 6.0D0 | */
/* | | */
/* | 3.0D0 6.0D0 | */
/* and ROW1 = 3 */
/* COL1 = 2 */
/* COL2 = 3 */
/* Then the call */
/* CALL MXMG ( M1, M2, ROW1, COL1, COL2, MOUT ) */
/* produces the matrix */
/* MOUT = | 9.0D0 19.0D0 29.0D0 | */
/* | | */
/* | 12.0D0 26.0D0 40.0D0 | */
/* | | */
/* | 15.0D0 33.0D0 51.0D0 | */
/* $ Particulars */
/* The code reflects precisely the following mathematical expression */
/* For each value of the subscript I from 1 to NC1, and J from 1 */
/* to COL2: */
/* MOUT(I,J) = Summation from K=1 to ROW1R2 of ( M1(I,K) * M2(K,J) */
/* Since this subroutine operates on matrices of arbitrary size, it */
/* is not feasible to buffer intermediate results. Thus, MOUT */
/* should NOT overwrite either M1 or M2. */
/* $ Restrictions */
/* 1) No error checking is performed to prevent numeric overflow or */
/* underflow. */
/* 2) No error checking performed to determine if the input and */
/* output matrices have, in fact, been correctly dimensioned. */
/* 3) MOUT should not overwrite M1 or M2. */
/* $ Exceptions */
/* Error free. */
/* 1) If COL1 < 1, the elements of the matrix MOUT are set equal to */
/* zero. */
/* $ Files */
/* None. */
/* $ Author_and_Institution */
/* W.M. Owen (JPL) */
/* $ Literature_References */
/* None. */
/* $ 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 (WMO) */
/* -& */
/* $ Index_Entries */
/* matrix times matrix n-dimensional_case */
/* -& */
/* Perform the matrix multiplication */
/* Parameter adjustments */
m1_dim1 = *row1;
m1_dim2 = *col1;
m1_offset = m1_dim1 + 1;
mout_dim1 = *row1;
mout_dim2 = *col2;
mout_offset = mout_dim1 + 1;
m2_dim1 = *col1;
m2_dim2 = *col2;
m2_offset = m2_dim1 + 1;
/* Function Body */
i__1 = *row1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *col2;
for (j = 1; j <= i__2; ++j) {
sum = 0.;
i__3 = *col1;
for (k = 1; k <= i__3; ++k) {
sum += m1[(i__4 = i__ + k * m1_dim1 - m1_offset) < m1_dim1 *
m1_dim2 && 0 <= i__4 ? i__4 : s_rnge("m1", i__4,
"mxmg_", (ftnlen)183)] * m2[(i__5 = k + j * m2_dim1 -
m2_offset) < m2_dim1 * m2_dim2 && 0 <= i__5 ? i__5 :
s_rnge("m2", i__5, "mxmg_", (ftnlen)183)];
}
mout[(i__3 = i__ + j * mout_dim1 - mout_offset) < mout_dim1 *
mout_dim2 && 0 <= i__3 ? i__3 : s_rnge("mout", i__3,
"mxmg_", (ftnlen)185)] = sum;
}
}
return 0;
} /* mxmg_ */
/* $Procedure ZZBODKER ( Private --- Process Body-Name Kernel Pool Maps ) */
/* Subroutine */ int zzbodker_(char *names, char *nornam, integer *codes,
integer *nvals, logical *extker, integer *bnmlst, integer *bnmpol,
char *bnmnms, integer *bnmidx, integer *bidlst, integer *bidpol,
integer *bidids, integer *bididx, ftnlen names_len, ftnlen nornam_len,
ftnlen bnmnms_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;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Local variables */
char type__[1*2];
integer nsiz[2];
extern /* Subroutine */ int zzbodini_(char *, char *, integer *, integer *
, integer *, integer *, integer *, char *, integer *, integer *,
integer *, integer *, integer *, ftnlen, ftnlen, ftnlen);
integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
logical found;
extern logical failed_(void);
logical plfind[2];
extern /* Subroutine */ int gcpool_(char *, integer *, integer *, integer
*, char *, logical *, ftnlen, ftnlen), gipool_(char *, integer *,
integer *, integer *, integer *, logical *, ftnlen), chkout_(char
*, ftnlen), sigerr_(char *, ftnlen), dtpool_(char *, logical *,
integer *, char *, ftnlen, ftnlen), setmsg_(char *, ftnlen),
errint_(char *, integer *, ftnlen), ljucrs_(integer *, char *,
char *, 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 lists and hashes 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. */
/* $ Parameters */
/* MAXL is the maximum length of a body name. */
/* MAXP is the maximum number of additional names that may */
/* be added via the ZZBODDEF interface. */
/* NPERM is the count of the mapping assignments built into */
/* SPICE. */
/* MAXE is the size of the lists and hashes storing combined */
/* built-in and ZZBODDEF-defined name/ID mappings. To */
/* ensure efficient hashing this size is the set to the */
/* first prime number greater than ( MAXP + NPERM ). */
/* NROOM is the size of the lists and hashes storing the */
/* POOL-defined name/ID mappings. To ensure efficient */
/* hashing and to provide the ability to store nearly as */
/* many names as can fit in the POOL, this size is */
/* set to the first prime number less than MAXLIN */
/* defined in the POOL umbrella routine. */
/* $ Required_Reading */
/* naif_ids.req */
/* $ Keywords */
/* BODY */
/* CONVERSION */
/* $ Author_and_Institution */
/* B.V. Semenov (JPL) */
/* E.D. Wright (JPL) */
/* $ Version */
/* - SPICELIB Version 2.0.0, 07-MAY-2014 (BVS)(EDW) */
/* Increased NROOM to 14983. Added a comment note explaining */
/* NROOM and MAXE */
/* - SPICELIB Version 1.0.0, 20-MAY-2010 (EDW) */
/* N0064 version with MAXP = 150, NPERM = 563, */
/* MAXE = MAXP + NPERM, and NROOM = 2000. */
/* 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 */
/* Maximum number of additional names that may be added via the */
/* ZZBODDEF interface. */
/* Count of default SPICE mapping assignments. */
/* Size of the lists and hashes storing the built-in and */
/* ZZBODDEF-defined name/ID mappings. To ensure efficient hashing */
/* this size is the set to the first prime number greater than */
/* ( MAXP + NPERM ). */
/* Size of the lists and hashes storing the POOL-defined name/ID */
/* mappings. To ensure efficient hashing and to provide the ability */
/* to store nearly as many names as can fit in the POOL, this size */
/* is set to the first prime number less than MAXLIN defined in */
/* the POOL umbrella routine. */
/* $ 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, and CODES arrays. */
/* EXTKER O Logical indicating presence of kernel pool names. */
/* BNMLST O Body name-based hash head node pointer list */
/* BNMPOL O Body name-based hash node collision list */
/* BNMNMS O Body name-based hash item list */
/* BNMIDX O Body name-based hash index storage array */
/* BIDLST O Body ID-based hash head node pointer list */
/* BIDPOL O Body ID-based hash node collision list */
/* BIDIDS O Body ID-based hash item list */
/* BIDIDX O Body ID-based hash index storage array */
/* LBPOOL P Lower bound of hash pool arrays */
/* MAXL P Maximum length of body name strings. */
/* NROOM P Maximum length of kernel pool data vectors. */
/* $ Detailed_Input */
/* None. */
/* $ Detailed_Output */
/* NAMES is the array of names extracted from the kernel pool */
/* vector NAIF_BODY_NAME. This array is parallel to */
/* NORNAM and CODES. */
/* NORNAM the array of 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 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, and */
/* CODES. */
/* 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. */
/* BNMLST */
/* BNMPOL */
/* BNMNMS are the body name-based hash head node pointer, node */
/* collision, and item lists. Together they return the */
/* index of the element in the BNMIDX index storage array */
/* that stores the index of the body items in the NAMES, */
/* NORNAM, and CODES arrays. */
/* BNMIDX is the body name-based hash index storage array */
/* containing at the index determined by the hash for a */
/* given normalized name the index corresponding to this */
/* name in the NAMES, NORNAM, and CODES arrays. */
/* BIDLST */
/* BIDPOL */
/* BIDIDS are the body ID-based hash head node pointer, node */
/* collision, and item lists. Together they return the */
/* index of the element in the BNMIDX index storage array */
/* that stores the index of the body items in the */
/* NAMES, NORNAM, and CODES arrays. */
/* BIDIDX is the body ID-based hash index storage array */
/* containing at the index determined by the hash for a */
/* given ID the index corresponding to this ID in the */
/* NAMES, NORNAM, and CODES arrays. */
/* $ Parameters */
/* LBPOOL is the lower bound of the hashes' collision list array. */
/* 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. */
/* $ 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. */
/* $ Files */
/* None. */
/* $ 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 name/code lists and hashes that ZZBODTRN requires to */
/* resolve code to name and name to code mappings. */
/* The NAMES and CODES arrays stored all values provided in the */
/* corresponding POOL variables. No attempt to remove duplicates, */
/* change order, or do any other alterations to these arrays is made */
/* by this routine. */
/* The order of mapping in the NAMES, NORNAM, and CODES arrays */
/* determines the priority, with the mapping with the lowest */
/* priority being first and the mapping with the highest priority */
/* being last. */
/* If more than one entry with a particular normalized name is */
/* present in the NORNAM array, only the latest entry is registered */
/* in the name-based hash. */
/* If more than one entry with a particular ID is present in the */
/* CODES array, only the latest entry that maps to a not-yet */
/* registered normalized name is registered in the ID-based hash. */
/* Registering IDs only for not-yet registered names achieves masking */
/* all IDs with the lower priority in cases when a single normalized */
/* name maps to more than one ID. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* B.V. Semenov (JPL) */
/* F.S. Turner (JPL) */
/* E.D. Wright (JPL) */
/* $ Version */
/* - SPICELIB Version 2.0.0, 16-SEP-2013 (BVS) */
/* Changed routine's calling sequence by dropping name and ID */
/* order vectors and adding name- and ID-based hashes and */
/* modified it to initialize hashes instead of the order arrays. */
/* - 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__14983, num, names, plfind, (ftnlen)32, (ftnlen)36)
;
gipool_(nbc, &c__1, &c__14983, &num[1], codes, &plfind[1], (ftnlen)32);
if (failed_()) {
chkout_("ZZBODKER", (ftnlen)8);
return 0;
}
/* 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 (failed_()) {
chkout_("ZZBODKER", (ftnlen)8);
return 0;
}
if (nsiz[0] > 14983 || nsiz[1] > 14983) {
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__14983, (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 upper-cases 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) < 14983 && 0 <= i__2 ? i__2 :
s_rnge("names", i__2, "zzbodker_", (ftnlen)403)) * 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. */
ljucrs_(&c__1, names + ((i__2 = i__ - 1) < 14983 && 0 <= i__2 ? i__2 :
s_rnge("names", i__2, "zzbodker_", (ftnlen)419)) * 36,
nornam + ((i__3 = i__ - 1) < 14983 && 0 <= i__3 ? i__3 :
s_rnge("nornam", i__3, "zzbodker_", (ftnlen)419)) * 36, (
ftnlen)36, (ftnlen)36);
}
/* Populate hashes required by ZZBODTRN. */
zzbodini_(names, nornam, codes, nvals, &c__14983, bnmlst, bnmpol, bnmnms,
bnmidx, bidlst, bidpol, bidids, bididx, (ftnlen)36, (ftnlen)36, (
ftnlen)36);
if (failed_()) {
chkout_("ZZBODKER", (ftnlen)8);
return 0;
}
/* 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 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 ZZPLATFM ( Private --- Get platform attributes ) */
/* Subroutine */ int zzplatfm_(char *key, char *value, ftnlen key_len, ftnlen
value_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
integer index;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
static char keyval[64*6];
char keycpy[64];
static char attcpy[32*7];
/* $ Abstract */
/* Return platform ID and various attributes of the intended */
/* environment */
/* $ 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 */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* KEY I String indicating what information to return. */
/* VALUE O String containing the requested information. */
/* $ Detailed_Input */
/* KEY is a string value that indicates which platform */
/* specific information is desired. Acceptable inputs */
/* are: */
/* 'SYSTEM' - System Identification String */
/* 'O/S' - Operating System or Environment */
/* 'COMPILER' - NAIF Supported Compiler */
/* 'FILE_FORMAT' - Native Binary File Format */
/* 'TEXT_FORMAT' - Native Text File Format */
/* 'READS_BFF' - List of supported binary file */
/* formats. */
/* Note: The comparison is case-insensitive, and the */
/* supplied value must fit into a string buffer */
/* KYSIZE characters in length. */
/* $ Detailed_Output */
/* VALUE is the string that holds the information requested */
/* by the input string KEY. VALUE must be able to */
/* contain the maximum number of characters returned */
/* by this routine, WDSIZE, or truncation will occur. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the KEY is invalid, then VALUE is set to the value */
/* stored in the character string parameter DEFRPY defined */
/* below. */
/* 2) If VALUE is not large enough to contain the requested */
/* KEY's value, then truncation will occur. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine serves to identify the platform and compiler */
/* used in creating SPICELIB. It is provided so that routines */
/* and programs can make run-time decisions based upon the */
/* ambient Fortran environment. */
/* Operating Systems: */
/* This routine is now aware of the operating systems for which */
/* the code is intended for compilation. In some cases this may */
/* be more than one operating system, particularly in the case */
/* of the PC. */
/* Binary File Format: */
/* This routine now adds the capability to return at run time */
/* the binary file architecture that is native to the system. */
/* Text File Format: */
/* This routine now has the capability to return at run time */
/* the mechanism (or line terminator) used to delimit lines */
/* in text files. In most cases it will return common labels */
/* for the special characters FORTRAN considers line break */
/* indicators. */
/* Binary File Formats Read: */
/* This returns a space delimited list of all the binary file */
/* formats this environment can read for DAF/DAS based files. */
/* $ Examples */
/* This routine could be used so that a single routine */
/* could be written that translates the meaning of IOSTAT values */
/* that depend upon the machine and compiler. At run time */
/* the routine could look up the appropriate message to associate */
/* with an IOSTAT value. */
/* $ Restrictions */
/* 1) VALUE must be large enough to contain the requested */
/* information, otherwise truncation will occur. */
/* 2) The string passed in via the KEY input must be capable */
/* of being properly copied into the KEYCPY buffer internal */
/* to this routine. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* F.S. Turner (JPL) */
/* E.D. Wright (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 2.9.0, 16-MAR-2010 (EDW) */
/* Updated for: */
/* - MAC-OSX-64BIT-INTEL_C */
/* - PC-64BIT-MS_C */
/* - SUN-SOLARIS-64BIT-NATIVE_C */
/* MAC-OSX-64BIT-GFORTRAN */
/* MAC-OSX-64BIT-IFORT */
/* PC-LINUX-64BIT-GFORTRAN */
/* PC-WINDOWS-64BIT-IFORT */
/* SUN-SOLARIS-INTEL-64BIT-CC_C */
/* SUN-SOLARIS-INTEL-CC_C */
/* SUN-SOLARIS-INTEL */
/* environments. */
/* - SPICELIB Version 2.8.0, 12-JAN-2009 (EDW) */
/* Added MAC-OSX-GFORTRAN PC-LINUX-GFORTRAN environments. */
/* - SPICELIB Version 2.7.0, 19-FEB-2008 (BVS) */
/* Added PC-LINUX-IFORT environment. */
/* - SPICELIB Version 2.6.0, 15-NOV-2006 (NJB) */
/* Added PC-WINDOWS-IFORT, MAC-OSX-IFORT, and MAC-OSX-INTEL_C */
/* environments. */
/* - SPICELIB Version 2.5.0, 21-FEB-2006 (NJB) */
/* Added PC-LINUX-64BIT-GCC_C environment. */
/* Corrected error in in-line comments: changed keyword */
/* from FILE_ARCH to FILE_FORMAT. */
/* - SPICELIB Version 2.4.0, 14-MAR-2005 (BVS) */
/* Added SUN-SOLARIS-64BIT-GCC_C environment. */
/* - SPICELIB Version 2.3.0, 31-DEC-2004 (BVS) */
/* Added PC CYGWIN environments. Changed OS for PC-LAHEY, */
/* PC-DIGITAL, and PC-MS_C to 'MICROSOFT WINDOWS'. */
/* - SPICELIB Version 2.2.0, 07-JUL-2002 (EDW) */
/* Added Mac OS X Unix environment. */
/* - SPICELIB Version 2.1.0, 06-FEB-2002 (FST) */
/* Updated the 'TEXT_FORMAT' key value for the PC-LINUX_C */
/* environment. Previous versions incorrectly indicated */
/* 'CR-LF' as line terminators. */
/* - SPICELIB Version 2.0.0, 05-JUN-2001 (FST) */
/* Added TEXT_FORMAT and READS_BFF key/value pairs. */
/* Modified the header slightly to improve word choice; */
/* specifically binary file format replaces file */
/* architecture. */
/* Updated the compiler entry for the PC-LINUX */
/* environment to refer to g77 as opposed to f2c. */
/* Updated the compiler entry for the MACPPC environment. */
/* This environment is now officially tied to Absoft */
/* Fortran. */
/* Updated the compiler entry for the PC-LAHEY environment. */
/* The compiler for this environment is LF95, the latest */
/* offering from Lahey. */
/* - SPICELIB Version 1.0.0, 22-FEB-1999 (FST) */
/* -& */
/* $ Index_Entries */
/* fetch platform dependent information */
/* -& */
/* SPICELIB Functions */
/* Local Parameters */
/* Array index parameters for each of the key/value pairs. */
/* SYSTEM Index. */
/* O/S Index. */
/* Compiler Index. */
/* Binary File Format Index. */
/* Text File Format Index */
/* Reads Binary File Format Index. */
/* Size of the buffer in which KEY is placed. */
/* Maximum Size of local string returned in VALUE */
/* Number of Platform Dependent values stored here. */
/* Default Reply in the event of an invalid KEY. */
/* Local Variables */
/* Saved Variables */
/* Data Statements */
/* Make the initial assignments to the saved character array. */
if (first) {
/* Store the keys in the KEYVAL array. */
s_copy(keyval, "SYSTEM", (ftnlen)64, (ftnlen)6);
s_copy(keyval + 64, "O/S", (ftnlen)64, (ftnlen)3);
s_copy(keyval + 128, "COMPILER", (ftnlen)64, (ftnlen)8);
s_copy(keyval + 192, "FILE_FORMAT", (ftnlen)64, (ftnlen)11);
s_copy(keyval + 256, "TEXT_FORMAT", (ftnlen)64, (ftnlen)11);
s_copy(keyval + 320, "READS_BFF", (ftnlen)64, (ftnlen)9);
/* Set the default reply to be the zero'th component of ATTCPY. */
/* This obviates IF-THEN-ELSE branching all together. */
s_copy(attcpy, "<UNAVAILABLE> ", (ftnlen)32, (
ftnlen)32);
/* Platform/Environment specific assignments follow. */
s_copy(attcpy + 32, "PC", (ftnlen)32, (ftnlen)2);
s_copy(attcpy + 64, "LINUX", (ftnlen)32, (ftnlen)5);
s_copy(attcpy + 96, "GCC/64BIT", (ftnlen)32, (ftnlen)9);
s_copy(attcpy + 128, "LTL-IEEE", (ftnlen)32, (ftnlen)8);
s_copy(attcpy + 160, "LF", (ftnlen)32, (ftnlen)2);
s_copy(attcpy + 192, "BIG-IEEE LTL-IEEE", (ftnlen)32, (ftnlen)17);
/* Don't execute these assignments again. */
first = FALSE_;
}
/* Determine which KEY was passed in; do this by converting KEY */
/* to the known member of the equivalence class of possible */
/* values. */
ucase_(key, keycpy, key_len, (ftnlen)64);
ljust_(keycpy, keycpy, (ftnlen)64, (ftnlen)64);
/* Find out which key we were given. In the event that one of the */
/* KEYVALs (or some equivalent string) was not passed in, ISRCHC */
/* returns a value of zero. */
index = isrchc_(keycpy, &c__6, keyval, (ftnlen)64, (ftnlen)64);
s_copy(value, attcpy + (((i__1 = index) < 7 && 0 <= i__1 ? i__1 : s_rnge(
"attcpy", i__1, "zzplatfm_", (ftnlen)413)) << 5), value_len, (
ftnlen)32);
return 0;
} /* zzplatfm_ */
/* $Procedure TRACEG ( Trace of a matrix, general dimension ) */
doublereal traceg_(doublereal *matrix, integer *ndim)
{
/* System generated locals */
integer matrix_dim1, matrix_dim2, matrix_offset, i__1, i__2;
doublereal ret_val;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
integer i__;
/* $ Abstract */
/* Return the trace of a square matrix of arbitrary dimension. */
/* $ 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 */
/* MATRIX */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* MATRIX I NDIM x NDIM matrix of double precision numbers. */
/* NDIM I Dimension of the matrix. */
/* TRACEG O The trace of MATRIX. */
/* $ Detailed_Input */
/* MATRIX is a double precision square matrix of arbitrary */
/* dimension. The input matrix must be square or else */
/* the concept is meaningless. */
/* NDIM is the dimension of MATRIX. */
/* $ Detailed_Output */
/* TRACEG is the trace of MATRIX, i.e. it is the sum of the */
/* diagonal elements of MATRIX. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* TRACEG simply executes in FORTRAN code the following loop: */
/* TRACEG = Summation from I = 1 to NDIM of MATRIX(I,I) */
/* No error detection or correction is implemented within this */
/* function. */
/* $ Examples */
/* | 3 5 7 | */
/* Suppose that MATRIX = | 0 -2 8 | (with NDIM = 3), then */
/* | 3 0 -1 | */
/* TRACEG (MATRIX, 3) = 0. (which is the sum of 3, -2 and -1). */
/* $ Restrictions */
/* No checking is performed to guard against floating point overflow */
/* or underflow. This routine should probably not be used if the */
/* input matrix is expected to have large double precision numbers */
/* along the diagonal. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* $ Literature_References */
/* None. */
/* $ 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 (WLT) */
/* -& */
/* $ Index_Entries */
/* trace of a nxn_matrix */
/* -& */
/* Parameter adjustments */
matrix_dim1 = *ndim;
matrix_dim2 = *ndim;
matrix_offset = matrix_dim1 + 1;
/* Function Body */
ret_val = 0.;
i__1 = *ndim;
for (i__ = 1; i__ <= i__1; ++i__) {
ret_val += matrix[(i__2 = i__ + i__ * matrix_dim1 - matrix_offset) <
matrix_dim1 * matrix_dim2 && 0 <= i__2 ? i__2 : s_rnge("matr"
"ix", i__2, "traceg_", (ftnlen)133)];
}
return ret_val;
} /* traceg_ */
/* $Procedure XFMSTA ( Transform state between coordinate systems) */
/* Subroutine */ int xfmsta_(doublereal *istate, char *icosys, char *ocosys,
char *body, doublereal *ostate, ftnlen icosys_len, ftnlen ocosys_len,
ftnlen body_len)
{
/* Initialized data */
static char cosys[40*6] = "RECTANGULAR "
"CYLINDRICAL " "LATITUDINAL "
" " "SPHERICAL "
"GEODETIC " "PLANETOGRAPHIC "
" ";
static logical first = TRUE_;
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
extern /* Subroutine */ int zzbods2c_(integer *, char *, integer *,
logical *, char *, integer *, logical *, ftnlen, ftnlen);
doublereal ivel[3], ipos[3];
extern /* Subroutine */ int vequ_(doublereal *, doublereal *);
integer isys, osys;
doublereal f;
extern /* Subroutine */ int zzctruin_(integer *);
integer i__, j;
doublereal radii[3];
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen), vpack_(doublereal *, doublereal *, doublereal *,
doublereal *);
extern doublereal dpmax_(void);
logical found;
extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen), vequg_(
doublereal *, integer *, doublereal *);
doublereal sqtmp;
char isysu[40], osysu[40];
static logical svfnd1;
static integer svctr1[2];
extern logical failed_(void);
doublereal jacobi[9] /* was [3][3] */;
extern /* Subroutine */ int bodvcd_(integer *, char *, integer *, integer
*, doublereal *, ftnlen), georec_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), drdgeo_(
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *), recgeo_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), dgeodr_(
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *);
integer bodyid;
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
static integer svbdid;
extern /* Subroutine */ int latrec_(doublereal *, doublereal *,
doublereal *, doublereal *), drdlat_(doublereal *, doublereal *,
doublereal *, doublereal *), cylrec_(doublereal *, doublereal *,
doublereal *, doublereal *), drdcyl_(doublereal *, doublereal *,
doublereal *, doublereal *);
doublereal toobig;
extern /* Subroutine */ int sphrec_(doublereal *, doublereal *,
doublereal *, doublereal *), drdsph_(doublereal *, doublereal *,
doublereal *, doublereal *), pgrrec_(char *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, ftnlen), drdpgr_(char *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, ftnlen),
reccyl_(doublereal *, doublereal *, doublereal *, doublereal *),
reclat_(doublereal *, doublereal *, doublereal *, doublereal *),
sigerr_(char *, ftnlen), recsph_(doublereal *, doublereal *,
doublereal *, doublereal *), chkout_(char *, ftnlen), recpgr_(
char *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, ftnlen), dcyldr_(doublereal *,
doublereal *, doublereal *, doublereal *), dlatdr_(doublereal *,
doublereal *, doublereal *, doublereal *), ljucrs_(integer *,
char *, char *, ftnlen, ftnlen), setmsg_(char *, ftnlen), dsphdr_(
doublereal *, doublereal *, doublereal *, doublereal *);
static char svbody[36];
extern /* Subroutine */ int dpgrdr_(char *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, ftnlen);
extern logical return_(void);
integer dim;
extern /* Subroutine */ int mxv_(doublereal *, doublereal *, doublereal *)
;
/* $ Abstract */
/* Transform a state between coordinate systems. */
/* $ 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 */
/* COORDINATE */
/* EPHEMERIS */
/* STATE */
/* $ Declarations */
/* $ Abstract */
/* This include file defines the dimension of the counter */
/* array used by various SPICE subsystems to uniquely identify */
/* changes in their states. */
/* $ 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 */
/* CTRSIZ is the dimension of the counter array used by */
/* various SPICE subsystems to uniquely identify */
/* changes in their states. */
/* $ Author_and_Institution */
/* B.V. Semenov (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 29-JUL-2013 (BVS) */
/* -& */
/* End of include file. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- ------------------------------------------------- */
/* ISTATE I Input state. */
/* ICOSYS I Current (input) coordinate system. */
/* OCOSYS I Desired (output) coordinate system. */
/* BODY I Name or NAIF ID of body with which */
/* coordinates are associated (if applicable). */
/* OSTATE O Converted output state. */
/* $ Detailed_Input */
/* ISTATE is a state vector in the input (ICOSYS) coordinate */
/* system representing position and velocity. */
/* All angular measurements must be in radians. */
/* Note: body radii values taken from the kernel */
/* pool are used when converting to or from geodetic or */
/* planetographic coordinates. It is the user's */
/* responsibility to verify the distance inputs are in */
/* the same units as the radii in the kernel pool, */
/* typically kilometers. */
/* ICOSYS is the name of the coordinate system that the input */
/* state vector (ISTATE) is currently in. */
/* ICOSYS may be any of the following: */
/* 'RECTANGULAR' */
/* 'CYLINDRICAL' */
/* 'LATITUDINAL' */
/* 'SPHERICAL' */
/* 'GEODETIC' */
/* 'PLANETOGRAPHIC' */
/* Leading spaces, trailing spaces, and letter case */
/* are ignored. For example, ' cyLindRical ' would be */
/* accepted. */
/* OCOSYS is the name of the coordinate system that the state */
/* should be converted to. */
/* Please see the description of ICOSYS for details. */
/* BODY is the name or NAIF ID of the body associated with the */
/* planetographic or geodetic coordinate system. */
/* If neither of the coordinate system choices are */
/* geodetic or planetographic, BODY may be an empty */
/* string (' '). */
/* Examples of accepted body names or IDs are: */
/* 'Earth' */
/* '399' */
/* Leading spaces, trailing spaces, and letter case are */
/* ignored. */
/* $ Detailed_Output */
/* OSTATE is the state vector that has been converted to the */
/* output coordinate system (OCOSYS). */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If either the input or output coordinate system is not */
/* recognized, the error SPICE(COORDSYSNOTREC) is signaled. */
/* 2) If the input body name cannot be converted to a NAIF ID */
/* (applies to geodetic and planetographic coordinate */
/* systems), the error 'SPICE(IDCODENOTFOUND)' is signaled. */
/* 3) If the input state ISTATE is not valid, meaning the position */
/* but not the velocity is along the z-axis, the error */
/* 'SPICE(INVALIDSTATE)' is signaled. */
/* Note: If both the input position and velocity are along */
/* the z-axis and the output coordinate system is not */
/* rectangular, the velocity can still be calculated even */
/* though the Jacobian is undefined. This case will not */
/* signal an error. An example of the input position and */
/* velocity along the z-axis is below. */
/* Term Value */
/* ----- ------ */
/* x 0 */
/* y 0 */
/* z z */
/* dx/dt 0 */
/* dy/dt 0 */
/* dz/dt dz_dt */
/* 4) If either the input or output coordinate system is */
/* geodetic or planetographic and at least one of the body's */
/* radii is less than or equal to zero, the error */
/* SPICE(INVALIDRADIUS) will be signaled. */
/* 5) If either the input or output coordinate system is */
/* geodetic or planetographic and the difference of the */
/* equatorial and polar radii divided by the equatorial radius */
/* would produce numeric overflow, the error */
/* 'SPICE(INVALIDRADIUS)' will be signaled. */
/* 6) If the product of the Jacobian and velocity components */
/* may lead to numeric overflow, the error */
/* 'SPICE(NUMERICOVERFLOW)' is signaled. */
/* $ Files */
/* SPK, PCK, CK, and FK kernels may be required. */
/* If the input or output coordinate systems are either geodetic or */
/* planetographic, a PCK providing the radii of the body */
/* name BODY must be loaded via FURNSH. */
/* Kernel data are normally loaded once per program run, NOT every */
/* time this routine is called. */
/* $ Particulars */
/* Input Order */
/* ------------------------------------------- */
/* The input and output states will be structured by the */
/* following descriptions. */
/* For rectangular coordinates, the state vector is the following */
/* in which X, Y, and Z are the rectangular position components and */
/* DX, DY, and DZ are the time derivatives of each position */
/* component. */
/* ISTATE = ( X, Y, Z, DX, DY, DZ ) */
/* For cylindrical coordinates, the state vector is the following */
/* in which R is the radius, LONG is the longitudes, Z is the */
/* height, and DR, DLONG, and DZ are the time derivatives of each */
/* position component. */
/* ISTATE = ( R, LONG, Z, DR, DLONG, DZ ) */
/* For latitudinal coordinates, the state vector is the following */
/* in which R is the radius, LONG is the longitude, LAT is the */
/* latitude, and DR, DLONG, and DLAT are the time derivatives of */
/* each position component. */
/* ISTATE = ( R, LONG, LAT, DR, DLONG, DLAT ) */
/* For spherical coordinates, the state vector is the following in */
/* which R is the radius, COLAT is the colatitude, LONG is the */
/* longitude, and DR, DCOLAT, and DLONG are the time derivatives of */
/* each position component. */
/* ISTATE = ( R, COLAT, LONG, DR, DCOLAT, DLONG ) */
/* For geodetic coordinates, the state vector is the following in */
/* which LONG is the longitude, LAT is the latitude, ALT is the */
/* altitude, and DLONG, DLAT, and DALT are the time derivatives of */
/* each position component. */
/* ISTATE = ( LONG, LAT, ALT, DLONG, DLAT, DALT ) */
/* For planetographic coordinates, the state vector is the */
/* following in which LONG is the longitude, LAT is the latitude, */
/* ALT is the altitude, and DLONG, DLAT, and DALT are the time */
/* derivatives of each position component. */
/* ISTATE = ( LONG, LAT, ALT, DLONG, DLAT, DALT ) */
/* Input Boundaries */
/* ------------------------------------------- */
/* There are intervals the input angles must fall within if */
/* the input coordinate system is not rectangular. These */
/* intervals are provided below. */
/* Input variable Input meaning Input interval [rad] */
/* -------------- ------------- ------------------------ */
/* LONG Longitude 0 <= LONG < 2*pi */
/* LAT Latitude -pi/2 <= LAT <= pi/2 */
/* COLAT Colatitude 0 <= COLAT <= pi */
/* $ Examples */
/* The numerical results shown for these examples may differ across */
/* platforms. The results depend on the SPICE kernels used as */
/* input, the compiler and supporting libraries, and the machine */
/* specific arithmetic implementation. */
/* 1) Find the apparent state of Phoebe as seen by CASSINI in the */
/* J2000 frame at 2004 Jun 11 19:32:00. Transform the state */
/* from rectangular to latitudinal coordinates. For verification, */
/* transform the state back from latitudinal to rectangular */
/* coordinates. */
/* Use the meta-kernel shown below to load the required SPICE */
/* kernels. */
/* KPL/MK */
/* File name: xfmsta_ex1.tm */
/* This meta-kernel is intended to support operation of SPICE */
/* example programs. The kernels shown here should not be */
/* assumed to contain adequate or correct versions of data */
/* required by SPICE-based user applications. */
/* In order for an application to use this meta-kernel, the */
/* kernels referenced here must be present in the user's */
/* current working directory. */
/* The names and contents of the kernels referenced */
/* by this meta-kernel are as follows: */
/* File name Contents */
/* --------- -------- */
/* cpck05Mar2004.tpc Planet orientation and */
/* radii */
/* naif0009.tls Leapseconds */
/* 020514_SE_SAT105.bsp Satellite ephemeris for */
/* Saturn */
/* 030201AP_SK_SM546_T45.bsp CASSINI ephemeris */
/* 981005_PLTEPH-DE405S.bsp Planetary ephemeris */
/* \begindata */
/* KERNELS_TO_LOAD = ( 'naif0009.tls' , */
/* '020514_SE_SAT105.bsp' , */
/* '030201AP_SK_SM546_T45.bsp' , */
/* '981005_PLTEPH-DE405S.bsp', */
/* 'cpck05Mar2004.tpc' ) */
/* End of meta-kernel */
/* Example code begins here. */
/* PROGRAM EX1_XFMSTA */
/* IMPLICIT NONE */
/* C */
/* C Local parameters */
/* C */
/* C METAKR is the meta-kernel's filename. */
/* C */
/* CHARACTER*(*) METAKR */
/* PARAMETER ( METAKR = 'xfmsta_ex1.tm' ) */
/* CHARACTER*(*) FORM */
/* PARAMETER ( FORM = '(F16.6, F16.6, F16.6)' ) */
/* C */
/* C Local variables */
/* C */
/* C STAREC is the state of Phoebe with respect to CASSINI in */
/* C rectangular coordinates. STALAT is the state rotated into */
/* C latitudinal coordinates. STREC2 is the state transformed */
/* C back into rectangular coordinates from latitudinal. */
/* C */
/* DOUBLE PRECISION STAREC (6) */
/* DOUBLE PRECISION STALAT (6) */
/* DOUBLE PRECISION STREC2 (6) */
/* C */
/* C ET is the ephemeris time (TDB) corresponding to the */
/* C observation. */
/* C */
/* DOUBLE PRECISION ET */
/* DOUBLE PRECISION LT */
/* INTEGER I */
/* C */
/* C The required kernels must be loaded. */
/* C */
/* CALL FURNSH ( METAKR ) */
/* C */
/* C Calculate the state at 2004 Jun 11 19:32:00 UTC. */
/* C */
/* CALL STR2ET ( '2004-JUN-11-19:32:00', ET ) */
/* C */
/* C Calculate the apparent state of Phoebe as seen by */
/* C CASSINI in the J2000 frame. */
/* C */
/* CALL SPKEZR ( 'PHOEBE', ET, 'IAU_PHOEBE', 'LT+S', */
/* . 'CASSINI', STAREC, LT ) */
/* C */
/* C Transform the state from rectangular to latitudinal. */
/* C Notice that since neither the input nor output */
/* C coordinate frames are 'geodetic' or 'planetographic', */
/* C the input for the body name is a blank string. */
/* C */
/* CALL XFMSTA ( STAREC, 'RECTANGULAR', 'LATITUDINAL', ' ', */
/* . STALAT ) */
/* C */
/* C Transform the state back to rectangular from latitudinal */
/* C for verification. This result should be very similar to */
/* C STAREC. */
/* C */
/* CALL XFMSTA ( STALAT, 'LATITUDINAL', 'RECTANGULAR',' ', */
/* . STREC2 ) */
/* C */
/* C Report the results. */
/* C */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Phoebe as seen by CASSINI - rectangular' */
/* WRITE (*,*) ' Position [km]:' */
/* WRITE (*,FORM) (STAREC(I), I = 1, 3) */
/* WRITE (*,*) ' Velocity [km/s]:' */
/* WRITE (*,FORM) (STAREC(I), I = 4, 6) */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Phoebe as seen by CASSINI - latitudinal' */
/* WRITE (*,*) ' Position [km, rad, rad]:' */
/* WRITE (*,FORM) (STALAT(I), I = 1, 3) */
/* WRITE (*,*) ' Velocity [km/s, rad/s, rad/s]:' */
/* WRITE (*,FORM) (STALAT(I), I = 4, 6) */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Verification: ' */
/* WRITE (*,*) 'Phoebe as seen by CASSINI - rectangular' */
/* WRITE (*,*) ' Position [km]:' */
/* WRITE (*,FORM) (STREC2(I), I = 1, 3) */
/* WRITE (*,*) ' Velocity [km/s]:' */
/* WRITE (*,FORM) (STREC2(I), I = 4, 6) */
/* END */
/* When this program was executed using gfortran on a PC Linux */
/* 64 bit environment, the output was: */
/* Phoebe as seen by CASSINI - rectangular */
/* Position [km]: */
/* -1982.639762 -934.530471 -166.562595 */
/* Velocity [km/s]: */
/* 3.970832 -3.812496 -2.371663 */
/* Phoebe as seen by CASSINI - latitudinal */
/* Position [km, rad, rad]: */
/* 2198.169858 -2.701121 -0.075846 */
/* Velocity [km/s, rad/s, rad/s]: */
/* -1.780939 0.002346 -0.001144 */
/* Verification: */
/* Phoebe as seen by CASSINI - rectangular */
/* Position [km]: */
/* -1982.639762 -934.530471 -166.562595 */
/* Velocity [km/s]: */
/* 3.970832 -3.812496 -2.371663 */
/* 2) Transform a given state from cylindrical to planetographic */
/* coordinates with respect to Earth. */
/* Use the meta-kernel shown below to load the required SPICE */
/* kernels. */
/* KPL/MK */
/* File name: xfmsta_ex2.tm */
/* This meta-kernel is intended to support operation of SPICE */
/* example programs. The kernels shown here should not be */
/* assumed to contain adequate or correct versions of data */
/* required by SPICE-based user applications. */
/* In order for an application to use this meta-kernel, the */
/* kernels referenced here must be present in the user's */
/* current working directory. */
/* The names and contents of the kernels referenced */
/* by this meta-kernel are as follows: */
/* File name Contents */
/* --------- -------- */
/* cpck05Mar2004.tpc Planet orientation and */
/* radii */
/* \begindata */
/* KERNELS_TO_LOAD = ( 'cpck05Mar2004.tpc' ) */
/* \begintext */
/* End of meta-kernel */
/* Example code begins here. */
/* PROGRAM EX2_XFMSTA */
/* IMPLICIT NONE */
/* C */
/* C Local parameters */
/* C */
/* C METAKR is the meta-kernel's filename. */
/* C */
/* CHARACTER*(*) METAKR */
/* PARAMETER ( METAKR = 'xfmsta_ex2.tm' ) */
/* CHARACTER*(*) FORM */
/* PARAMETER ( FORM = '(F16.6, F16.6, F16.6)' ) */
/* C */
/* C Local variables */
/* C */
/* C STACYL is the state in cylindrical coordinates. */
/* C */
/* DOUBLE PRECISION STACYL (6) */
/* C */
/* C STAPLN is the state transformed into planetographic */
/* C coordinates. */
/* C */
/* DOUBLE PRECISION STAPLN (6) */
/* C */
/* C STCYL2 is the state transformed back into */
/* C cylindrical coordinates from planetographic. */
/* C */
/* DOUBLE PRECISION STCYL2 (6) */
/* INTEGER I */
/* DATA STACYL / 1.0D0, 0.5D0, 0.5D0, 0.2D0, 0.1D0, -0.2D0 / */
/* C */
/* C The required kernels must be loaded. */
/* C */
/* CALL FURNSH ( METAKR ) */
/* C */
/* C Transform the state from cylindrical to planetographic. */
/* C Note that since one of the coordinate systems is */
/* C planetographic, the body name must be input. */
/* C */
/* CALL XFMSTA ( STACYL, 'CYLINDRICAL', 'PLANETOGRAPHIC', */
/* . 'EARTH', STAPLN ) */
/* C */
/* C Transform the state back to cylindrical from */
/* C planetographic for verification. The result should be very */
/* C close to STACYL. */
/* C */
/* CALL XFMSTA ( STAPLN, 'PLANETOGRAPHIC', 'CYLINDRICAL', */
/* . 'EARTH', STCYL2 ) */
/* C */
/* C Report the results. */
/* C */
/* WRITE (*,*) 'Cylindrical state' */
/* WRITE (*,*) ' Position [km, rad, km]:' */
/* WRITE (*,FORM) (STACYL(I), I = 1, 3) */
/* WRITE (*,*) ' Velocity [km/s, rad/s, km/s]:' */
/* WRITE (*,FORM) (STACYL(I), I = 4, 6) */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Planetographic state' */
/* WRITE (*,*) ' Position [rad, rad, km]:' */
/* WRITE (*,FORM) (STAPLN(I), I = 1, 3) */
/* WRITE (*,*) ' Velocity [rad/s, rad/s, km/s]:' */
/* WRITE (*,FORM) (STAPLN(I), I = 4, 6) */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Verification: Cylindrical state' */
/* WRITE (*,*) ' Position [km, rad, km]:' */
/* WRITE (*,FORM) (STCYL2(I), I = 1, 3) */
/* WRITE (*,*) ' Velocity [km/s, rad/s, km/s]:' */
/* WRITE (*,FORM) (STCYL2(I), I = 4, 6) */
/* END */
/* When this program was executed using gfortran on a PC Linux */
/* 64 bit environment, the output was: */
/* Cylindrical state */
/* Position [km, rad, km]: */
/* 1.000000 0.500000 0.500000 */
/* Velocity [km/s, rad/s, km/s]: */
/* 0.200000 0.100000 -0.200000 */
/* Planetographic state */
/* Position [rad, rad, km]: */
/* 0.500000 1.547727 -6356.238467 */
/* Velocity [rad/s, rad/s, km/s]: */
/* 0.100000 -0.004721 -0.195333 */
/* Verification: Cylindrical state */
/* Position [km, rad, km]: */
/* 1.000000 0.500000 0.500000 */
/* Velocity [km/s, rad/s, km/s]: */
/* 0.200000 0.100000 -0.200000 */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* S.C. Krening (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0 22-APR-2014 (SCK)(BVS) */
/* -& */
/* $ Index_Entries */
/* state transformation between coordinate systems */
/* convert state */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Potentially large numbers produced by transforming the */
/* velocity using the Jacobian must not exceed DPMAX()/MARGIN: */
/* The size of each coordinate system name must not exceed */
/* CHSIZ characters. */
/* NCOSYS is the number of coordinate systems supported by */
/* this routine. */
/* The following integer parameters represent the coordinate */
/* systems supported by this routine. */
/* Saved body name length. */
/* Local variables */
/* COSYS is the array of supported coordinate system names. */
/* ISYSU and OSYSU are the input and output coordinate systems */
/* from the user that are made insensitive to case or leading and */
/* trailing spaces. */
/* IPOS and IVEL are the input position and velocity translated */
/* into rectangular. */
/* For transformations including either geodetic or planetographic */
/* coordinate systems, RADII is an array of the radii values */
/* associated with the input body. These values will be loaded */
/* from the kernel pool. */
/* JACOBI is the Jacobian matrix that converts the velocity */
/* coordinates between systems. */
/* The flattening coefficient, F, is calculated when either */
/* geodetic or planetographic coordinate systems are included */
/* in the transformation. */
/* SQTMP and TOOBIG are used to check for possible numeric */
/* overflow situations. */
/* BODYID and DIM are only used when the input or output coordinate */
/* systems are geodetic or planetographic. The BODYID is the NAID ID */
/* associated with the input body name. DIM is used while retrieving */
/* the radii from the kernel pool. */
/* ISYS and OSYS are the integer codes corresponding to the */
/* input and output coordinate systems. I and J are iterators. */
/* Saved name/ID item declarations. */
/* Saved variables */
/* Saved name/ID items. */
/* Assign the names of the coordinate systems to a character */
/* array in which each coordinate system name is located at */
/* the index of the integer ID of the coordinate system. */
/* Initial values. */
/* There are three main sections of this routine: */
/* 1) Error handling and initialization. */
/* 2) Conversion of the input to rectangular coordinates. */
/* 3) Conversion from rectangular to the output coordinates. */
/* Error handling and initialization */
/* ---------------------------------------------------------------- */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
chkin_("XFMSTA", (ftnlen)6);
/* Initialization. */
if (first) {
/* Initialize counter. */
zzctruin_(svctr1);
first = FALSE_;
}
/* Remove initial and trailing spaces. */
/* Convert the input coordinate systems to upper case. */
ljucrs_(&c__0, icosys, isysu, icosys_len, (ftnlen)40);
ljucrs_(&c__0, ocosys, osysu, ocosys_len, (ftnlen)40);
/* Check to see if the input and output coordinate systems */
/* provided by the user are acceptable. Store the integer */
/* code of the input and output coordinate systems into */
/* ISYS and OSYS. */
isys = isrchc_(isysu, &c__6, cosys, (ftnlen)40, (ftnlen)40);
osys = isrchc_(osysu, &c__6, cosys, (ftnlen)40, (ftnlen)40);
/* If the coordinate systems are not acceptable, an error is */
/* signaled. */
if (isys == 0 || osys == 0) {
if (isys == 0 && osys == 0) {
/* Both the input and the output coordinate systems were not */
/* recognized. */
setmsg_("Input coordinate system # and output coordinate system "
"# are not recognized.", (ftnlen)76);
errch_("#", icosys, (ftnlen)1, icosys_len);
errch_("#", ocosys, (ftnlen)1, ocosys_len);
sigerr_("SPICE(COORDSYSNOTREC)", (ftnlen)21);
chkout_("XFMSTA", (ftnlen)6);
return 0;
} else if (isys == 0) {
/* The input coordinate system was not recognized. */
setmsg_("Input coordinate system # was not recognized", (ftnlen)
44);
errch_("#", icosys, (ftnlen)1, icosys_len);
sigerr_("SPICE(COORDSYSNOTREC)", (ftnlen)21);
chkout_("XFMSTA", (ftnlen)6);
return 0;
} else {
/* The output coordinate system was not recognized. */
setmsg_("Output coordinate system # was not recognized", (ftnlen)
45);
errch_("#", ocosys, (ftnlen)1, ocosys_len);
sigerr_("SPICE(COORDSYSNOTREC)", (ftnlen)21);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
}
/* If the input and output coordinate systems are equal, set the */
/* output equal to the input since no conversion needs to take */
/* place. */
if (isys == osys) {
vequg_(istate, &c__6, ostate);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* If converting to or from either geodetic or planetographic, the */
/* NAIF ID must be found from the input body name BODY. If the */
/* body name does not have a valid NAIF ID code, an error is */
/* signaled. If the NAIF ID is valid, the radii of the body are */
/* located and the flattening coefficient is calculated. */
if (osys == 5 || osys == 6 || isys == 5 || isys == 6) {
/* Find the NAIF ID code */
zzbods2c_(svctr1, svbody, &svbdid, &svfnd1, body, &bodyid, &found, (
ftnlen)36, body_len);
/* If the body's name was found, find the body's radii and */
/* compute flattening coefficient. Otherwise, signal an error. */
if (found) {
bodvcd_(&bodyid, "RADII", &c__3, &dim, radii, (ftnlen)5);
if (failed_()) {
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* If either radius is less than or equal to zero, an error is */
/* signaled. */
if (radii[2] <= 0. || radii[0] <= 0.) {
setmsg_("At least one radii is less than or equal to zero. T"
"he equatorial radius has a value of # and the polar "
"radius has has a value of #.", (ftnlen)131);
errdp_("#", radii, (ftnlen)1);
errdp_("#", &radii[2], (ftnlen)1);
sigerr_("SPICE(INVALIDRADIUS)", (ftnlen)20);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* If the difference of the equatorial and polar radii */
/* divided by the equatorial radius is greater than DPMAX, */
/* a numeric overflow may occur, so an error is signaled. */
if (sqrt((d__1 = radii[0] - radii[2], abs(d__1))) / sqrt((abs(
radii[0]))) >= sqrt(dpmax_())) {
setmsg_("The equatorial radius for # has a value of # and a "
"polar radius of #. The flattening coefficient cannot"
" be calculated due to numeric overflow.", (ftnlen)142)
;
errch_("#", body, (ftnlen)1, body_len);
errdp_("#", radii, (ftnlen)1);
errdp_("#", &radii[2], (ftnlen)1);
sigerr_("SPICE(INVALIDRADIUS)", (ftnlen)20);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
f = (radii[0] - radii[2]) / radii[0];
} else {
setmsg_("The input body name # does not have a valid NAIF ID cod"
"e.", (ftnlen)57);
errch_("#", body, (ftnlen)1, body_len);
sigerr_("SPICE(IDCODENOTFOUND)", (ftnlen)21);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
}
/* Conversion of the input to rectangular coordinates */
/* ---------------------------------------------------------------- */
/* First, the position and velocity coordinates will be converted */
/* into rectangular coordinates. If the input system is not */
/* rectangular, then the velocity coordinates must be translated */
/* into rectangular using the Jacobian. If the input system is */
/* rectangular, then the input state must simply be saved into IPOS */
/* and IVEL. */
/* TOOBIG is used for preventing numerical overflow. The square */
/* roots of values are used to safely check if overflow will occur. */
toobig = sqrt(dpmax_() / 100.);
if (isys != 1) {
/* To rectangular... */
if (isys == 2) {
/* ... from cylindrical */
cylrec_(istate, &istate[1], &istate[2], ipos);
drdcyl_(istate, &istate[1], &istate[2], jacobi);
} else if (isys == 3) {
/* ... from latitudinal */
latrec_(istate, &istate[1], &istate[2], ipos);
drdlat_(istate, &istate[1], &istate[2], jacobi);
} else if (isys == 4) {
/* ... from spherical */
sphrec_(istate, &istate[1], &istate[2], ipos);
drdsph_(istate, &istate[1], &istate[2], jacobi);
} else if (isys == 5) {
/* ... from geodetic */
georec_(istate, &istate[1], &istate[2], radii, &f, ipos);
if (failed_()) {
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
drdgeo_(istate, &istate[1], &istate[2], radii, &f, jacobi);
} else if (isys == 6) {
/* ... from planetographic */
pgrrec_(body, istate, &istate[1], &istate[2], radii, &f, ipos,
body_len);
if (failed_()) {
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
drdpgr_(body, istate, &istate[1], &istate[2], radii, &f, jacobi,
body_len);
} else {
setmsg_("This error should never occur. This is an intermediate "
"step in which a non-rectangular input state should be tr"
"ansferred to rectangular. The input coordinate system i"
"s not recognized, yet was not caught by an earlier check."
, (ftnlen)224);
sigerr_("SPICE(BUG1)", (ftnlen)11);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* Some DRD* routines are not error free. Be safe and check */
/* FAILED to not use un-initialized JACOBI. */
if (failed_()) {
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* If the multiplication of the Jacobian and velocity can cause */
/* overflow, signal an error. */
for (i__ = 1; i__ <= 3; ++i__) {
for (j = 1; j <= 3; ++j) {
sqtmp = sqrt((d__1 = jacobi[(i__1 = i__ + j * 3 - 4) < 9 && 0
<= i__1 ? i__1 : s_rnge("jacobi", i__1, "xfmsta_", (
ftnlen)1054)], abs(d__1))) * sqrt((d__2 = istate[(
i__2 = j + 2) < 6 && 0 <= i__2 ? i__2 : s_rnge("ista"
"te", i__2, "xfmsta_", (ftnlen)1054)], abs(d__2)));
if (sqtmp > toobig) {
setmsg_("The product of the Jacobian and velocity may ca"
"use numeric overflow.", (ftnlen)68);
sigerr_("SPICE(NUMERICOVERFLOW)", (ftnlen)22);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
}
}
/* Transform the velocity into rectangular coordinates. */
mxv_(jacobi, &istate[3], ivel);
} else if (isys == 1) {
/* If the input coordinate system is rectangular, the input */
/* position does not need to be translated into rectangular. */
vequ_(istate, ipos);
vequ_(&istate[3], ivel);
} else {
setmsg_("This error should never occur. This is an ELSE statement. I"
"f the input coordinate system is not rectangular, the IF sho"
"uld be executed. If the input coordinate system is rectangul"
"ar, the ELSE IF should be executed.", (ftnlen)214);
sigerr_("SPICE(BUG2)", (ftnlen)11);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* Conversion from rectangular into the output coordinates */
/* ---------------------------------------------------------------- */
/* Convert to the output coordinate system. If the output */
/* coordinate system is not rectangular, four calculations must */
/* be made: */
/* 1) Verify the position and velocity are not along the z-axis. */
/* If the position and velocity are along the z-axis, the */
/* velocity can still be converted even though the */
/* Jacobian is not defined. If the position is along the */
/* z-axis but the velocity is not, the velocity cannot be */
/* converted to the output coordinate system. */
/* 2) Calculate the Jacobian from rectangular to the output */
/* coordinate system and verify the product of the Jacobian */
/* and velocity will not cause numeric overflow. */
/* 3) Transform the position to the output coordinate system. */
/* 4) Transform the velocity to the output coordinates using */
/* the Jacobian and the rectangular velocity IVEL. */
if (osys != 1) {
/* From rectangular for the case when the input position is along */
/* the z-axis ... */
if (abs(ipos[0]) + abs(ipos[1]) == 0.) {
if (abs(ivel[0]) + abs(ivel[1]) == 0.) {
/* If the velocity is along the z-axis, then the velocity */
/* can be computed in the output coordinate frame even */
/* though the Jacobian is not defined. */
if (osys == 2) {
/* ... to cylindrical */
vpack_(&c_b56, &c_b56, &ivel[2], &ostate[3]);
reccyl_(ipos, ostate, &ostate[1], &ostate[2]);
} else if (osys == 3) {
/* ... to latitudinal */
vpack_(&ivel[2], &c_b56, &c_b56, &ostate[3]);
reclat_(ipos, ostate, &ostate[1], &ostate[2]);
} else if (osys == 4) {
/* ... to spherical */
vpack_(&ivel[2], &c_b56, &c_b56, &ostate[3]);
recsph_(ipos, ostate, &ostate[1], &ostate[2]);
} else if (osys == 5) {
/* ... to geodetic */
vpack_(&c_b56, &c_b56, &ivel[2], &ostate[3]);
recgeo_(ipos, radii, &f, ostate, &ostate[1], &ostate[2]);
} else if (osys == 6) {
/* ... to planetographic */
vpack_(&c_b56, &c_b56, &ivel[2], &ostate[3]);
recpgr_(body, ipos, radii, &f, ostate, &ostate[1], &
ostate[2], body_len);
} else {
setmsg_("This error should never occur. This is an inter"
"mediate step in which a position and velocity al"
"ong the z-axis are converted to a non-rectangula"
"r coordinate system from rectangular. The output"
" coordinate system is not recognized, yet was no"
"t caught by an earlier check.", (ftnlen)268);
sigerr_("SPICE(BUG3)", (ftnlen)11);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* The output state has been calculated for the special */
/* case of the position and velocity existing along the */
/* z-axis. */
chkout_("XFMSTA", (ftnlen)6);
return 0;
} else {
/* The Jacobian is undefined and the velocity cannot be */
/* converted since it is not along the z-axis. */
/* Signal an error. */
setmsg_("Invalid input state: z axis.", (ftnlen)28);
sigerr_("SPICE(INVALIDSTATE)", (ftnlen)19);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
}
/* From rectangular for cases when the input position is not along */
/* the z-axis ... */
if (osys == 2) {
/* ... to cylindrical */
dcyldr_(ipos, &ipos[1], &ipos[2], jacobi);
reccyl_(ipos, ostate, &ostate[1], &ostate[2]);
} else if (osys == 3) {
/* ... to latitudinal */
dlatdr_(ipos, &ipos[1], &ipos[2], jacobi);
reclat_(ipos, ostate, &ostate[1], &ostate[2]);
} else if (osys == 4) {
/* ... to spherical */
dsphdr_(ipos, &ipos[1], &ipos[2], jacobi);
recsph_(ipos, ostate, &ostate[1], &ostate[2]);
} else if (osys == 5) {
/* ... to geodetic */
dgeodr_(ipos, &ipos[1], &ipos[2], radii, &f, jacobi);
recgeo_(ipos, radii, &f, ostate, &ostate[1], &ostate[2]);
} else if (osys == 6) {
/* ... to planetographic */
dpgrdr_(body, ipos, &ipos[1], &ipos[2], radii, &f, jacobi,
body_len);
recpgr_(body, ipos, radii, &f, ostate, &ostate[1], &ostate[2],
body_len);
} else {
setmsg_("This error should never occur. This is an intermediate "
"step in which a state is converted to a non-rectangular "
"coordinate system from rectangular. The output coordinat"
"e system is not recognized, yet was not caught by an ear"
"lier check.", (ftnlen)234);
sigerr_("SPICE(BUG4)", (ftnlen)11);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* Many D*DR and REC* routines are not error free. Be safe and */
/* check FAILED to not use un-initialized JACOBI. */
if (failed_()) {
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* If the multiplication of the Jacobian and velocity can cause */
/* overflow, signal an error. */
for (i__ = 1; i__ <= 3; ++i__) {
for (j = 1; j <= 3; ++j) {
sqtmp = sqrt((d__1 = jacobi[(i__1 = i__ + j * 3 - 4) < 9 && 0
<= i__1 ? i__1 : s_rnge("jacobi", i__1, "xfmsta_", (
ftnlen)1314)], abs(d__1))) * sqrt((d__2 = ivel[(i__2 =
j - 1) < 3 && 0 <= i__2 ? i__2 : s_rnge("ivel", i__2,
"xfmsta_", (ftnlen)1314)], abs(d__2)));
if (sqtmp > toobig) {
setmsg_("The product of the Jacobian and velocity may ca"
"use numeric overflow.", (ftnlen)68);
sigerr_("SPICE(NUMERICOVERFLOW)", (ftnlen)22);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
}
}
/* Calculate the velocity in the output coordinate system. */
mxv_(jacobi, ivel, &ostate[3]);
} else if (osys == 1) {
/* If the output coordinate system is rectangular, the position */
/* and velocity components of the output state are set equal to */
/* the rectangular IPOS and IVEL, respectively, because the */
/* components have already been converted to rectangular. */
vequ_(ipos, ostate);
vequ_(ivel, &ostate[3]);
} else {
setmsg_("This error should never occur. This is an ELSE statement. I"
"f the output coordinate system is not rectangular, the IF sh"
"ould be executed. If the output coordinate system is rectang"
"ular, the ELSE IF should be executed.", (ftnlen)216);
sigerr_("SPICE(BUG5)", (ftnlen)11);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
chkout_("XFMSTA", (ftnlen)6);
return 0;
} /* xfmsta_ */
/* $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 SPKGPS ( S/P Kernel, geometric position ) */
/* Subroutine */ int spkgps_(integer *targ, doublereal *et, char *ref,
integer *obs, doublereal *pos, doublereal *lt, ftnlen ref_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), s_rnge(char *, integer,
char *, integer);
/* Local variables */
extern /* Subroutine */ int vadd_(doublereal *, doublereal *, doublereal *
);
integer cobs, legs;
doublereal sobs[6];
extern /* Subroutine */ int vsub_(doublereal *, doublereal *, doublereal *
), vequ_(doublereal *, doublereal *), zznamfrm_(integer *, char *,
integer *, char *, integer *, ftnlen, ftnlen), zzctruin_(integer
*);
integer i__;
extern /* Subroutine */ int etcal_(doublereal *, char *, ftnlen);
integer refid;
extern /* Subroutine */ int chkin_(char *, ftnlen);
char oname[40];
doublereal descr[5];
integer ctarg[20];
char ident[40], tname[40];
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen),
moved_(doublereal *, integer *, doublereal *);
logical found;
extern /* Subroutine */ int repmi_(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
doublereal starg[120] /* was [6][20] */;
logical nofrm;
static char svref[32];
doublereal stemp[6];
integer ctpos;
doublereal vtemp[6];
extern doublereal vnorm_(doublereal *);
extern /* Subroutine */ int bodc2n_(integer *, char *, logical *, ftnlen);
static integer svctr1[2];
extern logical failed_(void);
extern /* Subroutine */ int cleard_(integer *, doublereal *);
integer handle, cframe;
extern /* Subroutine */ int refchg_(integer *, integer *, doublereal *,
doublereal *);
extern doublereal clight_(void);
integer tframe[20];
extern integer isrchi_(integer *, integer *, integer *);
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen);
static integer svrefi;
extern /* Subroutine */ int irfnum_(char *, integer *, ftnlen), prefix_(
char *, integer *, char *, ftnlen, ftnlen), setmsg_(char *,
ftnlen), suffix_(char *, integer *, char *, ftnlen, ftnlen);
integer tmpfrm;
extern /* Subroutine */ int irfrot_(integer *, integer *, doublereal *),
spksfs_(integer *, doublereal *, integer *, doublereal *, char *,
logical *, ftnlen);
extern integer frstnp_(char *, ftnlen);
extern logical return_(void);
doublereal psxfrm[9] /* was [3][3] */;
extern /* Subroutine */ int spkpvn_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *), intstr_(integer *, char *,
ftnlen);
integer nct;
doublereal rot[9] /* was [3][3] */;
extern /* Subroutine */ int mxv_(doublereal *, doublereal *, doublereal *)
;
char tstring[80];
/* $ Abstract */
/* Compute the geometric position of a target body relative to an */
/* observing 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 */
/* SPK */
/* $ Keywords */
/* EPHEMERIS */
/* $ Declarations */
/* $ 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 include file defines the dimension of the counter */
/* array used by various SPICE subsystems to uniquely identify */
/* changes in their states. */
/* $ 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 */
/* CTRSIZ is the dimension of the counter array used by */
/* various SPICE subsystems to uniquely identify */
/* changes in their states. */
/* $ Author_and_Institution */
/* B.V. Semenov (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 29-JUL-2013 (BVS) */
/* -& */
/* End of include file. */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* TARG I Target body. */
/* ET I Target epoch. */
/* REF I Target reference frame. */
/* OBS I Observing body. */
/* POS O Position of target. */
/* LT O Light time. */
/* $ Detailed_Input */
/* TARG is the standard NAIF ID code for a target body. */
/* ET is the epoch (ephemeris time) at which the position */
/* of the target body is to be computed. */
/* REF is the name of the reference frame to */
/* which the vectors returned by the routine should */
/* be rotated. This may be any frame supported by */
/* the SPICELIB subroutine REFCHG. */
/* OBS is the standard NAIF ID code for an observing body. */
/* $ Detailed_Output */
/* POS contains the position of the target */
/* body, relative to the observing body. This vector is */
/* rotated into the specified reference frame. Units */
/* are always km. */
/* LT is the one-way light time from the observing body */
/* to the geometric position of the target body at the */
/* specified epoch. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If insufficient ephemeris data has been loaded to compute */
/* the necessary positions, the error SPICE(SPKINSUFFDATA) is */
/* signalled. */
/* $ Files */
/* See: $Restrictions. */
/* $ Particulars */
/* SPKGPS computes the geometric position, T(t), of the target */
/* body and the geometric position, O(t), of the observing body */
/* relative to the first common center of motion. Subtracting */
/* O(t) from T(t) gives the geometric position of the target */
/* body relative to the observer. */
/* CENTER ----- O(t) */
/* | / */
/* | / */
/* | / */
/* | / T(t) - O(t) */
/* | / */
/* T(t) */
/* The one-way light time, tau, is given by */
/* | T(t) - O(t) | */
/* tau = ----------------- */
/* c */
/* For example, if the observing body is -94, the Mars Observer */
/* spacecraft, and the target body is 401, Phobos, then the */
/* first common center is probably 4, the Mars Barycenter. */
/* O(t) is the position of -94 relative to 4 and T(t) is the */
/* position of 401 relative to 4. */
/* The center could also be the Solar System Barycenter, body 0. */
/* For example, if the observer is 399, Earth, and the target */
/* is 299, Venus, then O(t) would be the position of 399 relative */
/* to 0 and T(t) would be the position of 299 relative to 0. */
/* Ephemeris data from more than one segment may be required */
/* to determine the positions of the target body and observer */
/* relative to a common center. SPKGPS reads as many segments */
/* as necessary, from as many files as necessary, using files */
/* that have been loaded by previous calls to SPKLEF (load */
/* ephemeris file). */
/* SPKGPS is similar to SPKGEO but returns geometric positions */
/* only. */
/* $ Examples */
/* The following code example computes the geometric */
/* position of the moon with respect to the earth and */
/* then prints the distance of the moon from the */
/* the earth at a number of epochs. */
/* Assume the SPK file SAMPLE.BSP contains ephemeris data */
/* for the moon relative to earth over the time interval */
/* from BEGIN to END. */
/* INTEGER EARTH */
/* PARAMETER ( EARTH = 399 ) */
/* INTEGER MOON */
/* PARAMETER ( MOON = 301 ) */
/* INTEGER N */
/* PARAMETER ( N = 100 ) */
/* INTEGER I */
/* CHARACTER*(20) UTC */
/* DOUBLE PRECISION BEGIN */
/* DOUBLE PRECISION DELTA */
/* DOUBLE PRECISION END */
/* DOUBLE PRECISION ET */
/* DOUBLE PRECISION POS ( 3 ) */
/* DOUBLE PRECISION LT */
/* DOUBLE PRECISION VNORM */
/* C */
/* C Load the binary SPK ephemeris file. */
/* C */
/* CALL FURNSH ( 'SAMPLE.BSP' ) */
/* . */
/* . */
/* . */
/* C */
/* C Divide the interval of coverage [BEGIN,END] into */
/* C N steps. At each step, compute the position, and */
/* C print out the epoch in UTC time and position norm. */
/* C */
/* DELTA = ( END - BEGIN ) / N */
/* DO I = 0, N */
/* ET = BEGIN + I*DELTA */
/* CALL SPKGPS ( MOON, ET, 'J2000', EARTH, POS, LT ) */
/* CALL ET2UTC ( ET, 'C', 0, UTC ) */
/* WRITE (*,*) UTC, VNORM ( POS ) */
/* END DO */
/* $ Restrictions */
/* 1) The ephemeris files to be used by SPKGPS must be loaded */
/* by SPKLEF before SPKGPS is called. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* B.V. Semenov (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 2.0.0, 08-JAN-2014 (BVS) */
/* Updated to save the input frame name and POOL state counter */
/* and to do frame name-ID conversion only if the counter has */
/* changed. */
/* Updated to map the input frame name to its ID by first calling */
/* ZZNAMFRM, and then calling IRFNUM. The side effect of this */
/* change is that now the frame with the fixed name 'DEFAULT' */
/* that can be associated with any code via CHGIRF's entry point */
/* IRFDEF will be fully masked by a frame with indentical name */
/* defined via a text kernel. Previously the CHGIRF's 'DEFAULT' */
/* frame masked the text kernel frame with the same name. */
/* Replaced SPKLEF with FURNSH and fixed errors in Examples. */
/* - SPICELIB Version 1.2.0, 05-NOV-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in VADD calls. */
/* - SPICELIB Version 1.1.0, 05-JAN-2005 (NJB) */
/* Tests of routine FAILED() were added. */
/* - SPICELIB Version 1.0.0, 9-JUL-1998 (WLT) */
/* -& */
/* $ Index_Entries */
/* geometric position of one body relative to another */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.2.0, 05-NOV-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in VADD calls. */
/* -& */
/* This is the idea: */
/* Every body moves with respect to some center. The center */
/* is itself a body, which in turn moves about some other */
/* center. If we begin at the target body (T), follow */
/* the chain, */
/* T */
/* \ */
/* SSB \ */
/* \ C[1] */
/* \ / */
/* \ / */
/* \ / */
/* \ / */
/* C[3]-----------C[2] */
/* and avoid circular definitions (A moves about B, and B moves */
/* about A), eventually we get the position relative to the solar */
/* system barycenter (which, for our purposes, doesn't move). */
/* Thus, */
/* T = T + C[1] + C[2] + ... + C[n] */
/* SSB C[1] C[2] [C3] SSB */
/* where */
/* X */
/* Y */
/* is the position of body X relative to body Y. */
/* However, we don't want to follow each chain back to the SSB */
/* if it isn't necessary. Instead we will just follow the chain */
/* of the target body and follow the chain of the observing body */
/* until we find a common node in the tree. */
/* In the example below, C is the first common node. We compute */
/* the position of TARG relative to C and the position of OBS */
/* relative to C, then subtract the two positions. */
/* TARG */
/* \ */
/* SSB \ */
/* \ A */
/* \ / OBS */
/* \ / | */
/* \ / | */
/* \ / | */
/* B-------------C-----------------D */
/* SPICELIB functions */
/* Local parameters */
/* CHLEN is the maximum length of a chain. That is, */
/* it is the maximum number of bodies in the chain from */
/* the target or observer to the SSB. */
/* Saved frame name length. */
/* Local variables */
/* Saved frame name/ID item declarations. */
/* Saved frame name/ID items. */
/* Initial values. */
/* In-line Function Definitions */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SPKGPS", (ftnlen)6);
}
/* Initialization. */
if (first) {
/* Initialize counter. */
zzctruin_(svctr1);
first = FALSE_;
}
/* We take care of the obvious case first. It TARG and OBS are the */
/* same we can just fill in zero. */
if (*targ == *obs) {
*lt = 0.;
cleard_(&c__3, pos);
chkout_("SPKGPS", (ftnlen)6);
return 0;
}
/* CTARG contains the integer codes of the bodies in the */
/* target body chain, beginning with TARG itself and then */
/* the successive centers of motion. */
/* STARG(1,I) is the position of the target body relative */
/* to CTARG(I). The id-code of the frame of this position is */
/* stored in TFRAME(I). */
/* COBS and SOBS will contain the centers and positions of the */
/* observing body. (They are single elements instead of arrays */
/* because we only need the current center and position of the */
/* observer relative to it.) */
/* First, we construct CTARG and STARG. CTARG(1) is */
/* just the target itself, and STARG(1,1) is just a zero */
/* vector, that is, the position of the target relative */
/* to itself. */
/* Then we follow the chain, filling up CTARG and STARG */
/* as we go. We use SPKSFS to search through loaded */
/* files to find the first segment applicable to CTARG(1) */
/* and time ET. Then we use SPKPVN to compute the position */
/* of the body CTARG(1) at ET in the segment that was found */
/* and get its center and frame of motion (CTARG(2) and TFRAME(2). */
/* We repeat the process for CTARG(2) and so on, until */
/* there is no data found for some CTARG(I) or until we */
/* reach the SSB. */
/* Next, we find centers and positions in a similar manner */
/* for the observer. It's a similar construction as */
/* described above, but I is always 1. COBS and SOBS */
/* are overwritten with each new center and position, */
/* beginning at OBS. However, we stop when we encounter */
/* a common center of motion, that is when COBS is equal */
/* to CTARG(I) for some I. */
/* Finally, we compute the desired position of the target */
/* relative to the observer by subtracting the position of */
/* the observing body relative to the common node from */
/* the position of the target body relative to the common */
/* node. */
/* CTPOS is the position in CTARG of the common node. */
/* Since the upgrade to use hashes and counter bypass ZZNAMFRM */
/* became more efficient in looking up frame IDs than IRFNUM. So the */
/* original order of calls "IRFNUM first, NAMFRM second" was */
/* switched to "ZZNAMFRM first, IRFNUM second". */
/* The call to IRFNUM, now redundant for built-in inertial frames, */
/* was preserved to for a sole reason -- to still support the */
/* ancient and barely documented ability for the users to associate */
/* a frame with the fixed name 'DEFAULT' with any CHGIRF inertial */
/* frame code via CHGIRF's entry point IRFDEF. */
/* Note that in the case of ZZNAMFRM's failure to resolve name and */
/* IRFNUM's success to do so, the code returned by IRFNUM for */
/* 'DEFAULT' frame is *not* copied to the saved code SVREFI (which */
/* would be set to 0 by ZZNAMFRM) to make sure that on subsequent */
/* calls ZZNAMFRM does not do a bypass (as SVREFI always forced look */
/* up) and calls IRFNUM again to reset the 'DEFAULT's frame ID */
/* should it change between the calls. */
zznamfrm_(svctr1, svref, &svrefi, ref, &refid, (ftnlen)32, ref_len);
if (refid == 0) {
irfnum_(ref, &refid, ref_len);
}
if (refid == 0) {
if (frstnp_(ref, ref_len) > 0) {
setmsg_("The string supplied to specify the reference frame, ('#"
"') contains non-printing characters. The two most commo"
"n causes for this kind of error are: 1. an error in the "
"call to SPKGPS; 2. an uninitialized variable. ", (ftnlen)
213);
errch_("#", ref, (ftnlen)1, ref_len);
} else if (s_cmp(ref, " ", ref_len, (ftnlen)1) == 0) {
setmsg_("The string supplied to specify the reference frame is b"
"lank. The most common cause for this kind of error is a"
"n uninitialized variable. ", (ftnlen)137);
} else {
setmsg_("The string supplied to specify the reference frame was "
"'#'. This frame is not recognized. Possible causes for "
"this error are: 1. failure to load the frame definition "
"into the kernel pool; 2. An out-of-date edition of the t"
"oolkit. ", (ftnlen)231);
errch_("#", ref, (ftnlen)1, ref_len);
}
sigerr_("SPICE(UNKNOWNFRAME)", (ftnlen)19);
if (failed_()) {
chkout_("SPKGPS", (ftnlen)6);
return 0;
}
}
/* Fill in CTARG and STARG until no more data is found */
/* or until we reach the SSB. If the chain gets too */
/* long to fit in CTARG, that is if I equals CHLEN, */
/* then overwrite the last elements of CTARG and STARG. */
/* Note the check for FAILED in the loop. If SPKSFS */
/* or SPKPVN happens to fail during execution, and the */
/* current error handling action is to NOT abort, then */
/* FOUND may be stuck at TRUE, CTARG(I) will never */
/* become zero, and the loop will execute indefinitely. */
/* Construct CTARG and STARG. Begin by assigning the */
/* first elements: TARG and the position of TARG relative */
/* to itself. */
i__ = 1;
ctarg[(i__1 = i__ - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge("ctarg", i__1,
"spkgps_", (ftnlen)603)] = *targ;
found = TRUE_;
cleard_(&c__6, &starg[(i__1 = i__ * 6 - 6) < 120 && 0 <= i__1 ? i__1 :
s_rnge("starg", i__1, "spkgps_", (ftnlen)606)]);
while(found && i__ < 20 && ctarg[(i__1 = i__ - 1) < 20 && 0 <= i__1 ?
i__1 : s_rnge("ctarg", i__1, "spkgps_", (ftnlen)608)] != *obs &&
ctarg[(i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 : s_rnge("ctarg",
i__2, "spkgps_", (ftnlen)608)] != 0) {
/* Find a file and segment that has position */
/* data for CTARG(I). */
spksfs_(&ctarg[(i__1 = i__ - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge(
"ctarg", i__1, "spkgps_", (ftnlen)617)], et, &handle, descr,
ident, &found, (ftnlen)40);
if (found) {
/* Get the position of CTARG(I) relative to some */
/* center of motion. This new center goes in */
/* CTARG(I+1) and the position is called STEMP. */
++i__;
spkpvn_(&handle, descr, et, &tframe[(i__1 = i__ - 1) < 20 && 0 <=
i__1 ? i__1 : s_rnge("tframe", i__1, "spkgps_", (ftnlen)
627)], &starg[(i__2 = i__ * 6 - 6) < 120 && 0 <= i__2 ?
i__2 : s_rnge("starg", i__2, "spkgps_", (ftnlen)627)], &
ctarg[(i__3 = i__ - 1) < 20 && 0 <= i__3 ? i__3 : s_rnge(
"ctarg", i__3, "spkgps_", (ftnlen)627)]);
/* Here's what we have. STARG is the position of CTARG(I-1) */
/* relative to CTARG(I) in reference frame TFRAME(I) */
/* If one of the routines above failed during */
/* execution, we just give up and check out. */
if (failed_()) {
chkout_("SPKGPS", (ftnlen)6);
return 0;
}
}
}
tframe[0] = tframe[1];
/* If the loop above ended because we ran out of */
/* room in the arrays CTARG and STARG, then we */
/* continue finding positions but we overwrite the */
/* last elements of CTARG and STARG. */
/* If, as a result, the first common node is */
/* overwritten, we'll just have to settle for */
/* the last common node. This will cause a small */
/* loss of precision, but it's better than other */
/* alternatives. */
if (i__ == 20) {
while(found && ctarg[19] != 0 && ctarg[19] != *obs) {
/* Find a file and segment that has position */
/* data for CTARG(CHLEN). */
spksfs_(&ctarg[19], et, &handle, descr, ident, &found, (ftnlen)40)
;
if (found) {
/* Get the position of CTARG(CHLEN) relative to */
/* some center of motion. The new center */
/* overwrites the old. The position is called */
/* STEMP. */
spkpvn_(&handle, descr, et, &tmpfrm, stemp, &ctarg[19]);
/* Add STEMP to the position of TARG relative to */
/* the old center to get the position of TARG */
/* relative to the new center. Overwrite */
/* the last element of STARG. */
if (tframe[19] == tmpfrm) {
moved_(&starg[114], &c__3, vtemp);
} else if (tmpfrm > 0 && tmpfrm <= 21 && tframe[19] > 0 &&
tframe[19] <= 21) {
irfrot_(&tframe[19], &tmpfrm, rot);
mxv_(rot, &starg[114], vtemp);
} else {
refchg_(&tframe[19], &tmpfrm, et, psxfrm);
if (failed_()) {
chkout_("SPKGPS", (ftnlen)6);
return 0;
}
mxv_(psxfrm, &starg[114], vtemp);
}
vadd_(vtemp, stemp, &starg[114]);
tframe[19] = tmpfrm;
/* If one of the routines above failed during */
/* execution, we just give up and check out. */
if (failed_()) {
chkout_("SPKGPS", (ftnlen)6);
return 0;
}
}
}
}
nct = i__;
/* NCT is the number of elements in CTARG, */
/* the chain length. We have in hand the following information */
/* STARG(1...3,K) position of body */
/* CTARG(K-1) relative to body CTARG(K) in the frame */
/* TFRAME(K) */
/* For K = 2,..., NCT. */
/* CTARG(1) = TARG */
/* STARG(1...3,1) = ( 0, 0, 0 ) */
/* TFRAME(1) = TFRAME(2) */
/* Now follow the observer's chain. Assign */
/* the first values for COBS and SOBS. */
cobs = *obs;
cleard_(&c__6, sobs);
/* Perhaps we have a common node already. */
/* If so it will be the last node on the */
/* list CTARG. */
/* We let CTPOS will be the position of the common */
/* node in CTARG if one is found. It will */
/* be zero if COBS is not found in CTARG. */
if (ctarg[(i__1 = nct - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge("ctarg",
i__1, "spkgps_", (ftnlen)762)] == cobs) {
ctpos = nct;
cframe = tframe[(i__1 = ctpos - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge(
"tframe", i__1, "spkgps_", (ftnlen)764)];
} else {
ctpos = 0;
}
/* Repeat the same loop as above, but each time */
/* we encounter a new center of motion, check to */
/* see if it is a common node. (When CTPOS is */
/* not zero, CTARG(CTPOS) is the first common node.) */
/* Note that we don't need a centers array nor a */
/* positions array, just a single center and position */
/* is sufficient --- we just keep overwriting them. */
/* When the common node is found, we have everything */
/* we need in that one center (COBS) and position */
/* (SOBS-position of the target relative to COBS). */
found = TRUE_;
nofrm = TRUE_;
legs = 0;
while(found && cobs != 0 && ctpos == 0) {
/* Find a file and segment that has position */
/* data for COBS. */
spksfs_(&cobs, et, &handle, descr, ident, &found, (ftnlen)40);
if (found) {
/* Get the position of COBS; call it STEMP. */
/* The center of motion of COBS becomes the */
/* new COBS. */
if (legs == 0) {
spkpvn_(&handle, descr, et, &tmpfrm, sobs, &cobs);
} else {
spkpvn_(&handle, descr, et, &tmpfrm, stemp, &cobs);
}
if (nofrm) {
nofrm = FALSE_;
cframe = tmpfrm;
}
/* Add STEMP to the position of OBS relative to */
/* the old COBS to get the position of OBS */
/* relative to the new COBS. */
if (cframe == tmpfrm) {
/* On the first leg of the position of the observer, we */
/* don't have to add anything, the position of the */
/* observer is already in SOBS. We only have to add when */
/* the number of legs in the observer position is one or */
/* greater. */
if (legs > 0) {
vadd_(sobs, stemp, vtemp);
vequ_(vtemp, sobs);
}
} else if (tmpfrm > 0 && tmpfrm <= 21 && cframe > 0 && cframe <=
21) {
irfrot_(&cframe, &tmpfrm, rot);
mxv_(rot, sobs, vtemp);
vadd_(vtemp, stemp, sobs);
cframe = tmpfrm;
} else {
refchg_(&cframe, &tmpfrm, et, psxfrm);
if (failed_()) {
chkout_("SPKGPS", (ftnlen)6);
return 0;
}
mxv_(psxfrm, sobs, vtemp);
vadd_(vtemp, stemp, sobs);
cframe = tmpfrm;
}
/* Check failed. We don't want to loop */
/* indefinitely. */
if (failed_()) {
chkout_("SPKGPS", (ftnlen)6);
return 0;
}
/* We now have one more leg of the path for OBS. Set */
/* LEGS to reflect this. Then see if the new center */
/* is a common node. If not, repeat the loop. */
++legs;
ctpos = isrchi_(&cobs, &nct, ctarg);
}
}
/* If CTPOS is zero at this point, it means we */
/* have not found a common node though we have */
/* searched through all the available data. */
if (ctpos == 0) {
bodc2n_(targ, tname, &found, (ftnlen)40);
if (found) {
prefix_("# (", &c__0, tname, (ftnlen)3, (ftnlen)40);
suffix_(")", &c__0, tname, (ftnlen)1, (ftnlen)40);
repmi_(tname, "#", targ, tname, (ftnlen)40, (ftnlen)1, (ftnlen)40)
;
} else {
intstr_(targ, tname, (ftnlen)40);
}
bodc2n_(obs, oname, &found, (ftnlen)40);
if (found) {
prefix_("# (", &c__0, oname, (ftnlen)3, (ftnlen)40);
suffix_(")", &c__0, oname, (ftnlen)1, (ftnlen)40);
repmi_(oname, "#", obs, oname, (ftnlen)40, (ftnlen)1, (ftnlen)40);
} else {
intstr_(obs, oname, (ftnlen)40);
}
setmsg_("Insufficient ephemeris data has been loaded to compute the "
"position of TARG relative to OBS at the ephemeris epoch #. ",
(ftnlen)118);
etcal_(et, tstring, (ftnlen)80);
errch_("TARG", tname, (ftnlen)4, (ftnlen)40);
errch_("OBS", oname, (ftnlen)3, (ftnlen)40);
errch_("#", tstring, (ftnlen)1, (ftnlen)80);
sigerr_("SPICE(SPKINSUFFDATA)", (ftnlen)20);
chkout_("SPKGPS", (ftnlen)6);
return 0;
}
/* If CTPOS is not zero, then we have reached a */
/* common node, specifically, */
/* CTARG(CTPOS) = COBS = CENTER */
/* (in diagram below). The POSITION of the target */
/* (TARG) relative to the observer (OBS) is just */
/* STARG(1,CTPOS) - SOBS. */
/* SOBS */
/* CENTER ---------------->OBS */
/* | . */
/* | . N */
/* S | . O */
/* T | . I */
/* A | . T */
/* R | . I */
/* G | . S */
/* | . O */
/* | . P */
/* V L */
/* TARG */
/* And the light-time between them is just */
/* | POSITION | */
/* LT = --------- */
/* c */
/* Compute the position of the target relative to CTARG(CTPOS) */
if (ctpos == 1) {
tframe[0] = cframe;
}
i__1 = ctpos - 1;
for (i__ = 2; i__ <= i__1; ++i__) {
if (tframe[(i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 : s_rnge("tframe"
, i__2, "spkgps_", (ftnlen)960)] == tframe[(i__3 = i__) < 20
&& 0 <= i__3 ? i__3 : s_rnge("tframe", i__3, "spkgps_", (
ftnlen)960)]) {
vadd_(&starg[(i__2 = i__ * 6 - 6) < 120 && 0 <= i__2 ? i__2 :
s_rnge("starg", i__2, "spkgps_", (ftnlen)962)], &starg[(
i__3 = (i__ + 1) * 6 - 6) < 120 && 0 <= i__3 ? i__3 :
s_rnge("starg", i__3, "spkgps_", (ftnlen)962)], stemp);
moved_(stemp, &c__3, &starg[(i__2 = (i__ + 1) * 6 - 6) < 120 && 0
<= i__2 ? i__2 : s_rnge("starg", i__2, "spkgps_", (ftnlen)
963)]);
} else if (tframe[(i__3 = i__) < 20 && 0 <= i__3 ? i__3 : s_rnge(
"tframe", i__3, "spkgps_", (ftnlen)965)] > 0 && tframe[(i__3 =
i__) < 20 && 0 <= i__3 ? i__3 : s_rnge("tframe", i__3, "spk"
"gps_", (ftnlen)965)] <= 21 && tframe[(i__2 = i__ - 1) < 20 &&
0 <= i__2 ? i__2 : s_rnge("tframe", i__2, "spkgps_", (ftnlen)
965)] > 0 && tframe[(i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2
: s_rnge("tframe", i__2, "spkgps_", (ftnlen)965)] <= 21) {
irfrot_(&tframe[(i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("tframe", i__2, "spkgps_", (ftnlen)967)], &tframe[(
i__3 = i__) < 20 && 0 <= i__3 ? i__3 : s_rnge("tframe",
i__3, "spkgps_", (ftnlen)967)], rot);
mxv_(rot, &starg[(i__2 = i__ * 6 - 6) < 120 && 0 <= i__2 ? i__2 :
s_rnge("starg", i__2, "spkgps_", (ftnlen)968)], stemp);
vadd_(stemp, &starg[(i__2 = (i__ + 1) * 6 - 6) < 120 && 0 <= i__2
? i__2 : s_rnge("starg", i__2, "spkgps_", (ftnlen)969)],
vtemp);
moved_(vtemp, &c__3, &starg[(i__2 = (i__ + 1) * 6 - 6) < 120 && 0
<= i__2 ? i__2 : s_rnge("starg", i__2, "spkgps_", (ftnlen)
970)]);
} else {
refchg_(&tframe[(i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("tframe", i__2, "spkgps_", (ftnlen)974)], &tframe[(
i__3 = i__) < 20 && 0 <= i__3 ? i__3 : s_rnge("tframe",
i__3, "spkgps_", (ftnlen)974)], et, psxfrm);
if (failed_()) {
chkout_("SPKGPS", (ftnlen)6);
return 0;
}
mxv_(psxfrm, &starg[(i__2 = i__ * 6 - 6) < 120 && 0 <= i__2 ?
i__2 : s_rnge("starg", i__2, "spkgps_", (ftnlen)981)],
stemp);
vadd_(stemp, &starg[(i__2 = (i__ + 1) * 6 - 6) < 120 && 0 <= i__2
? i__2 : s_rnge("starg", i__2, "spkgps_", (ftnlen)982)],
vtemp);
moved_(vtemp, &c__3, &starg[(i__2 = (i__ + 1) * 6 - 6) < 120 && 0
<= i__2 ? i__2 : s_rnge("starg", i__2, "spkgps_", (ftnlen)
983)]);
}
}
/* To avoid unnecessary frame transformations we'll do */
/* a bit of extra decision making here. It's a lot */
/* faster to make logical checks than it is to compute */
/* frame transformations. */
if (tframe[(i__1 = ctpos - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge("tframe",
i__1, "spkgps_", (ftnlen)996)] == cframe) {
vsub_(&starg[(i__1 = ctpos * 6 - 6) < 120 && 0 <= i__1 ? i__1 :
s_rnge("starg", i__1, "spkgps_", (ftnlen)998)], sobs, pos);
} else if (tframe[(i__1 = ctpos - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge(
"tframe", i__1, "spkgps_", (ftnlen)1000)] == refid) {
/* If the last frame associated with the target is already */
/* in the requested output frame, we convert the position of */
/* the observer to that frame and then subtract the position */
/* of the observer from the position of the target. */
if (refid > 0 && refid <= 21 && cframe > 0 && cframe <= 21) {
irfrot_(&cframe, &refid, rot);
mxv_(rot, sobs, stemp);
} else {
refchg_(&cframe, &refid, et, psxfrm);
if (failed_()) {
chkout_("SPKGPS", (ftnlen)6);
return 0;
}
mxv_(psxfrm, sobs, stemp);
}
/* We've now transformed SOBS into the requested reference frame. */
/* Set CFRAME to reflect this. */
cframe = refid;
vsub_(&starg[(i__1 = ctpos * 6 - 6) < 120 && 0 <= i__1 ? i__1 :
s_rnge("starg", i__1, "spkgps_", (ftnlen)1031)], stemp, pos);
} else if (cframe > 0 && cframe <= 21 && tframe[(i__1 = ctpos - 1) < 20 &&
0 <= i__1 ? i__1 : s_rnge("tframe", i__1, "spkgps_", (ftnlen)
1034)] > 0 && tframe[(i__1 = ctpos - 1) < 20 && 0 <= i__1 ? i__1 :
s_rnge("tframe", i__1, "spkgps_", (ftnlen)1034)] <= 21) {
/* If both frames are inertial we use IRFROT instead of */
/* REFCHG to get things into a common frame. */
irfrot_(&tframe[(i__1 = ctpos - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge(
"tframe", i__1, "spkgps_", (ftnlen)1040)], &cframe, rot);
mxv_(rot, &starg[(i__1 = ctpos * 6 - 6) < 120 && 0 <= i__1 ? i__1 :
s_rnge("starg", i__1, "spkgps_", (ftnlen)1041)], stemp);
vsub_(stemp, sobs, pos);
} else {
/* Use the more general routine REFCHG to make the transformation. */
refchg_(&tframe[(i__1 = ctpos - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge(
"tframe", i__1, "spkgps_", (ftnlen)1048)], &cframe, et,
psxfrm);
if (failed_()) {
chkout_("SPKGPS", (ftnlen)6);
return 0;
}
mxv_(psxfrm, &starg[(i__1 = ctpos * 6 - 6) < 120 && 0 <= i__1 ? i__1 :
s_rnge("starg", i__1, "spkgps_", (ftnlen)1055)], stemp);
vsub_(stemp, sobs, pos);
}
/* Finally, rotate as needed into the requested frame. */
if (cframe == refid) {
/* We don't have to do anything in this case. */
} else if (refid > 0 && refid <= 21 && cframe > 0 && cframe <= 21) {
/* Since both frames are inertial, we use the more direct */
/* routine IRFROT to get the transformation to REFID. */
irfrot_(&cframe, &refid, rot);
mxv_(rot, pos, stemp);
moved_(stemp, &c__3, pos);
} else {
refchg_(&cframe, &refid, et, psxfrm);
if (failed_()) {
chkout_("SPKGPS", (ftnlen)6);
return 0;
}
mxv_(psxfrm, pos, stemp);
moved_(stemp, &c__3, pos);
}
*lt = vnorm_(pos) / clight_();
chkout_("SPKGPS", (ftnlen)6);
return 0;
} /* spkgps_ */
