/* $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_ */
/* $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 SCDECD ( Decode spacecraft clock ) */
/* Subroutine */ int scdecd_(integer *sc, doublereal *sclkdp, char *sclkch,
ftnlen sclkch_len)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1;
/* Builtin functions */
double d_nint(doublereal *);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer), i_len(char *, ftnlen);
/* Local variables */
integer part, i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), errdp_(char *,
doublereal *, ftnlen);
doublereal ticks;
extern /* Subroutine */ int scfmt_(integer *, doublereal *, char *,
ftnlen);
doublereal pstop[9999];
extern logical failed_(void);
extern integer lastnb_(char *, ftnlen);
integer prelen;
extern integer lstled_(doublereal *, integer *, doublereal *);
extern /* Subroutine */ int sigerr_(char *, ftnlen);
integer suflen;
extern /* Subroutine */ int scpart_(integer *, integer *, doublereal *,
doublereal *), chkout_(char *, ftnlen), prefix_(char *, integer *,
char *, ftnlen, ftnlen), setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen), suffix_(char *, integer *, char *, ftnlen,
ftnlen);
integer nparts;
doublereal pstart[9999];
extern logical return_(void);
extern /* Subroutine */ int intstr_(integer *, char *, ftnlen);
doublereal ptotls[9999];
char prtstr[5];
/* $ Abstract */
/* Convert double precision encoding of spacecraft clock time into */
/* a character representation. */
/* $ 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 */
/* SCLK */
/* $ Keywords */
/* CONVERSION */
/* TIME */
/* $ Declarations */
/* $ Abstract */
/* Include file sclk.inc */
/* SPICE private file intended solely for the support of SPICE */
/* routines. Users should not include this file directly due */
/* to the volatile nature of this file */
/* The parameters below define sizes and limits used by */
/* the SCLK system. */
/* $ 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 */
/* See the declaration section below. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 2.0.0, 24-MAY-2010 (NJB) */
/* Increased value of maximum coefficient record count */
/* parameter MXCOEF from 10K to 50K. */
/* - SPICELIB Version 1.0.0, 11-FEB-2008 (NJB) */
/* -& */
/* Number of supported SCLK field delimiters: */
/* Supported SCLK string field delimiters: */
/* Maximum number of partitions: */
/* Partition string length. */
/* Since the maximum number of partitions is given by MXPART is */
/* 9999, PRTSTR needs at most 4 characters for the partition number */
/* and one character for the slash. */
/* Maximum number of coefficient records: */
/* Maximum number of fields in an SCLK string: */
/* Length of strings used to represent D.P. */
/* numbers: */
/* Maximum number of supported parallel time systems: */
/* End of include file sclk.inc */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* SC I NAIF spacecraft identification code. */
/* SCLKDP I Encoded representation of a spacecraft clock count. */
/* SCLKCH O Character representation of a clock count. */
/* MXPART P Maximum number of spacecraft clock partitions. */
/* $ Detailed_Input */
/* SC is the NAIF integer code of the spacecraft whose */
/* clock's time is being decoded. */
/* SCLKDP is the double precision encoding of a clock time in */
/* units of ticks since the spacecraft clock start time. */
/* This value does reflect partition information. */
/* An analogy may be drawn between a spacecraft clock */
/* and a standard wall clock. The number of ticks */
/* corresponding to the wall clock string */
/* hh:mm:ss */
/* would be the number of seconds represented by that */
/* time. */
/* For example: */
/* Clock string Number of ticks */
/* ------------ --------------- */
/* 00:00:10 10 */
/* 00:01:00 60 */
/* 00:10:00 600 */
/* 01:00:00 3600 */
/* If SCLKDP contains a fractional part the result */
/* is the same as if SCLKDP had been rounded to the */
/* nearest whole number. */
/* $ Detailed_Output */
/* SCLKCH is the character representation of the clock count. */
/* The exact form that SCLKCH takes depends on the */
/* spacecraft. */
/* Nevertheless, SCLKCH will have the following general */
/* format: */
/* 'pp/sclk_string' */
/* 'pp' is an integer greater than or equal to one and */
/* represents a "partition number". */
/* Each mission is divided into some number of partitions. */
/* A new partition starts when the spacecraft clock */
/* resets, either to zero, or to some other */
/* value. Thus, the first partition for any mission */
/* starts with launch, and ends with the first clock */
/* reset. The second partition starts immediately when */
/* the first stopped, and so on. */
/* In order to be completely unambiguous about a */
/* particular time, you need to specify a partition number */
/* along with the standard clock string. */
/* Information about when partitions occur for different */
/* missions is contained in a spacecraft clock kernel */
/* file which needs to be loaded into the kernel pool */
/* before calling SCDECD. */
/* The routine SCPART may be used to read the partition */
/* start and stop times, in encoded units of ticks, from */
/* the kernel file. */
/* Since the end time of one partition is coincident with */
/* the begin time of the next, two different time strings */
/* with different partition numbers can encode into the */
/* same value. */
/* For example, if partition 1 ends at time t1, and */
/* partition 2 starts at time t2, then */
/* '1/t1' and '2/t2' */
/* will be encoded into the same value, say X. SCDECD */
/* always decodes such values into the latter of the */
/* two partitions. In this example, */
/* CALL SCDECD ( X, SC, CLKSTR ) */
/* will result in */
/* CLKSTR = '2/t2'. */
/* 'sclk_string' is a spacecraft specific clock string, */
/* typically consisting of a number of components */
/* separated by delimiters. */
/* Using Galileo as an example, the full format is */
/* wwwwwwww:xx:y:z */
/* where z is a mod-8 counter (values 0-7) which */
/* increments approximately once every 8 1/3 ms., y is a */
/* mod-10 counter (values 0-9) which increments once */
/* every time z turns over, i.e., approximately once every */
/* 66 2/3 ms., xx is a mod-91 (values 0-90) counter */
/* which increments once every time y turns over, i.e., */
/* once every 2/3 seconds. wwwwwwww is the Real-Time Image */
/* Count (RIM), which increments once every time xx turns */
/* over, i.e., once every 60 2/3 seconds. The roll-over */
/* expression for the RIM is 16777215, which corresponds */
/* to approximately 32 years. */
/* wwwwwwww, xx, y, and z are referred to interchangeably */
/* as the fields or components of the spacecraft clock. */
/* SCLK components may be separated by any of these five */
/* characters: ' ' ':' ',' '-' '.' */
/* The delimiter used is determined by a kernel pool */
/* variable and can be adjusted by the user. */
/* Some spacecraft clock components have offset, or */
/* starting, values different from zero. For example, */
/* with an offset value of 1, a mod 20 counter would */
/* cycle from 1 to 20 instead of from 0 to 19. */
/* See the SCLK required reading for a detailed */
/* description of the Voyager and Mars Observer clock */
/* formats. */
/* $ Parameters */
/* MXPART is the maximum number of spacecraft clock partitions */
/* expected in the kernel file for any one spacecraft. */
/* See the INCLUDE file sclk.inc for this parameter's */
/* value. */
/* $ Exceptions */
/* 1) If kernel variables required by this routine are unavailable, */
/* the error will be diagnosed by routines called by this routine. */
/* SCLKCH will be returned as a blank string in this case. */
/* 2) If the number of partitions in the kernel file for spacecraft */
/* SC exceeds the parameter MXPART, the error */
/* 'SPICE(TOOMANYPARTS)' is signaled. SCLKCH will be returned */
/* as a blank string in this case. */
/* 3) If the encoded value does not fall in the boundaries of the */
/* mission, the error 'SPICE(VALUEOUTOFRANGE)' is signaled. */
/* SCLKCH will be returned as a blank string in this case. */
/* 4) If the declared length of SCLKCH is not large enough to */
/* contain the output clock string the error */
/* 'SPICE(SCLKTRUNCATED)' is signaled either by this routine */
/* or by a routine called by this routine. On output SCLKCH */
/* will contain a portion of the truncated clock string. */
/* $ Files */
/* A kernel file containing spacecraft clock partition information */
/* for the desired spacecraft must be loaded, using the routine */
/* FURNSH, before calling this routine. */
/* $ Particulars */
/* In general, it is difficult to compare spacecraft clock counts */
/* numerically since there are too many clock components for a */
/* single comparison. The routine SCENCD provides a method of */
/* assigning a single double precision number to a spacecraft's */
/* clock count, given one of its character representations. */
/* This routine performs the inverse operation to SCENCD, converting */
/* an encoded double precision number to character format. */
/* To convert the number of ticks since the start of the mission to */
/* a clock format character string, SCDECD: */
/* 1) Determines the spacecraft clock partition that TICKS falls */
/* in. */
/* 2) Subtracts off the number of ticks occurring in previous */
/* partitions, to get the number of ticks since the beginning */
/* of the current partition. */
/* 3) Converts the resulting ticks to clock format and forms the */
/* string */
/* 'partition_number/clock_string' */
/* $ Examples */
/* Double precision encodings of spacecraft clock counts are used to */
/* tag pointing data in the C-kernel. */
/* In the following example, pointing for a sequence of images from */
/* the Voyager 2 narrow angle camera is requested from the C-kernel */
/* using an array of character spacecraft clock counts as input. */
/* The clock counts attached to the output are then decoded to */
/* character and compared with the input strings. */
/* CHARACTER*(25) CLKIN ( 4 ) */
/* CHARACTER*(25) CLKOUT */
/* CHARACTER*(25) CLKTOL */
/* DOUBLE PRECISION TIMEIN */
/* DOUBLE PRECISION TIMOUT */
/* DOUBLE PRECISION CMAT ( 3, 3 ) */
/* INTEGER NPICS */
/* INTEGER SC */
/* DATA NPICS / 4 / */
/* DATA CLKIN / '2/20538:39:768', */
/* . '2/20543:21:768', */
/* . '2/20550:37', */
/* . '2/20561:59' / */
/* DATA CLKTOL / ' 0:01:000' / */
/* C */
/* C The instrument we want pointing for is the Voyager 2 */
/* C narrow angle camera. The reference frame we want is */
/* C J2000. The spacecraft is Voyager 2. */
/* C */
/* INST = -32001 */
/* REF = 'J2000' */
/* SC = -32 */
/* C */
/* C Load the appropriate files. We need */
/* C */
/* C 1) CK file containing pointing data. */
/* C 2) Spacecraft clock kernel file, for SCENCD and SCDECD. */
/* C */
/* CALL CKLPF ( 'VGR2NA.CK' ) */
/* CALL FURNSH ( 'SCLK.KER' ) */
/* C */
/* C Convert the tolerance string to ticks. */
/* C */
/* CALL SCTIKS ( SC, CLKTOL, TOL ) */
/* DO I = 1, NPICS */
/* CALL SCENCD ( SC, CLKIN( I ), TIMEIN ) */
/* CALL CKGP ( INST, TIMEIN, TOL, REF, CMAT, TIMOUT, */
/* . FOUND ) */
/* CALL SCDECD ( SC, TIMOUT, CLKOUT ) */
/* WRITE (*,*) */
/* WRITE (*,*) 'Input s/c clock count: ', CLKIN( I ) */
/* WRITE (*,*) 'Output s/c clock count: ', CLKOUT */
/* WRITE (*,*) 'Output C-Matrix: ', CMAT */
/* END DO */
/* The output from such a program might look like: */
/* Input s/c clock count: 2/20538:39:768 */
/* Output s/c clock count: 2/20538:39:768 */
/* Output C-Matrix: 'first C-matrix' */
/* Input s/c clock count: 2/20543:21:768 */
/* Output s/c clock count: 2/20543:22:768 */
/* Output C-Matrix: 'second C-matrix' */
/* Input s/c clock count: 2/20550:37 */
/* Output s/c clock count: 2/20550:36:768 */
/* Output C-Matrix: 'third C-matrix' */
/* Input s/c clock count: 2/20561:59 */
/* Output s/c clock count: 2/20561:58:768 */
/* Output C-Matrix: 'fourth C-matrix' */
/* $ Restrictions */
/* 1) Assumes that an SCLK kernel file appropriate for the clock */
/* designated by SC is loaded in the kernel pool at the time */
/* this routine is called. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* J.M. Lynch (JPL) */
/* R.E. Thurman (JPL) */
/* $ Version */
/* - SPICELIB Version 2.1.0, 05-FEB-2008 (NJB) */
/* Values of parameter MXPART and PARTLN are now */
/* provided by the INCLUDE file sclk.inc. */
/* - SPICELIB Version 2.0.1, 22-AUG-2006 (EDW) */
/* Replaced references to LDPOOL with references */
/* to FURNSH. */
/* - SPICELIB Version 2.0.0, 17-APR-1992 (JML) (WLT) */
/* The routine was changed to signal an error when SCLKCH is */
/* not long enough to contain the output spacecraft clock */
/* string. */
/* FAILED is now checked after calling SCPART. */
/* References to CLPOOL were deleted. */
/* Miscellaneous minor updates to the header were performed. */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 06-SEP-1990 (JML) (RET) */
/* -& */
/* $ Index_Entries */
/* decode spacecraft_clock */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 10-APR-1992 (JML) (WLT) */
/* The routine was changed to signal an error when SCLKCH is */
/* not long enough to contain the output spacecraft clock */
/* string. Previously, the SCLK routines simply truncated */
/* the clock string on the right. It was determined that */
/* since this truncation could easily go undetected by the */
/* user ( only the leftmost field of a clock string is */
/* required when clock string is used as an input to a */
/* SCLK routine ), it would be better to signal an error */
/* when this happens. */
/* FAILED is checked after calling SCPART in case an */
/* error has occurred reading the kernel file and the */
/* error action is not set to 'abort'. */
/* References to CLPOOL were deleted. */
/* Miscellaneous minor updates to the header were performed. */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SCDECD", (ftnlen)6);
}
/* Use a working copy of the input. */
ticks = d_nint(sclkdp);
s_copy(sclkch, " ", sclkch_len, (ftnlen)1);
/* Read the partition start and stop times (in ticks) for this */
/* mission. Error if there are too many of them. Also need to */
/* check FAILED in case error handling is not in ABORT or */
/* DEFAULT mode. */
scpart_(sc, &nparts, pstart, pstop);
if (failed_()) {
chkout_("SCDECD", (ftnlen)6);
return 0;
}
if (nparts > 9999) {
setmsg_("The number of partitions, #, for spacecraft # exceeds the v"
"alue for parameter MXPART, #.", (ftnlen)88);
errint_("#", &nparts, (ftnlen)1);
errint_("#", sc, (ftnlen)1);
errint_("#", &c__9999, (ftnlen)1);
sigerr_("SPICE(TOOMANYPARTS)", (ftnlen)19);
chkout_("SCDECD", (ftnlen)6);
return 0;
}
/* For each partition, compute the total number of ticks in that */
/* partition plus all preceding partitions. */
d__1 = pstop[0] - pstart[0];
ptotls[0] = d_nint(&d__1);
i__1 = nparts;
for (i__ = 2; i__ <= i__1; ++i__) {
d__1 = ptotls[(i__3 = i__ - 2) < 9999 && 0 <= i__3 ? i__3 : s_rnge(
"ptotls", i__3, "scdecd_", (ftnlen)495)] + pstop[(i__4 = i__
- 1) < 9999 && 0 <= i__4 ? i__4 : s_rnge("pstop", i__4, "scd"
"ecd_", (ftnlen)495)] - pstart[(i__5 = i__ - 1) < 9999 && 0 <=
i__5 ? i__5 : s_rnge("pstart", i__5, "scdecd_", (ftnlen)495)];
ptotls[(i__2 = i__ - 1) < 9999 && 0 <= i__2 ? i__2 : s_rnge("ptotls",
i__2, "scdecd_", (ftnlen)495)] = d_nint(&d__1);
}
/* The partition corresponding to the input ticks is the first one */
/* whose tick total is greater than the input value. The one */
/* exception is when the input ticks is equal to the total number */
/* of ticks represented by all the partitions. In this case the */
/* partition number is the last one, i.e. NPARTS. */
/* Error if TICKS comes before the first partition (that is, if it's */
/* negative), or after the last one. */
if (ticks == ptotls[(i__1 = nparts - 1) < 9999 && 0 <= i__1 ? i__1 :
s_rnge("ptotls", i__1, "scdecd_", (ftnlen)510)]) {
part = nparts;
} else {
part = lstled_(&ticks, &nparts, ptotls) + 1;
}
if (ticks < 0. || part > nparts) {
setmsg_("Value for ticks, #, does not fall in any partition for spac"
"ecraft #.", (ftnlen)68);
errdp_("#", &ticks, (ftnlen)1);
errint_("#", sc, (ftnlen)1);
sigerr_("SPICE(VALUEOUTOFRANGE)", (ftnlen)22);
chkout_("SCDECD", (ftnlen)6);
return 0;
}
/* To get the count in this partition, subtract off the total of */
/* the preceding partition counts and add the beginning count for */
/* this partition. */
if (part == 1) {
ticks += pstart[(i__1 = part - 1) < 9999 && 0 <= i__1 ? i__1 : s_rnge(
"pstart", i__1, "scdecd_", (ftnlen)535)];
} else {
ticks = ticks + pstart[(i__1 = part - 1) < 9999 && 0 <= i__1 ? i__1 :
s_rnge("pstart", i__1, "scdecd_", (ftnlen)537)] - ptotls[(
i__2 = part - 2) < 9999 && 0 <= i__2 ? i__2 : s_rnge("ptotls",
i__2, "scdecd_", (ftnlen)537)];
}
/* Now create the output SCLK clock string. */
/* First convert from ticks to clock string format. */
scfmt_(sc, &ticks, sclkch, sclkch_len);
/* Now convert the partition number to a character string and prefix */
/* it to the output string. */
intstr_(&part, prtstr, (ftnlen)5);
suffix_("/", &c__0, prtstr, (ftnlen)1, (ftnlen)5);
prelen = lastnb_(prtstr, (ftnlen)5);
suflen = lastnb_(sclkch, sclkch_len);
if (i_len(sclkch, sclkch_len) - suflen < prelen) {
setmsg_("Output string too short to contain clock string. Input tick"
" value: #, requires string of length #, but declared length "
"is #.", (ftnlen)124);
errdp_("#", sclkdp, (ftnlen)1);
i__1 = prelen + suflen;
errint_("#", &i__1, (ftnlen)1);
i__1 = i_len(sclkch, sclkch_len);
errint_("#", &i__1, (ftnlen)1);
sigerr_("SPICE(SCLKTRUNCATED)", (ftnlen)20);
chkout_("SCDECD", (ftnlen)6);
return 0;
}
prefix_(prtstr, &c__0, sclkch, (ftnlen)5, sclkch_len);
chkout_("SCDECD", (ftnlen)6);
return 0;
} /* scdecd_ */
/* Subroutine */ int kerman_0_(int n__, char *commnd, char *infile__, char *
error, ftnlen commnd_len, ftnlen infile_len, ftnlen error_len)
{
/* Initialized data */
static integer nfiles = 0;
static logical first = TRUE_;
static char synval[80*9] = " "
" " " "
" " " "
" "
" " " "
" " " "
" " " "
" "
" " "EK #word[ekfile] "
" " "LEAPSECONDS #word[leapfile] "
" " "SCLK KERNEL #word[sc"
"lkfile] ";
/* System generated locals */
integer i__1, i__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);
/* Local variables */
static integer need;
static char file[127], name__[32];
static integer clen;
extern logical have_(char *, ftnlen);
static integer left, reqd, nseg;
static char indx[4], pval[32*4];
static integer hits;
static char size[32], type__[32];
static logical quit;
extern /* Subroutine */ int zzeksinf_(integer *, integer *, char *,
integer *, char *, integer *, ftnlen, ftnlen);
static integer i__, j, k;
extern integer cardc_(char *, ftnlen);
static integer l, n;
extern /* Subroutine */ int clgai_(integer *, char *, integer *, integer *
, ftnlen), clgac_(integer *, char *, char *, ftnlen, ftnlen);
static integer r__;
static char cname[80], break__[80];
static integer headr[5];
extern /* Subroutine */ int eklef_(char *, integer *, ftnlen), clnid_(
integer *, integer *, logical *);
static integer space;
extern logical match_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int chkin_(char *, ftnlen);
static integer tcode, ncomc;
extern /* Subroutine */ int ekuef_(integer *);
static char rname[6], tname[32];
extern /* Subroutine */ int repmc_(char *, char *, char *, char *, ftnlen,
ftnlen, ftnlen, ftnlen), clnew_(char *, integer *, integer *,
integer *, integer *, integer *, logical *, logical *, integer *,
ftnlen);
static logical found;
static integer csize, ncols, ncomr;
static logical cnull;
static integer right, width[5], ctype;
extern integer ltrim_(char *, ftnlen);
static integer count;
extern integer rtrim_(char *, ftnlen);
static integer sizes[5];
static char style[80];
extern /* Subroutine */ int clnum_(integer *);
static logical justr[5];
extern /* Subroutine */ int m2chck_(char *, char *, integer *, char *,
char *, ftnlen, ftnlen, ftnlen, ftnlen), m2getc_(char *, char *,
logical *, char *, ftnlen, ftnlen, ftnlen), m2ints_(integer *,
char *, integer *, char *, ftnlen, ftnlen);
static integer id, nb;
static char bs[1];
extern logical m2xist_(char *, ftnlen);
static integer nh, sb, handle;
static char ifname[60], tabnam[64], tabcol[80*506], rnamec[7], cnames[64*
100];
static integer handls[20], segdsc[24];
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen),
eknseg_(integer *);
extern /* Subroutine */ int gcolmn_();
extern integer isrchi_(integer *, integer *, integer *);
extern /* Subroutine */ int pagput_(char *, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int nspwln_(char *, ftnlen);
static char synkey[32*9];
static integer synptr[9];
static char ekfils[127*20], thisfl[127], messge[300], idword[8];
static integer cdscrs[1100] /* was [11][100] */, widest, totalc, nresvr,
nresvc;
static logical cindxd;
static char spcial[4*5], lsttab[32];
static integer colids[506], lmarge, ordvec[500];
static logical presrv[5];
extern /* Subroutine */ int replch_(char *, char *, char *, char *,
ftnlen, ftnlen, ftnlen, ftnlen), prefix_(char *, integer *, char *
, ftnlen, ftnlen), chkout_(char *, ftnlen), expool_(char *,
logical *, ftnlen), repmct_(char *, char *, integer *, char *,
char *, ftnlen, ftnlen, ftnlen, ftnlen), clunld_(integer *),
ldpool_(char *, ftnlen);
static integer nid;
extern /* Subroutine */ int dasfnh_(char *, integer *, ftnlen);
static integer col, seg, ids[5];
extern /* Subroutine */ int remlac_(integer *, integer *, char *, integer
*, ftnlen), nspglr_(integer *, integer *), nspmrg_(char *, ftnlen)
, suffix_(char *, integer *, char *, ftnlen, ftnlen), pagrst_(
void), pagset_(char *, integer *, ftnlen), ssizec_(integer *,
char *, ftnlen), ssizei_(integer *, integer *), appndc_(char *,
char *, ftnlen, ftnlen), appndi_(integer *, integer *), pagscn_(
char *, ftnlen), scolmn_(integer *, integer *, char *, ftnlen),
tabrpt_(integer *, integer *, integer *, integer *, logical *,
logical *, char *, integer *, integer *, U_fp, ftnlen), orderc_(
char *, integer *, integer *, ftnlen);
extern integer pos_(char *, char *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int pagsft_(void), dasrfr_(integer *, char *,
char *, integer *, integer *, integer *, integer *, ftnlen,
ftnlen), nspshc_(integer *, logical *), bbputc_1__(char *, char *,
integer *, char *, ftnlen, ftnlen, ftnlen), nicepr_1__(char *,
char *, S_fp, ftnlen, ftnlen);
/* Version 2.4.0, 26-SEP-2005 */
/* Minor bug fix: replaced FILE with INFILE in the RTRIM call */
/* constructing "The file # is not listed ..." error message. */
/* Version 2.3.0, 21-JUN-1999 */
/* Added RETURN before first entry points. */
/* Version 2.2.0, 22-APR-1997 */
/* Declared PAGPUT external */
/* Version 2.1.0 14-SEP-1995 */
/* Variable INDEX removed. */
/* Version 2.0.0 23-AUG-1995 */
/* The widest string in a string column is no longer supplied */
/* by the EK summary stuff. We just set the value WIDEST */
/* to 24. */
/* This routine handles the loading of E-kernels, leapsecond and */
/* SCLK kernels. */
/* Passable routines */
/* Parameters that contain the routine name for use in check-in, */
/* check-out, and error messages. */
/* SPICELIB functions */
/* E-kernel functions */
/* Meta/2 Functions */
/* Interface to the SPICELIB error handling. */
/* Ek include files. */
/* +============================================================== */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Column Descriptor Parameters */
/* ekcoldsc.inc Version 6 23-AUG-1995 (NJB) */
/* Note: The column descriptor size parameter CDSCSZ is */
/* declared separately in the include section CDSIZE$INC.FOR. */
/* Offset of column descriptors, relative to start of segment */
/* integer address range. This number, when added to the last */
/* integer address preceding the segment, yields the DAS integer */
/* base address of the first column descriptor. Currently, this */
/* offset is exactly the size of a segment descriptor. The */
/* parameter SDSCSZ, which defines the size of a segment descriptor, */
/* is declared in the include file eksegdsc.inc. */
/* Size of column descriptor */
/* Indices of various pieces of column descriptors: */
/* CLSIDX is the index of the column's class code. (We use the */
/* word `class' to distinguish this item from the column's data */
/* type.) */
/* TYPIDX is the index of the column's data type code (CHR, INT, DP, */
/* or TIME). The type is actually implied by the class, but it */
/* will frequently be convenient to look up the type directly. */
/* LENIDX is the index of the column's string length value, if the */
/* column has character type. A value of IFALSE in this element of */
/* the descriptor indicates that the strings have variable length. */
/* SIZIDX is the index of the column's element size value. This */
/* descriptor element is meaningful for columns with fixed-size */
/* entries. For variable-sized columns, this value is IFALSE. */
/* NAMIDX is the index of the base address of the column's name. */
/* IXTIDX is the data type of the column's index. IXTIDX */
/* contains a type value only if the column is indexed. For columns */
/* that are not indexed, the location IXTIDX contains the boolean */
/* value IFALSE. */
/* IXPIDX is a pointer to the column's index. IXTPDX contains a */
/* meaningful value only if the column is indexed. The */
/* interpretation of the pointer depends on the data type of the */
/* index. */
/* NFLIDX is the index of a flag indicating whether nulls are */
/* permitted in the column. The value at location NFLIDX is */
/* ITRUE if nulls are permitted and IFALSE otherwise. */
/* ORDIDX is the index of the column's ordinal position in the */
/* list of columns belonging to the column's parent segment. */
/* METIDX is the index of the column's integer metadata pointer. */
/* This pointer is a DAS integer address. */
/* The last position in the column descriptor is reserved. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Column Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Segment Descriptor Parameters */
/* eksegdsc.inc Version 8 06-NOV-1995 (NJB) */
/* All `base addresses' referred to below are the addresses */
/* *preceding* the item the base applies to. This convention */
/* enables simplied address calculations in many cases. */
/* Size of segment descriptor. Note: the include file ekcoldsc.inc */
/* must be updated if this parameter is changed. The parameter */
/* CDOFF in that file should be kept equal to SDSCSZ. */
/* Index of the segment type code: */
/* Index of the segment's number. This number is the segment's */
/* index in the list of segments contained in the EK to which */
/* the segment belongs. */
/* Index of the DAS integer base address of the segment's integer */
/* meta-data: */
/* Index of the DAS character base address of the table name: */
/* Index of the segment's column count: */
/* Index of the segment's record count: */
/* Index of the root page number of the record tree: */
/* Index of the root page number of the character data page tree: */
/* Index of the root page number of the double precision data page */
/* tree: */
/* Index of the root page number of the integer data page tree: */
/* Index of the `modified' flag: */
/* Index of the `initialized' flag: */
/* Index of the shadowing flag: */
/* Index of the companion file handle: */
/* Index of the companion segment number: */
/* The next three items are, respectively, the page numbers of the */
/* last character, d.p., and integer data pages allocated by the */
/* segment: */
/* The next three items are, respectively, the page-relative */
/* indices of the last DAS word in use in the segment's */
/* last character, d.p., and integer data pages: */
/* Index of the DAS character base address of the column name list: */
/* The last descriptor element is reserved for future use. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Segment Descriptor Parameters */
/* $ 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 */
/* +============================================================== */
/* Meta/2 syntax definition variables. */
/* $ 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 */
/* E-kernel column type definitions */
/* INTEGER CH */
/* PARAMETER ( CH = 1 ) */
/* INTEGER DP */
/* PARAMETER ( DP = 2 ) */
/* INTEGER INT */
/* PARAMETER ( INT = 3 ) */
/* INTEGER TIME */
/* PARAMETER ( TIME = 4 ) */
/* Local Parameters */
/* FILSIZ is the maximum number of characters allowed for a */
/* filename */
/* LNGSIZ is the maximum number of characters allowed for */
/* use in reporting the columns associated with a given */
/* file. */
/* MAXFIL is the maximum number of E-kernels that can be loaded */
/* at any one time. */
/* NNAMES is the maximum number of names/headings that can appear */
/* in a report of loaded files and columns. */
/* MAXCOL is the maximum number of columns that may be present */
/* in any segment of an E-kernel */
/* LNSIZE is the standard text line length. */
/* Initialization logical */
/* Loaded file database (shared between entry points) */
/* Local Variables */
/* INTEGER IFALSE */
/* PARAMETER ( IFALSE = -1 ) */
/* Variables needed by NSPEKS */
/* Save everything. */
/* Initial Values */
/* Parameter adjustments */
if (error) {
}
/* Function Body */
switch(n__) {
case 1: goto L_nspld;
case 2: goto L_nspuld;
case 3: goto L_nspeks;
case 4: goto L_nspekc;
}
return 0;
/* Load an E-, leapsecond, or sclk kernel. */
L_nspld:
/* Standard Spicelib error handling. */
s_copy(rname, "NSPLD", (ftnlen)6, (ftnlen)5);
s_copy(rnamec, "NSPLD:", (ftnlen)7, (ftnlen)6);
if (return_()) {
return 0;
}
chkin_(rname, (ftnlen)6);
/* On the first pass establish the syntax that this routine */
/* is responsible for recognizing. */
if (first) {
first = FALSE_;
*(unsigned char *)bs = '@';
for (i__ = 1; i__ <= 100; ++i__) {
s_copy(cnames + (((i__1 = i__ - 1) < 100 && 0 <= i__1 ? i__1 :
s_rnge("cnames", i__1, "kerman_", (ftnlen)361)) << 6),
" ", (ftnlen)64, (ftnlen)1);
}
for (i__ = 1; i__ <= 3; ++i__) {
replch_(synval + ((i__1 = i__ + 5) < 9 && 0 <= i__1 ? i__1 :
s_rnge("synval", i__1, "kerman_", (ftnlen)366)) * 80,
"#", bs, synval + ((i__2 = i__ + 5) < 9 && 0 <= i__2 ?
i__2 : s_rnge("synval", i__2, "kerman_", (ftnlen)366)) *
80, (ftnlen)80, (ftnlen)1, (ftnlen)1, (ftnlen)80);
}
m2ints_(&c__3, synkey, synptr, synval, (ftnlen)32, (ftnlen)80);
}
/* See if this command matches a known syntax. If it doesn't */
/* there is no point in hanging around. */
m2chck_(commnd, synkey, synptr, synval, error, commnd_len, (ftnlen)32, (
ftnlen)80, error_len);
if (have_(error, error_len)) {
prefix_(rnamec, &c__1, error, (ftnlen)7, error_len);
chkout_(rname, (ftnlen)6);
return 0;
}
if (m2xist_("ekfile", (ftnlen)6)) {
/* We need to have a leapseconds kernel loaded before */
/* we can load an E-kernel. */
expool_("DELTET/DELTA_AT", &found, (ftnlen)15);
if (! found) {
s_copy(error, "Before an E-kernel can be loaded, you must load a"
" leapseconds kernel. ", error_len, (ftnlen)71);
chkout_(rname, (ftnlen)6);
return 0;
}
m2getc_("ekfile", commnd, &found, file, (ftnlen)6, commnd_len, (
ftnlen)127);
/* See if we already have this file. */
if (isrchc_(file, &nfiles, ekfils, (ftnlen)127, (ftnlen)127) > 0) {
chkout_(rname, (ftnlen)6);
return 0;
}
/* Make sure there is room for this file. */
if (nfiles == 20) {
s_copy(error, "The maximum number of E-kernels that can loaded a"
"t open by INSPEKT at one time is #. That number has alr"
"eady been reached. You will need to unload one of the fi"
"les that have already been loaded before you will be abl"
"e to load any other files. ", error_len, (ftnlen)244);
repmct_(error, "#", &c__20, "L", error, error_len, (ftnlen)1, (
ftnlen)1, error_len);
prefix_(rnamec, &c__1, error, (ftnlen)7, error_len);
chkout_(rname, (ftnlen)6);
return 0;
}
/* Load the file as an e-kernel. */
eklef_(file, &handle, rtrim_(file, (ftnlen)127));
if (have_(error, error_len)) {
prefix_(rnamec, &c__1, error, (ftnlen)7, error_len);
chkout_(rname, (ftnlen)6);
return 0;
}
/* Store the name of this file. */
++nfiles;
s_copy(ekfils + ((i__1 = nfiles - 1) < 20 && 0 <= i__1 ? i__1 :
s_rnge("ekfils", i__1, "kerman_", (ftnlen)442)) * 127, file, (
ftnlen)127, (ftnlen)127);
/* Determine how many segments are in the file we just loaded. */
nseg = eknseg_(&handle);
/* For each segment in the newly loaded file ... */
i__1 = nseg;
for (seg = 1; seg <= i__1; ++seg) {
s_copy(tabnam, " ", (ftnlen)64, (ftnlen)1);
for (i__ = 1; i__ <= 100; ++i__) {
s_copy(cnames + (((i__2 = i__ - 1) < 100 && 0 <= i__2 ? i__2 :
s_rnge("cnames", i__2, "kerman_", (ftnlen)457)) << 6)
, " ", (ftnlen)64, (ftnlen)1);
}
zzeksinf_(&handle, &seg, tabnam, segdsc, cnames, cdscrs, (ftnlen)
64, (ftnlen)64);
/* Add each column name to the list of columns held by the */
/* column manager. */
ncols = segdsc[4];
i__2 = ncols;
for (col = 1; col <= i__2; ++col) {
/* We need to make the column name include table it */
/* belongs to (a fully qualified column name). */
prefix_(".", &c__0, cnames + (((i__3 = col - 1) < 100 && 0 <=
i__3 ? i__3 : s_rnge("cnames", i__3, "kerman_", (
ftnlen)475)) << 6), (ftnlen)1, (ftnlen)64);
prefix_(tabnam, &c__0, cnames + (((i__3 = col - 1) < 100 && 0
<= i__3 ? i__3 : s_rnge("cnames", i__3, "kerman_", (
ftnlen)476)) << 6), (ftnlen)64, (ftnlen)64);
cindxd = cdscrs[(i__3 = col * 11 - 6) < 1100 && 0 <= i__3 ?
i__3 : s_rnge("cdscrs", i__3, "kerman_", (ftnlen)478)]
!= -1;
cnull = cdscrs[(i__3 = col * 11 - 4) < 1100 && 0 <= i__3 ?
i__3 : s_rnge("cdscrs", i__3, "kerman_", (ftnlen)479)]
!= -1;
ctype = cdscrs[(i__3 = col * 11 - 10) < 1100 && 0 <= i__3 ?
i__3 : s_rnge("cdscrs", i__3, "kerman_", (ftnlen)481)]
;
clen = cdscrs[(i__3 = col * 11 - 9) < 1100 && 0 <= i__3 ?
i__3 : s_rnge("cdscrs", i__3, "kerman_", (ftnlen)482)]
;
csize = cdscrs[(i__3 = col * 11 - 8) < 1100 && 0 <= i__3 ?
i__3 : s_rnge("cdscrs", i__3, "kerman_", (ftnlen)483)]
;
/* This is what used to be here, but the item NBLIDX */
/* vanished by design. We now just set this so something */
/* reasonable. 24 seemed like the reasonable thing at */
/* the time. (See the column manager and do a bit of */
/* code diving to see what this is used for.) */
/* WIDEST = CDSCRS ( NBLIDX, COL ) */
widest = 24;
clnew_(cnames + (((i__3 = col - 1) < 100 && 0 <= i__3 ? i__3 :
s_rnge("cnames", i__3, "kerman_", (ftnlen)496)) << 6)
, &handle, &ctype, &clen, &widest, &csize, &cindxd, &
cnull, &id, (ftnlen)64);
}
}
/* If anything went wrong, unload the file. */
if (have_(error, error_len)) {
prefix_(rnamec, &c__1, error, (ftnlen)7, error_len);
ekuef_(&handle);
clunld_(&handle);
--nfiles;
chkout_(rname, (ftnlen)6);
return 0;
}
} else if (m2xist_("leapfile", (ftnlen)8)) {
m2getc_("leapfile", commnd, &found, file, (ftnlen)8, commnd_len, (
ftnlen)127);
ldpool_(file, (ftnlen)127);
bbputc_1__("POST", "LEAPSECONDS", &c__1, file, (ftnlen)4, (ftnlen)11,
(ftnlen)127);
} else if (m2xist_("sclkfile", (ftnlen)8)) {
m2getc_("sclkfile", commnd, &found, file, (ftnlen)8, commnd_len, (
ftnlen)127);
ldpool_(file, (ftnlen)127);
bbputc_1__("APPEND", "SCLK", &c__1, file, (ftnlen)6, (ftnlen)4, (
ftnlen)127);
} else {
s_copy(error, "The input command was unrecognized and somehow got to"
" an \"impossible\" place in KERMAN.FOR", error_len, (ftnlen)
89);
}
if (have_(error, error_len)) {
prefix_(rnamec, &c__1, error, (ftnlen)7, error_len);
chkout_(rname, (ftnlen)6);
return 0;
}
chkout_(rname, (ftnlen)6);
return 0;
/* Unload an E-kernel from the list of known files. */
L_nspuld:
s_copy(rname, "NSPULD", (ftnlen)6, (ftnlen)6);
s_copy(rnamec, "NSPULD:", (ftnlen)7, (ftnlen)7);
if (return_()) {
return 0;
}
chkin_(rname, (ftnlen)6);
j = isrchc_(infile__, &nfiles, ekfils, infile_len, (ftnlen)127);
if (j == 0) {
s_copy(error, "The file # is not listed among those files that have "
"been loaded. ", error_len, (ftnlen)66);
repmc_(error, "#", infile__, error, error_len, (ftnlen)1, rtrim_(
infile__, infile_len), error_len);
chkout_(rname, (ftnlen)6);
return 0;
}
/* Get the handle associated with this file. */
dasfnh_(infile__, &handle, rtrim_(infile__, infile_len));
if (have_(error, error_len)) {
chkout_(rname, (ftnlen)6);
return 0;
}
/* Now unload the file, and detach its handle from any columns to */
/* which it might be attached. */
ekuef_(&handle);
clunld_(&handle);
/* Finally remove this file from our internal list of files. */
remlac_(&c__1, &j, ekfils, &nfiles, (ftnlen)127);
chkout_(rname, (ftnlen)6);
return 0;
/* Create a report regarding currently loaded kernels/columns. */
L_nspeks:
/* Version 2.0 Aug 3, 1995 */
/* This routine was rewritten to provide a more friendly */
/* kernel summary. */
/* ---B. Taber */
/* This routine displays the currently loaded E-kernels. */
s_copy(rname, "NSPEKS", (ftnlen)6, (ftnlen)6);
s_copy(rnamec, "NSPEKS:", (ftnlen)7, (ftnlen)7);
if (return_()) {
return 0;
}
/* write (*,*) 'Checking in:' */
chkin_(rname, (ftnlen)6);
if (nfiles <= 0) {
nspwln_(" ", (ftnlen)1);
nspwln_("There are no E-kernels loaded now.", (ftnlen)34);
nspwln_(" ", (ftnlen)1);
chkout_(rname, (ftnlen)6);
return 0;
}
/* First thing we do is set up the NICEPR_1 style string */
/* to be used in creation of summary headers. */
/* write (*,*) 'Fetching margins: ' */
nspglr_(&left, &right);
nspmrg_(style, (ftnlen)80);
suffix_("FLAG", &c__1, style, (ftnlen)4, (ftnlen)80);
suffix_("E-kernel:", &c__1, style, (ftnlen)9, (ftnlen)80);
/* Reset the output page, title frequency and header frequency */
/* values. */
/* write (*,*) 'Resetting page and setting up page attributes:' */
pagrst_();
pagset_("TITLEFREQUENCY", &c__0, (ftnlen)14);
pagset_("HEADERFREQUENCY", &c__0, (ftnlen)15);
pagset_("NOSPACEFOOTER", &c__1, (ftnlen)13);
pagset_("FOOTERFREQUENCY", &c_n1, (ftnlen)15);
s_copy(pval, "CH", (ftnlen)32, (ftnlen)2);
s_copy(pval + 32, "D.P.", (ftnlen)32, (ftnlen)4);
s_copy(pval + 64, "INTEGER", (ftnlen)32, (ftnlen)7);
s_copy(pval + 96, "TIME", (ftnlen)32, (ftnlen)4);
lmarge = 1;
space = 1;
/* Next we set up the the column id codes, sizes, */
/* default widths, justifications, component preservation, */
/* and special marker attributes for each column. */
headr[0] = 1;
headr[1] = 2;
headr[2] = 3;
headr[3] = 4;
headr[4] = 5;
sizes[0] = 1;
sizes[1] = 1;
sizes[2] = 1;
sizes[3] = 1;
sizes[4] = 1;
width[0] = 16;
width[1] = 16;
width[2] = 8;
width[3] = 8;
width[4] = 6;
need = width[0] + width[1] + width[2] + width[3] + width[4] + 4;
right = min(right,need);
pagset_("PAGEWIDTH", &right, (ftnlen)9);
reqd = width[2] + width[3] + width[4] + 4;
/* If the page width is less than default needed, we reset the */
/* widths of the first two columns so they will fit in available */
/* space. */
if (right < need) {
width[0] = (right - reqd) / 2;
width[1] = width[0];
}
justr[0] = FALSE_;
justr[1] = FALSE_;
justr[2] = FALSE_;
justr[3] = TRUE_;
justr[4] = TRUE_;
presrv[0] = TRUE_;
presrv[1] = TRUE_;
presrv[2] = TRUE_;
presrv[3] = TRUE_;
presrv[4] = TRUE_;
s_copy(spcial, " ", (ftnlen)4, (ftnlen)1);
s_copy(spcial + 4, " ", (ftnlen)4, (ftnlen)1);
s_copy(spcial + 8, " ", (ftnlen)4, (ftnlen)1);
s_copy(spcial + 12, " ", (ftnlen)4, (ftnlen)1);
s_copy(spcial + 16, " ", (ftnlen)4, (ftnlen)1);
/* write (*,*) 'Starting file loop:' */
i__1 = nfiles;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Get the handle associated with this file, and get the */
/* number of ID's currently known. */
dasfnh_(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 : s_rnge(
"ekfils", i__2, "kerman_", (ftnlen)738)) * 127, &handle, (
ftnlen)127);
clnum_(&nid);
/* write (*,*) 'File: ', I, 'Handle: ', HANDLE */
/* Now empty out the table/column data for this file. */
/* write (*,*) 'Empty out the column collector.' */
ssizec_(&c__500, tabcol, (ftnlen)80);
ssizei_(&c__500, colids);
/* Cycle over all column id's to determine if they */
/* are attached to this particular file. */
/* write (*,*) 'Beginning Column search: ', NID, ' Columns' */
i__2 = nid;
for (j = 1; j <= i__2; ++j) {
clnid_(&j, &id, &found);
clgai_(&id, "HANDLES", &nh, handls, (ftnlen)7);
if (isrchi_(&handle, &nh, handls) > 0) {
/* This column is associated with this file. Store */
/* its name and id-code for the next section of code. */
/* write (*,*) 'Column id and associated handle match.' */
clgac_(&id, "NAME", cname, (ftnlen)4, (ftnlen)80);
appndc_(cname, tabcol, (ftnlen)80, (ftnlen)80);
appndi_(&id, colids);
}
}
/* Layout the pages. We perform a soft page reset */
/* so that the various sections will be empty. */
/* Note this doesn't affect frequency parameter */
/* or other geometry attributes of pages. */
/* write (*,*) 'Creating page: Title:' */
pagscn_("TITLE", (ftnlen)5);
pagput_(" ", (ftnlen)1);
pagput_("Summary of Loaded E-kernels", (ftnlen)27);
pagput_(" ", (ftnlen)1);
/* write (*,*) 'Creating page: Header' */
/* Set up the various items needed for the report header. */
pagscn_("HEADER", (ftnlen)6);
pagput_(" ", (ftnlen)1);
nicepr_1__(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("ekfils", i__2, "kerman_", (ftnlen)791)) * 127, style,
(S_fp)pagput_, (ftnlen)127, (ftnlen)80);
pagput_(" ", (ftnlen)1);
scolmn_(&c__1, &c__1, "Table Name", (ftnlen)10);
scolmn_(&c__2, &c__1, "Column Name", (ftnlen)11);
scolmn_(&c__3, &c__1, "Type", (ftnlen)4);
scolmn_(&c__4, &c__1, "Size", (ftnlen)4);
scolmn_(&c__5, &c__1, "Index", (ftnlen)5);
/* write (*,*) 'Creating page: Column headings' */
tabrpt_(&c__5, headr, sizes, width, justr, presrv, spcial, &lmarge, &
space, (U_fp)gcolmn_, (ftnlen)4);
s_copy(break__, "==================================================="
"=============================", (ftnlen)80, (ftnlen)80);
pagput_(break__, right);
/* Now set the page section to the body portion for */
/* preparing to fill in the e-kernel summary. */
/* write (*,*) 'Creating page: Body of report:' */
pagscn_("BODY", (ftnlen)4);
n = cardc_(tabcol, (ftnlen)80);
orderc_(tabcol + 480, &n, ordvec, (ftnlen)80);
s_copy(lsttab, " ", (ftnlen)32, (ftnlen)1);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
k = ordvec[(i__3 = j - 1) < 500 && 0 <= i__3 ? i__3 : s_rnge(
"ordvec", i__3, "kerman_", (ftnlen)826)];
clgac_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 : s_rnge(
"colids", i__3, "kerman_", (ftnlen)828)], "TABLE", tname,
(ftnlen)5, (ftnlen)32);
clgac_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 : s_rnge(
"colids", i__3, "kerman_", (ftnlen)829)], "NAME", cname, (
ftnlen)4, (ftnlen)80);
clgac_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 : s_rnge(
"colids", i__3, "kerman_", (ftnlen)830)], "SIZE", size, (
ftnlen)4, (ftnlen)32);
clgac_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 : s_rnge(
"colids", i__3, "kerman_", (ftnlen)831)], "INDEXED", indx,
(ftnlen)7, (ftnlen)4);
/* Note: There is only one type associated with each */
/* handle. Thus TCODE does not need to be an array. */
clgai_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 : s_rnge(
"colids", i__3, "kerman_", (ftnlen)836)], "TYPE", &count,
&tcode, (ftnlen)4);
if (s_cmp(tname, lsttab, (ftnlen)32, (ftnlen)32) == 0) {
s_copy(tname, " ", (ftnlen)32, (ftnlen)1);
} else if (s_cmp(lsttab, " ", (ftnlen)32, (ftnlen)1) != 0) {
pagput_(" ", (ftnlen)1);
s_copy(lsttab, tname, (ftnlen)32, (ftnlen)32);
} else {
s_copy(lsttab, tname, (ftnlen)32, (ftnlen)32);
}
nb = pos_(cname, ".", &c__1, (ftnlen)80, (ftnlen)1) + 1;
s_copy(name__, cname + (nb - 1), (ftnlen)32, 80 - (nb - 1));
if (tcode == 1) {
clgac_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 :
s_rnge("colids", i__3, "kerman_", (ftnlen)852)],
"TYPE", type__, (ftnlen)4, (ftnlen)32);
sb = pos_(type__, "*", &c__1, (ftnlen)32, (ftnlen)1);
s_copy(pval, "CH", (ftnlen)32, (ftnlen)2);
suffix_(type__ + (sb - 1), &c__0, pval, 32 - (sb - 1), (
ftnlen)32);
}
scolmn_(&c__6, &c__1, tname, (ftnlen)32);
scolmn_(&c__7, &c__1, name__, (ftnlen)32);
scolmn_(&c__8, &c__1, pval + (((i__3 = tcode - 1) < 4 && 0 <=
i__3 ? i__3 : s_rnge("pval", i__3, "kerman_", (ftnlen)860)
) << 5), (ftnlen)32);
scolmn_(&c__9, &c__1, size, (ftnlen)32);
scolmn_(&c__10, &c__1, indx, (ftnlen)4);
ids[0] = 6;
ids[1] = 7;
ids[2] = 8;
ids[3] = 9;
ids[4] = 10;
/* write (*,*) 'Creating next row:' */
/* write (*,*) TNAME */
/* write (*,*) NAME */
/* write (*,*) PVAL(TCODE) */
/* write (*,*) SIZE */
/* write (*,*) INDX */
tabrpt_(&c__5, ids, sizes, width, justr, presrv, spcial, &lmarge,
&space, (U_fp)gcolmn_, (ftnlen)4);
/* write (*,*) 'Row created.' */
}
/* Do a soft page reset so for the next file to be displayed */
/* write (*,*) 'Performing soft page reset.' */
pagsft_();
pagrst_();
pagset_("TITLEFREQUENCY", &c_n1, (ftnlen)14);
pagset_("HEADERFREQUENCY", &c__0, (ftnlen)15);
pagset_("NOSPACEFOOTER", &c__1, (ftnlen)13);
pagset_("FOOTERFREQUENCY", &c_n1, (ftnlen)15);
}
chkout_(rname, (ftnlen)6);
return 0;
/* $Procedure NSPEKC ( Inspekt the comments from EK files ) */
L_nspekc:
/* This entry point examines each file that matches the */
/* template given by INFILE and if comments exist for the */
/* file, they are displayed. */
/* Version 1.0.0 25-AUG-1995 (WLT) */
chkin_("NSPEKC", (ftnlen)6);
totalc = 0;
s_copy(thisfl, " ", (ftnlen)127, (ftnlen)1);
/* We might not need the style string, but it doesn't hurt to */
/* get it. */
nspmrg_(style, (ftnlen)80);
/* If there are no loaded E-kernels say so and return. */
if (nfiles == 0) {
s_copy(messge, "There are no E-kernels loaded now. ", (ftnlen)300, (
ftnlen)35);
nicepr_1__(messge, style, (S_fp)nspwln_, (ftnlen)300, (ftnlen)80);
chkout_("NSPEKC", (ftnlen)6);
return 0;
}
/* Count the number of characters present in the files */
/* that match the template. */
r__ = rtrim_(infile__, infile_len);
l = ltrim_(infile__, infile_len);
i__1 = nfiles;
for (i__ = 1; i__ <= i__1; ++i__) {
if (match_(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("ekfils", i__2, "kerman_", (ftnlen)945)) * 127,
infile__ + (l - 1), (ftnlen)127, r__ - (l - 1))) {
dasfnh_(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("ekfils", i__2, "kerman_", (ftnlen)947)) * 127, &
handle, (ftnlen)127);
dasrfr_(&handle, idword, ifname, &nresvr, &nresvc, &ncomr, &ncomc,
(ftnlen)8, (ftnlen)60);
totalc += ncomc;
++hits;
s_copy(thisfl, ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ?
i__2 : s_rnge("ekfils", i__2, "kerman_", (ftnlen)955)) *
127, (ftnlen)127, (ftnlen)127);
}
}
/* If we didn't get any characters there several possible */
/* reasons. We can look at HITS to see why and form a */
/* grammatically reasonable message. */
if (totalc == 0) {
if (hits == 0) {
s_copy(messge, "There are no E-kernels loaded whose file name ma"
"tches the supplied template '#'.", (ftnlen)300, (ftnlen)
80);
repmc_(messge, "#", infile__ + (l - 1), messge, (ftnlen)300, (
ftnlen)1, r__ - (l - 1), (ftnlen)300);
} else if (hits == 1) {
s_copy(messge, "There are no comments present in the file '#'. ",
(ftnlen)300, (ftnlen)47);
repmc_(messge, "#", thisfl, messge, (ftnlen)300, (ftnlen)1, (
ftnlen)127, (ftnlen)300);
} else if (hits == 2) {
s_copy(messge, "There are no comments present in either of the #"
" files that match the supplied template. ", (ftnlen)300, (
ftnlen)89);
repmct_(messge, "#", &hits, "L", messge, (ftnlen)300, (ftnlen)1, (
ftnlen)1, (ftnlen)300);
} else {
s_copy(messge, "There are no comments present in any of the # fi"
"les that match the supplied template. ", (ftnlen)300, (
ftnlen)86);
repmct_(messge, "#", &hits, "L", messge, (ftnlen)300, (ftnlen)1, (
ftnlen)1, (ftnlen)300);
}
nicepr_1__(messge, style, (S_fp)nspwln_, (ftnlen)300, (ftnlen)80);
chkout_("NSPEKC", (ftnlen)6);
return 0;
}
/* Ok. We've got something. Set up the output page to receive */
/* the comments a file at a time. */
suffix_("FLAG E-kernel:", &c__1, style, (ftnlen)14, (ftnlen)80);
i__1 = nfiles;
for (i__ = 1; i__ <= i__1; ++i__) {
if (match_(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("ekfils", i__2, "kerman_", (ftnlen)1012)) * 127,
infile__ + (l - 1), (ftnlen)127, r__ - (l - 1))) {
dasfnh_(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("ekfils", i__2, "kerman_", (ftnlen)1014)) * 127, &
handle, (ftnlen)127);
dasrfr_(&handle, idword, ifname, &nresvr, &nresvc, &ncomr, &ncomc,
(ftnlen)8, (ftnlen)60);
if (ncomc == 0) {
s_copy(messge, "# contains no comments.", (ftnlen)300, (
ftnlen)23);
repmc_(messge, "#", ekfils + ((i__2 = i__ - 1) < 20 && 0 <=
i__2 ? i__2 : s_rnge("ekfils", i__2, "kerman_", (
ftnlen)1023)) * 127, messge, (ftnlen)300, (ftnlen)1, (
ftnlen)127, (ftnlen)300);
nspwln_(" ", (ftnlen)1);
nicepr_1__(messge, style, (S_fp)nspwln_, (ftnlen)300, (ftnlen)
80);
} else {
pagrst_();
pagscn_("HEADER", (ftnlen)6);
pagset_("TITLEFREQUENCY", &c__0, (ftnlen)14);
pagset_("HEADERFREQUENCY", &c__0, (ftnlen)15);
pagset_("NOSPACEFOOTER", &c__1, (ftnlen)13);
pagset_("FOOTERFREQUENCY", &c_n1, (ftnlen)15);
pagput_(" ", (ftnlen)1);
nicepr_1__(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ?
i__2 : s_rnge("ekfils", i__2, "kerman_", (ftnlen)1038)
) * 127, style, (S_fp)pagput_, (ftnlen)127, (ftnlen)
80);
pagput_(" ", (ftnlen)1);
nspshc_(&handle, &quit);
if (quit) {
nspwln_(" ", (ftnlen)1);
chkout_("NSPEKC", (ftnlen)6);
return 0;
}
}
}
}
nspwln_(" ", (ftnlen)1);
chkout_("NSPEKC", (ftnlen)6);
return 0;
} /* kerman_ */
/* $Procedure LBUILD ( Build a list in a character string ) */
/* Subroutine */ int lbuild_(char *items, integer *n, char *delim, char *list,
ftnlen items_len, ftnlen delim_len, ftnlen list_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen), s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer dlen, ilen, llen, last, lpos, i__, first;
extern integer lastnb_(char *, ftnlen), frstnb_(char *, ftnlen);
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen);
/* $ Abstract */
/* Build a list of items delimited by a character. */
/* $ 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 */
/* CHARACTER, LIST, STRING */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ITEMS I Items in the list. */
/* N I Number of items in the list. */
/* DELIM I String used to delimit items. */
/* LIST O List of items delimited by DELIM. */
/* $ Detailed_Input */
/* ITEMS are the items to be combined to make the output */
/* list. Leading and trailing blanks are ignored. */
/* (Only the non-blank parts of the items are used.) */
/* N is the number of items. */
/* DELIM is the string used to delimit the items in the */
/* output list. DELIM may contain any number of */
/* characters, including blanks. */
/* $ Detailed_Output */
/* LIST is the output list, containing the N elements of */
/* ITEMS delimited by DELIM. If LIST is not long enough */
/* to contain the output list, it is truncated on the */
/* right. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* The non-blank parts of the elements of the ITEMS array are */
/* appended to the list, one at a time, separated by DELIM. */
/* $ Examples */
/* The following examples illustrate the operation of LBUILD. */
/* 1) Let */
/* DELIM = ' ' */
/* ITEMS(1) = 'A' */
/* ITEMS(2) = ' number' */
/* ITEMS(3) = 'of' */
/* ITEMS(4) = ' words' */
/* ITEMS(5) = 'separated' */
/* ITEMS(6) = ' by' */
/* ITEMS(7) = 'spaces' */
/* Then */
/* LIST = 'A number of words separated by spaces' */
/* 2) Let */
/* DELIM = '/' */
/* ITEMS(1) = ' ' */
/* ITEMS(2) = ' ' */
/* ITEMS(3) = 'option1' */
/* ITEMS(4) = ' ' */
/* ITEMS(5) = 'option2' */
/* ITEMS(6) = ' ' */
/* ITEMS(7) = ' ' */
/* ITEMS(8) = ' ' */
/* Then */
/* LIST = '//option1//option2///' */
/* 3) Let */
/* DELIM = ' and ' */
/* ITEMS(1) = 'Bob' */
/* ITEMS(2) = 'Carol' */
/* ITEMS(3) = 'Ted' */
/* ITEMS(4) = 'Alice' */
/* Then */
/* LIST = 'Bob and Carol and Ted and Alice' */
/* $ Restrictions */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Author_and_Institution */
/* I.M. Underwood (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 (IMU) */
/* -& */
/* $ Index_Entries */
/* build a list in a character_string */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Find the non-blank part of each item. Move it to the */
/* end of the list, followed by a delimiter. If the item is */
/* blank, don't move anything but the delimiter. */
/* LPOS is the next position in the output list to be filled. */
/* LLEN is the length of the output list. */
/* DLEN is the length of DELIM. */
/* ILEN is the length of the next item in the list. */
s_copy(list, " ", list_len, (ftnlen)1);
lpos = 1;
llen = i_len(list, list_len);
dlen = i_len(delim, delim_len);
if (*n > 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (lpos <= llen) {
if (s_cmp(items + (i__ - 1) * items_len, " ", items_len, (
ftnlen)1) == 0) {
s_copy(list + (lpos - 1), delim, list_len - (lpos - 1),
delim_len);
lpos += dlen;
} else {
first = frstnb_(items + (i__ - 1) * items_len, items_len);
last = lastnb_(items + (i__ - 1) * items_len, items_len);
ilen = last - first + 1;
s_copy(list + (lpos - 1), items + ((i__ - 1) * items_len
+ (first - 1)), list_len - (lpos - 1), last - (
first - 1));
suffix_(delim, &c__0, list, delim_len, list_len);
lpos = lpos + ilen + dlen;
}
}
}
/* We're at the end of the list. Right now, the list ends in */
/* a delimiter. Drop it. */
if (lpos - dlen <= llen) {
i__1 = lpos - dlen - 1;
s_copy(list + i__1, " ", list_len - i__1, (ftnlen)1);
}
}
return 0;
} /* lbuild_ */
/* $Procedure SCPART ( Spacecraft Clock Partition Information ) */
/* Subroutine */ int scpart_(integer *sc, integer *nparts, doublereal *pstart,
doublereal *pstop)
{
/* Initialized data */
static logical first = TRUE_;
static logical nodata = TRUE_;
static integer oldsc = 0;
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer);
double d_nint(doublereal *);
/* Local variables */
extern /* Subroutine */ int zzcvpool_(char *, integer *, logical *,
ftnlen), zzctruin_(integer *);
integer i__;
extern /* Subroutine */ int scld01_(char *, integer *, integer *, integer
*, doublereal *, ftnlen), chkin_(char *, ftnlen), repmi_(char *,
char *, integer *, char *, ftnlen, ftnlen, ftnlen);
static doublereal prtsa[9999], prtso[9999];
extern logical failed_(void);
char kvname[60*2];
logical update;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen), suffix_(char *, integer *, char *, ftnlen, ftnlen);
integer nprtsa;
extern logical return_(void);
static integer usrctr[2];
extern /* Subroutine */ int swpool_(char *, integer *, char *, ftnlen,
ftnlen);
integer nprtso;
static integer lstprt;
/* $ Abstract */
/* Get spacecraft clock partition information from a spacecraft */
/* clock kernel 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 */
/* SCLK */
/* $ Keywords */
/* TIME */
/* $ Declarations */
/* $ Abstract */
/* Include file sclk.inc */
/* SPICE private file intended solely for the support of SPICE */
/* routines. Users should not include this file directly due */
/* to the volatile nature of this file */
/* The parameters below define sizes and limits used by */
/* the SCLK system. */
/* $ 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 */
/* See the declaration section below. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 2.0.0, 24-MAY-2010 (NJB) */
/* Increased value of maximum coefficient record count */
/* parameter MXCOEF from 10K to 50K. */
/* - SPICELIB Version 1.0.0, 11-FEB-2008 (NJB) */
/* -& */
/* Number of supported SCLK field delimiters: */
/* Supported SCLK string field delimiters: */
/* Maximum number of partitions: */
/* Partition string length. */
/* Since the maximum number of partitions is given by MXPART is */
/* 9999, PRTSTR needs at most 4 characters for the partition number */
/* and one character for the slash. */
/* Maximum number of coefficient records: */
/* Maximum number of fields in an SCLK string: */
/* Length of strings used to represent D.P. */
/* numbers: */
/* Maximum number of supported parallel time systems: */
/* End of include file sclk.inc */
/* $ 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 */
/* -------- --- -------------------------------------------------- */
/* SC I NAIF spacecraft identification code. */
/* NPARTS O The number of spacecraft clock partitions. */
/* PSTART O Array of partition start times. */
/* PSTOP O Array of partition stop times. */
/* MXPART P Maximum number of partitions. */
/* $ Detailed_Input */
/* SC is the NAIF ID for the spacecraft whose clock partition */
/* information is being requested. */
/* $ Detailed_Output */
/* NPARTS is the number of spacecraft clock time partitions */
/* described in the kernel file for spacecraft SC. */
/* PSTART is an array containing NPARTS partition start times */
/* represented as double precision, encoded SCLK */
/* ("ticks"). The values contained in PSTART are whole */
/* numbers. */
/* PSTOP is an array containing NPARTS partition end times */
/* represented as double precision, encoded SCLK */
/* ("ticks"). The values contained in PSTOP are whole */
/* numbers. */
/* $ Parameters */
/* MXPART is the maximum number of partitions for any spacecraft */
/* clock. SCLK kernels contain start and stop times for */
/* each partition. See the INCLUDE file sclk.inc for this */
/* parameter's value. */
/* $ Exceptions */
/* 1) If the kernel variables containing the spacecraft clock */
/* partition start and stop times have not been loaded in the */
/* kernel pool, the error will be diagnosed by routines called */
/* by this routine. */
/* 2) If the number of start and stop times are different then */
/* the error SPICE(NUMPARTSUNEQUAL) is signaled. */
/* $ Files */
/* An SCLK kernel containing spacecraft clock partition start */
/* and stop times for the spacecraft clock indicated by SC must */
/* be loaded into the kernel pool. */
/* $ Particulars */
/* SCPART looks for two variables in the kernel pool for each */
/* spacecraft's partition information. If SC = -nn, then the names of */
/* the variables are */
/* 'SCLK_PARTITION_START_nn' and */
/* 'SCLK_PARTITION_END_nn'. */
/* The start and stop times returned are in units of "ticks". */
/* $ Examples */
/* 1) The following program fragment finds and prints out partition */
/* start and stop times in clock format for the Galileo mission. */
/* In this example, Galileo partition times are assumed to be */
/* in the kernel file SCLK.KER. */
/* CHARACTER*(30) START */
/* CHARACTER*(30) STOP */
/* CALL FURNSH ( 'SCLK.KER' ) */
/* SC = -77 */
/* CALL SCPART ( SC, NPARTS, PSTART, PSTOP ) */
/* DO I = 1, NPARTS */
/* CALL SCFMT ( SC, PSTART( I ), START ) */
/* CALL SCFMT ( SC, PSTOP ( I ), STOP ) */
/* WRITE (*,*) */
/* WRITE (*,*) 'Partition ', I, ':' */
/* WRITE (*,*) 'Start = ', START */
/* WRITE (*,*) 'Stop = ', STOP */
/* END DO */
/* $ Restrictions */
/* 1) This routine assumes that an SCLK kernel appropriate to the */
/* spacecraft identified by SC has been loaded into the kernel */
/* pool. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* J.M. Lynch (JPL) */
/* B.V. Semenov (JPL) */
/* R.E. Thurman (JPL) */
/* $ Version */
/* - SPICELIB Version 2.3.1, 19-MAR-2014 (NJB) */
/* Minor header comment updates were made. */
/* - SPICELIB Version 2.3.0, 09-SEP-2013 (BVS) */
/* Updated to keep track of the POOL counter and call ZZCVPOOL. */
/* - SPICELIB Version 2.2.0, 05-MAR-2009 (NJB) */
/* Bug fix: this routine now keeps track of whether its */
/* kernel pool look-up succeeded. If not, a kernel pool */
/* lookup is attempted on the next call to this routine. */
/* - SPICELIB Version 2.1.0, 05-FEB-2008 (NJB) */
/* The values of the parameter MXPART is now */
/* provided by the INCLUDE file sclk.inc. */
/* - SPICELIB Version 1.1.1, 22-AUG-2006 (EDW) */
/* Replaced references to LDPOOL with references */
/* to FURNSH. */
/* - SPICELIB Version 1.1.0, 22-MAR-1993 (JML) */
/* The routine now uses the kernel pool watch capability. */
/* - 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, 03-SEP-1990 (NJB) (JML) (RET) */
/* -& */
/* $ Index_Entries */
/* spacecraft_clock partition information */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Saved variables */
/* Initial values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
chkin_("SCPART", (ftnlen)6);
/* On the first pass through the subroutine, or if the */
/* spacecraft code changes, set watches on the SCLK kernel */
/* variables for the current clock. */
if (first || *sc != oldsc) {
/* Make up a list of names of kernel variables that we'll use. */
s_copy(kvname, "SCLK_PARTITION_START", (ftnlen)60, (ftnlen)20);
s_copy(kvname + 60, "SCLK_PARTITION_END", (ftnlen)60, (ftnlen)18);
for (i__ = 1; i__ <= 2; ++i__) {
suffix_("_#", &c__0, kvname + ((i__1 = i__ - 1) < 2 && 0 <= i__1 ?
i__1 : s_rnge("kvname", i__1, "scpart_", (ftnlen)284)) *
60, (ftnlen)2, (ftnlen)60);
i__3 = -(*sc);
repmi_(kvname + ((i__1 = i__ - 1) < 2 && 0 <= i__1 ? i__1 :
s_rnge("kvname", i__1, "scpart_", (ftnlen)285)) * 60,
"#", &i__3, kvname + ((i__2 = i__ - 1) < 2 && 0 <= i__2 ?
i__2 : s_rnge("kvname", i__2, "scpart_", (ftnlen)285)) *
60, (ftnlen)60, (ftnlen)1, (ftnlen)60);
}
/* Set a watch on all of the kernel variables used. */
swpool_("SCPART", &c__2, kvname, (ftnlen)6, (ftnlen)60);
/* Keep track of the last spacecraft ID encountered. */
oldsc = *sc;
/* Initialize the local POOL counter to user value. */
zzctruin_(usrctr);
first = FALSE_;
}
/* If any of the kernel pool variables that this routine uses */
/* have been updated, or if the spacecraft ID changes, look up */
/* the new values from the kernel pool. */
zzcvpool_("SCPART", usrctr, &update, (ftnlen)6);
if (update || nodata) {
/* Read the values from the kernel pool. */
scld01_("SCLK_PARTITION_START", sc, &c__9999, &nprtsa, prtsa, (ftnlen)
20);
scld01_("SCLK_PARTITION_END", sc, &c__9999, &nprtso, prtso, (ftnlen)
18);
if (failed_()) {
nodata = TRUE_;
chkout_("SCPART", (ftnlen)6);
return 0;
}
/* Error checking. */
if (nprtsa != nprtso) {
nodata = TRUE_;
setmsg_("The number of partition start and stop times are unequa"
"l for spacecraft #. ", (ftnlen)78);
errint_("#", sc, (ftnlen)1);
sigerr_("SPICE(NUMPARTSUNEQUAL)", (ftnlen)22);
chkout_("SCPART", (ftnlen)6);
return 0;
}
/* At this point we have the data we sought. We need not */
/* perform another kernel pool look-up unless there's */
/* a kernel pool update or change in the SCLK ID. */
nodata = FALSE_;
/* Buffer the number of partitions and the partition start */
/* and stop times. */
lstprt = nprtsa;
/* The partition start and stop times must be whole numbers. */
i__1 = lstprt;
for (i__ = 1; i__ <= i__1; ++i__) {
prtsa[(i__2 = i__ - 1) < 9999 && 0 <= i__2 ? i__2 : s_rnge("prtsa"
, i__2, "scpart_", (ftnlen)360)] = d_nint(&prtsa[(i__3 =
i__ - 1) < 9999 && 0 <= i__3 ? i__3 : s_rnge("prtsa",
i__3, "scpart_", (ftnlen)360)]);
prtso[(i__2 = i__ - 1) < 9999 && 0 <= i__2 ? i__2 : s_rnge("prtso"
, i__2, "scpart_", (ftnlen)361)] = d_nint(&prtso[(i__3 =
i__ - 1) < 9999 && 0 <= i__3 ? i__3 : s_rnge("prtso",
i__3, "scpart_", (ftnlen)361)]);
}
}
/* Copy the values in local buffers to the output arguments. */
*nparts = lstprt;
i__1 = *nparts;
for (i__ = 1; i__ <= i__1; ++i__) {
pstart[i__ - 1] = prtsa[(i__2 = i__ - 1) < 9999 && 0 <= i__2 ? i__2 :
s_rnge("prtsa", i__2, "scpart_", (ftnlen)372)];
pstop[i__ - 1] = prtso[(i__2 = i__ - 1) < 9999 && 0 <= i__2 ? i__2 :
s_rnge("prtso", i__2, "scpart_", (ftnlen)373)];
}
chkout_("SCPART", (ftnlen)6);
return 0;
} /* scpart_ */
/* $Procedure EDTCMD ( Edit a file using a specified text editor ) */
/* Subroutine */ int edtcmd_(char *cmd, char *file, ftnlen cmd_len, ftnlen
file_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern integer rtrim_(char *, ftnlen);
char loccmd[255];
extern /* Subroutine */ int chkout_(char *, ftnlen), suffix_(char *,
integer *, char *, ftnlen, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int exesys_(char *, ftnlen);
/* $ Abstract */
/* Edit a file using a specified editor. */
/* $ 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 */
/* SYSTEM */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* CMD I Command string used to invoke editor. */
/* FILE I Name of file to edit. */
/* $ Detailed_Input */
/* CMD is a character string containing the command */
/* used to invoke a text editor available on the */
/* system under which the calling program is running. */
/* This routine will invoke the specified editor */
/* using FILE as the target file to edit. The name */
/* of the file to be edited is not included in the */
/* command; this name is input as a separate argument. */
/* Case sensitivity of CMD varies with the system on */
/* which the calling program is run. */
/* Trailing white space in CMD is not significant. */
/* FILE is the name of a file that is to be edited. FILE */
/* need not exist at the time this routine is called. */
/* Case sensitivity of FILE varies with the system on */
/* which the calling program is run. */
/* Trailing white space in FILE is not significant. */
/* $ Detailed_Output */
/* None. See $Particulars for further information on the action of */
/* this routine. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the specified edit command fails, the error will be */
/* diagnosed by routines called by this routine. */
/* 2) If the editing session started by this routine is terminated */
/* abnormally, the effect on the operation of the calling program */
/* is unspecified. */
/* $ Files */
/* See $Particulars. */
/* $ Particulars */
/* This routine should be used with caution; calls to this routine */
/* may have unintended side effects on the operation of the calling */
/* program. A solid understanding of the global operation of the */
/* calling program is a prerequisite for programmers wishing to */
/* use this routine. */
/* The input argument FILE should unambiguously designate a file */
/* that can be edited by the specified editor on the system under */
/* which the calling program is being run. The calling program */
/* should have read or write privileges consistent with the intended */
/* mode of access to FILE. */
/* This routine may fail to recover in a predictable fashion from */
/* abnormal termination of an editing session. */
/* $ Examples */
/* 1) On a VAX/VMS system, the EDT editor could be invoked by */
/* the calls */
/* CALL EDTCMD ( 'EDIT/EDT', FILE ) */
/* or */
/* CALL EDTCMD ( 'EDIT/EDT/COMMAND = <command file>', FILE ) */
/* 2) On a Unix system, the emacs editor could be invoked */
/* (normally) by the calls */
/* CALL EDTCMD ( 'emacs', FILE ) */
/* or */
/* CALL EDTCMD ( '/usr/bin/emacs', FILE ) */
/* $ Restrictions */
/* 1) The means by which this routine invokes an editor are system- */
/* dependent; invoking the editor may have side effects that */
/* affect the operation of the calling program. For example, */
/* on Unix systems, this routine may start a new shell in which */
/* to run the editor; starting a new shell may interfere with */
/* any sequential file I/O in progress at the time the shell is */
/* started. */
/* See the code for implementation details. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - Beta Version 2.22.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - Beta Version 2.21.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - Beta Version 2.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - Beta Version 2.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - Beta Version 2.18.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - Beta Version 2.17.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - Beta Version 2.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - Beta Version 2.15.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - Beta Version 2.14.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - Beta Version 2.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - Beta Version 2.12.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - Beta Version 2.11.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - Beta Version 2.10.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - Beta Version 2.9.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - Beta Version 2.8.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - Beta Version 2.7.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - Beta Version 2.6.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - Beta Version 2.5.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - Beta Version 2.4.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - Beta Version 2.3.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - Beta Version 2.2.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - Beta Version 2.2.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - Beta Version 2.2.3, 20-SEP-1999 (NJB) */
/* CSPICE and PC-LINUX environment lines were added. Some */
/* typos were corrected. */
/* - Beta Version 2.2.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - Beta Version 2.2.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - Beta Version 2.2.0, 12-AUG-1996 (WLT) */
/* Added DEC-OSF1 to the list of supported environments */
/* - Beta Version 2.1.0, 10-JAN-1996 (WLT) */
/* Added PC-LAHEY to the list of supported environments. */
/* - Beta Version 2.0.0, 16-JUN-1995 (WLT)(HAN) */
/* Created master file from collection of machine dependent */
/* routines. Copyright notice added. */
/* - Beta Version 1.0.0, 16-AUG-1994 (NJB) */
/* -& */
/* $ Index_Entries */
/* invoke a text editor within a program */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("EDTCMD", (ftnlen)6);
}
/* VAX: */
/* Computer: VAX 11/780 */
/* Operating System: VAX VMS 5.3 */
/* Fortran: VAX FORTRAN 5.5 */
/* PC-MS: */
/* Computer: PC */
/* Operating System: Microsoft DOS 5.00 */
/* Fortran: Microsoft Powerstation Fortran V1.0 */
/* Build the edit command to be passed to the system. */
s_copy(loccmd, cmd, (ftnlen)255, cmd_len);
suffix_(file, &c__1, loccmd, file_len, (ftnlen)255);
/* Invoke the editor. */
exesys_(loccmd, rtrim_(loccmd, (ftnlen)255));
chkout_("EDTCMD", (ftnlen)6);
return 0;
} /* edtcmd_ */
/* $Procedure WRLINE ( Write Output Line to a Device ) */
/* Subroutine */ int wrline_0_(int n__, char *device, char *line, ftnlen
device_len, ftnlen line_len)
{
/* System generated locals */
integer i__1;
cilist ci__1;
olist o__1;
cllist cl__1;
inlist ioin__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
integer *, char *, ftnlen), e_wsfe(void), f_inqu(inlist *),
s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void), f_open(olist *);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer f_clos(cllist *);
/* Local variables */
integer unit;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
extern integer ltrim_(char *, ftnlen);
char error[240];
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
logical opened;
extern /* Subroutine */ int fndlun_(integer *);
char tmpnam[128];
integer iostat;
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen);
logical exists;
char errstr[11];
extern /* Subroutine */ int intstr_(integer *, char *, ftnlen);
/* Fortran I/O blocks */
static cilist io___6 = { 0, 6, 0, 0, 0 };
static cilist io___7 = { 0, 6, 0, 0, 0 };
static cilist io___8 = { 0, 6, 0, 0, 0 };
static cilist io___9 = { 0, 6, 0, 0, 0 };
static cilist io___10 = { 0, 6, 0, 0, 0 };
static cilist io___11 = { 0, 6, 0, 0, 0 };
static cilist io___12 = { 0, 6, 0, 0, 0 };
static cilist io___15 = { 0, 6, 0, 0, 0 };
static cilist io___16 = { 0, 6, 0, 0, 0 };
static cilist io___17 = { 0, 6, 0, 0, 0 };
static cilist io___18 = { 0, 6, 0, 0, 0 };
/* $ Abstract */
/* Write a character string to an output device. */
/* $ 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 */
/* TEXT */
/* FILES */
/* ERROR */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* DEVICE I A string specifying an output device. */
/* LINE I A line of text to be output. */
/* FILEN P Maximum length of a file name. */
/* $ Detailed_Input */
/* LINE is a line of text to be written to the output */
/* device specified by DEVICE. */
/* DEVICE is the output device to which the line of text */
/* will be written. */
/* Possible values and meanings of DEVICE are: */
/* a device name This may be the name of a */
/* file, or any other name that */
/* is valid in a FORTRAN OPEN */
/* statement. For example, on a */
/* VAX, a logical name may be */
/* used. */
/* The device name must not */
/* be any of the reserved strings */
/* below. */
/* 'SCREEN' The output will go to the */
/* terminal screen. */
/* 'NULL' The data will not be output. */
/* 'SCREEN' and 'NULL' can be written in mixed */
/* case. For example, the following call will work: */
/* CALL WRLINE ( 'screEn', LINE ) */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* FILEN is the maximum length of a file name. */
/* $ Exceptions */
/* This routine is a special case as far as error handling */
/* is concerned because it is called to output error */
/* messages resulting from errors detected by other routines. */
/* In such a case, calling SIGERR would constitute recursion. */
/* Therefore, this routine prints error messages rather */
/* than signalling errors via SIGERR and setting the long */
/* error message via SETMSG. */
/* The following exceptional cases are treated as errors: */
/* 1) SPICE(NOFREELOGICALUNIT) -- No logical unit number */
/* is available to refer to the device. */
/* 2) SPICE(FILEOPENFAILED) -- General file open error. */
/* 3) SPICE(FILEWRITEFAILED) -- General file write error. */
/* 4) SPICE(INQUIREFAILED) -- INQUIRE statement failed. */
/* 5) Leading blanks in (non-blank) file names are not */
/* significant. The file names */
/* 'MYFILE.DAT' */
/* ' MYFILE.DAT' */
/* are considered to name the same file. */
/* 6) If different names that indicate the same file are supplied */
/* to this routine on different calls, all output associated */
/* with these calls WILL be written to the file. For example, */
/* on a system where logical filenames are supported, if */
/* ALIAS is a logical name pointing to MYFILE, then the calls */
/* CALL WRLINE ( 'MYFILE', 'This is the first line' ) */
/* CALL WRLINE ( 'ALIAS', 'This is the second line' ) */
/* will place the lines of text */
/* 'This is the first line' */
/* 'This is the second line' */
/* in MYFILE. See $Restrictions for more information on use */
/* of logical names on VAX systems. */
/* $ Files */
/* 1) If DEVICE specifies a device other than 'SCREEN' or 'NULL', */
/* that device is opened (if it's not already open) as a NEW, */
/* SEQUENTIAL, FORMATTED file. The logical unit used is */
/* determined at run time. */
/* $ Particulars */
/* If the output device is a file that is not open, the file will */
/* be opened (if possible) as a NEW, sequential, formatted file, */
/* and the line of text will be written to the file. If the file */
/* is already opened as a sequential, formatted file, the line of */
/* text will be written to the file. */
/* Use the entry point CLLINE to close files opened by WRLINE. */
/* $ Examples */
/* 1) Write a message to the screen: */
/* CALL WRLINE ( 'SCREEN', 'Here''s a message.' ) */
/* The text */
/* Here's a message. */
/* will be written to the screen. */
/* 2) Write out all of the elements of a character string array */
/* to a file. */
/* CHARACTER*(80) STRING ( ASIZE ) */
/* . */
/* . */
/* . */
/* DO I = 1, ASIZE */
/* CALL WRLINE ( FILE, STRING(I) ) */
/* END DO */
/* 3) Set DEVICE to NULL to suppress output: */
/* C */
/* C Ask the user whether verbose program output is */
/* C desired. Set the output device accordingly. */
/* C */
/* WRITE (*,*) 'Do you want to see test results ' // */
/* . 'on the screen?' */
/* READ (*,FMT='(A)') VERBOS */
/* CALL LJUST ( VERBOS, VERBOS ) */
/* CALL UCASE ( VERBOS, VERBOS ) */
/* IF ( VERBOS(1:1) .EQ. 'Y' ) THEN */
/* DEVICE = 'SCREEN' */
/* ELSE */
/* DEVICE = 'NULL' */
/* ENDIF */
/* . */
/* . */
/* . */
/* C */
/* C Output test results. */
/* C */
/* CALL WRLINE ( DEVICE, STRING ) */
/* . */
/* . */
/* . */
/* $ Restrictions */
/* 1) File names must not exceed FILEN characters. */
/* 2) On VAX systems, caution should be exercised when using */
/* multiple logical names to point to the same file. Logical */
/* name translation supporting execution of the Fortran */
/* INQUIRE statement does not appear to work reliably in all */
/* cases, which may lead this routine to believe that different */
/* logical names indicate different files. The specific problem */
/* that has been observed is that logical names that include */
/* disk specifications are not always recognized as pointing */
/* to the file they actually name. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* $ Version */
/* - SPICELIB Version 4.25.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 4.24.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 4.23.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 4.22.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.21.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 4.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 4.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 4.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 4.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 4.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 4.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 4.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 4.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 4.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 4.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 4.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 4.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 4.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 4.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 4.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 4.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 4.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 4.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 4.0.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 4.0.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 4.0.3, 16-SEP-1999 (NJB) */
/* CSPICE environments were added. Some typos were corrected. */
/* - SPICELIB Version 4.0.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 4.0.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 4.0.0, 07-APR-1998 (NJB) */
/* References to the PC-LINUX environment were added. The */
/* write format for the case where the output device is the */
/* screen has been made system-dependent; list-directed output */
/* format is now used for systems that require a leading carriage */
/* control character; other systems use character format. The */
/* write format for the case where the output device is a file */
/* has been changed from list-directed to character. */
/* - SPICELIB Version 3.0.0, 11-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* and the appropriate OPEN statement for the Silicon */
/* Graphics, DEC Alpha-OSF/1, and NeXT platforms. The previous */
/* value of 256 for Unix platforms was changed to 255. */
/* - SPICELIB Version 2.1.0, 13-OCT-1992 (HAN) */
/* Module was updated to include the value of FILEN for the */
/* Hewlett Packard UX 9000/750 environment. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - 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, 26-MAR-1991 (NJB) */
/* This routine now can write to files that have been opened */
/* by other routines. */
/* The limit imposed by this routine on the number of files it */
/* can open has been removed. */
/* The output file is now opened as a normal text file on */
/* VAX systems. */
/* Improper treatment of the case where DEVICE is blank was */
/* remedied. */
/* Unneeded variable declarations and references were removed. */
/* Initialization of SAVED variables was added. */
/* All occurrences of "PRINT *" have been replaced by */
/* "WRITE (*,*)". */
/* Calls to UCASE and LJUST replace in-line code that performed */
/* these operations. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (NJB) */
/* -& */
/* $ Index_Entries */
/* write output line to a device */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 4.0.0, 07-APR-1998 (NJB) */
/* References to the PC-LINUX environment were added. */
/* The write format for the case where the output device is the */
/* screen has been made system-dependent; list-directed output */
/* format is now used for systems that require a leading carriage */
/* control character; other systems use character format. The */
/* write format for the case where the output device is a file */
/* has been changed from list-directed to character. */
/* - SPICELIB Version 3.0.0, 11-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* and the appropriate OPEN statement for the Silicon */
/* Graphics, DEC Alpha-OSF/1, and NeXT platforms. The previous */
/* value of 256 for Unix platforms was changed to 255. */
/* - SPICELIB Version 2.1.0, 13-OCT-1992 (HAN) */
/* Module was updated to include the value of FILEN for the */
/* Hewlett Packard UX 9000/750 environment. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 2.0.0, 25-MAR-1991 (NJB) */
/* 1) This routine now can write to files that have been opened */
/* by other routines. WRLINE uses an INQUIRE statement to */
/* determine whether the file indicated by DEVICE is open, */
/* and if it is, WRLINE does not attempt to open it. This */
/* allows use of WRLINE to feed error output into a log file */
/* opened by another routine. */
/* The header has been updated accordingly. */
/* This fix also fixes a bug wherein this routine would treat */
/* different character strings naming the same file as though */
/* they indicated different files. */
/* 2) The limit imposed by this routine on the number of files it */
/* can open has been removed. The file database used in */
/* previous versions of this routine is no longer used. */
/* 3) On VAX systems, this routine now opens the output file */
/* (when required to do so) as a normal text file. */
/* 4) Improper treatment of the case where DEVICE is blank was */
/* remedied. Any value of DEVICE that is not equal to */
/* 'SCREEN' or 'NULL' after being left-justified and */
/* converted to upper case is considered to be a file name. */
/* 5) Unneeded variable declarations and references were removed. */
/* The arrays called STATUS and FILES are not needed. */
/* 6) All instances if "PRINT *" have been replaced by */
/* "WRITE (*,*)" because Language Systems Fortran on the */
/* Macintosh interprets "PRINT *" in a non-standard manner. */
/* 7) Use of the EXIST specifier was added to the INQUIRE */
/* statement used to determine whether the file named by */
/* DEVICE is open. This is a work-around for a rather */
/* peculiar behavior of at least one version of Sun Fortran: */
/* files that don't exist may be considered to be open, as */
/* indicated by the OPENED specifier of the INQUIRE statement. */
/* 8) One other thing: now that LJUST and UCASE are error-free, */
/* WRLINE uses them; this simplifies the code. */
/* - Beta Version 1.2.0, 27-FEB-1989 (NJB) */
/* Call to GETLUN replaced by call to FNDLUN, which is error-free. */
/* Call to IOERR replaced with in-line code to construct long */
/* error message indicating file open failure. Arrangement of */
/* declarations changed. Keywords added. FILEN declaration */
/* moved to "declarations" section. Parameters section added. */
/* - Beta Version 1.1.0, 06-OCT-1988 (NJB) */
/* Upper bound of written substring changed to prevent use of */
/* invalid substring bound. Specifically, LASTNB ( LINE ) was */
/* replaced by MAX ( 1, LASTNB (LINE) ). This upper bound */
/* now used in the PRINT statement as well. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Executable Code: */
switch(n__) {
case 1: goto L_clline;
}
ljust_(device, tmpnam, device_len, (ftnlen)128);
ucase_(tmpnam, tmpnam, (ftnlen)128, (ftnlen)128);
/* TMPNAM is now left justified and is in upper case. */
if (s_cmp(tmpnam, "NULL", (ftnlen)128, (ftnlen)4) == 0) {
return 0;
} else if (s_cmp(tmpnam, "SCREEN", (ftnlen)128, (ftnlen)6) == 0) {
ci__1.cierr = 1;
ci__1.ciunit = 6;
ci__1.cifmt = "(A)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
iostat = do_fio(&c__1, line, rtrim_(line, line_len));
if (iostat != 0) {
goto L100001;
}
iostat = e_wsfe();
L100001:
return 0;
}
/* Find out whether we'll need to open the file. */
/* We use the EXIST inquiry specifier because files that don't exist */
/* may be (possibly due to a Sun compiler bug) deemed to be OPEN by */
/* Sun Fortran. */
i__1 = ltrim_(device, device_len) - 1;
ioin__1.inerr = 1;
ioin__1.infilen = device_len - i__1;
ioin__1.infile = device + i__1;
ioin__1.inex = &exists;
ioin__1.inopen = &opened;
ioin__1.innum = &unit;
ioin__1.innamed = 0;
ioin__1.inname = 0;
ioin__1.inacc = 0;
ioin__1.inseq = 0;
ioin__1.indir = 0;
ioin__1.infmt = 0;
ioin__1.inform = 0;
ioin__1.inunf = 0;
ioin__1.inrecl = 0;
ioin__1.innrec = 0;
ioin__1.inblank = 0;
iostat = f_inqu(&ioin__1);
if (iostat != 0) {
/* This is weird. How can an INQUIRE statement fail, */
/* if the syntax is correct? But just in case... */
s_wsle(&io___6);
do_lio(&c__9, &c__1, "SPICE(INQUIREFAILED)", (ftnlen)20);
e_wsle();
s_wsle(&io___7);
do_lio(&c__9, &c__1, "WRLINE: File = ", (ftnlen)15);
do_lio(&c__9, &c__1, device, device_len);
do_lio(&c__9, &c__1, "IOSTAT = ", (ftnlen)9);
do_lio(&c__3, &c__1, (char *)&iostat, (ftnlen)sizeof(integer));
e_wsle();
return 0;
}
if (! (opened && exists)) {
/* We will need a free logical unit. There is always the chance */
/* that no units are available. */
fndlun_(&unit);
if (unit < 1) {
s_wsle(&io___8);
do_lio(&c__9, &c__1, "SPICE(NOFREELOGICALUNIT)", (ftnlen)24);
e_wsle();
s_wsle(&io___9);
do_lio(&c__9, &c__1, " ", (ftnlen)1);
e_wsle();
s_wsle(&io___10);
do_lio(&c__9, &c__1, "WRLINE: Maximum number of logical units th"
"at can be allocated by SPICELIB has already been reached",
(ftnlen)98);
e_wsle();
return 0;
}
/* Okay, we have a unit. Open the file, and hope nothing */
/* goes awry. (On the VAX, the qualifier */
/* CARRIAGECONTROL = 'LIST' */
/* may be inserted into the OPEN statement.) */
i__1 = ltrim_(device, device_len) - 1;
o__1.oerr = 1;
o__1.ounit = unit;
o__1.ofnmlen = device_len - i__1;
o__1.ofnm = device + i__1;
o__1.orl = 0;
o__1.osta = "NEW";
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
iostat = f_open(&o__1);
if (iostat != 0) {
s_wsle(&io___11);
do_lio(&c__9, &c__1, "SPICE(FILEOPENFAILED)", (ftnlen)21);
e_wsle();
s_wsle(&io___12);
do_lio(&c__9, &c__1, " ", (ftnlen)1);
e_wsle();
s_copy(error, "WRLINE: An error occurred while attempting to open"
, (ftnlen)240, (ftnlen)50);
suffix_(device, &c__1, error, device_len, (ftnlen)240);
suffix_(".", &c__0, error, (ftnlen)1, (ftnlen)240);
suffix_("The value of IOSTAT returned was", &c__2, error, (ftnlen)
32, (ftnlen)240);
suffix_(":", &c__0, error, (ftnlen)1, (ftnlen)240);
intstr_(&iostat, errstr, (ftnlen)11);
suffix_(errstr, &c__1, error, (ftnlen)11, (ftnlen)240);
suffix_(".", &c__0, error, (ftnlen)1, (ftnlen)240);
s_wsle(&io___15);
do_lio(&c__9, &c__1, error, (ftnlen)240);
e_wsle();
return 0;
}
/* Whew! We're ready to write to this file. */
}
/* At this point, either we opened the file, or it was already */
/* opened by somebody else. */
/* This is the easy part. Write the next line to the file. */
ci__1.cierr = 1;
ci__1.ciunit = unit;
ci__1.cifmt = "(A)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100002;
}
iostat = do_fio(&c__1, line, rtrim_(line, line_len));
if (iostat != 0) {
goto L100002;
}
iostat = e_wsfe();
L100002:
/* Well, what happened? Any non-zero value for IOSTAT indicates */
/* an error. */
if (iostat != 0) {
s_copy(error, "WRLINE: An error occurred while attempting to WRITE t"
"o ", (ftnlen)240, (ftnlen)55);
suffix_(device, &c__1, error, device_len, (ftnlen)240);
suffix_(".", &c__0, error, (ftnlen)1, (ftnlen)240);
suffix_("The value of IOSTAT returned was", &c__2, error, (ftnlen)32,
(ftnlen)240);
suffix_(":", &c__0, error, (ftnlen)1, (ftnlen)240);
intstr_(&iostat, errstr, (ftnlen)11);
suffix_(errstr, &c__1, error, (ftnlen)11, (ftnlen)240);
suffix_(".", &c__0, error, (ftnlen)1, (ftnlen)240);
s_wsle(&io___16);
do_lio(&c__9, &c__1, error, (ftnlen)240);
e_wsle();
return 0;
}
return 0;
/* $Procedure CLLINE ( Close a device ) */
L_clline:
/* $ Abstract */
/* Close a device. */
/* $ 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 */
/* TEXT, FILES, ERROR */
/* $ Declarations */
/* CHARACTER*(*) DEVICE */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* DEVICE I Device to be closed. */
/* $ Detailed_Input */
/* DEVICE is the name of a device which is currently */
/* opened for reading or writing. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* This routine is called by SPICELIB error handling routines, so */
/* it cannot use the normal SPICELIB error signalling mechanism. */
/* Instead, it writes error messages to the screen if necessary. */
/* 1) If the device indicated by DEVICE was not opened by WRLINE, */
/* this routine closes it anyway. */
/* 2) If the INQUIRE performed by this routine fails, an error */
/* diagnosis is printed to the screen. */
/* $ Files */
/* This routin */
/* $ Particulars */
/* CLLINE closes a device that is currently open. */
/* $ Examples */
/* 1) Write two lines to the file, SPUD.DAT (VAX file name */
/* syntax), and then close the file. */
/* CALL WRLINE ( 'SPUD.DAT', ' This is line 1 ' ) */
/* CALL WRLINE ( 'SPUD.DAT', ' This is line 2 ' ) */
/* CALL CLLINE ( 'SPUD.DAT' ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 4.0.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 4.0.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 4.0.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 4.0.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - 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, 26-MAR-1991 (NJB) */
/* All occurrences of "PRINT *" have been replaced by */
/* "WRITE (*,*)". */
/* Also, this routine now closes the device named by DEVICE */
/* whether or not the device was opened by WRLINE. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (NJB) */
/* -& */
/* $ Index_Entries */
/* None. */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 26-MAR-1991 (NJB) */
/* All instances if "PRINT *" have been replaced by "WRITE (*,*)" */
/* because Language Systems Fortran on the Macintosh interprets */
/* "PRINT *" in a non-standard manner. */
/* This routine no longer has to maintain the file database, since */
/* WRLINE does not use it any more. */
/* Also, this routine now closes the device named by DEVICE, */
/* whether or not the device was opened by WRLINE. */
/* - Beta Version 1.0.1, 08-NOV-1988 (NJB) */
/* Keywords added. */
/* -& */
/* Find the unit connected to DEVICE. */
i__1 = ltrim_(device, device_len) - 1;
ioin__1.inerr = 1;
ioin__1.infilen = device_len - i__1;
ioin__1.infile = device + i__1;
ioin__1.inex = 0;
ioin__1.inopen = 0;
ioin__1.innum = &unit;
ioin__1.innamed = 0;
ioin__1.inname = 0;
ioin__1.inacc = 0;
ioin__1.inseq = 0;
ioin__1.indir = 0;
ioin__1.infmt = 0;
ioin__1.inform = 0;
ioin__1.inunf = 0;
ioin__1.inrecl = 0;
ioin__1.innrec = 0;
ioin__1.inblank = 0;
iostat = f_inqu(&ioin__1);
if (iostat != 0) {
/* This is weird. How can an INQUIRE statement fail, */
/* if the syntax is correct? But just in case... */
s_wsle(&io___17);
do_lio(&c__9, &c__1, "SPICE(INQUIREFAILED)", (ftnlen)20);
e_wsle();
s_wsle(&io___18);
do_lio(&c__9, &c__1, "CLLINE: File = ", (ftnlen)16);
do_lio(&c__9, &c__1, device, device_len);
do_lio(&c__9, &c__1, "IOSTAT = ", (ftnlen)9);
do_lio(&c__3, &c__1, (char *)&iostat, (ftnlen)sizeof(integer));
e_wsle();
return 0;
}
cl__1.cerr = 0;
cl__1.cunit = unit;
cl__1.csta = 0;
f_clos(&cl__1);
return 0;
} /* wrline_ */
/* $Procedure BODFND ( Find values from the kernel pool ) */
logical bodfnd_(integer *body, char *item, ftnlen item_len)
{
/* System generated locals */
logical ret_val;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char code[16];
integer n;
extern /* Subroutine */ int chkin_(char *, ftnlen);
logical found;
char dtype[1], varnam[32];
extern /* Subroutine */ int chkout_(char *, ftnlen), dtpool_(char *,
logical *, integer *, char *, ftnlen, ftnlen), suffix_(char *,
integer *, char *, ftnlen, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int intstr_(integer *, char *, ftnlen);
/* $ Abstract */
/* Determine whether values exist for some item for any body */
/* 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 */
/* KERNEL */
/* $ Keywords */
/* CONSTANTS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* BODY I ID code of body. */
/* ITEM I Item to find ('RADII', 'NUT_AMP_RA', etc.). */
/* $ Detailed_Input */
/* BODY is the ID code of the body for which the item is */
/* requested. Bodies are numbered according to the */
/* standard NAIF numbering scheme. */
/* ITEM is the item to be returned. Together, the body and */
/* item name combine to form a variable name, e.g., */
/* 'BODY599_RADII' */
/* 'BODY4_POLE_RA' */
/* $ Detailed_Output */
/* The result is TRUE if the item is in the kernel pool, */
/* and is FALSE if it is not. */
/* $ Parameters */
/* None. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Particulars */
/* BODVCD, which returns values from the kernel pool, causes an */
/* error to be signalled whenever the specified item is not found. */
/* In many cases, this is appropriate. However, sometimes the */
/* program may attempt to recover, by providing default values, */
/* prompting for replacements, and so on. */
/* $ Examples */
/* In the following example, default values are substituted for */
/* bodies for which axes are not found. */
/* IF ( BODFND ( TARGET, 'RADII' ) ) THEN */
/* CALL BODVCD ( TARGET, 'RADII', 3, N, RADII ) */
/* ELSE */
/* CALL VPACK ( 100.D0, 100.D0, 100.D0, RADII ) */
/* END IF */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* 1) Refer to the SPK required reading file for a complete list of */
/* the NAIF integer ID codes for bodies. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.2.1, 24-OCT-2005 (NJB) */
/* Header update: calls to BODVAR in example code were replaced */
/* with calls to BODVCD. The string 'AXES' and variable AXES */
/* were replaced with the string 'RADII' and variable 'RADII' */
/* throughout the header. */
/* - SPICELIB Version 1.2.0, 15-MAR-2002 (NJB) */
/* Bug fix: routine was updated to work with string-valued */
/* kernel variables. */
/* - SPICELIB Version 1.1.0, 17-MAY-1994 (HAN) */
/* If the value of the function RETURN is TRUE upon execution of */
/* this module, this function is assigned a default value of */
/* either 0, 0.0D0, .FALSE., or blank depending on the type of */
/* the function. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* find constants for a body in the kernel pool */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
ret_val = FALSE_;
return ret_val;
} else {
chkin_("BODFND", (ftnlen)6);
}
/* Construct the variable name from BODY and ITEM. */
s_copy(varnam, "BODY", (ftnlen)32, (ftnlen)4);
intstr_(body, code, (ftnlen)16);
suffix_(code, &c__0, varnam, (ftnlen)16, (ftnlen)32);
suffix_("_", &c__0, varnam, (ftnlen)1, (ftnlen)32);
suffix_(item, &c__0, varnam, item_len, (ftnlen)32);
/* Search the kernel pool for the item. */
dtpool_(varnam, &found, &n, dtype, (ftnlen)32, (ftnlen)1);
/* Was anything there? */
ret_val = found;
chkout_("BODFND", (ftnlen)6);
return ret_val;
} /* bodfnd_ */
/* $Procedure M2DIAG ( META/2 diagnostics formatting utility. ) */
/* Subroutine */ int m2diag_0_(int n__, char *filler, char *begmrk, char *
endmrk, char *string, integer *sb, integer *se, char *messge, ftnlen
filler_len, ftnlen begmrk_len, ftnlen endmrk_len, ftnlen string_len,
ftnlen messge_len)
{
/* Initialized data */
static char fill[80] = " "
" ";
static integer pad = 1;
static char bmark[16] = ".....< ";
static char emark[16] = ">..... ";
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer bpad, b, e;
extern /* Subroutine */ int zzinssub_(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
static integer place;
extern integer lastnb_(char *, ftnlen);
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen);
/* $ Abstract */
/* This routine contains the two entry points M2SERR and M2MARK that */
/* are used by META/2 template matching routines. It serves as */
/* a diagnostic formatting utility. */
/* $ 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 */
/* See the entry point headers for description of each of the */
/* input/output arguements. */
/* $ Detailed_Input */
/* See individual entry points. */
/* $ Detailed_Output */
/* See individual entry points. */
/* $ Exceptions */
/* See individual entry points. */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Particulars */
/* This routine is a dummy that serves as an home for the entry */
/* points M2SERR and M2MARK that are utility formatting routines */
/* used by the template matching routines of META/2. */
/* $ Examples */
/* To set the markers and filler used to offset the marked portion */
/* of a command that fails syntax checking, call the routine */
/* M2SERR */
/* To append a marked command to a diagnostic message call M2MARK. */
/* $ Restrictions */
/* See the entry points for appropriate restrictions. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - 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 */
/* Beta Version 1.0.0, 1-JUN-1988 (WLT) (IMU) */
/* -& */
/* Entry points */
/* M2MARK */
/* M2SERR */
/* SPICELIB functions */
/* Local variables */
switch(n__) {
case 1: goto L_m2serr;
case 2: goto L_m2mark;
}
return 0;
/* $Procedure M2SERR ( Set the META/2 error markers ) */
L_m2serr:
/* $ Abstract */
/* Set the error markers and padding between the end of the error */
/* message and the beginning of the marked copy of the input string */
/* in diagnostic messages. */
/* $ 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 */
/* The META/2 book. */
/* $ Keywords */
/* UTILITY */
/* $ Declarations */
/* CHARACTER*(*) FILLER */
/* CHARACTER*(*) BEGMRK */
/* CHARACTER*(*) ENDMRK */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* FILLER I string to leave between message and marked string */
/* BEGMRK I String to put at beginning of marked part of string */
/* ENDMRK I String to put at end of marked part of string */
/* $ Detailed_Input */
/* FILLER substring to leave between message and marked string */
/* BEGMRK String to put at beginning of marked part of string */
/* ENDMRK String to put at end of marked part of string */
/* $ Detailed_Output */
/* None. */
/* $ Error_Handling */
/* No errors are detected by this entry point. */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Particulars */
/* This entry point is used to set the space padding between the */
/* diagnostic message produced by a META/2 routine and to */
/* select what strings that will be used to mark the location */
/* of a problem that occured in in the input string when */
/* attempting to match a template. */
/* Since diagnostic messages can be quite long, it is important */
/* to be able to set a space between the end of the diagnostic */
/* and the start of the marked string. If the messages are to */
/* be output through use of some kind of string breaking routine */
/* such as the NAIF routine CUTSTR. By selecting the padding */
/* sufficiently large you can insure that the message will break */
/* before printing the marked string. */
/* $ Examples */
/* When printing error messages it is handy to have the marked */
/* portion of the string appear highlighted. For a machine that */
/* interprets VT100 escape sequences the following markers */
/* might prove very effective. */
/* BEGMRK = '<ESC>[7m' ! Turn on reverse video. */
/* ENDMRK = '<ESC>[0m' ! Turn off reverse video. */
/* SPACE = ' ' */
/* CALL M2SERR ( SPACE, BEGMRK, ENDMRK ) */
/* When an diagnostic message comes back, the following will */
/* code will ensure that the message is broken nicely and that */
/* the marked string begins on a new line. */
/* BEG = 1 */
/* MORE = .TRUE. */
/* DO WHILE ( MORE ) */
/* CALL CUTSTR ( CAUSE, 80, ' ,', BEG, END, MORE ) */
/* WRITE (6,*) CAUSE(BEG:END) */
/* BEG = END + 1 */
/* END DO */
/* Non-printing beginning and ending markers can also be useful */
/* in the event that you want to do your own processing of the */
/* diagnostic message for display. */
/* $ Restrictions */
/* The marking strings will be truncated to the first 16 characters. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - 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, 7-APR-1988 (WLT) (IMU) */
/* -& */
/* Computing MIN */
i__1 = 80, i__2 = i_len(filler, filler_len);
pad = min(i__1,i__2);
s_copy(bmark, begmrk, (ftnlen)16, begmrk_len);
s_copy(emark, endmrk, (ftnlen)16, endmrk_len);
s_copy(fill, filler, (ftnlen)80, filler_len);
return 0;
/* $Procedure M2MARK (META/2 Error Marking Utility) */
L_m2mark:
/* $ Abstract */
/* This is a utility routine used for constructing diagnostic */
/* message for META2. It is not intended for genereal consumption. */
/* $ 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 */
/* CHARACTER*(*) STRING */
/* INTEGER SB */
/* INTEGER SE */
/* CHARACTER*(*) MESSGE */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* STRING I String to concatenate to end of a partial message */
/* SB I Position of first string character to mark. */
/* SE I Position of last string character to mark. */
/* MESSGE I/O String to append marked string to and return. */
/* $ Detailed_Input */
/* STRING is a string that contains some sequence of characters */
/* that should be marked and then appended to a partially */
/* constructed message string. */
/* SB is the index of the first character in STRING that */
/* should be marked for output with some character string. */
/* SE is the index of the last character in STRING that */
/* should be marked for output with some character string. */
/* MESSGE Is a partially constructed string to which the marked */
/* string should be appended. */
/* $ Detailed_Output */
/* MESSGE is the original string concatenated with the marked */
/* string. */
/* $ Exceptions. */
/* If MESSGE is not long enough to contain everything that should */
/* go into it it will be truncated. */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Particulars */
/* This is a utility routine for use in constructing messages */
/* of the form: */
/* "The input string contained an unrecognized word SPIM. || */
/* >>SPIM<< THE WHEEL." */
/* The inputs to the routine are */
/* The first part of the message */
/* The string that was recognized to have some problem */
/* The index of the first character of the problem. */
/* The index of the last character of the problem. */
/* The actual effect of this routine is to put the string */
/* MESSGE(1: LASTNB(MESSGE) + 1 ) // STRING(1 :SB-1 ) */
/* // BMARK (1 :LASTNB(BMARK)) */
/* // STRING(SB :SE ) */
/* // EMARK (1 :LASTNB(EMARK)) */
/* // STRING(SB+1: ) */
/* Into the string MESSGE. */
/* In fact this is what you would probably do if standard Fortran */
/* allowed you to perform these operations with passed length */
/* character strings. Since you cant't this routine does it for */
/* you cleaning up the appearance of your code and handling all of */
/* the pathologies for you. */
/* $ Examples */
/* Inputs */
/* MESSGE = 'I believe the word "FILW" should have been */
/* "FILE" in the input string. || " */
/* STRING = 'SEND EPHEMERIS TO FILW OUTPUT.DAT' */
/* 123456789012345678901234567890123 */
/* SB = 19 */
/* SE = 22 */
/* BMARK = '>>>' */
/* EMARK = '<<<' */
/* Output */
/* MESSGE = 'I believe the word "FILW" should have been */
/* "FILE" in the input string. || SEND EPHEMERIS */
/* TO >>>FILW<<< OUTPUT.DAT' */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* $ Version */
/* - 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, 17-APR-1988 (WLT) */
/* -& */
/* The end of MESSGE looks like */
/* . . . xxx xxxxxx */
/* ^ */
/* | */
/* PLACE = LASTNB(CAUSE)+PAD */
/* After suffixing STRING to CAUSE with one space */
/* it will look like: */
/* . . . xx x xxxxxx string beginning */
/* ^ */
/* | */
/* PLACE + 1 */
/* and the beginning and end of the marked string */
/* will be at PLACE + SB and PLACE+SE respectively. */
b = lastnb_(bmark, (ftnlen)16);
e = lastnb_(emark, (ftnlen)16);
bpad = lastnb_(messge, messge_len) + 1;
if (pad < 1) {
place = lastnb_(messge, messge_len);
} else {
place = lastnb_(messge, messge_len) + pad;
suffix_(string, &pad, messge, string_len, messge_len);
s_copy(messge + (bpad - 1), fill, place - (bpad - 1), pad);
}
if (e > 0) {
i__1 = place + *se + 1;
zzinssub_(messge, emark, &i__1, messge, messge_len, e, messge_len);
}
if (b > 0) {
i__1 = place + *sb;
zzinssub_(messge, bmark, &i__1, messge, messge_len, b, messge_len);
}
return 0;
} /* m2diag_ */
/* $Procedure LIST ( Process a SUBTeX list item ) */
/* Subroutine */ int list_(char *source, integer *n, ftnlen source_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char line[132], cseq[12];
integer l, begin;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer index;
extern /* Subroutine */ int tempb_(char *, char *, ftnlen, ftnlen);
integer pgwid, width, iskip;
char token[132];
integer lskip, rskip;
extern /* Subroutine */ int rjust_(char *, char *, ftnlen, ftnlen);
integer remain, indent;
char marker[5];
extern /* Subroutine */ int params_(char *, char *, integer *, ftnlen,
ftnlen), chkout_(char *, ftnlen), tokens_(char *, char *, integer
*, char *, integer *, ftnlen, ftnlen, ftnlen), suffix_(char *,
integer *, char *, ftnlen, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int intstr_(integer *, char *, ftnlen);
/* $ Abstract */
/* Process a @newlist, @numitem, @symitem, or @paritem control */
/* sequence. */
/* $ 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 */
/* SUBTeX */
/* $ Keywords */
/* SUBTeX */
/* $ Declarations */
/* $ Detailed_Input */
/* SOURCE are the source lines containing a @newlist, @numitem, */
/* @symitem, or @paritem control sequence, followed by */
/* an associated paragraph of text. */
/* N is the number of source lines. */
/* $ Detailed_Output */
/* Processed lines are saved in the temporary buffer. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* SOURCE I Source lines. */
/* N I Number of source lines. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Particulars */
/* $ Examples */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* $Include SUBTeX.REFS */
/* $ Author_and_Institution */
/* I.M. Underwood (JPL) */
/* $ Version */
/* Beta Version 1.0.0, 11-JUN-1988 (IMU) */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling */
if (return_()) {
return 0;
} else {
chkin_("LIST", (ftnlen)4);
}
/* Retrieve the required parameters. */
params_("GET", "PAGEWIDTH", &width, (ftnlen)3, (ftnlen)9);
params_("GET", "LEFTSKIP", &lskip, (ftnlen)3, (ftnlen)8);
params_("GET", "RIGHTSKIP", &rskip, (ftnlen)3, (ftnlen)9);
params_("GET", "ITEMINDENT", &indent, (ftnlen)3, (ftnlen)10);
params_("GET", "ITEMSKIP", &iskip, (ftnlen)3, (ftnlen)8);
/* The first token should be a recognized control sequence. */
tokens_("NEW", source, n, cseq, &l, (ftnlen)3, source_len, (ftnlen)12);
/* @newlist just resets the list index. That's all. */
if (s_cmp(cseq, "@newlist", (ftnlen)12, (ftnlen)8) == 0) {
params_("SET", "LISTINDEX", &c__1, (ftnlen)3, (ftnlen)9);
chkout_("LIST", (ftnlen)4);
return 0;
}
/* The principal difference between the various items is the */
/* marker that begins the first line. */
if (s_cmp(cseq, "@numitem", (ftnlen)12, (ftnlen)8) == 0) {
params_("GET", "LISTINDEX", &index, (ftnlen)3, (ftnlen)9);
i__1 = index + 1;
params_("SET", "LISTINDEX", &i__1, (ftnlen)3, (ftnlen)9);
intstr_(&index, marker, (ftnlen)5);
suffix_(".", &c__0, marker, (ftnlen)1, (ftnlen)5);
} else if (s_cmp(cseq, "@symitem", (ftnlen)12, (ftnlen)8) == 0) {
s_copy(marker, "--", (ftnlen)5, (ftnlen)2);
} else if (s_cmp(cseq, "@paritem", (ftnlen)12, (ftnlen)8) == 0) {
s_copy(marker, " ", (ftnlen)5, (ftnlen)1);
}
/* The rest of the text is reformatted into a paragraph of width */
/* PAGEWIDTH - LEFTSKIP - RIGHTSKIP - ITEMINDENT - ITEMSKIP */
/* beginning in column */
/* LEFTSKIP + ITEMINDENT + ITEMSKIP + 1 */
/* The first line contains the marker, right-justified to column */
/* LEFTSKIP + ITEMINDENT */
/* Keep grabbing tokens until the run out. Start a new line whenever */
/* the current line becomes full. REMAIN is the number of spaces */
/* remaining in the current line. */
pgwid = width - lskip - rskip - indent - iskip;
begin = lskip + indent + iskip + 1;
remain = pgwid;
s_copy(line, " ", (ftnlen)132, (ftnlen)1);
rjust_(marker, line, (ftnlen)5, lskip + indent);
s_copy(token, " ", (ftnlen)132, (ftnlen)1);
tokens_("NEXT", source, n, token, &l, (ftnlen)4, source_len, pgwid);
while(s_cmp(token, " ", (ftnlen)132, (ftnlen)1) != 0) {
if (l > remain || s_cmp(token, "@newline", (ftnlen)132, (ftnlen)8) ==
0) {
tempb_("ADD", line, (ftnlen)3, (ftnlen)132);
s_copy(line, " ", (ftnlen)132, (ftnlen)1);
remain = pgwid;
s_copy(line + (begin - 1), token, 132 - (begin - 1), (ftnlen)132);
remain = remain - l - 1;
} else if (s_cmp(line + (begin - 1), " ", 132 - (begin - 1), (ftnlen)
1) == 0) {
s_copy(line + (begin - 1), token, 132 - (begin - 1), (ftnlen)132);
remain = remain - l - 1;
} else {
suffix_(token, &c__1, line + (begin - 1), (ftnlen)132, 132 - (
begin - 1));
remain = remain - l - 1;
}
tokens_("NEXT", source, n, token, &l, (ftnlen)4, source_len, pgwid);
}
if (s_cmp(line, " ", (ftnlen)132, (ftnlen)1) != 0) {
tempb_("ADD", line, (ftnlen)3, (ftnlen)132);
}
/* Every list item is followed by a blank line. */
tempb_("ADD", " ", (ftnlen)3, (ftnlen)1);
chkout_("LIST", (ftnlen)4);
return 0;
} /* list_ */
/* $Procedure ERRHAN ( Insert DAF/DAS file name into long error message ) */
/* Subroutine */ int errhan_(char *marker, integer *handle, ftnlen marker_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int zzddhnfo_(integer *, char *, integer *,
integer *, integer *, logical *, ftnlen);
char fname[255];
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen);
logical found;
integer intbff, intarc, intamh;
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen), intstr_(integer *, char *, ftnlen);
char numstr[32];
/* $ Abstract */
/* Substitute the first occurrence of a marker in the current long */
/* error message with the file name associated with a given */
/* DAF/DAS handle. (Works for DAF only for N0052.) */
/* $ 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 */
/* ERROR */
/* $ Keywords */
/* DAF */
/* DAS */
/* ERROR */
/* STRING */
/* $ 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 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 */
/* -------- --- -------------------------------------------------- */
/* MARKER I A substring in the long error message to be */
/* replaced. */
/* HANDLE I DAF/DAS handle associated with a file. */
/* FILEN P Maximum length of filename. */
/* $ Detailed_Input */
/* MARKER is a character string that marks a position in */
/* the long error message where a file name is to be */
/* substituted. Leading and trailing blanks in MARKER */
/* are not significant. */
/* Case IS significant; 'XX' is considered to be */
/* a different marker from 'xx'. */
/* HANDLE is the DAF/DAS handle associated with the file of */
/* interest. HANDLE must be associated with a currently */
/* loade DAF or DAS file. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* FILEN is the maximum file name length that can be */
/* accommodated by this routine. Currently this */
/* parameter is defined in the include file */
/* zzddhman.inc. */
/* $ Exceptions */
/* Error free. */
/* 1) If HANDLE refers to a scratch DAS file, the string inserted */
/* into the long error message is */
/* 'DAS SCRATCH FILE' */
/* 2) If HANDLE is not associated with a loaded DAF or DAS file, */
/* the string inserted into the long error message is: */
/* '<No name found for handle #>' */
/* where the handle number is substituted for the marker '#'. */
/* $ Files */
/* See "Detailed_Input" description of the variable HANDLE. */
/* $ Particulars */
/* This routine provides a convenient and error-free mechanism */
/* for inserting a DAF or DAS file name into an error message, */
/* given the file handle associated with the file of interest. */
/* $ Examples */
/* 1) Create an error message pertaining to an SPK file */
/* designated by HANDLE, then signal an error. */
/* CALL SETMSG ( 'SPK file # contains a type 3 segment ' // */
/* . 'with invalid polynomial degree #. ' // */
/* . 'Segment index in file is #.' ) */
/* CALL ERRHAN ( '#', HANDLE ) */
/* CALL ERRINT ( '#', DEGREE ) */
/* CALL ERRINT ( '#', I ) */
/* CALL SIGERR ( 'SPICE(INVALIDDEGREE)' ) */
/* $ Restrictions */
/* 1) This routine works only for DAF files in the N0052 Toolkit */
/* version. It will for for both DAF and DAS files for later */
/* Toolkit versions. */
/* 2) The supported filename length is limited by the parameter */
/* FILEN. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 04-JAN-2002 (NJB) */
/* -& */
/* $ Index_Entries */
/* insert filename into long error message */
/* -& */
/* Local parameters */
/* Local variables */
/* Get the name of the file designated by the input handle. */
zzddhnfo_(handle, fname, &intarc, &intbff, &intamh, &found, (ftnlen)255);
if (! found) {
intstr_(handle, numstr, (ftnlen)32);
s_copy(fname, "<No name found for handle ", (ftnlen)255, (ftnlen)26);
suffix_(numstr, &c__1, fname, (ftnlen)32, (ftnlen)255);
suffix_(">", &c__0, fname, (ftnlen)1, (ftnlen)255);
}
/* Insert the file name string into the long error message. */
errch_(marker, fname, marker_len, (ftnlen)255);
return 0;
} /* errhan_ */
/* $Procedure BODVCD ( Return d.p. values from the kernel pool ) */
/* Subroutine */ int bodvcd_(integer *bodyid, char *item, integer *maxn,
integer *dim, doublereal *values, ftnlen item_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char code[16], type__[1];
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
logical found;
char varnam[32];
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), suffix_(char *, integer *, char *, ftnlen,
ftnlen);
extern logical return_(void);
extern /* Subroutine */ int intstr_(integer *, char *, ftnlen);
/* $ Abstract */
/* Fetch from the kernel pool the double precision values */
/* of an item associated with a body, where the body is */
/* specified by an integer ID code. */
/* $ 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 */
/* KERNEL */
/* NAIF_IDS */
/* $ Keywords */
/* CONSTANTS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* BODYID I Body ID code. */
/* ITEM I Item for which values are desired. ('RADII', */
/* 'NUT_PREC_ANGLES', etc. ) */
/* MAXN I Maximum number of values that may be returned. */
/* DIM O Number of values returned. */
/* VALUES O Values. */
/* $ Detailed_Input */
/* BODYID is the NAIF integer ID code for a body of interest. */
/* For example, if the body is the earth, the code is */
/* 399. */
/* ITEM is the item to be returned. Together, the NAIF ID */
/* code of the body and the item name combine to form a */
/* kernel variable name, e.g., */
/* 'BODY599_RADII' */
/* 'BODY401_POLE_RA' */
/* The values associated with the kernel variable having */
/* the name constructed as shown are sought. Below */
/* we'll take the shortcut of calling this kernel variable */
/* the "requested kernel variable." */
/* Note that ITEM *is* case-sensitive. This attribute */
/* is inherited from the case-sensitivity of kernel */
/* variable names. */
/* MAXN is the maximum number of values that may be returned. */
/* The output array VALUES must be declared with size at */
/* least MAXN. It's an error to supply an output array */
/* that is too small to hold all of the values associated */
/* with the requested kernel variable. */
/* $ Detailed_Output */
/* DIM is the number of values returned; this is always the */
/* number of values associated with the requested kernel */
/* variable unless an error has been signaled. */
/* VALUES is the array of values associated with the requested */
/* kernel variable. If VALUES is too small to hold all */
/* of the values associated with the kernel variable, the */
/* returned values of DIM and VALUES are undefined. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the requested kernel variable is not found in the kernel */
/* pool, the error SPICE(KERNELVARNOTFOUND) is signaled. */
/* 2) If the requested kernel variable is found but the associated */
/* values aren't numeric, the error SPICE(TYPEMISMATCH) is */
/* signaled. */
/* 3) The output array VALUES must be declared with sufficient size */
/* to contain all of the values associated with the requested */
/* kernel variable. If the dimension of */
/* VALUES indicated by MAXN is too small to contain the */
/* requested values, the error SPICE(ARRAYTOOSMALL) is signaled. */
/* 4) If the input dimension MAXN indicates there is more room */
/* in VALUES than there really is---for example, if MAXN is */
/* 10 but values is declared with dimension 5---and the dimension */
/* of the requested kernel variable is larger than the actual */
/* dimension of VALUES, then this routine may overwrite */
/* memory. The results are unpredictable. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine simplifies looking up PCK kernel variables by */
/* constructing names of requested kernel variables and by */
/* performing error checking. */
/* This routine is intended for use in cases where the maximum */
/* number of values that may be returned is known at compile */
/* time. The caller fetches all of the values associated with */
/* the specified kernel variable via a single call to this */
/* routine. If the number of values to be fetched cannot be */
/* known until run time, the lower-level routine GDPOOL (an */
/* entry point of POOL) should be used instead. GDPOOL supports */
/* fetching arbitrary amounts of data in multiple "chunks." */
/* This routine is intended for use in cases where the requested */
/* kernel variable is expected to be present in the kernel pool. If */
/* the variable is not found or has the wrong data type, this */
/* routine signals an error. In cases where it is appropriate to */
/* indicate absence of an expected kernel variable by returning a */
/* boolean "found flag" with the value .FALSE., again the routine */
/* GDPOOL should be used. */
/* $ Examples */
/* 1) When the kernel variable */
/* BODY399_RADII */
/* is present in the kernel pool---normally because a PCK */
/* defining this variable has been loaded---the call */
/* CALL BODVCD ( 399, 'RADII', 3, DIM, VALUES ) */
/* returns the dimension and values associated with the variable */
/* 'BODY399_RADII', for example, */
/* DIM = 3 */
/* VALUES(1) = 6378.140 */
/* VALUES(2) = 6378.140 */
/* VALUES(3) = 6356.755 */
/* 2) The call */
/* CALL BODVCD ( 399, 'radii', 3, DIM, VALUES ) */
/* usually will cause a SPICE(KERNELVARNOTFOUND) error to be */
/* signaled, because this call will attempt to look up the */
/* values associated with a kernel variable of the name */
/* 'BODY399_radii' */
/* Since kernel variable names are case sensitive, this */
/* name is not considered to match the name */
/* 'BODY399_RADII' */
/* which normally would be present after a text PCK */
/* containing data for all planets and satellites has */
/* been loaded. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* B.V. Semenov (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 24-OCT-2004 (NJB) (BVS) (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* fetch constants for a body from the kernel pool */
/* physical constants for a body */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("BODVCD", (ftnlen)6);
}
/* Construct the variable name from BODY and ITEM. */
s_copy(varnam, "BODY", (ftnlen)32, (ftnlen)4);
intstr_(bodyid, code, (ftnlen)16);
suffix_(code, &c__0, varnam, (ftnlen)16, (ftnlen)32);
suffix_("_", &c__0, varnam, (ftnlen)1, (ftnlen)32);
suffix_(item, &c__0, varnam, item_len, (ftnlen)32);
/* Make sure the item is present in the kernel pool. */
dtpool_(varnam, &found, dim, type__, (ftnlen)32, (ftnlen)1);
if (! found) {
setmsg_("The variable # could not be found in the kernel pool.", (
ftnlen)53);
errch_("#", varnam, (ftnlen)1, (ftnlen)32);
sigerr_("SPICE(KERNELVARNOTFOUND)", (ftnlen)24);
chkout_("BODVCD", (ftnlen)6);
return 0;
}
/* Make sure the item's data type is numeric. */
if (*(unsigned char *)type__ != 'N') {
setmsg_("The data associated with variable # are not of numeric type."
, (ftnlen)60);
errch_("#", varnam, (ftnlen)1, (ftnlen)32);
sigerr_("SPICE(TYPEMISMATCH)", (ftnlen)19);
chkout_("BODVCD", (ftnlen)6);
return 0;
}
/* Make sure there's enough room in the array VALUES to hold */
/* the requested data. */
if (*maxn < *dim) {
setmsg_("The data array associated with variable # has dimension #, "
"which is larger than the available space # in the output arr"
"ay.", (ftnlen)122);
errch_("#", varnam, (ftnlen)1, (ftnlen)32);
errint_("#", dim, (ftnlen)1);
errint_("#", maxn, (ftnlen)1);
sigerr_("SPICE(ARRAYTOOSMALL)", (ftnlen)20);
chkout_("BODVCD", (ftnlen)6);
return 0;
}
/* Grab the values. We know at this point they're present in */
/* the kernel pool, so we don't check the FOUND flag. */
gdpool_(varnam, &c__1, maxn, dim, values, &found, (ftnlen)32);
chkout_("BODVCD", (ftnlen)6);
return 0;
} /* bodvcd_ */
/* $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 BODVAR ( Return values from the kernel pool ) */
/* Subroutine */ int bodvar_(integer *body, char *item, integer *dim,
doublereal *values, ftnlen item_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char code[16];
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
logical found;
char varnam[32];
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), suffix_(char *, integer *, char
*, ftnlen, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int rtpool_(char *, integer *, doublereal *,
logical *, ftnlen), intstr_(integer *, char *, ftnlen);
/* $ Abstract */
/* Deprecated: This routine has been superseded by BODVCD and */
/* BODVRD. This routine is supported for purposes of backward */
/* compatibility only. */
/* Return the values of some item for any body 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 */
/* KERNEL */
/* $ Keywords */
/* CONSTANTS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* BODY I ID code of body. */
/* ITEM I Item for which values are desired. ('RADII', */
/* 'NUT_PREC_ANGLES', etc. ) */
/* DIM O Number of values returned. */
/* VALUES O Values. */
/* $ Detailed_Input */
/* BODY is the ID code of the body for which ITEM is */
/* requested. Bodies are numbered according to the */
/* standard NAIF numbering scheme. */
/* ITEM is the item to be returned. Together, the body and */
/* item name combine to form a variable name, e.g., */
/* 'BODY599_RADII' */
/* 'BODY401_POLE_RA' */
/* $ Detailed_Output */
/* DIM is the number of values associated with the variable. */
/* VALUES are the values associated with the variable. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Files */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* The call */
/* CALL BODVAR ( 399, 'RADII', DIM, VALUE ) */
/* returns the dimension and values associated with the variable */
/* 'BODY399_RADII', for example, */
/* DIM = 3 */
/* VALUE(1) = 6378.140 */
/* VALUE(2) = 6378.140 */
/* VALUE(3) = 6356.755 */
/* $ Restrictions */
/* 1) If the requested item is not found, the error */
/* SPICE(KERNELVARNOTFOUND) is signalled. */
/* $ Literature_References */
/* 1) Refer to the SPK required reading file for a complete list of */
/* the NAIF integer ID codes for bodies. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.5, 18-MAY-2010 (BVS) */
/* Index lines now state that this routine is deprecated. */
/* - SPICELIB Version 1.0.4, 27-OCT-2005 (NJB) */
/* Routine is now deprecated. */
/* - SPICELIB Version 1.0.3, 08-JAN-2004 (EDW) */
/* Trivial typo corrected. */
/* - SPICELIB Version 1.0.2, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.1, 8-AUG-1990 (HAN) */
/* Detailed Input section of the header was updated. The */
/* description for the variable BODY was incorrect. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* DEPRECATED fetch constants for a body from the kernel pool */
/* DEPRECATED physical constants for a body */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("BODVAR", (ftnlen)6);
}
/* Construct the variable name from BODY and ITEM. */
s_copy(varnam, "BODY", (ftnlen)32, (ftnlen)4);
intstr_(body, code, (ftnlen)16);
suffix_(code, &c__0, varnam, (ftnlen)16, (ftnlen)32);
suffix_("_", &c__0, varnam, (ftnlen)1, (ftnlen)32);
suffix_(item, &c__0, varnam, item_len, (ftnlen)32);
/* Grab the items. Complain if they aren't there. */
rtpool_(varnam, dim, values, &found, (ftnlen)32);
if (! found) {
setmsg_("The variable # could not be found in the kernel pool.", (
ftnlen)53);
errch_("#", varnam, (ftnlen)1, (ftnlen)32);
sigerr_("SPICE(KERNELVARNOTFOUND)", (ftnlen)24);
}
chkout_("BODVAR", (ftnlen)6);
return 0;
} /* bodvar_ */
/* 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 MSPELD ( Misspelling diagnosis ) */
/* Subroutine */ int mspeld_(char *word, char *guess, char *cause, ftnlen
word_len, ftnlen guess_len, ftnlen cause_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char last[16];
extern /* Subroutine */ int lcase_(char *, char *, ftnlen, ftnlen);
char first[16];
extern /* Subroutine */ int matche_(char *, char *, char *, integer *,
ftnlen, ftnlen, ftnlen);
char diagns[12];
extern /* Subroutine */ int intord_(integer *, char *, ftnlen), suffix_(
char *, integer *, char *, ftnlen, ftnlen);
integer loc;
/* $ Abstract */
/* Diagnose possible spelling errors that might cause a word */
/* to differ from another (known) word. */
/* $ 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 */
/* COMPARE */
/* ERROR */
/* PARSING */
/* UTILITY */
/* WORD */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* WORD I A word that is thought to be misspelled. */
/* GUESS I A word that is thought to be "close" to WORD. */
/* CAUSE O A message indicating the difference between them. */
/* $ Detailed_Input */
/* WORD A word that is thought to be misspelled. */
/* GUESS A word that is thought to be "close" to WORD. */
/* $ Detailed_Output */
/* CAUSE A message that indicates the difference between WORD */
/* and GUESS. */
/* $ Exceptions */
/* 1) CAUSE is blank whenever WORD and GUESS are the same. */
/* $ Files */
/* None. */
/* $ Particulars */
/* A number of spelling errors are due to the lack of cooperation */
/* between the hands that do the typing and the brain that knows */
/* how something should be spelled. Four common errors are: */
/* 1) Leaving out a necessary character. */
/* 2) Adding an extra character. */
/* 3) Mistyping a single character. */
/* 4) Transposing two characters. */
/* This routine creates "friendly" diagnostic messages indicating */
/* whether or not the difference between WORD and GUESS could have */
/* been caused by one of these simple errors. */
/* This routine will typically be used only after the list of */
/* guesses has been narrowed down to words that are "close" to */
/* the unrecognized word. */
/* $ Examples */
/* $ */
/* WORD : LENGHT */
/* GUESS : LENGTH */
/* CAUSE : 'It appears that you have transposed the fifth and */
/* sixth letters of LENGTH (the letters T and H).' */
/* WORD : EPHEMRIS */
/* GUESS : EPHEMERIS */
/* CAUSE : 'It appears that you have left out the sixth letter of */
/* EPHEMERIS. (The sixth letter should be E.)' */
/* WORD : INTWGRATE */
/* WORD : INTEGRATE */
/* CAUSE : 'It appears that you have mistyped the fourth letter */
/* of INTEGRATE. (The fourth letter should be E. You */
/* have W instead.)' */
/* WORD : INTERGER */
/* GUESS: INTEGER */
/* CAUSE 'It appears that you have an extra letter at the fifth */
/* letter of INTERGER. (The fifth letter R should be */
/* removed.)' */
/* WORD : URUNAS */
/* GUESS: URANUS */
/* CAUSE: 'I believe you meant URANUS. However, the actual */
/* spelling error is not a simple one.' */
/* WORD : INTERDENOMINATIONAL */
/* GUESS: INTERDENOMINATIONAL */
/* CAUSE: ' ' */
/* $ Restrictions */
/* Any restrictions that apply to the words compared by MATCHE */
/* apply as well to WORD and GUESS. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - 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, 13-APR-1988 (WLT) (IMU) */
/* -& */
/* Local variables */
matche_(word, guess, diagns, &loc, word_len, guess_len, (ftnlen)12);
if (s_cmp(diagns, "IDENTITY", (ftnlen)12, (ftnlen)8) == 0) {
s_copy(cause, " ", cause_len, (ftnlen)1);
} else if (s_cmp(diagns, "TRANSPOSE", (ftnlen)12, (ftnlen)9) == 0) {
intord_(&loc, first, (ftnlen)16);
i__1 = loc + 1;
intord_(&i__1, last, (ftnlen)16);
lcase_(first, first, (ftnlen)16, (ftnlen)16);
lcase_(last, last, (ftnlen)16, (ftnlen)16);
s_copy(cause, "It appears that you have transposed the ", cause_len, (
ftnlen)40);
suffix_(first, &c__1, cause, (ftnlen)16, cause_len);
suffix_("and", &c__1, cause, (ftnlen)3, cause_len);
suffix_(last, &c__1, cause, (ftnlen)16, cause_len);
suffix_("letters of", &c__1, cause, (ftnlen)10, cause_len);
suffix_(guess, &c__1, cause, guess_len, cause_len);
suffix_("(the letters", &c__1, cause, (ftnlen)12, cause_len);
suffix_(guess + (loc - 1), &c__1, cause, (ftnlen)1, cause_len);
suffix_("and", &c__1, cause, (ftnlen)3, cause_len);
i__1 = loc;
suffix_(guess + i__1, &c__1, cause, loc + 1 - i__1, cause_len);
suffix_(").", &c__0, cause, (ftnlen)2, cause_len);
} else if (s_cmp(diagns, "INSERT", (ftnlen)12, (ftnlen)6) == 0) {
intord_(&loc, first, (ftnlen)16);
lcase_(first, first, (ftnlen)16, (ftnlen)16);
s_copy(cause, "It appears that you have left out the ", cause_len, (
ftnlen)38);
suffix_(first, &c__1, cause, (ftnlen)16, cause_len);
suffix_("letter of ", &c__1, cause, (ftnlen)10, cause_len);
suffix_(guess, &c__1, cause, guess_len, cause_len);
suffix_(". (The ", &c__0, cause, (ftnlen)7, cause_len);
suffix_(first, &c__1, cause, (ftnlen)16, cause_len);
suffix_("letter should be ", &c__1, cause, (ftnlen)17, cause_len);
suffix_(guess + (loc - 1), &c__1, cause, (ftnlen)1, cause_len);
suffix_(".)", &c__0, cause, (ftnlen)2, cause_len);
} else if (s_cmp(diagns, "REPLACE", (ftnlen)12, (ftnlen)7) == 0) {
intord_(&loc, first, (ftnlen)16);
lcase_(first, first, (ftnlen)16, (ftnlen)16);
s_copy(cause, "It appears that you have mistyped the ", cause_len, (
ftnlen)38);
suffix_(first, &c__1, cause, (ftnlen)16, cause_len);
suffix_("letter of ", &c__1, cause, (ftnlen)10, cause_len);
suffix_(guess, &c__1, cause, guess_len, cause_len);
suffix_(". (The ", &c__0, cause, (ftnlen)7, cause_len);
suffix_(first, &c__1, cause, (ftnlen)16, cause_len);
suffix_("letter should be ", &c__1, cause, (ftnlen)17, cause_len);
suffix_(guess + (loc - 1), &c__1, cause, (ftnlen)1, cause_len);
suffix_(". You have ", &c__0, cause, (ftnlen)11, cause_len);
suffix_(word + (loc - 1), &c__1, cause, (ftnlen)1, cause_len);
suffix_("instead.)", &c__1, cause, (ftnlen)9, cause_len);
} else if (s_cmp(diagns, "REMOVE", (ftnlen)12, (ftnlen)6) == 0) {
intord_(&loc, first, (ftnlen)16);
lcase_(first, first, (ftnlen)16, (ftnlen)16);
s_copy(cause, "It appears that you have an extra letter at the ",
cause_len, (ftnlen)48);
suffix_(first, &c__1, cause, (ftnlen)16, cause_len);
suffix_("letter of ", &c__1, cause, (ftnlen)10, cause_len);
suffix_(word, &c__1, cause, word_len, cause_len);
suffix_(". (The ", &c__0, cause, (ftnlen)7, cause_len);
suffix_(first, &c__1, cause, (ftnlen)16, cause_len);
suffix_("letter ", &c__1, cause, (ftnlen)7, cause_len);
suffix_(word + (loc - 1), &c__1, cause, (ftnlen)1, cause_len);
suffix_("should be removed.)", &c__1, cause, (ftnlen)19, cause_len);
} else {
s_copy(cause, "I believe you meant ", cause_len, (ftnlen)20);
suffix_(guess, &c__1, cause, guess_len, cause_len);
suffix_(". However, the actual spelling ", &c__1, cause, (ftnlen)32,
cause_len);
suffix_("error is not a simple one. ", &c__1, cause, (ftnlen)32,
cause_len);
}
return 0;
} /* mspeld_ */
/* $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 OUTMSG ( Output Error Messages ) */
/* Subroutine */ int outmsg_(char *list, ftnlen list_len)
{
/* Initialized data */
static char defmsg[80*4] = "Oh, by the way: The SPICELIB error handling"
" actions are USER-TAILORABLE. You " "can choose whether the To"
"olkit aborts or continues when errors occur, which " "error "
"messages to output, and where to send the output. Please read t"
"he ERROR " "\"Required Reading\" file, or see the routines ERRA"
"CT, ERRDEV, and ERRPRT. ";
static logical first = TRUE_;
/* System generated locals */
address a__1[2], a__2[3];
integer i__1, i__2, i__3[2], i__4[3];
char ch__1[38];
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen),
s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char name__[32], line[80];
logical long__;
char lmsg[1840];
logical expl;
char smsg[25], xmsg[80];
integer i__;
logical trace;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
integer depth, index;
extern integer wdcnt_(char *, ftnlen);
extern /* Subroutine */ int expln_(char *, char *, ftnlen, ftnlen);
extern integer rtrim_(char *, ftnlen);
char versn[80], words[9*5];
integer start;
logical short__;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
char device[255];
integer remain;
static char border[80];
extern /* Subroutine */ int getdev_(char *, ftnlen);
logical dfault;
integer length;
extern /* Subroutine */ int trcdep_(integer *);
extern integer lastnb_(char *, ftnlen);
extern /* Subroutine */ int trcnam_(integer *, char *, ftnlen), lparse_(
char *, char *, integer *, integer *, char *, ftnlen, ftnlen,
ftnlen);
extern logical msgsel_(char *, ftnlen);
integer wrdlen;
extern /* Subroutine */ int getlms_(char *, ftnlen), wrline_(char *, char
*, ftnlen, ftnlen), getsms_(char *, ftnlen), suffix_(char *,
integer *, char *, ftnlen, ftnlen);
char tmpmsg[105];
extern /* Subroutine */ int nextwd_(char *, char *, char *, ftnlen,
ftnlen, ftnlen);
integer numwrd;
char upword[9], outwrd[1840];
extern /* Subroutine */ int tkvrsn_(char *, char *, ftnlen, ftnlen);
logical output;
/* $ Abstract */
/* Output error messages. */
/* $ 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 */
/* ERROR */
/* $ Keywords */
/* ERROR */
/* $ 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 */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* LIST I A list of error message types. */
/* FILEN P Maximum length of file name. */
/* NAMLEN P Maximum length of module name. See TRCPKG. */
/* LL P Output line length. */
/* $ Detailed_Input */
/* LIST is a list of error message types. A list is a */
/* character string containing one or more words */
/* from the following list, separated by commas. */
/* SHORT */
/* EXPLAIN */
/* LONG */
/* TRACEBACK */
/* DEFAULT */
/* Each type of error message specified in LIST will */
/* be output when an error is detected, if it is */
/* enabled for output. Note that DEFAULT does */
/* NOT refer to the "default message selection," */
/* but rather to a special message that is output */
/* when the error action is 'DEFAULT'. This message */
/* is a statement referring the user to the error */
/* handling documentation. */
/* Messages are never duplicated in the output; for */
/* instance, supplying a value of LIST such as */
/* 'SHORT, SHORT' */
/* does NOT result in the output of two short */
/* messages. */
/* The words in LIST may appear in mixed case; */
/* for example, the call */
/* CALL OUTMSG ( 'ShOrT' ) */
/* will work. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* FILEN is the maximum device name length that can be */
/* accommodated by this routine. */
/* NAMELN is the maximum length of an individual module name. */
/* LL is the maximum line length for the output message. */
/* If the output message string is very long, it is */
/* displayed over several lines, each of which has a */
/* maximum length of LL characters. */
/* $ Exceptions */
/* 1) This routine detects invalid message types in the argument, */
/* LIST. The short error message in this case is */
/* 'SPICE(INVALIDLISTITEM)' */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine is part of the SPICELIB error handling */
/* mechanism. */
/* This routine outputs the error messages specified in LIST that */
/* have been enabled for output (use the SPICELIB routine ERRPRT */
/* to enable or disable output of specified types of error */
/* messages). A border is written out preceding and following the */
/* messages. Output is directed to the current error output device. */
/* $ Examples */
/* 1) Output the short and long error messages: */
/* C */
/* C Output short and long messages: */
/* C */
/* CALL OUTMSG ( 'SHORT, LONG' ) */
/* $ Restrictions */
/* 1) This routine is intended for use by the SPICELIB error */
/* handling mechanism. SPICELIB users are not expected to */
/* need to call this routine. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* K.R. Gehringer (JPL) */
/* H.A. Neilan (JPL) */
/* M.J. Spencer (JPL) */
/* $ Version */
/* - SPICELIB Version 5.27.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 5.26.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 5.25.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 5.24.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 5.23.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 5.22.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 5.21.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 5.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 5.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 5.18.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 5.17.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 5.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 5.15.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 5.14.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 5.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 5.12.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 5.11.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 5.10.0, 01-MAR-2009 (NJB) */
/* Bug fix: truncation of long words in */
/* output has been corrected. Local parameter */
/* TMPLEN was added and is used in declaration */
/* of TMPMSG. */
/* - SPICELIB Version 5.9.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 5.8.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 5.7.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 5.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 5.5.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 5.4.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 5.3.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 5.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 5.1.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 5.1.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 5.1.3, 24-SEP-1999 (NJB) */
/* CSPICE environments were added. Some typos were corrected. */
/* - SPICELIB Version 5.1.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 5.1.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 5.1.0, 13-JAN-1999 (BVS) */
/* ``errhnd.inc'' file was included. Long and short error */
/* message lengths parameter declarations were deleted. Long */
/* and short error message string sizes were changed to those */
/* declared in ``errhnd.inc''. */
/* - SPICELIB Version 5.0.0, 08-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 4.0.0, 09-MAY-1996 (KRG) */
/* Added the toolkit version to the output error message. */
/* Updated this routine to be consistent with the trace package */
/* revisions. This primarily affects the creation of the */
/* traceback string. */
/* Long error messages are now wrapped on word boundaries when */
/* they are longer than the output line length. Note that this */
/* only happens for long error messages obtained from GETLMS, */
/* and not for the error messages displayed by this subroutine */
/* and other error handling subroutines that write their own */
/* error messages. */
/* - SPICELIB Version 3.0.0, 09-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* for the Silicon Graphics, DEC Alpha-OSF/1, and */
/* NeXT platforms. Also, the previous value of 256 for */
/* Unix platforms was changed to 255. */
/* - SPICELIB Version 2.2.0, 12-OCT-1992 (HAN) */
/* Updated module for multiple environments. Moved the parameter */
/* LL to the Declarations section of the header since it's */
/* environment dependent. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 2.1.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 2.1.0, 15-MAY-1991 (MJS) */
/* Module was updated to include the value of LL for the */
/* Macintosh. */
/* - SPICELIB Version 2.0.0, 28-MAR-1991 (NJB) */
/* Work-around for MS Fortran compiler error under DOS 3.10 */
/* was made. Some substring bounds were simplified using RTRIM. */
/* Updates were made to the header to clarify the text and */
/* improve the header's appearance. The default error message */
/* was slightly de-uglified. */
/* The IBM PC version of this routine now uses an output line */
/* length of 78 characters rather than 80. This prevents */
/* wrapping of the message borders and default error message. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (NJB) */
/* -& */
/* $ Index_Entries */
/* None. */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 5.1.0, 13-JAN-1999 (BVS) */
/* ``errhnd.inc'' file was included. Long and short error */
/* message lengths parameter declarations were deleted. Long */
/* and short error message string size were changed to those */
/* declared in ``errhnd.inc''. */
/* - SPICELIB Version 5.0.0, 08-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 4.0.0, 09-MAY-1996 (KRG) */
/* Added the toolkit version to the output error message. */
/* Updated this routine to be consistent with the trace package */
/* revisions. This primarily affects the creation of the */
/* traceback string. */
/* Long error messages are now wrapped on word boundaries when */
/* they are longer than the output line length. Note that this */
/* only happens for long error messages obtained from GETLMS, */
/* and not for the error messages displayed by this subroutine */
/* and other error handling subroutines that write their own */
/* error messages. */
/* - SPICELIB Version 3.0.0, 9-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* for the Silicon Graphics, DEC Alpha-OSF/1, and */
/* NeXT platforms. Also, the previous value of 256 for */
/* Unix platforms was changed to 255. */
/* - SPICELIB Version 2.2.0, 12-OCT-1992 (HAN) */
/* Updated module for multiple environments. Moved the */
/* parameter LL to the Declarations section of the header since */
/* it's environment dependent. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 2.1.0, 15-MAY-1991 (MJS) */
/* Module was updated to include the value of LL for the */
/* Macintosh. */
/* - SPICELIB Version 2.0.0, 28-MAR-1991 (NJB) */
/* 1) Work-around for MS Fortran compiler error under DOS 3.10 */
/* was made. The compiler did not correctly handle code that */
/* concatenated strings whose bounds involved the intrinsic */
/* MAX function. */
/* 2) Some substring bounds were simplified using RTRIM. */
/* 3) Updates were made to the header to clarify the text and */
/* improve the header's appearance. */
/* 4) Declarations were re-organized. */
/* 5) The default error message was slightly de-uglified. */
/* 6) The IBM PC version of this routine now uses an output line */
/* length of 78 characters rather than 80. This prevents */
/* wrapping of the message borders and default error message. */
/* - Beta Version 1.3.0, 19-JUL-1989 (NJB) */
/* Calls to REMSUB removed; blanking and left-justifying used */
/* instead. This was done because REMSUB handles substring */
/* bounds differently than in previous versions, and no longer */
/* handles all possible inputs as required by this routine. */
/* LJUST, which is used now, is error free. */
/* Also, an instance of .LT. was changed to .LE. The old code */
/* caused a line break one character too soon. A minor bug, but */
/* a bug nonetheless. */
/* Also, two substring bounds were changed to ensure that they */
/* remain greater than zero. */
/* - Beta Version 1.2.0, 16-FEB-1989 (NJB) */
/* Warnings added to discourage use of this routine in */
/* non-error-handling code. Parameters section updated to */
/* describe FILEN and NAMLEN. */
/* Declaration of unused function FAILED removed. */
/* - Beta Version 1.1.0, 06-OCT-1988 (NJB) */
/* Test added to ensure substring upper bound is greater than 0. */
/* REMAIN must be greater than 0 when used as the upper bound */
/* for a substring of NAME. Also, substring upper bound in */
/* WRLINE call is now forced to be greater than 0. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* These parameters are system-independent. */
/* Local variables */
/* Saved variables */
/* Initial Values: */
/* Executable Code: */
/* The first time through, set up the output borders. */
if (first) {
first = FALSE_;
for (i__ = 1; i__ <= 80; ++i__) {
*(unsigned char *)&border[i__ - 1] = '=';
}
}
/* No messages are to be output which are not specified */
/* in LIST: */
short__ = FALSE_;
expl = FALSE_;
long__ = FALSE_;
trace = FALSE_;
dfault = FALSE_;
/* We parse the list of message types, and set local flags */
/* indicating which ones are to be output. If we find */
/* a word we don't recognize in the list, we signal an error */
/* and continue parsing the list. */
lparse_(list, ",", &c__5, &numwrd, words, list_len, (ftnlen)1, (ftnlen)9);
i__1 = numwrd;
for (i__ = 1; i__ <= i__1; ++i__) {
ucase_(words + ((i__2 = i__ - 1) < 5 && 0 <= i__2 ? i__2 : s_rnge(
"words", i__2, "outmsg_", (ftnlen)613)) * 9, upword, (ftnlen)
9, (ftnlen)9);
if (s_cmp(upword, "SHORT", (ftnlen)9, (ftnlen)5) == 0) {
short__ = TRUE_;
} else if (s_cmp(upword, "EXPLAIN", (ftnlen)9, (ftnlen)7) == 0) {
expl = TRUE_;
} else if (s_cmp(upword, "LONG", (ftnlen)9, (ftnlen)4) == 0) {
long__ = TRUE_;
} else if (s_cmp(upword, "TRACEBACK", (ftnlen)9, (ftnlen)9) == 0) {
trace = TRUE_;
} else if (s_cmp(upword, "DEFAULT", (ftnlen)9, (ftnlen)7) == 0) {
dfault = TRUE_;
} else {
/* Unrecognized word! This is an error... */
/* We have a special case on our hands; this routine */
/* is itself called by SIGERR, so a recursion error will */
/* result if this routine calls SIGERR. So we output */
/* the error message directly: */
getdev_(device, (ftnlen)255);
wrline_(device, "SPICE(INVALIDLISTITEM)", (ftnlen)255, (ftnlen)22)
;
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
wrline_(device, "OUTMSG: An invalid message type was specified "
"in the type list. ", (ftnlen)255, (ftnlen)65);
/* Writing concatenation */
i__3[0] = 29, a__1[0] = "The invalid message type was ";
i__3[1] = 9, a__1[1] = words + ((i__2 = i__ - 1) < 5 && 0 <= i__2
? i__2 : s_rnge("words", i__2, "outmsg_", (ftnlen)650)) *
9;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)38);
wrline_(device, ch__1, (ftnlen)255, (ftnlen)38);
}
}
/* LIST has been parsed. */
/* Now, we output those error messages that were specified by LIST */
/* and which belong to the set of messages selected for output. */
/* We get the default error output device: */
getdev_(device, (ftnlen)255);
output = short__ && msgsel_("SHORT", (ftnlen)5) || expl && msgsel_("EXPL"
"AIN", (ftnlen)7) || long__ && msgsel_("LONG", (ftnlen)4) || trace
&& msgsel_("TRACEBACK", (ftnlen)9) || dfault && msgsel_("DEFAULT",
(ftnlen)7) && s_cmp(device, "NULL", (ftnlen)255, (ftnlen)4) != 0;
/* We go ahead and output those messages that have been specified */
/* in the list and also are enabled for output. The order of the */
/* cases below IS significant; the order in which the messages */
/* appear in the output depends on it. */
/* If there's nothing to output, we can leave now. */
if (! output) {
return 0;
}
/* Write the starting border: skip a line, write the border, */
/* skip a line. */
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
wrline_(device, border, (ftnlen)255, (ftnlen)80);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
/* Output the toolkit version and skip a line. */
tkvrsn_("TOOLKIT", versn, (ftnlen)7, (ftnlen)80);
/* Writing concatenation */
i__3[0] = 17, a__1[0] = "Toolkit version: ";
i__3[1] = 80, a__1[1] = versn;
s_cat(line, a__1, i__3, &c__2, (ftnlen)80);
wrline_(device, line, (ftnlen)255, (ftnlen)80);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
/* Next, we output the messages specified in the list */
/* that have been enabled. */
/* We start with the short message and its accompanying */
/* explanation. If both are to be output, they are */
/* concatenated into a single message. */
if (short__ && msgsel_("SHORT", (ftnlen)5) && (expl && msgsel_("EXPLAIN",
(ftnlen)7))) {
/* Extract the short message from global storage; then get */
/* the corresponding explanation. */
getsms_(smsg, (ftnlen)25);
expln_(smsg, xmsg, (ftnlen)25, (ftnlen)80);
/* Writing concatenation */
i__4[0] = rtrim_(smsg, (ftnlen)25), a__2[0] = smsg;
i__4[1] = 4, a__2[1] = " -- ";
i__4[2] = 80, a__2[2] = xmsg;
s_cat(tmpmsg, a__2, i__4, &c__3, (ftnlen)105);
wrline_(device, tmpmsg, (ftnlen)255, (ftnlen)105);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
} else if (short__ && msgsel_("SHORT", (ftnlen)5)) {
/* Output the short error message without the explanation. */
getsms_(smsg, (ftnlen)25);
wrline_(device, smsg, (ftnlen)255, (ftnlen)25);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
} else if (expl && msgsel_("EXPLAIN", (ftnlen)7)) {
/* Obtain the explanatory text for the short error */
/* message and output it: */
getsms_(smsg, (ftnlen)25);
expln_(smsg, xmsg, (ftnlen)25, (ftnlen)80);
wrline_(device, xmsg, (ftnlen)255, (ftnlen)80);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
if (long__ && msgsel_("LONG", (ftnlen)4)) {
/* Extract the long message from global storage and */
/* output it: */
getlms_(lmsg, (ftnlen)1840);
/* Get the number of words in the error message. */
numwrd = wdcnt_(lmsg, (ftnlen)1840);
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
start = 1;
/* Format the words into output lines and display them as */
/* needed. */
i__1 = numwrd;
for (i__ = 1; i__ <= i__1; ++i__) {
nextwd_(lmsg, outwrd, lmsg, (ftnlen)1840, (ftnlen)1840, (ftnlen)
1840);
wrdlen = rtrim_(outwrd, (ftnlen)1840);
if (start + wrdlen <= 80) {
s_copy(line + (start - 1), outwrd, 80 - (start - 1), (ftnlen)
1840);
start = start + wrdlen + 1;
} else {
if (wrdlen <= 80) {
/* We had a short word, so just write the line and */
/* continue. */
wrline_(device, line, (ftnlen)255, (ftnlen)80);
start = wrdlen + 2;
s_copy(line, outwrd, (ftnlen)80, (ftnlen)1840);
} else {
/* We got a very long word here, so we break it up and */
/* write it out. We fit as much of it as we an into line */
/* as possible before writing it. */
/* Get the remaining space. If START is > 1 we have at */
/* least one word already in the line, including it's */
/* trailing space, otherwise the line is blank. If line */
/* is empty, we have all of the space available. */
if (start > 1) {
remain = 80 - start;
} else {
remain = 80;
}
/* Now we stuff bits of the word into the output line */
/* until we're done, i.e., until we have a word part */
/* that is less than the output length. First, we */
/* check to see if there is a "significant" amount of */
/* room left in the current output line. If not, we */
/* write it and then begin stuffing the long word into */
/* output lines. */
if (remain < 10) {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
remain = 80;
start = 1;
}
/* Stuff the word a chunk at a time into output lines */
/* and write them. After writing a line, we clear the */
/* part of the long word that we just wrote, left */
/* justifying the remaining part before proceeding. */
while(wrdlen > 80) {
s_copy(line + (start - 1), outwrd, 80 - (start - 1),
remain);
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(outwrd, " ", remain, (ftnlen)1);
ljust_(outwrd, outwrd, (ftnlen)1840, (ftnlen)1840);
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
wrdlen -= remain;
remain = 80;
start = 1;
}
/* If we had a part of the long word left, get set up to */
/* append more words from the error message to the output */
/* line. If we finished the word, WRDLEN .EQ. 0, then */
/* START and LINE have already been initialized. */
if (wrdlen > 0) {
start = wrdlen + 2;
s_copy(line, outwrd, (ftnlen)80, (ftnlen)1840);
}
}
}
}
/* We may need to write the remaining part of a line. */
if (s_cmp(line, " ", (ftnlen)80, (ftnlen)1) != 0) {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
}
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
if (trace && msgsel_("TRACEBACK", (ftnlen)9)) {
/* Extract the traceback from global storage and */
/* output it: */
trcdep_(&depth);
if (depth > 0) {
/* We know we'll be outputting some trace information. */
/* So, write a line telling the reader what's coming. */
wrline_(device, "A traceback follows. The name of the highest l"
"evel module is first.", (ftnlen)255, (ftnlen)68);
/* While there are more names in the traceback */
/* representation, we stuff them into output lines and */
/* write the lines out when they are full. */
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
remain = 80;
i__1 = depth;
for (index = 1; index <= i__1; ++index) {
/* For each module name in the traceback representation, */
/* retrieve module name and stuff it into one or more */
/* lines for output. */
/* Get a name and add the call order sign. We */
/* indicate calling order by a ' --> ' delimiter; e.g. */
/* "A calls B" is indicated by 'A --> B'. */
trcnam_(&index, name__, (ftnlen)32);
length = lastnb_(name__, (ftnlen)32);
/* If it's the first name, just put it into the output */
/* line, otherwise, add the call order sign and put the */
/* name into the output line. */
if (index == 1) {
suffix_(name__, &c__0, line, (ftnlen)32, (ftnlen)80);
remain -= length;
} else {
/* Add the calling order indicator, if it will fit. */
/* If not, write the line and put the indicator as */
/* the first thing on the next line. */
if (remain >= 4) {
suffix_("-->", &c__1, line, (ftnlen)3, (ftnlen)80);
remain += -4;
} else {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(line, "-->", (ftnlen)80, (ftnlen)3);
remain = 77;
}
/* The name fits or it doesn't. If it does, just add */
/* it, if it doesn't, write it, then make the name */
/* the first thing on the next line. */
if (remain >= length) {
suffix_(name__, &c__1, line, (ftnlen)32, (ftnlen)80);
remain = remain - length - 1;
} else {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(line, name__, (ftnlen)80, (ftnlen)32);
remain = 80 - length;
}
}
}
/* At this point, no more names are left in the */
/* trace representation. LINE may still contain */
/* names, or part of a long name. If it does, */
/* we now write it out. */
if (s_cmp(line, " ", (ftnlen)80, (ftnlen)1) != 0) {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
}
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
/* At this point, either we have output the trace */
/* representation, or the trace representation was */
/* empty. */
}
if (dfault && msgsel_("DEFAULT", (ftnlen)7)) {
/* Output the default message: */
for (i__ = 1; i__ <= 4; ++i__) {
wrline_(device, defmsg + ((i__1 = i__ - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("defmsg", i__1, "outmsg_", (ftnlen)971)) *
80, (ftnlen)255, (ftnlen)80);
}
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
/* At this point, we've output all of the enabled messages */
/* that were specified in LIST. At least one message that */
/* was specified was enabled. */
/* Write the ending border out: */
wrline_(device, border, (ftnlen)255, (ftnlen)80);
return 0;
} /* outmsg_ */
/* $Procedure META_2 ( Percy's interface to META_0 ) */
/* Subroutine */ int meta_2__0_(int n__, char *command, char *temps, integer *
ntemps, char *temp, integer *btemp, char *error, ftnlen command_len,
ftnlen temps_len, ftnlen temp_len, ftnlen error_len)
{
/* Initialized data */
static logical pass1 = TRUE_;
static char margns[128] = "LEFT 1 RIGHT 75 "
" "
" ";
static char keynam[6*10] = "1 " "2 " "3 " "4 " "5 "
"6 " "7 " "8 " "9 " "10 ";
/* System generated locals */
address a__1[5];
integer i__1, i__2[5];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsle(cilist *), e_wsle(
void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer do_lio(integer *, integer *, char *, ftnlen);
/* Local variables */
extern /* Subroutine */ int getopt_1__(char *, integer *, char *, integer
*, char *, integer *, char *, char *, ftnlen, ftnlen, ftnlen,
ftnlen, ftnlen);
static integer sbeg;
static char mode[16], pick[32];
static integer b, e, i__, j;
extern integer cardc_(char *, ftnlen);
extern logical batch_(void);
static integer score;
static logical fixit;
extern integer rtrim_(char *, ftnlen);
static char style[128];
static integer m2code;
static char tryit[600];
extern /* Subroutine */ int m2gmch_(char *, char *, char *, integer *,
logical *, integer *, logical *, integer *, integer *, char *,
ftnlen, ftnlen, ftnlen, ftnlen), m2rcvr_(integer *, integer *,
char *, ftnlen), scardc_(integer *, char *, ftnlen);
static integer bscore, cutoff;
static logical reason;
extern /* Subroutine */ int prefix_(char *, integer *, char *, ftnlen,
ftnlen), ssizec_(integer *, char *, ftnlen), repsub_(char *,
integer *, integer *, char *, char *, ftnlen, ftnlen, ftnlen);
static logical intrct;
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen);
static char thnwds[32*7], kwords[32*16];
extern /* Subroutine */ int cmprss_(char *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen), prepsn_(char *, ftnlen);
static logical pssthn;
static char questn[80];
extern /* Subroutine */ int niceio_3__(char *, integer *, char *, ftnlen,
ftnlen), cnfirm_1__(char *, logical *, ftnlen);
/* Fortran I/O blocks */
static cilist io___19 = { 0, 6, 0, 0, 0 };
static cilist io___20 = { 0, 6, 0, 0, 0 };
static cilist io___21 = { 0, 6, 0, 0, 0 };
static cilist io___22 = { 0, 6, 0, 0, 0 };
static cilist io___23 = { 0, 6, 0, 0, 0 };
static cilist io___27 = { 0, 6, 0, 0, 0 };
static cilist io___29 = { 0, 6, 0, 0, 0 };
static cilist io___30 = { 0, 6, 0, 0, 0 };
static cilist io___31 = { 0, 6, 0, 0, 0 };
/* $ Abstract */
/* Given a collection of acceptable syntax's and a statement */
/* (COMMAND) this routine determines if the statement is */
/* syntactically correct. */
/* $ 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 */
/* The META/2 Book. */
/* $ Keywords */
/* COMPARE */
/* PARSING */
/* SEARCH */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* COMMAND I A candidate PERCY command. */
/* TEMPS I A collection of language definition statements */
/* NTEMPS I The number of definition statements */
/* TEMP - Work space required for comparison of statements. */
/* BTEMP O The first of the def statements that best matches. */
/* ERROR O Non-blank if none of the def's match. */
/* $ Detailed_Input */
/* COMMAND A candidate PERCY command. */
/* TEMPS A collection of language definition statements */
/* NTEMPS The number of definition statements */
/* TEMP Work space required for comparison of statements. */
/* TEMP should be declared to have the same length */
/* as the character strings that make up TEMPS. */
/* $ Detailed_Output */
/* BTEMP The first of the def statements that best matches. */
/* ERROR Non-blank if none of the def's match. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Particulars */
/* Later. */
/* $ Examples */
/* Later. */
/* $ Restrictions */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - META/2 Configured Version 3.0.0, 11-AUG-1995 (WLT) */
/* The control flow through this routine was modified */
/* so that it will now re-try all templates (starting */
/* with the best previous match) if a spelling error */
/* is encountered. This should fix the confused */
/* responses that META/2 gave occassionally before. */
/* - 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 2.0.0, 9-MAY-1994 */
/* Added a pretty print formatting capability to the */
/* error diagnostics. */
/* - 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 */
/* - Beta Version 2.0.0, 14-JAN-1993 (HAN) */
/* Assigned the value 'INTERACTIVE' to the variable MODE, and */
/* replaced calls to VTLIB routines with calls to more */
/* portable routines. */
/* - Beta Version 1.0.0, 13-JUL-1988 (WLT) (IMU) */
/* -& */
/* Spice Functions */
/* Local variables. */
/* Saved variables */
/* Initial values */
/* Parameter adjustments */
if (temps) {
}
if (error) {
}
/* Function Body */
switch(n__) {
case 1: goto L_m2marg;
}
/* %&END_DECLARATIONS */
/* Take care of first pass initializations. */
if (pass1) {
pass1 = FALSE_;
ssizec_(&c__1, thnwds, (ftnlen)32);
scardc_(&c__0, thnwds, (ftnlen)32);
ssizec_(&c__10, kwords, (ftnlen)32);
scardc_(&c__0, kwords, (ftnlen)32);
/* Determine if were in batch or interactive mode. */
if (batch_()) {
s_copy(mode, "BATCH", (ftnlen)16, (ftnlen)5);
} else {
s_copy(mode, "INTERACTIVE", (ftnlen)16, (ftnlen)11);
}
}
intrct = s_cmp(mode, "BATCH", (ftnlen)16, (ftnlen)5) != 0;
s_copy(style, margns, (ftnlen)128, (ftnlen)128);
suffix_("NEWLINE /cr VTAB /vt HARDSPACE , ", &c__1, style, (ftnlen)33, (
ftnlen)128);
i__ = 0;
bscore = -1;
m2code = -1;
cutoff = 72;
reason = TRUE_;
/* Look through the templates until we get a match or we */
/* run out of templates to try. */
i__1 = *ntemps;
for (i__ = 1; i__ <= i__1; ++i__) {
score = 0;
s_copy(temp, temps + (i__ - 1) * temps_len, temp_len, temps_len);
sbeg = 1;
m2code = 0;
m2gmch_(temp, thnwds, command, &sbeg, &reason, &cutoff, &pssthn, &
m2code, &score, error, temp_len, (ftnlen)32, command_len,
error_len);
/* If M2CODE comes back zero, we are done with the work */
/* of this routine. */
if (m2code == 0) {
*btemp = i__;
return 0;
}
if (score > bscore) {
bscore = score;
*btemp = i__;
}
}
/* If we get here, we know we didn't have a match. Examine the */
/* highest scoring template to get available diagnostics */
/* about the mismatch. */
s_copy(temp, temps + (*btemp - 1) * temps_len, temp_len, temps_len);
sbeg = 1;
fixit = TRUE_;
m2code = 0;
m2gmch_(temp, thnwds, command, &sbeg, &c_true, &cutoff, &pssthn, &m2code,
&score, error, temp_len, (ftnlen)32, command_len, error_len);
/* If we are in interactiive mode and we have a spelling error, we */
/* can attempt to fix it. Note this occurs only if the M2CODE */
/* is less than 100 mod 10000. */
while(m2code % 10000 < 100 && intrct && fixit) {
/* Construct a friendly message; display it; and */
/* get the user's response as to whether or not the */
/* command should be modified. */
s_copy(tryit, error, (ftnlen)600, error_len);
prefix_("Hmmmm.,,,", &c__1, tryit, (ftnlen)9, (ftnlen)600);
suffix_("/cr/cr I can repair this if you like.", &c__0, tryit, (
ftnlen)37, (ftnlen)600);
s_wsle(&io___19);
e_wsle();
niceio_3__(tryit, &c__6, style, (ftnlen)600, (ftnlen)128);
s_wsle(&io___20);
e_wsle();
s_wsle(&io___21);
e_wsle();
s_wsle(&io___22);
e_wsle();
s_wsle(&io___23);
e_wsle();
m2rcvr_(&b, &e, kwords, (ftnlen)32);
if (cardc_(kwords, (ftnlen)32) == 1) {
/* Writing concatenation */
i__2[0] = 17, a__1[0] = "Should I change \"";
i__2[1] = e - (b - 1), a__1[1] = command + (b - 1);
i__2[2] = 6, a__1[2] = "\" to \"";
i__2[3] = rtrim_(kwords + 192, (ftnlen)32), a__1[3] = kwords +
192;
i__2[4] = 3, a__1[4] = "\" ?";
s_cat(questn, a__1, i__2, &c__5, (ftnlen)80);
cnfirm_1__(questn, &fixit, rtrim_(questn, (ftnlen)80));
} else {
cnfirm_1__("Should I fix it?", &fixit, (ftnlen)16);
}
/* If the user has elected to have us fix the command */
/* we have a few things to do... */
if (fixit) {
/* Look up the suggested fixes. If there is more than */
/* one possibility, see which one the user thinks is */
/* best. Otherwise, no more questions for now. */
m2rcvr_(&b, &e, kwords, (ftnlen)32);
if (cardc_(kwords, (ftnlen)32) > 1) {
i__1 = cardc_(kwords, (ftnlen)32) - 4;
for (i__ = 1; i__ <= i__1; ++i__) {
s_wsle(&io___27);
e_wsle();
}
i__1 = cardc_(kwords, (ftnlen)32);
getopt_1__("Which word did you mean?", &i__1, keynam, &c__6,
kwords + 192, &c__32, kwords + 192, pick, (ftnlen)24,
(ftnlen)6, (ftnlen)32, (ftnlen)32, (ftnlen)32);
} else {
s_copy(pick, kwords + 192, (ftnlen)32, (ftnlen)32);
}
/* Make the requested repairs on the command, and */
/* redisplay the command. */
repsub_(command, &b, &e, pick, command, command_len, (ftnlen)32,
command_len);
cmprss_(" ", &c__1, command, command, (ftnlen)1, command_len,
command_len);
s_wsle(&io___29);
do_lio(&c__9, &c__1, " ", (ftnlen)1);
e_wsle();
s_wsle(&io___30);
do_lio(&c__9, &c__1, " ", (ftnlen)1);
e_wsle();
niceio_3__(command, &c__6, style, command_len, (ftnlen)128);
s_wsle(&io___31);
e_wsle();
/* Look through the templates again until we get a match or we */
/* run out of templates to try. Note however, that this time */
/* we will start in a different spot. We already have a best */
/* matching template. We'll start our search for a match */
/* there and simulate a circular list of templates so that */
/* we can examine all of them if necessary. */
s_copy(error, " ", error_len, (ftnlen)1);
s_copy(error + error_len, " ", error_len, (ftnlen)1);
bscore = -1;
m2code = -1;
cutoff = 72;
reason = TRUE_;
j = *btemp - 1;
i__1 = *ntemps;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Get the index of the next template to examine. */
++j;
while(j > *ntemps) {
j -= *ntemps;
}
/* Set the template, score for this template, spot to */
/* begin examining it and the M2CODE so far. */
s_copy(temp, temps + (j - 1) * temps_len, temp_len, temps_len)
;
sbeg = 1;
score = 0;
m2code = 0;
m2gmch_(temp, thnwds, command, &sbeg, &reason, &cutoff, &
pssthn, &m2code, &score, error, temp_len, (ftnlen)32,
command_len, error_len);
/* If we get back a zero M2CODE we've got a match */
/* This routine's work is done. */
if (m2code == 0) {
*btemp = i__;
return 0;
}
/* Hmmph. No match. See if we've got a better */
/* matching score so far and then go on to the next */
/* template if any are left. */
if (score > bscore) {
bscore = score;
*btemp = i__;
}
}
/* If we made it to this point the command doesn't properly */
/* match any of the templates. Get the best match and */
/* determine the diagnostics for this template. */
s_copy(temp, temps + (*btemp - 1) * temps_len, temp_len,
temps_len);
sbeg = 1;
m2code = 0;
score = 0;
m2gmch_(temp, thnwds, command, &sbeg, &reason, &cutoff, &pssthn, &
m2code, &score, error, temp_len, (ftnlen)32, command_len,
error_len);
}
}
/* If you get to this point. We didn't have a match set up */
/* the second level of mismatch diagnostics using the best */
/* matching template. (BTEMP already points to it.) */
s_copy(temp, temps + (*btemp - 1) * temps_len, temp_len, temps_len);
cmprss_(" ", &c__1, temp, temp, (ftnlen)1, temp_len, temp_len);
prepsn_(temp, temp_len);
prepsn_(error + error_len, error_len);
prefix_("/cr/cr(-3:-3) ", &c__1, error + error_len, (ftnlen)14, error_len)
;
prefix_(temp, &c__1, error + error_len, temp_len, error_len);
prefix_("/cr/cr(3:3) ", &c__1, error + error_len, (ftnlen)12, error_len);
prefix_("a command with the following syntax:", &c__3, error + error_len,
(ftnlen)36, error_len);
prefix_("I Believe you were trying to enter", &c__1, error + error_len, (
ftnlen)34, error_len);
prefix_("META/2:", &c__1, error + error_len, (ftnlen)7, error_len);
return 0;
/* The following entry point allows user's to adjust the margins */
/* of the META/2 error messages. */
L_m2marg:
s_copy(margns, temp, (ftnlen)128, temp_len);
return 0;
} /* meta_2__ */
/* Subroutine */ int rdstmn_(char *prmpt, char *delim, char *stmt, ftnlen
prmpt_len, ftnlen delim_len, ftnlen stmt_len)
{
/* Initialized data */
static char blank[132] = " "
" "
" ";
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen), i_indx(char *, char *,
ftnlen, ftnlen);
/* Local variables */
char line[132];
extern logical batch_(void);
char space[1];
integer prlen;
extern integer rtrim_(char *, ftnlen);
char myprm[132];
extern /* Subroutine */ int replch_(char *, char *, char *, char *,
ftnlen, ftnlen, ftnlen, ftnlen), suffix_(char *, integer *, char *
, ftnlen, ftnlen), prompt_(char *, char *, ftnlen, ftnlen);
char tab[1];
integer end;
/* Read a statement entered on one or more lines. */
/* VARIABLE I/O DESCRIPTION */
/* PRMPT I Prompt for input. If PRMPT is not blank, */
/* the cursor is positioned one space after the */
/* last non-blank character. Successive lines */
/* are indented by the length of PRMPT. */
/* DELIM I Statement delimiter. RDSTMN will continue */
/* to read until the either the delimiter or */
/* a blank line is entered. */
/* STMT O The statement entered, up to but not */
/* including the delimiter. If RDSTMN is */
/* terminated by the entry of a blank line, */
/* STMT is blank. */
/* $ Version */
/* - Command Loop Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 4, 1994 */
/* 7 February 1986, I.M. Underwood */
/* - */
/* SPICELIB functions */
/* Local variables */
/* Read the first statement. Use the prompt. Return immediately */
/* if a blank line or an error is encountered. */
if (batch_()) {
s_copy(stmt, " ", stmt_len, (ftnlen)1);
return 0;
}
prlen = rtrim_(prmpt, prmpt_len) + 1;
s_copy(myprm, prmpt, (ftnlen)132, prmpt_len);
s_copy(line, " ", (ftnlen)132, (ftnlen)1);
*(unsigned char *)space = ' ';
*(unsigned char *)tab = '\t';
prompt_(myprm, line, prlen, (ftnlen)132);
if (s_cmp(line, " ", (ftnlen)132, (ftnlen)1) == 0) {
s_copy(stmt, " ", stmt_len, (ftnlen)1);
return 0;
} else {
s_copy(stmt, line, stmt_len, (ftnlen)132);
}
/* Get rid of any of those nasty old tabs. */
replch_(line, tab, space, line, (ftnlen)132, (ftnlen)1, (ftnlen)1, (
ftnlen)132);
/* Read succeeding lines. Indent to the length of the original */
/* prompt. Add the input line to the current statement. Quit when: */
/* - A delimiter is encountered. (Return the statement */
/* up to the delimiter.) */
/* - A blank line or an error is encountered. (Return */
/* a blank statement.) */
while(i_indx(stmt, delim, stmt_len, (ftnlen)1) == 0) {
prompt_(blank, line, prlen, (ftnlen)132);
replch_(line, tab, space, line, (ftnlen)132, (ftnlen)1, (ftnlen)1, (
ftnlen)132);
if (s_cmp(line, " ", (ftnlen)132, (ftnlen)1) == 0) {
s_copy(stmt, " ", stmt_len, (ftnlen)1);
return 0;
} else {
suffix_(line, &c__1, stmt, (ftnlen)132, stmt_len);
}
}
/* If we made it to here, we encountered a delimiter. Take the */
/* entire statement up to the character before the delimiter. */
end = i_indx(stmt, delim, stmt_len, (ftnlen)1);
s_copy(stmt + (end - 1), " ", stmt_len - (end - 1), (ftnlen)1);
return 0;
} /* rdstmn_ */
