/* $Procedure SPKLTC ( S/P Kernel, light time corrected state ) */
/* Subroutine */ int spkltc_(integer *targ, doublereal *et, char *ref, char *
abcorr, doublereal *stobs, doublereal *starg, doublereal *lt,
doublereal *dlt, ftnlen ref_len, ftnlen abcorr_len)
{
/* Initialized data */
static logical pass1 = TRUE_;
static char prvcor[5] = " ";
/* System generated locals */
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
doublereal dist;
extern doublereal vdot_(doublereal *, doublereal *);
static logical xmit;
extern /* Subroutine */ int zzvalcor_(char *, logical *, ftnlen);
doublereal a, b, c__;
integer i__, refid;
extern /* Subroutine */ int chkin_(char *, ftnlen);
doublereal epoch;
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen);
static logical usecn;
extern /* Subroutine */ int vlcom_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *), vsubg_(doublereal *, doublereal *,
integer *, doublereal *);
doublereal ssblt, lterr;
static logical uselt;
extern doublereal vnorm_(doublereal *);
doublereal prvlt;
extern logical failed_(void);
extern doublereal clight_(void);
logical attblk[15];
extern doublereal touchd_(doublereal *);
extern /* Subroutine */ int spkgeo_(integer *, doublereal *, char *,
integer *, doublereal *, doublereal *, ftnlen), sigerr_(char *,
ftnlen), chkout_(char *, ftnlen);
integer ltsign;
extern /* Subroutine */ int irfnum_(char *, integer *, ftnlen), setmsg_(
char *, ftnlen);
doublereal ssbtrg[6];
integer numitr;
extern logical return_(void);
logical usestl;
/* $ Abstract */
/* Return the state (position and velocity) of a target body */
/* relative to an observer, optionally corrected for light time, */
/* expressed relative to an inertial reference frame. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* SPK */
/* $ Keywords */
/* EPHEMERIS */
/* $ Declarations */
/* $ Abstract */
/* Include file zzabcorr.inc */
/* SPICE private file intended solely for the support of SPICE */
/* routines. Users should not include this file directly due */
/* to the volatile nature of this file */
/* The parameters below define the structure of an aberration */
/* correction attribute block. */
/* $ 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 */
/* An aberration correction attribute block is an array of logical */
/* flags indicating the attributes of the aberration correction */
/* specified by an aberration correction string. The attributes */
/* are: */
/* - Is the correction "geometric"? */
/* - Is light time correction indicated? */
/* - Is stellar aberration correction indicated? */
/* - Is the light time correction of the "converged */
/* Newtonian" variety? */
/* - Is the correction for the transmission case? */
/* - Is the correction relativistic? */
/* The parameters defining the structure of the block are as */
/* follows: */
/* NABCOR Number of aberration correction choices. */
/* ABATSZ Number of elements in the aberration correction */
/* block. */
/* GEOIDX Index in block of geometric correction flag. */
/* LTIDX Index of light time flag. */
/* STLIDX Index of stellar aberration flag. */
/* CNVIDX Index of converged Newtonian flag. */
/* XMTIDX Index of transmission flag. */
/* RELIDX Index of relativistic flag. */
/* The following parameter is not required to define the block */
/* structure, but it is convenient to include it here: */
/* CORLEN The maximum string length required by any aberration */
/* correction string */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 18-DEC-2004 (NJB) */
/* -& */
/* Number of aberration correction choices: */
/* Aberration correction attribute block size */
/* (number of aberration correction attributes): */
/* Indices of attributes within an aberration correction */
/* attribute block: */
/* Maximum length of an aberration correction string: */
/* End of include file zzabcorr.inc */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* TARG I Target body. */
/* ET I Observer epoch. */
/* REF I Inertial reference frame of output state. */
/* ABCORR I Aberration correction flag. */
/* STOBS I State of the observer relative to the SSB. */
/* STARG O State of target. */
/* LT O One way light time between observer and target. */
/* DLT O Derivative of light time with respect to time. */
/* $ Detailed_Input */
/* TARG is the NAIF ID code for a target body. The target */
/* and observer define a state vector whose position */
/* component points from the observer to the target. */
/* ET is the ephemeris time, expressed as seconds past */
/* J2000 TDB, at which the state of the target body */
/* relative to the observer is to be computed. ET */
/* refers to time at the observer's location. */
/* REF is the inertial reference frame with respect to which */
/* the input state STOBS and the output state STARG are */
/* expressed. REF must be recognized by the SPICE */
/* Toolkit. The acceptable frames are listed in the */
/* Frames Required Reading, as well as in the SPICELIB */
/* routine CHGIRF. */
/* Case and blanks are not significant in the string */
/* REF. */
/* ABCORR indicates the aberration corrections to be applied to */
/* the state of the target body to account for one-way */
/* light time. See the discussion in the Particulars */
/* section for recommendations on how to choose */
/* aberration corrections. */
/* If ABCORR includes the stellar aberration correction */
/* symbol '+S', this flag is simply ignored. Aside from */
/* the possible presence of this symbol, ABCORR may be */
/* any of the following: */
/* 'NONE' Apply no correction. Return the */
/* geometric state of the target body */
/* relative to the observer. */
/* The following values of ABCORR apply to the */
/* "reception" case in which photons depart from the */
/* target's location at the light-time corrected epoch */
/* ET-LT and *arrive* at the observer's location at ET: */
/* 'LT' Correct for one-way light time (also */
/* called "planetary aberration") using a */
/* Newtonian formulation. This correction */
/* yields the state of the target at the */
/* moment it emitted photons arriving at */
/* the observer at ET. */
/* The light time correction involves */
/* iterative solution of the light time */
/* equation (see Particulars for details). */
/* The solution invoked by the 'LT' option */
/* uses one iteration. */
/* 'CN' Converged Newtonian light time */
/* correction. In solving the light time */
/* equation, the 'CN' correction iterates */
/* until the solution converges (three */
/* iterations on all supported platforms). */
/* Whether the 'CN+S' solution is */
/* substantially more accurate than the */
/* 'LT' solution depends on the geometry */
/* of the participating objects and on the */
/* accuracy of the input data. In all */
/* cases this routine will execute more */
/* slowly when a converged solution is */
/* computed. See the Particulars section of */
/* SPKEZR for a discussion of precision of */
/* light time corrections. */
/* The following values of ABCORR apply to the */
/* "transmission" case in which photons *depart* from */
/* the observer's location at ET and arrive at the */
/* target's location at the light-time corrected epoch */
/* ET+LT: */
/* 'XLT' "Transmission" case: correct for */
/* one-way light time using a Newtonian */
/* formulation. This correction yields the */
/* state of the target at the moment it */
/* receives photons emitted from the */
/* observer's location at ET. */
/* 'XCN' "Transmission" case: converged */
/* Newtonian light time correction. */
/* Neither special nor general relativistic effects are */
/* accounted for in the aberration corrections applied */
/* by this routine. */
/* Case and blanks are not significant in the string */
/* ABCORR. */
/* STOBS is the geometric (uncorrected) state of the observer */
/* relative to the solar system barycenter at epoch ET. */
/* STOBS is a 6-vector: the first three components of */
/* STOBS represent a Cartesian position vector; the last */
/* three components represent the corresponding velocity */
/* vector. STOBS is expressed relative to the inertial */
/* reference frame designated by REF. */
/* Units are always km and km/sec. */
/* $ Detailed_Output */
/* STARG is a Cartesian state vector representing the position */
/* and velocity of the target body relative to the */
/* specified observer. STARG is corrected for the */
/* specified aberration, and is expressed with respect */
/* to the specified inertial reference frame. The first */
/* three components of STARG represent the x-, y- and */
/* z-components of the target's position; last three */
/* components form the corresponding velocity vector. */
/* The position component of STARG points from the */
/* observer's location at ET to the aberration-corrected */
/* location of the target. Note that the sense of the */
/* position vector is independent of the direction of */
/* radiation travel implied by the aberration */
/* correction. */
/* Units are always km and km/sec. */
/* LT is the one-way light time between the observer and */
/* target in seconds. If the target state is corrected */
/* for light time, then LT is the one-way light time */
/* between the observer and the light time-corrected */
/* target location. */
/* DLT is the derivative with respect to barycentric */
/* dynamical time of the one way light time between */
/* target and observer: */
/* DLT = d(LT)/d(ET) */
/* DLT can also be described as the rate of change of */
/* one way light time. DLT is unitless, since LT and */
/* ET both have units of TDB seconds. */
/* If the observer and target are at the same position, */
/* then DLT is set to zero. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) For the convenience of the caller, the input aberration */
/* correction flag can call for stellar aberration correction via */
/* inclusion of the '+S' suffix. This portion of the aberration */
/* correction flag is ignored if present. */
/* 2) If the value of ABCORR is not recognized, the error */
/* is diagnosed by a routine in the call tree of this */
/* routine. */
/* 3) If the reference frame requested is not a recognized */
/* inertial reference frame, the error SPICE(BADFRAME) */
/* is signaled. */
/* 4) If the state of the target relative to the solar system */
/* barycenter cannot be computed, the error will be diagnosed */
/* by routines in the call tree of this routine. */
/* 5) If the observer and target are at the same position, */
/* then DLT is set to zero. This situation could arise, */
/* for example, when the observer is Mars and the target */
/* is the Mars barycenter. */
/* 6) If a division by zero error would occur in the computation */
/* of DLT, the error SPICE(DIVIDEBYZERO) is signaled. */
/* $ Files */
/* This routine computes states using SPK files that have been */
/* loaded into the SPICE system, normally via the kernel loading */
/* interface routine FURNSH. Application programs typically load */
/* kernels once before this routine is called, for example during */
/* program initialization; kernels need not be loaded repeatedly. */
/* See the routine FURNSH and the SPK and KERNEL Required Reading */
/* for further information on loading (and unloading) kernels. */
/* If any of the ephemeris data used to compute STARG are expressed */
/* relative to a non-inertial frame in the SPK files providing those */
/* data, additional kernels may be needed to enable the reference */
/* frame transformations required to compute the state. Normally */
/* these additional kernels are PCK files or frame kernels. Any */
/* such kernels must already be loaded at the time this routine is */
/* called. */
/* $ Particulars */
/* This routine supports higher-level SPK API routines that can */
/* perform both light time and stellar aberration corrections. */
/* User applications normally will not need to call this routine */
/* directly. */
/* See the header of the routine SPKEZR for a detailed discussion */
/* of aberration corrections. */
/* $ Examples */
/* The numerical results shown for this example may differ across */
/* platforms. The results depend on the SPICE kernels used as */
/* input, the compiler and supporting libraries, and the machine */
/* specific arithmetic implementation. */
/* 1) Look up a sequence of states of the Moon as seen from the */
/* Earth. Use light time corrections. Compute the first state for */
/* the epoch 2000 JAN 1 12:00:00 TDB; compute subsequent states at */
/* intervals of 1 hour. For each epoch, display the states, the */
/* one way light time between target and observer, and the rate of */
/* change of the one way light time. */
/* Use the following meta-kernel to specify the kernels to */
/* load: */
/* KPL/MK */
/* File name: spkltc.tm */
/* This meta-kernel is intended to support operation of SPICE */
/* example programs. The kernels shown here should not be */
/* assumed to contain adequate or correct versions of data */
/* required by SPICE-based user applications. */
/* In order for an application to use this meta-kernel, the */
/* kernels referenced here must be present in the user's */
/* current working directory. */
/* \begindata */
/* KERNELS_TO_LOAD = ( 'de421.bsp', */
/* 'pck00010.tpc', */
/* 'naif0010.tls' ) */
/* \begintext */
/* The code example follows: */
/* PROGRAM EX1 */
/* IMPLICIT NONE */
/* C */
/* C Local constants */
/* C */
/* C The meta-kernel name shown here refers to a file whose */
/* C contents are those shown above. This file and the kernels */
/* C it references must exist in your current working directory. */
/* C */
/* CHARACTER*(*) META */
/* PARAMETER ( META = 'spkltc.tm' ) */
/* C */
/* C Use a time step of 1 hour; look up 5 states. */
/* C */
/* DOUBLE PRECISION STEP */
/* PARAMETER ( STEP = 3600.0D0 ) */
/* INTEGER MAXITR */
/* PARAMETER ( MAXITR = 5 ) */
/* C */
/* C Local variables */
/* C */
/* DOUBLE PRECISION DLT */
/* DOUBLE PRECISION ET */
/* DOUBLE PRECISION ET0 */
/* DOUBLE PRECISION LT */
/* DOUBLE PRECISION STATE ( 6 ) */
/* DOUBLE PRECISION STOBS ( 6 ) */
/* INTEGER I */
/* C */
/* C Load the SPK and LSK kernels via the meta-kernel. */
/* C */
/* CALL FURNSH ( META ) */
/* C */
/* C Convert the start time to seconds past J2000 TDB. */
/* C */
/* CALL STR2ET ( '2000 JAN 1 12:00:00 TDB', ET0 ) */
/* C */
/* C Step through a series of epochs, looking up a */
/* C state vector at each one. */
/* C */
/* DO I = 1, MAXITR */
/* ET = ET0 + (I-1)*STEP */
/* C */
/* C Look up a state vector at epoch ET using the */
/* C following inputs: */
/* C */
/* C Target: Moon (NAIF ID code 301) */
/* C Reference frame: J2000 */
/* C Aberration correction: Light time ('LT') */
/* C Observer: Earth (NAIF ID code 399) */
/* C */
/* C Before we can execute this computation, we'll need the */
/* C geometric state of the observer relative to the solar */
/* C system barycenter at ET, expressed relative to the */
/* C J2000 reference frame: */
/* C */
/* CALL SPKSSB ( 399, ET, 'J2000', STOBS ) */
/* C */
/* C Now compute the desired state vector: */
/* C */
/* CALL SPKLTC ( 301, ET, 'J2000', 'LT', */
/* . STOBS, STATE, LT, DLT ) */
/* WRITE (*,*) 'ET = ', ET */
/* WRITE (*,*) 'J2000 x-position (km): ', STATE(1) */
/* WRITE (*,*) 'J2000 y-position (km): ', STATE(2) */
/* WRITE (*,*) 'J2000 z-position (km): ', STATE(3) */
/* WRITE (*,*) 'J2000 x-velocity (km/s): ', STATE(4) */
/* WRITE (*,*) 'J2000 y-velocity (km/s): ', STATE(5) */
/* WRITE (*,*) 'J2000 z-velocity (km/s): ', STATE(6) */
/* WRITE (*,*) 'One-way light time (s): ', LT */
/* WRITE (*,*) 'Light time rate: ', DLT */
/* WRITE (*,*) ' ' */
/* END DO */
/* END */
/* On a PC/Linux/gfortran platform, the following output was */
/* produced: */
/* ET = 0.0000000000000000 */
/* J2000 x-position (km): -291569.26541282982 */
/* J2000 y-position (km): -266709.18647825718 */
/* J2000 z-position (km): -76099.155118763447 */
/* J2000 x-velocity (km/s): 0.64353061322177041 */
/* J2000 y-velocity (km/s): -0.66608181700820079 */
/* J2000 z-velocity (km/s): -0.30132283179625752 */
/* One-way light time (s): 1.3423106103251679 */
/* Light time rate: 1.07316908698977495E-007 */
/* ET = 3600.0000000000000 */
/* J2000 x-position (km): -289240.78128184378 */
/* J2000 y-position (km): -269096.44087958336 */
/* J2000 z-position (km): -77180.899725757539 */
/* J2000 x-velocity (km/s): 0.65006211520087476 */
/* J2000 y-velocity (km/s): -0.66016273921695667 */
/* J2000 z-velocity (km/s): -0.29964267390571342 */
/* One-way light time (s): 1.3426939548635302 */
/* Light time rate: 1.05652598952224259E-007 */
/* ET = 7200.0000000000000 */
/* J2000 x-position (km): -286888.88736709207 */
/* J2000 y-position (km): -271462.30170547962 */
/* J2000 z-position (km): -78256.555682137609 */
/* J2000 x-velocity (km/s): 0.65653599154284592 */
/* J2000 y-velocity (km/s): -0.65419657680401588 */
/* J2000 z-velocity (km/s): -0.29794027307420823 */
/* One-way light time (s): 1.3430713117337547 */
/* Light time rate: 1.03990456898758609E-007 */
/* ET = 10800.000000000000 */
/* J2000 x-position (km): -284513.79173691198 */
/* J2000 y-position (km): -273806.60031034052 */
/* J2000 z-position (km): -79326.043183274567 */
/* J2000 x-velocity (km/s): 0.66295190054599118 */
/* J2000 y-velocity (km/s): -0.64818380709706158 */
/* J2000 z-velocity (km/s): -0.29621577937090349 */
/* One-way light time (s): 1.3434426890693671 */
/* Light time rate: 1.02330665243423737E-007 */
/* ET = 14400.000000000000 */
/* J2000 x-position (km): -282115.70368389413 */
/* J2000 y-position (km): -276129.16976799071 */
/* J2000 z-position (km): -80389.282965712249 */
/* J2000 x-velocity (km/s): 0.66930950377548726 */
/* J2000 y-velocity (km/s): -0.64212490805688027 */
/* J2000 z-velocity (km/s): -0.29446934336246899 */
/* One-way light time (s): 1.3438080956559786 */
/* Light time rate: 1.00673403630050830E-007 */
/* $ Restrictions */
/* 1) The routine SPKGEO should be used instead of this routine */
/* to compute geometric states. SPKGEO introduces less */
/* round-off error when the observer and target have common */
/* center that is closer to both objects than is the solar */
/* system barycenter. */
/* 2) The kernel files to be used by SPKLTC must be loaded */
/* (normally by the SPICELIB kernel loader FURNSH) before */
/* this routine is called. */
/* 3) Unlike most other SPK state computation routines, this */
/* routine requires that the output state be relative to an */
/* inertial reference frame. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 2.0.0, 04-JUL-2014 (NJB) */
/* Discussion of light time corrections was updated. Assertions */
/* that converged light time corrections are unlikely to be */
/* useful were removed. */
/* Last update was 02-MAY-2012 (NJB) */
/* Updated to ensure convergence when CN or XCN light time */
/* corrections are used. The new algorithm also terminates early */
/* (after fewer than three iterations) when convergence is */
/* attained. */
/* Call to ZZPRSCOR was replaced by a call to ZZVALCOR. */
/* - SPICELIB Version 1.0.0, 11-JAN-2008 (NJB) */
/* -& */
/* $ Index_Entries */
/* low-level light time correction */
/* light-time corrected state from spk file */
/* get light-time corrected state */
/* -& */
/* $ Revisions */
/* None. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* TOL is the tolerance used for a division-by-zero test */
/* performed prior to computation of DLT. */
/* Convergence limit: */
/* Maximum number of light time iterations for any */
/* aberration correction: */
/* Local variables */
/* Saved variables */
/* Initial values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SPKLTC", (ftnlen)6);
}
if (pass1 || s_cmp(abcorr, prvcor, abcorr_len, (ftnlen)5) != 0) {
/* The aberration correction flag differs from the value it */
/* had on the previous call, if any. Analyze the new flag. */
zzvalcor_(abcorr, attblk, abcorr_len);
if (failed_()) {
chkout_("SPKLTC", (ftnlen)6);
return 0;
}
/* The aberration correction flag is recognized; save it. */
s_copy(prvcor, abcorr, (ftnlen)5, abcorr_len);
/* Set logical flags indicating the attributes of the requested */
/* correction: */
/* XMIT is .TRUE. when the correction is for transmitted */
/* radiation. */
/* USELT is .TRUE. when any type of light time correction */
/* (normal or converged Newtonian) is specified. */
/* USECN indicates converged Newtonian light time correction. */
/* The above definitions are consistent with those used by */
/* ZZVALCOR. */
xmit = attblk[4];
uselt = attblk[1];
usecn = attblk[3];
usestl = attblk[2];
pass1 = FALSE_;
}
/* See if the reference frame is a recognized inertial frame. */
irfnum_(ref, &refid, ref_len);
if (refid == 0) {
setmsg_("The requested frame '#' is not a recognized inertial frame. "
, (ftnlen)60);
errch_("#", ref, (ftnlen)1, ref_len);
sigerr_("SPICE(BADFRAME)", (ftnlen)15);
chkout_("SPKLTC", (ftnlen)6);
return 0;
}
/* Find the geometric state of the target body with respect to */
/* the solar system barycenter. Subtract the state of the */
/* observer to get the relative state. Use this to compute the */
/* one-way light time. */
spkgeo_(targ, et, ref, &c__0, ssbtrg, &ssblt, ref_len);
if (failed_()) {
chkout_("SPKLTC", (ftnlen)6);
return 0;
}
vsubg_(ssbtrg, stobs, &c__6, starg);
dist = vnorm_(starg);
*lt = dist / clight_();
if (*lt == 0.) {
/* This can happen only if the observer and target are at the */
/* same position. We don't consider this an error, but we're not */
/* going to compute the light time derivative. */
*dlt = 0.;
chkout_("SPKLTC", (ftnlen)6);
return 0;
}
if (! uselt) {
/* This is a special case: we're not using light time */
/* corrections, so the derivative */
/* of light time is just */
/* (1/c) * d(VNORM(STARG))/dt */
*dlt = vdot_(starg, &starg[3]) / (dist * clight_());
/* LT and DLT are both set, so we can return. */
chkout_("SPKLTC", (ftnlen)6);
return 0;
}
/* To correct for light time, find the state of the target body */
/* at the current epoch minus the one-way light time. Note that */
/* the observer remains where it is. */
/* Determine the sign of the light time offset. */
if (xmit) {
ltsign = 1;
} else {
ltsign = -1;
}
/* Let NUMITR be the number of iterations we'll perform to */
/* compute the light time. */
if (usecn) {
numitr = 5;
} else {
numitr = 1;
}
i__ = 0;
lterr = 1.;
while(i__ < numitr && lterr > 1e-17) {
/* LT was set either prior to this loop or */
/* during the previous loop iteration. */
epoch = *et + ltsign * *lt;
spkgeo_(targ, &epoch, ref, &c__0, ssbtrg, &ssblt, ref_len);
if (failed_()) {
chkout_("SPKLTC", (ftnlen)6);
return 0;
}
vsubg_(ssbtrg, stobs, &c__6, starg);
prvlt = *lt;
d__1 = vnorm_(starg) / clight_();
*lt = touchd_(&d__1);
/* LTERR is the magnitude of the change between the current */
/* estimate of light time and the previous estimate, relative to */
/* the previous light time corrected epoch. */
/* Computing MAX */
d__3 = 1., d__4 = abs(epoch);
d__2 = (d__1 = *lt - prvlt, abs(d__1)) / max(d__3,d__4);
lterr = touchd_(&d__2);
++i__;
}
/* At this point, STARG contains the light time corrected */
/* state of the target relative to the observer. */
/* Compute the derivative of light time with respect */
/* to time: dLT/dt. Below we derive the formula for */
/* this quantity for the reception case. Let */
/* POBS be the position of the observer relative to the */
/* solar system barycenter. */
/* VOBS be the velocity of the observer relative to the */
/* solar system barycenter. */
/* PTARG be the position of the target relative to the */
/* solar system barycenter. */
/* VTARG be the velocity of the target relative to the */
/* solar system barycenter. */
/* S be the sign of the light time correction. S is */
/* negative for the reception case. */
/* The light-time corrected position of the target relative to */
/* the observer at observation time ET, given the one-way */
/* light time LT is: */
/* PTARG(ET+S*LT) - POBS(ET) */
/* The light-time corrected velocity of the target relative to */
/* the observer at observation time ET is */
/* VTARG(ET+S*LT)*( 1 + S*d(LT)/d(ET) ) - VOBS(ET) */
/* We need to compute dLT/dt. Below, we use the facts that, */
/* for a time-dependent vector X(t), */
/* ||X|| = <X,X> ** (1/2) */
/* d(||X||)/dt = (1/2)<X,X>**(-1/2) * 2 * <X,dX/dt> */
/* = <X,X>**(-1/2) * <X,dX/dt> */
/* = <X,dX/dt> / ||X|| */
/* Newtonian light time equation: */
/* LT = (1/c) * || PTARG(ET+S*LT) - POBS(ET)|| */
/* Differentiate both sides: */
/* dLT/dt = (1/c) * ( 1 / || PTARG(ET+S*LT) - POBS(ET) || ) */
/* * < PTARG(ET+S*LT) - POBS(ET), */
/* VTARG(ET+S*LT)*(1+S*d(LT)/d(ET)) - VOBS(ET) > */
/* = (1/c) * ( 1 / || PTARG(ET+S*LT) - POBS(ET) || ) */
/* * ( < PTARG(ET+S*LT) - POBS(ET), */
/* VTARG(ET+S*LT) - VOBS(ET) > */
/* + < PTARG(ET+S*LT) - POBS(ET), */
/* VTARG(ET+S*LT) > * (S*d(LT)/d(ET)) ) */
/* Let */
/* A = (1/c) * ( 1 / || PTARG(ET+S*LT) - POBS(ET) || ) */
/* B = < PTARG(ET+S*LT) - POBS(ET), VTARG(ET+S*LT) - VOBS(ET) > */
/* C = < PTARG(ET+S*LT) - POBS(ET), VTARG(ET+S*LT) > */
/* Then */
/* d(LT)/d(ET) = A * ( B + C * S*d(LT)/d(ET) ) */
/* which implies */
/* d(LT)/d(ET) = A*B / ( 1 - S*C*A ) */
a = 1. / (clight_() * vnorm_(starg));
b = vdot_(starg, &starg[3]);
c__ = vdot_(starg, &ssbtrg[3]);
/* For physically realistic target velocities, S*C*A cannot equal 1. */
/* We'll check for this case anyway. */
if (ltsign * c__ * a > .99999999989999999) {
setmsg_("Target range rate magnitude is approximately the speed of l"
"ight. The light time derivative cannot be computed.", (ftnlen)
110);
sigerr_("SPICE(DIVIDEBYZERO)", (ftnlen)19);
chkout_("SPKLTC", (ftnlen)6);
return 0;
}
/* Compute DLT: the rate of change of light time. */
*dlt = a * b / (1. - ltsign * c__ * a);
/* Overwrite the velocity portion of the output state */
/* with the light-time corrected velocity. */
d__1 = ltsign * *dlt + 1.;
vlcom_(&d__1, &ssbtrg[3], &c_b19, &stobs[3], &starg[3]);
chkout_("SPKLTC", (ftnlen)6);
return 0;
} /* spkltc_ */
/* $Procedure REFCHG (Reference frame Change) */
/* Subroutine */ int refchg_(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 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), rotget_(integer *, doublereal *, doublereal *, integer *,
logical *);
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_("REFCHG", (ftnlen)6);
/* 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_("REFCHG", (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_("REFCHG", (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_("REFCHG", (ftnlen)6);
return 0;
}
node = 1;
frame[(i__1 = node - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge("frame", i__1,
"refchg_", (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, "refchg_", (ftnlen)293)] != 1 && node < 10 && frame[(i__2 =
node - 1) < 10 && 0 <= i__2 ? i__2 : s_rnge("frame", i__2, "refc"
"hg_", (ftnlen)293)] != *frame2 && found) {
/* Find out what rotation is available for this */
/* frame. */
rotget_(&frame[(i__1 = node - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge(
"frame", i__1, "refchg_", (ftnlen)301)], et, &rot[(i__2 = (
node * 3 + 1) * 3 - 12) < 126 && 0 <= i__2 ? i__2 : s_rnge(
"rot", i__2, "refchg_", (ftnlen)301)], &frame[(i__3 = node) <
10 && 0 <= i__3 ? i__3 : s_rnge("frame", i__3, "refchg_", (
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, "refchg_", (ftnlen)317)] == 1 || frame[(i__2 = node - 1) <
10 && 0 <= i__2 ? i__2 : s_rnge("frame", i__2, "refchg_", (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. */
rotget_(&frame[(i__1 = node - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge(
"frame", i__1, "refchg_", (ftnlen)331)], et, &rot[(i__2 = (
node * 3 + 1) * 3 - 12) < 126 && 0 <= i__2 ? i__2 : s_rnge(
"rot", i__2, "refchg_", (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, "refchg_", (ftnlen)342)] = relto;
zzrxr_(&rot[(i__1 = ((node - 1) * 3 + 1) * 3 - 12) < 126 && 0 <=
i__1 ? i__1 : s_rnge("rot", i__1, "refchg_", (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, "refchg_",
(ftnlen)347)] = tmprot[(i__2 = i__ + j * 3 - 4) <
9 && 0 <= i__2 ? i__2 : s_rnge("tmprot", i__2,
"refchg_", (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, "refchg_", (ftnlen)357)] == 1 || frame[(i__2 =
node - 1) < 10 && 0 <= i__2 ? i__2 : s_rnge("frame", i__2,
"refchg_", (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, "refchg_", (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_("REFCHG", (ftnlen)6);
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). */
rotget_(&this__, et, &rot2[(i__1 = (put * 3 + 1) * 3 - 12) < 18 &&
0 <= i__1 ? i__1 : s_rnge("rot2", i__1, "refchg_", (
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 */
rotget_(&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, "refch"
"g_", (ftnlen)478)] = tmprot[(i__2 = i__ - 1) <
9 && 0 <= i__2 ? i__2 : s_rnge("tmprot",
i__2, "refchg_", (ftnlen)478)] * rot2[(i__3 =
(j + get * 3) * 3 - 12) < 18 && 0 <= i__3 ?
i__3 : s_rnge("rot2", i__3, "refchg_", (
ftnlen)478)] + tmprot[(i__4 = i__ + 2) < 9 &&
0 <= i__4 ? i__4 : s_rnge("tmprot", i__4,
"refchg_", (ftnlen)478)] * rot2[(i__5 = (j +
get * 3) * 3 - 11) < 18 && 0 <= i__5 ? i__5 :
s_rnge("rot2", i__5, "refchg_", (ftnlen)478)]
+ tmprot[(i__6 = i__ + 5) < 9 && 0 <= i__6 ?
i__6 : s_rnge("tmprot", i__6, "refchg_", (
ftnlen)478)] * rot2[(i__7 = (j + get * 3) * 3
- 10) < 18 && 0 <= i__7 ? i__7 : s_rnge("rot2"
, i__7, "refchg_", (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, "refchg_", (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_("REFCHG", (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_("REFCHG", (ftnlen)6);
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, "refchg_", (ftnlen)568)], &rot[(i__2 = (
cmnode * 3 + 1) * 3 - 12) < 126 && 0 <= i__2 ? i__2 : s_rnge(
"rot", i__2, "refchg_", (ftnlen)568)]);
zzrxr_(rot, &cmnode, rotate);
chkout_("REFCHG", (ftnlen)6);
return 0;
} /* refchg_ */
/* $Procedure ZZEKUE02 ( EK, update column entry, class 2 ) */
/* Subroutine */ int zzekue02_(integer *handle, integer *segdsc, integer *
coldsc, integer *recptr, doublereal *dval, logical *isnull)
{
/* System generated locals */
integer i__1;
/* Local variables */
extern /* Subroutine */ int zzekiid1_(integer *, integer *, integer *,
doublereal *, integer *, logical *);
extern integer zzekrp2n_(integer *, integer *, integer *);
integer unit;
extern /* Subroutine */ int zzekpgch_(integer *, char *, ftnlen),
zzekglnk_(integer *, integer *, integer *, integer *), zzekpgpg_(
integer *, integer *, integer *, integer *), zzekixdl_(integer *,
integer *, integer *, integer *), zzekslnk_(integer *, integer *,
integer *, integer *);
integer p, pbase;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer recno, ncols;
extern logical failed_(void);
extern /* Subroutine */ int dasrdi_(integer *, integer *, integer *,
integer *), dasudi_(integer *, integer *, integer *, integer *);
extern logical return_(void);
integer datptr, idxtyp, nlinks, ptrloc;
extern /* Subroutine */ int chkout_(char *, ftnlen), setmsg_(char *,
ftnlen), errint_(char *, integer *, ftnlen), sigerr_(char *,
ftnlen), dasudd_(integer *, integer *, integer *, doublereal *),
dashlu_(integer *, integer *), errfnm_(char *, integer *, ftnlen),
zzekad02_(integer *, integer *, integer *, integer *, doublereal
*, logical *);
/* $ Abstract */
/* Update a specified class 2 column entry in an EK record. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* EK */
/* $ Keywords */
/* PRIVATE */
/* UTILITY */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Boolean Enumerated Type */
/* ekbool.inc Version 1 21-DEC-1994 (NJB) */
/* Within the EK system, boolean values sometimes must be */
/* represented by integer or character codes. The codes and their */
/* meanings are listed below. */
/* Integer code indicating `true': */
/* Integer code indicating `false': */
/* Character code indicating `true': */
/* Character code indicating `false': */
/* End Include Section: EK Boolean Enumerated Type */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Column Descriptor Parameters */
/* ekcoldsc.inc Version 6 23-AUG-1995 (NJB) */
/* Note: The column descriptor size parameter CDSCSZ is */
/* declared separately in the include section CDSIZE$INC.FOR. */
/* Offset of column descriptors, relative to start of segment */
/* integer address range. This number, when added to the last */
/* integer address preceding the segment, yields the DAS integer */
/* base address of the first column descriptor. Currently, this */
/* offset is exactly the size of a segment descriptor. The */
/* parameter SDSCSZ, which defines the size of a segment descriptor, */
/* is declared in the include file eksegdsc.inc. */
/* Size of column descriptor */
/* Indices of various pieces of column descriptors: */
/* CLSIDX is the index of the column's class code. (We use the */
/* word `class' to distinguish this item from the column's data */
/* type.) */
/* TYPIDX is the index of the column's data type code (CHR, INT, DP, */
/* or TIME). The type is actually implied by the class, but it */
/* will frequently be convenient to look up the type directly. */
/* LENIDX is the index of the column's string length value, if the */
/* column has character type. A value of IFALSE in this element of */
/* the descriptor indicates that the strings have variable length. */
/* SIZIDX is the index of the column's element size value. This */
/* descriptor element is meaningful for columns with fixed-size */
/* entries. For variable-sized columns, this value is IFALSE. */
/* NAMIDX is the index of the base address of the column's name. */
/* IXTIDX is the data type of the column's index. IXTIDX */
/* contains a type value only if the column is indexed. For columns */
/* that are not indexed, the location IXTIDX contains the boolean */
/* value IFALSE. */
/* IXPIDX is a pointer to the column's index. IXTPDX contains a */
/* meaningful value only if the column is indexed. The */
/* interpretation of the pointer depends on the data type of the */
/* index. */
/* NFLIDX is the index of a flag indicating whether nulls are */
/* permitted in the column. The value at location NFLIDX is */
/* ITRUE if nulls are permitted and IFALSE otherwise. */
/* ORDIDX is the index of the column's ordinal position in the */
/* list of columns belonging to the column's parent segment. */
/* METIDX is the index of the column's integer metadata pointer. */
/* This pointer is a DAS integer address. */
/* The last position in the column descriptor is reserved. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Column Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Data Page Parameters */
/* ekfilpar.inc Version 1 03-APR-1995 (NJB) */
/* These parameters apply to EK files using architecture 4. */
/* These files use a paged DAS file as their underlying file */
/* structure. */
/* In paged DAS EK files, data pages are structured: they contain */
/* metadata as well as data. The metadata is located in the last */
/* few addresses of each page, so as to interfere as little as */
/* possible with calculation of data addresses. */
/* Each data page belongs to exactly one segment. Some bookkeeping */
/* information, such as record pointers, is also stored in data */
/* pages. */
/* Each page contains a forward pointer that allows rapid lookup */
/* of data items that span multiple pages. Each page also keeps */
/* track of the current number of links from its parent segment */
/* to the page. Link counts enable pages to `know' when they */
/* are no longer in use by a segment; unused pages are deallocated */
/* and returned to the free list. */
/* The parameters in this include file depend on the parameters */
/* declared in the include file ekpage.inc. If those parameters */
/* change, this file must be updated. The specified parameter */
/* declarations we need from that file are: */
/* INTEGER PGSIZC */
/* PARAMETER ( PGSIZC = 1024 ) */
/* INTEGER PGSIZD */
/* PARAMETER ( PGSIZD = 128 ) */
/* INTEGER PGSIZI */
/* PARAMETER ( PGSIZI = 256 ) */
/* Character pages use an encoding mechanism to represent integer */
/* metadata. Each integer is encoded in five consecutive */
/* characters. */
/* Character data page parameters: */
/* Size of encoded integer: */
/* Usable page size: */
/* Location of character forward pointer: */
/* Location of character link count: */
/* Double precision data page parameters: */
/* Usable page size: */
/* Location of d.p. forward pointer: */
/* Location of d.p. link count: */
/* Integer data page parameters: */
/* Usable page size: */
/* Location of integer forward pointer: */
/* Location of integer link count: */
/* End Include Section: EK Data Page Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Record Pointer Parameters */
/* ekrecptr.inc Version 2 18-JUL-1995 (NJB) */
/* This file declares parameters used in EK record pointers. */
/* Each segment references data in a given record via two levels */
/* of indirection: a record number points to a record pointer, */
/* which is a structured array of metadata and data pointers. */
/* Record pointers always occupy contiguous ranges of integer */
/* addresses. */
/* The parameter declarations in this file depend on the assumption */
/* that integer pages contain 256 DAS integer words and that the */
/* maximum number of columns in a segment is 100. Record pointers */
/* are stored in integer data pages, so they must fit within the */
/* usable data area afforded by these pages. The size of the usable */
/* data area is given by the parameter IPSIZE which is declared in */
/* ekdatpag.inc. The assumed value of IPSIZE is 254. */
/* The first element of each record pointer is a status indicator. */
/* The meanings of status indicators depend on whether the parent EK */
/* is shadowed or not. For shadowed EKs, allowed status values and */
/* their meanings are: */
/* OLD The record has not been modified since */
/* the EK containing the record was opened. */
/* UPDATE The record is an update of a previously existing */
/* record. The original record is now on the */
/* modified record list. */
/* NEW The record has been added since the EK containing the */
/* record was opened. The record is not an update */
/* of a previously existing record. */
/* DELOLD This status applies only to a backup record. */
/* DELOLD status indicates that the record corresponds */
/* to a deleted OLD record in the source segment. */
/* DELNEW This status applies only to a backup record. */
/* DELNEW status indicates that the record corresponds */
/* to a deleted NEW record in the source segment. */
/* DELUPD This status applies only to a backup record. */
/* DELUPD status indicates that the record corresponds */
/* to a deleted UPDATEd record in the source segment. */
/* In EKs that are not shadowed, all records have status OLD. */
/* The following parameters refer to indices within the record */
/* pointer structure: */
/* Index of status indicator: */
/* Each record pointer contains a pointer to its companion: for a */
/* record belonging to a shadowed EK, this is the backup counterpart, */
/* or if the parent EK is itself a backup EK, a pointer to the */
/* record's source record. The pointer is UNINIT (see below) if the */
/* record is unmodified. */
/* Record companion pointers contain record numbers, not record */
/* base addresses. */
/* Index of record's companion pointer: */
/* Each data item is referenced by an integer. The meaning of */
/* this integer depends on the representation of data in the */
/* column to which the data item belongs. Actual lookup of a */
/* data item must be done by subroutines appropriate to the class of */
/* the column to which the item belongs. Note that data items don't */
/* necessarily occupy contiguous ranges of DAS addresses. */
/* Base address of data pointers: */
/* Maximum record pointer size: */
/* Data pointers are given the value UNINIT to start with; this */
/* indicates that the data item is uninitialized. UNINIT is */
/* distinct from the value NULL. NOBACK indicates an uninitialized */
/* backup column entry. */
/* End Include Section: EK Record Pointer Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Segment Descriptor Parameters */
/* eksegdsc.inc Version 8 06-NOV-1995 (NJB) */
/* All `base addresses' referred to below are the addresses */
/* *preceding* the item the base applies to. This convention */
/* enables simplied address calculations in many cases. */
/* Size of segment descriptor. Note: the include file ekcoldsc.inc */
/* must be updated if this parameter is changed. The parameter */
/* CDOFF in that file should be kept equal to SDSCSZ. */
/* Index of the segment type code: */
/* Index of the segment's number. This number is the segment's */
/* index in the list of segments contained in the EK to which */
/* the segment belongs. */
/* Index of the DAS integer base address of the segment's integer */
/* meta-data: */
/* Index of the DAS character base address of the table name: */
/* Index of the segment's column count: */
/* Index of the segment's record count: */
/* Index of the root page number of the record tree: */
/* Index of the root page number of the character data page tree: */
/* Index of the root page number of the double precision data page */
/* tree: */
/* Index of the root page number of the integer data page tree: */
/* Index of the `modified' flag: */
/* Index of the `initialized' flag: */
/* Index of the shadowing flag: */
/* Index of the companion file handle: */
/* Index of the companion segment number: */
/* The next three items are, respectively, the page numbers of the */
/* last character, d.p., and integer data pages allocated by the */
/* segment: */
/* The next three items are, respectively, the page-relative */
/* indices of the last DAS word in use in the segment's */
/* last character, d.p., and integer data pages: */
/* Index of the DAS character base address of the column name list: */
/* The last descriptor element is reserved for future use. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Segment Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Data Types */
/* ektype.inc Version 1 27-DEC-1994 (NJB) */
/* Within the EK system, data types of EK column contents are */
/* represented by integer codes. The codes and their meanings */
/* are listed below. */
/* Integer codes are also used within the DAS system to indicate */
/* data types; the EK system makes no assumptions about compatibility */
/* between the codes used here and those used in the DAS system. */
/* Character type: */
/* Double precision type: */
/* Integer type: */
/* `Time' type: */
/* Within the EK system, time values are represented as ephemeris */
/* seconds past J2000 (TDB), and double precision numbers are used */
/* to store these values. However, since time values require special */
/* treatment both on input and output, and since the `TIME' column */
/* has a special role in the EK specification and code, time values */
/* are identified as a type distinct from double precision numbers. */
/* End Include Section: EK Data Types */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I File handle. */
/* SEGDSC I Segment descriptor. */
/* COLDSC I Column descriptor. */
/* RECPTR I Record pointer. */
/* DVAL I Double precision value. */
/* ISNULL I Null flag. */
/* $ Detailed_Input */
/* HANDLE is a file handle of an EK open for write access. */
/* SEGDSC is the descriptor of the segment containing */
/* the specified column entry. */
/* COLDSC is the descriptor of the column containing */
/* the specified column entry. */
/* RECPTR is a pointer to the record containing the column */
/* entry to update. */
/* DVAL is the double precision value with which to update */
/* the specified column entry. */
/* ISNULL is a logical flag indicating whether the value */
/* of the specified column entry is to be set to NULL. */
/* If so, the input DVAL is ignored. */
/* $ Detailed_Output */
/* None. See the $Particulars section for a description of the */
/* effect of this routine. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If HANDLE is invalid, the error will be diagnosed by routines */
/* called by this routine. The file will not be modified. */
/* 2) If an I/O error occurs while reading or writing the indicated */
/* file, the error will be diagnosed by routines called by this */
/* routine. The file may be corrupted. */
/* $ Files */
/* See the EK Required Reading for a discussion of the EK file */
/* format. */
/* $ Particulars */
/* This routine operates by side effects: it updates a column entry */
/* in an EK segment. This routine does not participate in shadowing */
/* functions. If the target EK is shadowed, the caller is */
/* responsible for performing necessary backup operations. If the */
/* target EK is not shadowed, the target record's status is not */
/* modified. */
/* If the column containing the entry is indexed, the corresponding */
/* index is updated. */
/* The changes made by this routine to the target EK file become */
/* permanent when the file is closed. Failure to close the file */
/* properly will leave it in an indeterminate state. */
/* $ Examples */
/* See EKUCED. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.0, 18-JUN-1999 (WLT) */
/* Removed redundant calls to CHKIN. */
/* - Beta Version 1.0.0, 27-SEP-1995 (NJB) */
/* -& */
/* SPICELIB functions */
/* Non-SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZEKUE02", (ftnlen)8);
}
/* Is this file handle valid--is the file open for paged write */
/* access? Signal an error if not. */
zzekpgch_(handle, "WRITE", (ftnlen)5);
if (failed_()) {
chkout_("ZZEKUE02", (ftnlen)8);
return 0;
}
/* We'll need to know how many columns the segment has in order to */
/* compute the size of the record pointer. The record pointer */
/* contains DPTBAS items plus two elements for each column. */
ncols = segdsc[4];
/* Compute the data pointer location. */
ptrloc = *recptr + 2 + coldsc[8];
dasrdi_(handle, &ptrloc, &ptrloc, &datptr);
if (datptr > 0) {
/* The column entry is non-null. Determine whether the column is */
/* indexed. */
idxtyp = coldsc[5];
if (idxtyp == 1) {
/* The column has a type 1 index. Delete the index entry */
/* for this column. Create an index entry for the new value. */
zzekixdl_(handle, segdsc, coldsc, recptr);
zzekiid1_(handle, segdsc, coldsc, dval, recptr, isnull);
} else if (idxtyp != -1) {
setmsg_("Column having index # in segment # has index type #.", (
ftnlen)52);
errint_("#", &coldsc[8], (ftnlen)1);
errint_("#", &segdsc[1], (ftnlen)1);
errint_("#", &idxtyp, (ftnlen)1);
sigerr_("SPICE(INVALIDTYPE)", (ftnlen)18);
chkout_("ZZEKUE02", (ftnlen)8);
return 0;
}
/* If the new value is null, set the data pointer to indicate a */
/* null value. Otherwise, overwrite the old value with the new */
/* one. */
if (*isnull) {
/* The data location used by the previous value is no longer */
/* needed, so we have one less link to this page. */
zzekpgpg_(&c__2, &datptr, &p, &pbase);
zzekglnk_(handle, &c__2, &p, &nlinks);
i__1 = nlinks - 1;
zzekslnk_(handle, &c__2, &p, &i__1);
dasudi_(handle, &ptrloc, &ptrloc, &c_n2);
} else {
/* No link counts change; we just have a new value. */
dasudd_(handle, &datptr, &datptr, dval);
}
} else if (datptr == -2) {
/* If the new entry is null too, there's nothing to do. */
/* We don't have to adjust link counts or indexes. */
/* If the new entry is non-null, we must add a new column entry, */
/* since no space was reserved for the old one. The column */
/* index entry must be cleaned up, if the column is indexed. */
if (! (*isnull)) {
idxtyp = coldsc[5];
if (idxtyp == 1) {
/* The column has a type 1 index. Delete the index entry */
/* for this column. */
zzekixdl_(handle, segdsc, coldsc, recptr);
} else if (idxtyp != -1) {
setmsg_("Column having index # in segment # has index type #."
, (ftnlen)52);
errint_("#", &coldsc[8], (ftnlen)1);
errint_("#", &segdsc[1], (ftnlen)1);
errint_("#", &idxtyp, (ftnlen)1);
sigerr_("SPICE(INVALIDTYPE)", (ftnlen)18);
chkout_("ZZEKUE02", (ftnlen)8);
return 0;
}
/* We don't need to decrement the link count for this page. */
/* Just add the new value to the column. But first, set the */
/* data pointer to indicate an uninitialized value, so the */
/* data addition routine doesn't choke. */
dasudi_(handle, &ptrloc, &ptrloc, &c_n1);
zzekad02_(handle, segdsc, coldsc, recptr, dval, isnull);
}
} else if (datptr == -1 || datptr == -3) {
/* There is no current column entry. Just add a new entry. */
zzekad02_(handle, segdsc, coldsc, recptr, dval, isnull);
} else {
/* The data pointer is corrupted. */
recno = zzekrp2n_(handle, &segdsc[1], recptr);
dashlu_(handle, &unit);
setmsg_("Data pointer is corrupted. SEGNO = #; COLIDX = #; RECNO = "
"#; EK = #", (ftnlen)68);
errint_("#", &segdsc[1], (ftnlen)1);
errint_("#", &coldsc[8], (ftnlen)1);
errint_("#", &recno, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZEKUE02", (ftnlen)8);
return 0;
}
chkout_("ZZEKUE02", (ftnlen)8);
return 0;
} /* zzekue02_ */
/* $Procedure SCENCD ( Encode spacecraft clock ) */
/* Subroutine */ int scencd_(integer *sc, char *sclkch, doublereal *sclkdp,
ftnlen sclkch_len)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1;
/* Builtin functions */
double d_nint(doublereal *);
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Local variables */
extern integer cpos_(char *, char *, integer *, ftnlen, ftnlen);
integer part, i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
doublereal ticks;
integer pnter;
char error[25];
doublereal pstop[9999];
extern logical failed_(void);
extern /* Subroutine */ int sigerr_(char *, ftnlen), scpart_(integer *,
integer *, doublereal *, doublereal *), chkout_(char *, ftnlen),
nparsi_(char *, integer *, char *, integer *, ftnlen, ftnlen),
sctiks_(integer *, char *, doublereal *, ftnlen), setmsg_(char *,
ftnlen), errint_(char *, integer *, ftnlen);
integer nparts;
doublereal pstart[9999];
extern logical return_(void);
doublereal ptotls[9999];
integer pos;
/* $ Abstract */
/* Encode character representation of spacecraft clock time into a */
/* double precision number. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* SCLK */
/* $ Keywords */
/* CONVERSION */
/* TIME */
/* $ Declarations */
/* $ Abstract */
/* Include file sclk.inc */
/* SPICE private file intended solely for the support of SPICE */
/* routines. Users should not include this file directly due */
/* to the volatile nature of this file */
/* The parameters below define sizes and limits used by */
/* the SCLK system. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Parameters */
/* See the declaration section below. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 2.0.0, 24-MAY-2010 (NJB) */
/* Increased value of maximum coefficient record count */
/* parameter MXCOEF from 10K to 50K. */
/* - SPICELIB Version 1.0.0, 11-FEB-2008 (NJB) */
/* -& */
/* Number of supported SCLK field delimiters: */
/* Supported SCLK string field delimiters: */
/* Maximum number of partitions: */
/* Partition string length. */
/* Since the maximum number of partitions is given by MXPART is */
/* 9999, PRTSTR needs at most 4 characters for the partition number */
/* and one character for the slash. */
/* Maximum number of coefficient records: */
/* Maximum number of fields in an SCLK string: */
/* Length of strings used to represent D.P. */
/* numbers: */
/* Maximum number of supported parallel time systems: */
/* End of include file sclk.inc */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* SC I NAIF spacecraft identification code. */
/* SCLKCH I Character representation of a spacecraft clock. */
/* SCLKDP O Encoded representation of the clock count. */
/* MXPART P Maximum number of spacecraft clock partitions. */
/* $ Detailed_Input */
/* SC is the standard NAIF ID of the spacecraft whose clock's */
/* time is being encoded. */
/* SCLKCH is the character representation of some spacecraft's */
/* clock count. */
/* SCLKCH will have the following general format: */
/* 'pp/sclk_string', or just */
/* 'sclk_string' */
/* 'pp' is an integer greater than or equal to one */
/* and is called the partition number. */
/* Each mission is divided into some number of partitions. */
/* A new partition starts when the spacecraft clock */
/* resets, either to zero, or to some other */
/* value. Thus, the first partition for any mission */
/* starts with launch, and ends with the first clock */
/* reset. The second partition starts immediately when */
/* the first stopped, and so on. */
/* In order to be completely unambiguous about a */
/* particular time, you need to specify a partition number */
/* along with the standard clock string. */
/* Information about when partitions occur for different */
/* missions is contained in a spacecraft clock kernel */
/* file, which needs to be loaded into the kernel pool, */
/* using the routines CLPOOL and FURNSH. */
/* The routine SCPART is used to read the partition */
/* start and stop times, in encoded units of SCLK (called */
/* "ticks" -- see SCLKDP below) from the kernel file. */
/* If the partition number is included, it must be */
/* separated from the rest of the string by a '/'. */
/* Any number of spaces may separate the partition number, */
/* the '/', and the rest of the clock string. */
/* If the partition number is omitted, a default partition */
/* will be assumed. The default partition is the lowest- */
/* numbered partition that contains the given clock time. */
/* If the clock time does not fall in any of the */
/* partition boundaries then an error is signaled. */
/* 'sclk_string' is a spacecraft specific clock string. */
/* Using Galileo as an example, the full format is */
/* wwwwwwww:xx:y:z */
/* where z is a mod-8 counter (values 0-7) which */
/* increments approximately once every 8 1/3 ms., y is a */
/* mod-10 counter (values 0-9) which increments once */
/* every time z turns over, i.e., approximately once every */
/* 66 2/3 ms., xx is a mod-91 (values 0-90) counter */
/* which increments once every time y turns over, i.e., */
/* once every 2/3 seconds. wwwwwwww is the Real-Time Image */
/* Count (RIM), which increments once every time xx turns */
/* over, i.e., once every 60 2/3 seconds. The roll-over */
/* expression for the RIM is 16777215, which corresponds */
/* to approximately 32 years. */
/* wwwwwwww, xx, y, and z are referred to interchangeably */
/* as the fields or components of the spacecraft clock. */
/* SCLK components may be separated by any of these */
/* five characters: ' ' ':' ',' '-' '.' */
/* Any number of spaces can separate the components and */
/* the delimiters. The presence of the RIM component */
/* is required. Successive components may be omitted, and */
/* in such cases are assumed to represent zero values. */
/* Values for the individual components may exceed the */
/* maximum expected values. For instance, '0:0:0:9' is */
/* an acceptable Galileo clock string, and will convert */
/* to the same number of ticks as '0:0:1:1'. */
/* Consecutive delimiters containing no intervening digits */
/* are treated as if they delimit zero components. */
/* Trailing zeros should always be included to match the */
/* length of the counter. For example, a Galileo clock */
/* count of '25684.90' should not be represented as */
/* '25684.9'. */
/* Some spacecraft clock components have offset, or */
/* starting, values different from zero. For example, */
/* with an offset value of 1, a mod 20 counter would */
/* cycle from 1 to 20 instead of from 0 to 19. */
/* See the SCLK required reading for a detailed */
/* description of the Voyager and Mars Observer clock */
/* formats. */
/* $ Detailed_Output */
/* SCLKDP is the double precision encoding of SCLKCH. */
/* The encoding is such that order and proximity will be */
/* preserved. That is, if t1, t2, and t3 are spacecraft */
/* clock times, and t1*, t2*, and t3* are their encodings, */
/* then if */
/* t1 < t2 < t3, and */
/* t2 is closer to t1 than to t3, you will have the result */
/* that */
/* t1* < t2* < t3*, and */
/* t2* is closer to t1* than to t3*. */
/* The units of encoded SCLK are "ticks since the start of */
/* the mission", where a "tick" is defined to be the */
/* shortest time increment expressible by a particular */
/* spacecraft's clock. */
/* Each clock string without partition number represents */
/* a certain number of ticks, but you need to include */
/* partition information to determine the relative */
/* position of that time in relation to the start of the */
/* mission. */
/* Since the end time of one partition is coincident */
/* with the begin time of the next, there are two */
/* different representations for this instant, and they */
/* will both yield the same encoding. */
/* For example, if partition 1 has an end time of t1, and */
/* partition 2 has a begin time of t2, then if we did */
/* CALL SCENCD ( '1/t1', SC, X ) and */
/* CALL SCENCD ( '2/t2', SC, Y ), then */
/* X = Y. */
/* The individual routines TIKSnn, where nn is the */
/* clock type code, contain more detailed information */
/* on the conversion process. */
/* $ Parameters */
/* MXPART is the maximum number of spacecraft clock partitions */
/* expected in the kernel file for any one spacecraft. */
/* See the INCLUDE file sclk.inc for this parameter's */
/* value. */
/* $ Exceptions */
/* 1) If the number of partitions in the kernel file for spacecraft */
/* SC exceeds the parameter MXPART, the error */
/* 'SPICE(TOOMANYPARTS)' is signaled. */
/* If a partition number is included in the SCLK string, the */
/* following exceptions may occur: */
/* 2) If the partition number cannot be parsed as an integer, the */
/* error 'SPICE(BADPARTNUMBER)' is signaled. */
/* 3) If the partition number is not in the range of the number of */
/* partitions found in the kernel pool, the error */
/* 'SPICE(BADPARTNUMBER)' is signaled. */
/* 4) If the clock count does not fall in the boundaries of the */
/* specified partition, the error 'SPICE(NOTINPART)' is */
/* signaled. */
/* If a partition number is not included in the SCLK string, the */
/* following exception may occur. */
/* 5) If the clock count does not fall in the boundaries of any */
/* partition found in the kernel pool, the error */
/* 'SPICE(NOPARTITION)' is signaled. */
/* The following error is signaled by a routine called by SCENCD */
/* 6) If any of the extracted clock components cannot be parsed as */
/* integers, or the string has too many components, or the value */
/* of one of the components is less than the offset value, then */
/* the error SPICE(INVALIDSCLKSTRING) is signaled. */
/* $ Files */
/* A kernel file containing spacecraft clock partition information */
/* for the desired spacecraft must be loaded, using the routines */
/* CLPOOL and FURNSH, before calling this routine. */
/* $ Particulars */
/* In general, it is difficult to compare spacecraft clock counts */
/* numerically since there are too many clock components for a */
/* single comparison. This routine provides a method of assigning a */
/* single double precision number to a spacecraft's clock count, */
/* given one of its character representations. */
/* The routine SCDECD performs the inverse operation to SCENCD, */
/* converting an encoded double precision number to character format. */
/* To convert the string to ticks since the start of the mission, */
/* SCENCD */
/* 1) Converts the non-partition portion of the string to */
/* ticks, using the routine SCTIKS. */
/* 2) Determines the partition number for the clock time, */
/* either by getting it directly from the input string, or */
/* determining the default partition if none was specified. */
/* 3) Includes partition start and stop times, which are also */
/* measured in ticks, to compute the number of ticks */
/* since the beginning of the mission of the clock time. */
/* $ Examples */
/* Double precision encodings of spacecraft clock counts are used to */
/* tag pointing data in the C-kernel. */
/* In the following example, pointing for a sequence of images from */
/* the Voyager 2 narrow angle camera is requested from the C-kernel */
/* using an array of character spacecraft clock counts as input. */
/* The clock counts attached to the output are then decoded to */
/* character and compared with the input strings. */
/* CHARACTER*(25) SCLKIN ( 4 ) */
/* CHARACTER*(25) SCLKOUT */
/* CHARACTER*(25) CLKTOL */
/* DOUBLE PRECISION TIMEIN */
/* DOUBLE PRECISION TIMOUT */
/* DOUBLE PRECISION CMAT ( 3, 3 ) */
/* INTEGER NPICS */
/* INTEGER SC */
/* DATA NPICS / 4 / */
/* DATA SCLKIN / '2 / 20538:39:768', */
/* . '2 / 20543:21:768', */
/* . '2 / 20550:37', */
/* . '2 / 20561:59' / */
/* DATA CLKTOL / ' 0:01:000' / */
/* C */
/* C The instrument we want pointing for is the Voyager 2 */
/* C narrow angle camera. The reference frame we want is */
/* C J2000. The spacecraft is Voyager 2. */
/* C */
/* INST = -32001 */
/* REF = 'J2000' */
/* SC = -32 */
/* C */
/* C Load the appropriate files. We need */
/* C */
/* C 1) CK file containing pointing data. */
/* C 2) Spacecraft clock kernel file, for SCENCD and SCDECD. */
/* C */
/* CALL CKLPF ( 'VGR2NA.CK' ) */
/* CALL CLPOOL */
/* CALL FURNSH ( 'SCLK.KER' ) */
/* C */
/* C Convert the tolerance string to ticks. */
/* C */
/* CALL SCTIKS ( SC, CLKTOL, TOL ) */
/* DO I = 1, NPICS */
/* CALL SCENCD ( SC, SCLKIN( I ), TIMEIN ) */
/* CALL CKGP ( INST, TIMEIN, TOL, REF, CMAT, TIMOUT, */
/* . FOUND ) */
/* CALL SCDECD ( SC, TIMOUT, SCLKOUT ) */
/* WRITE (*,*) */
/* WRITE (*,*) 'Input s/c clock count: ', SCLKIN( I ) */
/* WRITE (*,*) 'Output s/c clock count: ', SCLKOUT */
/* WRITE (*,*) 'Output C-Matrix: ', CMAT */
/* WRITE (*,*) */
/* END DO */
/* The output from such a program might look like: */
/* Input s/c clock count: 2 / 20538:39:768 */
/* Output s/c clock count: 2/20538:39:768 */
/* Output C-Matrix: 'first C-matrix' */
/* Input s/c clock count: 2 / 20543:21:768 */
/* Output s/c clock count: 2/20543:22:768 */
/* Output C-Matrix: 'second C-matrix' */
/* Input s/c clock count: 2 / 20550:37 */
/* Output s/c clock count: 2/20550:36:768 */
/* Output C-Matrix: 'third C-matrix' */
/* Input s/c clock count: 2 / 20561:59 */
/* Output s/c clock count: 2/20561:58:768 */
/* Output C-Matrix: 'fourth C-matrix' */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* J.M. Lynch (JPL) */
/* R.E. Thurman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.2.0, 28-FEB-2014 (BVS) */
/* Added FAILED checks to prevent passing uninitialized values to */
/* ANINT, which can causing numeric exceptions on some */
/* environments. */
/* - SPICELIB Version 1.1.0, 05-FEB-2008 (NJB) */
/* The values of the parameter MXPART is now */
/* provided by the INCLUDE file sclk.inc. */
/* - SPICELIB Version 1.0.2, 22-AUG-2006 (EDW) */
/* Replaced references to LDPOOL with references */
/* to FURNSH. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 03-SEP-1990 (JML) (RET) */
/* -& */
/* $ Index_Entries */
/* encode spacecraft_clock */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SCENCD", (ftnlen)6);
}
/* Convert the non-partition portion of the clock string to ticks. */
pos = cpos_(sclkch, "/", &c__1, sclkch_len, (ftnlen)1);
i__1 = pos;
sctiks_(sc, sclkch + i__1, &ticks, sclkch_len - i__1);
if (failed_()) {
chkout_("SCENCD", (ftnlen)6);
return 0;
}
ticks = d_nint(&ticks);
/* Read the partition start and stop times (in ticks) for this */
/* mission. Error if there are too many of them. */
scpart_(sc, &nparts, pstart, pstop);
if (failed_()) {
chkout_("SCENCD", (ftnlen)6);
return 0;
}
if (nparts > 9999) {
setmsg_("The number of partitions, #, for spacecraft # exceeds the v"
"alue for parameter MXPART, #.", (ftnlen)88);
errint_("#", &nparts, (ftnlen)1);
errint_("#", sc, (ftnlen)1);
errint_("#", &c__9999, (ftnlen)1);
sigerr_("SPICE(TOOMANYPARTS)", (ftnlen)19);
chkout_("SCENCD", (ftnlen)6);
return 0;
}
/* PSTART and PSTOP represent integers but are read from the */
/* kernel pool as double precision numbers. Make them whole */
/* numbers so that logical tests may be performed with them. */
i__1 = nparts;
for (i__ = 1; i__ <= i__1; ++i__) {
pstop[(i__2 = i__ - 1) < 9999 && 0 <= i__2 ? i__2 : s_rnge("pstop",
i__2, "scencd_", (ftnlen)500)] = d_nint(&pstop[(i__3 = i__ -
1) < 9999 && 0 <= i__3 ? i__3 : s_rnge("pstop", i__3, "scenc"
"d_", (ftnlen)500)]);
pstart[(i__2 = i__ - 1) < 9999 && 0 <= i__2 ? i__2 : s_rnge("pstart",
i__2, "scencd_", (ftnlen)501)] = d_nint(&pstart[(i__3 = i__ -
1) < 9999 && 0 <= i__3 ? i__3 : s_rnge("pstart", i__3, "scen"
"cd_", (ftnlen)501)]);
}
/* For each partition, compute the total number of ticks in that */
/* partition plus all preceding partitions. */
d__1 = pstop[0] - pstart[0];
ptotls[0] = d_nint(&d__1);
i__1 = nparts;
for (i__ = 2; i__ <= i__1; ++i__) {
d__1 = ptotls[(i__3 = i__ - 2) < 9999 && 0 <= i__3 ? i__3 : s_rnge(
"ptotls", i__3, "scencd_", (ftnlen)512)] + pstop[(i__4 = i__
- 1) < 9999 && 0 <= i__4 ? i__4 : s_rnge("pstop", i__4, "sce"
"ncd_", (ftnlen)512)] - pstart[(i__5 = i__ - 1) < 9999 && 0 <=
i__5 ? i__5 : s_rnge("pstart", i__5, "scencd_", (ftnlen)512)];
ptotls[(i__2 = i__ - 1) < 9999 && 0 <= i__2 ? i__2 : s_rnge("ptotls",
i__2, "scencd_", (ftnlen)512)] = d_nint(&d__1);
}
/* Determine the partition number for the input clock string: */
/* If it was included in the string make sure it's valid for */
/* this mission. */
/* Error if */
/* 1) The partition number can't be parsed. */
/* 2) The partition number is not in the range 1 to the number */
/* of partitions. */
/* 3) The clock count does not fall in the boundaries of the */
/* specified partition. */
/* If it wasn't included, determine the default partition for */
/* this clock count. */
/* Error if */
/* 1) The clock count does not fall in the boundaries of any */
/* of the partitions. */
if (pos == 1) {
setmsg_("Unable to parse the partition number from SCLK string #.", (
ftnlen)56);
errch_("#", sclkch, (ftnlen)1, sclkch_len);
sigerr_("SPICE(BADPARTNUMBER)", (ftnlen)20);
chkout_("SCENCD", (ftnlen)6);
return 0;
}
if (pos > 1) {
part = 0;
nparsi_(sclkch, &part, error, &pnter, pos - 1, (ftnlen)25);
if (s_cmp(error, " ", (ftnlen)25, (ftnlen)1) != 0) {
setmsg_("Unable to parse the partition number from SCLK string #."
, (ftnlen)56);
errch_("#", sclkch, (ftnlen)1, sclkch_len);
sigerr_("SPICE(BADPARTNUMBER)", (ftnlen)20);
chkout_("SCENCD", (ftnlen)6);
return 0;
} else if (part <= 0 || part > nparts) {
setmsg_("Partition number # taken from SCLK string # is not in a"
"cceptable range 1 to #.", (ftnlen)78);
errint_("#", &part, (ftnlen)1);
errch_("#", sclkch, (ftnlen)1, sclkch_len);
errint_("#", &nparts, (ftnlen)1);
sigerr_("SPICE(BADPARTNUMBER)", (ftnlen)20);
chkout_("SCENCD", (ftnlen)6);
return 0;
} else if (ticks < pstart[(i__1 = part - 1) < 9999 && 0 <= i__1 ?
i__1 : s_rnge("pstart", i__1, "scencd_", (ftnlen)575)] ||
ticks > pstop[(i__2 = part - 1) < 9999 && 0 <= i__2 ? i__2 :
s_rnge("pstop", i__2, "scencd_", (ftnlen)575)]) {
setmsg_("SCLK count # does not fall in the boundaries of partiti"
"on number #.", (ftnlen)67);
errch_("#", sclkch, (ftnlen)1, sclkch_len);
errint_("#", &part, (ftnlen)1);
sigerr_("SPICE(NOTINPART)", (ftnlen)16);
chkout_("SCENCD", (ftnlen)6);
return 0;
}
} else {
part = 1;
while(part <= nparts && (ticks < pstart[(i__1 = part - 1) < 9999 && 0
<= i__1 ? i__1 : s_rnge("pstart", i__1, "scencd_", (ftnlen)
592)] || ticks > pstop[(i__2 = part - 1) < 9999 && 0 <= i__2 ?
i__2 : s_rnge("pstop", i__2, "scencd_", (ftnlen)592)])) {
++part;
}
if (part > nparts) {
setmsg_("SCLK count # does not fall in the boundaries of any of "
"the partitions for spacecraft #.", (ftnlen)87);
errch_("#", sclkch, (ftnlen)1, sclkch_len);
errint_("#", sc, (ftnlen)1);
sigerr_("SPICE(NOPARTITION)", (ftnlen)18);
chkout_("SCENCD", (ftnlen)6);
return 0;
}
}
/* Now we have a valid partition number, and the number of ticks for */
/* the clock string. To convert to ticks since the start of the */
/* mission, add in the total number of ticks in preceding partitions */
/* and subtract off the starting ticks value for this partition. */
if (part > 1) {
*sclkdp = ticks - pstart[(i__1 = part - 1) < 9999 && 0 <= i__1 ? i__1
: s_rnge("pstart", i__1, "scencd_", (ftnlen)622)] + ptotls[(
i__2 = part - 2) < 9999 && 0 <= i__2 ? i__2 : s_rnge("ptotls",
i__2, "scencd_", (ftnlen)622)];
} else {
*sclkdp = ticks - pstart[(i__1 = part - 1) < 9999 && 0 <= i__1 ? i__1
: s_rnge("pstart", i__1, "scencd_", (ftnlen)624)];
}
chkout_("SCENCD", (ftnlen)6);
return 0;
} /* scencd_ */
/* $Procedure SPKW19 ( Write SPK segment, type 19 ) */
/* Subroutine */ int spkw19_(integer *handle, integer *body, integer *center,
char *frame, doublereal *first, doublereal *last, char *segid,
integer *nintvl, integer *npkts, integer *subtps, integer *degres,
doublereal *packts, doublereal *epochs, doublereal *ivlbds, logical *
sellst, ftnlen frame_len, ftnlen segid_len)
{
/* Initialized data */
static integer pktszs[2] = { 12,6 };
/* System generated locals */
integer i__1, i__2;
doublereal d__1;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
integer isel, ndir, i__, j, k;
extern /* Subroutine */ int chkin_(char *, ftnlen), dafps_(integer *,
integer *, doublereal *, integer *, doublereal *);
doublereal descr[5];
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen);
integer bepix, eepix;
extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen), dafada_(
doublereal *, integer *);
doublereal dc[2];
extern /* Subroutine */ int dafbna_(integer *, doublereal *, char *,
ftnlen);
integer ic[6];
extern /* Subroutine */ int dafena_(void);
extern logical failed_(void);
integer segbeg, chrcod, refcod, segend, pktbeg;
extern /* Subroutine */ int namfrm_(char *, integer *, ftnlen);
extern integer lastnb_(char *, ftnlen);
integer pktend;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
integer minisz;
extern logical return_(void);
integer pktdsz, winsiz, pktsiz, subtyp;
extern logical odd_(integer *);
/* $ Abstract */
/* Write a type 19 segment to an SPK file. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* DAF */
/* NAIF_IDS */
/* SPC */
/* SPK */
/* TIME */
/* $ Keywords */
/* EPHEMERIS */
/* FILES */
/* $ Declarations */
/* $ Abstract */
/* Declare parameters specific to SPK type 19. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* SPK */
/* $ Keywords */
/* SPK */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* B.V. Semenov (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 07-MAR-2014 (NJB) (BVS) */
/* -& */
/* Maximum polynomial degree supported by the current */
/* implementation of this SPK type. */
/* The degree is compatible with the maximum degrees */
/* supported by types 13 and 21. */
/* Integer code indicating `true': */
/* Integer code indicating `false': */
/* SPK type 19 subtype codes: */
/* Subtype 0: Hermite interpolation, 12-element packets. */
/* Subtype 1: Lagrange interpolation, 6-element packets. */
/* Packet sizes associated with the various subtypes: */
/* Number of subtypes: */
/* Maximum packet size for type 19: */
/* Minimum packet size for type 19: */
/* The SPKPVN record size declared in spkrec.inc must be at least as */
/* large as the maximum possible size of an SPK type 19 record. */
/* The largest possible SPK type 19 record has subtype 1 (note that */
/* records of subtype 0 have half as many epochs as those of subtype */
/* 1, for a given polynomial degree). A type 1 record contains */
/* - The subtype and packet count */
/* - MAXDEG+1 packets of size S19PS1 */
/* - MAXDEG+1 time tags */
/* End of include file spk19.inc. */
/* $ Abstract */
/* Declare SPK data record size. This record is declared in */
/* SPKPVN and is passed to SPK reader (SPKRxx) and evaluator */
/* (SPKExx) routines. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* SPK */
/* $ Keywords */
/* SPK */
/* $ Restrictions */
/* 1) If new SPK types are added, it may be necessary to */
/* increase the size of this record. The header of SPKPVN */
/* should be updated as well to show the record size */
/* requirement for each data type. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 2.0.0, 05-OCT-2012 (NJB) */
/* Updated to support increase of maximum degree to 27 for types */
/* 2, 3, 8, 9, 12, 13, 18, and 19. See SPKPVN for a list */
/* of record size requirements as a function of data type. */
/* - SPICELIB Version 1.0.0, 16-AUG-2002 (NJB) */
/* -& */
/* End include file spkrec.inc */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle of an SPK file open for writing. */
/* BODY I NAIF ID code for an ephemeris object. */
/* CENTER I NAIF ID code for center of motion of BODY. */
/* FRAME I Reference frame name. */
/* FIRST I Start time of interval covered by segment. */
/* LAST I End time of interval covered by segment. */
/* SEGID I Segment identifier. */
/* NINTVL I Number of mini-segments and interpolation */
/* intervals. */
/* NPKTS I Array of packet counts of mini-segments. */
/* SUBTPS I Array of segment subtypes of mini-segments. */
/* DEGRES I Array of polynomial degrees of mini-segments. */
/* PACKTS I Array of data packets of mini-segments. */
/* EPOCHS I Array of epochs of mini-segments. */
/* IVLBDS I Interpolation interval bounds. */
/* SELLST I Interval selection flag. */
/* MAXDEG P Maximum allowed degree of interpolating polynomial. */
/* $ Detailed_Input */
/* HANDLE is the handle of an SPK file that has been opened */
/* for writing. */
/* BODY is the NAIF integer code for an ephemeris object */
/* whose state relative to another body is described */
/* by the segment to be created. */
/* CENTER is the NAIF integer code for the center of motion */
/* of the object identified by BODY. */
/* FRAME is the NAIF name for a reference frame */
/* relative to which the state information for BODY */
/* is specified. */
/* FIRST, */
/* LAST are, respectively, the bounds of the time interval */
/* over which the segment defines the state of BODY. */
/* FIRST must be greater than or equal to the first */
/* interpolation interval start time; LAST must be */
/* less than or equal to the last interpolation */
/* interval stop time. See the description of IVLBDS */
/* below. */
/* SEGID is the segment identifier. An SPK segment */
/* identifier may contain up to 40 characters. */
/* NINTVL is the number of interpolation intervals */
/* associated with the input data. The interpolation */
/* intervals are associated with data sets referred */
/* to as "mini-segments." */
/* The input data comprising each mini-segment are: */
/* - a packet count */
/* - a type 19 subtype */
/* - an interpolating polynomial degree */
/* - a sequence of type 19 data packets */
/* - a sequence of packet epochs */
/* These inputs are described below. */
/* NPKTS is an array of packet counts. The Ith element of */
/* NPKTS is the packet count of the Ith interpolation */
/* interval/mini-segment. */
/* NPKTS has dimension NINTVL. */
/* SUBTPS is an array of type 19 subtypes. The Ith element */
/* of SUBTPS is the subtype of the packets associated */
/* with the Ith interpolation interval/mini-segment. */
/* SUBTPS has dimension NINTVL. */
/* DEGRES is an array of interpolating polynomial degrees. */
/* The Ith element of DEGRES is the polynomial degree */
/* of the packets associated with the Ith */
/* interpolation interval/mini-segment. */
/* For subtype 0, interpolation degrees must be */
/* equivalent to 3 mod 4, that is, they must be in */
/* the set */
/* { 3, 7, 11, ..., MAXDEG } */
/* For subtype 1, interpolation degrees must be odd */
/* and must be in the range 1:MAXDEG. */
/* DEGRES has dimension NINTVL. */
/* PACKTS is an array containing data packets for all input */
/* mini-segments. The packets for a given */
/* mini-segment are stored contiguously in increasing */
/* time order. The order of the sets of packets for */
/* different mini-segments is the same as the order */
/* of their corresponding interpolation intervals. */
/* Each packet represents geometric states of BODY */
/* relative to CENTER, specified relative to FRAME. */
/* The packet structure depends on the segment */
/* subtype as follows: */
/* Type 0 (indicated by code S19TP0): */
/* x, y, z, dx/dt, dy/dt, dz/dt, */
/* vx, vy, vz, dvx/dt, dvy/dt, dvz/dt */
/* where x, y, z represent Cartesian position */
/* components and vx, vy, vz represent Cartesian */
/* velocity components. Note well: vx, vy, and */
/* vz *are not necessarily equal* to the time */
/* derivatives of x, y, and z. This packet */
/* structure mimics that of the Rosetta/MEX orbit */
/* file. */
/* Type 1 (indicated by code S19TP1): */
/* x, y, z, dx/dt, dy/dt, dz/dt */
/* where x, y, z represent Cartesian position */
/* components and vx, vy, vz represent Cartesian */
/* velocity components. */
/* Position units are kilometers, velocity units */
/* are kilometers per second, and acceleration units */
/* are kilometers per second per second. */
/* EPOCHS is an array containing epochs for all input */
/* mini-segments. Each epoch is expressed as seconds */
/* past J2000 TDB. The epochs have a one-to-one */
/* relationship with the packets in the input packet */
/* array. */
/* The epochs for a given mini-segment are stored */
/* contiguously in increasing order. The order of the */
/* sets of epochs for different mini-segments is the */
/* same as the order of their corresponding */
/* interpolation intervals. */
/* For each mini-segment, "padding" is allowed: the */
/* sequence of epochs for that mini-segment may start */
/* before the corresponding interpolation interval */
/* start time and end after the corresponding */
/* interpolation interval stop time. Padding is used */
/* to control behavior of interpolating polynomials */
/* near interpolation interval boundaries. */
/* Due to possible use of padding, the elements of */
/* EPOCHS, taken as a whole, may not be in increasing */
/* order. */
/* IVLBDS is an array of interpolation interval boundary */
/* times. This array is an ordered list of the */
/* interpolation interval start times, to which the */
/* the end time for the last interval is appended. */
/* The Ith interpolation interval is the time */
/* coverage interval of the Ith mini-segment (see the */
/* description of NPKTS above). */
/* For each mini-segment, the corresponding */
/* interpolation interval's start time is greater */
/* than or equal to the mini-segment's first epoch, */
/* and the interval's stop time is less than or equal */
/* to the mini-segment's last epoch. */
/* For each interpolation interval other than the */
/* last, the interval's coverage stop time coincides */
/* with the coverage start time of the next interval. */
/* There are no coverage gaps, and coverage overlap */
/* for adjacent intervals consists of a single epoch. */
/* IVLBDS has dimension NINTVL+1. */
/* SELLST is a logical flag indicating to the SPK type 19 */
/* segment reader SPKR19 how to select the */
/* interpolation interval when a request time */
/* coincides with a time boundary shared by two */
/* interpolation intervals. When SELLST ("select */
/* last") is .TRUE., the later interval is selected; */
/* otherwise the earlier interval is selected. */
/* $ Detailed_Output */
/* None. See $Particulars for a description of the effect of this */
/* routine. */
/* $ Parameters */
/* MAXDEG is the maximum allowed degree of the interpolating */
/* polynomial. */
/* See the INCLUDE file spk19.inc for the value of */
/* MAXDEG. */
/* $ Exceptions */
/* If any of the following exceptions occur, this routine will return */
/* without creating a new segment. */
/* 1) If FIRST is greater than LAST then the error */
/* SPICE(BADDESCRTIMES) will be signaled. */
/* 2) If FRAME is not a recognized name, the error */
/* SPICE(INVALIDREFFRAME) is signaled. */
/* 3) If the last non-blank character of SEGID occurs past index */
/* 40, the error SPICE(SEGIDTOOLONG) is signaled. */
/* 4) If SEGID contains any nonprintable characters, the error */
/* SPICE(NONPRINTABLECHARS) is signaled. */
/* 5) If NINTVL is not at least 1, the error SPICE(INVALIDCOUNT) */
/* is signaled. */
/* 6) If the elements of the array IVLBDS are not in strictly */
/* increasing order, the error SPICE(BOUNDSOUTOFORDER) will be */
/* signaled. */
/* 7) If the first interval start time IVLBDS(1) is greater than */
/* FIRST, or if the last interval end time IVLBDS(N+1) is less */
/* than LAST, the error SPICE(COVERAGEGAP) will be signaled. */
/* 8) If any packet count in the array NPKTS is not at least 2, the */
/* error SPICE(TOOFEWPACKETS) will be signaled. */
/* 9) If any subtype code in the array SUBTPS is not recognized, */
/* the error SPICE(INVALIDSUBTYPE) will be signaled. */
/* 10) If any interpolation degree in the array DEGRES */
/* is not at least 1 or is greater than MAXDEG, the */
/* error SPICE(INVALIDDEGREE) is signaled. */
/* 11) If the window size implied by any element of the array DEGRES */
/* is odd, the error SPICE(BADWINDOWSIZE) is signaled. */
/* 12) If the elements of the array EPOCHS corresponding to a given */
/* mini-segment are not in strictly increasing order, the error */
/* SPICE(TIMESOUTOFORDER) will be signaled. */
/* 13) If the first epoch of a mini-segment exceeds the start */
/* time of the associated interpolation interval, or if the */
/* last epoch of the mini-segment precedes the end time of the */
/* interpolation interval, the error SPICE(BOUNDSDISAGREE) */
/* is signaled. */
/* 14) Any error that occurs while writing the output segment will */
/* be diagnosed by routines in the call tree of this routine. */
/* $ Files */
/* A new type 19 SPK segment is written to the SPK file attached */
/* to HANDLE. */
/* $ Particulars */
/* This routine writes an SPK type 19 data segment to the open SPK */
/* file according to the format described in the type 19 section of */
/* the SPK Required Reading. The SPK file must have been opened with */
/* write access. */
/* $ Examples */
/* Suppose that you have states and are prepared to produce */
/* a segment of type 19 in an SPK file. */
/* The following code fragment could be used to add the new segment */
/* to a previously opened SPK file attached to HANDLE. The file must */
/* have been opened with write access. */
/* C */
/* C Create a segment identifier. */
/* C */
/* SEGID = 'MY_SAMPLE_SPK_TYPE_19_SEGMENT' */
/* C */
/* C Write the segment. */
/* C */
/* CALL SPKW19 ( HANDLE, BODY, CENTER, FRAME, */
/* . FIRST, LAST, SEGID, NINTVL, */
/* . NPKTS, SUBTPS, DEGRES, PACKTS, */
/* . EPOCHS, IVLBDS, SELLST ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 05-FEB-2014 (NJB) (BVS) */
/* -& */
/* $ Index_Entries */
/* write spk type_19 ephemeris data segment */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Saved values */
/* Initial values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
chkin_("SPKW19", (ftnlen)6);
/* Start with a parameter compatibility check. */
if (FALSE_) {
setmsg_("SPK type 19 record size may be as large as #, but SPKPVN re"
"cord size is #.", (ftnlen)74);
errint_("#", &c__198, (ftnlen)1);
errint_("#", &c__198, (ftnlen)1);
sigerr_("SPICE(BUG0)", (ftnlen)11);
chkout_("SPKW19", (ftnlen)6);
return 0;
}
/* Make sure the segment descriptor bounds are */
/* correctly ordered. */
if (*last < *first) {
setmsg_("Segment start time is #; stop time is #; bounds must be in "
"nondecreasing order.", (ftnlen)79);
errdp_("#", first, (ftnlen)1);
errdp_("#", last, (ftnlen)1);
sigerr_("SPICE(BADDESCRTIMES)", (ftnlen)20);
chkout_("SPKW19", (ftnlen)6);
return 0;
}
/* Get the NAIF integer code for the reference frame. */
namfrm_(frame, &refcod, frame_len);
if (refcod == 0) {
setmsg_("The reference frame # is not supported.", (ftnlen)39);
errch_("#", frame, (ftnlen)1, frame_len);
sigerr_("SPICE(INVALIDREFFRAME)", (ftnlen)22);
chkout_("SPKW19", (ftnlen)6);
return 0;
}
/* Check to see if the segment identifier is too long. */
if (lastnb_(segid, segid_len) > 40) {
setmsg_("Segment identifier contains more than 40 characters.", (
ftnlen)52);
sigerr_("SPICE(SEGIDTOOLONG)", (ftnlen)19);
chkout_("SPKW19", (ftnlen)6);
return 0;
}
/* Now check that all the characters in the segment identifier */
/* can be printed. */
i__1 = lastnb_(segid, segid_len);
for (i__ = 1; i__ <= i__1; ++i__) {
chrcod = *(unsigned char *)&segid[i__ - 1];
if (chrcod < 32 || chrcod > 126) {
setmsg_("The segment identifier contains nonprintable characters",
(ftnlen)55);
sigerr_("SPICE(NONPRINTABLECHARS)", (ftnlen)24);
chkout_("SPKW19", (ftnlen)6);
return 0;
}
}
/* The mini-segment/interval count must be positive. */
if (*nintvl < 1) {
setmsg_("Mini-segment/interval count was #; this count must be posit"
"ive.", (ftnlen)63);
errint_("#", nintvl, (ftnlen)1);
sigerr_("SPICE(INVALIDCOUNT)", (ftnlen)19);
chkout_("SPKW19", (ftnlen)6);
return 0;
}
/* Make sure the interval bounds form a strictly */
/* increasing sequence. */
/* Note that there are NINTVL+1 bounds. */
i__1 = *nintvl;
for (i__ = 1; i__ <= i__1; ++i__) {
if (ivlbds[i__ - 1] >= ivlbds[i__]) {
setmsg_("Interval bounds at indices # and # are # and # respecti"
"vely. The difference is #. The bounds are required to be"
" strictly increasing.", (ftnlen)132);
errint_("#", &i__, (ftnlen)1);
i__2 = i__ + 1;
errint_("#", &i__2, (ftnlen)1);
errdp_("#", &ivlbds[i__ - 1], (ftnlen)1);
errdp_("#", &ivlbds[i__], (ftnlen)1);
d__1 = ivlbds[i__] - ivlbds[i__ - 1];
errdp_("#", &d__1, (ftnlen)1);
sigerr_("SPICE(BOUNDSOUTOFORDER)", (ftnlen)23);
chkout_("SPKW19", (ftnlen)6);
return 0;
}
}
/* Make sure the time span of the descriptor doesn't extend */
/* beyond the span of the interval bounds. */
if (*first < ivlbds[0] || *last > ivlbds[*nintvl]) {
setmsg_("First interval start time is #; segment start time is #; se"
"gment stop time is #; last interval stop time is #. This seq"
"uence of times is required to be non-decreasing: segment cov"
"erage must be contained within the union of the interpolatio"
"n intervals.", (ftnlen)251);
errdp_("#", ivlbds, (ftnlen)1);
errdp_("#", first, (ftnlen)1);
errdp_("#", last, (ftnlen)1);
errdp_("#", &ivlbds[*nintvl], (ftnlen)1);
sigerr_("SPICE(COVERAGEGAP)", (ftnlen)18);
chkout_("SPKW19", (ftnlen)6);
return 0;
}
/* Check the input data before writing to the file. */
/* This order of operations entails some redundant */
/* calculations, but it allows for rapid error */
/* detection. */
/* Initialize the mini-segment packet array indices, */
/* and those of the mini-segment epoch array as well. */
pktbeg = 0;
pktend = 0;
bepix = 0;
eepix = 0;
i__1 = *nintvl;
for (i__ = 1; i__ <= i__1; ++i__) {
/* First, just make sure the packet count for the current */
/* mini-segment is at least two. This check reduces our chances */
/* of a subscript range violation. */
/* Check the number of packets. */
if (npkts[i__ - 1] < 2) {
setmsg_("At least 2 packets are required for SPK type 19. Number"
" of packets supplied was # in mini-segment at index #.", (
ftnlen)109);
errint_("#", &npkts[i__ - 1], (ftnlen)1);
errint_("#", &i__, (ftnlen)1);
sigerr_("SPICE(TOOFEWPACKETS)", (ftnlen)20);
chkout_("SPKW19", (ftnlen)6);
return 0;
}
/* Set the packet size, which is a function of the subtype. Also */
/* set the window size. First check the subtype, which will be */
/* used as an array index. */
subtyp = subtps[i__ - 1];
if (subtyp < 0 || subtyp > 1) {
setmsg_("Unexpected SPK type 19 subtype # found in mini-segment "
"#.", (ftnlen)57);
errint_("#", &subtyp, (ftnlen)1);
errint_("#", &i__, (ftnlen)1);
sigerr_("SPICE(INVALIDSUBTYPE)", (ftnlen)21);
chkout_("SPKW19", (ftnlen)6);
return 0;
}
pktsiz = pktszs[(i__2 = subtyp) < 2 && 0 <= i__2 ? i__2 : s_rnge(
"pktszs", i__2, "spkw19_", (ftnlen)689)];
if (odd_(&subtyp)) {
winsiz = degres[i__ - 1] + 1;
} else {
winsiz = (degres[i__ - 1] + 1) / 2;
}
/* Make sure that the degree of the interpolating polynomials is */
/* in range. */
if (degres[i__ - 1] < 1 || degres[i__ - 1] > 27) {
setmsg_("The interpolating polynomials of mini-segment # have de"
"gree #; the valid degree range is [1, #]", (ftnlen)95);
errint_("#", &i__, (ftnlen)1);
errint_("#", °res[i__ - 1], (ftnlen)1);
errint_("#", &c__27, (ftnlen)1);
sigerr_("SPICE(INVALIDDEGREE)", (ftnlen)20);
chkout_("SPKW19", (ftnlen)6);
return 0;
}
/* Make sure that the window size is even. */
if (odd_(&winsiz)) {
setmsg_("The interpolating polynomials of mini-segment # have wi"
"ndow size # and degree # for SPK type 19. The mini-segme"
"nt subtype is #. The degree must be equivalent to 3 mod "
"4 for subtype 0 (Hermite interpolation) and be odd for s"
"ubtype 1 (Lagrange interpolation).", (ftnlen)257);
errint_("#", &i__, (ftnlen)1);
errint_("#", &winsiz, (ftnlen)1);
errint_("#", °res[i__ - 1], (ftnlen)1);
errint_("#", &subtps[i__ - 1], (ftnlen)1);
sigerr_("SPICE(BADWINDOWSIZE)", (ftnlen)20);
chkout_("SPKW19", (ftnlen)6);
return 0;
}
/* Make sure the epochs of the Ith mini-segment form a */
/* strictly increasing sequence. */
/* To start out, determine the indices of the epoch sequence */
/* of the Ith mini-segment. We'll call the begin and end */
/* epoch indices BEPIX and EEPIX respectively. */
bepix = eepix + 1;
eepix = bepix - 1 + npkts[i__ - 1];
i__2 = npkts[i__ - 1] - 1;
for (j = 1; j <= i__2; ++j) {
k = bepix + j - 1;
if (epochs[k - 1] >= epochs[k]) {
setmsg_("In mini-segment #, epoch # having index # in array "
"EPOCHS and index # in the mini-segment is greater th"
"an or equal to its successor #.", (ftnlen)134);
errint_("#", &i__, (ftnlen)1);
errdp_("#", &epochs[k - 1], (ftnlen)1);
errint_("#", &k, (ftnlen)1);
errint_("#", &j, (ftnlen)1);
errdp_("#", &epochs[k], (ftnlen)1);
sigerr_("SPICE(TIMESOUTOFORDER)", (ftnlen)22);
chkout_("SPKW19", (ftnlen)6);
return 0;
}
}
/* Make sure that the span of the input epochs of the Ith */
/* mini-segment includes the Ith interpolation interval. */
if (epochs[bepix - 1] > ivlbds[i__ - 1]) {
setmsg_("Interpolation interval # start time # precedes mini-seg"
"ment's first epoch #.", (ftnlen)76);
errint_("#", &i__, (ftnlen)1);
errdp_("#", &ivlbds[i__ - 1], (ftnlen)1);
errdp_("#", &epochs[bepix - 1], (ftnlen)1);
sigerr_("SPICE(BOUNDSDISAGREE)", (ftnlen)21);
chkout_("SPKW19", (ftnlen)6);
return 0;
} else if (epochs[eepix - 1] < ivlbds[i__]) {
setmsg_("Interpolation interval # end time # exceeds mini-segmen"
"t's last epoch #.", (ftnlen)72);
errint_("#", &i__, (ftnlen)1);
errdp_("#", &ivlbds[i__], (ftnlen)1);
errdp_("#", &epochs[eepix - 1], (ftnlen)1);
sigerr_("SPICE(BOUNDSDISAGREE)", (ftnlen)21);
chkout_("SPKW19", (ftnlen)6);
return 0;
}
}
/* If we made it this far, we're ready to start writing the segment. */
/* The type 19 segment structure is eloquently described by this */
/* diagram from the SPK Required Reading: */
/* +--------------------------------+ */
/* | Interval 1 mini-segment | */
/* +--------------------------------+ */
/* . */
/* . */
/* . */
/* +--------------------------------+ */
/* | Interval N mini-segment | */
/* +--------------------------------+ */
/* | Interval 1 start time | */
/* +--------------------------------+ */
/* . */
/* . */
/* . */
/* +--------------------------------+ */
/* | Interval N start time | */
/* +--------------------------------+ */
/* | Interval N stop time | */
/* +--------------------------------+ */
/* | Interval start 100 | (First interval directory) */
/* +--------------------------------+ */
/* . */
/* . */
/* . */
/* +--------------------------------+ */
/* | Interval start (N/100)*100 | (Last interval directory) */
/* +--------------------------------+ */
/* | Interval 1 start pointer | */
/* +--------------------------------+ */
/* . */
/* . */
/* . */
/* +--------------------------------+ */
/* | Interval N start pointer | */
/* +--------------------------------+ */
/* | Interval N stop pointer + 1 | */
/* +--------------------------------+ */
/* | Boundary choice flag | */
/* +--------------------------------+ */
/* | Number of intervals | */
/* +--------------------------------+ */
/* SPK type 19 mini-segments have the following structure: */
/* +-----------------------+ */
/* | Packet 1 | */
/* +-----------------------+ */
/* . */
/* . */
/* . */
/* +-----------------------+ */
/* | Packet M | */
/* +-----------------------+ */
/* | Epoch 1 | */
/* +-----------------------+ */
/* . */
/* . */
/* . */
/* +-----------------------+ */
/* | Epoch M | */
/* +-----------------------+ */
/* | Epoch 100 | (First time tag directory) */
/* +-----------------------+ */
/* . */
/* . */
/* . */
/* +-----------------------+ */
/* | Epoch ((M-1)/100)*100 | (Last time tag directory) */
/* +-----------------------+ */
/* | Subtype code | */
/* +-----------------------+ */
/* | Window size | */
/* +-----------------------+ */
/* | Number of packets | */
/* +-----------------------+ */
/* Create the segment descriptor. We don't use SPKPDS because */
/* that routine doesn't allow creation of a singleton segment. */
ic[0] = *body;
ic[1] = *center;
ic[2] = refcod;
ic[3] = 19;
dc[0] = *first;
dc[1] = *last;
dafps_(&c__2, &c__6, dc, ic, descr);
/* Begin a new segment. */
dafbna_(handle, descr, segid, segid_len);
if (failed_()) {
chkout_("SPKW19", (ftnlen)6);
return 0;
}
/* Re-initialize the mini-segment packet array indices, */
/* and those of the mini-segment epoch array as well. */
pktbeg = 0;
pktend = 0;
bepix = 0;
eepix = 0;
/* Write data for each mini-segment to the file. */
i__1 = *nintvl;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Set the packet size, which is a function of the subtype. */
subtyp = subtps[i__ - 1];
pktsiz = pktszs[(i__2 = subtyp) < 2 && 0 <= i__2 ? i__2 : s_rnge(
"pktszs", i__2, "spkw19_", (ftnlen)931)];
if (odd_(&subtyp)) {
winsiz = degres[i__ - 1] + 1;
} else {
winsiz = (degres[i__ - 1] + 1) / 2;
}
/* Now that we have the packet size, we can compute */
/* mini-segment packet index range. We'll let PKTDSZ */
/* be the total count of packet data entries for this */
/* mini-segment. */
pktdsz = npkts[i__ - 1] * pktsiz;
pktbeg = pktend + 1;
pktend = pktbeg - 1 + pktdsz;
/* At this point, we're read to start writing the */
/* current mini-segment to the file. Start with the */
/* packet data. */
dafada_(&packts[pktbeg - 1], &pktdsz);
/* Write the epochs for this mini-segment. */
bepix = eepix + 1;
eepix = bepix - 1 + npkts[i__ - 1];
dafada_(&epochs[bepix - 1], &npkts[i__ - 1]);
/* Compute the number of epoch directories for the */
/* current mini-segment. */
ndir = (npkts[i__ - 1] - 1) / 100;
/* Write the epoch directories to the segment. */
i__2 = ndir;
for (j = 1; j <= i__2; ++j) {
k = bepix - 1 + j * 100;
dafada_(&epochs[k - 1], &c__1);
}
/* Write the mini-segment's subtype, window size, and packet */
/* count to the segment. */
d__1 = (doublereal) subtps[i__ - 1];
dafada_(&d__1, &c__1);
d__1 = (doublereal) winsiz;
dafada_(&d__1, &c__1);
d__1 = (doublereal) npkts[i__ - 1];
dafada_(&d__1, &c__1);
if (failed_()) {
chkout_("SPKW19", (ftnlen)6);
return 0;
}
}
/* We've finished writing the mini-segments. */
/* Next write the interpolation interval bounds. */
i__1 = *nintvl + 1;
dafada_(ivlbds, &i__1);
/* Create and write directories for the interval */
/* bounds. */
/* The directory count is the interval bound count */
/* (N+1), minus 1, divided by the directory size. */
ndir = *nintvl / 100;
i__1 = ndir;
for (i__ = 1; i__ <= i__1; ++i__) {
dafada_(&ivlbds[i__ * 100 - 1], &c__1);
}
/* Now we compute and write the start/stop pointers */
/* for each mini-segment. */
/* The pointers are relative to the DAF address */
/* preceding the segment. For example, a pointer */
/* to the first DAF address in the segment has */
/* value 1. */
segend = 0;
i__1 = *nintvl;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Set the packet size, which is a function of the subtype. */
pktsiz = pktszs[(i__2 = subtps[i__ - 1]) < 2 && 0 <= i__2 ? i__2 :
s_rnge("pktszs", i__2, "spkw19_", (ftnlen)1033)];
/* In order to compute the end pointer of the current */
/* mini-segment, we must compute the size, in terms */
/* of DAF addresses, of this mini-segment. The formula */
/* for the size is */
/* size = n_packets * packet_size */
/* + n_epochs */
/* + n_epoch_directories */
/* + 3 */
/* = n_packets * ( packet_size + 1 ) */
/* + ( n_packets - 1 ) / DIRSIZ */
/* + 3 */
minisz = npkts[i__ - 1] * (pktsiz + 1) + (npkts[i__ - 1] - 1) / 100 +
3;
segbeg = segend + 1;
segend = segbeg + minisz - 1;
/* Write the mini-segment begin pointer. */
/* After the loop terminates, the final end pointer, incremented */
/* by 1, will be written. */
d__1 = (doublereal) segbeg;
dafada_(&d__1, &c__1);
}
/* Write the last mini-segment end pointer, incremented by one. */
/* SEGEND was computed on the last iteration of the above loop. */
d__1 = (doublereal) (segend + 1);
dafada_(&d__1, &c__1);
/* Write out the interval selection flag. The input */
/* boolean value is represented by a numeric constant. */
if (*sellst) {
isel = 1;
} else {
isel = -1;
}
d__1 = (doublereal) isel;
dafada_(&d__1, &c__1);
/* Write the mini-segment/interpolation interval count. */
d__1 = (doublereal) (*nintvl);
dafada_(&d__1, &c__1);
/* End the segment. */
dafena_();
chkout_("SPKW19", (ftnlen)6);
return 0;
} /* spkw19_ */
/* $Procedure LPARSS ( Parse a list of items; return a set. ) */
/* Subroutine */ int lparss_(char *list, char *delims, char *set, ftnlen
list_len, ftnlen delims_len, ftnlen set_len)
{
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), i_indx(char *, char *,
ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char bchr[1], echr[1];
integer nmax, b, e, n;
extern /* Subroutine */ int chkin_(char *, ftnlen);
logical valid;
extern integer sizec_(char *, ftnlen);
extern logical failed_(void);
extern /* Subroutine */ int scardc_(integer *, char *, ftnlen), validc_(
integer *, integer *, char *, ftnlen);
extern integer lastnb_(char *, ftnlen);
extern /* Subroutine */ int chkout_(char *, ftnlen), insrtc_(char *, char
*, ftnlen, ftnlen);
extern logical return_(void);
integer eol;
/* $ Abstract */
/* Parse a list of items delimited by multiple delimiters, */
/* placing the resulting items into a set. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* CELLS */
/* SETS */
/* $ Keywords */
/* CHARACTER */
/* PARSING */
/* SETS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* LIST I List of items delimited by DELIMS on input. */
/* DELIMS I Single characters which delimit items. */
/* SET O Items in the list, validated, left justified. */
/* $ Detailed_Input */
/* LIST is a list of items delimited by any one of the */
/* characters in the string DELIMS. Consecutive */
/* delimiters, and delimiters at the beginning and */
/* end of the list, are considered to delimit blank */
/* items. A blank list is considered to contain */
/* a single (blank) item. */
/* DELIMS contains the individual characters which delimit */
/* the items in the list. These may be any ASCII */
/* characters, including blanks. */
/* However, by definition, consecutive blanks are NOT */
/* considered to be consecutive delimiters. Nor are */
/* a blank and any other delimiter considered to be */
/* consecutive delimiters. In addition, leading and */
/* trailing blanks are ignored. */
/* $ Detailed_Output */
/* SET is a set containing the items in the list, left */
/* justified. Any item in the list too long to fit */
/* into an element of SET is truncated on the right. */
/* The size of the set must be initialized prior */
/* to calling LPARSS. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the size of the set is not large enough to accommodate all */
/* of the items in the set, the error is diagnosed by routines in */
/* the call tree of this routine. */
/* 2) If the string length of ITEMS is too short to accommodate */
/* an item, the item will be truncated on the right. */
/* 3) If the string length of ITEMS is too short to permit encoding */
/* of integers via ENCHAR, the error is diagnosed by routines in */
/* the call tree of this routine. */
/* $ Files */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* The following examples illustrate the operation of LPARSS. */
/* 1) Let */
/* LIST = 'A number of words separated by */
/* spaces.' */
/* DELIMS = ' ,.' */
/* SIZE (SET) = 20 */
/* Then */
/* CARDC (SET) = 8 */
/* SET (1) = ' ' */
/* SET (2) = 'A' */
/* SET (3) = 'by' */
/* SET (4) = 'number' */
/* SET (5) = 'of' */
/* SET (6) = 'separated' */
/* SET (7) = 'spaces' */
/* SET (8) = 'words' */
/* 2) Let */
/* LIST = ' 1986-187// 13:15:12.184 ' */
/* DELIMS = ' ,/-:' */
/* SIZE (SET) = 20 */
/* Then */
/* CARDC (SET) = 6 */
/* SET (1) = ' ' */
/* SET (2) = '12.184' */
/* SET (3) = '13' */
/* SET (4) = '15' */
/* SET (5) = '187' */
/* SET (6) = '1986' */
/* 3) Let LIST = ' ,This, is, ,an,, example, ' */
/* DELIMS = ' ,' */
/* SIZE (SET) = 20 */
/* Then */
/* CARDC (SET) = 5 */
/* SET (1) = ' ' */
/* SET (2) = 'This' */
/* SET (3) = 'an' */
/* SET (4) = 'example' */
/* SET (5) = 'is' */
/* 4) Let LIST = 'Mary had a little lamb, little lamb */
/* whose fleece was white as snow.' */
/* DELIMS = ' ,.' */
/* SIZE (SET) = 6 */
/* An error would be signaled because the set is not */
/* large enough to accommodate all of the items in the */
/* list. */
/* 5) Let LIST = '1 2 3 4 5 6 7 8 9 10.' */
/* DELIMS = ' .' */
/* SIZE (SET) = 10 */
/* An error would be signaled because the set is not */
/* large enough to accommodate all of the items in the */
/* list. Note that delimiters at the end (or beginning) */
/* of list are considered to delimit blank items. */
/* 6) Let LIST = '1 2 3 4 5 6 7 8 9 10.' */
/* DELIMS = '.' */
/* SIZE (SET) = 10 */
/* Then */
/* CARDC (SET) = 2 */
/* SET (1) = ' ' */
/* SET (2) = '1 2 3 4 5 6 7 8 9 10' */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* I.M. Underwood (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.1.0, 26-OCT-2005 (NJB) */
/* Bug fix: code was modified to avoid out-of-range */
/* substring bound conditions. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (HAN) (IMU) */
/* -& */
/* $ Index_Entries */
/* parse a list of items and return a set */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.1.0, 26-OCT-2005 (NJB) */
/* Bug fix: code was modified to avoid out-of-range */
/* substring bound conditions. The previous version */
/* of this routine used DO WHILE statements of the form */
/* DO WHILE ( ( B .LE. EOL ) */
/* . .AND. ( LIST(B:B) .EQ. BLANK ) ) */
/* Such statements can cause index range violations when the */
/* index B is greater than the length of the string LIST. */
/* Whether or not such violations occur is platform-dependent. */
/* - Beta Version 2.0.0, 10-JAN-1989 (HAN) */
/* Error handling was added, and old error flags and their */
/* checks were removed. An error is signaled if the set */
/* is not large enough to accommodate all of the items in */
/* the list. */
/* The header documentation was updated to reflect the error */
/* handling changes, and more examples were added. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("LPARSS", (ftnlen)6);
}
/* Because speed is essential in many list parsing applications, */
/* LPARSS, like LPARSE, parses the input list in a single pass. */
/* What follows is nearly identical to LPARSE, except the FORTRAN */
/* INDEX function is used to test for delimiters, instead of testing */
/* each character for simple equality. Also, the items are inserted */
/* into a set instead of simply placed at the end of an array. */
/* No items yet. */
n = 0;
/* What is the size of the set? */
nmax = sizec_(set, set_len);
/* The array has not been validated yet. */
valid = FALSE_;
/* Blank list contains a blank item. No need to validate. */
if (s_cmp(list, " ", list_len, (ftnlen)1) == 0) {
scardc_(&c__0, set, set_len);
insrtc_(" ", set, (ftnlen)1, set_len);
valid = TRUE_;
} else {
/* Eliminate trailing blanks. EOL is the last non-blank */
/* character in the list. */
eol = lastnb_(list, list_len);
/* As the King said to Alice: 'Begin at the beginning. */
/* Continue until you reach the end. Then stop.' */
/* When searching for items, B is the beginning of the current */
/* item; E is the end. E points to the next non-blank delimiter, */
/* if any; otherwise E points to either the last character */
/* preceding the next item, or to the last character of the list. */
b = 1;
while(b <= eol) {
/* Skip any blanks before the next item or delimiter. */
/* At this point in the loop, we know */
/* B <= EOL */
*(unsigned char *)bchr = *(unsigned char *)&list[b - 1];
while(b <= eol && *(unsigned char *)bchr == 32) {
++b;
if (b <= eol) {
*(unsigned char *)bchr = *(unsigned char *)&list[b - 1];
}
}
/* At this point B is the index of the next non-blank */
/* character BCHR, or else */
/* B == EOL + 1 */
/* The item ends at the next delimiter. */
e = b;
if (e <= eol) {
*(unsigned char *)echr = *(unsigned char *)&list[e - 1];
} else {
*(unsigned char *)echr = ' ';
}
while(e <= eol && i_indx(delims, echr, delims_len, (ftnlen)1) ==
0) {
++e;
if (e <= eol) {
*(unsigned char *)echr = *(unsigned char *)&list[e - 1];
}
}
/* (This is different from LPARSE. If the delimiter was */
/* a blank, find the next non-blank character. If it's not */
/* a delimiter, back up. This prevents constructions */
/* like 'a , b', where the delimiters are blank and comma, */
/* from being interpreted as three items instead of two. */
/* By definition, consecutive blanks, or a blank and any */
/* other delimiter, do not count as consecutive delimiters.) */
if (e <= eol && *(unsigned char *)echr == 32) {
/* Find the next non-blank character. */
while(e <= eol && *(unsigned char *)echr == 32) {
++e;
if (e <= eol) {
*(unsigned char *)echr = *(unsigned char *)&list[e -
1];
}
}
if (e <= eol) {
if (i_indx(delims, echr, delims_len, (ftnlen)1) == 0) {
/* We're looking at a non-delimiter character. */
/* E is guaranteed to be > 1 if we're here, so the */
/* following subtraction is valid. */
--e;
}
}
}
/* The item now lies between B and E. Unless, of course, B and */
/* E are the same character; this can happen if the list */
/* starts or ends with a non-blank delimiter, or if we have */
/* stumbled upon consecutive delimiters. */
if (! valid) {
/* If the array has not been validated, it's just an */
/* array, and we can insert items directly into it. */
/* Unless it's full, in which case we validate now and */
/* insert later. */
if (n < nmax) {
++n;
if (e > b) {
s_copy(set + (n + 5) * set_len, list + (b - 1),
set_len, e - 1 - (b - 1));
} else {
s_copy(set + (n + 5) * set_len, " ", set_len, (ftnlen)
1);
}
} else {
validc_(&nmax, &nmax, set, set_len);
valid = TRUE_;
}
}
/* Once the set has been validated, the strings are inserted */
/* into the set if there's room. If there is not enough room */
/* in the set, let INSRTC signal the error. */
if (valid) {
if (e > b) {
insrtc_(list + (b - 1), set, e - 1 - (b - 1), set_len);
} else {
insrtc_(" ", set, (ftnlen)1, set_len);
}
if (failed_()) {
chkout_("LPARSS", (ftnlen)6);
return 0;
}
}
/* If there are more items to be found, continue with the */
/* character following E (which is a delimiter). */
b = e + 1;
}
/* If the array has not yet been validated, validate it before */
/* returning. */
if (! valid) {
validc_(&nmax, &n, set, set_len);
}
/* If the list ended with a (non-blank) delimiter, insert a */
/* blank item into the set. If there isn't any room, signal */
/* an error. */
if (i_indx(delims, list + (eol - 1), delims_len, (ftnlen)1) != 0) {
insrtc_(" ", set, (ftnlen)1, set_len);
/* If INSRTC failed to insert the blank because the set */
/* was already full, INSRTC will have signaled an error. */
/* No action is necessary here. */
}
}
chkout_("LPARSS", (ftnlen)6);
return 0;
} /* lparss_ */
static FLAC__bool do_picture(const char *prefix)
{
FLAC__StreamMetadata *obj;
const char *error;
size_t i;
printf("\n+++ grabbag unit test: picture\n\n");
/* invalid spec: no filename */
printf("testing grabbag__picture_parse_specification(\"\")... ");
if(0 != (obj = grabbag__picture_parse_specification("", &error)))
return failed_("expected error, got object");
printf("OK (failed as expected, error: %s)\n", error);
/* invalid spec: no filename */
printf("testing grabbag__picture_parse_specification(\"||||\")... ");
if(0 != (obj = grabbag__picture_parse_specification("||||", &error)))
return failed_("expected error, got object");
printf("OK (failed as expected: %s)\n", error);
/* invalid spec: no filename */
printf("testing grabbag__picture_parse_specification(\"|image/gif|||\")... ");
if(0 != (obj = grabbag__picture_parse_specification("|image/gif|||", &error)))
return failed_("expected error, got object");
printf("OK (failed as expected: %s)\n", error);
/* invalid spec: bad resolution */
printf("testing grabbag__picture_parse_specification(\"|image/gif|desc|320|0.gif\")... ");
if(0 != (obj = grabbag__picture_parse_specification("|image/gif|desc|320|0.gif", &error)))
return failed_("expected error, got object");
printf("OK (failed as expected: %s)\n", error);
/* invalid spec: bad resolution */
printf("testing grabbag__picture_parse_specification(\"|image/gif|desc|320x240|0.gif\")... ");
if(0 != (obj = grabbag__picture_parse_specification("|image/gif|desc|320x240|0.gif", &error)))
return failed_("expected error, got object");
printf("OK (failed as expected: %s)\n", error);
/* invalid spec: no filename */
printf("testing grabbag__picture_parse_specification(\"|image/gif|desc|320x240x9|\")... ");
if(0 != (obj = grabbag__picture_parse_specification("|image/gif|desc|320x240x9|", &error)))
return failed_("expected error, got object");
printf("OK (failed as expected: %s)\n", error);
/* invalid spec: #colors exceeds color depth */
printf("testing grabbag__picture_parse_specification(\"|image/gif|desc|320x240x9/2345|0.gif\")... ");
if(0 != (obj = grabbag__picture_parse_specification("|image/gif|desc|320x240x9/2345|0.gif", &error)))
return failed_("expected error, got object");
printf("OK (failed as expected: %s)\n", error);
/* invalid spec: standard icon has to be 32x32 PNG */
printf("testing grabbag__picture_parse_specification(\"1|-->|desc|32x24x9|0.gif\")... ");
if(0 != (obj = grabbag__picture_parse_specification("1|-->|desc|32x24x9|0.gif", &error)))
return failed_("expected error, got object");
printf("OK (failed as expected: %s)\n", error);
/* invalid spec: need resolution for linked URL */
printf("testing grabbag__picture_parse_specification(\"|-->|desc||http://blah.blah.blah/z.gif\")... ");
if(0 != (obj = grabbag__picture_parse_specification("|-->|desc||http://blah.blah.blah/z.gif", &error)))
return failed_("expected error, got object");
printf("OK (failed as expected: %s)\n", error);
printf("testing grabbag__picture_parse_specification(\"|-->|desc|320x240x9|http://blah.blah.blah/z.gif\")... ");
if(0 == (obj = grabbag__picture_parse_specification("|-->|desc|320x240x9|http://blah.blah.blah/z.gif", &error)))
return failed_(error);
printf("OK\n");
FLAC__metadata_object_delete(obj);
/* test automatic parsing of picture files from only the file name */
for(i = 0; i < sizeof(picturefiles)/sizeof(picturefiles[0]); i++)
if(!test_one_picture(prefix, picturefiles+i, "", /*fn_only=*/true))
return false;
/* test automatic parsing of picture files to get resolution/color info */
for(i = 0; i < sizeof(picturefiles)/sizeof(picturefiles[0]); i++)
if(!test_one_picture(prefix, picturefiles+i, "", /*fn_only=*/false))
return false;
picturefiles[0].width = 320;
picturefiles[0].height = 240;
picturefiles[0].depth = 3;
picturefiles[0].colors = 2;
if(!test_one_picture(prefix, picturefiles+0, "320x240x3/2", /*fn_only=*/false))
return false;
return true;
}
/* $Procedure PCKWSS ( PCK write segment summary ) */
/* Subroutine */ int pckwss_(integer *unit, char *segid, integer *segbod,
integer *segfrm, integer *segtyp, doublereal *segbtm, doublereal *
segetm, ftnlen segid_len)
{
/* Initialized data */
static char pcktyp[80*3] = "***Not Used*** "
" " "Fixed Width, Fixed Order "
"Chebyshev Polynomials: Angles " "Variab"
"le Width Chebyshev Polynomials Angles (in degrees!!!) "
" ";
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen), s_rnge(char *, integer,
char *, integer);
/* Local variables */
static char body[32];
extern /* Subroutine */ int etcal_(doublereal *, char *, ftnlen);
static char frame[32];
extern /* Subroutine */ int chkin_(char *, ftnlen), repmc_(char *, char *,
char *, char *, ftnlen, ftnlen, ftnlen, ftnlen);
static char lines[80*9];
static logical found;
extern /* Subroutine */ int repmi_(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen), bodc2n_(integer *, char *, logical *,
ftnlen), et2utc_(doublereal *, char *, integer *, char *, ftnlen,
ftnlen);
extern logical failed_(void);
static char begtim[32], endtim[32];
extern /* Subroutine */ int frmnam_(integer *, char *, ftnlen), chkout_(
char *, ftnlen), writla_(integer *, char *, integer *, ftnlen);
static char typdsc[80];
extern logical return_(void);
/* $ Abstract */
/* Write the segment summary for a PCK segment to a Fortran logical */
/* unit. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* None. */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* UNIT I The logical unit to use for writing the summary. */
/* SEGIDS I Segment ID for the segment in a PCK file. */
/* SEGBOD I Body for the segment in a PCK file. */
/* SEGFRM I Reference frame for the segment in a PCK file. */
/* SEGTYP I Ephemeris type for the segment in a PCK file. */
/* SEGBTM I Begin time (ET) for the segment in a PCK file. */
/* SEGETM I End time (ET) for the segment in a PCK file. */
/* $ Detailed_Input */
/* UNIT The Fortran logical unit to which the segment summary */
/* is written. */
/* SEGID Segment ID for a segment in a PCK file. */
/* SEGBOD Body for a segment in a PCK file. This is the */
/* NAIF integer code for the body. */
/* SEGFRM Inertial reference frame for a segment in a PCK file. */
/* this is the NAIF integer code for the inertial reference */
/* frame. */
/* SEGTYP Ephemeris type for a segment in a PCK file. This is an */
/* integer code which represents the PCK segment data type. */
/* SEGBTM Begin time (ET) for a segment in a PCK file. */
/* SEGETM End time (ET) for a segment in a PCK file. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If an error occurs while writing to the logical unit, the error */
/* will be signalled by a routine called by this routine. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine will format and display a PCK segment summary in a */
/* human compatible fashion. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* 1) This routine performs time conversions using ET2UTC, and */
/* therefore requires that a SPICE leapseconds kernel file be */
/* loaded into the SPICELIB kernel pool before being called. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* K.R. Gehringer (JPL) */
/* $ Version */
/* - Beta Version 2.1.0, 17-May-2001 (WLT) (20 years in CA today!) */
/* Added a description for type 03 PCK segments. */
/* - Beta Version 2.0.0, 24-JAN-1996 (KRG) */
/* There have been several undocumented revisions of this */
/* subroutine to improve its display formats and fix display bugs. */
/* We are starting a new trend here, with the documentation of the */
/* changes to this version. Hopefully we will continue to do so. */
/* The changes to this version are: */
/* Calling a new subroutien to get reference frame names, to */
/* support the non-inertial frames software. */
/* Fixing some display inconsistencies when body, or frame */
/* names are not found. */
/* - Beta Version 1.0.0, 25-FEB-1993 (KRG) */
/* -& */
/* $ Index_Entries */
/* format and write a pck segment summary */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Set the value for the maximum output display width. */
/* Set the maximum length for the inertial reference frame name. */
/* Set the maximum length for a body name. */
/* Set the precision for fractions of seconds used for UTC times */
/* when converted from ET times. */
/* Set the length of a UTC time string. */
/* Set the maximum length of an PCK data type description. */
/* Set the maximum number of PCK data types. */
/* Set up some mnemonics for accessing the correct labels. */
/* Set the number of output lines. */
/* Local variables */
/* Save everything to keep configuration control happy. */
/* Initial Values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("PCKWSS", (ftnlen)6);
}
/* Set up the line labels. */
s_copy(lines, " Segment ID : #", (ftnlen)80, (ftnlen)21);
s_copy(lines + 400, " UTC Start time : #", (ftnlen)80, (ftnlen)21);
s_copy(lines + 480, " UTC Stop time : #", (ftnlen)80, (ftnlen)21);
s_copy(lines + 560, " ET Start time : #", (ftnlen)80, (ftnlen)21);
s_copy(lines + 640, " ET Stop time : #", (ftnlen)80, (ftnlen)21);
s_copy(lines + 80, " Body : Body #", (ftnlen)80, (ftnlen)26);
s_copy(lines + 160, " Reference frame: Frame #", (ftnlen)80, (ftnlen)27)
;
s_copy(lines + 240, " PCK Data Type : #", (ftnlen)80, (ftnlen)21);
s_copy(lines + 320, " Description : #", (ftnlen)80, (ftnlen)21);
/* Format the segment ID. */
repmc_(lines, "#", segid, lines, (ftnlen)80, (ftnlen)1, segid_len, (
ftnlen)80);
/* Convert the segment start and stop times from ET to UTC for */
/* human readability. */
et2utc_(segbtm, "C", &c__3, begtim, (ftnlen)1, (ftnlen)32);
et2utc_(segetm, "C", &c__3, endtim, (ftnlen)1, (ftnlen)32);
if (failed_()) {
chkout_("PCKWSS", (ftnlen)6);
return 0;
}
/* Format the UTC times. */
repmc_(lines + 400, "#", begtim, lines + 400, (ftnlen)80, (ftnlen)1, (
ftnlen)32, (ftnlen)80);
repmc_(lines + 480, "#", endtim, lines + 480, (ftnlen)80, (ftnlen)1, (
ftnlen)32, (ftnlen)80);
/* Convert the ET times into Calendar format. */
etcal_(segbtm, begtim, (ftnlen)32);
etcal_(segetm, endtim, (ftnlen)32);
if (failed_()) {
chkout_("PCKWSS", (ftnlen)6);
return 0;
}
/* Format the ET times. */
repmc_(lines + 560, "#", begtim, lines + 560, (ftnlen)80, (ftnlen)1, (
ftnlen)32, (ftnlen)80);
repmc_(lines + 640, "#", endtim, lines + 640, (ftnlen)80, (ftnlen)1, (
ftnlen)32, (ftnlen)80);
/* Format the body and its name if we found it. */
bodc2n_(segbod, body, &found, (ftnlen)32);
if (found) {
repmc_(lines + 80, "#", "#, #", lines + 80, (ftnlen)80, (ftnlen)1, (
ftnlen)4, (ftnlen)80);
repmi_(lines + 80, "#", segbod, lines + 80, (ftnlen)80, (ftnlen)1, (
ftnlen)80);
repmc_(lines + 80, "#", body, lines + 80, (ftnlen)80, (ftnlen)1, (
ftnlen)32, (ftnlen)80);
} else {
repmi_(lines + 80, "#", segbod, lines + 80, (ftnlen)80, (ftnlen)1, (
ftnlen)80);
}
/* Format the inertial reference frame and its name if we found it. */
frmnam_(segfrm, frame, (ftnlen)32);
if (s_cmp(frame, " ", (ftnlen)32, (ftnlen)1) != 0) {
repmc_(lines + 160, "#", "#, #", lines + 160, (ftnlen)80, (ftnlen)1, (
ftnlen)4, (ftnlen)80);
repmi_(lines + 160, "#", segfrm, lines + 160, (ftnlen)80, (ftnlen)1, (
ftnlen)80);
repmc_(lines + 160, "#", frame, lines + 160, (ftnlen)80, (ftnlen)1, (
ftnlen)32, (ftnlen)80);
} else {
repmi_(lines + 160, "#", segfrm, lines + 160, (ftnlen)80, (ftnlen)1, (
ftnlen)80);
}
/* Format the PCK segment type and a description if we have one. */
/* The reason SEGTYP >= 2 is that this routine works on binary */
/* PCK files, and their segment types begin with type 2. Type 1 is */
/* considered to be the text PCK files. */
if (*segtyp > 3 || *segtyp < 2) {
s_copy(typdsc, "No description for this type. Do you need a new tool"
"kit?", (ftnlen)80, (ftnlen)56);
} else {
s_copy(typdsc, pcktyp + ((i__1 = *segtyp - 1) < 3 && 0 <= i__1 ? i__1
: s_rnge("pcktyp", i__1, "pckwss_", (ftnlen)352)) * 80, (
ftnlen)80, (ftnlen)80);
}
repmi_(lines + 240, "#", segtyp, lines + 240, (ftnlen)80, (ftnlen)1, (
ftnlen)80);
repmc_(lines + 320, "#", typdsc, lines + 320, (ftnlen)80, (ftnlen)1, (
ftnlen)80, (ftnlen)80);
/* Display the summary. */
writla_(&c__9, lines, unit, (ftnlen)80);
/* We were either successful or not on the previous write. In either */
/* event, we want to check out and return to the caller, so there is */
/* no need to check FAILED() here. */
chkout_("PCKWSS", (ftnlen)6);
return 0;
} /* pckwss_ */
/* $Procedure COMMNT ( Comment utility program ) */
/* Main program */ MAIN__(void)
{
/* Initialized data */
static logical insbln = TRUE_;
static char maintl[20] = "COMMNT Options ";
static char mainvl[20*5] = "QUIT " "ADD_COMMENTS "
"READ_COMMENTS " "EXTRACT_COMMENTS " "DELETE_COMMENTS "
" ";
static char maintx[40*5] = "Quit. "
"Add comments to a binary file. " "Read the comments in"
" a binary file. " "Extract comments from a binary file. "
"Delete the comments in a binary file. ";
static char mainnm[1*5] = "Q" "A" "R" "E" "D";
/* System generated locals */
address a__1[3];
integer i__1[3], i__2, i__3, i__4, i__5;
cllist cl__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen), f_clos(cllist *);
/* Local variables */
static char arch[3];
static logical done;
static char line[1000];
static logical more;
static integer iopt;
static char type__[4];
static integer i__;
extern /* Subroutine */ int dasdc_(integer *);
extern integer cardi_(integer *);
static integer r__;
extern /* Subroutine */ int spcac_(integer *, integer *, char *, char *,
ftnlen, ftnlen), chkin_(char *, ftnlen), spcec_(integer *,
integer *), spcdc_(integer *), errch_(char *, char *, ftnlen,
ftnlen), repmc_(char *, char *, char *, char *, ftnlen, ftnlen,
ftnlen, ftnlen), reset_(void);
extern integer rtrim_(char *, ftnlen);
extern logical failed_(void);
extern /* Subroutine */ int dafhof_(integer *);
static integer handle;
extern /* Subroutine */ int dafcls_(integer *), dasacu_(integer *, char *,
char *, logical *, integer *, ftnlen, ftnlen), cleari_(integer *,
integer *), delfil_(char *, ftnlen), dasecu_(integer *, integer *
, logical *), scardi_(integer *, integer *), dashof_(integer *);
static logical fileok;
extern /* Subroutine */ int clcomm_(void), getfat_(char *, char *, char *,
ftnlen, ftnlen, ftnlen), cnfirm_(char *, logical *, ftnlen);
static char fnmtbl[128*2], messag[1000], errmsg[320], messgs[1000*7],
option[20], prmtbl[80*2], statbl[3*2];
extern logical exists_(char *, ftnlen);
static integer comlun;
static char status[1000*2];
static integer numfnm;
static char prmpts[80*2];
static integer numopn, opnset[7], tblidx[2];
static logical comnts, contnu, ndfnms, tryagn;
extern /* Subroutine */ int tkvrsn_(char *, char *, ftnlen, ftnlen),
erract_(char *, char *, ftnlen, ftnlen), errprt_(char *, char *,
ftnlen, ftnlen), tostdo_(char *, ftnlen), ssizei_(integer *,
integer *), getopt_(char *, integer *, char *, char *, integer *,
ftnlen, ftnlen, ftnlen), getfnm_(char *, char *, char *, logical *
, char *, ftnlen, ftnlen, ftnlen, ftnlen), setmsg_(char *, ftnlen)
, sigerr_(char *, ftnlen), txtopr_(char *, integer *, ftnlen),
dafopw_(char *, integer *, ftnlen), dasopw_(char *, integer *,
ftnlen), dascls_(integer *), dafopr_(char *, integer *, ftnlen),
spcrfl_(integer *, char *, logical *, ftnlen), spcrnl_(char *,
logical *, ftnlen), dasopr_(char *, integer *, ftnlen), txtopn_(
char *, integer *, ftnlen), chkout_(char *, ftnlen);
static logical eoc;
static char tkv[12];
/* $ Abstract */
/* NAIF Toolkit utility program for adding, reading, extracting, */
/* and deleting comments from a binary file. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* SPC */
/* DAS */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* K.R. Gehringer (JPL) */
/* J.E. McLean (JPL) */
/* M.J. Spencer (JPL) */
/* $ Version */
/* - Version 6.0.1, 08-MAY-2001 (BVS) */
/* Increased LINLEN from 255 to 1000 to make it consistent */
/* with SPICELIB's SPC* and SUPPORT's DAF* internal line sizes. */
/* - Version 5.0.1, 21-JUL-1997 (WLT) */
/* Modified the banner at start up so that the version of the */
/* toolkit used to link COMMNT will be displayed. */
/* In addition all WRITE statements were replaced by calls to */
/* TOSTDO. */
/* - Version 5.0.0, 05-MAY-1994 (KRG) */
/* Modified the program to use the new file type identification */
/* capability that was added to spicelib. No file type menu is */
/* necessary now, as the file type is determined during the */
/* execution of the program. */
/* The prompts for the begin and end markers used to extract a */
/* subset of text lines from an input comment file which were then */
/* placed into the comment area of a SPICE binary kernel file have */
/* been removed. The entire input comment file is now placed into */
/* the comment area of the binary kernel file. This change */
/* simplifies the user interaction with the program. */
/* Added support for the new PCK binary kernel files. */
/* If an error occurs during the extraction of comments to a file, */
/* the file that was being created is deleted. We cannot know */
/* whether the file had been successfully created before the error */
/* occurred. */
/* - Version 4.0.0, 11-DEC-1992 (KRG) */
/* Added code to support the E-Kernel, and redesigned the */
/* user interface. */
/* - Version 3.1.0, 19-NOV-1991 (MJS) */
/* Variable QUIT initialized to FALSE. */
/* - Version 3.0.1, 10-AUG-1991 (CHA) (NJB) */
/* Updated comments to reflect status as a Toolkit */
/* utility program. Message indicating that no comments */
/* were found in the specified file was changed to include */
/* the file name. */
/* - Version 2.0.0, 28-JUN-1991 (JEM) */
/* The option to read the comments from the comment */
/* area of a binary SPK or CK was added to the menu. */
/* - Version 1.0.0, 05-APR-1991 (JEM) */
/* -& */
/* SPICELIB functions */
/* Parameters */
/* Set the version of the comment program. This should be updated */
/* every time a change is made, and it should agree with the */
/* version number in the header. */
/* Set a value for the logical unit which represents the standard */
/* output device, commonly a terminal. A value of 6 is widely used, */
/* but the Fortran standard does not specify a value, so it may be */
/* different for different Fortran implementations. */
/* Lower bound for a SPICELIB CELL data structure. */
/* Maximum number of open binary files allowed. */
/* Set a value for a replacement marker. */
/* Set a value for a filename prompt. */
/* File types */
/* Set a value for the length of a text line. */
/* Set a value for the length of an error message. */
/* Set a value for the length of a filename. */
/* Set a length for the prompts in the prompt table. */
/* Set a length for the status of a file: 'OLD' or 'NEW'. */
/* Set the length for the architecture of a file. */
/* Set the length for the type of a file. */
/* Set a length for the option values. */
/* Set a length for the title of a menu. */
/* Set a length for an option name (what is typed to select it) */
/* for a menu. */
/* Set the length of the text description of an option on a menu. */
/* The number of options available on the main menu. */
/* Set up some mnemonics for indexing the prompts in the prompt */
/* table. */
/* Set the maximum size of the filename table: this must be the */
/* number of distinct ``types'' of files that the program may */
/* require. */
/* Set up some mnemonics for indexing the messages in the message */
/* table. */
/* Set the maximum size of the message table: There should be a */
/* message for each ``type'' of action that the program can take. */
/* Set up some mnemonics for the OK and not OK status messages. */
/* Set the maximum number of status messages that are available. */
/* We need to have TKVLEN characters to hold the current version */
/* of the toolkit. */
/* Variables */
/* We want to insert a blank line between additions if there are */
/* already comments in the binary file. We indicate this by giving */
/* the variable INSBLN the value .TRUE.. */
/* Define the main menu title ... */
/* Define the main menu option values ... */
/* Define the main menu descriptive text for each option ... */
/* Define the main menu option names ... */
/* Register the COMMNT main program with the SPICELIB error handler. */
chkin_("COMMNT", (ftnlen)6);
clcomm_();
tkvrsn_("TOOLKIT", tkv, (ftnlen)7, (ftnlen)12);
r__ = rtrim_(tkv, (ftnlen)12);
/* Set the error action to 'RETURN'. We don't want the program */
/* to abort if an error is signalled. We check FAILED where */
/* necessary. If an error is signalled, we'll just handle the */
/* error, display an appropriate message, then call RESET at the */
/* end of the loop to continue. */
erract_("SET", "RETURN", (ftnlen)3, (ftnlen)6);
/* Set the error messages that we want to have displayed. We will */
/* diaplay the SPICELIB short and long error messages. This is done */
/* to ensure that some sort of an error message is displayed if an */
/* error occurs. In several places, long error messages are not set, */
/* so if only the long error messages were displayed, it would be */
/* possible to have an error signalled and not see any error */
/* information. This is not a very useful thing. */
errprt_("SET", "NONE, SHORT, LONG, TRACEBACK", (ftnlen)3, (ftnlen)28);
/* Set up the prompt table for the different types of files. */
s_copy(prmtbl + 80, "Enter the name of the comment file to be #.", (
ftnlen)80, (ftnlen)43);
s_copy(prmtbl, "Enter the name of the binary file.", (ftnlen)80, (ftnlen)
34);
/* Set up the message table for the different ``types'' of */
/* operations. The message table contains generic messages which will */
/* have their missing parts filled in after the option and file type */
/* havve been selected. */
s_copy(messgs, "Reading the comment area of the # file.", (ftnlen)1000, (
ftnlen)39);
s_copy(messgs + 1000, "Adding comments to the # file.", (ftnlen)1000, (
ftnlen)30);
s_copy(messgs + 2000, "Extracting comments from the # file.", (ftnlen)
1000, (ftnlen)36);
s_copy(messgs + 3000, "Deleting the comment area of # file.", (ftnlen)
1000, (ftnlen)36);
s_copy(messgs + 4000, "Quitting the program.", (ftnlen)1000, (ftnlen)21);
s_copy(messgs + 5000, "The comments were successfully #.", (ftnlen)1000, (
ftnlen)33);
s_copy(messgs + 6000, "The comments were NOT successfully #.", (ftnlen)
1000, (ftnlen)37);
/* Display a brief commercial with the name of the program and the */
/* version. */
s_copy(line, " Welcome to COMMNT Version: #", (ftnlen)1000, (ftnlen)31);
repmc_(line, "#", "6.0.1", line, (ftnlen)1000, (ftnlen)1, (ftnlen)5, (
ftnlen)1000);
tostdo_(" ", (ftnlen)1);
tostdo_(line, (ftnlen)1000);
/* Writing concatenation */
i__1[0] = 23, a__1[0] = " (Spice Toolkit ";
i__1[1] = r__, a__1[1] = tkv;
i__1[2] = 1, a__1[2] = ")";
s_cat(line, a__1, i__1, &c__3, (ftnlen)1000);
tostdo_(line, (ftnlen)1000);
tostdo_(" ", (ftnlen)1);
/* Initialize the CELL oriented set for collecting open DAF or DAS */
/* files in the event of an error. */
ssizei_(&c__1, opnset);
/* While there is still more to do ... */
done = FALSE_;
while(! done) {
/* We initialize a few things here, so that they get reset for */
/* every trip through the loop. */
/* Initialize the logical flags that we use. */
comnts = FALSE_;
contnu = TRUE_;
eoc = FALSE_;
ndfnms = FALSE_;
/* Initialize the filename table, ... */
s_copy(fnmtbl, " ", (ftnlen)128, (ftnlen)1);
s_copy(fnmtbl + 128, " ", (ftnlen)128, (ftnlen)1);
/* the file status table, ... */
s_copy(statbl, " ", (ftnlen)3, (ftnlen)1);
s_copy(statbl + 3, " ", (ftnlen)3, (ftnlen)1);
/* the table indices, ... */
tblidx[0] = 0;
tblidx[1] = 0;
/* set the number of file names to zero, ... */
numfnm = 0;
/* the prompts in the prompt table, ... */
s_copy(prmpts, " ", (ftnlen)80, (ftnlen)1);
s_copy(prmpts + 80, " ", (ftnlen)80, (ftnlen)1);
/* the message, and the option. */
s_copy(messag, " ", (ftnlen)1000, (ftnlen)1);
s_copy(option, " ", (ftnlen)20, (ftnlen)1);
/* Set the status messages. */
s_copy(status, messgs + 5000, (ftnlen)1000, (ftnlen)1000);
s_copy(status + 1000, messgs + 6000, (ftnlen)1000, (ftnlen)1000);
/* Get the option to be performed from the main menu. */
getopt_(maintl, &c__5, mainnm, maintx, &iopt, (ftnlen)20, (ftnlen)1, (
ftnlen)40);
s_copy(option, mainvl + ((i__2 = iopt - 1) < 5 && 0 <= i__2 ? i__2 :
s_rnge("mainvl", i__2, "commnt_", (ftnlen)502)) * 20, (ftnlen)
20, (ftnlen)20);
/* Set up the messages and other information for the option */
/* selected. */
if (contnu) {
if (s_cmp(option, "ADD_COMMENTS", (ftnlen)20, (ftnlen)12) == 0) {
ndfnms = TRUE_;
numfnm = 2;
s_copy(messag, messgs + 1000, (ftnlen)1000, (ftnlen)1000);
tblidx[0] = 2;
s_copy(prmpts, prmtbl + 80, (ftnlen)80, (ftnlen)80);
repmc_(prmpts, "#", "added", prmpts, (ftnlen)80, (ftnlen)1, (
ftnlen)5, (ftnlen)80);
s_copy(statbl + 3, "OLD", (ftnlen)3, (ftnlen)3);
tblidx[1] = 1;
s_copy(prmpts + 80, prmtbl, (ftnlen)80, (ftnlen)80);
s_copy(statbl, "OLD", (ftnlen)3, (ftnlen)3);
/* Set the operation status messages. */
s_copy(status, messgs + 5000, (ftnlen)1000, (ftnlen)1000);
repmc_(status, "#", "added", status, (ftnlen)1000, (ftnlen)1,
(ftnlen)5, (ftnlen)1000);
s_copy(status + 1000, messgs + 6000, (ftnlen)1000, (ftnlen)
1000);
repmc_(status + 1000, "#", "added", status + 1000, (ftnlen)
1000, (ftnlen)1, (ftnlen)5, (ftnlen)1000);
} else if (s_cmp(option, "READ_COMMENTS", (ftnlen)20, (ftnlen)13)
== 0) {
ndfnms = TRUE_;
numfnm = 1;
s_copy(messag, messgs, (ftnlen)1000, (ftnlen)1000);
tblidx[0] = 1;
s_copy(prmpts, prmtbl, (ftnlen)80, (ftnlen)80);
s_copy(statbl, "OLD", (ftnlen)3, (ftnlen)3);
/* Set the operation status messages. */
s_copy(status, messgs + 5000, (ftnlen)1000, (ftnlen)1000);
repmc_(status, "#", "read", status, (ftnlen)1000, (ftnlen)1, (
ftnlen)4, (ftnlen)1000);
s_copy(status + 1000, messgs + 6000, (ftnlen)1000, (ftnlen)
1000);
repmc_(status + 1000, "#", "read", status + 1000, (ftnlen)
1000, (ftnlen)1, (ftnlen)4, (ftnlen)1000);
} else if (s_cmp(option, "EXTRACT_COMMENTS", (ftnlen)20, (ftnlen)
16) == 0) {
ndfnms = TRUE_;
numfnm = 2;
s_copy(messag, messgs + 2000, (ftnlen)1000, (ftnlen)1000);
tblidx[0] = 1;
s_copy(prmpts, prmtbl, (ftnlen)80, (ftnlen)80);
s_copy(statbl, "OLD", (ftnlen)3, (ftnlen)3);
tblidx[1] = 2;
s_copy(prmpts + 80, prmtbl + 80, (ftnlen)80, (ftnlen)80);
repmc_(prmpts + 80, "#", "created", prmpts + 80, (ftnlen)80, (
ftnlen)1, (ftnlen)7, (ftnlen)80);
s_copy(statbl + 3, "NEW", (ftnlen)3, (ftnlen)3);
/* Set the operation status messages. */
s_copy(status, messgs + 5000, (ftnlen)1000, (ftnlen)1000);
repmc_(status, "#", "extracted", status, (ftnlen)1000, (
ftnlen)1, (ftnlen)9, (ftnlen)1000);
s_copy(status + 1000, messgs + 6000, (ftnlen)1000, (ftnlen)
1000);
repmc_(status + 1000, "#", "extracted", status + 1000, (
ftnlen)1000, (ftnlen)1, (ftnlen)9, (ftnlen)1000);
} else if (s_cmp(option, "DELETE_COMMENTS", (ftnlen)20, (ftnlen)
15) == 0) {
ndfnms = TRUE_;
numfnm = 1;
s_copy(messag, messgs + 3000, (ftnlen)1000, (ftnlen)1000);
tblidx[0] = 1;
s_copy(prmpts, prmtbl, (ftnlen)80, (ftnlen)80);
s_copy(statbl, "OLD", (ftnlen)3, (ftnlen)3);
/* Set the operation status messages. */
s_copy(status, messgs + 5000, (ftnlen)1000, (ftnlen)1000);
repmc_(status, "#", "deleted", status, (ftnlen)1000, (ftnlen)
1, (ftnlen)7, (ftnlen)1000);
s_copy(status + 1000, messgs + 6000, (ftnlen)1000, (ftnlen)
1000);
repmc_(status + 1000, "#", "deleted", status + 1000, (ftnlen)
1000, (ftnlen)1, (ftnlen)7, (ftnlen)1000);
} else if (s_cmp(option, "QUIT", (ftnlen)20, (ftnlen)4) == 0) {
s_copy(messag, messgs + 4000, (ftnlen)1000, (ftnlen)1000);
}
}
/* Collect any filenames that we may need. */
if (contnu && ndfnms) {
/* we always need at least one filename if we get to here. */
i__ = 1;
more = TRUE_;
while(more) {
fileok = FALSE_;
tryagn = TRUE_;
while(tryagn) {
tostdo_(" ", (ftnlen)1);
tostdo_(prmpts + ((i__2 = i__ - 1) < 2 && 0 <= i__2 ?
i__2 : s_rnge("prmpts", i__2, "commnt_", (ftnlen)
614)) * 80, (ftnlen)80);
tostdo_(" ", (ftnlen)1);
getfnm_("Filename? ", statbl + ((i__3 = tblidx[(i__2 =
i__ - 1) < 2 && 0 <= i__2 ? i__2 : s_rnge("tblidx"
, i__2, "commnt_", (ftnlen)617)] - 1) < 2 && 0 <=
i__3 ? i__3 : s_rnge("statbl", i__3, "commnt_", (
ftnlen)617)) * 3, fnmtbl + (((i__5 = tblidx[(i__4
= i__ - 1) < 2 && 0 <= i__4 ? i__4 : s_rnge("tbl"
"idx", i__4, "commnt_", (ftnlen)617)] - 1) < 2 &&
0 <= i__5 ? i__5 : s_rnge("fnmtbl", i__5, "commn"
"t_", (ftnlen)617)) << 7), &fileok, errmsg, (
ftnlen)10, (ftnlen)3, (ftnlen)128, (ftnlen)320);
/* If the filename is OK, increment the filename index */
/* and leave the try again loop. Otherwise, write out the */
/* error message, and give the opportunity to go around */
/* again. */
if (fileok) {
++i__;
tryagn = FALSE_;
} else {
tostdo_(" ", (ftnlen)1);
tostdo_(errmsg, (ftnlen)320);
tostdo_(" ", (ftnlen)1);
cnfirm_("Try again? (Yes/No) ", &tryagn, (ftnlen)20);
if (! tryagn) {
contnu = FALSE_;
more = FALSE_;
}
}
}
if (i__ > numfnm) {
more = FALSE_;
}
}
}
/* Get the file architecture and type. */
if (contnu && ndfnms) {
getfat_(fnmtbl, arch, type__, (ftnlen)128, (ftnlen)3, (ftnlen)4);
if (failed_()) {
contnu = FALSE_;
}
}
/* Check to see that we got back a valid architecture and type. */
if (contnu && ndfnms) {
if (s_cmp(arch, "?", (ftnlen)3, (ftnlen)1) == 0 || s_cmp(type__,
"?", (ftnlen)4, (ftnlen)1) == 0) {
contnu = FALSE_;
setmsg_("The architecture and type of the binary file '#' co"
"uld not be determined. A common error is to give the"
" name of a text file instead of the name of a binary"
" file.", (ftnlen)161);
errch_("#", fnmtbl, (ftnlen)1, (ftnlen)128);
sigerr_("SPICE(BADFILEFORMAT)", (ftnlen)20);
}
}
/* Customize the message. We know we can do this, because we */
/* need files, and so we don't have the QUIT message. */
if (contnu && ndfnms) {
repmc_(messag, "#", type__, messag, (ftnlen)1000, (ftnlen)1, (
ftnlen)4, (ftnlen)1000);
}
/* Process the option that was selected so long ago. */
if (contnu) {
if (s_cmp(option, "QUIT", (ftnlen)20, (ftnlen)4) == 0) {
tostdo_(" ", (ftnlen)1);
tostdo_(messag, (ftnlen)1000);
tostdo_(" ", (ftnlen)1);
done = TRUE_;
} else if (s_cmp(option, "ADD_COMMENTS", (ftnlen)20, (ftnlen)12)
== 0) {
tostdo_(" ", (ftnlen)1);
tostdo_(messag, (ftnlen)1000);
s_copy(line, "From File: #", (ftnlen)1000, (ftnlen)12);
repmc_(line, "#", fnmtbl + 128, line, (ftnlen)1000, (ftnlen)1,
(ftnlen)128, (ftnlen)1000);
tostdo_(" ", (ftnlen)1);
tostdo_(line, (ftnlen)1000);
s_copy(line, "To File : #", (ftnlen)1000, (ftnlen)12);
repmc_(line, "#", fnmtbl, line, (ftnlen)1000, (ftnlen)1, (
ftnlen)128, (ftnlen)1000);
tostdo_(line, (ftnlen)1000);
/* Open the text file which contains the comments to be */
/* added to the binary file. */
txtopr_(fnmtbl + 128, &comlun, (ftnlen)128);
if (! failed_()) {
if (s_cmp(type__, "CK", (ftnlen)4, (ftnlen)2) == 0) {
/* Open the binary file, add the comments, and close */
/* the binary file. */
dafopw_(fnmtbl, &handle, (ftnlen)128);
spcac_(&handle, &comlun, " ", " ", (ftnlen)1, (ftnlen)
1);
dafcls_(&handle);
} else if (s_cmp(type__, "PCK", (ftnlen)4, (ftnlen)3) ==
0) {
/* Open the binary file, add the comments, and close */
/* the binary file. */
dafopw_(fnmtbl, &handle, (ftnlen)128);
spcac_(&handle, &comlun, " ", " ", (ftnlen)1, (ftnlen)
1);
dafcls_(&handle);
} else if (s_cmp(type__, "SPK", (ftnlen)4, (ftnlen)3) ==
0) {
/* Open the binary file, add the comments, and close */
/* the binary file. */
dafopw_(fnmtbl, &handle, (ftnlen)128);
spcac_(&handle, &comlun, " ", " ", (ftnlen)1, (ftnlen)
1);
dafcls_(&handle);
} else if (s_cmp(type__, "EK", (ftnlen)4, (ftnlen)2) == 0)
{
/* Open the binary file, add the comments, and close */
/* the binary file. */
dasopw_(fnmtbl, &handle, (ftnlen)128);
dasacu_(&comlun, " ", " ", &insbln, &handle, (ftnlen)
1, (ftnlen)1);
dascls_(&handle);
}
/* Close the comment file. */
cl__1.cerr = 0;
cl__1.cunit = comlun;
cl__1.csta = 0;
f_clos(&cl__1);
}
/* Display the status of the operation that was selected. */
tostdo_(" ", (ftnlen)1);
if (failed_()) {
tostdo_(status + 1000, (ftnlen)1000);
} else {
tostdo_(status, (ftnlen)1000);
}
} else if (s_cmp(option, "READ_COMMENTS", (ftnlen)20, (ftnlen)13)
== 0) {
tostdo_(" ", (ftnlen)1);
tostdo_(messag, (ftnlen)1000);
s_copy(line, "File: #", (ftnlen)1000, (ftnlen)7);
repmc_(line, "#", fnmtbl, line, (ftnlen)1000, (ftnlen)1, (
ftnlen)128, (ftnlen)1000);
tostdo_(" ", (ftnlen)1);
tostdo_(line, (ftnlen)1000);
tostdo_(" ", (ftnlen)1);
if (s_cmp(type__, "CK", (ftnlen)4, (ftnlen)2) == 0) {
/* Open the binary file, read the comments, and close */
/* the binary file. */
dafopr_(fnmtbl, &handle, (ftnlen)128);
/* The comments are read a line at a time and displayed */
/* on the screen. */
spcrfl_(&handle, line, &eoc, (ftnlen)1000);
if (! failed_()) {
if (eoc) {
tostdo_("There were no comments found in the fil"
"e.", (ftnlen)41);
}
while(! eoc && ! failed_()) {
tostdo_(line, (ftnlen)1000);
spcrnl_(line, &eoc, (ftnlen)1000);
}
}
dafcls_(&handle);
} else if (s_cmp(type__, "PCK", (ftnlen)4, (ftnlen)3) == 0) {
/* Open the binary file, read the comments, and close */
/* the binary file. */
dafopr_(fnmtbl, &handle, (ftnlen)128);
/* The comments are read a line at a time and displayed */
/* on the screen. */
spcrfl_(&handle, line, &eoc, (ftnlen)1000);
if (! failed_()) {
if (eoc) {
tostdo_("There were no commentfound in the file.",
(ftnlen)39);
}
while(! eoc && ! failed_()) {
tostdo_(line, (ftnlen)1000);
spcrnl_(line, &eoc, (ftnlen)1000);
}
}
dafcls_(&handle);
} else if (s_cmp(type__, "SPK", (ftnlen)4, (ftnlen)3) == 0) {
/* Open the binary file, read the comments, and close */
/* the binary file. */
dafopr_(fnmtbl, &handle, (ftnlen)128);
/* The comments are read a line at a time and displayed */
/* on the screen. */
spcrfl_(&handle, line, &eoc, (ftnlen)1000);
if (! failed_()) {
if (eoc) {
tostdo_("There were no comments found in the fil"
"e.", (ftnlen)41);
}
while(! eoc && ! failed_()) {
tostdo_(line, (ftnlen)1000);
spcrnl_(line, &eoc, (ftnlen)1000);
}
}
dafcls_(&handle);
} else if (s_cmp(type__, "EK", (ftnlen)4, (ftnlen)2) == 0) {
/* Open the binary file, read the comments, and close */
/* the binary file. */
dasopr_(fnmtbl, &handle, (ftnlen)128);
dasecu_(&handle, &c__6, &comnts);
dascls_(&handle);
if (! comnts) {
s_copy(line, "There were no comments found in the fi"
"le.", (ftnlen)1000, (ftnlen)41);
tostdo_(line, (ftnlen)1000);
}
}
/* Display the status of the operation that was selected. */
tostdo_(" ", (ftnlen)1);
if (failed_()) {
tostdo_(status + 1000, (ftnlen)1000);
} else {
tostdo_(status, (ftnlen)1000);
}
} else if (s_cmp(option, "EXTRACT_COMMENTS", (ftnlen)20, (ftnlen)
16) == 0) {
tostdo_(" ", (ftnlen)1);
tostdo_(messag, (ftnlen)1000);
s_copy(line, "From File: #", (ftnlen)1000, (ftnlen)12);
repmc_(line, "#", fnmtbl, line, (ftnlen)1000, (ftnlen)1, (
ftnlen)128, (ftnlen)1000);
tostdo_(" ", (ftnlen)1);
tostdo_(line, (ftnlen)1000);
s_copy(line, "To File : #", (ftnlen)1000, (ftnlen)12);
repmc_(line, "#", fnmtbl + 128, line, (ftnlen)1000, (ftnlen)1,
(ftnlen)128, (ftnlen)1000);
tostdo_(line, (ftnlen)1000);
/* Open the text file. */
txtopn_(fnmtbl + 128, &comlun, (ftnlen)128);
if (! failed_()) {
if (s_cmp(type__, "CK", (ftnlen)4, (ftnlen)2) == 0) {
/* Open the binary file, extract the comments, and */
/* close the binary file. */
dafopr_(fnmtbl, &handle, (ftnlen)128);
spcec_(&handle, &comlun);
dafcls_(&handle);
} else if (s_cmp(type__, "PCK", (ftnlen)4, (ftnlen)3) ==
0) {
/* Open the binary file, extract the comments, and */
/* close the binary file. */
dafopr_(fnmtbl, &handle, (ftnlen)128);
spcec_(&handle, &comlun);
dafcls_(&handle);
} else if (s_cmp(type__, "SPK", (ftnlen)4, (ftnlen)3) ==
0) {
/* Open the binary file, extract the comments, and */
/* close the binary file. */
dafopr_(fnmtbl, &handle, (ftnlen)128);
spcec_(&handle, &comlun);
dafcls_(&handle);
} else if (s_cmp(type__, "EK", (ftnlen)4, (ftnlen)2) == 0)
{
/* Open the binary file, extract the comments, and */
/* close the binary file. */
dasopr_(fnmtbl, &handle, (ftnlen)128);
dasecu_(&handle, &comlun, &comnts);
dascls_(&handle);
if (! comnts) {
s_copy(line, "There were no comments found in th"
"e file.", (ftnlen)1000, (ftnlen)41);
tostdo_(line, (ftnlen)1000);
}
}
/* Close the text file that we opened. */
cl__1.cerr = 0;
cl__1.cunit = comlun;
cl__1.csta = 0;
f_clos(&cl__1);
}
/* Display the status of the operation that was selected. */
tostdo_(" ", (ftnlen)1);
if (failed_()) {
tostdo_(status + 1000, (ftnlen)1000);
} else {
tostdo_(status, (ftnlen)1000);
}
} else if (s_cmp(option, "DELETE_COMMENTS", (ftnlen)20, (ftnlen)
15) == 0) {
tostdo_(" ", (ftnlen)1);
tostdo_(messag, (ftnlen)1000);
s_copy(line, "File: #", (ftnlen)1000, (ftnlen)7);
repmc_(line, "#", fnmtbl, line, (ftnlen)1000, (ftnlen)1, (
ftnlen)128, (ftnlen)1000);
tostdo_(" ", (ftnlen)1);
tostdo_(line, (ftnlen)1000);
if (s_cmp(type__, "CK", (ftnlen)4, (ftnlen)2) == 0) {
/* Open the binary file, delete the comments, and close */
/* the binary file. */
dafopw_(fnmtbl, &handle, (ftnlen)128);
spcdc_(&handle);
dafcls_(&handle);
} else if (s_cmp(type__, "PCK", (ftnlen)4, (ftnlen)3) == 0) {
/* Open the binary file, delete the comments, and close */
/* the binary file. */
dafopw_(fnmtbl, &handle, (ftnlen)128);
spcdc_(&handle);
dafcls_(&handle);
} else if (s_cmp(type__, "SPK", (ftnlen)4, (ftnlen)3) == 0) {
/* Open the binary file, delete the comments, and close */
/* the binary file. */
dafopw_(fnmtbl, &handle, (ftnlen)128);
spcdc_(&handle);
dafcls_(&handle);
} else if (s_cmp(type__, "EK", (ftnlen)4, (ftnlen)2) == 0) {
/* Open the binary file, delete the comments, and close */
/* the binary file. */
dasopw_(fnmtbl, &handle, (ftnlen)128);
dasdc_(&handle);
dascls_(&handle);
}
/* Display the status of the operation that was selected. */
tostdo_(" ", (ftnlen)1);
if (failed_()) {
tostdo_(status + 1000, (ftnlen)1000);
} else {
tostdo_(status, (ftnlen)1000);
}
}
}
/* If anything failed, close any binary files that might still be */
/* open and reset the error handling before getting the next */
/* option. */
if (failed_()) {
/* Before we can attempt to perform any clean up actions if an */
/* error occurred, we need to reset the SPICELIB error handling */
/* mechanism so that we can call the SPICELIB routines that we */
/* need to. */
reset_();
/* Clear out any binary file handles in the open set, OPNSET. */
scardi_(&c__0, opnset);
cleari_(&c__1, &opnset[6]);
/* Get the handles for any DAF files which may still be open. */
dafhof_(opnset);
numopn = cardi_(opnset);
if (numopn > 0) {
i__2 = numopn;
for (i__ = 1; i__ <= i__2; ++i__) {
dafcls_(&opnset[(i__3 = i__ + 5) < 7 && 0 <= i__3 ? i__3 :
s_rnge("opnset", i__3, "commnt_", (ftnlen)1100)])
;
}
}
/* Clear out any binary file handles in the open set, OPNSET. */
scardi_(&c__0, opnset);
cleari_(&c__1, &opnset[6]);
/* Get the handles for any DAS files which may still be open. */
dashof_(opnset);
numopn = cardi_(opnset);
if (numopn > 0) {
i__2 = numopn;
for (i__ = 1; i__ <= i__2; ++i__) {
dascls_(&opnset[(i__3 = i__ + 5) < 7 && 0 <= i__3 ? i__3 :
s_rnge("opnset", i__3, "commnt_", (ftnlen)1121)])
;
}
}
/* If there was an error and we were extracting comments to a */
/* file, then we should delete the file that was created, */
/* because we do not know whether the extraction was completed */
/* successfully. */
if (s_cmp(option, "EXTRACT_COMMENTS", (ftnlen)20, (ftnlen)16) ==
0) {
if (exists_(fnmtbl + 128, (ftnlen)128)) {
delfil_(fnmtbl + 128, (ftnlen)128);
}
}
/* Finally, reset the error handling, and go get the next */
/* option. This is just to be sure. */
reset_();
}
}
chkout_("COMMNT", (ftnlen)6);
return 0;
} /* MAIN__ */
/* $Procedure CKFROT ( C-kernel, find rotation ) */
/* Subroutine */ int ckfrot_(integer *inst, doublereal *et, doublereal *
rotate, integer *ref, logical *found)
{
logical have, pfnd, sfnd;
doublereal time;
extern /* Subroutine */ int sce2c_(integer *, doublereal *, doublereal *);
char segid[40];
extern /* Subroutine */ int chkin_(char *, ftnlen);
doublereal descr[5];
extern /* Subroutine */ int dafus_(doublereal *, integer *, integer *,
doublereal *, integer *), ckbss_(integer *, doublereal *,
doublereal *, logical *), ckpfs_(integer *, doublereal *,
doublereal *, doublereal *, logical *, doublereal *, doublereal *,
doublereal *, logical *), cksns_(integer *, doublereal *, char *,
logical *, ftnlen), xpose_(doublereal *, doublereal *);
extern logical failed_(void);
doublereal av[3];
integer handle;
extern /* Subroutine */ int ckhave_(logical *);
logical needav;
extern /* Subroutine */ int ckmeta_(integer *, char *, integer *, ftnlen);
integer sclkid;
extern /* Subroutine */ int chkout_(char *, ftnlen);
doublereal clkout;
extern logical return_(void), zzsclk_(integer *, integer *);
doublereal dcd[2];
integer icd[6];
doublereal tol, rot[9] /* was [3][3] */;
/* $ Abstract */
/* Find the rotation from a C-kernel Id to the native */
/* frame at the time requested. */
/* $ 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 */
/* CK */
/* $ Keywords */
/* POINTING */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* INST I NAIF instrument ID. */
/* ET I Epoch measured in seconds past J2000. */
/* ROTATE O rotation from CK platform to frame REF. */
/* REF O Reference frame. */
/* FOUND O True when requested pointing is available. */
/* $ Detailed_Input */
/* INST is the unique NAIF integer ID for the spacecraft */
/* instrument for which data is being requested. */
/* ET is the epoch for which the state rotation */
/* is desired. ET should be given in seconds past the */
/* epoch of J2000. */
/* $ Detailed_Output */
/* ROTATE is a rotation matrix that converts */
/* positions relative to the input frame (given by INST) */
/* to positions relative to the frame REF. */
/* Thus, if a state S has components x,y,z,dx,dy,dz */
/* in the frame of INST, frame, then S has components */
/* x', y', z', dx', dy', dz' in frame REF. */
/* [ x' ] [ ] [ x ] */
/* | y' | = | ROTATE | | y | */
/* [ z' ] [ ] [ z ] */
/* REF is the id-code reference frame to which ROTATE will */
/* transform states. */
/* FOUND is true if a record was found to satisfy the pointing */
/* request. FOUND will be false otherwise. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If a C-kernel file is not loaded using CKLPF prior to calling */
/* this routine, an error is signalled by a routine that this */
/* routine calls. */
/* $ Files */
/* CKFROT searches through files loaded by CKLPF to locate a segment */
/* that can satisfy the request for position rotation */
/* for instrument INST at time ET. You must load a C-kernel */
/* file using CKLPF before calling this routine. */
/* $ Particulars */
/* CKFROT searches through files loaded by CKLPF to satisfy a */
/* pointing request. Last-loaded files are searched first, and */
/* individual files are searched in backwards order, giving */
/* priority to segments that were added to a file later than the */
/* others. CKFROT considers only those segments that contain */
/* angular velocity data. */
/* The search ends when a segment is found that can give pointing */
/* for the specified instrument at the request time. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* A C-kernel file should have been loaded by CKLPF. */
/* In addition it is helpful to load a CK-info file into the */
/* Kernel pool. This file should have the following variables */
/* defined. */
/* CK_<INST>_SCLK = SCLK idcode that yields SCLK mapping for INST. */
/* CK_<INST>_SPK = SPK idcode that yields ephemeris for INST. */
/* where <INST> is the integer string corresponding to INST. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.2.0, 17-FEB-2000 (WLT) */
/* The routine now checks to make sure convert ET to TICKS */
/* and that at least one C-kernel is loaded before trying */
/* to look up the transformation. Also the routine now calls */
/* SCE2C instead of SCE2T. */
/* - SPICELIB Version 1.0.0, 03-MAR-1999 (WLT) */
/* -& */
/* $ Index_Entries */
/* get instrument frame rotation and reference frame */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* NDC is the number of double precision components in an */
/* unpacked C-kernel segment descriptor. */
/* NIC is the number of integer components in an unpacked */
/* C-kernel segment descriptor. */
/* NC is the number of components in a packed C-kernel */
/* descriptor. All DAF summaries have this formulaic */
/* relationship between the number of its integer and */
/* double precision components and the number of packed */
/* components. */
/* IDLEN is the length of the C-kernel segment identifier. */
/* All DAF names have this formulaic relationship */
/* between the number of summary components and */
/* the length of the name (You will notice that */
/* a name and a summary have the same length in bytes.) */
/* Local variables */
/* Set FOUND to FALSE right now in case we end up */
/* returning before doing any work. */
*found = FALSE_;
*ref = 0;
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("CKFROT", (ftnlen)6);
}
/* We don't need angular velocity data. */
/* Assume the segment won't be found until it really is. */
needav = FALSE_;
tol = 0.;
/* Begin a search for this instrument and time, and get the first */
/* applicable segment. */
ckhave_(&have);
ckmeta_(inst, "SCLK", &sclkid, (ftnlen)4);
if (! have) {
chkout_("CKFROT", (ftnlen)6);
return 0;
} else if (! zzsclk_(inst, &sclkid)) {
chkout_("CKFROT", (ftnlen)6);
return 0;
}
sce2c_(&sclkid, et, &time);
ckbss_(inst, &time, &tol, &needav);
cksns_(&handle, descr, segid, &sfnd, (ftnlen)40);
/* Keep trying candidate segments until a segment can produce a */
/* pointing instance within the specified time tolerance of the */
/* input time. */
/* Check FAILED to prevent an infinite loop if an error is detected */
/* by a SPICELIB routine and the error handling is not set to abort. */
while(sfnd && ! failed_()) {
ckpfs_(&handle, descr, &time, &tol, &needav, rot, av, &clkout, &pfnd);
if (pfnd) {
/* Found one. Fetch the ID code of the reference frame */
/* from the descriptor. */
dafus_(descr, &c__2, &c__6, dcd, icd);
*ref = icd[1];
*found = TRUE_;
/* We now have the rotation matrix from */
/* REF to INS. We invert ROT to get the rotation */
/* from INST to REF. */
xpose_(rot, rotate);
chkout_("CKFROT", (ftnlen)6);
return 0;
}
cksns_(&handle, descr, segid, &sfnd, (ftnlen)40);
}
chkout_("CKFROT", (ftnlen)6);
return 0;
} /* ckfrot_ */
/* $Procedure EKRCED ( EK, read column entry element, d.p. ) */
/* Subroutine */ int ekrced_(integer *handle, integer *segno, integer *recno,
char *column, integer *nvals, doublereal *dvals, logical *isnull,
ftnlen column_len)
{
integer unit;
extern /* Subroutine */ int zzekcdsc_(integer *, integer *, char *,
integer *, ftnlen), zzeksdsc_(integer *, integer *, integer *),
zzektrdp_(integer *, integer *, integer *, integer *);
extern integer zzekesiz_(integer *, integer *, integer *, integer *);
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
integer class__;
logical found;
integer dtype;
extern logical failed_(void);
integer coldsc[11], segdsc[24];
extern /* Subroutine */ int dashlu_(integer *, integer *);
integer recptr;
extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen), errfnm_(char *, integer *, ftnlen), sigerr_(
char *, ftnlen), chkout_(char *, ftnlen), zzekrd02_(integer *,
integer *, integer *, integer *, doublereal *, logical *),
zzekrd05_(integer *, integer *, integer *, integer *, integer *,
integer *, doublereal *, logical *, logical *), zzekrd08_(integer
*, integer *, integer *, integer *, doublereal *, logical *);
/* $ Abstract */
/* Read data from a double precision column in a specified EK */
/* record. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* EK */
/* $ Keywords */
/* EK */
/* FILES */
/* UTILITY */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK 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 Data Types */
/* ektype.inc Version 1 27-DEC-1994 (NJB) */
/* Within the EK system, data types of EK column contents are */
/* represented by integer codes. The codes and their meanings */
/* are listed below. */
/* Integer codes are also used within the DAS system to indicate */
/* data types; the EK system makes no assumptions about compatibility */
/* between the codes used here and those used in the DAS system. */
/* Character type: */
/* Double precision type: */
/* Integer type: */
/* `Time' type: */
/* Within the EK system, time values are represented as ephemeris */
/* seconds past J2000 (TDB), and double precision numbers are used */
/* to store these values. However, since time values require special */
/* treatment both on input and output, and since the `TIME' column */
/* has a special role in the EK specification and code, time values */
/* are identified as a type distinct from double precision numbers. */
/* End Include Section: EK Data Types */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle attached to EK file. */
/* SEGNO I Index of segment containing record. */
/* RECNO I Record from which data is to be read. */
/* COLUMN I Column name. */
/* NVALS O Number of values in column entry. */
/* DVALS O D.p. values in column entry. */
/* ISNULL O Flag indicating whether column entry is null. */
/* $ Detailed_Input */
/* HANDLE is an EK file handle. The file may be open for */
/* read or write access. */
/* SEGNO is the index of the segment from which data is to */
/* be read. */
/* RECNO is the index of the record from which data is to be */
/* read. This record number is relative to the start */
/* of the segment indicated by SEGNO; the first */
/* record in the segment has index 1. */
/* COLUMN is the name of the column from which data is to be */
/* read. */
/* $ Detailed_Output */
/* NVALS, */
/* DVALS are, respectively, the number of values found in */
/* the specified column entry and the set of values */
/* themselves. */
/* For columns having fixed-size entries, when a */
/* a column entry is null, NVALS is still set to the */
/* column entry size. For columns having variable- */
/* size entries, NVALS is set to 1 for null entries. */
/* ISNULL is a logical flag indicating whether the returned */
/* column entry is null. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If HANDLE is invalid, the error will be diagnosed by routines */
/* called by this routine. */
/* 2) If SEGNO is out of range, the error will diagnosed by routines */
/* called by this routine. */
/* 3) If RECNO is out of range, the error will diagnosed by routines */
/* called by this routine. */
/* 4) If COLUMN is not the name of a declared column, the error */
/* will be diagnosed by routines called by this routine. */
/* 5) If COLUMN specifies a column of whose data type is not */
/* double precision, the error SPICE(WRONGDATATYPE) will be */
/* signalled. */
/* 6) If COLUMN specifies a column of whose class is not */
/* a double precision class known to this routine, the error */
/* SPICE(NOCLASS) will be signalled. */
/* 7) If an attempt is made to read an uninitialized column entry, */
/* the error will be diagnosed by routines called by this */
/* routine. A null entry is considered to be initialized, but */
/* entries do not contain null values by default. */
/* 8) If an I/O error occurs while reading or writing the indicated */
/* file, the error will be diagnosed by routines called by this */
/* routine. */
/* $ Files */
/* See the EK Required Reading for a discussion of the EK file */
/* format. */
/* $ Particulars */
/* This routine is a utility that allows an EK file to be read */
/* directly without using the high-level query interface. */
/* $ Examples */
/* 1) Read the value in the third record of the column DCOL in */
/* the fifth segment of an EK file designated by HANDLE. */
/* CALL EKRCED ( HANDLE, 5, 3, 'DCOL', N, DVAL, ISNULL ) */
/* $ Restrictions */
/* 1) EK files open for write access are not necessarily readable. */
/* In particular, a column entry can be read only if it has been */
/* initialized. The caller is responsible for determining */
/* when it is safe to read from files open for write access. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.2.0, 20-JUN-1999 (WLT) */
/* Removed unbalanced call to CHKOUT. */
/* - SPICELIB Version 1.1.0, 28-JUL-1997 (NJB) */
/* Bug fix: Record number, not record pointer, is now supplied */
/* to look up data in the class 8 case. Miscellaneous header */
/* changes were made as well. */
/* - SPICELIB Version 1.0.0, 06-NOV-1995 (NJB) */
/* -& */
/* $ Index_Entries */
/* read double precision data from EK column */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.1.0, 28-JUL-1997 (NJB) */
/* Bug fix: Record number, not record pointer, is now supplied */
/* to look up data in the class 8 case. For class 8 columns, */
/* column entry locations are calculated directly from record */
/* numbers; no indirection is used. */
/* Miscellaneous header changes were made as well. */
/* -& */
/* SPICELIB functions */
/* Non-SPICELIB functions */
/* Local variables */
/* Use discovery check-in. */
/* First step: find the descriptor for the named segment. Using */
/* this descriptor, get the column descriptor. */
zzeksdsc_(handle, segno, segdsc);
zzekcdsc_(handle, segdsc, column, coldsc, column_len);
if (failed_()) {
return 0;
}
/* This column had better be of d.p. or TIME type. */
dtype = coldsc[1];
if (dtype != 2 && dtype != 4) {
chkin_("EKRCED", (ftnlen)6);
dashlu_(handle, &unit);
setmsg_("Column # is of type #; EKRCED only works with d.p. or TIME "
"columns. RECNO = #; SEGNO = #; EK = #.", (ftnlen)99);
errch_("#", column, (ftnlen)1, column_len);
errint_("#", &dtype, (ftnlen)1);
errint_("#", recno, (ftnlen)1);
errint_("#", segno, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(WRONGDATATYPE)", (ftnlen)20);
chkout_("EKRCED", (ftnlen)6);
return 0;
}
/* Now it's time to read data from the file. Call the low-level */
/* reader appropriate to the column's class. */
class__ = coldsc[0];
if (class__ == 2) {
/* Look up the record pointer for the target record. */
zzektrdp_(handle, &segdsc[6], recno, &recptr);
zzekrd02_(handle, segdsc, coldsc, &recptr, dvals, isnull);
*nvals = 1;
} else if (class__ == 5) {
zzektrdp_(handle, &segdsc[6], recno, &recptr);
*nvals = zzekesiz_(handle, segdsc, coldsc, &recptr);
zzekrd05_(handle, segdsc, coldsc, &recptr, &c__1, nvals, dvals,
isnull, &found);
} else if (class__ == 8) {
/* Records in class 8 columns are identified by a record number */
/* rather than a pointer. */
zzekrd08_(handle, segdsc, coldsc, recno, dvals, isnull);
*nvals = 1;
} else {
/* This is an unsupported d.p. column class. */
*segno = segdsc[1];
chkin_("EKRCED", (ftnlen)6);
dashlu_(handle, &unit);
setmsg_("Class # from input column descriptor is not a supported d.p"
". class. COLUMN = #; RECNO = #; SEGNO = #; EK = #.", (ftnlen)
110);
errint_("#", &class__, (ftnlen)1);
errch_("#", column, (ftnlen)1, column_len);
errint_("#", recno, (ftnlen)1);
errint_("#", segno, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(NOCLASS)", (ftnlen)14);
chkout_("EKRCED", (ftnlen)6);
return 0;
}
return 0;
} /* ekrced_ */
/* $Procedure GETFNM_1 ( Get a filename from standard input ) */
/* Subroutine */ int getfnm_1__(char *prmpt, char *fstat, char *fname,
logical *valid, ftnlen prmpt_len, ftnlen fstat_len, ftnlen fname_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
address a__1[2];
integer i__1, i__2[2];
char ch__1[1], ch__2[81];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
extern integer cpos_(char *, char *, integer *, ftnlen, ftnlen);
integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen), errch_(char *, char *, ftnlen, ftnlen), reset_(
void);
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
static char badchr[162];
extern logical failed_(void);
char oldact[10];
extern /* Subroutine */ int cnfirm_(char *, logical *, ftnlen), erract_(
char *, char *, ftnlen, ftnlen);
integer length;
extern integer lastnb_(char *, ftnlen);
char myfnam[1000];
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen);
logical tryagn, myvlid;
extern logical exists_(char *, ftnlen), return_(void);
extern /* Subroutine */ int prompt_(char *, char *, ftnlen, ftnlen),
writln_(char *, integer *, ftnlen);
char status[3], myprmt[80];
/* $ Abstract */
/* This routine prompts the user for a valid filename. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* PRMPT I The prompt to use when asking for the filename. */
/* FSTAT I Status of the file: 'OLD' or 'NEW'. */
/* FNAME O A valid filename typed in by the user. */
/* VALID O A logical flag indicating a valid filename. */
/* PRMLEN P Maximum length allowed for a prompt before */
/* truncation. */
/* $ Detailed_Input */
/* PRMPT is a character string that will be displayed from the */
/* current cursor position that informs a user that input */
/* is expected. Prompts should be fairly short, since we */
/* need to declare some local storage. The current maximum */
/* length of a prompt is given by the parameter PRMLEN. */
/* FSTAT This is the status of the filename entered. It should */
/* be 'OLD' when prompting for the filename of a file which */
/* already exists, and 'NEW' when prompting for the */
/* filename of a file which does not already exist or is to */
/* be over written. */
/* $ Detailed_Output */
/* FNAME is a character string that contains a valid filename */
/* typed in by the user. A valid filename is defined */
/* simply to be a nonblank character string with no */
/* embedded blanks, nonprinting characters, or characters */
/* having decimal values > 126. */
/* VALID A logical flag which indicates whether or not the */
/* filename entered is valid, i.e., a nonblank character */
/* string with no leading or embedded blanks, which */
/* satisfies the constraints for validity imposed. */
/* $ Parameters */
/* PRMLEN The maximum length for an input prompt string. */
/* $ Exceptions */
/* 1) If the input file status is not equal to 'NEW' or 'OLD' after */
/* being left justified and converted to upper case, the error */
/* SPICE(INVALIDARGUMENT) will be signalled. The error handling */
/* is then reset. */
/* 2) If the filename entered at the prompt is blank, the error */
/* SPICE(BLANKFILENAME) will be signalled. The error handling is */
/* then reset. */
/* 3) If the filename contains an illegal character, a nonprinting */
/* character or embedded blanks, the error */
/* SPICE(ILLEGALCHARACTER) will be signalled. */
/* 4) If the file status is equal to 'OLD' after being left */
/* justified and converted to upper case and the file specified */
/* by the filename entered at the prompt does not exist, the */
/* error SPICE(FILEDOESNOTEXIST) will be signalled. */
/* 5) If the file status is equal to 'NEW' after being left */
/* justified and converted to upper case and the file specified */
/* by the filename entered at the prompt already exists, the */
/* error SPICE(FILEALREADYEXISTS) will be signalled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This is a utility that allows you to "easily" request a valid, */
/* filename from a program user. At a high level, it frees you */
/* from the peculiarities of a particular FORTRAN's implementation */
/* of cursor control. */
/* A valid filename is defined as a nonblank character string with */
/* no embedded blanks, nonprinting characters, or characters with */
/* decimal values > 126. Leading blanks are removed, and trailing */
/* blanks are ignored. */
/* If an invalid filename is entered, this routine provides a */
/* descriptive error message and halts the execution of the */
/* process which called it by using a Fortran STOP. */
/* $ Examples */
/* EXAMPLE 1: */
/* FNAME = ' ' */
/* PRMPT = 'Filename? ' */
/* FSTAT = 'OLD' */
/* CALL GETFNM_1( PRMPT, FSTAT, FNAME, VALID ) */
/* The user sees the following displayed on the screen: */
/* Filename? _ */
/* where the underbar, '_', represents the cursor position. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* $ Version */
/* - SPICELIB Version 6.17.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 6.16.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 6.15.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 6.14.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 6.13.0, 14-DEC-2010 (EDW) */
/* Declared PROMPT as EXTERNAL. */
/* Unfied Version and Revision sections, eliminated Revision */
/* section. Corrected error in 09-DEC-1999 Version entry. */
/* Version ID changed to 6.0.9 from 7.0.0. */
/* - Beta Version 6.12.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - Beta Version 6.11.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - Beta Version 6.10.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - Beta Version 6.9.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - Beta Version 6.8.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - Beta Version 6.7.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - Beta Version 6.6.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - Beta Version 6.5.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - Beta Version 6.4.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - Beta Version 6.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - Beta Version 6.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - Beta Version 6.1.1, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - Beta Version 6.1.0, 16-AUG-2000 (WLT) */
/* Added PC-LINUX environment */
/* - Beta Version 6.0.9, 09-DEC-1999 (WLT) */
/* This routine now calls EXPFNM_2 only UNIX environments */
/* - Beta Version 6.0.0, 20-JAN-1998 (NJB) */
/* Now calls EXPFNM_2 to attempt to expand environment variables. */
/* Fixed a typo or two at various places in the header. */
/* - Beta Version 5.1.0, 31-JAN-1996 (KRG) */
/* Fixed a pedantic Fortran syntax error dealing with input */
/* strings that are dimensioned CHARACTER*(*). */
/* A local character string is now declared, and a parameter, */
/* PRMLEN, has been added to the interface description for this */
/* subroutine. PRMLEN defines the maximum length allowed for a */
/* prompt before it is truncated. */
/* - Beta Version 5.0.0, 05-JUL-1995 (KRG) */
/* Modified the routine to handle all of its own error messages */
/* and error conditions. The routine now signals an error */
/* immediately resetting the error handling when an exceptional */
/* condition is encountered. This is done so that input attempts */
/* may continue until a user decides to stop trying. */
/* Added several exceptions to the $ Exceptions section of the */
/* header. */
/* - Beta Version 4.0.1, 25-APR-1994 (KRG) */
/* Removed some incorrect comments from the $ Particulars section */
/* of the header. Something about a looping structure that is not */
/* a part of the code now, if it ever was. */
/* Fixed a typo or two at various places in the header. */
/* - Beta Version 4.0.0, 29-SEP-1993 (KRG) */
/* Added the character reperesnted by decimal 127 to the BADCHR. */
/* It should have been there, but it wasn't. */
/* - Beta Version 3.0.0, 10-SEP-1993 (KRG) */
/* Made the file status variable FSTAT case insensitive. */
/* Added code to the file status .EQ. 'NEW' case to set the */
/* valid flag to .FALSE. and set an appropriate error message */
/* about the file already existing. */
/* - Beta Version 2.0.0, 02-APR-1993 (KRG) */
/* The variable BADCHR was not saved which caused problems on */
/* some computers. This variable is now saved. */
/* - Beta Version 1.0.0, 01-JUN-1992 (KRG) */
/* -& */
/* $ Index_Entries */
/* prompt for a filename with error handling */
/* -& */
/* SPICELIB Functions */
/* Local Parameters */
/* Maximum length of a filename. */
/* Length of an error action */
/* Local Variables */
/* Saved Variables */
/* Initial Values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("GETFNM_1", (ftnlen)8);
}
/* We are going to be signalling errors and resetting the error */
/* handling, so we need to be in RETURN mode. First we get the */
/* current mode and save it, then we set the mode to return. Upon */
/* leaving the subroutine, we will restore the error handling mode */
/* that was in effect when we entered. */
erract_("GET", oldact, (ftnlen)3, (ftnlen)10);
erract_("SET", "RETURN", (ftnlen)3, (ftnlen)6);
/* If this is the first time this routine has been called, */
/* initialize the ``bad character'' string. */
if (first) {
first = FALSE_;
for (i__ = 0; i__ <= 32; ++i__) {
i__1 = i__;
*(unsigned char *)&ch__1[0] = i__;
s_copy(badchr + i__1, ch__1, i__ + 1 - i__1, (ftnlen)1);
}
for (i__ = 1; i__ <= 129; ++i__) {
i__1 = i__ + 32;
*(unsigned char *)&ch__1[0] = i__ + 126;
s_copy(badchr + i__1, ch__1, i__ + 33 - i__1, (ftnlen)1);
}
}
/* Left justify and convert the file status to upper case for */
/* comparisons. */
ljust_(fstat, status, fstat_len, (ftnlen)3);
ucase_(status, status, (ftnlen)3, (ftnlen)3);
/* Check to see if we have a valid status for the filename. */
if (s_cmp(status, "OLD", (ftnlen)3, (ftnlen)3) != 0 && s_cmp(status,
"NEW", (ftnlen)3, (ftnlen)3) != 0) {
setmsg_("The file status '#' was not valid. The file status must hav"
"e a value of 'NEW' or 'OLD'.", (ftnlen)87);
errch_("#", status, (ftnlen)1, (ftnlen)3);
sigerr_("SPICE(INVALIDARGUMENT)", (ftnlen)22);
chkout_("GETFNM_1", (ftnlen)8);
return 0;
}
/* Store the input value for the prompt into our local value. We do */
/* this for pedantic Fortran compilers that issue warnings for */
/* CHARACTER*(*) variables used with concatenation. */
s_copy(myprmt, prmpt, (ftnlen)80, prmpt_len);
/* Read in a potential filename, and test it for validity. */
tryagn = TRUE_;
while(tryagn) {
/* Set the value of the valid flag to .TRUE.. We assume that the */
/* name entered will be a valid one. */
myvlid = TRUE_;
/* Get the filename. */
if (s_cmp(myprmt, " ", (ftnlen)80, (ftnlen)1) == 0) {
prompt_("Filename? ", myfnam, (ftnlen)10, (ftnlen)1000);
} else {
/* Writing concatenation */
i__2[0] = lastnb_(myprmt, (ftnlen)80), a__1[0] = myprmt;
i__2[1] = 1, a__1[1] = " ";
s_cat(ch__2, a__1, i__2, &c__2, (ftnlen)81);
prompt_(ch__2, myfnam, lastnb_(myprmt, (ftnlen)80) + 1, (ftnlen)
1000);
}
if (failed_()) {
myvlid = FALSE_;
}
if (myvlid) {
if (s_cmp(myfnam, " ", (ftnlen)1000, (ftnlen)1) == 0) {
myvlid = FALSE_;
setmsg_("The filename entered was blank.", (ftnlen)31);
sigerr_("SPICE(BLANKFILENAME)", (ftnlen)20);
}
}
if (myvlid) {
/* Left justify the filename. */
ljust_(myfnam, myfnam, (ftnlen)1000, (ftnlen)1000);
/* Check for bad characters in the filename. */
length = lastnb_(myfnam, (ftnlen)1000);
i__ = cpos_(myfnam, badchr, &c__1, length, (ftnlen)162);
if (i__ > 0) {
myvlid = FALSE_;
setmsg_("The filename entered contains non printing characte"
"rs or embedded blanks.", (ftnlen)73);
sigerr_("SPICE(ILLEGALCHARACTER)", (ftnlen)23);
}
}
if (myvlid) {
/* We know that the filename that was entered was nonblank and */
/* had no bad characters. So, now we take care of the status */
/* question. */
if (s_cmp(status, "OLD", (ftnlen)3, (ftnlen)3) == 0) {
if (! exists_(myfnam, rtrim_(myfnam, (ftnlen)1000))) {
myvlid = FALSE_;
setmsg_("A file with the name '#' does not exist.", (
ftnlen)40);
errch_("#", myfnam, (ftnlen)1, (ftnlen)1000);
sigerr_("SPICE(FILEDOESNOTEXIST)", (ftnlen)23);
}
} else if (s_cmp(status, "NEW", (ftnlen)3, (ftnlen)3) == 0) {
if (exists_(myfnam, rtrim_(myfnam, (ftnlen)1000))) {
myvlid = FALSE_;
setmsg_("A file with the name '#' already exists.", (
ftnlen)40);
errch_("#", myfnam, (ftnlen)1, (ftnlen)1000);
sigerr_("SPICE(FILEALREADYEXISTS)", (ftnlen)24);
}
}
}
if (myvlid) {
tryagn = FALSE_;
} else {
writln_(" ", &c__6, (ftnlen)1);
cnfirm_("Try again? (Yes/No) ", &tryagn, (ftnlen)20);
writln_(" ", &c__6, (ftnlen)1);
if (tryagn) {
reset_();
}
}
}
/* At this point, we have done the best we can. If the status */
/* was new, we might still have an invalid filename, but the */
/* exact reasons for its invalidity are system dependent, and */
/* therefore hard to test. */
*valid = myvlid;
if (*valid) {
s_copy(fname, myfnam, fname_len, rtrim_(myfnam, (ftnlen)1000));
}
/* Restore the error action. */
erract_("SET", oldact, (ftnlen)3, (ftnlen)10);
chkout_("GETFNM_1", (ftnlen)8);
return 0;
} /* getfnm_1__ */
/* $Procedure ZZEKPGCH ( EK, paging system access check ) */
/* Subroutine */ int zzekpgch_(integer *handle, char *access, ftnlen
access_len)
{
integer topc, topd, topi, unit;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer lastc, lastd, lasti, id;
extern logical failed_(void);
extern /* Subroutine */ int daslla_(integer *, integer *, integer *,
integer *), dasrdi_(integer *, integer *, integer *, integer *),
dassih_(integer *, char *, ftnlen), dashlu_(integer *, integer *),
errfnm_(char *, integer *, ftnlen), sigerr_(char *, ftnlen),
chkout_(char *, ftnlen), setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen);
integer npc, npd, npi;
/* $ Abstract */
/* Check that an EK is valid for a specified type of access by the */
/* paging system. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* EK */
/* $ Keywords */
/* EK */
/* PRIVATE */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Das Paging Parameters */
/* ekpage.inc Version 4 25-AUG-1995 (NJB) */
/* The EK DAS paging system makes use of the integer portion */
/* of an EK file's DAS address space to store the few numbers */
/* required to describe the system's state. The allocation */
/* of DAS integer addresses is shown below. */
/* DAS integer array */
/* +--------------------------------------------+ */
/* | EK architecture code | Address = 1 */
/* +--------------------------------------------+ */
/* | Character page size (in DAS words) | */
/* +--------------------------------------------+ */
/* | Character page base address | */
/* +--------------------------------------------+ */
/* | Number of character pages in file | */
/* +--------------------------------------------+ */
/* | Number of character pages on free list | */
/* +--------------------------------------------+ */
/* | Character free list head pointer | Address = 6 */
/* +--------------------------------------------+ */
/* | | Addresses = */
/* | Metadata for d.p. pages | 7--11 */
/* | | */
/* +--------------------------------------------+ */
/* | | Addresses = */
/* | Metadata for integer pages | 12--16 */
/* | | */
/* +--------------------------------------------+ */
/* . */
/* . */
/* . */
/* +--------------------------------------------+ */
/* | | End Address = */
/* | Unused space | integer page */
/* | | end */
/* +--------------------------------------------+ */
/* | | Start Address = */
/* | First integer page | integer page */
/* | | base */
/* +--------------------------------------------+ */
/* . */
/* . */
/* . */
/* +--------------------------------------------+ */
/* | | */
/* | Last integer page | */
/* | | */
/* +--------------------------------------------+ */
/* The following parameters indicate positions of elements in the */
/* paging system metadata array: */
/* Number of metadata items per data type: */
/* Character metadata indices: */
/* Double precision metadata indices: */
/* Integer metadata indices: */
/* Size of metadata area: */
/* Page sizes, in units of DAS words of the appropriate type: */
/* Default page base addresses: */
/* End Include Section: EK Das Paging Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Architecture Version Parameters */
/* ekarch.inc Version 1 01-NOV-1995 (NJB) */
/* The following parameter indicates the EK file architecture */
/* version. EK files read by the EK system must have the */
/* architecture expected by the reader software; the architecture ID */
/* below is used to test for compatibility. */
/* Architecture code: */
/* End Include Section: EK Architecture Version Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Data Types */
/* ektype.inc Version 1 27-DEC-1994 (NJB) */
/* Within the EK system, data types of EK column contents are */
/* represented by integer codes. The codes and their meanings */
/* are listed below. */
/* Integer codes are also used within the DAS system to indicate */
/* data types; the EK system makes no assumptions about compatibility */
/* between the codes used here and those used in the DAS system. */
/* Character type: */
/* Double precision type: */
/* Integer type: */
/* `Time' type: */
/* Within the EK system, time values are represented as ephemeris */
/* seconds past J2000 (TDB), and double precision numbers are used */
/* to store these values. However, since time values require special */
/* treatment both on input and output, and since the `TIME' column */
/* has a special role in the EK specification and code, time values */
/* are identified as a type distinct from double precision numbers. */
/* End Include Section: EK Data Types */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle attached to EK file. */
/* ACCESS I Access type. */
/* $ Detailed_Input */
/* HANDLE is an EK file handle. The specified file is to be */
/* checked to see whether it is a valid paged EK and */
/* whether it is open for the specified type of */
/* access. */
/* ACCESS is a short string indicating the type of access */
/* desired. Possible values are 'READ' and 'WRITE'. */
/* Leading and trailing blanks in ACCESS are ignored, */
/* and case is not significant. */
/* $ Detailed_Output */
/* None. See $Particulars for a description of the effect of this */
/* routine. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If HANDLE is invalid, the error will be diagnosed by routines */
/* called by this routine. */
/* 2) If the EK architecture version is not current, the error */
/* SPICE(WRONGARCHITECTURE) is signalled. */
/* 3) If the DAS logical address ranges occupied by the EK are */
/* not consistent with those recorded by the paging system, */
/* the error SPICE(INVALIDFORMAT) is signalled. */
/* 4) If the EK is not open for the specified type of access, the */
/* error will be diagnosed by routines called by this routine. */
/* $ Files */
/* See the EK Required Reading for a discussion of the EK file */
/* format. */
/* $ Particulars */
/* This routine centralizes a validation check performed by many */
/* EK routines. The EK designated by HANDLE is tested to see */
/* whether some aspects of its structure are valid, and whether */
/* the specified type of access (read or write) is allowed. */
/* The tests performed are: */
/* - Is the file a DAS file open for the specified type of access? */
/* - Is the file's EK architecture version correct? */
/* - Are the DAS address ranges in use consistent with those */
/* recorded in the file by the paging system? */
/* If the file fails any test, an error is signalled. */
/* $ Examples */
/* See EKINSR. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - Beta Version 1.0.0, 19-OCT-1995 (NJB) */
/* -& */
/* SPICELIB functions */
/* Local variables */
chkin_("ZZEKPGCH", (ftnlen)8);
/* Check whether the DAS is opened for the specified access method. */
dassih_(handle, access, access_len);
if (failed_()) {
chkout_("ZZEKPGCH", (ftnlen)8);
return 0;
}
/* Make sure the DAS file is of the right type. */
dasrdi_(handle, &c__1, &c__1, &id);
if (id != 8) {
dashlu_(handle, &unit);
setmsg_("File # has architecture #, which is invalid for paged acces"
"s. You are using EK software version #.", (ftnlen)99);
errfnm_("#", &unit, (ftnlen)1);
errint_("#", &id, (ftnlen)1);
errint_("#", &c__8, (ftnlen)1);
sigerr_("SPICE(WRONGARCHITECTURE)", (ftnlen)24);
chkout_("ZZEKPGCH", (ftnlen)8);
return 0;
}
/* Obtain the page counts. Set the `top' addresses. */
dasrdi_(handle, &c__4, &c__4, &npc);
dasrdi_(handle, &c__9, &c__9, &npd);
dasrdi_(handle, &c__14, &c__14, &npi);
topc = npc << 10;
topd = npd << 7;
topi = (npi << 8) + 256;
/* Verify that the last addresses in use are consistent with the */
/* `top' addresses known to this system. */
daslla_(handle, &lastc, &lastd, &lasti);
if (lastc > topc) {
dashlu_(handle, &unit);
setmsg_("File # has last char address #; `top' = #.", (ftnlen)42);
errfnm_("#", &unit, (ftnlen)1);
errint_("#", &lastc, (ftnlen)1);
errint_("#", &topc, (ftnlen)1);
sigerr_("SPICE(INVALIDFORMAT)", (ftnlen)20);
chkout_("ZZEKPGCH", (ftnlen)8);
return 0;
} else if (lastd > topd) {
dashlu_(handle, &unit);
setmsg_("File # has last d.p. address #; `top' = #.", (ftnlen)42);
errfnm_("#", &unit, (ftnlen)1);
errint_("#", &lastd, (ftnlen)1);
errint_("#", &topd, (ftnlen)1);
sigerr_("SPICE(INVALIDFORMAT)", (ftnlen)20);
chkout_("ZZEKPGCH", (ftnlen)8);
return 0;
} else if (lasti > topi) {
dashlu_(handle, &unit);
setmsg_("File # has last int. address #; `top' = #.", (ftnlen)42);
errfnm_("#", &unit, (ftnlen)1);
errint_("#", &lasti, (ftnlen)1);
errint_("#", &topi, (ftnlen)1);
sigerr_("SPICE(INVALIDFORMAT)", (ftnlen)20);
chkout_("ZZEKPGCH", (ftnlen)8);
return 0;
}
chkout_("ZZEKPGCH", (ftnlen)8);
return 0;
} /* zzekpgch_ */
/* $Procedure ZZEKGLNK ( EK, get link count for data page ) */
/* Subroutine */ int zzekglnk_(integer *handle, integer *type__, integer *p,
integer *nlinks)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer i_dnnt(doublereal *);
/* Local variables */
integer base;
extern /* Subroutine */ int zzekpgbs_(integer *, integer *, integer *);
doublereal dplnk;
extern logical failed_(void);
extern /* Subroutine */ int dasrdd_(integer *, integer *, integer *,
doublereal *), dasrdi_(integer *, integer *, integer *, integer *)
, zzekgei_(integer *, integer *, integer *);
/* $ Abstract */
/* Return the link count for a specified EK data page. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* EK */
/* $ Keywords */
/* EK */
/* PRIVATE */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Data Page Parameters */
/* ekfilpar.inc Version 1 03-APR-1995 (NJB) */
/* These parameters apply to EK files using architecture 4. */
/* These files use a paged DAS file as their underlying file */
/* structure. */
/* In paged DAS EK files, data pages are structured: they contain */
/* metadata as well as data. The metadata is located in the last */
/* few addresses of each page, so as to interfere as little as */
/* possible with calculation of data addresses. */
/* Each data page belongs to exactly one segment. Some bookkeeping */
/* information, such as record pointers, is also stored in data */
/* pages. */
/* Each page contains a forward pointer that allows rapid lookup */
/* of data items that span multiple pages. Each page also keeps */
/* track of the current number of links from its parent segment */
/* to the page. Link counts enable pages to `know' when they */
/* are no longer in use by a segment; unused pages are deallocated */
/* and returned to the free list. */
/* The parameters in this include file depend on the parameters */
/* declared in the include file ekpage.inc. If those parameters */
/* change, this file must be updated. The specified parameter */
/* declarations we need from that file are: */
/* INTEGER PGSIZC */
/* PARAMETER ( PGSIZC = 1024 ) */
/* INTEGER PGSIZD */
/* PARAMETER ( PGSIZD = 128 ) */
/* INTEGER PGSIZI */
/* PARAMETER ( PGSIZI = 256 ) */
/* Character pages use an encoding mechanism to represent integer */
/* metadata. Each integer is encoded in five consecutive */
/* characters. */
/* Character data page parameters: */
/* Size of encoded integer: */
/* Usable page size: */
/* Location of character forward pointer: */
/* Location of character link count: */
/* Double precision data page parameters: */
/* Usable page size: */
/* Location of d.p. forward pointer: */
/* Location of d.p. link count: */
/* Integer data page parameters: */
/* Usable page size: */
/* Location of integer forward pointer: */
/* Location of integer link count: */
/* End Include Section: EK Data Page Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Segment Descriptor Parameters */
/* eksegdsc.inc Version 8 06-NOV-1995 (NJB) */
/* All `base addresses' referred to below are the addresses */
/* *preceding* the item the base applies to. This convention */
/* enables simplied address calculations in many cases. */
/* Size of segment descriptor. Note: the include file ekcoldsc.inc */
/* must be updated if this parameter is changed. The parameter */
/* CDOFF in that file should be kept equal to SDSCSZ. */
/* Index of the segment type code: */
/* Index of the segment's number. This number is the segment's */
/* index in the list of segments contained in the EK to which */
/* the segment belongs. */
/* Index of the DAS integer base address of the segment's integer */
/* meta-data: */
/* Index of the DAS character base address of the table name: */
/* Index of the segment's column count: */
/* Index of the segment's record count: */
/* Index of the root page number of the record tree: */
/* Index of the root page number of the character data page tree: */
/* Index of the root page number of the double precision data page */
/* tree: */
/* Index of the root page number of the integer data page tree: */
/* Index of the `modified' flag: */
/* Index of the `initialized' flag: */
/* Index of the shadowing flag: */
/* Index of the companion file handle: */
/* Index of the companion segment number: */
/* The next three items are, respectively, the page numbers of the */
/* last character, d.p., and integer data pages allocated by the */
/* segment: */
/* The next three items are, respectively, the page-relative */
/* indices of the last DAS word in use in the segment's */
/* last character, d.p., and integer data pages: */
/* Index of the DAS character base address of the column name list: */
/* The last descriptor element is reserved for future use. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Segment Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Data Types */
/* ektype.inc Version 1 27-DEC-1994 (NJB) */
/* Within the EK system, data types of EK column contents are */
/* represented by integer codes. The codes and their meanings */
/* are listed below. */
/* Integer codes are also used within the DAS system to indicate */
/* data types; the EK system makes no assumptions about compatibility */
/* between the codes used here and those used in the DAS system. */
/* Character type: */
/* Double precision type: */
/* Integer type: */
/* `Time' type: */
/* Within the EK system, time values are represented as ephemeris */
/* seconds past J2000 (TDB), and double precision numbers are used */
/* to store these values. However, since time values require special */
/* treatment both on input and output, and since the `TIME' column */
/* has a special role in the EK specification and code, time values */
/* are identified as a type distinct from double precision numbers. */
/* End Include Section: EK Data Types */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I File handle. */
/* TYPE I Data type of page. */
/* P I Page number. */
/* NLINKS O Number of links to page. */
/* $ Detailed_Input */
/* HANDLE is a file handle of an EK open for write access. */
/* TYPE is the data type of the desired page. */
/* P is the page number of the allocated page. This */
/* number is recognized by the EK paged access */
/* routines. */
/* $ Detailed_Output */
/* NLINKS is the currently held number of links to the */
/* specified data page. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If HANDLE is invalid, the error will be diagnosed by routines */
/* called by this routine. */
/* 2) If TYPE is invalid, the error will be diagnosed by routines */
/* called by this routine. */
/* 3) If an I/O error occurs while reading or writing the indicated */
/* file, the error will be diagnosed by routines called by this */
/* routine. */
/* $ Files */
/* See the EK Required Reading for a discussion of the EK file */
/* format. */
/* $ Particulars */
/* This routine centralizes EK data page link count accesses. */
/* $ Examples */
/* See EKDELR. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - Beta Version 1.0.0, 10-OCT-1995 (NJB) */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Use discovery check-in. */
/* Look up the base address of the page. */
zzekpgbs_(type__, p, &base);
if (failed_()) {
return 0;
}
if (*type__ == 1) {
/* Look up the encoded count. */
i__1 = base + 1020;
zzekgei_(handle, &i__1, nlinks);
} else if (*type__ == 2) {
/* Convert the encoded count to integer type. */
i__1 = base + 128;
i__2 = base + 128;
dasrdd_(handle, &i__1, &i__2, &dplnk);
*nlinks = i_dnnt(&dplnk);
} else {
/* The remaining possibility is that TYPE is INT. If we had had */
/* an unrecognized type, ZZEKPGBS would have complained. */
i__1 = base + 256;
i__2 = base + 256;
dasrdi_(handle, &i__1, &i__2, nlinks);
}
return 0;
} /* zzekglnk_ */
/* $Procedure TIPBOD ( Transformation, inertial position to bodyfixed ) */
/* Subroutine */ int tipbod_(char *ref, integer *body, doublereal *et,
doublereal *tipm, ftnlen ref_len)
{
doublereal ref2j[9] /* was [3][3] */;
extern /* Subroutine */ int chkin_(char *, ftnlen), moved_(doublereal *,
integer *, doublereal *);
extern logical failed_(void);
extern /* Subroutine */ int bodmat_(integer *, doublereal *, doublereal *)
, chkout_(char *, ftnlen);
doublereal tmpmat[9] /* was [3][3] */;
extern /* Subroutine */ int irftrn_(char *, char *, doublereal *, ftnlen,
ftnlen);
extern logical return_(void);
extern /* Subroutine */ int mxm_(doublereal *, doublereal *, doublereal *)
;
/* $ Abstract */
/* Return a 3x3 matrix that transforms positions in inertial */
/* coordinates to positions in body-equator-and-prime-meridian */
/* coordinates. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* PCK */
/* NAIF_IDS */
/* ROTATION */
/* TIME */
/* $ Keywords */
/* TRANSFORMATION */
/* ROTATION */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* REF I ID of inertial reference frame to transform from. */
/* BODY I ID code of body. */
/* ET I Epoch of transformation. */
/* TIPM O Transformation (position), inertial to prime */
/* meridian. */
/* $ Detailed_Input */
/* REF is the NAIF name for an inertial reference frame. */
/* Acceptable names include: */
/* Name Description */
/* -------- -------------------------------- */
/* 'J2000' Earth mean equator, dynamical */
/* equinox of J2000 */
/* 'B1950' Earth mean equator, dynamical */
/* equinox of B1950 */
/* 'FK4' Fundamental Catalog (4) */
/* 'DE-118' JPL Developmental Ephemeris (118) */
/* 'DE-96' JPL Developmental Ephemeris ( 96) */
/* 'DE-102' JPL Developmental Ephemeris (102) */
/* 'DE-108' JPL Developmental Ephemeris (108) */
/* 'DE-111' JPL Developmental Ephemeris (111) */
/* 'DE-114' JPL Developmental Ephemeris (114) */
/* 'DE-122' JPL Developmental Ephemeris (122) */
/* 'DE-125' JPL Developmental Ephemeris (125) */
/* 'DE-130' JPL Developmental Ephemeris (130) */
/* 'GALACTIC' Galactic System II */
/* 'DE-200' JPL Developmental Ephemeris (200) */
/* 'DE-202' JPL Developmental Ephemeris (202) */
/* (See the routine CHGIRF for a full list of names.) */
/* The output TIPM will give the transformation */
/* from this frame to the bodyfixed frame specified by */
/* BODY at the epoch specified by ET. */
/* BODY is the integer ID code of the body for which the */
/* position transformation matrix is requested. Bodies */
/* are numbered according to the standard NAIF */
/* numbering scheme. The numbering scheme is */
/* explained in the NAIF_IDS required reading file. */
/* ET is the epoch at which the position transformation */
/* matrix is requested. (This is typically the */
/* epoch of observation minus the one-way light time */
/* from the observer to the body at the epoch of */
/* observation.) */
/* $ Detailed_Output */
/* TIPM is a 3x3 coordinate transformation matrix. It is */
/* used to transform positions from inertial */
/* coordinates to body fixed (also called equator and */
/* prime meridian --- PM) coordinates. */
/* Given a position P in the inertial reference frame */
/* specified by REF, the corresponding bodyfixed */
/* position is given by the matrix vector product: */
/* TIPM * S */
/* The X axis of the PM system is directed to the */
/* intersection of the equator and prime meridian. */
/* The Z axis points along the spin axis and points */
/* towards the same side of the invariable plane of */
/* the solar system as does earth's north pole. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the kernel pool does not contain all of the data required */
/* for computing the transformation matrix, TIPM, the error */
/* SPICE(INSUFFICIENTANGLES) is signalled. */
/* 2) If the reference frame, REF, is not recognized, a routine */
/* called by TIPBOD will diagnose the condition and invoke the */
/* SPICE error handling system. */
/* 3) If the specified body code, BODY, is not recognized, the */
/* error is diagnosed by a routine called by TIPBOD. */
/* $ Files */
/* None. */
/* $ Particulars */
/* TIPBOD takes PCK information as input, either in the */
/* form of a binary or text PCK file. High precision */
/* binary files are searched for first (the last loaded */
/* file takes precedence); then it defaults to the text */
/* PCK file. If binary information is found for the */
/* requested body and time, the Euler angles are */
/* evaluated and the transformation matrix is calculated */
/* from them. Using the Euler angles PHI, DELTA and W */
/* we compute */
/* TIPM = [W] [DELTA] [PHI] */
/* 3 1 3 */
/* If no appropriate binary PCK files have been loaded, */
/* the text PCK file is used. Here information is found */
/* as RA, DEC and W (with the possible addition of nutation */
/* and libration terms for satellites). Again, the Euler */
/* angles are found, and the transformation matrix is */
/* calculated from them. The transformation from inertial to */
/* bodyfixed coordinates is represented as: */
/* TIPM = [W] [HALFPI-DEC] [RA+HALFPI] */
/* 3 1 3 */
/* These are basically the Euler angles, PHI, DELTA and W: */
/* RA = PHI - HALFPI */
/* DEC = HALFPI - DELTA */
/* W = W */
/* In the text file, RA, DEC, and W are defined as follows: */
/* 2 ____ */
/* RA2*t \ */
/* RA = RA0 + RA1*t/T + ------ + / a sin theta */
/* 2 ---- i i */
/* T i */
/* 2 ____ */
/* DEC2*t \ */
/* DEC = DEC0 + DEC1*t/T + ------- + / d cos theta */
/* 2 ---- i i */
/* T i */
/* 2 ____ */
/* W2*t \ */
/* W = W0 + W1*t/d + ----- + / w sin theta */
/* 2 ---- i i */
/* d i */
/* where: */
/* d = seconds/day */
/* T = seconds/Julian century */
/* a , d , and w arrays apply to satellites only. */
/* i i i */
/* theta = THETA0(i) + THETA1(i)*t/T are specific to each */
/* i */
/* planet. */
/* These angles -- typically nodal rates -- vary in number and */
/* definition from one planetary system to the next. */
/* $ Examples */
/* Note that the items necessary to compute the Euler angles */
/* must have been loaded into the kernel pool (by one or more */
/* previous calls to FURNSH). The Euler angles are typically */
/* stored in the P_constants kernel file that comes with */
/* SPICELIB. */
/* 1) In the following code fragment, TIPBOD is used to transform */
/* a position in J2000 inertial coordinates to a state in */
/* bodyfixed coordinates. */
/* The 3-vectors POSTN represents the inertial position */
/* of an object with respect to the center of the */
/* body at time ET. */
/* C */
/* C First load the kernel pool. */
/* C */
/* CALL FURNSH ( 'PLANETARY_CONSTANTS.KER' ) */
/* C */
/* C Next get the transformation and its derivative. */
/* C */
/* CALL TIPBOD ( 'J2000', BODY, ET, TIPM ) */
/* C */
/* C Convert position, the first three elements of */
/* C STATE, to bodyfixed coordinates. */
/* C */
/* CALL MXVG ( TIPM, POSTN, BDPOS ) */
/* $ Restrictions */
/* The kernel pool must be loaded with the appropriate */
/* coefficients (from the P_constants kernel or binary PCK file) */
/* prior to calling this routine. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* K.S. Zukor (JPL) */
/* $ Version */
/* - SPICELIB Version 1.2.0, 23-OCT-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in MXM call. Replaced header references to LDPOOL with */
/* references to FURNSH. */
/* - SPICELIB Version 1.1.0, 05-JAN-2005 (NJB) */
/* Tests of routine FAILED() were added. */
/* - SPICELIB Version 1.0.3, 10-MAR-1994 (KSZ) */
/* Underlying BODMAT code changed to look for binary PCK */
/* data files, and use them to get orientation information if */
/* they are available. Only the comments to TIPBOD changed. */
/* - SPICELIB Version 1.0.2, 06-JUL-1993 (HAN) */
/* Example in header was corrected. Previous version had */
/* incorrect matrix dimension specifications passed to MXVG. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 05-AUG-1991 (NJB) (WLT) */
/* -& */
/* $ Index_Entries */
/* transformation from inertial position to bodyfixed */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.2.0, 06-SEP-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in MXM call. Replaced header references to LDPOOL with */
/* references to FURNSH. */
/* - SPICELIB Version 1.1.0, 05-JAN-2005 (NJB) */
/* Tests of routine FAILED() were added. The new checks */
/* are intended to prevent arithmetic operations from */
/* being performed with uninitialized or invalid data. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("TIPBOD", (ftnlen)6);
}
/* Get the transformation from the inertial from REF to J2000 */
/* coordinates. */
irftrn_(ref, "J2000", ref2j, ref_len, (ftnlen)5);
/* Get the transformation from J2000 to body-fixed coordinates */
/* for the requested epoch. */
bodmat_(body, et, tipm);
if (failed_()) {
chkout_("TIPBOD", (ftnlen)6);
return 0;
}
/* Compose the transformations to arrive at the REF-to-J2000 */
/* transformation. */
mxm_(tipm, ref2j, tmpmat);
moved_(tmpmat, &c__9, tipm);
/* That's all folks. Check out and get out. */
chkout_("TIPBOD", (ftnlen)6);
return 0;
} /* tipbod_ */
/* $Procedure ZZEKACPS ( EK, allocate contiguous pages for segment ) */
/* Subroutine */ int zzekacps_(integer *handle, integer *segdsc, integer *
type__, integer *n, integer *p, integer *base)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
integer tree;
extern /* Subroutine */ int zzekpgan_(integer *, integer *, integer *,
integer *), zzeksfwd_(integer *, integer *, integer *, integer *),
zzektrap_(integer *, integer *, integer *, integer *), zzekslnk_(
integer *, integer *, integer *, integer *);
integer b, i__, p2;
extern logical failed_(void);
integer idx;
/* $ Abstract */
/* Allocate a series of contiguous data pages for a specified EK */
/* segment. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* EK */
/* $ Keywords */
/* PRIVATE */
/* UTILITY */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Segment Descriptor Parameters */
/* eksegdsc.inc Version 8 06-NOV-1995 (NJB) */
/* All `base addresses' referred to below are the addresses */
/* *preceding* the item the base applies to. This convention */
/* enables simplied address calculations in many cases. */
/* Size of segment descriptor. Note: the include file ekcoldsc.inc */
/* must be updated if this parameter is changed. The parameter */
/* CDOFF in that file should be kept equal to SDSCSZ. */
/* Index of the segment type code: */
/* Index of the segment's number. This number is the segment's */
/* index in the list of segments contained in the EK to which */
/* the segment belongs. */
/* Index of the DAS integer base address of the segment's integer */
/* meta-data: */
/* Index of the DAS character base address of the table name: */
/* Index of the segment's column count: */
/* Index of the segment's record count: */
/* Index of the root page number of the record tree: */
/* Index of the root page number of the character data page tree: */
/* Index of the root page number of the double precision data page */
/* tree: */
/* Index of the root page number of the integer data page tree: */
/* Index of the `modified' flag: */
/* Index of the `initialized' flag: */
/* Index of the shadowing flag: */
/* Index of the companion file handle: */
/* Index of the companion segment number: */
/* The next three items are, respectively, the page numbers of the */
/* last character, d.p., and integer data pages allocated by the */
/* segment: */
/* The next three items are, respectively, the page-relative */
/* indices of the last DAS word in use in the segment's */
/* last character, d.p., and integer data pages: */
/* Index of the DAS character base address of the column name list: */
/* The last descriptor element is reserved for future use. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Segment Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Data Types */
/* ektype.inc Version 1 27-DEC-1994 (NJB) */
/* Within the EK system, data types of EK column contents are */
/* represented by integer codes. The codes and their meanings */
/* are listed below. */
/* Integer codes are also used within the DAS system to indicate */
/* data types; the EK system makes no assumptions about compatibility */
/* between the codes used here and those used in the DAS system. */
/* Character type: */
/* Double precision type: */
/* Integer type: */
/* `Time' type: */
/* Within the EK system, time values are represented as ephemeris */
/* seconds past J2000 (TDB), and double precision numbers are used */
/* to store these values. However, since time values require special */
/* treatment both on input and output, and since the `TIME' column */
/* has a special role in the EK specification and code, time values */
/* are identified as a type distinct from double precision numbers. */
/* End Include Section: EK Data Types */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I File handle. */
/* SEGDSC I Segment descriptor. */
/* TYPE I Data type of page. */
/* N I Number of pages to allocate. */
/* P O Page number. */
/* BASE O DAS base address of page. */
/* $ Detailed_Input */
/* HANDLE is a file handle of an EK open for write access. */
/* SEGDSC is the descriptor of the segment for which to */
/* allocate a series of data pages. */
/* TYPE is the data type of the desired pages. */
/* N is the number of pages desired. All pages */
/* allocated are new. A new page is one that has not */
/* been allocated before. */
/* $ Detailed_Output */
/* P is the number of the first page of the allocated */
/* series. The rest of the pages have numbers */
/* P+1, P+2, ... , P+N-1 */
/* These numbers are recognized by the EK paged access */
/* routines. */
/* BASE is the DAS base address of the first allocated */
/* page. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If HANDLE is invalid, the error will be diagnosed by routines */
/* called by this routine. The file will not be modified. */
/* 2) If an I/O error occurs while reading or writing the indicated */
/* file, the error will be diagnosed by routines called by this */
/* routine. The file may be corrupted. */
/* $ Files */
/* See the EK Required Reading for a discussion of the EK file */
/* format. */
/* $ Particulars */
/* This routine operates by side effects: it allocates a series of */
/* new, contiguous EK data pages for a specified segment. The */
/* segment's metadata are updated to reflect aquisition of the pages. */
/* This routine, not ZZEKAPS, should be used when contiguous pages */
/* are required. */
/* Each allocated page is initialized as follows: */
/* - The page's link count is zeroed out. */
/* - The page's forward pointer is zeroed out. */
/* After all pages are allocated, the metadata for the segment are */
/* adjusted to reflect ownership of the allocated pages. */
/* The changes made by this routine to the target EK file become */
/* permanent when the file is closed. Failure to close the file */
/* properly will leave it in an indeterminate state. */
/* $ Examples */
/* See ZZEKWPAI. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - Beta Version 1.0.0, 09-NOV-1995 (NJB) */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Use discovery check-in. */
/* Allocate the pages. */
zzekpgan_(handle, type__, p, base);
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
zzekpgan_(handle, type__, &p2, &b);
}
if (failed_()) {
return 0;
}
/* Initialize the pages. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Zero out the page's link count and forward pointer. */
i__2 = *p + i__ - 1;
zzekslnk_(handle, type__, &i__2, &c__0);
i__2 = *p + i__ - 1;
zzeksfwd_(handle, type__, &i__2, &c__0);
}
/* Update the segment's metadata. Insert the number of each new */
/* page into the page tree of the appropriate data type. */
if (*type__ == 1) {
tree = segdsc[7];
} else if (*type__ == 2) {
tree = segdsc[8];
} else {
/* The remaining possibility is that TYPE is INT. If we had had */
/* an unrecognized type, one of the allocation routines would have */
/* complained. */
tree = segdsc[9];
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *p + i__ - 1;
zzektrap_(handle, &tree, &i__2, &idx);
}
return 0;
} /* zzekacps_ */
/* $Procedure SCPART ( Spacecraft Clock Partition Information ) */
/* Subroutine */ int scpart_(integer *sc, integer *nparts, doublereal *pstart,
doublereal *pstop)
{
/* Initialized data */
static logical first = TRUE_;
static logical nodata = TRUE_;
static integer oldsc = 0;
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer);
double d_nint(doublereal *);
/* Local variables */
extern /* Subroutine */ int zzcvpool_(char *, integer *, logical *,
ftnlen), zzctruin_(integer *);
integer i__;
extern /* Subroutine */ int scld01_(char *, integer *, integer *, integer
*, doublereal *, ftnlen), chkin_(char *, ftnlen), repmi_(char *,
char *, integer *, char *, ftnlen, ftnlen, ftnlen);
static doublereal prtsa[9999], prtso[9999];
extern logical failed_(void);
char kvname[60*2];
logical update;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen), suffix_(char *, integer *, char *, ftnlen, ftnlen);
integer nprtsa;
extern logical return_(void);
static integer usrctr[2];
extern /* Subroutine */ int swpool_(char *, integer *, char *, ftnlen,
ftnlen);
integer nprtso;
static integer lstprt;
/* $ Abstract */
/* Get spacecraft clock partition information from a spacecraft */
/* clock kernel file. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* SCLK */
/* $ Keywords */
/* TIME */
/* $ Declarations */
/* $ Abstract */
/* Include file sclk.inc */
/* SPICE private file intended solely for the support of SPICE */
/* routines. Users should not include this file directly due */
/* to the volatile nature of this file */
/* The parameters below define sizes and limits used by */
/* the SCLK system. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Parameters */
/* See the declaration section below. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 2.0.0, 24-MAY-2010 (NJB) */
/* Increased value of maximum coefficient record count */
/* parameter MXCOEF from 10K to 50K. */
/* - SPICELIB Version 1.0.0, 11-FEB-2008 (NJB) */
/* -& */
/* Number of supported SCLK field delimiters: */
/* Supported SCLK string field delimiters: */
/* Maximum number of partitions: */
/* Partition string length. */
/* Since the maximum number of partitions is given by MXPART is */
/* 9999, PRTSTR needs at most 4 characters for the partition number */
/* and one character for the slash. */
/* Maximum number of coefficient records: */
/* Maximum number of fields in an SCLK string: */
/* Length of strings used to represent D.P. */
/* numbers: */
/* Maximum number of supported parallel time systems: */
/* End of include file sclk.inc */
/* $ Abstract */
/* This include file defines the dimension of the counter */
/* array used by various SPICE subsystems to uniquely identify */
/* changes in their states. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Parameters */
/* CTRSIZ is the dimension of the counter array used by */
/* various SPICE subsystems to uniquely identify */
/* changes in their states. */
/* $ Author_and_Institution */
/* B.V. Semenov (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 29-JUL-2013 (BVS) */
/* -& */
/* End of include file. */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* SC I NAIF spacecraft identification code. */
/* NPARTS O The number of spacecraft clock partitions. */
/* PSTART O Array of partition start times. */
/* PSTOP O Array of partition stop times. */
/* MXPART P Maximum number of partitions. */
/* $ Detailed_Input */
/* SC is the NAIF ID for the spacecraft whose clock partition */
/* information is being requested. */
/* $ Detailed_Output */
/* NPARTS is the number of spacecraft clock time partitions */
/* described in the kernel file for spacecraft SC. */
/* PSTART is an array containing NPARTS partition start times */
/* represented as double precision, encoded SCLK */
/* ("ticks"). The values contained in PSTART are whole */
/* numbers. */
/* PSTOP is an array containing NPARTS partition end times */
/* represented as double precision, encoded SCLK */
/* ("ticks"). The values contained in PSTOP are whole */
/* numbers. */
/* $ Parameters */
/* MXPART is the maximum number of partitions for any spacecraft */
/* clock. SCLK kernels contain start and stop times for */
/* each partition. See the INCLUDE file sclk.inc for this */
/* parameter's value. */
/* $ Exceptions */
/* 1) If the kernel variables containing the spacecraft clock */
/* partition start and stop times have not been loaded in the */
/* kernel pool, the error will be diagnosed by routines called */
/* by this routine. */
/* 2) If the number of start and stop times are different then */
/* the error SPICE(NUMPARTSUNEQUAL) is signaled. */
/* $ Files */
/* An SCLK kernel containing spacecraft clock partition start */
/* and stop times for the spacecraft clock indicated by SC must */
/* be loaded into the kernel pool. */
/* $ Particulars */
/* SCPART looks for two variables in the kernel pool for each */
/* spacecraft's partition information. If SC = -nn, then the names of */
/* the variables are */
/* 'SCLK_PARTITION_START_nn' and */
/* 'SCLK_PARTITION_END_nn'. */
/* The start and stop times returned are in units of "ticks". */
/* $ Examples */
/* 1) The following program fragment finds and prints out partition */
/* start and stop times in clock format for the Galileo mission. */
/* In this example, Galileo partition times are assumed to be */
/* in the kernel file SCLK.KER. */
/* CHARACTER*(30) START */
/* CHARACTER*(30) STOP */
/* CALL FURNSH ( 'SCLK.KER' ) */
/* SC = -77 */
/* CALL SCPART ( SC, NPARTS, PSTART, PSTOP ) */
/* DO I = 1, NPARTS */
/* CALL SCFMT ( SC, PSTART( I ), START ) */
/* CALL SCFMT ( SC, PSTOP ( I ), STOP ) */
/* WRITE (*,*) */
/* WRITE (*,*) 'Partition ', I, ':' */
/* WRITE (*,*) 'Start = ', START */
/* WRITE (*,*) 'Stop = ', STOP */
/* END DO */
/* $ Restrictions */
/* 1) This routine assumes that an SCLK kernel appropriate to the */
/* spacecraft identified by SC has been loaded into the kernel */
/* pool. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* J.M. Lynch (JPL) */
/* B.V. Semenov (JPL) */
/* R.E. Thurman (JPL) */
/* $ Version */
/* - SPICELIB Version 2.3.1, 19-MAR-2014 (NJB) */
/* Minor header comment updates were made. */
/* - SPICELIB Version 2.3.0, 09-SEP-2013 (BVS) */
/* Updated to keep track of the POOL counter and call ZZCVPOOL. */
/* - SPICELIB Version 2.2.0, 05-MAR-2009 (NJB) */
/* Bug fix: this routine now keeps track of whether its */
/* kernel pool look-up succeeded. If not, a kernel pool */
/* lookup is attempted on the next call to this routine. */
/* - SPICELIB Version 2.1.0, 05-FEB-2008 (NJB) */
/* The values of the parameter MXPART is now */
/* provided by the INCLUDE file sclk.inc. */
/* - SPICELIB Version 1.1.1, 22-AUG-2006 (EDW) */
/* Replaced references to LDPOOL with references */
/* to FURNSH. */
/* - SPICELIB Version 1.1.0, 22-MAR-1993 (JML) */
/* The routine now uses the kernel pool watch capability. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 03-SEP-1990 (NJB) (JML) (RET) */
/* -& */
/* $ Index_Entries */
/* spacecraft_clock partition information */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Saved variables */
/* Initial values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
chkin_("SCPART", (ftnlen)6);
/* On the first pass through the subroutine, or if the */
/* spacecraft code changes, set watches on the SCLK kernel */
/* variables for the current clock. */
if (first || *sc != oldsc) {
/* Make up a list of names of kernel variables that we'll use. */
s_copy(kvname, "SCLK_PARTITION_START", (ftnlen)60, (ftnlen)20);
s_copy(kvname + 60, "SCLK_PARTITION_END", (ftnlen)60, (ftnlen)18);
for (i__ = 1; i__ <= 2; ++i__) {
suffix_("_#", &c__0, kvname + ((i__1 = i__ - 1) < 2 && 0 <= i__1 ?
i__1 : s_rnge("kvname", i__1, "scpart_", (ftnlen)284)) *
60, (ftnlen)2, (ftnlen)60);
i__3 = -(*sc);
repmi_(kvname + ((i__1 = i__ - 1) < 2 && 0 <= i__1 ? i__1 :
s_rnge("kvname", i__1, "scpart_", (ftnlen)285)) * 60,
"#", &i__3, kvname + ((i__2 = i__ - 1) < 2 && 0 <= i__2 ?
i__2 : s_rnge("kvname", i__2, "scpart_", (ftnlen)285)) *
60, (ftnlen)60, (ftnlen)1, (ftnlen)60);
}
/* Set a watch on all of the kernel variables used. */
swpool_("SCPART", &c__2, kvname, (ftnlen)6, (ftnlen)60);
/* Keep track of the last spacecraft ID encountered. */
oldsc = *sc;
/* Initialize the local POOL counter to user value. */
zzctruin_(usrctr);
first = FALSE_;
}
/* If any of the kernel pool variables that this routine uses */
/* have been updated, or if the spacecraft ID changes, look up */
/* the new values from the kernel pool. */
zzcvpool_("SCPART", usrctr, &update, (ftnlen)6);
if (update || nodata) {
/* Read the values from the kernel pool. */
scld01_("SCLK_PARTITION_START", sc, &c__9999, &nprtsa, prtsa, (ftnlen)
20);
scld01_("SCLK_PARTITION_END", sc, &c__9999, &nprtso, prtso, (ftnlen)
18);
if (failed_()) {
nodata = TRUE_;
chkout_("SCPART", (ftnlen)6);
return 0;
}
/* Error checking. */
if (nprtsa != nprtso) {
nodata = TRUE_;
setmsg_("The number of partition start and stop times are unequa"
"l for spacecraft #. ", (ftnlen)78);
errint_("#", sc, (ftnlen)1);
sigerr_("SPICE(NUMPARTSUNEQUAL)", (ftnlen)22);
chkout_("SCPART", (ftnlen)6);
return 0;
}
/* At this point we have the data we sought. We need not */
/* perform another kernel pool look-up unless there's */
/* a kernel pool update or change in the SCLK ID. */
nodata = FALSE_;
/* Buffer the number of partitions and the partition start */
/* and stop times. */
lstprt = nprtsa;
/* The partition start and stop times must be whole numbers. */
i__1 = lstprt;
for (i__ = 1; i__ <= i__1; ++i__) {
prtsa[(i__2 = i__ - 1) < 9999 && 0 <= i__2 ? i__2 : s_rnge("prtsa"
, i__2, "scpart_", (ftnlen)360)] = d_nint(&prtsa[(i__3 =
i__ - 1) < 9999 && 0 <= i__3 ? i__3 : s_rnge("prtsa",
i__3, "scpart_", (ftnlen)360)]);
prtso[(i__2 = i__ - 1) < 9999 && 0 <= i__2 ? i__2 : s_rnge("prtso"
, i__2, "scpart_", (ftnlen)361)] = d_nint(&prtso[(i__3 =
i__ - 1) < 9999 && 0 <= i__3 ? i__3 : s_rnge("prtso",
i__3, "scpart_", (ftnlen)361)]);
}
}
/* Copy the values in local buffers to the output arguments. */
*nparts = lstprt;
i__1 = *nparts;
for (i__ = 1; i__ <= i__1; ++i__) {
pstart[i__ - 1] = prtsa[(i__2 = i__ - 1) < 9999 && 0 <= i__2 ? i__2 :
s_rnge("prtsa", i__2, "scpart_", (ftnlen)372)];
pstop[i__ - 1] = prtso[(i__2 = i__ - 1) < 9999 && 0 <= i__2 ? i__2 :
s_rnge("prtso", i__2, "scpart_", (ftnlen)373)];
}
chkout_("SCPART", (ftnlen)6);
return 0;
} /* scpart_ */
/* $Procedure ZZEKJSQZ ( Private: EK, join row set squeeze ) */
/* Subroutine */ int zzekjsqz_(integer *jrsbas)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
integer ntab, size;
extern /* Subroutine */ int zzeksupd_(integer *, integer *, integer *);
integer i__, j, delta, rbase, nrloc, ptarg, ntloc, rtarg, vtarg;
extern logical failed_(void);
integer rc, nr, segvec[10], pcpair[2], ptbase, setbas, cntloc, nsvdel,
nrvdel, svbase, nsvloc, ptrloc, rowvec[11], sizloc, newnsv,
rvsize, svsize, nsv;
extern /* Subroutine */ int zzeksrd_(integer *, integer *, integer *);
/* $ 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. */
/* Compress a join row set by eliminating segment vectors for */
/* which there are no corresponding row vectors. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* EK */
/* $ Keywords */
/* EK */
/* PRIVATE */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Join Row Set Parameters */
/* ekjrs.inc Version 1 07-FEB-1995 (NJB) */
/* Maximum number of join row sets in a join row set union: */
/* The layout of a join row set in the EK scratch area is shown */
/* below: */
/* +--------------------------------------------+ */
/* | join row set size | 1 element */
/* +--------------------------------------------+ */
/* | number of row vectors in join row set | 1 element */
/* +--------------------------------------------+ */
/* | table count (TC) | 1 element */
/* +--------------------------------------------+ */
/* | segment vector count (SVC) | 1 element */
/* +--------------------------------------------+ */
/* | segment vector 1 | TC elements */
/* +--------------------------------------------+ */
/* . */
/* . */
/* . */
/* +--------------------------------------------+ */
/* | segment vector SVC | TC elements */
/* +--------------------------------------------+ */
/* | segment vector 1 row set base address | 1 element */
/* +--------------------------------------------+ */
/* | segment vector 1 row count (RC_1) | 1 element */
/* +--------------------------------------------+ */
/* . */
/* . */
/* . */
/* +--------------------------------------------+ */
/* | segment vector SVC row set base address | 1 element */
/* +--------------------------------------------+ */
/* | segment vector SVC row count (RC_SVC) | 1 element */
/* +--------------------------------------------+ */
/* | Augmented row vectors for segment vector 1 | (TC+1)*RC_1 */
/* +--------------------------------------------+ elements */
/* . */
/* . */
/* . */
/* +--------------------------------------------+ */
/* |Augmented row vectors for segment vector SVC| (TC+1)*RC_SVC1 */
/* +--------------------------------------------+ elements */
/* The following parameters indicate positions of elements in the */
/* join row set structure: */
/* Base-relative index of join row set size */
/* Index of row vector count */
/* Index of table count */
/* Index of segment vector count */
/* Base address of first segment vector */
/* End Include Section: EK Join Row Set 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 Query Limit Parameters */
/* ekqlimit.inc Version 3 16-NOV-1995 (NJB) */
/* Parameter MAXCON increased to 1000. */
/* ekqlimit.inc Version 2 01-AUG-1995 (NJB) */
/* Updated to support SELECT clause. */
/* ekqlimit.inc Version 1 07-FEB-1995 (NJB) */
/* These limits apply to character string queries input to the */
/* EK scanner. This limits are part of the EK system's user */
/* interface: the values should be advertised in the EK required */
/* reading document. */
/* Maximum length of an input query: MAXQRY. This value is */
/* currently set to twenty-five 80-character lines. */
/* Maximum number of columns that may be listed in the */
/* `order-by clause' of a query: MAXSEL. MAXSEL = 50. */
/* Maximum number of tables that may be listed in the `FROM */
/* clause' of a query: MAXTAB. */
/* Maximum number of relational expressions that may be listed */
/* in the `constraint clause' of a query: MAXCON. */
/* This limit applies to a query when it is represented in */
/* `normalized form': that is, the constraints have been */
/* expressed as a disjunction of conjunctions of relational */
/* expressions. The number of relational expressions in a query */
/* that has been expanded in this fashion may be greater than */
/* the number of relations in the query as orginally written. */
/* For example, the expression */
/* ( ( A LT 1 ) OR ( B GT 2 ) ) */
/* AND */
/* ( ( C NE 3 ) OR ( D EQ 4 ) ) */
/* which contains 4 relational expressions, expands to the */
/* equivalent normalized constraint */
/* ( ( A LT 1 ) AND ( C NE 3 ) ) */
/* OR */
/* ( ( A LT 1 ) AND ( D EQ 4 ) ) */
/* OR */
/* ( ( B GT 2 ) AND ( C NE 3 ) ) */
/* OR */
/* ( ( B GT 2 ) AND ( D EQ 4 ) ) */
/* which contains eight relational expressions. */
/* MXJOIN is the maximum number of tables that can be joined. */
/* MXJCON is the maximum number of join constraints allowed. */
/* Maximum number of order-by columns that may be used in the */
/* `order-by clause' of a query: MAXORD. MAXORD = 10. */
/* Maximum number of tokens in a query: 500. Tokens are reserved */
/* words, column names, parentheses, and values. Literal strings */
/* and time values count as single tokens. */
/* Maximum number of numeric tokens in a query: */
/* Maximum total length of character tokens in a query: */
/* Maximum length of literal string values allowed in queries: */
/* MAXSTR. */
/* End Include Section: EK Query Limit Parameters */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* JRSBAS I Scratch area base address of join row set. */
/* $ Detailed_Input */
/* JRSBAS is the base address, in the scratch area, of a */
/* join row set to be compressed. */
/* $ Detailed_Output */
/* None. See $Particulars for a description of the effect of this */
/* routine. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If JRSBAS is not the base address of a structurally valid */
/* join row set, the results of this routine will be */
/* unpredictable. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine operates by side effects: it modifies the join row */
/* set designated by the input argument JRSBAS. Every row vector */
/* marked for deletion is removed. Every empty segment vector is */
/* removed, along with the row count and row vector base for that */
/* segment vector. The join row set is compressed to remove all */
/* gaps. All counts are updated to reflect the updated join row */
/* set. */
/* The purpose of the compression performed by this routine is to */
/* save work during joins by reducing the size of the cartesian */
/* products of sets of segment vectors. Also, special cases */
/* involving null segment vectors can be avoided by this clean-up */
/* mechanism. Finally, it may be possible to save space in the EK */
/* scratch area freed by the compression. */
/* $ Examples */
/* See EKSRCH. */
/* $ Restrictions */
/* 1) Relies on the EK scratch area. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.0, 07-AUG-2006 (NJB) */
/* Bug fix: added intialization of variable NRVDEL to support */
/* operation under the Macintosh Intel Fortran */
/* compiler. Note that this bug did not affect */
/* operation of this routine on other platforms. */
/* - SPICELIB Version 1.0.0, 10-OCT-1995 (NJB) */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.1.0, 07-AUG-2006 (NJB) */
/* Bug fix: added intialization of variable NRVDEL to support */
/* operation under the Macintosh Intel Fortran */
/* compiler. Note that this bug did not affect */
/* operation of this routine on other platforms. The */
/* statement referencing the uninitialized variable */
/* was: */
/* IF ( ( RC .EQ. 0 ) .OR. ( NRVDEL .EQ. RC ) ) THEN */
/* In the previous version of the code, NRVDEL is uninitialized */
/* when NRVDEL is 0. NRVDEL *is* initialized when RC is */
/* non-zero, so the logical value of the IF expression is not */
/* affected by the lack of proper intialization. */
/* However, the Intel Fortran compiler for the Mac flags a runtime */
/* error when the above code is exercised. So NRVDEL is now */
/* initialized prior to the above IF statement. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Use discovery check-in. */
/* Look up the counts that are of interest: */
/* -- The table count */
/* -- The segment vector count */
/* -- The join row set size */
/* Save the address of each count. */
sizloc = *jrsbas + 1;
nsvloc = *jrsbas + 4;
ntloc = *jrsbas + 3;
zzeksrd_(&sizloc, &sizloc, &size);
zzeksrd_(&ntloc, &ntloc, &ntab);
zzeksrd_(&nsvloc, &nsvloc, &nsv);
if (failed_()) {
return 0;
}
/* Set the sizes of segment and row vectors. */
svsize = ntab;
rvsize = ntab + 1;
/* For each segment vector, obtain the row count. Clean up after */
/* null segment vectors: compress out the space allocated for their */
/* row vector pointers. Keep track of the number of deletions. */
nsvdel = 0;
nrvdel = 0;
vtarg = *jrsbas + 4;
i__1 = nsv;
for (i__ = 1; i__ <= i__1; ++i__) {
/* The location of the row count is CNTLOC. The row vector base */
/* pointer precedes the row count. */
cntloc = *jrsbas + 4 + nsv * svsize + (i__ - 1 << 1) + 2;
ptrloc = cntloc - 1;
zzeksrd_(&cntloc, &cntloc, &rc);
if (rc > 0) {
/* The row vector set for this segment vector is non-empty. */
/* scan the rows, looking for those marked for deletion, and */
/* update the row count to reflect the number of rows that */
/* we're going to keep. */
zzeksrd_(&ptrloc, &ptrloc, &setbas);
nrvdel = 0;
i__2 = rc;
for (j = 1; j <= i__2; ++j) {
rbase = *jrsbas + setbas + (j - 1) * rvsize;
i__3 = rbase + 1;
i__4 = rbase + 1;
zzeksrd_(&i__3, &i__4, rowvec);
if (rowvec[0] == 0) {
++nrvdel;
}
}
}
/* Compute the base address of the current segment vector. */
svbase = *jrsbas + 4 + (i__ - 1) * svsize;
if (rc == 0 || nrvdel == rc) {
/* We're going to delete the current segment vector. We'll */
/* just skip over it without advancing our target pointers. */
++nsvdel;
} else if (nsvdel > 0) {
/* We need to shift the current segment vector to its */
/* destination. */
i__2 = svbase + 1;
i__3 = svbase + svsize;
zzeksrd_(&i__2, &i__3, segvec);
i__2 = vtarg + 1;
i__3 = vtarg + svsize;
zzeksupd_(&i__2, &i__3, segvec);
vtarg += svsize;
} else {
/* No segment vectors have been deleted yet. We still must */
/* update the target in case we shift vectors later on in this */
/* loop. */
vtarg += svsize;
}
}
/* At this point, we've compressed out the null segment vectors. */
/* The next step is to compress out the row vector counts and row */
/* vector pointers that corresponded to those segment vectors. We */
/* also want to remove the gap between the segment vectors and the */
/* row vector pointer/count pairs. */
/* We need to do this only if we deleted some segment vectors. */
if (nsvdel > 0) {
newnsv = nsv - nsvdel;
ptarg = *jrsbas + 4 + newnsv * svsize;
i__1 = nsv;
for (i__ = 1; i__ <= i__1; ++i__) {
/* The row count is RC. */
svsize = ntab;
cntloc = *jrsbas + 4 + nsv * svsize + (i__ - 1 << 1) + 2;
zzeksrd_(&cntloc, &cntloc, &rc);
ptbase = cntloc - 2;
if (rc > 0) {
/* Shift the current row vector pointer and row vector */
/* count. */
i__2 = ptbase + 1;
i__3 = ptbase + 2;
zzeksrd_(&i__2, &i__3, pcpair);
i__2 = ptarg + 1;
i__3 = ptarg + 2;
zzeksupd_(&i__2, &i__3, pcpair);
ptarg += 2;
}
}
} else {
newnsv = nsv;
}
/* Update the segment vector count. */
zzeksupd_(&nsvloc, &nsvloc, &newnsv);
/* Remove any gaps that may exist between any of the row vectors, */
/* or between the end of the segment vector's row vector counts */
/* and base addresses and the first row vector. */
/* The initial target location is the first element following the */
/* last segment vector's row vector count. RTARG is used as a base */
/* address; it precedes this location by 1. */
/* If we deleted any segment vectors, the segment vector pointers */
/* embedded in the row vectors must change. Make these updates */
/* if necessary. */
rtarg = *jrsbas + 4 + newnsv * (svsize + 2);
i__1 = newnsv;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Find the row count and row pointer for the current segment */
/* vector. */
cntloc = *jrsbas + 4 + newnsv * svsize + (i__ - 1 << 1) + 2;
zzeksrd_(&cntloc, &cntloc, &rc);
ptrloc = cntloc - 1;
/* Get the row vector set base pointer. After capturing the */
/* current value, we'll update this pointer to account for */
/* the shifting of row vectors. */
zzeksrd_(&ptrloc, &ptrloc, &setbas);
rbase = *jrsbas + setbas;
delta = rtarg - rbase;
i__2 = setbas + delta;
zzeksupd_(&ptrloc, &ptrloc, &i__2);
/* Shift the row vectors for the current segment vector, */
/* leaving behind the row vectors marked for deletion. */
nrvdel = 0;
i__2 = rc;
for (j = 1; j <= i__2; ++j) {
i__3 = rbase + 1;
i__4 = rbase + rvsize;
zzeksrd_(&i__3, &i__4, rowvec);
if (rowvec[0] == 0) {
/* This row vector is to be deleted; don't copy it. */
rbase += rvsize;
++nrvdel;
} else {
/* The segment vector pointer is base-relative. */
rowvec[(i__3 = rvsize - 1) < 11 && 0 <= i__3 ? i__3 : s_rnge(
"rowvec", i__3, "zzekjsqz_", (ftnlen)415)] = (i__ - 1)
* svsize + 4;
i__3 = rtarg + 1;
i__4 = rtarg + rvsize;
zzeksupd_(&i__3, &i__4, rowvec);
rbase += rvsize;
rtarg += rvsize;
}
}
/* Update the row count for the current segment vector, if */
/* necessary. Note that no segment vector will become empty */
/* as a result of the row vector deletions we've done; we */
/* already eliminated any segment vectors for which that */
/* could happen, before we entered this loop. */
if (nrvdel > 0) {
i__2 = rc - nrvdel;
zzeksupd_(&cntloc, &cntloc, &i__2);
}
}
/* Update the total row count and size of the join row set. */
nr = 0;
i__1 = newnsv;
for (i__ = 1; i__ <= i__1; ++i__) {
cntloc = *jrsbas + 4 + newnsv * svsize + (i__ - 1 << 1) + 2;
zzeksrd_(&cntloc, &cntloc, &rc);
nr += rc;
}
nrloc = *jrsbas + 2;
size = newnsv * (svsize + 2) + 4 + nr * rvsize;
zzeksupd_(&nrloc, &nrloc, &nr);
zzeksupd_(&sizloc, &sizloc, &size);
return 0;
} /* zzekjsqz_ */
/* $Procedure ZZEKUE04 ( EK, update column entry, class 4 ) */
/* Subroutine */ int zzekue04_(integer *handle, integer *segdsc, integer *
coldsc, integer *recptr, integer *nvals, integer *ivals, logical *
isnull)
{
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern logical failed_(void), return_(void);
extern /* Subroutine */ int chkout_(char *, ftnlen), zzekad04_(integer *,
integer *, integer *, integer *, integer *, integer *, logical *),
zzekde04_(integer *, integer *, integer *, integer *);
/* $ Abstract */
/* Update a specified class 4 column entry in an EK record. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* EK */
/* $ Keywords */
/* EK */
/* PRIVATE */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Column 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 Data Types */
/* ektype.inc Version 1 27-DEC-1994 (NJB) */
/* Within the EK system, data types of EK column contents are */
/* represented by integer codes. The codes and their meanings */
/* are listed below. */
/* Integer codes are also used within the DAS system to indicate */
/* data types; the EK system makes no assumptions about compatibility */
/* between the codes used here and those used in the DAS system. */
/* Character type: */
/* Double precision type: */
/* Integer type: */
/* `Time' type: */
/* Within the EK system, time values are represented as ephemeris */
/* seconds past J2000 (TDB), and double precision numbers are used */
/* to store these values. However, since time values require special */
/* treatment both on input and output, and since the `TIME' column */
/* has a special role in the EK specification and code, time values */
/* are identified as a type distinct from double precision numbers. */
/* End Include Section: EK Data Types */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I File handle. */
/* SEGDSC I Segment descriptor. */
/* COLDSC I Column descriptor. */
/* RECPTR I Record pointer. */
/* NVALS I Number of values. */
/* IVALS I Integer values. */
/* ISNULL I Null flag. */
/* $ Detailed_Input */
/* HANDLE is a file handle of an EK open for write access. */
/* SEGDSC is the descriptor of the segment containing */
/* the specified column entry. */
/* COLDSC is the descriptor of the column containing */
/* the specified column entry. */
/* RECPTR is a pointer to the record containing the column */
/* entry to update. */
/* NVALS is the number of values in the replacement */
/* column entry. */
/* IVALS is an array of integer values with which to update */
/* the specified column entry. */
/* ISNULL is a logical flag indicating whether the value */
/* of the specified column entry is to be set to NULL. */
/* If so, the input IVALS is ignored. */
/* $ Detailed_Output */
/* None. See the $Particulars section for a description of the */
/* effect of this routine. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If HANDLE is invalid, the error will be diagnosed by routines */
/* called by this routine. The file will not be modified. */
/* 2) If an I/O error occurs while reading or writing the indicated */
/* file, the error will be diagnosed by routines called by this */
/* routine. The file may be corrupted. */
/* $ Files */
/* See the EK Required Reading for a discussion of the EK file */
/* format. */
/* $ Particulars */
/* This routine operates by side effects: it updates a column entry */
/* in an EK segment. The status of the record containing the entry */
/* is set to `updated'. If the column containing the entry is */
/* indexed, the corresponding index is updated. */
/* The changes made by this routine to the target EK file become */
/* permanent when the file is closed. Failure to close the file */
/* properly will leave it in an indeterminate state. */
/* $ Examples */
/* See EKUCEI. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - Beta Version 1.0.0, 27-SEP-1995 (NJB) */
/* -& */
/* SPICELIB functions */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZEKUE04", (ftnlen)8);
}
/* Get rid of the old column entry first. */
zzekde04_(handle, segdsc, coldsc, recptr);
if (failed_()) {
chkout_("ZZEKUE04", (ftnlen)8);
return 0;
}
/* We've reduced the problem to a solved one: that of adding */
/* a column entry. */
zzekad04_(handle, segdsc, coldsc, recptr, nvals, ivals, isnull);
chkout_("ZZEKUE04", (ftnlen)8);
return 0;
} /* zzekue04_ */
/* $Procedure ZZLDKER ( Load a kernel ) */
/* Subroutine */ int zzldker_(char *file, char *nofile, char *filtyp, integer
*handle, ftnlen file_len, ftnlen nofile_len, ftnlen filtyp_len)
{
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char arch[32];
extern /* Subroutine */ int zzbodkik_(void), eklef_(char *, integer *,
ftnlen), chkin_(char *, ftnlen), cklpf_(char *, integer *, ftnlen)
, errch_(char *, char *, ftnlen, ftnlen);
char versn[32];
extern logical failed_(void);
extern /* Subroutine */ int getfat_(char *, char *, char *, ftnlen,
ftnlen, ftnlen), pcklof_(char *, integer *, ftnlen), spklef_(char
*, integer *, ftnlen), ldpool_(char *, ftnlen), sigerr_(char *,
ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen);
extern logical exists_(char *, ftnlen), return_(void);
char mytype[32];
extern /* Subroutine */ int tkvrsn_(char *, char *, ftnlen, ftnlen);
/* $ Abstract */
/* SPICE Private routine intended solely for the support of SPICE */
/* routines. Users should not call this routine directly due */
/* to the volatile nature of this routine. */
/* Determine the architecture and type of a file and load */
/* the file into the appropriate SPICE subsystem */
/* $ 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 */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* FILE I The name of a file to be loaded. */
/* NOFILE I A message to issue if FILE cannot be located */
/* FILTYP O The type of kernel. */
/* HANDLE O The handle associated with the loaded kernel. */
/* $ Detailed_Input */
/* FILE is the name of a file that is anticipated to */
/* be a SPICE kernel. */
/* NOFILE is a template for the message that should be created */
/* with SETMSG if a problem is identified with FILE. The */
/* message should have the form: "[text] '#' [text] #" The */
/* first octothorpe ('#') will be replaced by the name of */
/* the file. The second by a descriptive message. */
/* $ Detailed_Output */
/* FILTYP is the type of the kernel as determined by the */
/* SPICE file record of the file or by various */
/* heuristics. Possible return values are: */
/* TEXT --- if FILE is interpreted as a text kernel */
/* suitable for loading via LDPOOL. No */
/* attempt is made to distinguish between */
/* different types of text kernels. */
/* SPK | */
/* CK | */
/* PCK |--- if FILE is a binary PCK file. */
/* EK | */
/* If a failure occurs during the attempt to load */
/* the FILE, FILTYP will be returned as the blank string. */
/* HANDLE is the DAF or DAS handle that is associated with the */
/* file. If the FILTYP of the file is 'TEXT', HANDLE */
/* will be set to zero. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the specified file does not exist, the error */
/* SPICE(NOSUCHFILE) will be signaled. */
/* 2) If the specified file can be identified as unloadable */
/* because it is a transfer format file, the error */
/* SPICE(TRANSFERFILE) will be signaled. */
/* 3) If the specified file can be identified as unloadable */
/* because it is an obsolete text E-kernel, the error */
/* SPICE(TYPE1TEXTEK) will be signaled. */
/* 4) If the specified file can be recognized as a DAF/DAS file */
/* but is not one of the currently recognized binary kernel */
/* types, the error SPICE(UNKNOWNKERNELTYPE) will be signaled. */
/* 5) FILTYP is not sufficiently long to hold the full text of the */
/* type of the kernel, the value returned will be the truncation */
/* of the value. As currently implemented this truncated type is */
/* sufficient to distinguish between the various types of */
/* kernels. */
/* 6) If the FILE cannot be loaded, HANDLE will be set to zero. */
/* 7) All other problems associated with the loading of FILE */
/* are diagnosed by the routines called by this routine. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine is intended as a supporting routine for the */
/* SPICE routine FURNSH. It handles the task of loading */
/* an arbitrary kernel without the caller having to specify */
/* the type of the kernel. */
/* $ Examples */
/* None. (After all it's a private routine) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* E.D. Wright (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 1.17.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 1.16.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 1.15.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 1.14.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.13.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 1.12.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 1.11.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.10.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 1.9.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.8.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 1.7.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 1.6.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - 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, 03-OCT-2005 (EDW) */
/* Source file zzldker.f converted to master file. */
/* Modification occurred to prevent f2c's versions */
/* from making the zzascii test. CSPICE now */
/* includes coed to allow reading of non native text files. */
/* - SPICELIB Version 1.2.0, 17-FEB-2004 (EDW) (BVS) */
/* Added the ZZASCII terminator test for text files. Used a */
/* working line length of 132 characters (maximum text kernel */
/* line size.) */
/* - SPICELIB Version 1.1.0, 24-JUN-2002 (EDW) */
/* Added a call to ZZBODKIK to run the */
/* NAIF_BODY_NAME/CODE read/check routine */
/* whenever a text kernel loads. */
/* - SPICELIB Version 1.0.0, 04-JUN-1999 (WLT) */
/* -& */
/* SPICELIB Functions */
/* Local Variables. */
if (return_()) {
return 0;
}
chkin_("ZZLDKER", (ftnlen)7);
if (! exists_(file, file_len)) {
setmsg_(nofile, nofile_len);
errch_("#", file, (ftnlen)1, file_len);
errch_("#", "could not be located.", (ftnlen)1, (ftnlen)21);
sigerr_("SPICE(NOSUCHFILE)", (ftnlen)17);
chkout_("ZZLDKER", (ftnlen)7);
return 0;
}
getfat_(file, arch, mytype, file_len, (ftnlen)32, (ftnlen)32);
/* Possible values for the architecture are: */
/* DAF -- The file is based on the DAF architecture. */
/* DAS -- The file is based on the DAS architecture. */
/* XFR -- The file is in a SPICE transfer file format. */
/* DEC -- The file is an old SPICE decimal text file. */
/* ASC -- An ASCII text file. */
/* KPL -- Kernel Pool File (i.e., a text kernel) */
/* TXT -- An ASCII text file. */
/* TE1 -- Text E-Kernel type 1. */
/* ? -- The architecture could not be determined. */
/* Some of these are obviously losers. */
if (s_cmp(arch, "XFR", (ftnlen)32, (ftnlen)3) == 0 || s_cmp(arch, "DEC", (
ftnlen)32, (ftnlen)3) == 0) {
setmsg_(nofile, nofile_len);
errch_("#", file, (ftnlen)1, file_len);
errch_("#", "is a transfer format file. Transfer format files cannot"
" be loaded. ", (ftnlen)1, (ftnlen)67);
sigerr_("SPICE(TRANSFERFILE)", (ftnlen)19);
chkout_("ZZLDKER", (ftnlen)7);
return 0;
} else if (s_cmp(arch, "TE1", (ftnlen)32, (ftnlen)3) == 0) {
setmsg_(nofile, nofile_len);
errch_("#", file, (ftnlen)1, file_len);
errch_("#", "is a type 1 text E-kernel. These files are obsolete an"
"d cannot be loaded. ", (ftnlen)1, (ftnlen)75);
sigerr_("SPICE(TYPE1TEXTEK)", (ftnlen)18);
chkout_("ZZLDKER", (ftnlen)7);
return 0;
}
/* That takes care of the obvious errors. Try loading the */
/* kernel. */
*handle = 0;
s_copy(filtyp, " ", filtyp_len, (ftnlen)1);
if (s_cmp(arch, "DAF", (ftnlen)32, (ftnlen)3) == 0) {
if (s_cmp(mytype, "SPK", (ftnlen)32, (ftnlen)3) == 0) {
spklef_(file, handle, file_len);
} else if (s_cmp(mytype, "CK", (ftnlen)32, (ftnlen)2) == 0) {
cklpf_(file, handle, file_len);
} else if (s_cmp(mytype, "PCK", (ftnlen)32, (ftnlen)3) == 0) {
pcklof_(file, handle, file_len);
} else {
tkvrsn_("TOOLKIT", versn, (ftnlen)7, (ftnlen)32);
setmsg_(nofile, nofile_len);
errch_("#", file, (ftnlen)1, file_len);
errch_("#", "is a \"#\" DAF file. This kind of binary file is no"
"t supported in version # of the SPICE toolkit. Check wit"
"h NAIF to see if your toolkit version is up to date. ", (
ftnlen)1, (ftnlen)158);
errch_("#", mytype, (ftnlen)1, (ftnlen)32);
errch_("#", versn, (ftnlen)1, (ftnlen)32);
sigerr_("SPICE(UNKNOWNKERNELTYPE)", (ftnlen)24);
chkout_("ZZLDKER", (ftnlen)7);
return 0;
}
s_copy(filtyp, mytype, filtyp_len, (ftnlen)32);
} else if (s_cmp(arch, "DAS", (ftnlen)32, (ftnlen)3) == 0) {
if (s_cmp(mytype, "EK", (ftnlen)32, (ftnlen)2) == 0) {
eklef_(file, handle, file_len);
} else {
tkvrsn_("TOOLKIT", versn, (ftnlen)7, (ftnlen)32);
setmsg_(nofile, nofile_len);
errch_("#", file, (ftnlen)1, file_len);
errch_("#", "is a \"#\" DAS file. This kind of binary file is n"
"ot supported in version # of the SPICE toolkit. Check wi"
"th NAIF to see if your toolkit version is up to date. ", (
ftnlen)1, (ftnlen)159);
errch_("#", mytype, (ftnlen)1, (ftnlen)32);
errch_("#", versn, (ftnlen)1, (ftnlen)32);
sigerr_("SPICE(UNKNOWNKERNELTYPE)", (ftnlen)24);
chkout_("ZZLDKER", (ftnlen)7);
return 0;
}
s_copy(filtyp, mytype, filtyp_len, (ftnlen)32);
} else {
/* Load the file using the text file loader. */
ldpool_(file, file_len);
if (! failed_()) {
s_copy(filtyp, "TEXT", filtyp_len, (ftnlen)4);
/* Cause the kernel pool mechanism to perform */
/* the standard error checks on the pool */
/* data. */
zzbodkik_();
}
}
chkout_("ZZLDKER", (ftnlen)7);
return 0;
} /* zzldker_ */
/* $Procedure ZZSPKGO1 ( S/P Kernel, geometric state ) */
/* Subroutine */ int zzspkgo1_(integer *targ, doublereal *et, char *ref,
integer *obs, doublereal *state, 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 zzfrmch1_(integer *, integer *, doublereal *,
doublereal *);
integer cobs, legs;
doublereal sobs[6];
extern /* Subroutine */ int mxvg_(doublereal *, doublereal *, integer *,
integer *, doublereal *), zznamfrm_(integer *, char *, integer *,
char *, integer *, ftnlen, ftnlen), zzctruin_(integer *);
integer i__;
extern /* Subroutine */ int vaddg_(doublereal *, doublereal *, integer *,
doublereal *), 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];
extern /* Subroutine */ int vsubg_(doublereal *, doublereal *, integer *,
doublereal *);
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 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);
extern /* Subroutine */ int spkpvn_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
doublereal stxfrm[36] /* was [6][6] */;
extern /* Subroutine */ int intstr_(integer *, char *, ftnlen);
integer nct;
doublereal rot[9] /* was [3][3] */;
extern /* Subroutine */ int mxv_(doublereal *, doublereal *, doublereal *)
;
char tstring[80];
/* $ 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. */
/* Compute the geometric state (position and velocity) 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. */
/* STATE O State 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 state */
/* 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 ZZFRMCH1. */
/* OBS is the standard NAIF ID code for an observing body. */
/* $ Detailed_Output */
/* STATE contains the geometric position and velocity of the */
/* target body, relative to the observing body, at epoch */
/* ET. STATE has six elements: the first three contain */
/* the target's position; the last three contain the */
/* target's velocity. These vectors are transformed into */
/* the specified reference frame. Units are always km */
/* and km/sec. */
/* LT is the one-way light time in seconds 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 states, the error SPICE(SPKINSUFFDATA) is */
/* signaled. */
/* $ Files */
/* See: $Restrictions. */
/* $ Particulars */
/* ZZSPKGO1 computes the geometric state, T(t), of the target */
/* body and the geometric state, O(t), of the observing body */
/* relative to the first common center of motion. Subtracting */
/* O(t) from T(t) gives the geometric state 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 state of -94 relative to 4 and T(t) is the */
/* state 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 state of 399 relative */
/* to 0 and T(t) would be the state of 299 relative to 0. */
/* Ephemeris data from more than one segment may be required */
/* to determine the states of the target body and observer */
/* relative to a common center. ZZSPKGO1 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). */
/* ZZSPKGO1 is similar to SPKEZ but returns geometric states */
/* only, with no option to make planetary (light-time) nor */
/* stellar aberration corrections. The geometric states */
/* returned by SPKEZ and ZZSPKGO1 are the same. */
/* $ Examples */
/* The following code example computes the geometric */
/* state 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 LT */
/* DOUBLE PRECISION STATE ( 6 ) */
/* 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 state, 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 ZZSPKGO1 ( MOON, ET, 'J2000', EARTH, STATE, LT ) */
/* CALL ET2UTC ( ET, 'C', 0, UTC ) */
/* WRITE (*,*) UTC, VNORM ( STATE ) */
/* END DO */
/* $ Restrictions */
/* 1) SPICE Private routine. */
/* 2) The ephemeris files to be used by ZZSPKGO1 must be loaded */
/* by SPKLEF before ZZSPKGO1 is called. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* J.E. McLean (JPL) */
/* B.V. Semenov (JPL) */
/* W.L. Taber (JPL) */
/* W.D. Wright (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. */
/* Fixed description of STATE in Detailed Output. Replaced */
/* SPKLEF with FURNSH and fixed errors in Examples. */
/* - SPICELIB Version 1.1.0, 06-SEP-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in VADDG calls. */
/* - SPICELIB Version 1.0.0, 05-JAN-2005 (NJB) */
/* Based on SPICELIB Version 2.3.0, 05-JAN-2005 (NJB) */
/* -& */
/* $ Index_Entries */
/* geometric state of one body relative to another */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.1.0, 06-SEP-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in VADDG 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 state 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 state 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 state of TARG relative to C and the state of OBS relative */
/* to C, then subtract the two states. */
/* 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_("ZZSPKGO1", (ftnlen)8);
}
/* 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__6, state);
chkout_("ZZSPKGO1", (ftnlen)8);
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 state of the target body relative */
/* to CTARG(I). The id-code of the frame of this state is */
/* stored in TFRAME(I). */
/* COBS and SOBS will contain the centers and states of the */
/* observing body. (They are single elements instead of arrays */
/* because we only need the current center and state 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 state 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 state */
/* 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 states 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 state, */
/* 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 state of the target */
/* relative to the observer by subtracting the state of */
/* the observing body relative to the common node from */
/* the state 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 ZZSPKGO1; 2. an uninitialized variable. ", (
ftnlen)215);
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_("ZZSPKGO1", (ftnlen)8);
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 state of TARG relative */
/* to itself. */
i__ = 1;
ctarg[(i__1 = i__ - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge("ctarg", i__1,
"zzspkgo1_", (ftnlen)615)] = *targ;
found = TRUE_;
cleard_(&c__6, &starg[(i__1 = i__ * 6 - 6) < 120 && 0 <= i__1 ? i__1 :
s_rnge("starg", i__1, "zzspkgo1_", (ftnlen)618)]);
while(found && i__ < 20 && ctarg[(i__1 = i__ - 1) < 20 && 0 <= i__1 ?
i__1 : s_rnge("ctarg", i__1, "zzspkgo1_", (ftnlen)620)] != *obs &&
ctarg[(i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 : s_rnge("ctarg",
i__2, "zzspkgo1_", (ftnlen)620)] != 0) {
/* Find a file and segment that has state */
/* data for CTARG(I). */
spksfs_(&ctarg[(i__1 = i__ - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge(
"ctarg", i__1, "zzspkgo1_", (ftnlen)629)], et, &handle, descr,
ident, &found, (ftnlen)40);
if (found) {
/* Get the state of CTARG(I) relative to some */
/* center of motion. This new center goes in */
/* CTARG(I+1) and the state is called STEMP. */
++i__;
spkpvn_(&handle, descr, et, &tframe[(i__1 = i__ - 1) < 20 && 0 <=
i__1 ? i__1 : s_rnge("tframe", i__1, "zzspkgo1_", (ftnlen)
639)], &starg[(i__2 = i__ * 6 - 6) < 120 && 0 <= i__2 ?
i__2 : s_rnge("starg", i__2, "zzspkgo1_", (ftnlen)639)], &
ctarg[(i__3 = i__ - 1) < 20 && 0 <= i__3 ? i__3 : s_rnge(
"ctarg", i__3, "zzspkgo1_", (ftnlen)639)]);
/* Here's what we have. STARG is the state 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_("ZZSPKGO1", (ftnlen)8);
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 states 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 state */
/* data for CTARG(CHLEN). */
spksfs_(&ctarg[19], et, &handle, descr, ident, &found, (ftnlen)40)
;
if (found) {
/* Get the state of CTARG(CHLEN) relative to */
/* some center of motion. The new center */
/* overwrites the old. The state is called */
/* STEMP. */
spkpvn_(&handle, descr, et, &tmpfrm, stemp, &ctarg[19]);
/* Add STEMP to the state of TARG relative to */
/* the old center to get the state of TARG */
/* relative to the new center. Overwrite */
/* the last element of STARG. */
if (tframe[19] == tmpfrm) {
moved_(&starg[114], &c__6, vtemp);
} else if (tmpfrm > 0 && tmpfrm <= 21 && tframe[19] > 0 &&
tframe[19] <= 21) {
irfrot_(&tframe[19], &tmpfrm, rot);
mxv_(rot, &starg[114], vtemp);
mxv_(rot, &starg[117], &vtemp[3]);
} else {
zzfrmch1_(&tframe[19], &tmpfrm, et, stxfrm);
if (failed_()) {
chkout_("ZZSPKGO1", (ftnlen)8);
return 0;
}
mxvg_(stxfrm, &starg[114], &c__6, &c__6, vtemp);
}
vaddg_(vtemp, stemp, &c__6, &starg[114]);
tframe[19] = tmpfrm;
/* If one of the routines above failed during */
/* execution, we just give up and check out. */
if (failed_()) {
chkout_("ZZSPKGO1", (ftnlen)8);
return 0;
}
}
}
}
nct = i__;
/* NCT is the number of elements in CTARG, */
/* the chain length. We have in hand the following information */
/* STARG(1...6,K) state of body */
/* CTARG(K-1) relative to body CTARG(K) in the frame */
/* TFRAME(K) */
/* For K = 2,..., NCT. */
/* CTARG(1) = TARG */
/* STARG(1...6,1) = ( 0, 0, 0, 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, "zzspkgo1_", (ftnlen)775)] == cobs) {
ctpos = nct;
cframe = tframe[(i__1 = ctpos - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge(
"tframe", i__1, "zzspkgo1_", (ftnlen)777)];
} 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 */
/* states array, just a single center and state */
/* is sufficient --- we just keep overwriting them. */
/* When the common node is found, we have everything */
/* we need in that one center (COBS) and state */
/* (SOBS-state 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 state */
/* data for COBS. */
spksfs_(&cobs, et, &handle, descr, ident, &found, (ftnlen)40);
if (found) {
/* Get the state 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 state of OBS relative to */
/* the old COBS to get the state of OBS */
/* relative to the new COBS. */
if (cframe == tmpfrm) {
/* On the first leg of the state of the observer, we */
/* don't have to add anything, the state of the observer */
/* is already in SOBS. We only have to add when the */
/* number of legs in the observer state is one or greater. */
if (legs > 0) {
vaddg_(sobs, stemp, &c__6, vtemp);
moved_(vtemp, &c__6, sobs);
}
} else if (tmpfrm > 0 && tmpfrm <= 21 && cframe > 0 && cframe <=
21) {
irfrot_(&cframe, &tmpfrm, rot);
mxv_(rot, sobs, vtemp);
mxv_(rot, &sobs[3], &vtemp[3]);
vaddg_(vtemp, stemp, &c__6, sobs);
cframe = tmpfrm;
} else {
zzfrmch1_(&cframe, &tmpfrm, et, stxfrm);
if (failed_()) {
chkout_("ZZSPKGO1", (ftnlen)8);
return 0;
}
mxvg_(stxfrm, sobs, &c__6, &c__6, vtemp);
vaddg_(vtemp, stemp, &c__6, sobs);
cframe = tmpfrm;
}
/* Check failed. We don't want to loop */
/* indefinitely. */
if (failed_()) {
chkout_("ZZSPKGO1", (ftnlen)8);
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 "
"state of TARG relative to OBS at the ephemeris epoch #. ", (
ftnlen)115);
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_("ZZSPKGO1", (ftnlen)8);
return 0;
}
/* If CTPOS is not zero, then we have reached a */
/* common node, specifically, */
/* CTARG(CTPOS) = COBS = CENTER */
/* (in diagram below). The STATE of the target */
/* (TARG) relative to the observer (OBS) is just */
/* STARG(1,CTPOS) - SOBS. */
/* SOBS */
/* CENTER ---------------->OBS */
/* | . */
/* | . */
/* S | . E */
/* T | . T */
/* A | . A */
/* R | . T */
/* G | . S */
/* | . */
/* | . */
/* V L */
/* TARG */
/* And the light-time between them is just */
/* | STATE | */
/* LT = --------- */
/* c */
/* Compute the state 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, "zzspkgo1_", (ftnlen)973)] == tframe[(i__3 = i__) <
20 && 0 <= i__3 ? i__3 : s_rnge("tframe", i__3, "zzspkgo1_", (
ftnlen)973)]) {
vaddg_(&starg[(i__2 = i__ * 6 - 6) < 120 && 0 <= i__2 ? i__2 :
s_rnge("starg", i__2, "zzspkgo1_", (ftnlen)975)], &starg[(
i__3 = (i__ + 1) * 6 - 6) < 120 && 0 <= i__3 ? i__3 :
s_rnge("starg", i__3, "zzspkgo1_", (ftnlen)975)], &c__6,
vtemp);
moved_(vtemp, &c__6, &starg[(i__2 = (i__ + 1) * 6 - 6) < 120 && 0
<= i__2 ? i__2 : s_rnge("starg", i__2, "zzspkgo1_", (
ftnlen)976)]);
} else if (tframe[(i__3 = i__) < 20 && 0 <= i__3 ? i__3 : s_rnge(
"tframe", i__3, "zzspkgo1_", (ftnlen)978)] > 0 && tframe[(
i__3 = i__) < 20 && 0 <= i__3 ? i__3 : s_rnge("tframe", i__3,
"zzspkgo1_", (ftnlen)978)] <= 21 && tframe[(i__2 = i__ - 1) <
20 && 0 <= i__2 ? i__2 : s_rnge("tframe", i__2, "zzspkgo1_", (
ftnlen)978)] > 0 && tframe[(i__2 = i__ - 1) < 20 && 0 <= i__2
? i__2 : s_rnge("tframe", i__2, "zzspkgo1_", (ftnlen)978)] <=
21) {
irfrot_(&tframe[(i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("tframe", i__2, "zzspkgo1_", (ftnlen)980)], &
tframe[(i__3 = i__) < 20 && 0 <= i__3 ? i__3 : s_rnge(
"tframe", i__3, "zzspkgo1_", (ftnlen)980)], rot);
mxv_(rot, &starg[(i__2 = i__ * 6 - 6) < 120 && 0 <= i__2 ? i__2 :
s_rnge("starg", i__2, "zzspkgo1_", (ftnlen)981)], stemp);
mxv_(rot, &starg[(i__2 = i__ * 6 - 3) < 120 && 0 <= i__2 ? i__2 :
s_rnge("starg", i__2, "zzspkgo1_", (ftnlen)982)], &stemp[
3]);
vaddg_(stemp, &starg[(i__2 = (i__ + 1) * 6 - 6) < 120 && 0 <=
i__2 ? i__2 : s_rnge("starg", i__2, "zzspkgo1_", (ftnlen)
983)], &c__6, vtemp);
moved_(vtemp, &c__6, &starg[(i__2 = (i__ + 1) * 6 - 6) < 120 && 0
<= i__2 ? i__2 : s_rnge("starg", i__2, "zzspkgo1_", (
ftnlen)984)]);
} else {
zzfrmch1_(&tframe[(i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("tframe", i__2, "zzspkgo1_", (ftnlen)988)], &
tframe[(i__3 = i__) < 20 && 0 <= i__3 ? i__3 : s_rnge(
"tframe", i__3, "zzspkgo1_", (ftnlen)988)], et, stxfrm);
if (failed_()) {
chkout_("ZZSPKGO1", (ftnlen)8);
return 0;
}
mxvg_(stxfrm, &starg[(i__2 = i__ * 6 - 6) < 120 && 0 <= i__2 ?
i__2 : s_rnge("starg", i__2, "zzspkgo1_", (ftnlen)995)], &
c__6, &c__6, stemp);
vaddg_(stemp, &starg[(i__2 = (i__ + 1) * 6 - 6) < 120 && 0 <=
i__2 ? i__2 : s_rnge("starg", i__2, "zzspkgo1_", (ftnlen)
996)], &c__6, vtemp);
moved_(vtemp, &c__6, &starg[(i__2 = (i__ + 1) * 6 - 6) < 120 && 0
<= i__2 ? i__2 : s_rnge("starg", i__2, "zzspkgo1_", (
ftnlen)997)]);
}
}
/* 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, "zzspkgo1_", (ftnlen)1010)] == cframe) {
vsubg_(&starg[(i__1 = ctpos * 6 - 6) < 120 && 0 <= i__1 ? i__1 :
s_rnge("starg", i__1, "zzspkgo1_", (ftnlen)1012)], sobs, &
c__6, state);
} else if (tframe[(i__1 = ctpos - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge(
"tframe", i__1, "zzspkgo1_", (ftnlen)1014)] == refid) {
/* If the last frame associated with the target is already */
/* in the requested output frame, we convert the state of */
/* the observer to that frame and then subtract the state */
/* of the observer from the state of the target. */
if (refid > 0 && refid <= 21 && cframe > 0 && cframe <= 21) {
irfrot_(&cframe, &refid, rot);
mxv_(rot, sobs, stemp);
mxv_(rot, &sobs[3], &stemp[3]);
} else {
zzfrmch1_(&cframe, &refid, et, stxfrm);
if (failed_()) {
chkout_("ZZSPKGO1", (ftnlen)8);
return 0;
}
mxvg_(stxfrm, sobs, &c__6, &c__6, stemp);
}
/* We've now transformed SOBS into the requested reference frame. */
/* Set CFRAME to reflect this. */
cframe = refid;
vsubg_(&starg[(i__1 = ctpos * 6 - 6) < 120 && 0 <= i__1 ? i__1 :
s_rnge("starg", i__1, "zzspkgo1_", (ftnlen)1046)], stemp, &
c__6, state);
} else if (cframe > 0 && cframe <= 21 && tframe[(i__1 = ctpos - 1) < 20 &&
0 <= i__1 ? i__1 : s_rnge("tframe", i__1, "zzspkgo1_", (ftnlen)
1049)] > 0 && tframe[(i__1 = ctpos - 1) < 20 && 0 <= i__1 ? i__1 :
s_rnge("tframe", i__1, "zzspkgo1_", (ftnlen)1049)] <= 21) {
/* If both frames are inertial we use IRFROT instead of */
/* ZZFRMCH1 to get things into a common frame. */
irfrot_(&tframe[(i__1 = ctpos - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge(
"tframe", i__1, "zzspkgo1_", (ftnlen)1055)], &cframe, rot);
mxv_(rot, &starg[(i__1 = ctpos * 6 - 6) < 120 && 0 <= i__1 ? i__1 :
s_rnge("starg", i__1, "zzspkgo1_", (ftnlen)1056)], stemp);
mxv_(rot, &starg[(i__1 = ctpos * 6 - 3) < 120 && 0 <= i__1 ? i__1 :
s_rnge("starg", i__1, "zzspkgo1_", (ftnlen)1057)], &stemp[3]);
vsubg_(stemp, sobs, &c__6, state);
} else {
/* Use the more general routine ZZFRMCH1 to make the */
/* transformation. */
zzfrmch1_(&tframe[(i__1 = ctpos - 1) < 20 && 0 <= i__1 ? i__1 :
s_rnge("tframe", i__1, "zzspkgo1_", (ftnlen)1065)], &cframe,
et, stxfrm);
if (failed_()) {
chkout_("ZZSPKGO1", (ftnlen)8);
return 0;
}
mxvg_(stxfrm, &starg[(i__1 = ctpos * 6 - 6) < 120 && 0 <= i__1 ? i__1
: s_rnge("starg", i__1, "zzspkgo1_", (ftnlen)1072)], &c__6, &
c__6, stemp);
vsubg_(stemp, sobs, &c__6, state);
}
/* 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, state, stemp);
mxv_(rot, &state[3], &stemp[3]);
moved_(stemp, &c__6, state);
} else {
zzfrmch1_(&cframe, &refid, et, stxfrm);
if (failed_()) {
chkout_("ZZSPKGO1", (ftnlen)8);
return 0;
}
mxvg_(stxfrm, state, &c__6, &c__6, stemp);
moved_(stemp, &c__6, state);
}
*lt = vnorm_(state) / clight_();
chkout_("ZZSPKGO1", (ftnlen)8);
return 0;
} /* zzspkgo1_ */
/* $Procedure ZZEKRD04 ( EK, read class 4 column entry elements ) */
/* Subroutine */ int zzekrd04_(integer *handle, integer *segdsc, integer *
coldsc, integer *recptr, integer *beg, integer *end, integer *ivals,
logical *isnull, logical *found)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
integer base, nrec, nelt;
extern integer zzekrp2n_(integer *, integer *, integer *);
integer unit;
extern /* Subroutine */ int zzekgfwd_(integer *, integer *, integer *,
integer *), zzekpgbs_(integer *, integer *, integer *), zzekpgpg_(
integer *, integer *, integer *, integer *);
integer p, nread;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer recno, ncols, ptemp, start;
extern logical failed_(void);
extern /* Subroutine */ int dasrdi_(integer *, integer *, integer *,
integer *);
integer remain, colidx, datptr, maxidx, minidx, ptrloc;
extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen), sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), dashlu_(integer *, integer *), errfnm_(char *, integer *,
ftnlen);
/* $ Abstract */
/* Read a specified element range from a column entry in a specified */
/* record in a class 4 column. Class 4 columns have integer arrays */
/* as column entries. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* EK */
/* $ Keywords */
/* EK */
/* FILES */
/* UTILITY */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Boolean Enumerated Type */
/* ekbool.inc Version 1 21-DEC-1994 (NJB) */
/* Within the EK system, boolean values sometimes must be */
/* represented by integer or character codes. The codes and their */
/* meanings are listed below. */
/* Integer code indicating `true': */
/* Integer code indicating `false': */
/* Character code indicating `true': */
/* Character code indicating `false': */
/* End Include Section: EK Boolean Enumerated Type */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Column Descriptor Parameters */
/* ekcoldsc.inc Version 6 23-AUG-1995 (NJB) */
/* Note: The column descriptor size parameter CDSCSZ is */
/* declared separately in the include section CDSIZE$INC.FOR. */
/* Offset of column descriptors, relative to start of segment */
/* integer address range. This number, when added to the last */
/* integer address preceding the segment, yields the DAS integer */
/* base address of the first column descriptor. Currently, this */
/* offset is exactly the size of a segment descriptor. The */
/* parameter SDSCSZ, which defines the size of a segment descriptor, */
/* is declared in the include file eksegdsc.inc. */
/* Size of column descriptor */
/* Indices of various pieces of column descriptors: */
/* CLSIDX is the index of the column's class code. (We use the */
/* word `class' to distinguish this item from the column's data */
/* type.) */
/* TYPIDX is the index of the column's data type code (CHR, INT, DP, */
/* or TIME). The type is actually implied by the class, but it */
/* will frequently be convenient to look up the type directly. */
/* LENIDX is the index of the column's string length value, if the */
/* column has character type. A value of IFALSE in this element of */
/* the descriptor indicates that the strings have variable length. */
/* SIZIDX is the index of the column's element size value. This */
/* descriptor element is meaningful for columns with fixed-size */
/* entries. For variable-sized columns, this value is IFALSE. */
/* NAMIDX is the index of the base address of the column's name. */
/* IXTIDX is the data type of the column's index. IXTIDX */
/* contains a type value only if the column is indexed. For columns */
/* that are not indexed, the location IXTIDX contains the boolean */
/* value IFALSE. */
/* IXPIDX is a pointer to the column's index. IXTPDX contains a */
/* meaningful value only if the column is indexed. The */
/* interpretation of the pointer depends on the data type of the */
/* index. */
/* NFLIDX is the index of a flag indicating whether nulls are */
/* permitted in the column. The value at location NFLIDX is */
/* ITRUE if nulls are permitted and IFALSE otherwise. */
/* ORDIDX is the index of the column's ordinal position in the */
/* list of columns belonging to the column's parent segment. */
/* METIDX is the index of the column's integer metadata pointer. */
/* This pointer is a DAS integer address. */
/* The last position in the column descriptor is reserved. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Column Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Data Page Parameters */
/* ekfilpar.inc Version 1 03-APR-1995 (NJB) */
/* These parameters apply to EK files using architecture 4. */
/* These files use a paged DAS file as their underlying file */
/* structure. */
/* In paged DAS EK files, data pages are structured: they contain */
/* metadata as well as data. The metadata is located in the last */
/* few addresses of each page, so as to interfere as little as */
/* possible with calculation of data addresses. */
/* Each data page belongs to exactly one segment. Some bookkeeping */
/* information, such as record pointers, is also stored in data */
/* pages. */
/* Each page contains a forward pointer that allows rapid lookup */
/* of data items that span multiple pages. Each page also keeps */
/* track of the current number of links from its parent segment */
/* to the page. Link counts enable pages to `know' when they */
/* are no longer in use by a segment; unused pages are deallocated */
/* and returned to the free list. */
/* The parameters in this include file depend on the parameters */
/* declared in the include file ekpage.inc. If those parameters */
/* change, this file must be updated. The specified parameter */
/* declarations we need from that file are: */
/* INTEGER PGSIZC */
/* PARAMETER ( PGSIZC = 1024 ) */
/* INTEGER PGSIZD */
/* PARAMETER ( PGSIZD = 128 ) */
/* INTEGER PGSIZI */
/* PARAMETER ( PGSIZI = 256 ) */
/* Character pages use an encoding mechanism to represent integer */
/* metadata. Each integer is encoded in five consecutive */
/* characters. */
/* Character data page parameters: */
/* Size of encoded integer: */
/* Usable page size: */
/* Location of character forward pointer: */
/* Location of character link count: */
/* Double precision data page parameters: */
/* Usable page size: */
/* Location of d.p. forward pointer: */
/* Location of d.p. link count: */
/* Integer data page parameters: */
/* Usable page size: */
/* Location of integer forward pointer: */
/* Location of integer link count: */
/* End Include Section: EK Data Page Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Record Pointer Parameters */
/* ekrecptr.inc Version 2 18-JUL-1995 (NJB) */
/* This file declares parameters used in EK record pointers. */
/* Each segment references data in a given record via two levels */
/* of indirection: a record number points to a record pointer, */
/* which is a structured array of metadata and data pointers. */
/* Record pointers always occupy contiguous ranges of integer */
/* addresses. */
/* The parameter declarations in this file depend on the assumption */
/* that integer pages contain 256 DAS integer words and that the */
/* maximum number of columns in a segment is 100. Record pointers */
/* are stored in integer data pages, so they must fit within the */
/* usable data area afforded by these pages. The size of the usable */
/* data area is given by the parameter IPSIZE which is declared in */
/* ekdatpag.inc. The assumed value of IPSIZE is 254. */
/* The first element of each record pointer is a status indicator. */
/* The meanings of status indicators depend on whether the parent EK */
/* is shadowed or not. For shadowed EKs, allowed status values and */
/* their meanings are: */
/* OLD The record has not been modified since */
/* the EK containing the record was opened. */
/* UPDATE The record is an update of a previously existing */
/* record. The original record is now on the */
/* modified record list. */
/* NEW The record has been added since the EK containing the */
/* record was opened. The record is not an update */
/* of a previously existing record. */
/* DELOLD This status applies only to a backup record. */
/* DELOLD status indicates that the record corresponds */
/* to a deleted OLD record in the source segment. */
/* DELNEW This status applies only to a backup record. */
/* DELNEW status indicates that the record corresponds */
/* to a deleted NEW record in the source segment. */
/* DELUPD This status applies only to a backup record. */
/* DELUPD status indicates that the record corresponds */
/* to a deleted UPDATEd record in the source segment. */
/* In EKs that are not shadowed, all records have status OLD. */
/* The following parameters refer to indices within the record */
/* pointer structure: */
/* Index of status indicator: */
/* Each record pointer contains a pointer to its companion: for a */
/* record belonging to a shadowed EK, this is the backup counterpart, */
/* or if the parent EK is itself a backup EK, a pointer to the */
/* record's source record. The pointer is UNINIT (see below) if the */
/* record is unmodified. */
/* Record companion pointers contain record numbers, not record */
/* base addresses. */
/* Index of record's companion pointer: */
/* Each data item is referenced by an integer. The meaning of */
/* this integer depends on the representation of data in the */
/* column to which the data item belongs. Actual lookup of a */
/* data item must be done by subroutines appropriate to the class of */
/* the column to which the item belongs. Note that data items don't */
/* necessarily occupy contiguous ranges of DAS addresses. */
/* Base address of data pointers: */
/* Maximum record pointer size: */
/* Data pointers are given the value UNINIT to start with; this */
/* indicates that the data item is uninitialized. UNINIT is */
/* distinct from the value NULL. NOBACK indicates an uninitialized */
/* backup column entry. */
/* End Include Section: EK Record Pointer Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Segment Descriptor Parameters */
/* eksegdsc.inc Version 8 06-NOV-1995 (NJB) */
/* All `base addresses' referred to below are the addresses */
/* *preceding* the item the base applies to. This convention */
/* enables simplied address calculations in many cases. */
/* Size of segment descriptor. Note: the include file ekcoldsc.inc */
/* must be updated if this parameter is changed. The parameter */
/* CDOFF in that file should be kept equal to SDSCSZ. */
/* Index of the segment type code: */
/* Index of the segment's number. This number is the segment's */
/* index in the list of segments contained in the EK to which */
/* the segment belongs. */
/* Index of the DAS integer base address of the segment's integer */
/* meta-data: */
/* Index of the DAS character base address of the table name: */
/* Index of the segment's column count: */
/* Index of the segment's record count: */
/* Index of the root page number of the record tree: */
/* Index of the root page number of the character data page tree: */
/* Index of the root page number of the double precision data page */
/* tree: */
/* Index of the root page number of the integer data page tree: */
/* Index of the `modified' flag: */
/* Index of the `initialized' flag: */
/* Index of the shadowing flag: */
/* Index of the companion file handle: */
/* Index of the companion segment number: */
/* The next three items are, respectively, the page numbers of the */
/* last character, d.p., and integer data pages allocated by the */
/* segment: */
/* The next three items are, respectively, the page-relative */
/* indices of the last DAS word in use in the segment's */
/* last character, d.p., and integer data pages: */
/* Index of the DAS character base address of the column name list: */
/* The last descriptor element is reserved for future use. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Segment Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Data Types */
/* ektype.inc Version 1 27-DEC-1994 (NJB) */
/* Within the EK system, data types of EK column contents are */
/* represented by integer codes. The codes and their meanings */
/* are listed below. */
/* Integer codes are also used within the DAS system to indicate */
/* data types; the EK system makes no assumptions about compatibility */
/* between the codes used here and those used in the DAS system. */
/* Character type: */
/* Double precision type: */
/* Integer type: */
/* `Time' type: */
/* Within the EK system, time values are represented as ephemeris */
/* seconds past J2000 (TDB), and double precision numbers are used */
/* to store these values. However, since time values require special */
/* treatment both on input and output, and since the `TIME' column */
/* has a special role in the EK specification and code, time values */
/* are identified as a type distinct from double precision numbers. */
/* End Include Section: EK Data Types */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle attached to EK file. */
/* SEGDSC I Segment descriptor. */
/* COLDSC I Column descriptor. */
/* RECPTR I Record pointer. */
/* BEG I Start element index. */
/* END I End element index. */
/* IVALS O Integer values in column entry. */
/* ISNULL O Flag indicating whether column entry is null. */
/* FOUND O Flag indicating whether elements were found. */
/* $ Detailed_Input */
/* HANDLE is an EK file handle. */
/* SEGDSC is the descriptor of the segment from which data is */
/* to be read. */
/* COLDSC is the descriptor of the column from which data is */
/* to be read. */
/* RECPTR is a pointer to the record containing the column */
/* entry to be written. */
/* BEG, */
/* END are, respectively, the start and end indices of */
/* the contiguous range of elements to be read from */
/* the specified column entry. */
/* $ Detailed_Output */
/* IVALS are the values read from the specified column */
/* entry. The mapping of elements of the column entry */
/* to elements of IVALS is as shown below: */
/* Column entry element IVALS element */
/* -------------------- ------------- */
/* BEG 1 */
/* BEG+1 2 */
/* . . */
/* . . */
/* . . */
/* END END-BEG+1 */
/* IVALS is valid only if the output argument */
/* FOUND is returned .TRUE. */
/* ISNULL is a logical flag indicating whether the entry is */
/* null. ISNULL is set on output whether or not */
/* the range of elements designated by BEG and END */
/* exists. */
/* FOUND is a logical flag indicating whether the range */
/* of elements designated by BEG and END exists. */
/* If the number of elements in the specified column */
/* entry is not at least END, FOUND will be returned */
/* .FALSE. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If HANDLE is invalid, the error will be diagnosed by routines */
/* called by this routine. */
/* 2) If the specified column entry has not been initialized, the */
/* error SPICE(UNINITIALIZEDVALUE) is signalled. */
/* 3) If the ordinal position of the column specified by COLDSC */
/* is out of range, the error SPICE(INVALIDINDEX) is signalled. */
/* 4) If an I/O error occurs while reading the indicated file, */
/* the error will be diagnosed by routines called by this */
/* routine. */
/* $ Files */
/* See the EK Required Reading for a discussion of the EK file */
/* format. */
/* $ Particulars */
/* This routine is a utility for reading data from class 4 columns. */
/* $ Examples */
/* See EKRCEI. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.0, 08-SEP-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in ZZEKGFWD call. */
/* - SPICELIB Version 1.0.0, 18-OCT-1995 (NJB) */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.1.0, 08-SEP-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in ZZEKGFWD call. */
/* -& */
/* SPICELIB functions */
/* Non-SPICELIB functions */
/* Local variables */
/* Use discovery check-in. */
nrec = segdsc[5];
/* Make sure the column exists. */
ncols = segdsc[4];
colidx = coldsc[8];
if (colidx < 1 || colidx > ncols) {
chkin_("ZZEKRD04", (ftnlen)8);
setmsg_("Column index = #; valid range is 1:#.", (ftnlen)37);
errint_("#", &colidx, (ftnlen)1);
errint_("#", &nrec, (ftnlen)1);
sigerr_("SPICE(INVALIDINDEX)", (ftnlen)19);
chkout_("ZZEKRD04", (ftnlen)8);
return 0;
}
/* Compute the data pointer location, and read the pointer. */
ptrloc = *recptr + 2 + colidx;
dasrdi_(handle, &ptrloc, &ptrloc, &datptr);
if (datptr > 0) {
/* The entry is non-null. */
*isnull = FALSE_;
/* Get the element count. Check for range specifications that */
/* can't be met. */
dasrdi_(handle, &datptr, &datptr, &nelt);
if (*beg < 1 || *beg > nelt) {
*found = FALSE_;
return 0;
} else if (*end < 1 || *end > nelt) {
*found = FALSE_;
return 0;
} else if (*end < *beg) {
*found = FALSE_;
return 0;
}
/* The request is valid, so read the data. The first step is to */
/* locate the element at index BEG. */
zzekpgpg_(&c__3, &datptr, &p, &base);
minidx = 1;
maxidx = base + 254 - datptr;
datptr += *beg;
while(maxidx < *beg) {
/* Locate the page on which the element is continued. */
i__1 = base + 255;
i__2 = base + 255;
dasrdi_(handle, &i__1, &i__2, &p);
/* Determine the highest-indexed element of the column entry */
/* located on the current page. */
zzekpgbs_(&c__3, &p, &base);
minidx = maxidx + 1;
/* Computing MIN */
i__1 = maxidx + 254;
maxidx = min(i__1,nelt);
/* The following assignment will set DATPTR to the correct */
/* value on the last pass through this loop. */
datptr = base + 1 + (*beg - minidx);
}
/* At this point, P is the page on which the element having index */
/* BEG is located. BASE is the base address of this page. */
/* MAXIDX is the highest index of any element on the current page. */
remain = *end - *beg + 1;
start = 1;
/* Decide how many elements to read from the current page, and */
/* read them. */
/* Computing MIN */
i__1 = remain, i__2 = base + 254 - datptr + 1;
nread = min(i__1,i__2);
i__1 = datptr + nread - 1;
dasrdi_(handle, &datptr, &i__1, &ivals[start - 1]);
remain -= nread;
while(remain > 0 && ! failed_()) {
/* Locate the page on which the element is continued. */
zzekgfwd_(handle, &c__3, &p, &ptemp);
p = ptemp;
zzekpgbs_(&c__3, &p, &base);
datptr = base + 1;
start += nread;
nread = min(remain,254);
i__1 = datptr + nread - 1;
dasrdi_(handle, &datptr, &i__1, &ivals[start - 1]);
remain -= nread;
}
*found = ! failed_();
} else if (datptr == -2) {
/* The value is null. */
*isnull = TRUE_;
*found = TRUE_;
} else if (datptr == -1) {
/* The data value is absent. This is an error. */
recno = zzekrp2n_(handle, &segdsc[1], recptr);
dashlu_(handle, &unit);
chkin_("ZZEKRD04", (ftnlen)8);
setmsg_("Attempted to read uninitialized column entry. SEGNO = #; C"
"OLIDX = #; RECNO = #; EK = #", (ftnlen)87);
errint_("#", &segdsc[1], (ftnlen)1);
errint_("#", &colidx, (ftnlen)1);
errint_("#", &recno, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(UNINITIALIZEDVALUE)", (ftnlen)25);
chkout_("ZZEKRD04", (ftnlen)8);
return 0;
} else {
/* The data pointer is corrupted. */
dashlu_(handle, &unit);
chkin_("ZZEKRD04", (ftnlen)8);
setmsg_("Data pointer is corrupted. SEGNO = #; COLIDX = #; RECNO = "
"#; EK = #", (ftnlen)68);
errint_("#", &segdsc[1], (ftnlen)1);
errint_("#", &colidx, (ftnlen)1);
errint_("#", &recno, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZEKRD04", (ftnlen)8);
return 0;
}
return 0;
} /* zzekrd04_ */
/* $Procedure DAFDC ( DAF delete comments ) */
/* Subroutine */ int dafdc_(integer *handle)
{
integer free;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer bward, fward, ncomr, nd;
extern logical failed_(void);
integer ni;
extern /* Subroutine */ int dafsih_(integer *, char *, ftnlen);
char ifname[60];
extern /* Subroutine */ int dafrfr_(integer *, integer *, integer *, char
*, integer *, integer *, integer *, ftnlen), dafrrr_(integer *,
integer *), chkout_(char *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Delete the entire comment area of a previously opened binary */
/* DAF attached to 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 */
/* DAF */
/* $ Keywords */
/* None. */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I The handle of a binary DAF opened for writing. */
/* $ Detailed_Input */
/* HANDLE The handle of a binary DAF that is to have its entire */
/* comment area deleted. The DAF must have been opened */
/* with write access. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the binary DAF attached to HANDLE is not open with write */
/* access, an error will be signalled by a routine called by */
/* this routine. */
/* $ Files */
/* See argument HANDLE in $ Detailed_Input. */
/* $ Particulars */
/* A binary DAF contains an area which is reserved for storing */
/* annotations or descriptive textual information about the data */
/* contained in a file. This area is referred to as the ``comment */
/* area'' of the file. The comment area of a DAF is a line */
/* oriented medium for storing textual information. The comment */
/* area preserves any leading or embedded white space in the line(s) */
/* of text which are stored, so that the appearance of the of */
/* information will be unchanged when it is retrieved (extracted) at */
/* some other time. Trailing blanks, however, are NOT preserved, */
/* due to the way that character strings are represented in */
/* standard Fortran 77. */
/* This routine will delete the entire comment area from the binary */
/* DAF attached to HANDLE. The size of the binary DAF will remain */
/* unchanged. The space that was used by the comment records */
/* is reclaimed. */
/* $ Examples */
/* Let */
/* HANDLE be the handle of a DAF which has been opened */
/* with write access. */
/* The call */
/* CALL DAFDC ( HANDLE ) */
/* deletes the entire comment area of the binary DAF attached to */
/* HANDLE. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* $ Version */
/* - Beta Version 1.0.0, 23-SEP-1994 (KRG) */
/* -& */
/* $ Index_Entries */
/* delete DAF comment area */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Length of a DAF file internal filename. */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("DAFDC", (ftnlen)5);
}
/* Verify that the DAF attached to HANDLE was opened with write */
/* access. */
dafsih_(handle, "WRITE", (ftnlen)5);
if (failed_()) {
chkout_("DAFDC", (ftnlen)5);
return 0;
}
/* Read the file record to obtain the current number of comment */
/* records in the DAF attached to HANDLE. We will also get back some */
/* extra stuff that we do not use. */
dafrfr_(handle, &nd, &ni, ifname, &fward, &bward, &free, (ftnlen)60);
ncomr = fward - 2;
if (failed_()) {
chkout_("DAFDC", (ftnlen)5);
return 0;
}
/* Now we will attempt to remove the comment records, if there are */
/* any, otherwise we do nothing. */
if (ncomr > 0) {
/* We have some comment records, so remove them. */
dafrrr_(handle, &ncomr);
if (failed_()) {
chkout_("DAFDC", (ftnlen)5);
return 0;
}
}
/* We're done now, so goodbye. */
chkout_("DAFDC", (ftnlen)5);
return 0;
} /* dafdc_ */
/* $Procedure LTIME ( Light Time ) */
/* Subroutine */ int ltime_(doublereal *etobs, integer *obs, char *dir,
integer *targ, doublereal *ettarg, doublereal *elapsd, ftnlen dir_len)
{
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
doublereal sobs[6], myet, c__;
integer r__;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
doublereal starg[6];
extern doublereal vdist_(doublereal *, doublereal *);
extern integer rtrim_(char *, ftnlen);
extern logical failed_(void);
doublereal lt;
extern doublereal clight_(void);
integer bcentr;
extern /* Subroutine */ int spkgeo_(integer *, doublereal *, char *,
integer *, doublereal *, doublereal *, ftnlen), sigerr_(char *,
ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* This routine computes the transmit (or receive) time */
/* of a signal at a specified target, given the receive */
/* (or transmit) time at a specified observer. The elapsed */
/* time between transmit and receive is also returned. */
/* $ 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 */
/* SPK */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ETOBS I Epoch of a signal at some observer */
/* OBS I NAIF-id of some observer */
/* DIR I Direction the signal travels ( '->' or '<-' ) */
/* TARG I NAIF-id of the target object */
/* ETTARG O Epoch of the signal at the target */
/* ELAPSD O Time between transmit and receipt of the signal */
/* $ Detailed_Input */
/* ETOBS is an epoch expressed in ephemeris second (TDB) */
/* past the epoch of the J2000 reference system. */
/* This is the time at which an electromagnetic */
/* signal is "at" the observer. */
/* OBS is the NAIF-id of some observer. */
/* DIR is the direction the signal travels. The */
/* acceptable values are '->' and '<-'. When */
/* you read the calling sequence from left to */
/* right, the "arrow" given by DIR indicates */
/* which way the electromagnetic signal is travelling. */
/* If the argument list reads as below, */
/* ..., OBS, '->', TARG, ... */
/* the signal is travelling from the observer to the */
/* target. */
/* If the argument reads as */
/* ..., OBS, '<-', TARG */
/* the signal is travelling from the target to */
/* the observer. */
/* TARG is the NAIF-id of the target. */
/* $ Detailed_Output */
/* ETTARG is the epoch expressed in ephemeris seconds (TDB) */
/* past the epoch of the J2000 reference system */
/* at which the electromagnetic signal is "at" the */
/* target body. */
/* Note ETTARG is computed using only Newtonian */
/* assumptions about the propagation of light. */
/* ELAPSD is the number of ephemeris seconds (TDB) between */
/* transmission and receipt of the signal. */
/* ELAPSD = DABS( ETOBS - ETTARG ) */
/* $ Parameters */
/* None. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* 1) If DIR is not one of '->' or '<-' the error */
/* 'SPICE(BADDIRECTION)' will be signalled. In this case */
/* ETTARG and ELAPSD will not be altered from their */
/* input values. */
/* 2) If insufficient ephemeris information is available to */
/* compute the outputs ETTARG and ELAPSD, or if observer */
/* or target is not recognized, the problems is diagnosed */
/* by a routine in the call tree of this routine. */
/* In this case, the value of ETTARG will be set to ETOBS */
/* and ELAPSD will be set to zero. */
/* $ Particulars */
/* Suppose a radio signal travels between two solar system */
/* objects. Given an ephemeris for the two objects, which way */
/* the signal is travelling, and the time when the signal is */
/* "at" at one of the objects (the observer OBS), this routine */
/* determines when the signal is "at" the other object (the */
/* target TARG). It also returns the elapsed time between */
/* transmission and receipt of the signal. */
/* $ Examples */
/* Example 1. */
/* ---------- */
/* Suppose a signal is transmitted at time ET from the Goldstone */
/* tracking site (id-code 399001) to a spacecraft whose id-code */
/* is -77. */
/* signal travelling to spacecraft */
/* * -._.-._.-._.-._.-._.-._.-._.-._.-> * */
/* Goldstone (OBS=399001) Spacecraft (TARG = -77) */
/* at epoch ETOBS(given) at epoch ETTARG(unknown) */
/* Assuming that all of the required SPICE kernels have been */
/* loaded, the code fragment below shows how to compute the */
/* time (ARRIVE) at which the signal arrives at the spacecraft */
/* and how long (HOWLNG) it took the signal to reach the spacecraft. */
/* (Note that we display the arrival time as the number of seconds */
/* past J2000.) */
/* OBS = 399001 */
/* TARG = -77 */
/* ETOBS = ET */
/* CALL LTIME ( ETOBS, OBS, '->', TARG, ARRIVE, HOWLNG ) */
/* CALL ETCAL */
/* WRITE (*,*) 'The signal arrived at time: ', ARRIVE */
/* WRITE (*,*) 'It took ', HOWLNG, ' seconds to get there.' */
/* Example 2. */
/* ---------- */
/* Suppose a signal is received at the Goldstone tracking sight */
/* at epoch ET from the spacecraft of the previous example. */
/* signal sent from spacecraft */
/* * <-._.-._.-._.-._.-._.-._.-._.-._.- * */
/* Goldstone (OBS=399001) Spacecraft (TARG = -77) */
/* at epoch ETOBS(given) at epoch ETTARG(unknown) */
/* Again assuming that all the required kernels have been loaded */
/* the code fragment below computes the epoch at which the */
/* signal was transmitted from the spacecraft. */
/* OBS = 399001 */
/* TARG = -77 */
/* ETOBS = ET */
/* CALL LTIME ( ETOBS, OBS, '<-', TARG, SENT, HOWLNG ) */
/* CALL ETCAL */
/* WRITE (*,*) 'The signal was transmitted at: ', SENT */
/* WRITE (*,*) 'It took ', HOWLNG, ' seconds to get here.' */
/* EXAMPLE 3 */
/* --------- */
/* Suppose there is a transponder on board the spacecraft of */
/* the previous examples that transmits a signal back to the */
/* sender exactly 1 microsecond after a signal arrives at */
/* the spacecraft. If we send a signal from Goldstone */
/* to the spacecraft and wait to receive it at Canberra. */
/* What will be the epoch at which the return signal arrives */
/* in Canberra? ( The id-code for Canberra is 399002 ). */
/* Again, assuming we've loaded all the necessary kernels, */
/* the fragment below will give us the answer. */
/* GSTONE = 399001 */
/* SC = -77 */
/* CANBER = 399002 */
/* ETGOLD = ET */
/* CALL LTIME ( ETGOLD, GSTONE, '->', SC, SCGET, LT1 ) */
/* Account for the microsecond delay between receipt and transmit */
/* SCSEND = SCGET + 0.000001 */
/* CALL LTIME ( SCSEND, SC, '->', CANBER, ETCANB, LT2 ) */
/* RNDTRP = ETCANB - ETGOLD */
/* WRITE (*,*) 'The signal arrives in Canberra at: ', ETCANB */
/* WRITE (*,*) 'Round trip time for the signal was: ', RNDTRP */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.1.2, 22-SEP-2004 (EDW) */
/* Placed Copyright after Abstract. */
/* - SPICELIB Version 1.1.1, 18-NOV-1996 (WLT) */
/* Errors in the examples section were corrected. */
/* - SPICELIB Version 1.1.0, 10-JUL-1996 (WLT) */
/* Added Copyright Notice to the header. */
/* - SPICELIB Version 1.0.0, 10-NOV-1995 (WLT) */
/* -& */
/* $ Index_Entries */
/* Compute uplink and downlink light time */
/* -& */
/* SPICELIB Functions */
/* Local Variables */
if (return_()) {
return 0;
}
chkin_("LTIME", (ftnlen)5);
/* First perform the obvious error check. */
if (s_cmp(dir, "->", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(dir, "<-", (
ftnlen)2, (ftnlen)2) != 0) {
setmsg_("The direction specifier for the signal was '#' it must be "
"either '->' or '<-'. ", (ftnlen)80);
r__ = rtrim_(dir, (ftnlen)2);
errch_("#", dir, (ftnlen)1, r__);
sigerr_("SPICE(BADDIRECTION)", (ftnlen)19);
chkout_("LTIME", (ftnlen)5);
return 0;
}
/* We need two constants, the speed of light and the id-code */
/* for the solar system barycenter. */
c__ = clight_();
bcentr = 0;
myet = *etobs;
/* First get the barycenter relative states of the observer */
/* and target. */
spkgeo_(obs, &myet, "J2000", &bcentr, sobs, <, (ftnlen)5);
spkgeo_(targ, &myet, "J2000", &bcentr, starg, <, (ftnlen)5);
*elapsd = vdist_(sobs, starg) / c__;
/* The rest is straight forward. We either add the elapsed */
/* time to get the next state or subtract the elapsed time. */
/* This depends on whether we are receiving or transmitting */
/* at the observer. */
/* Note that 3 iterations as performed here gives us */
/* Newtonian accuracy to the nanosecond level for all */
/* known objects in the solar system. The ephemeris */
/* is certain to be much worse than this. */
if (s_cmp(dir, "->", (ftnlen)2, (ftnlen)2) == 0) {
*ettarg = myet + *elapsd;
spkgeo_(targ, ettarg, "J2000", &bcentr, starg, <, (ftnlen)5);
*elapsd = vdist_(sobs, starg) / c__;
*ettarg = myet + *elapsd;
spkgeo_(targ, ettarg, "J2000", &bcentr, starg, <, (ftnlen)5);
*elapsd = vdist_(sobs, starg) / c__;
*ettarg = myet + *elapsd;
spkgeo_(targ, ettarg, "J2000", &bcentr, starg, <, (ftnlen)5);
*elapsd = vdist_(sobs, starg) / c__;
*ettarg = myet + *elapsd;
} else {
*ettarg = myet - *elapsd;
spkgeo_(targ, ettarg, "J2000", &bcentr, starg, <, (ftnlen)5);
*elapsd = vdist_(sobs, starg) / c__;
*ettarg = myet - *elapsd;
spkgeo_(targ, ettarg, "J2000", &bcentr, starg, <, (ftnlen)5);
*elapsd = vdist_(sobs, starg) / c__;
*ettarg = myet - *elapsd;
spkgeo_(targ, ettarg, "J2000", &bcentr, starg, <, (ftnlen)5);
*elapsd = vdist_(sobs, starg) / c__;
*ettarg = myet - *elapsd;
}
if (failed_()) {
*ettarg = myet;
*elapsd = 0.;
}
chkout_("LTIME", (ftnlen)5);
return 0;
} /* ltime_ */
/* $Procedure ZZEKIID1 ( EK, insert into index, d.p., type 1 ) */
/* Subroutine */ int zzekiid1_(integer *handle, integer *segdsc, integer *
coldsc, doublereal *dkey, integer *recptr, logical *null)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer tree;
extern /* Subroutine */ int zzekcnam_(integer *, integer *, char *,
ftnlen), zzeklerd_(integer *, integer *, integer *, doublereal *,
integer *, logical *, integer *, integer *), zzektrin_(integer *,
integer *, integer *, integer *), chkin_(char *, ftnlen), errch_(
char *, char *, ftnlen, ftnlen);
integer dtype, itype;
extern logical failed_(void);
logical indexd;
char column[32];
integer prvidx;
extern /* Subroutine */ int setmsg_(char *, ftnlen), sigerr_(char *,
ftnlen), chkout_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
integer prvptr;
/* $ Abstract */
/* Insert into a type 1 EK index a record pointer associated with a */
/* d.p. key. The key and record pointer determine the insertion */
/* point via dictionary ordering on (value, record pointer) pairs. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* EK */
/* $ Keywords */
/* EK */
/* PRIVATE */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Boolean Enumerated Type */
/* ekbool.inc Version 1 21-DEC-1994 (NJB) */
/* Within the EK system, boolean values sometimes must be */
/* represented by integer or character codes. The codes and their */
/* meanings are listed below. */
/* Integer code indicating `true': */
/* Integer code indicating `false': */
/* Character code indicating `true': */
/* Character code indicating `false': */
/* End Include Section: EK Boolean Enumerated Type */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Column Name Size */
/* ekcnamsz.inc Version 1 17-JAN-1995 (NJB) */
/* Size of column name, in characters. */
/* End Include Section: EK Column Name Size */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Column Descriptor Parameters */
/* ekcoldsc.inc Version 6 23-AUG-1995 (NJB) */
/* Note: The column descriptor size parameter CDSCSZ is */
/* declared separately in the include section CDSIZE$INC.FOR. */
/* Offset of column descriptors, relative to start of segment */
/* integer address range. This number, when added to the last */
/* integer address preceding the segment, yields the DAS integer */
/* base address of the first column descriptor. Currently, this */
/* offset is exactly the size of a segment descriptor. The */
/* parameter SDSCSZ, which defines the size of a segment descriptor, */
/* is declared in the include file eksegdsc.inc. */
/* Size of column descriptor */
/* Indices of various pieces of column descriptors: */
/* CLSIDX is the index of the column's class code. (We use the */
/* word `class' to distinguish this item from the column's data */
/* type.) */
/* TYPIDX is the index of the column's data type code (CHR, INT, DP, */
/* or TIME). The type is actually implied by the class, but it */
/* will frequently be convenient to look up the type directly. */
/* LENIDX is the index of the column's string length value, if the */
/* column has character type. A value of IFALSE in this element of */
/* the descriptor indicates that the strings have variable length. */
/* SIZIDX is the index of the column's element size value. This */
/* descriptor element is meaningful for columns with fixed-size */
/* entries. For variable-sized columns, this value is IFALSE. */
/* NAMIDX is the index of the base address of the column's name. */
/* IXTIDX is the data type of the column's index. IXTIDX */
/* contains a type value only if the column is indexed. For columns */
/* that are not indexed, the location IXTIDX contains the boolean */
/* value IFALSE. */
/* IXPIDX is a pointer to the column's index. IXTPDX contains a */
/* meaningful value only if the column is indexed. The */
/* interpretation of the pointer depends on the data type of the */
/* index. */
/* NFLIDX is the index of a flag indicating whether nulls are */
/* permitted in the column. The value at location NFLIDX is */
/* ITRUE if nulls are permitted and IFALSE otherwise. */
/* ORDIDX is the index of the column's ordinal position in the */
/* list of columns belonging to the column's parent segment. */
/* METIDX is the index of the column's integer metadata pointer. */
/* This pointer is a DAS integer address. */
/* The last position in the column descriptor is reserved. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Column Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Operator Codes */
/* ekopcd.inc Version 1 30-DEC-1994 (NJB) */
/* Within the EK system, operators used in EK queries are */
/* represented by integer codes. The codes and their meanings are */
/* listed below. */
/* Relational expressions in EK queries have the form */
/* <column name> <operator> <value> */
/* For columns containing numeric values, the operators */
/* EQ, GE, GT, LE, LT, NE */
/* may be used; these operators have the same meanings as their */
/* Fortran counterparts. For columns containing character values, */
/* the list of allowed operators includes those in the above list, */
/* and in addition includes the operators */
/* LIKE, UNLIKE */
/* which are used to compare strings to a template. In the character */
/* case, the meanings of the parameters */
/* GE, GT, LE, LT */
/* match those of the Fortran lexical functions */
/* LGE, LGT, LLE, LLT */
/* The additional unary operators */
/* ISNULL, NOTNUL */
/* are used to test whether a value of any type is null. */
/* End Include Section: EK Operator Codes */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Segment Descriptor Parameters */
/* eksegdsc.inc Version 8 06-NOV-1995 (NJB) */
/* All `base addresses' referred to below are the addresses */
/* *preceding* the item the base applies to. This convention */
/* enables simplied address calculations in many cases. */
/* Size of segment descriptor. Note: the include file ekcoldsc.inc */
/* must be updated if this parameter is changed. The parameter */
/* CDOFF in that file should be kept equal to SDSCSZ. */
/* Index of the segment type code: */
/* Index of the segment's number. This number is the segment's */
/* index in the list of segments contained in the EK to which */
/* the segment belongs. */
/* Index of the DAS integer base address of the segment's integer */
/* meta-data: */
/* Index of the DAS character base address of the table name: */
/* Index of the segment's column count: */
/* Index of the segment's record count: */
/* Index of the root page number of the record tree: */
/* Index of the root page number of the character data page tree: */
/* Index of the root page number of the double precision data page */
/* tree: */
/* Index of the root page number of the integer data page tree: */
/* Index of the `modified' flag: */
/* Index of the `initialized' flag: */
/* Index of the shadowing flag: */
/* Index of the companion file handle: */
/* Index of the companion segment number: */
/* The next three items are, respectively, the page numbers of the */
/* last character, d.p., and integer data pages allocated by the */
/* segment: */
/* The next three items are, respectively, the page-relative */
/* indices of the last DAS word in use in the segment's */
/* last character, d.p., and integer data pages: */
/* Index of the DAS character base address of the column name list: */
/* The last descriptor element is reserved for future use. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Segment Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Data Types */
/* ektype.inc Version 1 27-DEC-1994 (NJB) */
/* Within the EK system, data types of EK column contents are */
/* represented by integer codes. The codes and their meanings */
/* are listed below. */
/* Integer codes are also used within the DAS system to indicate */
/* data types; the EK system makes no assumptions about compatibility */
/* between the codes used here and those used in the DAS system. */
/* Character type: */
/* Double precision type: */
/* Integer type: */
/* `Time' type: */
/* Within the EK system, time values are represented as ephemeris */
/* seconds past J2000 (TDB), and double precision numbers are used */
/* to store these values. However, since time values require special */
/* treatment both on input and output, and since the `TIME' column */
/* has a special role in the EK specification and code, time values */
/* are identified as a type distinct from double precision numbers. */
/* End Include Section: EK Data Types */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I File handle. */
/* SEGDSC I Segment descriptor. */
/* COLDSC I Column descriptor. */
/* DKEY I Double precision key. */
/* RECPTR I Record pointer. */
/* NULL I Null flag. */
/* $ Detailed_Input */
/* HANDLE is a file handle of an EK open for write access. */
/* SEGDSC is the segment descriptor of the segment */
/* containing the column specified by COLDSC. */
/* COLDSC is the column descriptor of the column to */
/* which the index corresponds. */
/* DKEY is a double precision key. */
/* RECPTR is a record pointer associated with the input key. */
/* NULL is a logical flag indicating whether the input */
/* value is null. */
/* $ Detailed_Output */
/* None. This routine operates by side effects. See $Particulars */
/* for a description of the effect of this routine. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If HANDLE is invalid, the error will be diagnosed by routines */
/* called by this routine. */
/* 2) If the data type of the input column is not double precision, */
/* the error SPICE(INVALIDTYPE) is signalled. */
/* 3) If the input column is not indexed, the error */
/* SPICE(NOTINDEXED) is signalled. */
/* 4) If the index type of the input column is not recognized, */
/* the error SPICE(INVALIDTYPE) is signalled. */
/* 5) If an I/O error occurs while reading or writing the indicated */
/* file, the error will be diagnosed by routines called by this */
/* routine. */
/* $ Files */
/* See the EK Required Reading for a discussion of the EK file */
/* format. */
/* $ Particulars */
/* This routine updates the index of an EK segment to reflect the */
/* addition of a record to the segment. The index must be */
/* associated with a double precision, scalar column. The type of */
/* the double precision index must be 1. */
/* The ordinal position of the new item is determined by the key */
/* DKEY. The new item will follow the last item already present */
/* in the column having a value less than or equal to DKEY. */
/* In order to support the capability of creating an index for a */
/* column that has already been populated with data, this routine */
/* does not require that number of elements referenced by the */
/* input column's index match the number of elements in the column; */
/* the index is allowed to reference fewer elements. However, */
/* every record referenced by the index must be populated with data. */
/* $ Examples */
/* See ZZEKAD02. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - Beta Version 1.1.0, 18-JUN-1999 (WLT) */
/* Removed an unbalanced call to CHKOUT. */
/* - Beta Version 1.0.0, 10-OCT-1995 (NJB) */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Use discovery check-in. */
if (failed_()) {
return 0;
}
/* If the column's not indexed, we have no business being here. */
indexd = coldsc[5] != -1;
if (! indexd) {
zzekcnam_(handle, coldsc, column, (ftnlen)32);
chkin_("ZZEKIID1", (ftnlen)8);
setmsg_("Column # is not indexed.", (ftnlen)24);
errch_("#", column, (ftnlen)1, (ftnlen)32);
sigerr_("SPICE(NOTINDEXED)", (ftnlen)17);
chkout_("ZZEKIID1", (ftnlen)8);
return 0;
}
/* Check the column's data type. */
dtype = coldsc[1];
if (dtype != 2 && dtype != 4) {
zzekcnam_(handle, coldsc, column, (ftnlen)32);
chkin_("ZZEKIID1", (ftnlen)8);
setmsg_("Column # should be DP or TIME but has type #.", (ftnlen)45);
errch_("#", column, (ftnlen)1, (ftnlen)32);
errint_("#", &dtype, (ftnlen)1);
sigerr_("SPICE(INVALIDTYPE)", (ftnlen)18);
chkout_("ZZEKIID1", (ftnlen)8);
return 0;
}
itype = coldsc[5];
if (itype == 1) {
/* Get the tree pointer from the column descriptor. */
tree = coldsc[6];
/* Locate the predecessor of the input key, record pointer pair. */
zzeklerd_(handle, segdsc, coldsc, dkey, recptr, null, &prvidx, &
prvptr);
/* Insert the new record pointer right after the item we've found. */
i__1 = prvidx + 1;
zzektrin_(handle, &tree, &i__1, recptr);
} else {
zzekcnam_(handle, coldsc, column, (ftnlen)32);
chkin_("ZZEKIID1", (ftnlen)8);
setmsg_("Column # has index type #.", (ftnlen)26);
errch_("#", column, (ftnlen)1, (ftnlen)32);
errint_("#", &itype, (ftnlen)1);
sigerr_("SPICE(INVALIDTYPE)", (ftnlen)18);
chkout_("ZZEKIID1", (ftnlen)8);
return 0;
}
return 0;
} /* zzekiid1_ */
/* $Procedure EKUCEC ( EK, update d.p. column entry ) */
/* Subroutine */ int ekucec_(integer *handle, integer *segno, integer *recno,
char *column, integer *nvals, char *cvals, logical *isnull, ftnlen
column_len, ftnlen cvals_len)
{
integer unit;
extern /* Subroutine */ int zzekcdsc_(integer *, integer *, char *,
integer *, ftnlen), zzekrbck_(char *, integer *, integer *,
integer *, integer *, ftnlen), zzeksdsc_(integer *, integer *,
integer *), zzektrdp_(integer *, integer *, integer *, integer *),
chkin_(char *, ftnlen), errch_(char *, char *, ftnlen, ftnlen);
integer class__, dtype;
extern logical failed_(void);
integer coldsc[11], segdsc[24];
logical isshad;
extern /* Subroutine */ int dashlu_(integer *, integer *);
integer recptr;
extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen), errfnm_(char *, integer *, ftnlen), sigerr_(
char *, ftnlen), chkout_(char *, ftnlen), ekshdw_(integer *,
logical *), zzekue03_(integer *, integer *, integer *, integer *,
char *, logical *, ftnlen), zzekue06_(integer *, integer *,
integer *, integer *, integer *, char *, logical *, ftnlen);
/* $ Abstract */
/* Update a character column entry in a specified EK record. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* EK */
/* $ Keywords */
/* EK */
/* FILES */
/* UTILITY */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK 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 Data Types */
/* ektype.inc Version 1 27-DEC-1994 (NJB) */
/* Within the EK system, data types of EK column contents are */
/* represented by integer codes. The codes and their meanings */
/* are listed below. */
/* Integer codes are also used within the DAS system to indicate */
/* data types; the EK system makes no assumptions about compatibility */
/* between the codes used here and those used in the DAS system. */
/* Character type: */
/* Double precision type: */
/* Integer type: */
/* `Time' type: */
/* Within the EK system, time values are represented as ephemeris */
/* seconds past J2000 (TDB), and double precision numbers are used */
/* to store these values. However, since time values require special */
/* treatment both on input and output, and since the `TIME' column */
/* has a special role in the EK specification and code, time values */
/* are identified as a type distinct from double precision numbers. */
/* End Include Section: EK Data Types */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle attached to EK file. */
/* SEGNO I Index of segment containing record. */
/* RECNO I Record in which entry is to be updated. */
/* COLUMN I Column name. */
/* NVALS I Number of values in in new column entry. */
/* CVALS I Character string values to add to column. */
/* ISNULL I Flag indicating whether column entry is null. */
/* $ Detailed_Input */
/* HANDLE is a file handle attached to an EK open for */
/* write access. */
/* SEGNO is the index of the segment containing the column */
/* entry to be updated. */
/* RECNO is the index of the record containing the column */
/* entry to be updated. This record number is */
/* relative to the start of the segment indicated by */
/* SEGNO; the first record in the segment has index 1. */
/* COLUMN is the name of the column containing the entry to */
/* be updated. */
/* NVALS, */
/* CVALS are, respectively, the number of values to add to */
/* the specified column and the set of values */
/* themselves. The data values are written in to the */
/* specifed column and record. */
/* If the column has fixed-size entries, then NVALS */
/* must equal the entry size for the specified column. */
/* For columns with variable-sized entries, the size */
/* of the new entry need not match the size of the */
/* entry it replaces. In particular, the new entry */
/* may be larger. */
/* ISNULL is a logical flag indicating whether the entry is */
/* null. If ISNULL is .FALSE., the column entry */
/* defined by NVALS and CVALS is added to the */
/* specified kernel file. */
/* If ISNULL is .TRUE., NVALS and CVALS are ignored. */
/* The contents of the column entry are undefined. */
/* If the column has fixed-length, variable-size */
/* entries, the number of entries is considered to */
/* be 1. */
/* The new entry may be null even though it replaces */
/* a non-null value, and vice versa. */
/* $ Detailed_Output */
/* None. See $Particulars for a description of the effect of this */
/* routine. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If HANDLE is invalid, the error will be diagnosed by routines */
/* called by this routine. */
/* 2) If SEGNO is out of range, the error will diagnosed by routines */
/* called by this routine. */
/* 3) If COLUMN is not the name of a declared column, the error */
/* will be diagnosed by routines called by this routine. */
/* 4) If COLUMN specifies a column of whose data type is not */
/* CHARACTER, the error SPICE(WRONGDATATYPE) will */
/* be signalled. */
/* 5) If RECNO is out of range, the error will diagnosed by routines */
/* called by this routine. */
/* 6) If the specified column has fixed-size entries and NVALS */
/* does not match this size, the error will diagnosed by routines */
/* called by this routine. */
/* 7) If the specified column has variable-size entries and NVALS */
/* is non-positive, the error will diagnosed by routines */
/* called by this routine. */
/* 8) If an attempt is made to add a null value to a column that */
/* doesn't take null values, the error will diagnosed by routines */
/* called by this routine. */
/* 9) If COLUMN specifies a column of whose class is not */
/* a character class known to this routine, the error */
/* SPICE(NOCLASS) will be signalled. */
/* 10) If an I/O error occurs while reading or writing the indicated */
/* file, the error will be diagnosed by routines called by this */
/* routine. */
/* $ Files */
/* See the EK Required Reading for a discussion of the EK file */
/* format. */
/* $ Particulars */
/* This routine operates by side effects: it modifies the named */
/* EK file by adding data to the specified record in the specified */
/* column. Data may be added to a segment in random order; it is not */
/* necessary to fill in columns or rows sequentially. Data may only */
/* be added one logical element at a time. Partial assignments of */
/* logical elements are not supported. */
/* Since columns of data type TIME are implemented using double */
/* precision column classes, this routine may be used to update */
/* columns of type TIME. */
/* $ Examples */
/* 1) Replace the value in the third record of the column CCOL in */
/* the fifth segment of an EK file designated by HANDLE. Set */
/* the new value to '999'. */
/* CALL EKUCEC ( HANDLE, 5, 3, 'CCOL', 1, '999', .FALSE. ) */
/* 2) Same as (1), but this time add a null value. The argument */
/* '999' is ignored because the null flag is set to .TRUE. */
/* CALL EKUCEC ( HANDLE, 5, 3, 'CCOL', 1, '999', .TRUE. ) */
/* 3) Replace the entry in the third record of the column CARRAY in */
/* the fifth segment of an EK file designated by HANDLE. Set */
/* the new value using an array CBUFF of 10 string values. */
/* CALL EKUCEC ( HANDLE, 5, 3, 'CARRAY', 10, CBUFF, .FALSE. ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.0, 20-JUN-1999 (WLT) */
/* Removed unbalanced call to CHKOUT. */
/* - Beta Version 1.0.0, 26-SEP-1995 (NJB) */
/* -& */
/* $ Index_Entries */
/* replace character entry in an EK column */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Use discovery check-in. */
/* First step: find the descriptor for the named segment. Using */
/* this descriptor, get the column descriptor. */
zzeksdsc_(handle, segno, segdsc);
zzekcdsc_(handle, segdsc, column, coldsc, column_len);
if (failed_()) {
return 0;
}
/* This column had better be of character type. */
dtype = coldsc[1];
if (dtype != 1) {
chkin_("EKUCEC", (ftnlen)6);
dashlu_(handle, &unit);
setmsg_("Column # is of type #; EKUCEC only works with character col"
"umns. RECNO = #; SEGNO = #; EK = #.", (ftnlen)95);
errch_("#", column, (ftnlen)1, column_len);
errint_("#", &dtype, (ftnlen)1);
errint_("#", recno, (ftnlen)1);
errint_("#", segno, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(WRONGDATATYPE)", (ftnlen)20);
chkout_("EKUCEC", (ftnlen)6);
return 0;
}
/* Look up the record pointer for the target record. */
zzektrdp_(handle, &segdsc[6], recno, &recptr);
/* Determine whether the EK is shadowed. */
ekshdw_(handle, &isshad);
/* If the EK is shadowed, we must back up the current column entry */
/* if the entry has not already been backed up. ZZEKRBCK will */
/* handle this task. */
if (isshad) {
zzekrbck_("UPDATE", handle, segdsc, coldsc, recno, (ftnlen)6);
}
/* Now it's time to carry out the replacement. */
class__ = coldsc[0];
if (class__ == 3) {
/* Class 3 columns contain scalar character data. */
zzekue03_(handle, segdsc, coldsc, &recptr, cvals, isnull, cvals_len);
} else if (class__ == 6) {
/* Class 6 columns contain array-valued character data. */
zzekue06_(handle, segdsc, coldsc, &recptr, nvals, cvals, isnull,
cvals_len);
} else {
/* This is an unsupported character column class. */
*segno = segdsc[1];
chkin_("EKUCEC", (ftnlen)6);
dashlu_(handle, &unit);
setmsg_("Class # from input column descriptor is not a supported cha"
"racter class. COLUMN = #; RECNO = #; SEGNO = #; EK = #.", (
ftnlen)115);
errint_("#", &class__, (ftnlen)1);
errch_("#", column, (ftnlen)1, column_len);
errint_("#", recno, (ftnlen)1);
errint_("#", segno, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(NOCLASS)", (ftnlen)14);
chkout_("EKUCEC", (ftnlen)6);
return 0;
}
return 0;
} /* ekucec_ */
/* $Procedure ZZSPKAS0 ( SPK, apparent state ) */
/* Subroutine */ int zzspkas0_(integer *targ, doublereal *et, char *ref, char
*abcorr, doublereal *stobs, doublereal *accobs, doublereal *starg,
doublereal *lt, doublereal *dlt, ftnlen ref_len, ftnlen abcorr_len)
{
/* Initialized data */
static logical first = TRUE_;
static char prvcor[5] = " ";
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int vadd_(doublereal *, doublereal *, doublereal *
), zzspklt0_(integer *, doublereal *, char *, char *, doublereal *
, doublereal *, doublereal *, doublereal *, ftnlen, ftnlen);
static logical xmit;
extern /* Subroutine */ int vequ_(doublereal *, doublereal *), zzstelab_(
logical *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), zzprscor_(char *, logical *, ftnlen);
integer refid;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
doublereal pcorr[3];
static logical uselt;
extern logical failed_(void);
logical attblk[15];
doublereal dpcorr[3], corvel[3];
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), irfnum_(char *, integer *, ftnlen), setmsg_(char *,
ftnlen);
doublereal corpos[3];
extern logical return_(void);
static logical usestl;
/* $ Abstract */
/* Given the state and acceleration of an observer relative to the */
/* solar system barycenter, return the state (position and velocity) */
/* of a target body relative to the observer, optionally corrected */
/* for light time and stellar aberration. All input and output */
/* vectors are expressed relative to an inertial reference frame. */
/* This routine supersedes SPKAPP. */
/* SPICE users normally should call the high-level API routines */
/* SPKEZR or SPKEZ rather than this routine. */
/* $ 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 */
/* Include file zzabcorr.inc */
/* SPICE private file intended solely for the support of SPICE */
/* routines. Users should not include this file directly due */
/* to the volatile nature of this file */
/* The parameters below define the structure of an aberration */
/* correction attribute block. */
/* $ 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 */
/* An aberration correction attribute block is an array of logical */
/* flags indicating the attributes of the aberration correction */
/* specified by an aberration correction string. The attributes */
/* are: */
/* - Is the correction "geometric"? */
/* - Is light time correction indicated? */
/* - Is stellar aberration correction indicated? */
/* - Is the light time correction of the "converged */
/* Newtonian" variety? */
/* - Is the correction for the transmission case? */
/* - Is the correction relativistic? */
/* The parameters defining the structure of the block are as */
/* follows: */
/* NABCOR Number of aberration correction choices. */
/* ABATSZ Number of elements in the aberration correction */
/* block. */
/* GEOIDX Index in block of geometric correction flag. */
/* LTIDX Index of light time flag. */
/* STLIDX Index of stellar aberration flag. */
/* CNVIDX Index of converged Newtonian flag. */
/* XMTIDX Index of transmission flag. */
/* RELIDX Index of relativistic flag. */
/* The following parameter is not required to define the block */
/* structure, but it is convenient to include it here: */
/* CORLEN The maximum string length required by any aberration */
/* correction string */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 18-DEC-2004 (NJB) */
/* -& */
/* Number of aberration correction choices: */
/* Aberration correction attribute block size */
/* (number of aberration correction attributes): */
/* Indices of attributes within an aberration correction */
/* attribute block: */
/* Maximum length of an aberration correction string: */
/* End of include file zzabcorr.inc */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* TARG I Target body. */
/* ET I Observer epoch. */
/* REF I Inertial reference frame of output state. */
/* ABCORR I Aberration correction flag. */
/* STOBS I State of the observer relative to the SSB. */
/* ACCOBS I Acceleration of the observer relative to the SSB. */
/* STARG O State of target. */
/* LT O One way light time between observer and target. */
/* DLT O Derivative of light time with respect to time. */
/* $ Detailed_Input */
/* TARG is the NAIF ID code for a target body. The target */
/* and observer define a state vector whose position */
/* component points from the observer to the target. */
/* ET is the ephemeris time, expressed as seconds past */
/* J2000 TDB, at which the state of the target body */
/* relative to the observer is to be computed. ET */
/* refers to time at the observer's location. */
/* REF is the inertial reference frame with respect to which */
/* the input state STOBS, the input acceleration ACCOBS, */
/* and the output state STARG are expressed. REF must be */
/* recognized by the SPICE Toolkit. The acceptable */
/* frames are listed in the Frames Required Reading, as */
/* well as in the SPICELIB routine CHGIRF. */
/* Case and blanks are not significant in the string */
/* REF. */
/* ABCORR indicates the aberration corrections to be applied */
/* to the state of the target body to account for one-way */
/* light time and stellar aberration. See the discussion */
/* in the header of SPKEZR for recommendations on */
/* how to choose aberration corrections. */
/* ABCORR may be any of the following: */
/* 'NONE' Apply no correction. Return the */
/* geometric state of the target body */
/* relative to the observer. */
/* The following values of ABCORR apply to the */
/* "reception" case in which photons depart from the */
/* target's location at the light-time corrected epoch */
/* ET-LT and *arrive* at the observer's location at ET: */
/* 'LT' Correct for one-way light time (also */
/* called "planetary aberration") using a */
/* Newtonian formulation. This correction */
/* yields the state of the target at the */
/* moment it emitted photons arriving at */
/* the observer at ET. */
/* The light time correction uses an */
/* iterative solution of the light time */
/* equation (see Particulars for details). */
/* The solution invoked by the 'LT' option */
/* uses one iteration. */
/* 'LT+S' Correct for one-way light time and */
/* stellar aberration using a Newtonian */
/* formulation. This option modifies the */
/* state obtained with the 'LT' option to */
/* account for the observer's velocity */
/* relative to the solar system */
/* barycenter. The result is the apparent */
/* state of the target---the position and */
/* velocity of the target as seen by the */
/* observer. */
/* 'CN' Converged Newtonian light time */
/* correction. In solving the light time */
/* equation, the 'CN' correction iterates */
/* until the solution converges (three */
/* iterations on all supported platforms). */
/* Whether the 'CN+S' solution is */
/* substantially more accurate than the */
/* 'LT' solution depends on the geometry */
/* of the participating objects and on the */
/* accuracy of the input data. In all */
/* cases this routine will execute more */
/* slowly when a converged solution is */
/* computed. See the Particulars section of */
/* SPKEZR for a discussion of precision of */
/* light time corrections. */
/* 'CN+S' Converged Newtonian light time */
/* correction and stellar aberration */
/* correction. */
/* The following values of ABCORR apply to the */
/* "transmission" case in which photons *depart* from */
/* the observer's location at ET and arrive at the */
/* target's location at the light-time corrected epoch */
/* ET+LT: */
/* 'XLT' "Transmission" case: correct for */
/* one-way light time using a Newtonian */
/* formulation. This correction yields the */
/* state of the target at the moment it */
/* receives photons emitted from the */
/* observer's location at ET. */
/* 'XLT+S' "Transmission" case: correct for */
/* one-way light time and stellar */
/* aberration using a Newtonian */
/* formulation This option modifies the */
/* state obtained with the 'XLT' option to */
/* account for the observer's velocity */
/* relative to the solar system */
/* barycenter. The position component of */
/* the computed target state indicates the */
/* direction that photons emitted from the */
/* observer's location must be "aimed" to */
/* hit the target. */
/* 'XCN' "Transmission" case: converged */
/* Newtonian light time correction. */
/* 'XCN+S' "Transmission" case: converged */
/* Newtonian light time correction and */
/* stellar aberration correction. */
/* Neither special nor general relativistic effects are */
/* accounted for in the aberration corrections applied */
/* by this routine. */
/* Case and blanks are not significant in the string */
/* ABCORR. */
/* STOBS is the geometric state of the observer relative to */
/* the solar system barycenter at ET. STOBS is expressed */
/* relative to the reference frame designated by REF. */
/* The target and observer define a state vector whose */
/* position component points from the observer to the */
/* target. */
/* ACCOBS is the geometric acceleration of the observer */
/* relative to the solar system barycenter at ET. This */
/* is the derivative with respect to time of the */
/* velocity portion of STOBS. ACCOBS is expressed */
/* relative to the reference frame designated by REF. */
/* ACCOBS is used for computing stellar aberration */
/* corrected velocity. If stellar aberration corrections */
/* are not specified by ABCORR, ACCOBS is ignored; the */
/* caller need not provide a valid input value in this */
/* case. */
/* $ Detailed_Output */
/* STARG is a Cartesian state vector representing the position */
/* and velocity of the target body relative to the */
/* specified observer. STARG is corrected for the */
/* specified aberrations, and is expressed with respect */
/* to the inertial reference frame designated by REF. */
/* The first three components of STARG represent the x-, */
/* y- and z-components of the target's position; last */
/* three components form the corresponding velocity */
/* vector. */
/* The position component of STARG points from the */
/* observer's location at ET to the aberration-corrected */
/* location of the target. Note that the sense of the */
/* position vector is independent of the direction of */
/* radiation travel implied by the aberration */
/* correction. */
/* Units are always km and km/sec. */
/* LT is the one-way light time between the observer and */
/* target in seconds. If the target state is corrected */
/* for light time, then LT is the one-way light time */
/* between the observer and the light time-corrected */
/* target location. */
/* DLT is the derivative with respect to barycentric */
/* dynamical time of the one way light time between */
/* target and observer: */
/* DLT = d(LT)/d(ET) */
/* DLT can also be described as the rate of change of */
/* one way light time. DLT is unitless, since LT and */
/* ET both have units of TDB seconds. */
/* If the observer and target are at the same position, */
/* then DLT is set to zero. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the value of ABCORR is not recognized, the error */
/* is diagnosed by a routine in the call tree of this */
/* routine. */
/* 2) If ABCORR calls for stellar aberration but not light */
/* time corrections, the error SPICE(NOTSUPPORTED) is */
/* signaled. */
/* 3) If ABCORR calls for relativistic light time corrections, the */
/* error SPICE(NOTSUPPORTED) is signaled. */
/* 4) If the reference frame requested is not a recognized */
/* inertial reference frame, the error SPICE(BADFRAME) */
/* is signaled. */
/* 5) If the state of the target relative to the solar system */
/* barycenter cannot be computed, the error will be diagnosed */
/* by routines in the call tree of this routine. */
/* 6) If the observer and target are at the same position, */
/* then DLT is set to zero. This situation could arise, */
/* for example, when the observer is Mars and the target */
/* is the Mars barycenter. */
/* $ Files */
/* This routine computes states using SPK files that have been */
/* loaded into the SPICE system, normally via the kernel loading */
/* interface routine FURNSH. Application programs typically load */
/* kernels once before this routine is called, for example during */
/* program initialization; kernels need not be loaded repeatedly. */
/* See the routine FURNSH and the SPK and KERNEL Required Reading */
/* for further information on loading (and unloading) kernels. */
/* If any of the ephemeris data used to compute STARG are expressed */
/* relative to a non-inertial frame in the SPK files providing those */
/* data, additional kernels may be needed to enable the reference */
/* frame transformations required to compute the state. Normally */
/* these additional kernels are PCK files or frame kernels. Any such */
/* kernels must already be loaded at the time this routine is */
/* called. */
/* $ Particulars */
/* This routine supports higher-level SPK API routines that can */
/* perform both light time and stellar aberration corrections. */
/* User applications normally will not need to call this routine */
/* directly. However, this routine can improve run-time efficiency */
/* in situations where many targets are observed from the same */
/* location at the same time. In such cases, the state and */
/* acceleration of the observer relative to the solar system */
/* barycenter need be computed only once per look-up epoch. */
/* When apparent positions, rather than apparent states, are */
/* required, consider using the high-level position-only API */
/* routines */
/* SPKPOS */
/* SPKEZP */
/* or the low-level, position-only analog of this routine */
/* SPKAPO */
/* In general, the position-only routines are more efficient. */
/* See the header of the routine SPKEZR for a detailed discussion */
/* of aberration corrections. */
/* $ Examples */
/* 1) Look up a sequence of states of the Moon as seen from the */
/* Earth. Use light time and stellar aberration corrections. */
/* Compute the first state for the epoch 2000 JAN 1 12:00:00 TDB; */
/* compute subsequent states at intervals of 1 hour. For each */
/* epoch, display the states, the one way light time between */
/* target and observer, and the rate of change of the one way */
/* light time. */
/* Use the following meta-kernel to specify the kernels to */
/* load: */
/* KPL/MK */
/* This meta-kernel is intended to support operation of SPICE */
/* example programs. The kernels shown here should not be */
/* assumed to contain adequate or correct versions of data */
/* required by SPICE-based user applications. */
/* In order for an application to use this meta-kernel, the */
/* kernels referenced here must be present in the user's */
/* current working directory. */
/* \begindata */
/* KERNELS_TO_LOAD = ( 'de418.bsp', */
/* 'pck00008.tpc', */
/* 'naif0008.tls' ) */
/* \begintext */
/* The code example follows: */
/* PROGRAM EX1 */
/* IMPLICIT NONE */
/* C */
/* C Local constants */
/* C */
/* C The meta-kernel name shown here refers to a file whose */
/* C contents are those shown above. This file and the kernels */
/* C it references must exist in your current working directory. */
/* C */
/* CHARACTER*(*) META */
/* PARAMETER ( META = 'example.mk' ) */
/* C */
/* C Use a time step of 1 hour; look up 5 states. */
/* C */
/* DOUBLE PRECISION STEP */
/* PARAMETER ( STEP = 3600.0D0 ) */
/* INTEGER MAXITR */
/* PARAMETER ( MAXITR = 5 ) */
/* C */
/* C Local variables */
/* C */
/* DOUBLE PRECISION ACC ( 3 ) */
/* DOUBLE PRECISION DLT */
/* DOUBLE PRECISION ET */
/* DOUBLE PRECISION ET0 */
/* DOUBLE PRECISION LT */
/* DOUBLE PRECISION STATE ( 6 ) */
/* DOUBLE PRECISION STATE0 ( 6 ) */
/* DOUBLE PRECISION STATE2 ( 6 ) */
/* DOUBLE PRECISION STOBS ( 6 ) */
/* DOUBLE PRECISION TDELTA */
/* INTEGER I */
/* C */
/* C Load the SPK and LSK kernels via the meta-kernel. */
/* C */
/* CALL FURNSH ( META ) */
/* C */
/* C Convert the start time to seconds past J2000 TDB. */
/* C */
/* CALL STR2ET ( '2000 JAN 1 12:00:00 TDB', ET0 ) */
/* C */
/* C Step through a series of epochs, looking up a */
/* C state vector at each one. */
/* C */
/* DO I = 1, MAXITR */
/* ET = ET0 + (I-1)*STEP */
/* C */
/* C Look up a state vector at epoch ET using the */
/* C following inputs: */
/* C */
/* C Target: Moon (NAIF ID code 301) */
/* C Reference frame: J2000 */
/* C Aberration correction: Light time and stellar */
/* C aberration ('LT+S') */
/* C Observer: Earth (NAIF ID code 399) */
/* C */
/* C Before we can execute this computation, we'll need the */
/* C geometric state and accleration of the observer relative */
/* C to the solar system barycenter at ET, expressed */
/* C relative to the J2000 reference frame. First find */
/* C the state: */
/* C */
/* CALL SPKSSB ( 399, ET, 'J2000', STOBS ) */
/* C */
/* C Next compute the acceleration. We numerically */
/* C differentiate the velocity using a quadratic */
/* C approximation: */
/* C */
/* TDELTA = 1.D0 */
/* CALL SPKSSB ( 399, ET-TDELTA, 'J2000', STATE0 ) */
/* CALL SPKSSB ( 399, ET+TDELTA, 'J2000', STATE2 ) */
/* CALL QDERIV ( 3, STATE0(4), STATE2(4), TDELTA, ACC ) */
/* C */
/* C Now compute the desired state vector: */
/* C */
/* CALL SPKAPS ( 301, ET, 'J2000', 'LT+S', */
/* . STOBS, ACC, STATE, LT, DLT ) */
/* WRITE (*,*) 'ET = ', ET */
/* WRITE (*,*) 'J2000 x-position (km): ', STATE(1) */
/* WRITE (*,*) 'J2000 y-position (km): ', STATE(2) */
/* WRITE (*,*) 'J2000 z-position (km): ', STATE(3) */
/* WRITE (*,*) 'J2000 x-velocity (km/s): ', STATE(4) */
/* WRITE (*,*) 'J2000 y-velocity (km/s): ', STATE(5) */
/* WRITE (*,*) 'J2000 z-velocity (km/s): ', STATE(6) */
/* WRITE (*,*) 'One-way light time (s): ', LT */
/* WRITE (*,*) 'Light time rate: ', DLT */
/* WRITE (*,*) ' ' */
/* END DO */
/* END */
/* The output produced by this program will vary somewhat as */
/* a function of the platform on which the program is built and */
/* executed. On a PC/Linux/g77 platform, the following output */
/* was produced: */
/* ET = 0. */
/* J2000 x-position (km): -291584.614 */
/* J2000 y-position (km): -266693.406 */
/* J2000 z-position (km): -76095.6532 */
/* J2000 x-velocity (km/s): 0.643439157 */
/* J2000 y-velocity (km/s): -0.666065874 */
/* J2000 z-velocity (km/s): -0.301310063 */
/* One-way light time (s): 1.34231061 */
/* Light time rate: 1.07316909E-07 */
/* ET = 3600. */
/* J2000 x-position (km): -289256.459 */
/* J2000 y-position (km): -269080.605 */
/* J2000 z-position (km): -77177.3528 */
/* J2000 x-velocity (km/s): 0.64997032 */
/* J2000 y-velocity (km/s): -0.660148253 */
/* J2000 z-velocity (km/s): -0.299630418 */
/* One-way light time (s): 1.34269395 */
/* Light time rate: 1.05652599E-07 */
/* ET = 7200. */
/* J2000 x-position (km): -286904.897 */
/* J2000 y-position (km): -271446.417 */
/* J2000 z-position (km): -78252.9655 */
/* J2000 x-velocity (km/s): 0.656443883 */
/* J2000 y-velocity (km/s): -0.654183552 */
/* J2000 z-velocity (km/s): -0.297928533 */
/* One-way light time (s): 1.34307131 */
/* Light time rate: 1.03990457E-07 */
/* ET = 10800. */
/* J2000 x-position (km): -284530.133 */
/* J2000 y-position (km): -273790.671 */
/* J2000 z-position (km): -79322.4117 */
/* J2000 x-velocity (km/s): 0.662859505 */
/* J2000 y-velocity (km/s): -0.648172247 */
/* J2000 z-velocity (km/s): -0.296204558 */
/* One-way light time (s): 1.34344269 */
/* Light time rate: 1.02330665E-07 */
/* ET = 14400. */
/* J2000 x-position (km): -282132.378 */
/* J2000 y-position (km): -276113.202 */
/* J2000 z-position (km): -80385.612 */
/* J2000 x-velocity (km/s): 0.669216846 */
/* J2000 y-velocity (km/s): -0.642114815 */
/* J2000 z-velocity (km/s): -0.294458645 */
/* One-way light time (s): 1.3438081 */
/* Light time rate: 1.00673404E-07 */
/* $ Restrictions */
/* 1) This routine should not be used to compute geometric states. */
/* Instead, use SPKEZR, SPKEZ, or SPKGEO. SPKGEO, which is called */
/* by SPKEZR and SPKEZ, introduces less round-off error when the */
/* observer and target have a common center that is closer to */
/* both objects than is the solar system barycenter. */
/* 2) The kernel files to be used by SPKAPS must be loaded */
/* (normally by the SPICELIB kernel loader FURNSH) before */
/* this routine is called. */
/* 3) Unlike most other SPK state computation routines, this */
/* routine requires that the output state be relative to an */
/* inertial reference frame. */
/* $ Literature_References */
/* SPK Required Reading. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.0, 04-JUL-2014 (NJB) */
/* Discussion of light time corrections was updated. Assertions */
/* that converged light time corrections are unlikely to be */
/* useful were removed. */
/* Last update was 15-APR-2014 (NJB) */
/* Added a FAILED() call to prevent numeric problems */
/* resulting from uninitialized values. */
/* - SPICELIB Version 1.0.0, 11-JAN-2008 (NJB) */
/* -& */
/* $ Index_Entries */
/* low-level aberration-corrected state computation */
/* low-level light time and stellar aberration correction */
/* -& */
/* $ Revisions */
/* None. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Saved variables */
/* Initial values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
chkin_("ZZSPKAS0", (ftnlen)8);
if (first || s_cmp(abcorr, prvcor, abcorr_len, (ftnlen)5) != 0) {
/* The aberration correction flag differs from the value it */
/* had on the previous call, if any. Analyze the new flag. */
zzprscor_(abcorr, attblk, abcorr_len);
if (failed_()) {
chkout_("ZZSPKAS0", (ftnlen)8);
return 0;
}
/* The aberration correction flag is recognized; save it. */
s_copy(prvcor, abcorr, (ftnlen)5, abcorr_len);
/* Set logical flags indicating the attributes of the requested */
/* correction: */
/* XMIT is .TRUE. when the correction is for transmitted */
/* radiation. */
/* USELT is .TRUE. when any type of light time correction */
/* (normal or converged Newtonian) is specified. */
/* USECN indicates converged Newtonian light time correction. */
/* The above definitions are consistent with those used by */
/* ZZPRSCOR. */
xmit = attblk[4];
uselt = attblk[1];
usestl = attblk[2];
if (usestl && ! uselt) {
setmsg_("Aberration correction flag # calls for stellar aberrati"
"on but not light time corrections. This combination is n"
"ot expected.", (ftnlen)123);
errch_("#", abcorr, (ftnlen)1, abcorr_len);
sigerr_("SPICE(NOTSUPPORTED)", (ftnlen)19);
chkout_("ZZSPKAS0", (ftnlen)8);
return 0;
} else if (attblk[5]) {
setmsg_("Aberration correction flag # calls for relativistic lig"
"ht time correction.", (ftnlen)74);
errch_("#", abcorr, (ftnlen)1, abcorr_len);
sigerr_("SPICE(NOTSUPPORTED)", (ftnlen)19);
chkout_("ZZSPKAS0", (ftnlen)8);
return 0;
}
first = FALSE_;
}
/* See if the reference frame is a recognized inertial frame. */
irfnum_(ref, &refid, ref_len);
if (refid == 0) {
setmsg_("The requested frame '#' is not a recognized inertial frame. "
, (ftnlen)60);
errch_("#", ref, (ftnlen)1, ref_len);
sigerr_("SPICE(BADFRAME)", (ftnlen)15);
chkout_("ZZSPKAS0", (ftnlen)8);
return 0;
}
/* Get the state of the target relative to the observer, */
/* optionally corrected for light time. */
zzspklt0_(targ, et, ref, abcorr, stobs, starg, lt, dlt, ref_len,
abcorr_len);
if (failed_()) {
chkout_("ZZSPKAS0", (ftnlen)8);
return 0;
}
/* If stellar aberration corrections are not needed, we're */
/* already done. */
if (! usestl) {
chkout_("ZZSPKAS0", (ftnlen)8);
return 0;
}
/* Get the stellar aberration correction and its time derivative. */
zzstelab_(&xmit, accobs, &stobs[3], starg, pcorr, dpcorr);
/* Adding the stellar aberration correction to the light */
/* time-corrected target position yields the position corrected for */
/* both light time and stellar aberration. */
vadd_(pcorr, starg, corpos);
vequ_(corpos, starg);
/* Velocity is treated in an analogous manner. */
vadd_(dpcorr, &starg[3], corvel);
vequ_(corvel, &starg[3]);
chkout_("ZZSPKAS0", (ftnlen)8);
return 0;
} /* zzspkas0_ */
/* $Procedure SGFPKT ( Generic Segment: Fetch data packets ) */
/* Subroutine */ int sgfpkt_(integer *handle, doublereal *descr, integer *
first, integer *last, doublereal *values, integer *ends)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer size, b, e, i__;
extern /* Subroutine */ int chkin_(char *, ftnlen);
doublereal dtemp[2];
integer begin1, begin2;
extern /* Subroutine */ int dafgda_(integer *, integer *, integer *,
doublereal *);
extern logical failed_(void);
extern /* Subroutine */ int sgmeta_(integer *, doublereal *, integer *,
integer *), sigerr_(char *, ftnlen);
integer mypdrb;
extern /* Subroutine */ int chkout_(char *, ftnlen);
integer soffst;
extern /* Subroutine */ int setmsg_(char *, ftnlen);
integer mypktb, voffst;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
integer mynpdr;
extern logical return_(void);
integer mypdrt, mynpkt, mypkto, mypksz;
/* $ Abstract */
/* Given the descriptor for a generic segment in a DAF file */
/* associated with HANDLE, fetch the data packets indexed from FIRST */
/* to LAST from the packet partition of the generic segment. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* DAF Required Reading */
/* $ Keywords */
/* GENERIC SEGMENTS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* HANDLE I The file handle attached to an open DAF. */
/* DESCR I The descriptor associated with a generic segment. */
/* FIRST I The index of the first data packet to fetch. */
/* LAST I The index of the last data packet to fetch. */
/* VALUES O The data packets that have been fetched. */
/* ENDS O An array of pointers to the ends of the packets. */
/* $ Detailed_Input */
/* HANDLE is the handle of a DAF opened for reading that */
/* contains the segment described by DESCR. */
/* DESCR is the descriptor of the segment with the desired */
/* constant values. This must be the descriptor for a */
/* generic segment in the DAF associated with HANDLE. */
/* FIRST is the index of the first value to fetch from the */
/* constants section of the DAF segment described */
/* by DESCR. */
/* LAST is the index of the last value to fetch from the */
/* constants section of the DAF segment described */
/* by DESCR */
/* $ Detailed_Output */
/* VALUES is the array of values constructed by concatenating */
/* requested packets one after the other into */
/* an array. Pictorially we can represent VALUES */
/* as: */
/* +--------------------------+ */
/* | first requested packet | */
/* +--------------------------+ */
/* | second requested packet | */
/* +--------------------------+ */
/* . */
/* . */
/* . */
/* +--------------------------+ */
/* | first requested packet | */
/* +--------------------------+ */
/* ENDS is an array of pointers to the ends of the */
/* fetched packets. ENDS(1) gives the index */
/* of the last item of the first packet fetched. */
/* ENDS(2) gives the index of the last item of */
/* the second packet fetched, etc. */
/* $ Parameters */
/* This subroutine makes use of parameters defined in the file */
/* 'sgparam.inc'. */
/* $ Files */
/* See the description of HANDLE above. */
/* $ Exceptions */
/* 1) The error SPICE(REQUESTOUTOFBOUNDS) will be signalled */
/* if FIRST is less than 1 or LAST is greater than the */
/* number of packets. */
/* 2) The error SPICE(REQUESTOUTOFORDER) will be signalled */
/* if LAST is less than FIRST. */
/* 3) The error SPICE(UNKNOWNPACKETDIR) will be signalled if */
/* the packet directory structure is unrecognized. The most */
/* likely cause of this error is that an upgrade to your */
/* version of the SPICE toolkit is needed. */
/* $ Particulars */
/* This routine fetches requested packets from a generic */
/* DAF segment. The two arrays returned have the following */
/* relationship to one another. The first packet returned */
/* resides in VALUES between indexes 1 and ENDS(1). If a */
/* second packet is returned it resides in VALUES between */
/* indices ENDS(1)+1 and ENDS(2). This relations ship is */
/* repeated so that if I is greater than 1 and at least I */
/* packets were returned then the I'th packet resides in */
/* VALUES between index ENDS(I-1) + 1 and ENDS(I). */
/* $ Examples */
/* Suppose that you have located a generic DAF segment (as */
/* identified by the contents of a segment descriptor). The */
/* fragment of code below shows how you could fetch packets */
/* 3 through 7 (assuming that many packets are present). */
/* from the segment. */
/* Declarations: */
/* DOUBLE PRECISION MYPKSZ (<enough room to hold all packets>) */
/* INTEGER ENDS ( 5 ) */
/* INTEGER MYNPKT */
/* get the number of packets */
/* CALL SGMETA ( HANDLE, DESCR, NPKT, MYNPKT ) */
/* finally, fetch the packets from the segment. */
/* IF ( 7 .LE. MYNPKT ) THEN */
/* CALL SGFPKT ( HANDLE, DESCR, 3, 7, MYPKSZ, ENDS ) */
/* END IF */
/* $ Restrictions */
/* The segment described by DESCR must be a generic segment, */
/* otherwise the results of this routine are not predictable. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* W.L. Taber (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.2.0, 07-SEP-2001 (EDW) */
/* Replaced DAFRDA calls with DAFGDA. */
/* - SPICELIB Version 1.1.0, 30-JUL-1996 (KRG) (NJB) */
/* Found and fixed a bug in the calculation of the beginning */
/* address for variable length packet fetching. The base address */
/* for the packet directory was not added into the value. This */
/* bug went unnoticed because of a bug in SGSEQW, entry SGWES, */
/* that put absolute addresses into the packet directory rather */
/* than addresses that were relative to the start of the DAF */
/* array. The bug in SGSEQW has also been fixed. */
/* - SPICELIB Version 1.0.0, 06-JAN-1994 (KRG) (WLT) */
/* -& */
/* $ Index_Entries */
/* fetch packets from a generic segment */
/* -& */
/* Spicelib Functions */
/* Local Parameters */
/* Include the mnemonic values. */
/* Local Variables */
/* $ Abstract */
/* Parameter declarations for the generic segments subroutines. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* DAF Required Reading */
/* $ Keywords */
/* GENERIC SEGMENTS */
/* $ Particulars */
/* This include file contains the parameters used by the generic */
/* segments subroutines, SGxxxx. A generic segment is a */
/* generalization of a DAF array which places a particular structure */
/* on the data contained in the array, as described below. */
/* This file defines the mnemonics that are used for the index types */
/* allowed in generic segments as well as mnemonics for the meta data */
/* items which are used to describe a generic segment. */
/* A DAF generic segment contains several logical data partitions: */
/* 1) A partition for constant values to be associated with each */
/* data packet in the segment. */
/* 2) A partition for the data packets. */
/* 3) A partition for reference values. */
/* 4) A partition for a packet directory, if the segment contains */
/* variable sized packets. */
/* 5) A partition for a reference value directory. */
/* 6) A reserved partition that is not currently used. This */
/* partition is only for the use of the NAIF group at the Jet */
/* Propulsion Laboratory (JPL). */
/* 7) A partition for the meta data which describes the locations */
/* and sizes of other partitions as well as providing some */
/* additional descriptive information about the generic */
/* segment. */
/* +============================+ */
/* | Constants | */
/* +============================+ */
/* | Packet 1 | */
/* |----------------------------| */
/* | Packet 2 | */
/* |----------------------------| */
/* | . | */
/* | . | */
/* | . | */
/* |----------------------------| */
/* | Packet N | */
/* +============================+ */
/* | Reference Values | */
/* +============================+ */
/* | Packet Directory | */
/* +============================+ */
/* | Reference Directory | */
/* +============================+ */
/* | Reserved Area | */
/* +============================+ */
/* | Segment Meta Data | */
/* +----------------------------+ */
/* Only the placement of the meta data at the end of a generic */
/* segment is required. The other data partitions may occur in any */
/* order in the generic segment because the meta data will contain */
/* pointers to their appropriate locations within the generic */
/* segment. */
/* The meta data for a generic segment should only be obtained */
/* through use of the subroutine SGMETA. The meta data should not be */
/* written through any mechanism other than the ending of a generic */
/* segment begun by SGBWFS or SGBWVS using SGWES. */
/* $ Restrictions */
/* 1) If new reference index types are added, the new type(s) should */
/* be defined to be the consecutive integer(s) after the last */
/* defined reference index type used. In this way a value for */
/* the maximum allowed index type may be maintained. This value */
/* must also be updated if new reference index types are added. */
/* 2) If new meta data items are needed, mnemonics for them must be */
/* added to the end of the current list of mnemonics and before */
/* the NMETA mnemonic. In this way compatibility with files having */
/* a different, but smaller, number of meta data items may be */
/* maintained. See the description and example below. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* K.R. Gehringer (JPL) */
/* W.L. Taber (JPL) */
/* F.S. Turner (JPL) */
/* $ Literature_References */
/* Generic Segments Required Reading. */
/* DAF Required Reading. */
/* $ Version */
/* - SPICELIB Version 1.1.1, 28-JAN-2004 (NJB) */
/* Header update: equations for comptutations of packet indices */
/* for the cases of index types 0 and 1 were corrected. */
/* - SPICELIB Version 1.1.0, 25-09-98 (FST) */
/* Added parameter MNMETA, the minimum number of meta data items */
/* that must be present in a generic DAF segment. */
/* - SPICELIB Version 1.0.0, 04-03-95 (KRG) (WLT) */
/* -& */
/* Mnemonics for the type of reference value index. */
/* Two forms of indexing are provided: */
/* 1) An implicit form of indexing based on using two values, a */
/* starting value, which will have an index of 1, and a step */
/* size between reference values, which are used to compute an */
/* index and a reference value associated with a specified key */
/* value. See the descriptions of the implicit types below for */
/* the particular formula used in each case. */
/* 2) An explicit form of indexing based on a reference value for */
/* each data packet. */
/* Reference Index Type 0 */
/* ---------------------- */
/* Implied index. The index and reference value of a data packet */
/* associated with a specified key value are computed from the two */
/* generic segment reference values using the formula below. The two */
/* generic segment reference values, REF(1) and REF(2), represent, */
/* respectively, a starting value and a step size between reference */
/* values. The index of the data packet associated with a key value */
/* of VALUE is given by: */
/* / VALUE - REF(1) \ */
/* INDEX = 1 + INT | -------------------- | */
/* \ REF(2) / */
/* and the reference value associated with VALUE is given by: */
/* REFVAL = REF(1) + DBLE (INDEX-1) * REF(2) */
/* Reference Index Type 1 */
/* ---------------------- */
/* Implied index. The index and reference value of a data packet */
/* associated with a specified key value are computed from the two */
/* generic segment reference values using the formula below. The two */
/* generic segment reference values, REF(1) and REF(2), represent, */
/* respectively, a starting value and a step size between reference */
/* values. The index of the data packet associated with a key value */
/* of VALUE is given by: */
/* / VALUE - REF(1) \ */
/* INDEX = 1 + INT | 0.5 + -------------------- | */
/* \ REF(2) / */
/* and the reference value associated with VALUE is given by: */
/* REFVAL = REF(1) + DBLE (INDEX-1) * REF(2) */
/* We get the larger index in the event that VALUE is halfway between */
/* X(I) and X(I+1), where X(I) = BUFFER(1) + DBLE (I-1) * REFDAT(2). */
/* Reference Index Type 2 */
/* ---------------------- */
/* Explicit index. In this case the number of packets must equal the */
/* number of reference values. The index of the packet associated */
/* with a key value of VALUE is the index of the last reference item */
/* that is strictly less than VALUE. The reference values must be in */
/* ascending order, REF(I) < REF(I+1). */
/* Reference Index Type 3 */
/* ---------------------- */
/* Explicit index. In this case the number of packets must equal the */
/* number of reference values. The index of the packet associated */
/* with a key value of VALUE is the index of the last reference item */
/* that is less than or equal to VALUE. The reference values must be */
/* in ascending order, REF(I) < REF(I+1). */
/* Reference Index Type 4 */
/* ---------------------- */
/* Explicit index. In this case the number of packets must equal the */
/* number of reference values. The index of the packet associated */
/* with a key value of VALUE is the index of the reference item */
/* that is closest to the value of VALUE. In the event of a "tie" */
/* the larger index is selected. The reference values must be in */
/* ascending order, REF(I) < REF(I+1). */
/* These parameters define the valid range for the index types. An */
/* index type code, MYTYPE, for a generic segment must satisfy the */
/* relation MNIDXT <= MYTYPE <= MXIDXT. */
/* The following meta data items will appear in all generic segments. */
/* Other meta data items may be added if a need arises. */
/* 1) CONBAS Base Address of the constants in a generic segment. */
/* 2) NCON Number of constants in a generic segment. */
/* 3) RDRBAS Base Address of the reference directory for a */
/* generic segment. */
/* 4) NRDR Number of items in the reference directory of a */
/* generic segment. */
/* 5) RDRTYP Type of the reference directory 0, 1, 2 ... for a */
/* generic segment. */
/* 6) REFBAS Base Address of the reference items for a generic */
/* segment. */
/* 7) NREF Number of reference items in a generic segment. */
/* 8) PDRBAS Base Address of the Packet Directory for a generic */
/* segment. */
/* 9) NPDR Number of items in the Packet Directory of a generic */
/* segment. */
/* 10) PDRTYP Type of the packet directory 0, 1, ... for a generic */
/* segment. */
/* 11) PKTBAS Base Address of the Packets for a generic segment. */
/* 12) NPKT Number of Packets in a generic segment. */
/* 13) RSVBAS Base Address of the Reserved Area in a generic */
/* segment. */
/* 14) NRSV Number of items in the reserved area of a generic */
/* segment. */
/* 15) PKTSZ Size of the packets for a segment with fixed width */
/* data packets or the size of the largest packet for a */
/* segment with variable width data packets. */
/* 16) PKTOFF Offset of the packet data from the start of a packet */
/* record. Each data packet is placed into a packet */
/* record which may have some bookkeeping information */
/* prepended to the data for use by the generic */
/* segments software. */
/* 17) NMETA Number of meta data items in a generic segment. */
/* Meta Data Item 1 */
/* ----------------- */
/* Meta Data Item 2 */
/* ----------------- */
/* Meta Data Item 3 */
/* ----------------- */
/* Meta Data Item 4 */
/* ----------------- */
/* Meta Data Item 5 */
/* ----------------- */
/* Meta Data Item 6 */
/* ----------------- */
/* Meta Data Item 7 */
/* ----------------- */
/* Meta Data Item 8 */
/* ----------------- */
/* Meta Data Item 9 */
/* ----------------- */
/* Meta Data Item 10 */
/* ----------------- */
/* Meta Data Item 11 */
/* ----------------- */
/* Meta Data Item 12 */
/* ----------------- */
/* Meta Data Item 13 */
/* ----------------- */
/* Meta Data Item 14 */
/* ----------------- */
/* Meta Data Item 15 */
/* ----------------- */
/* Meta Data Item 16 */
/* ----------------- */
/* If new meta data items are to be added to this list, they should */
/* be added above this comment block as described below. */
/* INTEGER NEW1 */
/* PARAMETER ( NEW1 = PKTOFF + 1 ) */
/* INTEGER NEW2 */
/* PARAMETER ( NEW2 = NEW1 + 1 ) */
/* INTEGER NEWEST */
/* PARAMETER ( NEWEST = NEW2 + 1 ) */
/* and then the value of NMETA must be changed as well to be: */
/* INTEGER NMETA */
/* PARAMETER ( NMETA = NEWEST + 1 ) */
/* Meta Data Item 17 */
/* ----------------- */
/* Maximum number of meta data items. This is always set equal to */
/* NMETA. */
/* Minimum number of meta data items that must be present in a DAF */
/* generic segment. This number is to remain fixed even if more */
/* meta data items are added for compatibility with old DAF files. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
chkin_("SGFPKT", (ftnlen)6);
/* Perform the needed initialization */
sgmeta_(handle, descr, &c__12, &mynpkt);
sgmeta_(handle, descr, &c__10, &mypdrt);
sgmeta_(handle, descr, &c__16, &mypkto);
sgmeta_(handle, descr, &c__15, &mypksz);
sgmeta_(handle, descr, &c__11, &mypktb);
if (failed_()) {
chkout_("SGFPKT", (ftnlen)6);
return 0;
}
/* Perform checks on the inputs for reasonableness. */
if (*first < 1 || *last > mynpkt) {
setmsg_("The range of packets requested extends beyond the available"
" packet data. The packet data is available for indexes 1 to"
" #. You've requested data from # to #. ", (ftnlen)159);
errint_("#", &mynpkt, (ftnlen)1);
errint_("#", first, (ftnlen)1);
errint_("#", last, (ftnlen)1);
sigerr_("SPICE(REQUESTOUTOFBOUNDS)", (ftnlen)25);
chkout_("SGFPKT", (ftnlen)6);
return 0;
}
if (*last < *first) {
setmsg_("The last packet requested, #, is before the first packet re"
"quested, #. ", (ftnlen)71);
errint_("#", last, (ftnlen)1);
errint_("#", first, (ftnlen)1);
sigerr_("SPICE(REQUESTOUTOFORDER)", (ftnlen)24);
chkout_("SGFPKT", (ftnlen)6);
return 0;
}
/* We've passed the sanity tests, if the packet directory structure */
/* is recognized fetch the values and ends. We assume that we are */
/* reading data from a correctly constructed generic segment, so we */
/* do not need to worry about the type of reference index, as this is */
/* not needed to fetch a data packet. */
/* Currently, only two packet directory types are supported, and this */
/* subroutine is the only place that this is documented. The types */
/* have values zero (0) and one (1) for, respectively, fixed size */
/* packets and variable size packets. */
if (mypdrt == 0) {
/* All packets have the same size MYPKSZ so the address of the */
/* start of the first packet and end of the last packet are easily */
/* computed. */
if (mypkto == 0) {
/* Compute tha addresses for the packet data in the generic */
/* segment. */
b = mypktb + (*first - 1) * mypksz + 1;
e = mypktb + *last * mypksz;
/* Get the packet data all in one shot since we know it's */
/* contiguous. */
dafgda_(handle, &b, &e, values);
} else {
/* Compute the addresses for the packet data in the generic */
/* segment. Remember that we need to account for an offset */
/* here to get to the start of the actual data packet. */
size = mypksz + mypkto;
/* Get the packet data. Because there is an offset from the */
/* address to the start of the packet data, we need to get */
/* the data one packet at a time rather than all at once. */
i__1 = *last;
for (i__ = *first; i__ <= i__1; ++i__) {
soffst = (i__ - 1) * size + 1;
voffst = (i__ - *first) * mypksz + 1;
b = mypktb + soffst + mypkto;
e = mypktb + soffst + mypksz;
dafgda_(handle, &b, &e, &values[voffst - 1]);
if (failed_()) {
chkout_("SGFPKT", (ftnlen)6);
return 0;
}
}
}
/* Compute the ends for each of the data packets. This is the */
/* same for both of the cases above because we have fixed size */
/* data packets. */
i__1 = *last - *first + 1;
for (i__ = 1; i__ <= i__1; ++i__) {
ends[i__ - 1] = i__ * mypksz;
}
} else {
/* In addition to the other meta data items already retrieved, we */
/* will also need a few others. */
sgmeta_(handle, descr, &c__8, &mypdrb);
sgmeta_(handle, descr, &c__9, &mynpdr);
if (failed_()) {
chkout_("SGFPKT", (ftnlen)6);
return 0;
}
/* Each packet has a different size, so we need to fetch each one */
/* individually, keeping track of the ends and things. We assume */
/* that there is enough room in the array of values to hold all of */
/* the packets. For the variable packet case, however, we do not */
/* need to treat the implicit indexing and explicit indexing cases */
/* separately. */
voffst = 1;
i__1 = *last - *first + 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Compute the addresses in the generic segment for the */
/* beginning of data packets I and I+1. We need these to */
/* compute the size of the packet. */
b = mypdrb + *first + i__ - 1;
e = b + 1;
/* Get the beginning addresses for the two data packets and */
/* convert them into integers. */
dafgda_(handle, &b, &e, dtemp);
if (failed_()) {
chkout_("SGFPKT", (ftnlen)6);
return 0;
}
begin1 = (integer) dtemp[0];
begin2 = (integer) dtemp[1];
/* Compute the size of data packet I, remembering to deal with */
/* the packet offset that might be present, and the beginning */
/* and ending addresses for the packet data. */
size = begin2 - begin1 - mypkto;
b = mypktb + begin1;
e = b + size - 1;
/* Get the data for packet I. */
dafgda_(handle, &b, &e, &values[voffst - 1]);
if (failed_()) {
chkout_("SGFPKT", (ftnlen)6);
return 0;
}
/* Compute the end for packet I and store it. */
voffst += size;
ends[i__ - 1] = voffst - 1;
}
}
chkout_("SGFPKT", (ftnlen)6);
return 0;
} /* sgfpkt_ */
/* $Procedure WNCOMD ( Complement a DP window ) */
/* Subroutine */ int wncomd_(doublereal *left, doublereal *right, doublereal *
window, doublereal *result)
{
integer card, i__;
extern integer cardd_(doublereal *);
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern logical failed_(void);
extern /* Subroutine */ int scardd_(integer *, doublereal *), sigerr_(
char *, ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen),
wninsd_(doublereal *, doublereal *, doublereal *);
extern logical return_(void);
/* $ Abstract */
/* Determine the complement of a double precision window with */
/* respect to the interval [LEFT,RIGHT]. */
/* $ 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 */
/* WINDOWS */
/* $ Keywords */
/* WINDOWS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* LEFT, */
/* RIGHT I Left, right endpoints of complement interval. */
/* WINDOW I Input window. */
/* RESULT O Complement of WINDOW with respect to [LEFT,RIGHT]. */
/* $ Detailed_Input */
/* LEFT, */
/* RIGHT are the left and right endpoints of the complement */
/* interval. */
/* WINDOW is the window to be complemented. */
/* $ Detailed_Output */
/* RESULT is the output window, containing the complement */
/* of WINDOW with respect to the interval from LEFT */
/* to RIGHT. If the output window is not large enough */
/* to contain the result, as many intervals as will */
/* fit are returned. */
/* RESULT must be distinct from WINDOW. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* Mathematically, the complement of a window contains those */
/* points that are not contained in the window. That is, the */
/* complement of the set of closed intervals */
/* [ a(1), b(1) ], [ a(2), b(2) ], ..., [ a(n), b(n) ] */
/* is the set of open intervals */
/* ( -inf, a(1) ), ( b(1), a(2) ), ..., ( b(n), +inf ) */
/* Because Fortran offers no satisfactory representation of */
/* infinity, we must take the complement with respect to a */
/* finite interval. */
/* In addition, Fortran offers no satisfactory floating point */
/* representation of open intervals. Therefore, the complement */
/* of a floating point window is closure of the set theoretical */
/* complement. In short, the floating point complement of the */
/* window */
/* [ a(1), b(1) ], [ a(2), b(2) ], ..., [ a(n), b(n) ] */
/* with respect to the interval from LEFT to RIGHT is the */
/* intersection of the windows */
/* ( -inf, a(1) ], [ b(1), a(2) ], ..., [ b(n), +inf ) */
/* and */
/* [ LEFT, RIGHT ] */
/* Note that floating point intervals of measure zero (singleton */
/* intervals) in the original window are replaced by gaps of */
/* measure zero, which are filled. Thus, complementing a floating */
/* point window twice does not necessarily yield the original */
/* window. */
/* $ Examples */
/* Let WINDOW contain the intervals */
/* [ 1, 3 ] [ 7, 11 ] [ 23, 27 ] */
/* Then the floating point complement of WINDOW with respect */
/* to [2,20] contains the intervals */
/* [ 3, 7 ] [ 11, 20 ] */
/* and the complement with respect to [ 0, 100 ] contains */
/* [ 0, 1 ] [ 3, 7 ] [ 11, 23 ] [ 27, 100 ] */
/* $ Exceptions */
/* If LEFT is greater than RIGHT, the error SPICE(BADENDPOINTS) is */
/* signalled. */
/* $ Files */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* complement a d.p. window */
/* -& */
/* $ Revisions */
/* - Beta Version 1.1.0, 17-FEB-1989 (HAN) (NJB) */
/* Contents of the Required_Reading section was */
/* changed from "None." to "WINDOWS". Also, the */
/* declaration of the unused variable J was removed. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Set up the error processing. */
if (return_()) {
return 0;
}
chkin_("WNCOMD", (ftnlen)6);
/* Get the cardinality of the input window. */
card = cardd_(window);
/* Empty out the result window before proceeding. */
scardd_(&c__0, result);
/* Check to see if the input interval is valid. If it is not, signal */
/* an error and return. */
if (*left > *right) {
setmsg_("WNCOMD: Left endpoint may not exceed right endpoint.", (
ftnlen)52);
sigerr_("SPICE(BADENDPOINTS)", (ftnlen)19);
chkout_("WNCOMD", (ftnlen)6);
return 0;
}
/* There are two trivial cases: the window is empty, or it does not */
/* intersect the input interval. In either case, the complement is */
/* the entire interval. */
if (card == 0 || window[6] >= *right || window[card + 5] <= *left) {
wninsd_(left, right, result);
chkout_("WNCOMD", (ftnlen)6);
return 0;
}
/* Let WINDOW represent the set of intervals */
/* [a1,b1], [a2,b2], ..., [aN,bN] */
/* Then the closure of the complement of WINDOW in the reals is */
/* (-infinity,a1], [b1,a2], [b2,a3], ..., [bN, infinity) */
/* Thus the sequence of endpoints of WINDOW is also the sequence */
/* of finite endpoints of its complement. Moreover, these endpoints */
/* are simply "shifted" from their original positions in WINDOW. */
/* This makes finding the complement of WINDOW with respect to */
/* a given interval almost trivial. */
/* Find the first right not less than the beginning of the input */
/* interval. */
i__ = 2;
while(i__ <= card && window[i__ + 5] < *left) {
i__ += 2;
}
/* If the beginning of the input interval doesn't split an interval */
/* in the input window, the complement begins with LEFT. */
if (i__ <= card && window[i__ + 4] > *left) {
wninsd_(left, &window[i__ + 4], result);
}
/* Start schlepping endpoints [b(i),a(i+1)] from the input window */
/* to the output window. Stop when we find one of our new right */
/* endpoints exceeds the end of the input interval. */
while(! failed_() && i__ < card && window[i__ + 6] < *right) {
wninsd_(&window[i__ + 5], &window[i__ + 6], result);
i__ += 2;
}
/* If the end of the input interval doesn't split an interval */
/* in the input window, the complement ends with RIGHT. */
if (i__ <= card && window[i__ + 5] < *right) {
wninsd_(&window[i__ + 5], right, result);
}
chkout_("WNCOMD", (ftnlen)6);
return 0;
} /* wncomd_ */
/* $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_ */
