/* $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 CHCKDO ( Check presence of required input parameters ) */
/* Subroutine */ int chckdo_(char *indtvl, integer *outtvl, integer *param,
integer *nparam, char *doval, ftnlen indtvl_len, ftnlen doval_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer l;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen), repmc_(char *, char *, char *, char *, ftnlen,
ftnlen, ftnlen, ftnlen);
logical found;
extern integer rtrim_(char *, ftnlen), isrchi_(integer *, integer *,
integer *);
extern logical return_(void);
char errlin[512];
extern /* Subroutine */ int setmsg_(char *, ftnlen), sigerr_(char *,
ftnlen), inssub_(char *, char *, integer *, char *, ftnlen,
ftnlen, ftnlen), chkout_(char *, ftnlen);
/* $ Abstract */
/* This routine is a module of the MKSPK program. It checks whether */
/* set of input parameters specified in the DATA_ORDER value */
/* contains all parameters required for a given input data type and */
/* output SPK type. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* MKSPK User's Guide */
/* $ Keywords */
/* None. */
/* $ Declarations */
/* $ Abstract */
/* MKSPK Include File. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Author_and_Institution */
/* N.G. Khavenson (IKI RAS, Russia) */
/* B.V. Semenov (NAIF, JPL) */
/* $ Version */
/* - Version 1.3.0, 08-FEB-2012 (BVS). */
/* Added TLE coverage and ID keywords. Added default TLE pad */
/* parameter. */
/* - Version 1.2.0, 16-JAN-2008 (BVS). */
/* Added ETTMWR parameter */
/* - Version 1.1.0, 05-JUN-2001 (BVS). */
/* Added MAXDEG parameter. */
/* - Version 1.0.4, 21-MAR-2001 (BVS). */
/* Added parameter for command line flag '-append' indicating */
/* that appending to an existing output file was requested. */
/* Added corresponding setup file keyword ('APPEND_TO_OUTPUT'.) */
/* Added parameters for yes and no values of this keyword. */
/* - Version 1.0.3, 28-JAN-2000 (BVS). */
/* Added parameter specifying number of supported input data */
/* types and parameter specifying number of supported output SPK */
/* types */
/* - Version 1.0.2, 22-NOV-1999 (NGK). */
/* Added parameters for two-line elements processing. */
/* - Version 1.0.1, 18-MAR-1999 (BVS). */
/* Added usage, help and template displays. Corrected comments. */
/* - Version 1.0.0, 8-SEP-1998 (NGK). */
/* -& */
/* Begin Include Section: MKSPK generic parameters. */
/* Maximum number of states allowed per one segment. */
/* String size allocation parameters */
/* Length of buffer for input text processing */
/* Length of a input text line */
/* Length of file name and comment line */
/* Length of string for keyword value processing */
/* Length of string for word processing */
/* Length of data order parameters string */
/* Length of string reserved as delimiter */
/* Numbers of different parameters */
/* Maximum number of allowed comment lines. */
/* Reserved number of input parameters */
/* Full number of delimiters */
/* Number of delimiters that may appear in time string */
/* Command line flags */
/* Setup file keywords reserved values */
/* Standard YES and NO values for setup file keywords. */
/* Number of supported input data types and input DATA TYPE */
/* reserved values. */
/* Number of supported output SPK data types -- this version */
/* supports SPK types 5, 8, 9, 10, 12, 13, 15 and 17. */
/* End of input record marker */
/* Maximum allowed polynomial degree. The value of this parameter */
/* is consistent with the ones in SPKW* routines. */
/* Special time wrapper tag for input times given as ET seconds past */
/* J2000 */
/* Default TLE pad, 1/2 day in seconds. */
/* End Include Section: MKSPK generic parameters. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* INDTVL I Input data type. */
/* OUTTVL I Output spk type. */
/* PARAM I Array of DATA_ORDER parameter IDs */
/* NPARAM I Number of not zero parameter IDs in PARAM */
/* DOVAL I Array of parameter values acceptable in DATA_ORDER */
/* $ Detailed_Input */
/* INDTVL is the input data type. See MKSPK.INC for the */
/* current list of supported input data types. */
/* OUTTVL is the output SPK type. Currently supported output */
/* SPK types are 5, 8, 9, 12, 13, 15 and 17. */
/* PARAM is an integer array containing indexes of the */
/* recognizable input parameters present in the */
/* DATA_ORDER keyword value in the order in which they */
/* were provided in that value. */
/* NPARAM is the number of elements in PARAM. */
/* DOVAL is an array containing complete set recognizable */
/* input parameters. (see main module for the current */
/* list) */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* If the set of input parameters does not contain some of the */
/* required tokens, then the error 'SPICE(MISSINGDATAORDERTK)' */
/* will be signalled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.G. Khavenson (IKI RAS, Russia) */
/* B.V. Semenov (NAIF, JPL) */
/* $ Version */
/* - Version 1.0.3, 29-MAR-1999 (NGK). */
/* Added comments. */
/* - Version 1.0.2, 18-MAR-1999 (BVS). */
/* Corrected comments. */
/* - Version 1.0.1, 13-JAN-1999 (BVS). */
/* Modified error messages. */
/* - Version 1.0.0, 08-SEP-1998 (NGK). */
/* -& */
/* $ Index_Entries */
/* Check adequacy of the DATA_ORDER defined in MKSPK setup */
/* -& */
/* SPICELIB functions */
/* Parameters INELTP, INSTTP, INEQTP containing supported */
/* input data type names and keyword parameter KDATOR are declared */
/* in the include file. */
/* Local variables */
/* Error line variable. Size LINLEN declared in the include file. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("CHCKDO", (ftnlen)6);
}
/* Check if EPOCH is present among specified input parameters. */
if (isrchi_(&c__1, nparam, param) == 0) {
setmsg_("Set of input data parameters specified in the setup file ke"
"yword '#' must contain token '#' designating epoch position "
"in the input data records.", (ftnlen)145);
errch_("#", "DATA_ORDER", (ftnlen)1, (ftnlen)10);
errch_("#", doval, (ftnlen)1, doval_len);
sigerr_("SPICE(MISSINGEPOCHTOKEN)", (ftnlen)24);
}
/* Check whether all necessary input parameters are present */
/* according to the input data type. */
found = TRUE_;
s_copy(errlin, "The following token(s) designating input parameter(s) re"
"quired when input data type is '#' is(are) missing in the value "
"of the setup file keyword '#':", (ftnlen)512, (ftnlen)150);
if (s_cmp(indtvl, "ELEMENTS", rtrim_(indtvl, indtvl_len), (ftnlen)8) == 0)
{
/* Input type is ELEMENTS. Check whether eccentricity, */
/* inclination, argument of periapsis and longitude of ascending */
/* node are present in the input data. */
repmc_(errlin, "#", "ELEMENTS", errlin, (ftnlen)512, (ftnlen)1, (
ftnlen)8, (ftnlen)512);
repmc_(errlin, "#", "DATA_ORDER", errlin, (ftnlen)512, (ftnlen)1, (
ftnlen)10, (ftnlen)512);
if (isrchi_(&c__9, nparam, param) == 0) {
i__1 = rtrim_(errlin, (ftnlen)512) + 1;
inssub_(errlin, " '#',", &i__1, errlin, (ftnlen)512, (ftnlen)5, (
ftnlen)512);
repmc_(errlin, "#", doval + (doval_len << 3), errlin, (ftnlen)512,
(ftnlen)1, doval_len, (ftnlen)512);
found = FALSE_;
}
for (l = 13; l <= 15; ++l) {
if (isrchi_(&l, nparam, param) == 0) {
i__1 = rtrim_(errlin, (ftnlen)512) + 1;
inssub_(errlin, " '#',", &i__1, errlin, (ftnlen)512, (ftnlen)
5, (ftnlen)512);
repmc_(errlin, "#", doval + (l - 1) * doval_len, errlin, (
ftnlen)512, (ftnlen)1, doval_len, (ftnlen)512);
found = FALSE_;
}
}
} else if (s_cmp(indtvl, "STATES", rtrim_(indtvl, indtvl_len), (ftnlen)6)
== 0) {
/* Input type is STATES. Check whether all state vector */
/* components are present in the input data. */
repmc_(errlin, "#", "STATES", errlin, (ftnlen)512, (ftnlen)1, (ftnlen)
6, (ftnlen)512);
repmc_(errlin, "#", "DATA_ORDER", errlin, (ftnlen)512, (ftnlen)1, (
ftnlen)10, (ftnlen)512);
for (l = 2; l <= 7; ++l) {
if (isrchi_(&l, nparam, param) == 0) {
i__1 = rtrim_(errlin, (ftnlen)512) + 1;
inssub_(errlin, " '#',", &i__1, errlin, (ftnlen)512, (ftnlen)
5, (ftnlen)512);
repmc_(errlin, "#", doval + (l - 1) * doval_len, errlin, (
ftnlen)512, (ftnlen)1, doval_len, (ftnlen)512);
found = FALSE_;
}
}
} else if (s_cmp(indtvl, "EQ_ELEMENTS", rtrim_(indtvl, indtvl_len), (
ftnlen)11) == 0) {
/* Input type is EQ_ELEMENTS. Check whether all equinoctial */
/* elements are present in the input data. */
repmc_(errlin, "#", "EQ_ELEMENTS", errlin, (ftnlen)512, (ftnlen)1, (
ftnlen)11, (ftnlen)512);
repmc_(errlin, "#", "DATA_ORDER", errlin, (ftnlen)512, (ftnlen)1, (
ftnlen)10, (ftnlen)512);
for (l = 21; l <= 29; ++l) {
if (isrchi_(&l, nparam, param) == 0) {
i__1 = rtrim_(errlin, (ftnlen)512) + 1;
inssub_(errlin, " '#',", &i__1, errlin, (ftnlen)512, (ftnlen)
5, (ftnlen)512);
repmc_(errlin, "#", doval + (l - 1) * doval_len, errlin, (
ftnlen)512, (ftnlen)1, doval_len, (ftnlen)512);
found = FALSE_;
}
}
}
/* Signal the error if any of the required parameters wasn't found. */
if (! found) {
i__1 = rtrim_(errlin, (ftnlen)512) - 1;
s_copy(errlin + i__1, ".", rtrim_(errlin, (ftnlen)512) - i__1, (
ftnlen)1);
setmsg_(errlin, (ftnlen)512);
sigerr_("SPICE(MISSINGDATAORDERTK)", (ftnlen)25);
}
/* Check whether all necessary input parameters are present */
/* according to the output SPK type. */
found = TRUE_;
if (*outtvl == 17) {
/* Output type is 17. Verify if dM/dt, dNOD/dt, dPER/dt */
/* exist in input data. */
s_copy(errlin, "The following token(s) designating input parameter(s"
") required when output SPK type is 17 is(are) missing in the"
" value of the setup file keyword '#':", (ftnlen)512, (ftnlen)
149);
for (l = 27; l <= 29; ++l) {
if (isrchi_(&l, nparam, param) == 0) {
i__1 = rtrim_(errlin, (ftnlen)512) + 1;
inssub_(errlin, " '#',", &i__1, errlin, (ftnlen)512, (ftnlen)
5, (ftnlen)512);
repmc_(errlin, "#", doval + (l - 1) * doval_len, errlin, (
ftnlen)512, (ftnlen)1, doval_len, (ftnlen)512);
found = FALSE_;
}
}
}
/* Signal the error if any of the required parameters wasn't found. */
if (! found) {
i__1 = rtrim_(errlin, (ftnlen)512) - 1;
s_copy(errlin + i__1, ".", rtrim_(errlin, (ftnlen)512) - i__1, (
ftnlen)1);
setmsg_(errlin, (ftnlen)512);
sigerr_("SPICE(MISSINGDATAORDERTK)", (ftnlen)25);
}
chkout_("CHCKDO", (ftnlen)6);
return 0;
} /* chckdo_ */
/* $Procedure FRMCHG (Frame Change) */
/* Subroutine */ int frmchg_(integer *frame1, integer *frame2, doublereal *et,
doublereal *xform)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10,
i__11, i__12, i__13;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
integer node;
logical done;
integer cent, this__;
extern /* Subroutine */ int zznofcon_(doublereal *, integer *, integer *,
integer *, integer *, char *, ftnlen);
integer i__, j, k, l, frame[10];
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer class__;
logical found;
integer relto;
doublereal trans[504] /* was [6][6][14] */, trans2[72] /*
was [6][6][2] */;
extern logical failed_(void);
integer cmnode;
extern integer isrchi_(integer *, integer *, integer *);
integer clssid;
extern /* Subroutine */ int frinfo_(integer *, integer *, integer *,
integer *, logical *), frmget_(integer *, doublereal *,
doublereal *, integer *, logical *);
logical gotone;
extern /* Subroutine */ int chkout_(char *, ftnlen);
char errmsg[1840];
extern /* Subroutine */ int sigerr_(char *, ftnlen), setmsg_(char *,
ftnlen);
doublereal tempxf[36] /* was [6][6] */;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int invstm_(doublereal *, doublereal *), zzmsxf_(
doublereal *, integer *, doublereal *);
integer inc, get, put;
/* $ Abstract */
/* Return the state transformation matrix from one */
/* frame to another. */
/* $ 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 */
/* $ 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. */
/* ALL indicates any of the above classes. This parameter */
/* is used in APIs that fetch information about frames */
/* of a specified class. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 4.0.0, 08-MAY-2012 (NJB) */
/* The parameter ALL was added to support frame fetch APIs. */
/* - SPICELIB Version 3.0.0, 28-MAY-2004 (NJB) */
/* The parameter DYN was added to support the dynamic frame class. */
/* - SPICELIB Version 2.0.0, 12-DEC-1996 (WLT) */
/* Various unused frames types were removed and the */
/* frame time TK was added. */
/* - SPICELIB Version 1.0.0, 10-DEC-1995 (WLT) */
/* -& */
/* End of INCLUDE file frmtyp.inc */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* FRAME1 I the frame id-code for some reference frame */
/* FRAME2 I the frame id-code for some reference frame */
/* ET I an epoch in TDB seconds past J2000. */
/* XFORM O a state transformation matrix */
/* $ Detailed_Input */
/* FRAME1 is the frame id-code in which some states are known. */
/* FRAME2 is the frame id-code for some frame in which you */
/* would like to represent states. */
/* ET is the epoch at which to compute the state */
/* transformation matrix. This epoch should be */
/* in TDB seconds past the ephemeris epoch of J2000. */
/* $ Detailed_Output */
/* XFORM is a 6 x 6 state transformation matrix that can */
/* be used to transform states relative to the frame */
/* corresponding to frame FRAME2 to states relative */
/* to the frame FRAME2. More explicitly, if STATE */
/* is the state of some object relative to the reference */
/* frame of FRAME1 then STATE2 is the state of the */
/* same object relative to FRAME2 where STATE2 is */
/* computed via the subroutine call below */
/* CALL MXVG ( XFORM, STATE, 6, 6, STATE2 ) */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If either of the reference frames is unrecognized, the error */
/* SPICE(UNKNOWNFRAME) will be signaled. */
/* 2) If the auxiliary information needed to compute a non-inertial */
/* frame is not available an error will be diagnosed and signaled */
/* by a routine in the call tree of this routine. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine allows you to compute the state transformation matrix */
/* between two reference frames. */
/* The currently supported reference frames are IAU bodyfixed frames */
/* and inertial reference frames. */
/* $ Examples */
/* Example 1. Suppose that you have a state STATE1 at epoch ET */
/* relative to FRAME1 and wish to determine its representation */
/* STATE2 relative to FRAME2. The following subroutine calls */
/* would suffice to make this transformation. */
/* CALL FRMCHG ( FRAME1, FRAME2, ET, XFORM ) */
/* CALL MXVG ( XFORM, STATE1, 6, 6, STATE2 ) */
/* Example 2. Suppose that you have the angular velocity, W, of some */
/* rotation relative to FRAME1 at epoch ET and that you wish to */
/* express this angular velocity with respect to FRAME2. The */
/* following subroutines will suffice to perform this computation. */
/* CALL FRMCHG ( FRAME1, FRAME2, ET, STXFRM ) */
/* Recall that a state transformation matrix has the following form. */
/* - - */
/* | | */
/* | R 0 | */
/* | | */
/* | | */
/* | dR | */
/* | -- R | */
/* | dt | */
/* | | */
/* - - */
/* The velocity of an arbitrary point P undergoing rotation with the */
/* angular velocity W is W x P */
/* Thus the velocity of P in FRAME2 is: */
/* dR */
/* -- P + R*(W x P ) */
/* dt */
/* dR t */
/* = ( -- R R P + R*(W x P) ) ( 1 ) */
/* dt */
/* dR t t */
/* But -- R is skew symmetric (simply differentiate R*R to see */
/* dt */
/* dR t */
/* this ). Hence -- R R P can be written as Ax(R*P) for some fixed */
/* dt */
/* vector A. Moreover the vector A can be read from the upper */
/* dR t */
/* triangular portion of -- R . So that equation (1) above can */
/* dt */
/* be re-written as */
/* dR t */
/* = ( -- R R*P + R*(WxP) ) */
/* dt */
/* = Ax(R*P) + R*W x R*P */
/* = ( [A+R*W] x R*P ) */
/* From this final expression it follows that in FRAME2 the angular */
/* velocity vector is given by [A+R*W]. */
/* The code below implements these ideas. */
/* CALL FRMCHG ( FRAME1, FRAME2, ET, STXFRM ) */
/* DO I = 1, 3 */
/* DO J = 1, 3 */
/* RT ( I, J ) = STXFRM ( I, J ) */
/* DRDT( I, J ) = STXFRM ( I+3, J ) */
/* END DO */
/* END DO */
/* CALL MXMT ( DRDT, R, AMATRIX ) */
/* Read the angular velocity of R from the skew symmetric matrix */
/* dR t */
/* -- R */
/* dt */
/* Recall that if A has components A1, A2, A3 then the matrix */
/* corresponding to the cross product linear mapping is: */
/* - - */
/* | 0 -A3 A2 | */
/* | | */
/* | A3 0 -A1 | */
/* | | */
/* | -A2 A1 0 | */
/* - - */
/* A(1) = -AMATRIX(2,3) */
/* A(2) = AMATRIX(1,3) */
/* A(3) = -AMATRIX(1,2) */
/* CALL MXV ( R, W1, W ) */
/* CALL VADD ( A, W, W2 ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 2.0.1, 16-JAN-2014 (NJB) */
/* Corrected equation 1 in header comments. Corrected */
/* numerous spelling errors in comments. */
/* - SPICELIB Version 2.0.0, 14-DEC-2008 (NJB) */
/* Upgraded long error message associated with frame */
/* connection failure. */
/* - SPICELIB Version 1.1.0, 25-JUL-1996 (WLT) */
/* Bug Fix: */
/* The previous edition of the routine had a bug in the */
/* first pass of the DO WHILE that looks for a frame */
/* in the chain of frames associated with FRAME2 that is */
/* in common with the chain of frames for FRAME1. */
/* On machines where variables are created as static */
/* variables, this error could lead to finding a frame */
/* when a legitimate path between FRAME1 and FRAME2 */
/* did not exist. */
/* - SPICELIB Version 1.0.1, 06-MAR-1996 (WLT) */
/* An typo was fixed in the Brief I/O section. It used */
/* to say TDT instead of the correct time system TDB. */
/* - SPICELIB Version 1.0.0, 28-SEP-1994 (WLT) */
/* -& */
/* $ Index_Entries */
/* Transform states from one frame to another */
/* -& */
/* SPICE functions */
/* Local Parameters */
/* The root of all reference frames is J2000 (Frame ID = 1). */
/* Local Variables */
/* TRANS contains the transformations from FRAME1 to FRAME2 */
/* TRANS(1...6,1...6,I) has the transformation from FRAME(I) */
/* to FRAME(I+1). We make extra room in TRANS because we */
/* plan to add transformations beyond the obvious chain from */
/* FRAME1 to a root node. */
/* TRANS2 is used to store intermediate transformations from */
/* FRAME2 to some node in the chain from FRAME1 to PCK or */
/* INERTL frames. */
/* FRAME contains the frames we transform from in going from */
/* FRAME1 to FRAME2. FRAME(1) = FRAME1 by construction. */
/* NODE counts the number of transformations needed to go */
/* from FRAME1 to FRAME2. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
chkin_("FRMCHG", (ftnlen)6);
/* Do the obvious thing first. If FRAME1 and FRAME2 are the */
/* same then we simply return the identity matrix. */
if (*frame1 == *frame2) {
for (i__ = 1; i__ <= 6; ++i__) {
xform[(i__1 = i__ + i__ * 6 - 7) < 36 && 0 <= i__1 ? i__1 :
s_rnge("xform", i__1, "frmchg_", (ftnlen)376)] = 1.;
i__1 = i__ - 1;
for (j = 1; j <= i__1; ++j) {
xform[(i__2 = i__ + j * 6 - 7) < 36 && 0 <= i__2 ? i__2 :
s_rnge("xform", i__2, "frmchg_", (ftnlen)379)] = 0.;
xform[(i__2 = j + i__ * 6 - 7) < 36 && 0 <= i__2 ? i__2 :
s_rnge("xform", i__2, "frmchg_", (ftnlen)380)] = 0.;
}
}
chkout_("FRMCHG", (ftnlen)6);
return 0;
}
/* Now perform the obvious check to make sure that both */
/* frames are recognized. */
frinfo_(frame1, ¢, &class__, &clssid, &found);
if (! found) {
setmsg_("The number # is not a recognized id-code for a reference fr"
"ame. ", (ftnlen)64);
errint_("#", frame1, (ftnlen)1);
sigerr_("SPICE(UNKNOWNFRAME)", (ftnlen)19);
chkout_("FRMCHG", (ftnlen)6);
return 0;
}
frinfo_(frame2, ¢, &class__, &clssid, &found);
if (! found) {
setmsg_("The number # is not a recognized id-code for a reference fr"
"ame. ", (ftnlen)64);
errint_("#", frame2, (ftnlen)1);
sigerr_("SPICE(UNKNOWNFRAME)", (ftnlen)19);
chkout_("FRMCHG", (ftnlen)6);
return 0;
}
node = 1;
frame[(i__1 = node - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge("frame", i__1,
"frmchg_", (ftnlen)423)] = *frame1;
found = TRUE_;
/* Follow the chain of transformations until we run into */
/* one that transforms to J2000 (frame id = 1) or we hit FRAME2. */
while(frame[(i__1 = node - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge("frame",
i__1, "frmchg_", (ftnlen)429)] != 1 && node < 10 && frame[(i__2 =
node - 1) < 10 && 0 <= i__2 ? i__2 : s_rnge("frame", i__2, "frmc"
"hg_", (ftnlen)429)] != *frame2 && found) {
/* Find out what transformation is available for this */
/* frame. */
frmget_(&frame[(i__1 = node - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge(
"frame", i__1, "frmchg_", (ftnlen)437)], et, &trans[(i__2 = (
node * 6 + 1) * 6 - 42) < 504 && 0 <= i__2 ? i__2 : s_rnge(
"trans", i__2, "frmchg_", (ftnlen)437)], &frame[(i__3 = node)
< 10 && 0 <= i__3 ? i__3 : s_rnge("frame", i__3, "frmchg_", (
ftnlen)437)], &found);
if (found) {
/* We found a transformation matrix. TRANS(1,1,NODE) */
/* now contains the transformation from FRAME(NODE) */
/* to FRAME(NODE+1). We need to look up the information */
/* for the next NODE. */
++node;
}
}
done = frame[(i__1 = node - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge("frame",
i__1, "frmchg_", (ftnlen)453)] == 1 || frame[(i__2 = node - 1) <
10 && 0 <= i__2 ? i__2 : s_rnge("frame", i__2, "frmchg_", (ftnlen)
453)] == *frame2 || ! found;
while(! done) {
/* The only way to get to this point is to have run out of */
/* room in the array of reference frame transformation */
/* buffers. We will now build the transformation from */
/* the previous NODE to whatever the next node in the */
/* chain is. We'll do this until we get to one of the */
/* root classes or we run into FRAME2. */
frmget_(&frame[(i__1 = node - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge(
"frame", i__1, "frmchg_", (ftnlen)467)], et, &trans[(i__2 = (
node * 6 + 1) * 6 - 42) < 504 && 0 <= i__2 ? i__2 : s_rnge(
"trans", i__2, "frmchg_", (ftnlen)467)], &relto, &found);
if (found) {
/* Recall that TRANS(1,1,NODE-1) contains the transformation */
/* from FRAME(NODE-1) to FRAME(NODE). We are going to replace */
/* FRAME(NODE) with the frame indicated by RELTO. This means */
/* that TRANS(1,1,NODE-1) should be replaced with the */
/* transformation from FRAME(NODE) to RELTO. */
frame[(i__1 = node - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge("frame",
i__1, "frmchg_", (ftnlen)478)] = relto;
zzmsxf_(&trans[(i__1 = ((node - 1) * 6 + 1) * 6 - 42) < 504 && 0
<= i__1 ? i__1 : s_rnge("trans", i__1, "frmchg_", (ftnlen)
479)], &c__2, tempxf);
for (i__ = 1; i__ <= 6; ++i__) {
for (j = 1; j <= 6; ++j) {
trans[(i__1 = i__ + (j + (node - 1) * 6) * 6 - 43) < 504
&& 0 <= i__1 ? i__1 : s_rnge("trans", i__1, "frm"
"chg_", (ftnlen)483)] = tempxf[(i__2 = i__ + j * 6
- 7) < 36 && 0 <= i__2 ? i__2 : s_rnge("tempxf",
i__2, "frmchg_", (ftnlen)483)];
}
}
}
/* We are done if the class of the last frame is J2000 */
/* or if the last frame is FRAME2 or if we simply couldn't get */
/* another transformation. */
done = frame[(i__1 = node - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge(
"frame", i__1, "frmchg_", (ftnlen)493)] == 1 || frame[(i__2 =
node - 1) < 10 && 0 <= i__2 ? i__2 : s_rnge("frame", i__2,
"frmchg_", (ftnlen)493)] == *frame2 || ! found;
}
/* Right now we have the following situation. We have in hand */
/* a collection of transformations between frames. (Assuming */
/* that is that NODE .GT. 1. If NODE .EQ. 1 then we have */
/* no transformations computed yet. */
/* TRANS(1...6, 1...6, 1 ) transforms FRAME1 to FRAME(2) */
/* TRANS(1...6, 1...6, 2 ) transforms FRAME(2) to FRAME(3) */
/* TRANS(1...6, 1...6, 3 ) transforms FRAME(3) to FRAME(4) */
/* . */
/* . */
/* . */
/* TRANS(1...6, 1...6, NODE-1 ) transforms FRAME(NODE-1) */
/* to FRAME(NODE) */
/* One of the following situations is true. */
/* 1) FRAME(NODE) is the root of all frames, J2000. */
/* 2) FRAME(NODE) is the same as FRAME2 */
/* 3) There is no transformation from FRAME(NODE) to another */
/* more fundamental frame. The chain of transformations */
/* from FRAME1 stops at FRAME(NODE). This means that the */
/* "frame atlas" is incomplete because we can't get to the */
/* root frame. */
/* We now have to do essentially the same thing for FRAME2. */
if (frame[(i__1 = node - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge("frame",
i__1, "frmchg_", (ftnlen)531)] == *frame2) {
/* We can handle this one immediately with the private routine */
/* ZZMSXF which multiplies a series of state transformation */
/* matrices. */
i__1 = node - 1;
zzmsxf_(trans, &i__1, xform);
chkout_("FRMCHG", (ftnlen)6);
return 0;
}
/* We didn't luck out above. So we follow the chain of */
/* transformation for FRAME2. Note that at the moment the */
/* chain of transformations from FRAME2 to other frames */
/* does not share a node in the chain for FRAME1. */
/* ( GOTONE = .FALSE. ) . */
this__ = *frame2;
gotone = FALSE_;
/* First see if there is any chain to follow. */
done = this__ == 1;
/* Set up the matrices TRANS2(,,1) and TRANS(,,2) and set up */
/* PUT and GET pointers so that we know where to GET the partial */
/* transformation from and where to PUT partial results. */
if (! done) {
for (k = 1; k <= 2; ++k) {
for (i__ = 1; i__ <= 3; ++i__) {
for (j = 4; j <= 6; ++j) {
trans2[(i__1 = i__ + (j + k * 6) * 6 - 43) < 72 && 0 <=
i__1 ? i__1 : s_rnge("trans2", i__1, "frmchg_", (
ftnlen)568)] = 0.;
}
}
}
put = 1;
get = 1;
inc = 1;
}
/* Follow the chain of transformations until we run into */
/* one that transforms to the root frame or we land in the */
/* chain of nodes for FRAME1. */
/* Note that this time we will simply keep track of the full */
/* translation from FRAME2 to the last node. */
while(! done) {
/* Find out what transformation is available for this */
/* frame. */
if (this__ == *frame2) {
/* This is the first pass, just put the transformation */
/* directly into TRANS2(,,PUT). */
frmget_(&this__, et, &trans2[(i__1 = (put * 6 + 1) * 6 - 42) < 72
&& 0 <= i__1 ? i__1 : s_rnge("trans2", i__1, "frmchg_", (
ftnlen)597)], &relto, &found);
if (found) {
this__ = relto;
get = put;
put += inc;
inc = -inc;
cmnode = isrchi_(&this__, &node, frame);
gotone = cmnode > 0;
}
} else {
/* Fetch the transformation into a temporary spot TEMPXF */
frmget_(&this__, et, tempxf, &relto, &found);
if (found) {
/* Next multiply TEMPXF on the right by the last partial */
/* product (in TRANS2(,,GET) ). We do this in line because */
/* we can cut down the number of multiplies to 3/8 of the */
/* normal result of MXMG. For a discussion of why this */
/* works see ZZMSXF. */
for (i__ = 1; i__ <= 3; ++i__) {
for (j = 1; j <= 3; ++j) {
trans2[(i__1 = i__ + (j + put * 6) * 6 - 43) < 72 &&
0 <= i__1 ? i__1 : s_rnge("trans2", i__1,
"frmchg_", (ftnlen)626)] = tempxf[(i__2 = i__
- 1) < 36 && 0 <= i__2 ? i__2 : s_rnge("temp"
"xf", i__2, "frmchg_", (ftnlen)626)] * trans2[(
i__3 = (j + get * 6) * 6 - 42) < 72 && 0 <=
i__3 ? i__3 : s_rnge("trans2", i__3, "frmchg_"
, (ftnlen)626)] + tempxf[(i__4 = i__ + 5) <
36 && 0 <= i__4 ? i__4 : s_rnge("tempxf",
i__4, "frmchg_", (ftnlen)626)] * trans2[(i__5
= (j + get * 6) * 6 - 41) < 72 && 0 <= i__5 ?
i__5 : s_rnge("trans2", i__5, "frmchg_", (
ftnlen)626)] + tempxf[(i__6 = i__ + 11) < 36
&& 0 <= i__6 ? i__6 : s_rnge("tempxf", i__6,
"frmchg_", (ftnlen)626)] * trans2[(i__7 = (j
+ get * 6) * 6 - 40) < 72 && 0 <= i__7 ? i__7
: s_rnge("trans2", i__7, "frmchg_", (ftnlen)
626)];
}
}
for (i__ = 4; i__ <= 6; ++i__) {
for (j = 1; j <= 3; ++j) {
trans2[(i__1 = i__ + (j + put * 6) * 6 - 43) < 72 &&
0 <= i__1 ? i__1 : s_rnge("trans2", i__1,
"frmchg_", (ftnlen)635)] = tempxf[(i__2 = i__
- 1) < 36 && 0 <= i__2 ? i__2 : s_rnge("temp"
"xf", i__2, "frmchg_", (ftnlen)635)] * trans2[(
i__3 = (j + get * 6) * 6 - 42) < 72 && 0 <=
i__3 ? i__3 : s_rnge("trans2", i__3, "frmchg_"
, (ftnlen)635)] + tempxf[(i__4 = i__ + 5) <
36 && 0 <= i__4 ? i__4 : s_rnge("tempxf",
i__4, "frmchg_", (ftnlen)635)] * trans2[(i__5
= (j + get * 6) * 6 - 41) < 72 && 0 <= i__5 ?
i__5 : s_rnge("trans2", i__5, "frmchg_", (
ftnlen)635)] + tempxf[(i__6 = i__ + 11) < 36
&& 0 <= i__6 ? i__6 : s_rnge("tempxf", i__6,
"frmchg_", (ftnlen)635)] * trans2[(i__7 = (j
+ get * 6) * 6 - 40) < 72 && 0 <= i__7 ? i__7
: s_rnge("trans2", i__7, "frmchg_", (ftnlen)
635)] + tempxf[(i__8 = i__ + 17) < 36 && 0 <=
i__8 ? i__8 : s_rnge("tempxf", i__8, "frmchg_"
, (ftnlen)635)] * trans2[(i__9 = (j + get * 6)
* 6 - 39) < 72 && 0 <= i__9 ? i__9 : s_rnge(
"trans2", i__9, "frmchg_", (ftnlen)635)] +
tempxf[(i__10 = i__ + 23) < 36 && 0 <= i__10 ?
i__10 : s_rnge("tempxf", i__10, "frmchg_", (
ftnlen)635)] * trans2[(i__11 = (j + get * 6) *
6 - 38) < 72 && 0 <= i__11 ? i__11 : s_rnge(
"trans2", i__11, "frmchg_", (ftnlen)635)] +
tempxf[(i__12 = i__ + 29) < 36 && 0 <= i__12 ?
i__12 : s_rnge("tempxf", i__12, "frmchg_", (
ftnlen)635)] * trans2[(i__13 = (j + get * 6) *
6 - 37) < 72 && 0 <= i__13 ? i__13 : s_rnge(
"trans2", i__13, "frmchg_", (ftnlen)635)];
}
}
/* Note that we don't have to compute the upper right */
/* hand block. It's already set to zero by construction. */
/* Finally we can just copy the lower right hand block */
/* from the upper left hand block of the matrix. */
for (i__ = 4; i__ <= 6; ++i__) {
k = i__ - 3;
for (j = 4; j <= 6; ++j) {
l = j - 3;
trans2[(i__1 = i__ + (j + put * 6) * 6 - 43) < 72 &&
0 <= i__1 ? i__1 : s_rnge("trans2", i__1,
"frmchg_", (ftnlen)654)] = trans2[(i__2 = k +
(l + put * 6) * 6 - 43) < 72 && 0 <= i__2 ?
i__2 : s_rnge("trans2", i__2, "frmchg_", (
ftnlen)654)];
}
}
/* Adjust GET and PUT so that GET points to the slots */
/* where we just stored the result of our multiply and */
/* so that PUT points to the next available storage */
/* locations. */
get = put;
put += inc;
inc = -inc;
this__ = relto;
cmnode = isrchi_(&this__, &node, frame);
gotone = cmnode > 0;
}
}
/* See if we have a common node and determine whether or not */
/* we are done with this loop. */
done = this__ == 1 || gotone || ! found;
}
/* There are two possible scenarios. Either the chain of */
/* transformations from FRAME2 ran into a node in the chain for */
/* FRAME1 or it didn't. (The common node might very well be */
/* the root node.) If we didn't run into a common one, then */
/* the two chains don't intersect and there is no way to */
/* get from FRAME1 to FRAME2. */
if (! gotone) {
zznofcon_(et, frame1, &frame[(i__1 = node - 1) < 10 && 0 <= i__1 ?
i__1 : s_rnge("frame", i__1, "frmchg_", (ftnlen)697)], frame2,
&this__, errmsg, (ftnlen)1840);
if (failed_()) {
/* We were unable to create the error message. This */
/* unfortunate situation could arise if a frame kernel */
/* is corrupted. */
chkout_("FRMCHG", (ftnlen)6);
return 0;
}
/* The normal case: signal an error with a descriptive long */
/* error message. */
setmsg_(errmsg, (ftnlen)1840);
sigerr_("SPICE(NOFRAMECONNECT)", (ftnlen)21);
chkout_("FRMCHG", (ftnlen)6);
return 0;
}
/* Recall that we have the following. */
/* TRANS(1...6, 1...6, 1 ) transforms FRAME(1) to FRAME(2) */
/* TRANS(1...6, 1...6, 2 ) transforms FRAME(2) to FRAME(3) */
/* TRANS(1...6, 1...6, 3 ) transforms FRAME(3) to FRAME(4) */
/* TRANS(1...6, 1...6, CMNODE-1) transforms FRAME(CMNODE-1) */
/* to FRAME(CMNODE) */
/* and that TRANS2(1,1,GET) transforms from FRAME2 to CMNODE. */
/* Hence the inverse of TRANS2(1,1,GET) transforms from CMNODE */
/* to FRAME2. */
/* If we compute the inverse of TRANS2 and store it in */
/* the next available slot of TRANS (.i.e. TRANS(1,1,CMNODE) */
/* we can simply apply our custom routine that multiplies a */
/* sequence of transformation matrices together to get the */
/* result from FRAME1 to FRAME2. */
invstm_(&trans2[(i__1 = (get * 6 + 1) * 6 - 42) < 72 && 0 <= i__1 ? i__1 :
s_rnge("trans2", i__1, "frmchg_", (ftnlen)740)], &trans[(i__2 = (
cmnode * 6 + 1) * 6 - 42) < 504 && 0 <= i__2 ? i__2 : s_rnge(
"trans", i__2, "frmchg_", (ftnlen)740)]);
zzmsxf_(trans, &cmnode, xform);
chkout_("FRMCHG", (ftnlen)6);
return 0;
} /* frmchg_ */
/* 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 ZZDDHF2H ( Private --- DDH Filename to Handle ) */
/* Subroutine */ int zzddhf2h_(char *fname, integer *ftabs, integer *ftamh,
integer *ftarc, integer *ftbff, integer *fthan, char *ftnam, integer *
ftrtm, doublereal *ftmnm, integer *nft, integer *utcst, integer *
uthan, logical *utlck, integer *utlun, integer *nut, logical *exists,
logical *opened, integer *handle, logical *found, doublereal *mnm,
ftnlen fname_len, ftnlen ftnam_len)
{
/* System generated locals */
olist o__1;
cllist cl__1;
inlist ioin__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), f_inqu(inlist *), f_open(
olist *), f_clos(cllist *);
/* Local variables */
integer unit;
extern doublereal zzddhmnm_(integer *);
extern /* Subroutine */ int zzddhgtu_(integer *, integer *, logical *,
integer *, integer *, integer *), zzddhrmu_(integer *, integer *,
integer *, integer *, logical *, integer *, integer *);
integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer rchar;
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen);
extern integer rtrim_(char *, ftnlen);
extern logical failed_(void);
extern integer isrchi_(integer *, integer *, integer *);
logical locopn;
extern /* Subroutine */ int sigerr_(char *, ftnlen);
integer uindex;
logical locexs;
extern /* Subroutine */ int chkout_(char *, ftnlen), setmsg_(char *,
ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* SPICE Private routine intended solely for the support of SPICE */
/* routines. Users should not call this routine directly due */
/* to the volatile nature of this routine. */
/* Convert filename to a handle. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* PRIVATE */
/* $ Declarations */
/* $ Abstract */
/* Parameter declarations for the DAF/DAS handle manager. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* DAF, DAS */
/* $ Keywords */
/* PRIVATE */
/* $ Particulars */
/* This include file contains parameters defining limits and */
/* integer codes that are utilized in the DAF/DAS handle manager */
/* routines. */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 2.5.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 2.4.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 2.3.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 2.2.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 2.1.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 2.0.0, 12-APR-2012 (BVS) */
/* Increased FTSIZE (from 1000 to 5000). */
/* - SPICELIB Version 1.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 1.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 1.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 1.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 1.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 1.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 1.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 1.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 1.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 1.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 1.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 1.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 1.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 1.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 1.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 1.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 1.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 1.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 1.0.1, 17-JUL-2002 */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 1.0.0, 07-NOV-2001 */
/* -& */
/* Unit and file table size parameters. */
/* FTSIZE is the maximum number of files (DAS and DAF) that a */
/* user may have open simultaneously. */
/* RSVUNT is the number of units protected from being locked */
/* to a particular handle by ZZDDHHLU. */
/* SCRUNT is the number of units protected for use by scratch */
/* files. */
/* UTSIZE is the maximum number of logical units this manager */
/* will utilize at one time. */
/* Access method enumeration. These parameters are used to */
/* identify which access method is associated with a particular */
/* handle. They need to be synchronized with the STRAMH array */
/* defined in ZZDDHGSD in the following fashion: */
/* STRAMH ( READ ) = 'READ' */
/* STRAMH ( WRITE ) = 'WRITE' */
/* STRAMH ( SCRTCH ) = 'SCRATCH' */
/* STRAMH ( NEW ) = 'NEW' */
/* These values are used in the file table variable FTAMH. */
/* Binary file format enumeration. These parameters are used to */
/* identify which binary file format is associated with a */
/* particular handle. They need to be synchronized with the STRBFF */
/* array defined in ZZDDHGSD in the following fashion: */
/* STRBFF ( BIGI3E ) = 'BIG-IEEE' */
/* STRBFF ( LTLI3E ) = 'LTL-IEEE' */
/* STRBFF ( VAXGFL ) = 'VAX-GFLT' */
/* STRBFF ( VAXDFL ) = 'VAX-DFLT' */
/* These values are used in the file table variable FTBFF. */
/* Some random string lengths... more documentation required. */
/* For now this will have to suffice. */
/* Architecture enumeration. These parameters are used to identify */
/* which file architecture is associated with a particular handle. */
/* They need to be synchronized with the STRARC array defined in */
/* ZZDDHGSD in the following fashion: */
/* STRARC ( DAF ) = 'DAF' */
/* STRARC ( DAS ) = 'DAS' */
/* These values will be used in the file table variable FTARC. */
/* For the following environments, record length is measured in */
/* characters (bytes) with eight characters per double precision */
/* number. */
/* Environment: Sun, Sun FORTRAN */
/* Source: Sun Fortran Programmer's Guide */
/* Environment: PC, MS FORTRAN */
/* Source: Microsoft Fortran Optimizing Compiler User's Guide */
/* Environment: Macintosh, Language Systems FORTRAN */
/* Source: Language Systems FORTRAN Reference Manual, */
/* Version 1.2, page 12-7 */
/* Environment: PC/Linux, g77 */
/* Source: Determined by experiment. */
/* Environment: PC, Lahey F77 EM/32 Version 4.0 */
/* Source: Lahey F77 EM/32 Language Reference Manual, */
/* page 144 */
/* Environment: HP-UX 9000/750, FORTRAN/9000 Series 700 computers */
/* Source: FORTRAN/9000 Reference-Series 700 Computers, */
/* page 5-110 */
/* Environment: NeXT Mach OS (Black Hardware), */
/* Absoft Fortran Version 3.2 */
/* Source: NAIF Program */
/* The following parameter defines the size of a string used */
/* to store a filenames on this target platform. */
/* The following parameter controls the size of the character record */
/* buffer used to read data from non-native files. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* FNAME I Name of the file to convert to a handle. */
/* FTABS, */
/* FTAMH, */
/* FTARC, */
/* FTBFF, */
/* FTHAN, */
/* FTNAM, */
/* FTRTM, */
/* FTMNM I File table. */
/* NFT I Number of entries in the file table. */
/* UTCST, */
/* UTHAN, */
/* UTLCK, */
/* UTLUN I/O Unit table. */
/* NUT I/O Number of entries in the unit table. */
/* EXISTS O Logical indicating if FNAME exists. */
/* OPENED O Logical indicating if FNAME is opened. */
/* HANDLE O Handle associated with FNAME. */
/* FOUND O Logical indicating if FNAME's HANDLE was found. */
/* MNM O Unique DP (Magic NuMber) associated with FNAME. */
/* $ Detailed_Input */
/* FNAME is the name of the file to locate in the file table. */
/* FTABS, */
/* FTAMH, */
/* FTARC, */
/* FTBFF, */
/* FTHAN, */
/* FTNAM, */
/* FTRTM, */
/* FTMNM are the arrays respectively containing the absolute */
/* value of the handle, access method, architecture, */
/* binary file format, handle, name, RTRIM and */
/* magic number columns of the file table. */
/* NFT is the number of entries in the file table. */
/* UTCST, */
/* UTHAN, */
/* UTLCK, */
/* UTLUN are the arrays respectively containing the cost, */
/* handle, locked, and logical unit columns of the unit */
/* table. */
/* NUT is the number of entries in the unit table. */
/* $ Detailed_Output */
/* UTCST, */
/* UTHAN, */
/* UTLCK, */
/* UTLUN are the arrays respectively containing the cost, */
/* handle, locked, and logical unit columns of the unit */
/* table. If ZZDDHF2H requires a logical unit, then */
/* it will borrow one from the unit table. Depending */
/* on the state of the table passed in from the caller */
/* one of three possible scenarios may occur (Recall */
/* that 'zero-cost' rows are ones whose units are */
/* reserved with RESLUN and not currently connected */
/* to any file.) */
/* A 'zero-cost' row exists in the table, in */
/* which case the row is used temporarily and */
/* may be removed depending on the number of entries */
/* in the file table (NFT). */
/* The unit table is full (NUT=UTSIZE), in which */
/* case the unit with the lowest cost that is not */
/* locked to its handle will be disconnected, used, */
/* and then returned to the table as a 'zero-cost' */
/* row before returning to the caller. */
/* The unit table is not full (NUT<UTSIZE) and there */
/* are no 'zero-cost' rows. In this case NUT is */
/* temporarily increased by one, and the new row */
/* is used. After this routine no longer requires */
/* the unit, depending on the number of entries in */
/* the file table (NFT) the row may be left in the */
/* table as a 'zero-handle' row or removed entirely. */
/* In the event an error is signaled, the contents of the */
/* unit table are placed into a usable state before */
/* returning to the caller. */
/* NUT is the number of entries in the unit table. Since */
/* this routine borrows a unit from the unit table, which */
/* may involve allocation of a new unit, this value may */
/* change. */
/* EXISTS is a logical if set to TRUE, indicates that FNAME */
/* exists. If FALSE, FNAME does not exist. In the event */
/* an exception is signaled the value is undefined. */
/* OPENED is a logical if set to TRUE, indicates that FNAME */
/* is opened and attached to a logical unit. If FALSE, */
/* FNAME is not attached to a unit. In the event an */
/* exception is signaled the value is undefined. */
/* HANDLE is the handle in the file table associated with */
/* FNAME. If FOUND is FALSE, then HANDLE is returned as */
/* 0. */
/* FOUND is a logical if TRUE indicates that FNAME was found */
/* in the file table. If FALSE indicates that it was not */
/* located. */
/* MNM is a unique (enough) DP number -- the Magic NuMber -- */
/* associated with FNAME computed by this examining the */
/* file contents. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If any of the INQUIRE statments this routine performs fail, */
/* the error SPICE(INQUIREFAILED) is signaled. FOUND is set to */
/* FALSE and HANDLE to 0. */
/* 2) If the attempt to open FNAME fails, then SPICE(FILEOPENFAILED) */
/* is signaled. FOUND is set to FALSE, and HANDLE to 0. */
/* 3) If FNAME is determined not to be loaded into the file table */
/* then FOUND is set to FALSE and HANDLE is set to 0. */
/* $ Files */
/* If the file named by FNAME is not connected to a logical unit, */
/* this routine will open it for direct access to complete its */
/* examination. */
/* $ Particulars */
/* This routine encapsulates the logic necessary to determine if */
/* a particular filename names a file already loaded into the */
/* DAF/DAS handle manager. If it discovers the file is loaded, */
/* the routine returns the handle to the caller. */
/* $ Examples */
/* See ZZDDHFNH for sample usage. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* E.D. Wright (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 3.0.0, 26-APR-2012 (BVS) */
/* Changed calling sequence to include FTMNM and MNM. Change */
/* algorithm to compute MNM and use it to bypass n^2 INQUIREs */
/* for files opened for READ access, if possible. */
/* - SPICELIB Version 2.0.1, 24-APR-2003 (EDW) */
/* Added MAC-OSX-F77 to the list of platforms */
/* that require READONLY to read write protected */
/* kernels. */
/* - SPICELIB Version 2.0.0, 05-AUG-2002 (FST) */
/* Bug fix: this module was updated to allow proper loading */
/* of read-only files on VAX environments. */
/* - SPICELIB Version 1.0.0, 04-OCT-2001 (FST) */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 05-AUG-2002 (FST) */
/* An OPEN statement that is exercised by this module under */
/* certain circumstances, failed to pass the non-standard */
/* READONLY option for the VAX environments. This had the */
/* undesirable side-effect of not permitting files available */
/* only for READ access to be opened. */
/* This file was promoted from a standard portable module */
/* to a master file. */
/* -& */
/* SPICELIB Functions */
/* Local Variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZDDHF2H", (ftnlen)8);
}
/* First check to see if FNAME is blank. If so, set FOUND to .FALSE. */
/* and return. ZZDDHOPN prevents any blank filenames from being */
/* loaded into the file table. */
if (s_cmp(fname, " ", fname_len, (ftnlen)1) == 0) {
*found = FALSE_;
*handle = 0;
*opened = FALSE_;
*exists = FALSE_;
chkout_("ZZDDHF2H", (ftnlen)8);
return 0;
}
/* Start by trimming the file name in preparation for the INQUIRE. */
rchar = rtrim_(fname, fname_len);
/* Now INQUIRE on the input file FNAME. */
ioin__1.inerr = 1;
ioin__1.infilen = rchar;
ioin__1.infile = fname;
ioin__1.inex = &locexs;
ioin__1.inopen = &locopn;
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);
/* Check IOSTAT for failure. */
if (iostat != 0) {
*found = FALSE_;
*handle = 0;
setmsg_("INQUIRE failed. Value of IOSTAT was #.", (ftnlen)38);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(INQUIREFAILED)", (ftnlen)20);
chkout_("ZZDDHF2H", (ftnlen)8);
return 0;
}
/* First, set some of the output arguments. Remember, some */
/* systems consider non-existant files as open. Compensate for */
/* this unusual behavior. */
*exists = locexs;
*opened = locopn && *exists;
/* Now check to see if the file exists. If it does not, then */
/* set FOUND to false and HANDLE to 0 as non-existant files */
/* can not possibly be present in the file table. */
if (! (*exists)) {
*found = FALSE_;
*handle = 0;
chkout_("ZZDDHF2H", (ftnlen)8);
return 0;
}
/* Now check to see if the file is opened. If it is, we need to */
/* determine whether or not the logical unit to which it is */
/* attached is present in the unit table. */
if (*opened) {
/* Since the file is opened, see if we can find its unit */
/* in the unit table. */
uindex = isrchi_(&unit, nut, utlun);
/* When UINDEX is 0, the file is opened, but not by */
/* the DAF/DAS handle manager. Set FOUND to FALSE, HANDLE */
/* to 0, and return to the caller. */
if (uindex == 0) {
*handle = 0;
*found = FALSE_;
chkout_("ZZDDHF2H", (ftnlen)8);
return 0;
}
/* If we end up here, then we found UNIT in the unit table. */
/* Set FOUND to TRUE if the handle associated with UNIT is */
/* non-zero. */
*handle = uthan[uindex - 1];
*found = *handle != 0;
chkout_("ZZDDHF2H", (ftnlen)8);
return 0;
}
/* At this point, we took action for all simple cases. Now */
/* we need to find out if FNAME is one of the files in the */
/* file table that isn't open. To determine this, we open FNAME, */
/* and then INQUIRE on every file in the table. To do this, we */
/* need a unit. Get one. */
zzddhgtu_(utcst, uthan, utlck, utlun, nut, &uindex);
if (failed_()) {
*handle = 0;
*found = FALSE_;
chkout_("ZZDDHF2H", (ftnlen)8);
return 0;
}
/* Now open the file (which we know exists and isn't open). Since */
/* we effectively are just borrowing this unit, we are not going to */
/* set UTHAN or UTCST from the defaults that ZZDDHGTU sets up. */
o__1.oerr = 1;
o__1.ounit = utlun[uindex - 1];
o__1.ofnmlen = rchar;
o__1.ofnm = fname;
o__1.orl = 1024;
o__1.osta = "OLD";
o__1.oacc = "DIRECT";
o__1.ofm = 0;
o__1.oblnk = 0;
iostat = f_open(&o__1);
/* Check IOSTAT. */
if (iostat != 0) {
/* Since an error has occurred, set FOUND to false and HANDLE */
/* to 0. */
*found = FALSE_;
*handle = 0;
/* Close the unit and remove it from the unit table. */
cl__1.cerr = 0;
cl__1.cunit = utlun[uindex - 1];
cl__1.csta = 0;
f_clos(&cl__1);
zzddhrmu_(&uindex, nft, utcst, uthan, utlck, utlun, nut);
/* Signal the error and return. */
setmsg_("Attempt to open file '#' failed. Value of IOSTAT was #.", (
ftnlen)55);
errch_("#", fname, (ftnlen)1, fname_len);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEOPENFAILED)", (ftnlen)21);
chkout_("ZZDDHF2H", (ftnlen)8);
return 0;
}
/* Get a unique enough DP number -- the Magic NuMber (MNM) ;) -- for */
/* this file. */
*mnm = zzddhmnm_(&utlun[uindex - 1]);
/* Now loop through all the files in the file table. Unfortunately */
/* we have no other choice. */
i__ = 1;
*found = FALSE_;
while(i__ <= *nft && ! (*found)) {
/* If this file's magic number is non-zero and is different from */
/* the magic number of the currently checked, opened-for-READ */
/* file, we will declare that these files are not the same file */
/* and will skip INQUIRE. In all other cases we will do INQUIRE */
/* and check UNITs. */
if (*mnm != 0. && (*mnm != ftmnm[i__ - 1] && ftamh[i__ - 1] == 1)) {
/* These files are not the same file. Clear IOSTAT and set */
/* UNIT to not match the UNIT of the input file. */
iostat = 0;
unit = utlun[uindex - 1] + 1;
} else {
/* Do the INQUIRE. ;( */
ioin__1.inerr = 1;
ioin__1.infilen = ftrtm[i__ - 1];
ioin__1.infile = ftnam + (i__ - 1) * ftnam_len;
ioin__1.inex = &locexs;
ioin__1.inopen = &locopn;
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);
}
/* Check IOSTAT. */
if (iostat != 0) {
/* Since we have an error condition, set FOUND to FALSE */
/* and HANDLE to 0. */
*found = FALSE_;
*handle = 0;
/* Close the unit and clean up the unit table. */
cl__1.cerr = 0;
cl__1.cunit = utlun[uindex - 1];
cl__1.csta = 0;
f_clos(&cl__1);
zzddhrmu_(&uindex, nft, utcst, uthan, utlck, utlun, nut);
/* Signal the error and return. */
setmsg_("INQUIRE failed. Value of IOSTAT was #.", (ftnlen)38);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(INQUIREFAILED)", (ftnlen)20);
chkout_("ZZDDHF2H", (ftnlen)8);
return 0;
}
/* Now check to see if FILE exists, is currently open. and */
/* its UNIT matches UTLUN(UINDEX). */
if (locexs && locopn && unit == utlun[uindex - 1]) {
*handle = fthan[i__ - 1];
*found = TRUE_;
/* Otherwise, continue searching. */
} else {
++i__;
}
}
/* Check to see if we found the file in the file table. */
if (! (*found)) {
*handle = 0;
}
/* Close the unit and clean up the unit table. */
cl__1.cerr = 0;
cl__1.cunit = utlun[uindex - 1];
cl__1.csta = 0;
f_clos(&cl__1);
zzddhrmu_(&uindex, nft, utcst, uthan, utlck, utlun, nut);
chkout_("ZZDDHF2H", (ftnlen)8);
return 0;
} /* zzddhf2h_ */
/* $Procedure ZZREFCH1 (Reference frame Change) */
/* Subroutine */ int zzrefch1_(integer *frame1, integer *frame2, doublereal *
et, doublereal *rotate)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6, i__7;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
integer node;
logical done;
integer cent, this__;
extern /* Subroutine */ int zzrotgt1_(integer *, doublereal *, doublereal
*, integer *, logical *), zznofcon_(doublereal *, integer *,
integer *, integer *, integer *, char *, ftnlen);
integer i__, j, frame[10];
extern /* Subroutine */ int chkin_(char *, ftnlen), ident_(doublereal *);
integer class__;
logical found;
integer relto;
extern /* Subroutine */ int xpose_(doublereal *, doublereal *), zzrxr_(
doublereal *, integer *, doublereal *);
extern logical failed_(void);
integer cmnode;
extern integer isrchi_(integer *, integer *, integer *);
integer clssid;
extern /* Subroutine */ int frinfo_(integer *, integer *, integer *,
integer *, logical *);
logical gotone;
char errmsg[1840];
extern /* Subroutine */ int chkout_(char *, ftnlen), setmsg_(char *,
ftnlen), errint_(char *, integer *, ftnlen), sigerr_(char *,
ftnlen);
extern logical return_(void);
doublereal tmprot[9] /* was [3][3] */;
integer inc, get;
doublereal rot[126] /* was [3][3][14] */;
integer put;
doublereal rot2[18] /* was [3][3][2] */;
/* $ Abstract */
/* Return the transformation matrix from one */
/* frame to another. */
/* $ 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 */
/* $ 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 */
/* -------- --- -------------------------------------------------- */
/* FRAME1 I the frame id-code for some reference frame */
/* FRAME2 I the frame id-code for some reference frame */
/* ET I an epoch in TDB seconds past J2000. */
/* ROTATE O a rotation matrix */
/* $ Detailed_Input */
/* FRAME1 is the frame id-code in which some positions */
/* are known. */
/* FRAME2 is the frame id-code for some frame in which you */
/* would like to represent positions. */
/* ET is the epoch at which to compute the transformation */
/* matrix. This epoch should be in TDB seconds past */
/* the ephemeris epoch of J2000. */
/* $ Detailed_Output */
/* ROTATE is a 3 x 3 rotaion matrix that can be used to */
/* transform positions relative to the frame */
/* correspsonding to frame FRAME2 to positions relative */
/* to the frame FRAME2. More explicitely, if POS is */
/* the position of some object relative to the */
/* reference frame of FRAME1 then POS2 is the position */
/* of the same object relative to FRAME2 where POS2 is */
/* computed via the subroutine call below */
/* CALL MXV ( ROTATE, POS, POS2 ) */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If either of the reference frames is unrecognized, the error */
/* SPICE(UNKNOWNFRAME) will be signalled. */
/* 2) If the auxillary information needed to compute a non-inertial */
/* frame is not available an error will be diagnosed and signalled */
/* by a routine in the call tree of this routine. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine allows you to compute the rotation matrix */
/* between two reference frames. */
/* $ Examples */
/* Suppose that you have a position POS1 at epoch ET */
/* relative to FRAME1 and wish to determine its representation */
/* POS2 relative to FRAME2. The following subroutine calls */
/* would suffice to make this rotation. */
/* CALL REFCHG ( FRAME1, FRAME2, ET, ROTATE ) */
/* CALL MXV ( ROTATE, POS1, POS2 ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 2.0.0, 14-DEC-2008 (NJB) */
/* Upgraded long error message associated with frame */
/* connection failure. */
/* - SPICELIB Version 1.2.0, 26-APR-2004 (NJB) */
/* Another typo was corrected in the long error message, and */
/* in a comment. */
/* - SPICELIB Version 1.1.0, 23-MAY-2000 (WLT) */
/* A typo was corrected in the long error message. */
/* - SPICELIB Version 1.0.0, 9-JUL-1998 (WLT) */
/* -& */
/* $ Index_Entries */
/* Rotate positions from one frame to another */
/* -& */
/* SPICE functions */
/* Local Paramters */
/* The root of all reference frames is J2000 (Frame ID = 1). */
/* Local Variables */
/* ROT contains the rotations from FRAME1 to FRAME2 */
/* ROT(1...3,1...3,I) has the rotation from FRAME(I) */
/* to FRAME(I+1). We make extra room in ROT because we */
/* plan to add rotations beyond the obvious chain from */
/* FRAME1 to a root node. */
/* ROT2 is used to store intermediate rotation from */
/* FRAME2 to some node in the chain from FRAME1 to PCK or */
/* INERTL frames. */
/* FRAME contains the frames we transform from in going from */
/* FRAME1 to FRAME2. FRAME(1) = FRAME1 by construction. */
/* NODE counts the number of rotations needed to go */
/* from FRAME1 to FRAME2. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
chkin_("ZZREFCH1", (ftnlen)8);
/* Do the obvious thing first. If FRAME1 and FRAME2 are the */
/* same then we simply return the identity matrix. */
if (*frame1 == *frame2) {
ident_(rotate);
chkout_("ZZREFCH1", (ftnlen)8);
return 0;
}
/* Now perform the obvious check to make sure that both */
/* frames are recognized. */
frinfo_(frame1, ¢, &class__, &clssid, &found);
if (! found) {
setmsg_("The number # is not a recognized id-code for a reference fr"
"ame. ", (ftnlen)64);
errint_("#", frame1, (ftnlen)1);
sigerr_("SPICE(UNKNOWNFRAME)", (ftnlen)19);
chkout_("ZZREFCH1", (ftnlen)8);
return 0;
}
frinfo_(frame2, ¢, &class__, &clssid, &found);
if (! found) {
setmsg_("The number # is not a recognized id-code for a reference fr"
"ame. ", (ftnlen)64);
errint_("#", frame2, (ftnlen)1);
sigerr_("SPICE(UNKNOWNFRAME)", (ftnlen)19);
chkout_("ZZREFCH1", (ftnlen)8);
return 0;
}
node = 1;
frame[(i__1 = node - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge("frame", i__1,
"zzrefch1_", (ftnlen)287)] = *frame1;
found = TRUE_;
/* Follow the chain of rotations until we run into */
/* one that rotates to J2000 (frame id = 1) or we hit FRAME2. */
while(frame[(i__1 = node - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge("frame",
i__1, "zzrefch1_", (ftnlen)293)] != 1 && node < 10 && frame[(i__2
= node - 1) < 10 && 0 <= i__2 ? i__2 : s_rnge("frame", i__2,
"zzrefch1_", (ftnlen)293)] != *frame2 && found) {
/* Find out what rotation is available for this */
/* frame. */
zzrotgt1_(&frame[(i__1 = node - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge(
"frame", i__1, "zzrefch1_", (ftnlen)301)], et, &rot[(i__2 = (
node * 3 + 1) * 3 - 12) < 126 && 0 <= i__2 ? i__2 : s_rnge(
"rot", i__2, "zzrefch1_", (ftnlen)301)], &frame[(i__3 = node)
< 10 && 0 <= i__3 ? i__3 : s_rnge("frame", i__3, "zzrefch1_",
(ftnlen)301)], &found);
if (found) {
/* We found a rotation matrix. ROT(1,1,NODE) */
/* now contains the rotation from FRAME(NODE) */
/* to FRAME(NODE+1). We need to look up the information */
/* for the next NODE. */
++node;
}
}
done = frame[(i__1 = node - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge("frame",
i__1, "zzrefch1_", (ftnlen)317)] == 1 || frame[(i__2 = node - 1) <
10 && 0 <= i__2 ? i__2 : s_rnge("frame", i__2, "zzrefch1_", (
ftnlen)317)] == *frame2 || ! found;
while(! done) {
/* The only way to get to this point is to have run out of */
/* room in the array of reference frame rotation */
/* buffers. We will now build the rotation from */
/* the previous NODE to whatever the next node in the */
/* chain is. We'll do this until we get to one of the */
/* root classes or we run into FRAME2. */
zzrotgt1_(&frame[(i__1 = node - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge(
"frame", i__1, "zzrefch1_", (ftnlen)331)], et, &rot[(i__2 = (
node * 3 + 1) * 3 - 12) < 126 && 0 <= i__2 ? i__2 : s_rnge(
"rot", i__2, "zzrefch1_", (ftnlen)331)], &relto, &found);
if (found) {
/* Recall that ROT(1,1,NODE-1) contains the rotation */
/* from FRAME(NODE-1) to FRAME(NODE). We are going to replace */
/* FRAME(NODE) with the frame indicated by RELTO. This means */
/* that ROT(1,1,NODE-1) should be replaced with the */
/* rotation from FRAME(NODE) to RELTO. */
frame[(i__1 = node - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge("frame",
i__1, "zzrefch1_", (ftnlen)342)] = relto;
zzrxr_(&rot[(i__1 = ((node - 1) * 3 + 1) * 3 - 12) < 126 && 0 <=
i__1 ? i__1 : s_rnge("rot", i__1, "zzrefch1_", (ftnlen)
343)], &c__2, tmprot);
for (i__ = 1; i__ <= 3; ++i__) {
for (j = 1; j <= 3; ++j) {
rot[(i__1 = i__ + (j + (node - 1) * 3) * 3 - 13) < 126 &&
0 <= i__1 ? i__1 : s_rnge("rot", i__1, "zzrefch1_"
, (ftnlen)347)] = tmprot[(i__2 = i__ + j * 3 - 4)
< 9 && 0 <= i__2 ? i__2 : s_rnge("tmprot", i__2,
"zzrefch1_", (ftnlen)347)];
}
}
}
/* We are done if the class of the last frame is J2000 */
/* or if the last frame is FRAME2 or if we simply couldn't get */
/* another rotation. */
done = frame[(i__1 = node - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge(
"frame", i__1, "zzrefch1_", (ftnlen)357)] == 1 || frame[(i__2
= node - 1) < 10 && 0 <= i__2 ? i__2 : s_rnge("frame", i__2,
"zzrefch1_", (ftnlen)357)] == *frame2 || ! found;
}
/* Right now we have the following situation. We have in hand */
/* a collection of rotations between frames. (Assuming */
/* that is that NODE .GT. 1. If NODE .EQ. 1 then we have */
/* no rotations computed yet. */
/* ROT(1...3, 1...3, 1 ) rotates FRAME1 to FRAME(2) */
/* ROT(1...3, 1...3, 2 ) rotates FRAME(2) to FRAME(3) */
/* ROT(1...3, 1...3, 3 ) rotates FRAME(3) to FRAME(4) */
/* . */
/* . */
/* . */
/* ROT(1...3, 1...3, NODE-1 ) rotates FRAME(NODE-1) */
/* to FRAME(NODE) */
/* One of the following situations is true. */
/* 1) FRAME(NODE) is the root of all frames, J2000. */
/* 2) FRAME(NODE) is the same as FRAME2 */
/* 3) There is no rotation from FRAME(NODE) to another */
/* more fundamental frame. The chain of rotations */
/* from FRAME1 stops at FRAME(NODE). This means that the */
/* "frame atlas" is incomplete because we can't get to the */
/* root frame. */
/* We now have to do essentially the same thing for FRAME2. */
if (frame[(i__1 = node - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge("frame",
i__1, "zzrefch1_", (ftnlen)395)] == *frame2) {
/* We can handle this one immediately with the private routine */
/* ZZRXR which multiplies a series of matrices. */
i__1 = node - 1;
zzrxr_(rot, &i__1, rotate);
chkout_("ZZREFCH1", (ftnlen)8);
return 0;
}
/* We didn't luck out above. So we follow the chain of */
/* rotation for FRAME2. Note that at the moment the */
/* chain of rotations from FRAME2 to other frames */
/* does not share a node in the chain for FRAME1. */
/* ( GOTONE = .FALSE. ) . */
this__ = *frame2;
gotone = FALSE_;
/* First see if there is any chain to follow. */
done = this__ == 1;
/* Set up the matrices ROT2(,,1) and ROT(,,2) and set up */
/* PUT and GET pointers so that we know where to GET the partial */
/* rotation from and where to PUT partial results. */
if (! done) {
put = 1;
get = 1;
inc = 1;
}
/* Follow the chain of rotations until we run into */
/* one that rotates to the root frame or we land in the */
/* chain of nodes for FRAME1. */
/* Note that this time we will simply keep track of the full */
/* rotation from FRAME2 to the last node. */
while(! done) {
/* Find out what rotation is available for this */
/* frame. */
if (this__ == *frame2) {
/* This is the first pass, just put the rotation */
/* directly into ROT2(,,PUT). */
zzrotgt1_(&this__, et, &rot2[(i__1 = (put * 3 + 1) * 3 - 12) < 18
&& 0 <= i__1 ? i__1 : s_rnge("rot2", i__1, "zzrefch1_", (
ftnlen)452)], &relto, &found);
if (found) {
this__ = relto;
get = put;
put += inc;
inc = -inc;
cmnode = isrchi_(&this__, &node, frame);
gotone = cmnode > 0;
}
} else {
/* Fetch the rotation into a temporary spot TMPROT */
zzrotgt1_(&this__, et, tmprot, &relto, &found);
if (found) {
/* Next multiply TMPROT on the right by the last partial */
/* product (in ROT2(,,GET) ). We do this in line. */
for (i__ = 1; i__ <= 3; ++i__) {
for (j = 1; j <= 3; ++j) {
rot2[(i__1 = i__ + (j + put * 3) * 3 - 13) < 18 && 0
<= i__1 ? i__1 : s_rnge("rot2", i__1, "zzref"
"ch1_", (ftnlen)478)] = tmprot[(i__2 = i__ - 1)
< 9 && 0 <= i__2 ? i__2 : s_rnge("tmprot",
i__2, "zzrefch1_", (ftnlen)478)] * rot2[(i__3
= (j + get * 3) * 3 - 12) < 18 && 0 <= i__3 ?
i__3 : s_rnge("rot2", i__3, "zzrefch1_", (
ftnlen)478)] + tmprot[(i__4 = i__ + 2) < 9 &&
0 <= i__4 ? i__4 : s_rnge("tmprot", i__4,
"zzrefch1_", (ftnlen)478)] * rot2[(i__5 = (j
+ get * 3) * 3 - 11) < 18 && 0 <= i__5 ? i__5
: s_rnge("rot2", i__5, "zzrefch1_", (ftnlen)
478)] + tmprot[(i__6 = i__ + 5) < 9 && 0 <=
i__6 ? i__6 : s_rnge("tmprot", i__6, "zzrefc"
"h1_", (ftnlen)478)] * rot2[(i__7 = (j + get *
3) * 3 - 10) < 18 && 0 <= i__7 ? i__7 :
s_rnge("rot2", i__7, "zzrefch1_", (ftnlen)478)
];
}
}
/* Adjust GET and PUT so that GET points to the slots */
/* where we just stored the result of our multiply and */
/* so that PUT points to the next available storage */
/* locations. */
get = put;
put += inc;
inc = -inc;
this__ = relto;
cmnode = isrchi_(&this__, &node, frame);
gotone = cmnode > 0;
}
}
/* See if we have a common node and determine whether or not */
/* we are done with this loop. */
done = this__ == 1 || gotone || ! found;
}
/* There are two possible scenarios. Either the chain of */
/* rotations from FRAME2 ran into a node in the chain for */
/* FRAME1 or it didn't. (The common node might very well be */
/* the root node.) If we didn't run into a common one, then */
/* the two chains don't intersect and there is no way to */
/* get from FRAME1 to FRAME2. */
if (! gotone) {
zznofcon_(et, frame1, &frame[(i__1 = node - 1) < 10 && 0 <= i__1 ?
i__1 : s_rnge("frame", i__1, "zzrefch1_", (ftnlen)525)],
frame2, &this__, errmsg, (ftnlen)1840);
if (failed_()) {
/* We were unable to create the error message. This */
/* unfortunate situation could arise if a frame kernel */
/* is corrupted. */
chkout_("ZZREFCH1", (ftnlen)8);
return 0;
}
/* The normal case: signal an error with a descriptive long */
/* error message. */
setmsg_(errmsg, (ftnlen)1840);
sigerr_("SPICE(NOFRAMECONNECT)", (ftnlen)21);
chkout_("ZZREFCH1", (ftnlen)8);
return 0;
}
/* Recall that we have the following. */
/* ROT(1...3, 1...3, 1 ) rotates FRAME(1) to FRAME(2) */
/* ROT(1...3, 1...3, 2 ) rotates FRAME(2) to FRAME(3) */
/* ROT(1...3, 1...3, 3 ) rotates FRAME(3) to FRAME(4) */
/* ROT(1...3, 1...3, CMNODE-1) rotates FRAME(CMNODE-1) */
/* to FRAME(CMNODE) */
/* and that ROT2(1,1,GET) rotates from FRAME2 to CMNODE. */
/* Hence the inverse of ROT2(1,1,GET) rotates from CMNODE */
/* to FRAME2. */
/* If we compute the inverse of ROT2 and store it in */
/* the next available slot of ROT (.i.e. ROT(1,1,CMNODE) */
/* we can simply apply our custom routine that multiplies a */
/* sequence of rotation matrices together to get the */
/* result from FRAME1 to FRAME2. */
xpose_(&rot2[(i__1 = (get * 3 + 1) * 3 - 12) < 18 && 0 <= i__1 ? i__1 :
s_rnge("rot2", i__1, "zzrefch1_", (ftnlen)568)], &rot[(i__2 = (
cmnode * 3 + 1) * 3 - 12) < 126 && 0 <= i__2 ? i__2 : s_rnge(
"rot", i__2, "zzrefch1_", (ftnlen)568)]);
zzrxr_(rot, &cmnode, rotate);
chkout_("ZZREFCH1", (ftnlen)8);
return 0;
} /* zzrefch1_ */
/* $Procedure DASA2L ( DAS, address to physical location ) */
/* Subroutine */ int dasa2l_(integer *handle, integer *type__, integer *
addrss, integer *clbase, integer *clsize, integer *recno, integer *
wordno)
{
/* Initialized data */
static integer next[3] = { 2,3,1 };
static integer prev[3] = { 3,1,2 };
static integer nw[3] = { 1024,128,256 };
static integer rngloc[3] = { 3,5,7 };
static logical first = TRUE_;
static integer nfiles = 0;
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Local variables */
static integer free, nrec, fidx;
static logical fast;
static integer unit, i__, range[2], tbhan[20];
extern /* Subroutine */ int chkin_(char *, ftnlen);
static integer ncomc, ncomr, ndirs;
static logical known;
static integer hiaddr;
extern /* Subroutine */ int dasham_(integer *, char *, ftnlen);
static integer tbbase[60] /* was [3][20] */;
static char access[10];
static integer dscloc, dirrec[256];
extern /* Subroutine */ int dashfs_(integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *);
static logical samfil;
static integer mxaddr;
extern integer isrchi_(integer *, integer *, integer *);
static integer tbmxad[60] /* was [3][20] */;
static logical tbfast[20];
static integer mxclrc;
extern /* Subroutine */ int dashlu_(integer *, integer *), errfnm_(char *,
integer *, ftnlen);
static integer lstrec[3];
extern /* Subroutine */ int sigerr_(char *, ftnlen);
static integer prvhan;
extern /* Subroutine */ int chkout_(char *, ftnlen);
static integer nresvc, tbsize[60] /* was [3][20] */, nxtrec;
extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen), dasrri_(integer *, integer *, integer *,
integer *, integer *);
static logical rdonly;
static integer lstwrd[3], nresvr, ntypes, curtyp, prvtyp;
/* $ Abstract */
/* Map a DAS address to a physical location in the DAS file */
/* it refers to. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* DAS */
/* $ Keywords */
/* DAS */
/* FILES */
/* TRANSFORMATION */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I DAS file handle. */
/* TYPE I Data type specifier. */
/* ADDRSS I DAS address of a word of data type TYPE. */
/* CLBASE, */
/* CLSIZE O Cluster base record number and size. */
/* RECNO, */
/* WORDNO O Record/word pair corresponding to ADDRSS. */
/* CHAR P Parameter indicating character data type. */
/* DP P Parameter indicating double precision data type. */
/* INT P Parameter indicating integer data type. */
/* $ Detailed_Input */
/* HANDLE is the file handle of an open DAS file. */
/* TYPE is a data type specifier. TYPE may be any of */
/* the parameters */
/* CHAR */
/* DP */
/* INT */
/* which indicate `character', `double precision', */
/* and `integer' respectively. */
/* ADDRSS is the address in a DAS of a word of data */
/* type TYPE. For each data type (double precision, */
/* integer, or character), addresses range */
/* from 1 to the maximum current value for that type, */
/* which is available from DAFRFR. */
/* $ Detailed_Output */
/* CLBASE, */
/* CLSIZE are, respectively, the base record number and */
/* size, in records, of the cluster containing the */
/* word corresponding to ADDRSS. The cluster spans */
/* records numbered CLBASE through CLBASE + */
/* CLSIZE - 1. */
/* RECNO, */
/* WORD are, respectively, the number of the physical */
/* record and the number of the word within the */
/* record that correspond to ADDRSS. Word numbers */
/* start at 1 and go up to NC, ND, or NI in */
/* character, double precision, or integer records */
/* respectively. */
/* $ Parameters */
/* CHAR, */
/* DP, */
/* INT are data type specifiers which indicate */
/* `character', `double precision', and `integer' */
/* respectively. These parameters are used in */
/* all DAS routines that require a data type */
/* specifier as input. */
/* $ Exceptions */
/* 1) If TYPE is not recognized, the error SPICE(DASINVALIDTYPE) */
/* will be signalled. */
/* 2) ADDRSS must be between 1 and LAST inclusive, where LAST */
/* is last address in the DAS for a word of the specified */
/* type. If ADDRSS is out of range, the error */
/* SPICE(DASNOSUCHADDRESS) will be signalled. */
/* 3) If this routine fails to find directory information for */
/* the input address, the error SPICE(NOSUCHRECORD) will be */
/* signalled. */
/* 4) If the input handle is invalid, the error will be diagnosed */
/* by routines called by this routine. */
/* If any of the above exceptions occur, the output arguments may */
/* contain bogus information. */
/* $ Files */
/* See the description of the argument HANDLE in $Detailed_Input. */
/* $ Particulars */
/* The DAS architecture allows a programmer to think of the data */
/* within a DAS file as three one-dimensional arrays: one of */
/* double precision numbers, one of integers, and one of characters. */
/* This model allows a programmer to ask the DAS system for the */
/* `nth double precision number (or integer, or character) in the */
/* file'. */
/* DAS files are Fortran direct access files, so to find the */
/* `nth double precision number', you must have the number of the */
/* record containing it and the `word number', or position, within */
/* the record of the double precision number. This routine finds */
/* the record/word number pair that specify the physical location */
/* in a DAS file corresponding to a DAS address. */
/* As opposed to DAFs, the mapping of addresses to physical locations */
/* for a DAS file depends on the organization of data in the file. */
/* Given a fixed set of DAS format parameters, the physical location */
/* of the nth double precision number can depend on how many integer */
/* and character records have been written prior to the record */
/* containing that double precision number. */
/* The cluster information output from this routine allows the */
/* caller to substantially reduce the number of directory reads */
/* required to read a from range of addresses that spans */
/* multiple physical records; the reading program only need call */
/* this routine once per cluster read, rather than once per */
/* physical record read. */
/* $ Examples */
/* 1) Use this routine to read integers from a range of */
/* addresses. This is done in the routine DASRDI. */
/* C */
/* C Decide how many integers to read. */
/* C */
/* NUMINT = LAST - FIRST + 1 */
/* NREAD = 0 */
/* C */
/* C Find out the physical location of the first */
/* C integer. If FIRST is invalid, DASA2L will take care */
/* C of the problem. */
/* C */
/* CALL DASA2L ( HANDLE, INT, FIRST, */
/* . CLBASE, CLSIZE, RECNO, WORDNO ) */
/* C */
/* C Read as much data from record RECNO as necessary. */
/* C */
/* N = MIN ( NUMINT, NWI - WORDNO + 1 ) */
/* CALL DASRRI ( HANDLE, RECNO, WORDNO, WORDNO + N-1, */
/* . DATA ) */
/* NREAD = N */
/* RECNO = RECNO + 1 */
/* C */
/* C Read from as many additional records as necessary. */
/* C */
/* DO WHILE ( NREAD .LT. NUMINT ) */
/* C */
/* C At this point, RECNO is the correct number of the */
/* C record to read from next. CLBASE is the number */
/* C of the first record of the cluster we're about */
/* C to read from. */
/* C */
/* IF ( RECNO .LT. ( CLBASE + CLSIZE ) ) THEN */
/* C */
/* C We can continue reading from the current */
/* C cluster. */
/* C */
/* N = MIN ( NUMINT - NREAD, NWI ) */
/* CALL DASRRI ( HANDLE, */
/* . RECNO, */
/* . 1, */
/* . N, */
/* . DATA ( NREAD + 1 ) ) */
/* NREAD = NREAD + N */
/* RECNO = RECNO + 1 */
/* ELSE */
/* C */
/* C We must find the next integer cluster to */
/* C read from. The first integer in this */
/* C cluster has address FIRST + NREAD. */
/* C */
/* CALL DASA2L ( HANDLE, */
/* . INT, */
/* . FIRST + NREAD, */
/* . CLBASE, */
/* . CLSIZE, */
/* . RECNO, */
/* . WORDNO ) */
/* END IF */
/* END DO */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.2.1 20-NOV-2001 (NJB) */
/* Comment fix: diagram showing directory record pointers */
/* incorrectly showed element 2 of the record as a backward */
/* pointer. The element is actually a forward pointer. */
/* - SPICELIB Version 1.2.0 03-JUL-1996 (NJB) */
/* Bug fix: calculation to determine whether file is segregated */
/* has been fixed. */
/* - SPICELIB Version 1.1.1 19-DEC-1995 (NJB) */
/* Corrected title of permuted index entry section. */
/* - SPICELIB Version 1.1.0, 03-NOV-1995 (NJB) */
/* Re-written to optimize address calculations for segregated, */
/* read-only files. */
/* - SPICELIB Version 1.0.1, 26-OCT-1993 (KRG) */
/* Fixed a typo in the $ Brief_I/O section of the header. */
/* Removed references to specific DAS file open routines in the */
/* $ Detailed_Input section of the header. This was done in order */
/* to minimize documentation changes if the DAS open routines ever */
/* change. */
/* - SPICELIB Version 1.0.0, 11-NOV-1992 (NJB) (WLT) */
/* -& */
/* $ Index_Entries */
/* map DAS logical address to physical location */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.2.0 03-JUL-1996 (NJB) */
/* Bug fix: calculation to determine whether file is segregated */
/* has been fixed. An incorrect variable name used in a bound */
/* calculation resulted in an incorrect determination of whether */
/* a file was segregated, and caused arithmetic overflow for */
/* files with large maximum addresses. */
/* In the previous version, the number of DAS words in a cluster */
/* was incorrectly calculated as the product of the maximum */
/* address of the cluster's data type and the number of words of */
/* that data type in a DAS record. The correct product involves */
/* the number of records in the cluster and the number of words of */
/* that data type in a DAS record. */
/* - SPICELIB Version 1.1.0, 03-NOV-1995 (NJB) */
/* Re-written to optimize address calculations for segregated, */
/* read-only files. */
/* - SPICELIB Version 1.0.1, 26-OCT-1993 (KRG) */
/* Fixed a typo in the $ Brief_I/O section of the header. */
/* Removed references to specific DAS file open routines in the */
/* $ Detailed_Input section of the header. This was done in order */
/* to minimize documentation changes if the DAS open routines ever */
/* change. */
/* - SPICELIB Version 1.0.0, 11-NOV-1992 (NJB) (WLT) */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Words per data record, for each data type: */
/* Directory pointer locations */
/* Directory address range locations */
/* Indices of lowest and highest addresses in a `range array': */
/* Location of first type descriptor */
/* Access word length */
/* File table size */
/* Local variables */
/* Saved variables */
/* Initial values */
/* NEXT and PREV map the DAS data type codes to their */
/* successors and predecessors, respectively. */
/* Discovery check-in is used in this routine. */
/* DAS files have the following general structure: */
/* +------------------------+ */
/* | file record | */
/* +------------------------+ */
/* | reserved records | */
/* | | */
/* +------------------------+ */
/* | comment records | */
/* | | */
/* | | */
/* | | */
/* +------------------------+ */
/* | first data directory | */
/* +------------------------+ */
/* | data records | */
/* | | */
/* | | */
/* | | */
/* | | */
/* +------------------------+ */
/* . */
/* . */
/* +------------------------+ */
/* | last data directory | */
/* +------------------------+ */
/* | data records | */
/* | | */
/* | | */
/* +------------------------+ */
/* Within each DAS data record, word numbers start at one and */
/* increase up to NWI, NWD, or NWC: the number of words in an */
/* integer, double precision, or character data record. */
/* +--------------------------------+ */
/* | | | ... | | */
/* +--------------------------------+ */
/* 1 2 NWD */
/* +--------------------------------+ */
/* | | | ... | | */
/* +--------------------------------+ */
/* 1 2 NWI */
/* +------------------------------------+ */
/* | | | ... | | */
/* +------------------------------------+ */
/* 1 2 NWC */
/* Directories are single records that describe the data */
/* types of data records that follow. The directories */
/* in a DAS file form a doubly linked list: each directory */
/* contains forward and backward pointers to the next and */
/* previous directories. */
/* Each directory also contains, for each data type, the lowest */
/* and highest logical address occurring in any of the records */
/* described by the directory. */
/* Following the pointers and address range information is */
/* a sequence of data type descriptors. These descriptors */
/* indicate the data type of data records following the */
/* directory record. Each descriptor gives the data type */
/* of a maximal set of contiguous data records, all having the */
/* same type. By `maximal set' we mean that no data records of */
/* the same type bound the set of records in question. */
/* Pictorially, the structure of a directory is as follows: */
/* +----------------------------------------------------+ */
/* | <pointers> | <address ranges> | <type descriptors> | */
/* +----------------------------------------------------+ */
/* where the <pointers> section looks like */
/* +-----------------------------------------+ */
/* | <backward pointer> | <forward pointer> | */
/* +-----------------------------------------+ */
/* the <address ranges> section looks like */
/* +-------------------------------------------+ */
/* | <char range> | <d.p. range> | <int range> | */
/* +-------------------------------------------+ */
/* and each range looks like one of: */
/* +------------------------------------------------+ */
/* | <lowest char address> | <highest char address> | */
/* +------------------------------------------------+ */
/* +------------------------------------------------+ */
/* | <lowest d.p. address> | <highest d.p. address> | */
/* +------------------------------------------------+ */
/* +------------------------------------------------+ */
/* | <lowest int address> | <highest int address> | */
/* +------------------------------------------------+ */
/* The type descriptors implement a run-length encoding */
/* scheme. The first element of the series of descriptors */
/* occupies two integers: it contains a type code and a count. */
/* The rest of the descriptors are just signed counts; the data */
/* types of the records they describe are deduced from the sign */
/* of the count and the data type of the previous descriptor. */
/* The method of finding the data type for a given descriptor */
/* in terms of its predecessor is as follows: if the sign of a */
/* descriptor is positive, the type of that descriptor is the */
/* successor of the type of the preceding descriptor in the */
/* sequence of types below. If the sign of a descriptor is */
/* negative, the type of the descriptor is the predecessor of the */
/* type of the preceding descriptor. */
/* C --> D --> I --> C */
/* For example, if the preceding type is `I', and a descriptor */
/* contains the number 16, the type of the descriptor is `C', */
/* whereas if the descriptor contained the number -800, the type */
/* of the descriptor would be `D'. */
/* Make sure the data type is valid. */
if (*type__ < 1 || *type__ > 3) {
chkin_("DASA2L", (ftnlen)6);
dashlu_(handle, &unit);
setmsg_("Invalid data type: #. File was #", (ftnlen)33);
errint_("#", type__, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(DASINVALIDTYPE)", (ftnlen)21);
chkout_("DASA2L", (ftnlen)6);
return 0;
}
/* Decide whether we're looking at the same file as we did on */
/* the last call. */
if (first) {
samfil = FALSE_;
fast = FALSE_;
prvhan = *handle;
first = FALSE_;
} else {
samfil = *handle == prvhan;
prvhan = *handle;
}
/* We have a special case if we're looking at a `fast' file */
/* that we saw on the last call. When we say a file is fast, */
/* we're implying that it's open for read access only and that it's */
/* segregated. In this case, we can do an address calculation */
/* without looking up any information from the file. */
if (samfil && fast) {
*clbase = tbbase[(i__1 = *type__ + fidx * 3 - 4) < 60 && 0 <= i__1 ?
i__1 : s_rnge("tbbase", i__1, "dasa2l_", (ftnlen)666)];
*clsize = tbsize[(i__1 = *type__ + fidx * 3 - 4) < 60 && 0 <= i__1 ?
i__1 : s_rnge("tbsize", i__1, "dasa2l_", (ftnlen)667)];
mxaddr = tbmxad[(i__1 = *type__ + fidx * 3 - 4) < 60 && 0 <= i__1 ?
i__1 : s_rnge("tbmxad", i__1, "dasa2l_", (ftnlen)668)];
hiaddr = *clsize * nw[(i__1 = *type__ - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("nw", i__1, "dasa2l_", (ftnlen)669)];
/* Make sure that ADDRSS points to an existing location. */
if (*addrss < 1 || *addrss > mxaddr) {
chkin_("DASA2L", (ftnlen)6);
dashlu_(handle, &unit);
setmsg_("ADDRSS was #; valid range for type # is # to #. File w"
"as #", (ftnlen)59);
errint_("#", addrss, (ftnlen)1);
errint_("#", type__, (ftnlen)1);
errint_("#", &c__1, (ftnlen)1);
errint_("#", &mxaddr, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(DASNOSUCHADDRESS)", (ftnlen)23);
chkout_("DASA2L", (ftnlen)6);
return 0;
}
} else {
/* If the current file is not the same one we looked at on the */
/* last call, find out whether the file is on record in our file */
/* table. Add the file to the table if necessary. Bump the */
/* oldest file in the table if there's no room. */
if (! samfil) {
fidx = isrchi_(handle, &nfiles, tbhan);
known = fidx > 0;
if (known) {
/* The file is in our list. */
fast = tbfast[(i__1 = fidx - 1) < 20 && 0 <= i__1 ? i__1 :
s_rnge("tbfast", i__1, "dasa2l_", (ftnlen)708)];
if (fast) {
/* This is a segregated, read-only file. Look up the */
/* saved information we'll need to calculate addresses. */
*clbase = tbbase[(i__1 = *type__ + fidx * 3 - 4) < 60 &&
0 <= i__1 ? i__1 : s_rnge("tbbase", i__1, "dasa2"
"l_", (ftnlen)715)];
*clsize = tbsize[(i__1 = *type__ + fidx * 3 - 4) < 60 &&
0 <= i__1 ? i__1 : s_rnge("tbsize", i__1, "dasa2"
"l_", (ftnlen)716)];
mxaddr = tbmxad[(i__1 = *type__ + fidx * 3 - 4) < 60 && 0
<= i__1 ? i__1 : s_rnge("tbmxad", i__1, "dasa2l_",
(ftnlen)717)];
hiaddr = *clsize * nw[(i__1 = *type__ - 1) < 3 && 0 <=
i__1 ? i__1 : s_rnge("nw", i__1, "dasa2l_", (
ftnlen)718)];
/* Make sure that ADDRSS points to an existing location. */
if (*addrss < 1 || *addrss > mxaddr) {
chkin_("DASA2L", (ftnlen)6);
dashlu_(handle, &unit);
setmsg_("ADDRSS was #; valid range for type # is # "
"to #. File was #", (ftnlen)60);
errint_("#", addrss, (ftnlen)1);
errint_("#", type__, (ftnlen)1);
errint_("#", &c__1, (ftnlen)1);
errint_("#", &mxaddr, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(DASNOSUCHADDRESS)", (ftnlen)23);
chkout_("DASA2L", (ftnlen)6);
return 0;
}
}
/* FAST is set. */
}
/* KNOWN is set. */
}
/* SAMFIL, FAST, and KNOWN are set. If the file is the same one */
/* we saw on the last call, the state variables FAST, and KNOWN */
/* retain their values from the previous call. */
/* FIDX is set at this point only if we're looking at a known */
/* file. */
/* Unless the file is recognized and known to be a fast file, we */
/* look up all metadata for the file. */
if (! (known && fast)) {
if (! known) {
/* This file is not in our list. If the list is not full, */
/* append the file to the list. If the list is full, */
/* replace the oldest (first) file with this one. */
if (nfiles < 20) {
++nfiles;
fidx = nfiles;
} else {
fidx = 1;
}
tbhan[(i__1 = fidx - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge(
"tbhan", i__1, "dasa2l_", (ftnlen)781)] = *handle;
/* Find out whether the file is open for read or write */
/* access. We consider the file to be `slow' until we find */
/* out otherwise. The contents of the arrays TBHIGH, */
/* TBBASE, TBSIZE, and TBMXAD are left undefined for slow */
/* files. */
dasham_(handle, access, (ftnlen)10);
rdonly = s_cmp(access, "READ", (ftnlen)10, (ftnlen)4) == 0;
fast = FALSE_;
tbfast[(i__1 = fidx - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge(
"tbfast", i__1, "dasa2l_", (ftnlen)794)] = fast;
/* We'll set the flag KNOWN at the end of the outer IF */
/* block. */
} else {
/* We set RDONLY to .FALSE. for any known file that is */
/* not fast. It's actually possible for a read-only file */
/* to be unsegregated, but this is expected to be a rare */
/* case, one that's not worth complicating this routine */
/* further for. */
rdonly = FALSE_;
}
/* RDONLY is set. */
/* FIDX is now set whether or not the current file is known. */
/* Get the number of reserved records, comment records, and */
/* the current last address of the data type TYPE from the */
/* file summary. */
dashfs_(handle, &nresvr, &nresvc, &ncomr, &ncomc, &free, &tbmxad[(
i__1 = fidx * 3 - 3) < 60 && 0 <= i__1 ? i__1 : s_rnge(
"tbmxad", i__1, "dasa2l_", (ftnlen)821)], lstrec, lstwrd);
mxaddr = tbmxad[(i__1 = *type__ + fidx * 3 - 4) < 60 && 0 <= i__1
? i__1 : s_rnge("tbmxad", i__1, "dasa2l_", (ftnlen)831)];
/* Make sure that ADDRSS points to an existing location. */
if (*addrss < 1 || *addrss > mxaddr) {
chkin_("DASA2L", (ftnlen)6);
dashlu_(handle, &unit);
setmsg_("ADDRSS was #; valid range for type # is # to #. F"
"ile was #", (ftnlen)60);
errint_("#", addrss, (ftnlen)1);
errint_("#", type__, (ftnlen)1);
errint_("#", &c__1, (ftnlen)1);
errint_("#", &mxaddr, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(DASNOSUCHADDRESS)", (ftnlen)23);
chkout_("DASA2L", (ftnlen)6);
return 0;
}
/* Find out which directory describes the cluster containing */
/* this word. To do this, we must traverse the directory */
/* list. The first directory record comes right after the */
/* last comment record. (Don't forget the file record when */
/* counting the predecessors of the directory record.) */
/* Note that we don't need to worry about not finding a */
/* directory record that contains the address we're looking */
/* for, since we've already checked that the address is in */
/* range. */
/* Keep track of the number of directory records we see. We'll */
/* use this later to determine whether we've got a segregated */
/* file. */
nrec = nresvr + ncomr + 2;
ndirs = 1;
i__3 = rngloc[(i__2 = *type__ - 1) < 3 && 0 <= i__2 ? i__2 :
s_rnge("rngloc", i__2, "dasa2l_", (ftnlen)872)] + 1;
dasrri_(handle, &nrec, &rngloc[(i__1 = *type__ - 1) < 3 && 0 <=
i__1 ? i__1 : s_rnge("rngloc", i__1, "dasa2l_", (ftnlen)
872)], &i__3, range);
while(range[1] < *addrss) {
/* The record number of the next directory is the forward */
/* pointer in the current directory record. Update NREC */
/* with this pointer. Get the address range for the */
/* specified type covered by this next directory record. */
dasrri_(handle, &nrec, &c__2, &c__2, &nxtrec);
nrec = nxtrec;
++ndirs;
i__3 = rngloc[(i__2 = *type__ - 1) < 3 && 0 <= i__2 ? i__2 :
s_rnge("rngloc", i__2, "dasa2l_", (ftnlen)891)] + 1;
dasrri_(handle, &nrec, &rngloc[(i__1 = *type__ - 1) < 3 && 0
<= i__1 ? i__1 : s_rnge("rngloc", i__1, "dasa2l_", (
ftnlen)891)], &i__3, range);
}
/* NREC is now the record number of the directory that contains */
/* the type descriptor for the address we're looking for. */
/* Our next task is to find the descriptor for the cluster */
/* containing the input address. To do this, we must examine */
/* the directory record in `left-to-right' order. As we do so, */
/* we'll keep track of the highest address of type TYPE */
/* occurring in the clusters whose descriptors we've seen. */
/* The variable HIADDR will contain this address. */
dasrri_(handle, &nrec, &c__1, &c__256, dirrec);
/* In the process of finding the physical location */
/* corresponding to ADDRSS, we'll find the record number of the */
/* base of the cluster containing ADDRSS. We'll start out by */
/* initializing this value with the number of the first data */
/* record of the next cluster. */
*clbase = nrec + 1;
/* We'll initialize HIADDR with the value preceding the lowest */
/* address of type TYPE described by the current directory. */
hiaddr = dirrec[(i__2 = rngloc[(i__1 = *type__ - 1) < 3 && 0 <=
i__1 ? i__1 : s_rnge("rngloc", i__1, "dasa2l_", (ftnlen)
925)] - 1) < 256 && 0 <= i__2 ? i__2 : s_rnge("dirrec",
i__2, "dasa2l_", (ftnlen)925)] - 1;
/* Initialize the number of records described by the last seen */
/* type descriptor. This number, when added to CLBASE, should */
/* yield the number of the first record of the current cluster; */
/* that's why it's initialized to 0. */
*clsize = 0;
/* Now find the descriptor for the cluster containing ADDRSS. */
/* Read descriptors until we get to the one that describes the */
/* record containing ADDRSS. Keep track of descriptor data */
/* types as we go. Also count the descriptors. */
/* At this point, HIADDR is less than ADDRSS, so the loop will */
/* always be executed at least once. */
prvtyp = prev[(i__1 = dirrec[8] - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("prev", i__1, "dasa2l_", (ftnlen)944)];
dscloc = 10;
while(hiaddr < *addrss) {
/* Update CLBASE so that it is the record number of the */
/* first record of the current cluster. */
*clbase += *clsize;
/* Find the type of the current descriptor. */
if (dirrec[(i__1 = dscloc - 1) < 256 && 0 <= i__1 ? i__1 :
s_rnge("dirrec", i__1, "dasa2l_", (ftnlen)957)] > 0) {
curtyp = next[(i__1 = prvtyp - 1) < 3 && 0 <= i__1 ? i__1
: s_rnge("next", i__1, "dasa2l_", (ftnlen)958)];
} else {
curtyp = prev[(i__1 = prvtyp - 1) < 3 && 0 <= i__1 ? i__1
: s_rnge("prev", i__1, "dasa2l_", (ftnlen)960)];
}
/* Forgetting to update PRVTYP is a Very Bad Thing (VBT). */
prvtyp = curtyp;
/* If the current descriptor is of the type we're interested */
/* in, update the highest address count. */
if (curtyp == *type__) {
hiaddr += nw[(i__1 = *type__ - 1) < 3 && 0 <= i__1 ? i__1
: s_rnge("nw", i__1, "dasa2l_", (ftnlen)973)] * (
i__3 = dirrec[(i__2 = dscloc - 1) < 256 && 0 <=
i__2 ? i__2 : s_rnge("dirrec", i__2, "dasa2l_", (
ftnlen)973)], abs(i__3));
}
/* Compute the number of records described by the current */
/* descriptor. Update the descriptor location. */
*clsize = (i__2 = dirrec[(i__1 = dscloc - 1) < 256 && 0 <=
i__1 ? i__1 : s_rnge("dirrec", i__1, "dasa2l_", (
ftnlen)980)], abs(i__2));
++dscloc;
}
/* If we have an unknown read-only file, see whether the file */
/* is segregated. If it is, we'll be able to compute */
/* addresses much faster for subsequent reads to this file. */
if (rdonly && ! known) {
if (ndirs == 1) {
/* If this file is segregated, there are at most three */
/* cluster descriptors, and each one points to a cluster */
/* containing all records of the corresponding data type. */
/* For each data type having a non-zero maximum address, */
/* the size of the corresponding cluster must be large */
/* enough to hold all addresses of that type. */
ntypes = 0;
for (i__ = 1; i__ <= 3; ++i__) {
if (tbmxad[(i__1 = i__ + fidx * 3 - 4) < 60 && 0 <=
i__1 ? i__1 : s_rnge("tbmxad", i__1, "dasa2l_"
, (ftnlen)1005)] > 0) {
++ntypes;
}
}
/* Now look at the first NTYPES cluster descriptors, */
/* collecting cluster bases and sizes as we go. */
mxclrc = nrec + 1;
prvtyp = prev[(i__1 = dirrec[8] - 1) < 3 && 0 <= i__1 ?
i__1 : s_rnge("prev", i__1, "dasa2l_", (ftnlen)
1016)];
dscloc = 10;
fast = TRUE_;
while(dscloc <= ntypes + 9 && fast) {
/* Find the type of the current descriptor. */
if (dirrec[(i__1 = dscloc - 1) < 256 && 0 <= i__1 ?
i__1 : s_rnge("dirrec", i__1, "dasa2l_", (
ftnlen)1025)] > 0) {
curtyp = next[(i__1 = prvtyp - 1) < 3 && 0 <=
i__1 ? i__1 : s_rnge("next", i__1, "dasa"
"2l_", (ftnlen)1026)];
} else {
curtyp = prev[(i__1 = prvtyp - 1) < 3 && 0 <=
i__1 ? i__1 : s_rnge("prev", i__1, "dasa"
"2l_", (ftnlen)1028)];
}
prvtyp = curtyp;
tbbase[(i__1 = curtyp + fidx * 3 - 4) < 60 && 0 <=
i__1 ? i__1 : s_rnge("tbbase", i__1, "dasa2l_"
, (ftnlen)1032)] = mxclrc;
tbsize[(i__1 = curtyp + fidx * 3 - 4) < 60 && 0 <=
i__1 ? i__1 : s_rnge("tbsize", i__1, "dasa2l_"
, (ftnlen)1033)] = (i__3 = dirrec[(i__2 =
dscloc - 1) < 256 && 0 <= i__2 ? i__2 :
s_rnge("dirrec", i__2, "dasa2l_", (ftnlen)
1033)], abs(i__3));
mxclrc += tbsize[(i__1 = curtyp + fidx * 3 - 4) < 60
&& 0 <= i__1 ? i__1 : s_rnge("tbsize", i__1,
"dasa2l_", (ftnlen)1034)];
fast = tbmxad[(i__1 = curtyp + fidx * 3 - 4) < 60 &&
0 <= i__1 ? i__1 : s_rnge("tbmxad", i__1,
"dasa2l_", (ftnlen)1037)] <= tbsize[(i__2 =
curtyp + fidx * 3 - 4) < 60 && 0 <= i__2 ?
i__2 : s_rnge("tbsize", i__2, "dasa2l_", (
ftnlen)1037)] * nw[(i__3 = curtyp - 1) < 3 &&
0 <= i__3 ? i__3 : s_rnge("nw", i__3, "dasa2"
"l_", (ftnlen)1037)];
++dscloc;
}
/* FAST is set. */
} else {
/* The file has more than one directory record. */
fast = FALSE_;
}
/* If the file was unknown, readonly, and had one directory */
/* record, we determined whether it was a fast file. */
} else {
/* The file was already known and wasn't fast, or is not */
/* readonly. */
fast = FALSE_;
}
/* FAST is set. */
}
/* This is the end of the `.NOT. ( KNOWN .AND. FAST )' case. */
/* At this point, we've set or looked up CLBASE, CLSIZE, MXADDR, */
/* and HIADDR. */
/* If the file was unknown, we set TBHAN, TBRDON, and TBFAST. */
/* If the file was unknown and turned out to be fast, we set */
/* TBBASE, TBSIZE, TBHIGH, and TBMXAD as well. */
/* At this point, it's safe to indicate that the file is known. */
known = TRUE_;
}
/* At this point, */
/* -- CLBASE is properly set: it is the record number of the */
/* first record of the cluster containing ADDRSS. */
/* -- CLSIZE is properly set: it is the size of the cluster */
/* containing ADDRSS. */
/* -- HIADDR is the last logical address in the cluster */
/* containing ADDRSS. */
/* Now we must find the physical record and word corresponding */
/* to ADDRSS. The structure of the cluster containing ADDRSS and */
/* HIADDR is shown below: */
/* +--------------------------------------+ */
/* | | Record # CLBASE */
/* +--------------------------------------+ */
/* . */
/* . */
/* . */
/* +--------------------------------------+ */
/* | |ADDRSS| | Record # RECNO */
/* +--------------------------------------+ */
/* . */
/* . */
/* . */
/* +--------------------------------------+ Record # */
/* | |HIADDR| */
/* +--------------------------------------+ CLBASE + CLSIZE - 1 */
*recno = *clbase + *clsize - 1 - (hiaddr - *addrss) / nw[(i__1 = *type__
- 1) < 3 && 0 <= i__1 ? i__1 : s_rnge("nw", i__1, "dasa2l_", (
ftnlen)1122)];
*wordno = *addrss - (*addrss - 1) / nw[(i__1 = *type__ - 1) < 3 && 0 <=
i__1 ? i__1 : s_rnge("nw", i__1, "dasa2l_", (ftnlen)1125)] * nw[(
i__2 = *type__ - 1) < 3 && 0 <= i__2 ? i__2 : s_rnge("nw", i__2,
"dasa2l_", (ftnlen)1125)];
return 0;
} /* dasa2l_ */
