/* $Procedure CKW05 ( Write CK segment, type 5 ) */
/* Subroutine */ int ckw05_(integer *handle, integer *subtyp, integer *degree,
doublereal *begtim, doublereal *endtim, integer *inst, char *ref,
logical *avflag, char *segid, integer *n, doublereal *sclkdp,
doublereal *packts, doublereal *rate, integer *nints, doublereal *
starts, ftnlen ref_len, ftnlen segid_len)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1;
/* Local variables */
integer addr__, i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), dafps_(integer *,
integer *, doublereal *, integer *, doublereal *);
doublereal descr[5];
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen),
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 chrcod, refcod;
extern integer bsrchd_(doublereal *, integer *, doublereal *);
extern /* Subroutine */ int namfrm_(char *, integer *, ftnlen);
extern integer lastnb_(char *, ftnlen);
integer packsz;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
extern integer lstltd_(doublereal *, integer *, doublereal *);
extern logical vzerog_(doublereal *, integer *), return_(void);
integer winsiz;
extern logical odd_(integer *);
/* $ Abstract */
/* Write a type 5 segment to a CK 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 */
/* CK */
/* NAIF_IDS */
/* ROTATION */
/* TIME */
/* $ Keywords */
/* POINTING */
/* FILES */
/* $ Declarations */
/* $ Abstract */
/* Declare parameters specific to CK type 05. */
/* $ 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 */
/* CK */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 20-AUG-2002 (NJB) */
/* -& */
/* CK type 5 subtype codes: */
/* Subtype 0: Hermite interpolation, 8-element packets. Quaternion */
/* and quaternion derivatives only, no angular velocity */
/* vector provided. Quaternion elements are listed */
/* first, followed by derivatives. Angular velocity is */
/* derived from the quaternions and quaternion */
/* derivatives. */
/* Subtype 1: Lagrange interpolation, 4-element packets. Quaternion */
/* only. Angular velocity is derived by differentiating */
/* the interpolating polynomials. */
/* Subtype 2: Hermite interpolation, 14-element packets. */
/* Quaternion and angular angular velocity vector, as */
/* well as derivatives of each, are provided. The */
/* quaternion comes first, then quaternion derivatives, */
/* then angular velocity and its derivatives. */
/* Subtype 3: Lagrange interpolation, 7-element packets. Quaternion */
/* and angular velocity vector provided. The quaternion */
/* comes first. */
/* Packet sizes associated with the various subtypes: */
/* End of file ck05.inc. */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle of an CK file open for writing. */
/* SUBTYP I CK type 5 subtype code. */
/* DEGREE I Degree of interpolating polynomials. */
/* BEGTIM I Start time of interval covered by segment. */
/* ENDTIM I End time of interval covered by segment. */
/* INST I NAIF code for a s/c instrument or structure. */
/* REF I Reference frame name. */
/* AVFLAG I True if the segment will contain angular velocity. */
/* SEGID I Segment identifier. */
/* N I Number of packets. */
/* SCLKDP I Encoded SCLK times. */
/* PACKTS I Array of packets. */
/* RATE I Nominal SCLK rate in seconds per tick. */
/* NINTS I Number of intervals. */
/* STARTS I Encoded SCLK interval start times. */
/* MAXDEG P Maximum allowed degree of interpolating polynomial. */
/* $ Detailed_Input */
/* HANDLE is the file handle of a CK file that has been */
/* opened for writing. */
/* SUBTYP is an integer code indicating the subtype of the */
/* the segment to be created. */
/* DEGREE is the degree of the polynomials used to */
/* interpolate the quaternions contained in the input */
/* packets. All components of the quaternions are */
/* interpolated by polynomials of fixed degree. */
/* BEGTIM, */
/* ENDTIM are the beginning and ending encoded SCLK times */
/* for which the segment provides pointing */
/* information. BEGTIM must be less than or equal to */
/* ENDTIM, and at least one data packet must have a */
/* time tag T such that */
/* BEGTIM < T < ENDTIM */
/* - - */
/* INST is the NAIF integer code for the instrument or */
/* structure for which a segment is to be created. */
/* REF is the NAIF name for a reference frame relative to */
/* which the pointing information for INST is */
/* specified. */
/* AVFLAG is a logical flag which indicates whether or not */
/* the segment will contain angular velocity. */
/* SEGID is the segment identifier. A CK segment */
/* identifier may contain up to 40 characters. */
/* N is the number of packets in the input packet */
/* array. */
/* SCLKDP are the encoded spacecraft clock times associated */
/* with each pointing instance. These times must be */
/* strictly increasing. */
/* PACKTS contains a time-ordered array of data packets */
/* representing the orientation of INST relative to */
/* the frame REF. Each packet contains a SPICE-style */
/* quaternion and optionally, depending on the */
/* segment subtype, attitude derivative data, from */
/* which a C-matrix and an angular velocity vector */
/* may be derived. */
/* See the discussion of quaternion styles in */
/* Particulars below. */
/* The C-matrix represented by the Ith data packet is */
/* a rotation matrix that transforms the components */
/* of a vector expressed in the base frame specified */
/* by REF to components expressed in the instrument */
/* fixed frame at the time SCLKDP(I). */
/* Thus, if a vector V has components x, y, z in the */
/* base frame, then V has components x', y', z' */
/* in the instrument fixed frame where: */
/* [ x' ] [ ] [ x ] */
/* | y' | = | CMAT | | y | */
/* [ z' ] [ ] [ z ] */
/* The attitude derivative information in PACKTS(I) */
/* gives the angular velocity of the instrument fixed */
/* frame at time SCLKDP(I) with respect to the */
/* reference frame specified by REF. */
/* The direction of an angular velocity vector gives */
/* the right-handed axis about which the instrument */
/* fixed reference frame is rotating. The magnitude */
/* of the vector is the magnitude of the */
/* instantaneous velocity of the rotation, in radians */
/* per second. */
/* Packet contents and the corresponding */
/* interpolation methods depend on the segment */
/* subtype, and are as follows: */
/* Subtype 0: Hermite interpolation, 8-element */
/* packets. Quaternion and quaternion */
/* derivatives only, no angular */
/* velocity vector provided. */
/* Quaternion elements are listed */
/* first, followed by derivatives. */
/* Angular velocity is derived from */
/* the quaternions and quaternion */
/* derivatives. */
/* Subtype 1: Lagrange interpolation, 4-element */
/* packets. Quaternion only. Angular */
/* velocity is derived by */
/* differentiating the interpolating */
/* polynomials. */
/* Subtype 2: Hermite interpolation, 14-element */
/* packets. Quaternion and angular */
/* angular velocity vector, as well as */
/* derivatives of each, are provided. */
/* The quaternion comes first, then */
/* quaternion derivatives, then */
/* angular velocity and its */
/* derivatives. */
/* Subtype 3: Lagrange interpolation, 7-element */
/* packets. Quaternion and angular */
/* velocity vector provided. The */
/* quaternion comes first. */
/* Angular velocity is always specified relative to */
/* the base frame. */
/* RATE is the nominal rate of the spacecraft clock */
/* associated with INST. Units are seconds per */
/* tick. RATE is used to scale angular velocity */
/* to radians/second. */
/* NINTS is the number of intervals that the pointing */
/* instances are partitioned into. */
/* STARTS are the start times of each of the interpolation */
/* intervals. These times must be strictly increasing */
/* and must coincide with times for which the segment */
/* contains pointing. */
/* $ 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. If the value of MAXDEG is increased, */
/* the SPICELIB routine CKPFS must be changed */
/* accordingly. In particular, the size of the */
/* record passed to CKRnn and CKEnn must be */
/* increased, and comments describing the record size */
/* must be changed. */
/* $ Exceptions */
/* If any of the following exceptions occur, this routine will return */
/* without creating a new segment. */
/* 1) If HANDLE is not the handle of a C-kernel opened for writing */
/* the error will be diagnosed by routines called by this */
/* routine. */
/* 2) If the last non-blank character of SEGID occurs past index 40, */
/* the error SPICE(SEGIDTOOLONG) is signaled. */
/* 3) If SEGID contains any nonprintable characters, the error */
/* SPICE(NONPRINTABLECHARS) is signaled. */
/* 4) If the first encoded SCLK time is negative then the error */
/* SPICE(INVALIDSCLKTIME) is signaled. If any subsequent times */
/* are negative the error will be detected in exception (5). */
/* 5) If the encoded SCLK times are not strictly increasing, */
/* the error SPICE(TIMESOUTOFORDER) is signaled. */
/* 6) If the name of the reference frame is not one of those */
/* supported by the routine FRAMEX, the error */
/* SPICE(INVALIDREFFRAME) is signaled. */
/* 7) If the number of packets N is not at least 1, the error */
/* SPICE(TOOFEWPACKETS) will be signaled. */
/* 8) If NINTS, the number of interpolation intervals, is less than */
/* or equal to 0, the error SPICE(INVALIDNUMINTS) is signaled. */
/* 9) If the encoded SCLK interval start times are not strictly */
/* increasing, the error SPICE(TIMESOUTOFORDER) is signaled. */
/* 10) If an interval start time does not coincide with a time for */
/* which there is an actual pointing instance in the segment, */
/* then the error SPICE(INVALIDSTARTTIME) is signaled. */
/* 11) This routine assumes that the rotation between adjacent */
/* quaternions that are stored in the same interval has a */
/* rotation angle of THETA radians, where */
/* 0 < THETA < pi. */
/* _ */
/* The routines that evaluate the data in the segment produced */
/* by this routine cannot distinguish between rotations of THETA */
/* radians, where THETA is in the interval [0, pi), and */
/* rotations of */
/* THETA + 2 * k * pi */
/* radians, where k is any integer. These "large" rotations will */
/* yield invalid results when interpolated. You must ensure that */
/* the data stored in the segment will not be subject to this */
/* sort of ambiguity. */
/* 12) If any quaternion has magnitude zero, the error */
/* SPICE(ZEROQUATERNION) is signaled. */
/* 13) If the interpolation window size implied by DEGREE is not */
/* even, the error SPICE(INVALIDDEGREE) is signaled. The window */
/* size is DEGREE+1 for Lagrange subtypes and is (DEGREE+1)/2 */
/* for Hermite subtypes. */
/* 14) If an unrecognized subtype code is supplied, the error */
/* SPICE(NOTSUPPORTED) is signaled. */
/* 15) If DEGREE is not at least 1 or is greater than MAXDEG, the */
/* error SPICE(INVALIDDEGREE) is signaled. */
/* 16) If the segment descriptor bounds are out of order, the */
/* error SPICE(BADDESCRTIMES) is signaled. */
/* 17) If there is no element of SCLKDP that lies between BEGTIM and */
/* ENDTIM inclusive, the error SPICE(EMPTYSEGMENT) is signaled. */
/* 18) If RATE is zero, the error SPICE(INVALIDVALUE) is signaled. */
/* $ Files */
/* A new type 5 CK segment is written to the CK file attached */
/* to HANDLE. */
/* $ Particulars */
/* This routine writes a CK type 5 data segment to the open CK */
/* file according to the format described in the type 5 section of */
/* the CK Required Reading. The CK file must have been opened with */
/* write access. */
/* Quaternion Styles */
/* ----------------- */
/* There are different "styles" of quaternions used in */
/* science and engineering applications. Quaternion styles */
/* are characterized by */
/* - The order of quaternion elements */
/* - The quaternion multiplication formula */
/* - The convention for associating quaternions */
/* with rotation matrices */
/* Two of the commonly used styles are */
/* - "SPICE" */
/* > Invented by Sir William Rowan Hamilton */
/* > Frequently used in mathematics and physics textbooks */
/* - "Engineering" */
/* > Widely used in aerospace engineering applications */
/* SPICELIB subroutine interfaces ALWAYS use SPICE quaternions. */
/* Quaternions of any other style must be converted to SPICE */
/* quaternions before they are passed to SPICELIB routines. */
/* Relationship between SPICE and Engineering Quaternions */
/* ------------------------------------------------------ */
/* Let M be a rotation matrix such that for any vector V, */
/* M*V */
/* is the result of rotating V by theta radians in the */
/* counterclockwise direction about unit rotation axis vector A. */
/* Then the SPICE quaternions representing M are */
/* (+/-) ( cos(theta/2), */
/* sin(theta/2) A(1), */
/* sin(theta/2) A(2), */
/* sin(theta/2) A(3) ) */
/* while the engineering quaternions representing M are */
/* (+/-) ( -sin(theta/2) A(1), */
/* -sin(theta/2) A(2), */
/* -sin(theta/2) A(3), */
/* cos(theta/2) ) */
/* For both styles of quaternions, if a quaternion q represents */
/* a rotation matrix M, then -q represents M as well. */
/* Given an engineering quaternion */
/* QENG = ( q0, q1, q2, q3 ) */
/* the equivalent SPICE quaternion is */
/* QSPICE = ( q3, -q0, -q1, -q2 ) */
/* Associating SPICE Quaternions with Rotation Matrices */
/* ---------------------------------------------------- */
/* Let FROM and TO be two right-handed reference frames, for */
/* example, an inertial frame and a spacecraft-fixed frame. Let the */
/* symbols */
/* V , V */
/* FROM TO */
/* denote, respectively, an arbitrary vector expressed relative to */
/* the FROM and TO frames. Let M denote the transformation matrix */
/* that transforms vectors from frame FROM to frame TO; then */
/* V = M * V */
/* TO FROM */
/* where the expression on the right hand side represents left */
/* multiplication of the vector by the matrix. */
/* Then if the unit-length SPICE quaternion q represents M, where */
/* q = (q0, q1, q2, q3) */
/* the elements of M are derived from the elements of q as follows: */
/* +- -+ */
/* | 2 2 | */
/* | 1 - 2*( q2 + q3 ) 2*(q1*q2 - q0*q3) 2*(q1*q3 + q0*q2) | */
/* | | */
/* | | */
/* | 2 2 | */
/* M = | 2*(q1*q2 + q0*q3) 1 - 2*( q1 + q3 ) 2*(q2*q3 - q0*q1) | */
/* | | */
/* | | */
/* | 2 2 | */
/* | 2*(q1*q3 - q0*q2) 2*(q2*q3 + q0*q1) 1 - 2*( q1 + q2 ) | */
/* | | */
/* +- -+ */
/* Note that substituting the elements of -q for those of q in the */
/* right hand side leaves each element of M unchanged; this shows */
/* that if a quaternion q represents a matrix M, then so does the */
/* quaternion -q. */
/* To map the rotation matrix M to a unit quaternion, we start by */
/* decomposing the rotation matrix as a sum of symmetric */
/* and skew-symmetric parts: */
/* 2 */
/* M = [ I + (1-cos(theta)) OMEGA ] + [ sin(theta) OMEGA ] */
/* symmetric skew-symmetric */
/* OMEGA is a skew-symmetric matrix of the form */
/* +- -+ */
/* | 0 -n3 n2 | */
/* | | */
/* OMEGA = | n3 0 -n1 | */
/* | | */
/* | -n2 n1 0 | */
/* +- -+ */
/* The vector N of matrix entries (n1, n2, n3) is the rotation axis */
/* of M and theta is M's rotation angle. Note that N and theta */
/* are not unique. */
/* Let */
/* C = cos(theta/2) */
/* S = sin(theta/2) */
/* Then the unit quaternions Q corresponding to M are */
/* Q = +/- ( C, S*n1, S*n2, S*n3 ) */
/* The mappings between quaternions and the corresponding rotations */
/* are carried out by the SPICELIB routines */
/* Q2M {quaternion to matrix} */
/* M2Q {matrix to quaternion} */
/* M2Q always returns a quaternion with scalar part greater than */
/* or equal to zero. */
/* SPICE Quaternion Multiplication Formula */
/* --------------------------------------- */
/* Given a SPICE quaternion */
/* Q = ( q0, q1, q2, q3 ) */
/* corresponding to rotation axis A and angle theta as above, we can */
/* represent Q using "scalar + vector" notation as follows: */
/* s = q0 = cos(theta/2) */
/* v = ( q1, q2, q3 ) = sin(theta/2) * A */
/* Q = s + v */
/* Let Q1 and Q2 be SPICE quaternions with respective scalar */
/* and vector parts s1, s2 and v1, v2: */
/* Q1 = s1 + v1 */
/* Q2 = s2 + v2 */
/* We represent the dot product of v1 and v2 by */
/* <v1, v2> */
/* and the cross product of v1 and v2 by */
/* v1 x v2 */
/* Then the SPICE quaternion product is */
/* Q1*Q2 = s1*s2 - <v1,v2> + s1*v2 + s2*v1 + (v1 x v2) */
/* If Q1 and Q2 represent the rotation matrices M1 and M2 */
/* respectively, then the quaternion product */
/* Q1*Q2 */
/* represents the matrix product */
/* M1*M2 */
/* $ Examples */
/* Suppose that you have data packets and are prepared to produce */
/* a segment of type 5 in a CK file. */
/* The following code fragment could be used to add the new segment */
/* to a previously opened CK file attached to HANDLE. The file must */
/* have been opened with write access. */
/* C */
/* C Create a segment identifier. */
/* C */
/* SEGID = 'MY_SAMPLE_CK_TYPE_5_SEGMENT' */
/* C */
/* C Write the segment. */
/* C */
/* CALL CKW05 ( HANDLE, SUBTYP, DEGREE, BEGTIM, ENDTIM, */
/* . INST, REF, AVFLAG, SEGID, N, */
/* . SCLKDP, PACKTS, RATE, NINTS, STARTS ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* K.R. Gehringer (JPL) */
/* J.M. Lynch (JPL) */
/* $ Version */
/* - SPICELIB Version 2.0.0, 08-FEB-2010 (NJB) */
/* The check for non-unit quaternions has been replaced */
/* with a check for zero-length quaternions. */
/* - SPICELIB Version 1.1.0, 26-FEB-2008 (NJB) */
/* Updated header; added information about SPICE */
/* quaternion conventions. */
/* Minor typo in a long error message was corrected. */
/* - SPICELIB Version 1.0.1, 07-JAN-2005 (NJB) */
/* Description in Detailed_Input header section of */
/* constraints on BEGTIM and ENDTIM was corrected. */
/* - SPICELIB Version 1.0.0, 30-AUG-2002 (NJB) (KRG) (JML) (WLT) */
/* -& */
/* $ Index_Entries */
/* write ck type_5 data segment */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 08-FEB-2010 (NJB) */
/* The check for non-unit quaternions has been replaced */
/* with a check for zero-length quaternions. */
/* This change was made to accommodate CK generation, */
/* via the non-SPICE utility MEX2KER, for European missions. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Packet structure parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("CKW05", (ftnlen)5);
}
/* Make sure that the number of packets is positive. */
if (*n < 1) {
setmsg_("At least 1 packet is required for CK type 5. Number of pack"
"ets supplied: #", (ftnlen)75);
errint_("#", n, (ftnlen)1);
sigerr_("SPICE(TOOFEWPACKETS)", (ftnlen)20);
chkout_("CKW05", (ftnlen)5);
return 0;
}
/* Make sure that there is a positive number of interpolation */
/* intervals. */
if (*nints <= 0) {
setmsg_("# is an invalid number of interpolation intervals for type "
"5.", (ftnlen)61);
errint_("#", nints, (ftnlen)1);
sigerr_("SPICE(INVALIDNUMINTS)", (ftnlen)21);
chkout_("CKW05", (ftnlen)5);
return 0;
}
/* Get the NAIF integer code for the reference frame. */
namfrm_(ref, &refcod, ref_len);
if (refcod == 0) {
setmsg_("The reference frame # is not supported.", (ftnlen)39);
errch_("#", ref, (ftnlen)1, ref_len);
sigerr_("SPICE(INVALIDREFFRAME)", (ftnlen)22);
chkout_("CKW05", (ftnlen)5);
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_("CKW05", (ftnlen)5);
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_("CKW05", (ftnlen)5);
return 0;
}
}
/* Now check that the encoded SCLK times are positive and strictly */
/* increasing. */
/* Check that the first time is nonnegative. */
if (sclkdp[0] < 0.) {
setmsg_("The first SCLKDP time: # is negative.", (ftnlen)37);
errdp_("#", sclkdp, (ftnlen)1);
sigerr_("SPICE(INVALIDSCLKTIME)", (ftnlen)22);
chkout_("CKW05", (ftnlen)5);
return 0;
}
/* Now check that the times are ordered properly. */
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
if (sclkdp[i__ - 1] <= sclkdp[i__ - 2]) {
setmsg_("The SCLKDP times are not strictly increasing. SCLKDP(#)"
" = # and SCLKDP(#) = #.", (ftnlen)78);
errint_("#", &i__, (ftnlen)1);
errdp_("#", &sclkdp[i__ - 1], (ftnlen)1);
i__2 = i__ - 1;
errint_("#", &i__2, (ftnlen)1);
errdp_("#", &sclkdp[i__ - 2], (ftnlen)1);
sigerr_("SPICE(TIMESOUTOFORDER)", (ftnlen)22);
chkout_("CKW05", (ftnlen)5);
return 0;
}
}
/* Now check that the interval start times are ordered properly. */
i__1 = *nints;
for (i__ = 2; i__ <= i__1; ++i__) {
if (starts[i__ - 1] <= starts[i__ - 2]) {
setmsg_("The interval start times are not strictly increasing. S"
"TARTS(#) = # and STARTS(#) = #.", (ftnlen)86);
errint_("#", &i__, (ftnlen)1);
errdp_("#", &starts[i__ - 1], (ftnlen)1);
i__2 = i__ - 1;
errint_("#", &i__2, (ftnlen)1);
errdp_("#", &starts[i__ - 2], (ftnlen)1);
sigerr_("SPICE(TIMESOUTOFORDER)", (ftnlen)22);
chkout_("CKW05", (ftnlen)5);
return 0;
}
}
/* Now make sure that all of the interval start times coincide with */
/* one of the times associated with the actual pointing. */
i__1 = *nints;
for (i__ = 1; i__ <= i__1; ++i__) {
/* We know the SCLKDP array is ordered, so a binary search is */
/* ok. */
if (bsrchd_(&starts[i__ - 1], n, sclkdp) == 0) {
setmsg_("Interval start time number # is invalid. STARTS(#) = *",
(ftnlen)54);
errint_("#", &i__, (ftnlen)1);
errint_("#", &i__, (ftnlen)1);
errdp_("*", &starts[i__ - 1], (ftnlen)1);
sigerr_("SPICE(INVALIDSTARTTIME)", (ftnlen)23);
chkout_("CKW05", (ftnlen)5);
return 0;
}
}
/* Set the window, packet size and angular velocity flag, all of */
/* which are functions of the subtype. */
if (*subtyp == 0) {
winsiz = (*degree + 1) / 2;
packsz = 8;
} else if (*subtyp == 1) {
winsiz = *degree + 1;
packsz = 4;
} else if (*subtyp == 2) {
winsiz = (*degree + 1) / 2;
packsz = 14;
} else if (*subtyp == 3) {
winsiz = *degree + 1;
packsz = 7;
} else {
setmsg_("CK type 5 subtype <#> is not supported.", (ftnlen)39);
errint_("#", subtyp, (ftnlen)1);
sigerr_("SPICE(NOTSUPPORTED)", (ftnlen)19);
chkout_("CKW05", (ftnlen)5);
return 0;
}
/* Make sure that the quaternions are non-zero. This is just */
/* a check for uninitialized data. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* We have to address the quaternion explicitly, since the shape */
/* of the packet array is not known at compile time. */
addr__ = packsz * (i__ - 1) + 1;
if (vzerog_(&packts[addr__ - 1], &c__4)) {
setmsg_("The quaternion at index # has magnitude zero.", (ftnlen)
45);
errint_("#", &i__, (ftnlen)1);
sigerr_("SPICE(ZEROQUATERNION)", (ftnlen)21);
chkout_("CKW05", (ftnlen)5);
return 0;
}
}
/* Make sure that the degree of the interpolating polynomials is */
/* in range. */
if (*degree < 1 || *degree > 15) {
setmsg_("The interpolating polynomials have degree #; the valid degr"
"ee range is [1, #]", (ftnlen)77);
errint_("#", degree, (ftnlen)1);
errint_("#", &c__15, (ftnlen)1);
sigerr_("SPICE(INVALIDDEGREE)", (ftnlen)20);
chkout_("CKW05", (ftnlen)5);
return 0;
}
/* Make sure that the window size is even. If not, the input */
/* DEGREE is incompatible with the subtype. */
if (odd_(&winsiz)) {
setmsg_("The interpolating polynomials have degree #; for CK type 5,"
" the degree must be equivalent to 3 mod 4 for Hermite interp"
"olation and odd for for Lagrange interpolation.", (ftnlen)166)
;
errint_("#", degree, (ftnlen)1);
sigerr_("SPICE(INVALIDDEGREE)", (ftnlen)20);
chkout_("CKW05", (ftnlen)5);
return 0;
}
/* If we made it this far, we're ready to start writing the segment. */
/* Create the segment descriptor. */
/* Assign values to the integer components of the segment descriptor. */
ic[0] = *inst;
ic[1] = refcod;
ic[2] = 5;
if (*avflag) {
ic[3] = 1;
} else {
ic[3] = 0;
}
dc[0] = *begtim;
dc[1] = *endtim;
/* Make sure the descriptor times are in increasing order. */
if (*endtim < *begtim) {
setmsg_("Descriptor bounds are non-increasing: #:#", (ftnlen)41);
errdp_("#", begtim, (ftnlen)1);
errdp_("#", endtim, (ftnlen)1);
sigerr_("SPICE(BADDESCRTIMES)", (ftnlen)20);
chkout_("CKW05", (ftnlen)5);
return 0;
}
/* Make sure that at least one time tag lies between BEGTIM and */
/* ENDTIM. The first time tag not less than BEGTIM must exist */
/* and must be less than or equal to ENDTIM. */
i__ = lstltd_(begtim, n, sclkdp);
if (i__ == *n) {
setmsg_("All time tags are less than segment start time #.", (ftnlen)
49);
errdp_("#", begtim, (ftnlen)1);
sigerr_("SPICE(EMPTYSEGMENT)", (ftnlen)19);
chkout_("CKW05", (ftnlen)5);
return 0;
} else if (sclkdp[i__] > *endtim) {
setmsg_("No time tags lie between the segment start time # and segme"
"nt end time #", (ftnlen)72);
errdp_("#", begtim, (ftnlen)1);
errdp_("#", endtim, (ftnlen)1);
sigerr_("SPICE(EMPTYSEGMENT)", (ftnlen)19);
chkout_("CKW05", (ftnlen)5);
return 0;
}
/* The clock rate must be non-zero. */
if (*rate == 0.) {
setmsg_("The SCLK rate RATE was zero.", (ftnlen)28);
sigerr_("SPICE(INVALIDVALUE)", (ftnlen)19);
chkout_("CKW05", (ftnlen)5);
return 0;
}
/* Now pack the segment descriptor. */
dafps_(&c__2, &c__6, dc, ic, descr);
/* Begin a new segment. */
dafbna_(handle, descr, segid, segid_len);
if (failed_()) {
chkout_("CKW05", (ftnlen)5);
return 0;
}
/* The type 5 segment structure is eloquently described by this */
/* diagram from the CK Required Reading: */
/* +-----------------------+ */
/* | Packet 1 | */
/* +-----------------------+ */
/* | Packet 2 | */
/* +-----------------------+ */
/* . */
/* . */
/* . */
/* +-----------------------+ */
/* | Packet N | */
/* +-----------------------+ */
/* | Epoch 1 | */
/* +-----------------------+ */
/* | Epoch 2 | */
/* +-----------------------+ */
/* . */
/* . */
/* . */
/* +----------------------------+ */
/* | Epoch N | */
/* +----------------------------+ */
/* | Epoch 100 | (First directory) */
/* +----------------------------+ */
/* . */
/* . */
/* . */
/* +----------------------------+ */
/* | Epoch ((N-1)/100)*100 | (Last directory) */
/* +----------------------------+ */
/* | Start time 1 | */
/* +----------------------------+ */
/* | Start time 2 | */
/* +----------------------------+ */
/* . */
/* . */
/* . */
/* +----------------------------+ */
/* | Start time M | */
/* +----------------------------+ */
/* | Start time 100 | (First interval start */
/* +----------------------------+ time directory) */
/* . */
/* . */
/* . */
/* +----------------------------+ */
/* | Start time ((M-1)/100)*100 | (Last interval start */
/* +----------------------------+ time directory) */
/* | Seconds per tick | */
/* +----------------------------+ */
/* | Subtype code | */
/* +----------------------------+ */
/* | Window size | */
/* +----------------------------+ */
/* | Number of interp intervals | */
/* +----------------------------+ */
/* | Number of packets | */
/* +----------------------------+ */
i__1 = *n * packsz;
dafada_(packts, &i__1);
dafada_(sclkdp, n);
i__1 = (*n - 1) / 100;
for (i__ = 1; i__ <= i__1; ++i__) {
dafada_(&sclkdp[i__ * 100 - 1], &c__1);
}
/* Now add the interval start times. */
dafada_(starts, nints);
/* And the directory of interval start times. The directory of */
/* start times will simply be every (DIRSIZ)th start time. */
i__1 = (*nints - 1) / 100;
for (i__ = 1; i__ <= i__1; ++i__) {
dafada_(&starts[i__ * 100 - 1], &c__1);
}
/* Add the SCLK rate, segment subtype, window size, interval */
/* count, and packet count. */
dafada_(rate, &c__1);
d__1 = (doublereal) (*subtyp);
dafada_(&d__1, &c__1);
d__1 = (doublereal) winsiz;
dafada_(&d__1, &c__1);
d__1 = (doublereal) (*nints);
dafada_(&d__1, &c__1);
d__1 = (doublereal) (*n);
dafada_(&d__1, &c__1);
/* As long as nothing went wrong, end the segment. */
if (! failed_()) {
dafena_();
}
chkout_("CKW05", (ftnlen)5);
return 0;
} /* ckw05_ */
/* $Procedure PARSDO ( Parsing of DATA_ORDER string ) */
/* Subroutine */ int parsdo_(char *line, char *doval, integer *nval, integer *
param, integer *nparam, ftnlen line_len, ftnlen doval_len)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer i__, l;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
char value[12];
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen),
lastnb_(char *, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int nextwd_(char *, char *, char *, ftnlen,
ftnlen, ftnlen), setmsg_(char *, ftnlen), sigerr_(char *, ftnlen),
chkout_(char *, ftnlen);
/* $ Abstract */
/* This routine is a module of the MKSPK program. It parses the */
/* DATA_ORDER value provided in a setup file and forms an array */
/* of indexes of recognizable input parameters contaned in it. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* MKSPK User's Guide */
/* $ Keywords */
/* PARSING */
/* $ Declarations */
/* $ Abstract */
/* MKSPK Include File. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Author_and_Institution */
/* N.G. Khavenson (IKI RAS, Russia) */
/* B.V. Semenov (NAIF, JPL) */
/* $ Version */
/* - Version 1.2.0, 16-JAN-2008 (BVS). */
/* Added ETTMWR parameter */
/* - Version 1.1.0, 05-JUN-2001 (BVS). */
/* Added MAXDEG parameter. */
/* - Version 1.0.4, 21-MAR-2001 (BVS). */
/* Added parameter for command line flag '-append' indicating */
/* that appending to an existing output file was requested. */
/* Added corresponding setup file keyword ('APPEND_TO_OUTPUT'.) */
/* Added parameters for yes and no values of this keyword. */
/* - Version 1.0.3, 28-JAN-2000 (BVS). */
/* Added parameter specifying number of supported input data */
/* types and parameter specifying number of supported output SPK */
/* types */
/* - Version 1.0.2, 22-NOV-1999 (NGK). */
/* Added parameters for two-line elements processing. */
/* - Version 1.0.1, 18-MAR-1999 (BVS). */
/* Added usage, help and template displays. Corrected comments. */
/* - Version 1.0.0, 8-SEP-1998 (NGK). */
/* -& */
/* Begin Include Section: MKSPK generic parameters. */
/* Maximum number of states allowed per one segment. */
/* String size allocation parameters */
/* Length of buffer for input text processing */
/* Length of a input text line */
/* Length of file name and comment line */
/* Length of string for keyword value processing */
/* Length of string for word processing */
/* Length of data order parameters string */
/* Length of string reserved as delimiter */
/* Numbers of different parameters */
/* Maximum number of allowed comment lines. */
/* Reserved number of input parameters */
/* Full number of delimiters */
/* Number of delimiters that may appear in time string */
/* Command line flags */
/* Setup file keywords reserved values */
/* Standard YES and NO values for setup file keywords. */
/* Number of supported input data types and input DATA TYPE */
/* reserved values. */
/* Number of supported output SPK data types -- this version */
/* supports SPK types 5, 8, 9, 10, 12, 13, 15 and 17. */
/* End of input record marker */
/* Maximum allowed polynomial degree. The value of this parameter */
/* is consistent with the ones in SPKW* routines. */
/* Special time wrapper tag for input times given as ET seconds past */
/* J2000 */
/* End Include Section: MKSPK generic parameters. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- ---------------------------------------------- */
/* LINE I DATA_ORDER string */
/* DOVAL I Array of recognizable input parameter names */
/* NVAL I Number of recognizable input parameters */
/* PARAM O Array of parameter IDs present in DATA_ORDER */
/* NPARAM O Number of elements in PARAM */
/* $ Detailed_Input */
/* LINE is the DATA_ORDER value that will be parsed. */
/* DOVAL is an array containing complete set recognizable */
/* input parameters (see main module for the current */
/* list). */
/* NVAL is the total number of recognizable input parameters */
/* (number of elements in DOVAL). */
/* $ Detailed_Output */
/* PARAM is an integer array containing indexes of the */
/* recognizable input parameters present in the input */
/* DATA_ORDER value in the order in which they are */
/* provided in that value. */
/* NPARAM is the number of elements in PARAM. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If token in the data order is not recognized, then the */
/* error 'SPICE(BADDATAORDERTOKEN)' will be signalled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This subroutine parses DATA_ORDER string containing names of */
/* input data record parameters in the order in which they appear */
/* in the input records and returns an integer array of the indexes */
/* of the parameters that were found in the string. */
/* $ Examples */
/* Let DATA_ORDER has following value: */
/* LINE = 'EPOCH X Y Z SKIP VX VY VZ' */
/* and DOVAL array contains the following values: */
/* DOVAL(1) = 'EPOCH' */
/* DOVAL(2) = 'X' */
/* DOVAL(3) = 'Y' */
/* DOVAL(4) = 'Z' */
/* DOVAL(5) = 'VX' */
/* DOVAL(6) = 'VY' */
/* DOVAL(7) = 'VZ' */
/* ... */
/* DOVAL(30) = 'SKIP' */
/* Then after parsing we will have on the output: */
/* NPARAM = 8 */
/* PARAM = 1, 2, 3, 4, 30, 5, 6, 7 */
/* $ Restrictions */
/* Because search for a parameter in the DATA_ORDER value is case */
/* sensitive, the DATA_ORDER value and parameter names must be */
/* in the same case (nominally uppercase). */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.G. Khavenson (IKI RAS, Russia) */
/* B.V. Semenov (NAIF, JPL) */
/* $ Version */
/* - Version 1.0.3, 29-MAR-1999 (NGK). */
/* Corrected examples section. */
/* - Version 1.0.2, 18-MAR-1999 (BVS). */
/* Corrected comments. */
/* - Version 1.0.1, 13-JAN-1999 (BVS). */
/* Modified error messages. */
/* - Version 1.0.0, 08-SEP-1998 (NGK). */
/* -& */
/* $ Index_Entries */
/* Parse MKSPK setup DATA_ORDER string. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Size VALUEL declared in the include file. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("PARSDO", (ftnlen)6);
}
/* Assign zero to PARAM array. */
i__1 = *nval;
for (l = 1; l <= i__1; ++l) {
param[l - 1] = 0;
}
/* Reset counter of words on line. */
*nparam = 0;
while(lastnb_(line, line_len) != 0) {
/* Get next word from the line. Value is already uppercase. */
nextwd_(line, value, line, line_len, (ftnlen)12, line_len);
i__ = isrchc_(value, nval, doval, (ftnlen)12, doval_len);
/* Look whether this value is one of the reserved values. */
if (i__ != 0) {
/* This value is OK. Memorize it. */
++(*nparam);
param[*nparam - 1] = i__;
} else {
/* We can not recognize this value. */
setmsg_("Can not recognize token '#' in the value of the setup f"
"ile keyword '#'. Refer to the User's Guide for the progr"
"am for complete list of allowed tokens.", (ftnlen)150);
errch_("#", value, (ftnlen)1, (ftnlen)12);
errch_("#", "DATA_ORDER", (ftnlen)1, (ftnlen)10);
sigerr_("SPICE(BADDATAORDERTOKEN)", (ftnlen)24);
}
}
chkout_("PARSDO", (ftnlen)6);
return 0;
} /* parsdo_ */
/* $Procedure 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 REPMCT ( Replace marker with cardinal text ) */
/* Subroutine */ int repmct_(char *in, char *marker, integer *value, char *
case__, char *out, ftnlen in_len, ftnlen marker_len, ftnlen case_len,
ftnlen out_len)
{
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
char card[145];
extern /* Subroutine */ int lcase_(char *, char *, ftnlen, ftnlen),
chkin_(char *, ftnlen), ucase_(char *, char *, ftnlen, ftnlen),
errch_(char *, char *, ftnlen, ftnlen), ljust_(char *, char *,
ftnlen, ftnlen);
integer mrknbf;
extern integer lastnb_(char *, ftnlen);
integer mrknbl;
char tmpcas[1];
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen);
extern integer frstnb_(char *, ftnlen);
integer mrkpsb;
extern /* Subroutine */ int repsub_(char *, integer *, integer *, char *,
char *, ftnlen, ftnlen, ftnlen);
integer mrkpse;
extern /* Subroutine */ int setmsg_(char *, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int inttxt_(integer *, char *, ftnlen);
/* $ Abstract */
/* Replace a marker with the text representation of a */
/* cardinal 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 */
/* None. */
/* $ Keywords */
/* CHARACTER */
/* CONVERSION */
/* STRING */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* IN I Input string. */
/* MARKER I Marker to be replaced. */
/* VALUE I Cardinal value. */
/* CASE I Case of replacement text. */
/* OUT O Output string. */
/* MAXLCN P Maximum length of a cardinal number. */
/* $ Detailed_Input */
/* IN is an arbitrary character string. */
/* MARKER is an arbitrary character string. The first */
/* occurrence of MARKER in the input string is */
/* to be replaced by the text representation of */
/* the cardinal number VALUE. */
/* Leading and trailing blanks in MARKER are NOT */
/* significant. In particular, no substitution is */
/* performed if MARKER is blank. */
/* VALUE is an arbitrary integer. */
/* CASE indicates the case of the replacement text. */
/* CASE may be any of the following: */
/* CASE Meaning Example */
/* ---- ----------- ----------------------- */
/* U, u Uppercase ONE HUNDRED FIFTY-THREE */
/* L, l Lowercase one hundred fifty-three */
/* C, c Capitalized One hundred fifty-three */
/* $ Detailed_Output */
/* OUT is the string obtained by substituting the text */
/* representation of the cardinal number VALUE for */
/* the first occurrence of MARKER in the input string. */
/* OUT and IN must be identical or disjoint. */
/* $ Parameters */
/* MAXLCN is the maximum expected length of any cardinal */
/* text. 145 characters are sufficient to hold the */
/* text representing any value in the range */
/* ( -10**12, 10**12 ) */
/* An example of a number whose text representation */
/* is of maximum length is */
/* - 777 777 777 777 */
/* $ Exceptions */
/* 1) If OUT does not have sufficient length to accommodate the */
/* result of the substitution, the result will be truncated on */
/* the right. */
/* 2) If MARKER is blank, or if MARKER is not a substring of IN, */
/* no substitution is performed. (OUT and IN are identical.) */
/* 3) If the value of CASE is not recognized, the error */
/* SPICE(INVALIDCASE) is signalled. OUT is not changed. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This is one of a family of related routines for inserting values */
/* into strings. They are typically used to construct messages that */
/* are partly fixed, and partly determined at run time. For example, */
/* a message like */
/* 'Fifty-one pictures were found in directory [USER.DATA].' */
/* might be constructed from the fixed string */
/* '#1 pictures were found in directory #2.' */
/* by the calls */
/* CALL REPMCT ( STRING, '#1', NPICS, 'C', STRING ) */
/* CALL REPMC ( STRING, '#2', DIRNAM, STRING ) */
/* which substitute the cardinal text 'Fifty-one' and the character */
/* string '[USER.DATA]' for the markers '#1' and '#2' respectively. */
/* The complete list of routines is shown below. */
/* REPMC ( Replace marker with character string value ) */
/* REPMD ( Replace marker with double precision value ) */
/* REPMF ( Replace marker with formatted d.p. value ) */
/* REPMI ( Replace marker with integer value ) */
/* REPMCT ( Replace marker with cardinal text) */
/* REPMOT ( Replace marker with ordinal text ) */
/* $ Examples */
/* The following examples illustrate the use of REPMCT to */
/* replace a marker within a string with the cardinal text */
/* corresponding to an integer. */
/* Uppercase */
/* --------- */
/* Let */
/* MARKER = '#' */
/* IN = 'INVALID COMMAND. WORD # WAS NOT RECOGNIZED.' */
/* Then following the call, */
/* CALL REPMCT ( IN, '#', 5, 'U', IN ) */
/* IN is */
/* 'INVALID COMMAND. WORD FIVE WAS NOT RECOGNIZED.' */
/* Lowercase */
/* --------- */
/* Let */
/* MARKER = ' XX ' */
/* IN = 'Word XX of the XX sentence was misspelled.' */
/* Then following the call, */
/* CALL REPMCT ( IN, ' XX ', 5, 'L', OUT ) */
/* OUT is */
/* 'Word five of the XX sentence was misspelled.' */
/* Capitalized */
/* ----------- */
/* Let */
/* MARKER = ' XX ' */
/* IN = 'Name: YY. Rank: XX.' */
/* Then following the calls, */
/* CALL REPMC ( IN, 'YY', 'Moriarty', OUT ) */
/* CALL REPMCT ( OUT, 'XX', 1, 'C', OUT ) */
/* OUT is */
/* 'Name: Moriarty. Rank: One.' */
/* $ Restrictions */
/* 1) VALUE must be in the range accepted by subroutine INTTXT. */
/* This range is currently */
/* ( -10**12, 10**12 ) */
/* Note that the endpoints of the interval are excluded. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* B.V. Semenov (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.0, 21-SEP-2013 (BVS) */
/* Minor efficiency update: the routine now looks up the first */
/* and last non-blank characters only once. */
/* - 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, 30-AUG-1990 (NJB) (IMU) */
/* -& */
/* $ Index_Entries */
/* replace marker with cardinal text */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("REPMCT", (ftnlen)6);
}
/* Bail out if CASE is not recognized. */
ljust_(case__, tmpcas, (ftnlen)1, (ftnlen)1);
ucase_(tmpcas, tmpcas, (ftnlen)1, (ftnlen)1);
if (*(unsigned char *)tmpcas != 'U' && *(unsigned char *)tmpcas != 'L' &&
*(unsigned char *)tmpcas != 'C') {
setmsg_("Case (#) must be U, L, or C.", (ftnlen)28);
errch_("#", case__, (ftnlen)1, (ftnlen)1);
sigerr_("SPICE(INVALIDCASE)", (ftnlen)18);
chkout_("REPMCT", (ftnlen)6);
return 0;
}
/* If MARKER is blank, no substitution is possible. */
if (s_cmp(marker, " ", marker_len, (ftnlen)1) == 0) {
s_copy(out, in, out_len, in_len);
chkout_("REPMCT", (ftnlen)6);
return 0;
}
/* Locate the leftmost occurrence of MARKER, if there is one */
/* (ignoring leading and trailing blanks). If MARKER is not */
/* a substring of IN, no substitution can be performed. */
mrknbf = frstnb_(marker, marker_len);
mrknbl = lastnb_(marker, marker_len);
mrkpsb = i_indx(in, marker + (mrknbf - 1), in_len, mrknbl - (mrknbf - 1));
if (mrkpsb == 0) {
s_copy(out, in, out_len, in_len);
chkout_("REPMCT", (ftnlen)6);
return 0;
}
mrkpse = mrkpsb + mrknbl - mrknbf;
/* Okay, CASE is recognized and MARKER has been found. */
/* Generate the cardinal text corresponding to VALUE. */
inttxt_(value, card, (ftnlen)145);
/* CARD is always returned in upper case; change to the specified */
/* case, if required. */
if (*(unsigned char *)tmpcas == 'L') {
lcase_(card, card, (ftnlen)145, (ftnlen)145);
} else if (*(unsigned char *)tmpcas == 'C') {
lcase_(card + 1, card + 1, (ftnlen)144, (ftnlen)144);
}
/* Replace MARKER with CARD. */
repsub_(in, &mrkpsb, &mrkpse, card, out, in_len, lastnb_(card, (ftnlen)
145), out_len);
chkout_("REPMCT", (ftnlen)6);
return 0;
} /* repmct_ */
/* $Procedure STRAN */
/* Subroutine */ int stran_0_(int n__, char *input, char *output, logical *
tran, ftnlen input_len, ftnlen output_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen), i_indx(char *, char *,
ftnlen, ftnlen), s_rnge(char *, integer, char *, integer), i_len(
char *, ftnlen);
/* Local variables */
static integer ldef, leno, vdim, slot, lout, lsym, ptrs[810], i__, j;
extern integer cardc_(char *, ftnlen);
static integer l, n;
static logical check[200];
extern logical batch_(void);
static integer place;
extern /* Subroutine */ int lcase_(char *, char *, ftnlen, ftnlen);
static char delim[1];
extern /* Subroutine */ int chkin_(char *, ftnlen);
static integer nname;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
static char names[32*206];
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen),
geteq_(char *, ftnlen);
extern integer ncpos_(char *, char *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int nthwd_(char *, integer *, char *, integer *,
ftnlen, ftnlen);
static char symbl[33];
static integer psize;
extern integer rtrim_(char *, ftnlen);
static logical checkd[200];
extern logical failed_(void);
static char alphab[32];
extern /* Subroutine */ int getdel_(char *, ftnlen);
extern logical matchm_(char *, char *, char *, char *, char *, char *,
ftnlen, ftnlen, ftnlen, ftnlen, ftnlen, ftnlen);
static char buffer[256*52];
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen),
lastnb_(char *, ftnlen);
static logical gotone;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), repsub_(char *, integer *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen);
static char equote[1];
extern /* Subroutine */ int setmsg_(char *, ftnlen);
static char resvrd[32*12], symbol[33], pattrn[80];
static integer nxtchr;
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen), rdstmn_(char *, char *, char *, ftnlen, ftnlen, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int sbget_1__(char *, char *, integer *, char *,
char *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), nthuqw_(char *
, integer *, char *, char *, integer *, ftnlen, ftnlen, ftnlen);
static char myprmt[80];
extern /* Subroutine */ int sbrem_1__(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
static integer lsttry;
extern /* Subroutine */ int sbset_1__(char *, char *, char *, integer *,
char *, ftnlen, ftnlen, ftnlen, ftnlen);
static char def[1024];
static integer loc;
static char key[32];
static logical new__;
extern /* Subroutine */ int sbinit_1__(integer *, integer *, integer *,
char *, integer *, char *, ftnlen, ftnlen);
/* $ Abstract */
/* Translate the symbols in an input string. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Keywords */
/* PARSE */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* INPUT I Input string containing symbols to be translated. */
/* OUTPUT O Output string, with all symbols translated. */
/* $ Detailed_Input */
/* INPUT is the input string to be translated. INPUT may contain */
/* any number of known symbols. */
/* $ Detailed_Output */
/* OUTPUT is the translation of the input string. The first */
/* of the symbols in INPUT will have been translated. */
/* When INPUT is either a DEFINE or an UNDEFINE command, */
/* OUTPUT is blank. */
/* OUTPUT may overwrite INPUT. */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* None. */
/* $ Exceptions */
/* The following exceptions are detected by this routine: */
/* 1) Attempt to define or undefine a symbol that does */
/* not begin with a letter. */
/* 2) Attempt to define or undefine a symbol that ends with */
/* a question mark '?' . */
/* 3) Failure to specify a symbol to define or undefine. */
/* 4) Attempting to define a reserved word. The reserved */
/* words are: */
/* 'START' */
/* 'STOP' */
/* 'EXIT' */
/* 'INQUIRE' */
/* 'SHOW' */
/* 'DEFINE' */
/* 'SHOW' */
/* 'UNDEFINE' */
/* 'HELP' */
/* In all of the above cases OUTPUT is set to blank and TRAN to */
/* FALSE. No new symbol is placed in the table of symbol */
/* definitions. */
/* In all of these cases the error BAD_SYMBOL_SPC is signalled. */
/* 5) Recursive symbol definitions are detected and disallowed. */
/* A long error message diagnosing the problem is set and */
/* the error RECURSIVE_SYMBOL is signalled. */
/* 5) Overflow of the input command caused by symbol resolution. */
/* In this case the OUTPUT is left at the state it had reached */
/* prior to the overflow condition and TRAN is returned as */
/* FALSE. The error SYMBOL_OVERFLOW is signalled. */
/* $ Detailed_Description */
/* A new symbol may be defined with the DEFINE command. The */
/* syntax is: */
/* DEFINE <symbol> <definition> */
/* where <symbol> is a valid symbol name and <definition> is any */
/* valid definition. The DEFINE command, the symbol name, and the */
/* definition are delimited by blanks. */
/* When a symbol is defined, the symbol and definition are inserted */
/* into the symbol table. */
/* An existing symbol may be removed from the table with the */
/* UNDEFINE command. The syntax is: */
/* UNDEFINE <symbol> */
/* where <symbol> is the name of an existing symbol. The UNDEFINE */
/* command and the symbol name are delimited by blanks. */
/* If the input string does not contain a definition statement, */
/* STRANS searches the input string for potential symbol names. */
/* When a valid symbol is encountered, it is removed from the */
/* string and replaced by the corresponding definition. This */
/* continues until no untranslated symbols remain. */
/* $ Examples */
/* Suppose that we are given the following definitions: */
/* DEFINE BODIES PLANET AND SATS */
/* DEFINE EUROPA 502 */
/* DEFINE GANYMEDE 503 */
/* DEFINE IO 501 */
/* DEFINE JUPITER 599 */
/* DEFINE PLANET JUPITER */
/* DEFINE CALLISTO 504 */
/* DEFINE SATS IO EUROPA GANYMEDE CALLISTO */
/* Then the string 'BODIES AND SOULS' would translate, */
/* at various stages, to: */
/* 'PLANET AND SATS AND SOULS' */
/* 'JUPITER AND SATS AND SOULS' */
/* '599 AND SATS AND SOULS' */
/* '599 AND IO EUROPA GANYMEDE CALLISTO AND SOULS' */
/* '599 AND 501 EUROPA GANYMEDE CALLISTO AND SOULS' */
/* '599 AND 501 502 GANYMEDE CALLISTO AND SOULS' */
/* '599 AND 501 502 503 CALLISTO AND SOULS' */
/* '599 AND 501 502 503 504 AND SOULS' */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* I. M. Underwood (JPL) */
/* $ Version_and_Date */
/* Version 1.2.0 29-Aug-1996 (WLT) */
/* Fixed the error message for the case in which someone */
/* tries to create a symbol that is more than 32 characters */
/* in length. */
/* Version 1.1, 14-SEP-1995 */
/* Reference to unused variable WORD deleted. */
/* Version 1, 8-SEP-1986 */
/* -& */
/* SPICELIB Functions */
/* Other supporting functions */
/* The following parameters are used to define our table */
/* of symbol translations. */
/* Longest allowed symbol name is given by WDSIZE */
/* Maximum number of allowed symbols is MAXN */
/* The longest we expect any symbol to be is MAXL characters */
/* The average number of characters per symbol is AVGL */
/* Finally, here are the arrays used to hold the symbol translations. */
/* Here's the storage we need for the reserved words. */
switch(n__) {
case 1: goto L_sympat;
case 2: goto L_symget;
}
/* Set up all of the data structures and special strings in */
/* the first pass through the routine. */
if (return_()) {
return 0;
}
chkin_("STRAN", (ftnlen)5);
if (first) {
first = FALSE_;
vdim = 51;
psize = 804;
nname = 200;
sbinit_1__(&nname, &psize, &vdim, names, ptrs, buffer, (ftnlen)32, (
ftnlen)256);
s_copy(resvrd, "START", (ftnlen)32, (ftnlen)5);
s_copy(resvrd + 32, "STOP", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 64, "EXIT", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 96, "INQUIRE", (ftnlen)32, (ftnlen)7);
s_copy(resvrd + 128, "SHOW", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 160, "DEFINE", (ftnlen)32, (ftnlen)6);
s_copy(resvrd + 192, "SHOW", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 224, "UNDEFINE", (ftnlen)32, (ftnlen)8);
s_copy(resvrd + 256, "HELP", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 288, "RECALL", (ftnlen)32, (ftnlen)6);
s_copy(resvrd + 320, "DO", (ftnlen)32, (ftnlen)2);
s_copy(resvrd + 352, "EDIT", (ftnlen)32, (ftnlen)4);
s_copy(alphab, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", (ftnlen)32, (ftnlen)26);
}
/* Find out what the special marker character is for suppressing */
/* symbol evaluation. */
geteq_(equote, (ftnlen)1);
/* Is this a definition statement? The presence of DEFINE, INQUIRE or */
/* UNDEFINE at the beginning of the string will confirm this. */
nthwd_(input, &c__1, key, &loc, input_len, (ftnlen)32);
ucase_(key, key, (ftnlen)32, (ftnlen)32);
/* The keyword must be followed by a valid symbol name. */
if (s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0 || s_cmp(key, "INQU"
"IRE", (ftnlen)32, (ftnlen)7) == 0 || s_cmp(key, "UNDEFINE", (
ftnlen)32, (ftnlen)8) == 0) {
nthwd_(input, &c__2, symbl, &loc, input_len, (ftnlen)33);
ucase_(symbl, symbol, (ftnlen)33, (ftnlen)33);
l = rtrim_(symbol, (ftnlen)33);
if (s_cmp(symbol, " ", (ftnlen)33, (ftnlen)1) == 0) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
setmsg_("The \"#\" command must be followed by the name of the s"
"ymbol that you want to #. ", (ftnlen)79);
errch_("#", key, (ftnlen)1, (ftnlen)32);
lcase_(key, key, (ftnlen)32, (ftnlen)32);
errch_("#", key, (ftnlen)1, (ftnlen)32);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (i_indx(alphab, symbol, (ftnlen)32, (ftnlen)1) == 0) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
lcase_(key, key, (ftnlen)32, (ftnlen)32);
setmsg_("You cannot # \"#\". Symbols must begin with a letter ("
"A-Z) ", (ftnlen)58);
errch_("#", key, (ftnlen)1, (ftnlen)32);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (l > 32) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
lcase_(key, key, (ftnlen)32, (ftnlen)32);
setmsg_("You cannot # \"#...\". Symbols may not be longer than "
"32 characters in length.", (ftnlen)77);
errch_("#", key, (ftnlen)1, (ftnlen)32);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (*(unsigned char *)&symbol[l - 1] == '?') {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
lcase_(key, key, (ftnlen)32, (ftnlen)32);
setmsg_("You cannot # \"#\". Symbols may not end with a questio"
"n mark '?'. ", (ftnlen)65);
errch_("#", key, (ftnlen)1, (ftnlen)32);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if ((s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0 || s_cmp(
key, "INQUIRE", (ftnlen)32, (ftnlen)7) == 0) && isrchc_(
symbol, &c__12, resvrd, (ftnlen)33, (ftnlen)32) > 0) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
setmsg_("The word '#' is a reserved word. You may not redefine i"
"t. ", (ftnlen)58);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
}
}
if (s_cmp(key, "INQUIRE", (ftnlen)32, (ftnlen)7) == 0) {
/* First of all we, can only INQUIRE for symbol definitions */
/* if the program is not running in "batch" mode. */
if (batch_()) {
setmsg_("You've attempted to INQUIRE for the value of a symbol w"
"hile the program is running in \"batch\" mode. You can I"
"NQUIRE for a symbol value only if you are running in INT"
"ERACTIVE mode. ", (ftnlen)180);
sigerr_("WRONG_MODE", (ftnlen)10);
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* See if there is anything following the symbol that is */
/* to be defined. This will be used as our prompt value. */
/* Computing MAX */
i__3 = loc + l;
i__1 = loc + l, i__2 = ncpos_(input, " ", &i__3, input_len, (ftnlen)1)
;
nxtchr = max(i__1,i__2);
if (s_cmp(input + (nxtchr - 1), " ", input_len - (nxtchr - 1), (
ftnlen)1) != 0) {
s_copy(myprmt, input + (nxtchr - 1), (ftnlen)80, input_len - (
nxtchr - 1));
} else {
s_copy(myprmt, "Enter definition for", (ftnlen)80, (ftnlen)20);
suffix_(symbol, &c__1, myprmt, (ftnlen)33, (ftnlen)80);
suffix_(">", &c__1, myprmt, (ftnlen)1, (ftnlen)80);
}
getdel_(delim, (ftnlen)1);
rdstmn_(myprmt, delim, def, (ftnlen)80, (ftnlen)1, (ftnlen)1024);
sbset_1__(symbol, def, names, ptrs, buffer, (ftnlen)33, (ftnlen)1024,
(ftnlen)32, (ftnlen)256);
}
/* If this is a definition, and the symbol already exists in the */
/* symbol table, simply replace the existing definition with the */
/* string following the symbol name. If this is a new symbol, */
/* find the first symbol in the list that should follow the new */
/* one. Move the rest of the symbols back, and insert the new one */
/* at this point. */
if (s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0) {
/* Computing MAX */
i__3 = loc + l;
i__1 = loc + l, i__2 = ncpos_(input, " ", &i__3, input_len, (ftnlen)1)
;
nxtchr = max(i__1,i__2);
sbset_1__(symbol, input + (nxtchr - 1), names, ptrs, buffer, (ftnlen)
33, input_len - (nxtchr - 1), (ftnlen)32, (ftnlen)256);
}
if (s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0 || s_cmp(key, "INQU"
"IRE", (ftnlen)32, (ftnlen)7) == 0) {
if (failed_()) {
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* Now check for a recursive definition. To do this we have */
/* two parallel arrays to the NAMES array of the string */
/* buffer. The first array CHECK is used to indicate that */
/* in the course of the definition resolution of the */
/* new symbol, another symbol shows up. The second array */
/* called CHECKD indicats whether or not we have examined this */
/* existing symbol to see if contains the newly created */
/* symbol as part of its definition. */
/* So far we have nothing to check and haven't checked anything. */
n = cardc_(names, (ftnlen)32);
i__1 = n;
for (j = 1; j <= i__1; ++j) {
check[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge("check",
i__2, "stran_", (ftnlen)545)] = FALSE_;
checkd[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge("checkd",
i__2, "stran_", (ftnlen)546)] = FALSE_;
}
/* Find the location of our new symbol in the NAMES cell. */
place = isrchc_(symbol, &n, names + 192, (ftnlen)33, (ftnlen)32);
new__ = TRUE_;
while(new__) {
/* Look up the definition currently associated with */
/* the symbol we are checking. */
sbget_1__(symbol, names, ptrs, buffer, def, &i__, (ftnlen)33, (
ftnlen)32, (ftnlen)256, (ftnlen)1024);
j = 1;
nthuqw_(def, &j, equote, symbol, &loc, (ftnlen)1024, (ftnlen)1, (
ftnlen)33);
while(loc > 0) {
ucase_(symbol, symbol, (ftnlen)33, (ftnlen)33);
slot = isrchc_(symbol, &n, names + 192, (ftnlen)33, (ftnlen)
32);
/* If the word is located in the same place as the */
/* symbol we've just defined, we've introduced */
/* a recursive symbol definition. Remove this */
/* symbol and diagnose the error. */
if (slot == place) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
s_copy(symbol, names + (((i__1 = place + 5) < 206 && 0 <=
i__1 ? i__1 : s_rnge("names", i__1, "stran_", (
ftnlen)582)) << 5), (ftnlen)33, (ftnlen)32);
sbrem_1__(symbol, names, ptrs, buffer, (ftnlen)33, (
ftnlen)32, (ftnlen)256);
setmsg_("The definition of '#' is recursive. Recursivel"
"y defined symbol definitions are not allowed. ", (
ftnlen)93);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("RECURSIVE_SYMBOL", (ftnlen)16);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (slot > 0) {
/* Otherwise if this word is in the names list */
/* we may need to check this symbol to see if */
/* it lists the just defined symbol in its definition. */
if (checkd[(i__1 = slot - 1) < 200 && 0 <= i__1 ? i__1 :
s_rnge("checkd", i__1, "stran_", (ftnlen)602)]) {
check[(i__1 = slot - 1) < 200 && 0 <= i__1 ? i__1 :
s_rnge("check", i__1, "stran_", (ftnlen)603)]
= FALSE_;
} else {
check[(i__1 = slot - 1) < 200 && 0 <= i__1 ? i__1 :
s_rnge("check", i__1, "stran_", (ftnlen)605)]
= TRUE_;
}
}
/* Locate the next unquoted word in the definition. */
++j;
nthuqw_(def, &j, equote, symbol, &loc, (ftnlen)1024, (ftnlen)
1, (ftnlen)33);
}
/* See if there are any new items to check. If there */
/* are create a new value for symbol, and mark the */
/* new item as being checked. */
new__ = FALSE_;
i__1 = n;
for (j = 1; j <= i__1; ++j) {
if (check[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge(
"check", i__2, "stran_", (ftnlen)625)] && ! new__) {
s_copy(symbol, names + (((i__2 = j + 5) < 206 && 0 <=
i__2 ? i__2 : s_rnge("names", i__2, "stran_", (
ftnlen)626)) << 5), (ftnlen)33, (ftnlen)32);
check[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge(
"check", i__2, "stran_", (ftnlen)627)] = FALSE_;
checkd[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge(
"checkd", i__2, "stran_", (ftnlen)628)] = TRUE_;
new__ = TRUE_;
}
}
}
/* If we get to this point, we have a new non-recursively */
/* defined symbol. */
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* If this is a deletion, and the symbol already exists in the */
/* symbol table, simply move the symbols that follow toward the */
/* front of the table. */
if (s_cmp(key, "UNDEFINE", (ftnlen)32, (ftnlen)8) == 0) {
sbrem_1__(symbol, names, ptrs, buffer, (ftnlen)33, (ftnlen)32, (
ftnlen)256);
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* This is not a definition statement. Look for potential symbols. */
/* Try to resolve the first symbol in the string by substituting the */
/* corresponding definition for the existing symbol. */
s_copy(output, input, output_len, input_len);
*tran = FALSE_;
j = 1;
nthuqw_(output, &j, equote, symbol, &loc, output_len, (ftnlen)1, (ftnlen)
33);
while(! (*tran) && s_cmp(symbol, " ", (ftnlen)33, (ftnlen)1) != 0) {
ucase_(symbol, symbol, (ftnlen)33, (ftnlen)33);
sbget_1__(symbol, names, ptrs, buffer, def, &i__, (ftnlen)33, (ftnlen)
32, (ftnlen)256, (ftnlen)1024);
if (i__ > 0) {
lsym = lastnb_(symbol, (ftnlen)33);
ldef = lastnb_(def, (ftnlen)1024) + 1;
lout = lastnb_(output, output_len);
leno = i_len(output, output_len);
if (lout - lsym + ldef > leno) {
*tran = FALSE_;
setmsg_("As a result of attempting to resolve the symbols in"
" the input command, the command has overflowed the a"
"llocated memory. This is may be due to unintentional"
"ly using symbols that you had not intended to use. "
"You may protect portions of your string from symbol "
"evaluation by enclosing that portion of your string "
"between the character # as in 'DO #THIS PART WITHOUT"
" SYMBOLS#' . ", (ftnlen)376);
errch_("#", equote, (ftnlen)1, (ftnlen)1);
errch_("#", equote, (ftnlen)1, (ftnlen)1);
errch_("#", equote, (ftnlen)1, (ftnlen)1);
sigerr_("SYMBOL_OVERFLOW", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
}
i__1 = loc + lsym - 1;
repsub_(output, &loc, &i__1, def, output, output_len, ldef,
output_len);
*tran = TRUE_;
} else {
++j;
}
nthuqw_(output, &j, equote, symbol, &loc, output_len, (ftnlen)1, (
ftnlen)33);
}
chkout_("STRAN", (ftnlen)5);
return 0;
/* The following entry point allows us to set up a search */
/* of defined symbols that match a wild-card pattern. It must */
/* be called prior to getting any symbol definitions. */
L_sympat:
lsttry = 0;
s_copy(pattrn, input, (ftnlen)80, input_len);
return 0;
/* The following entry point fetches the next symbol and its */
/* definition for the next SYMBOL whose name */
/* matches a previously supplied template via the entry point */
/* above --- SYMPAT. */
/* If there is no matching symbol, we get back blanks. Note */
/* that no translation of the definition is performed. */
L_symget:
s_copy(input, " ", input_len, (ftnlen)1);
s_copy(output, " ", output_len, (ftnlen)1);
n = cardc_(names, (ftnlen)32);
while(lsttry < n) {
++lsttry;
gotone = matchm_(names + (((i__1 = lsttry + 5) < 206 && 0 <= i__1 ?
i__1 : s_rnge("names", i__1, "stran_", (ftnlen)767)) << 5),
pattrn, "*", "%", "~", "|", (ftnlen)32, (ftnlen)80, (ftnlen)1,
(ftnlen)1, (ftnlen)1, (ftnlen)1);
if (gotone) {
s_copy(symbol, names + (((i__1 = lsttry + 5) < 206 && 0 <= i__1 ?
i__1 : s_rnge("names", i__1, "stran_", (ftnlen)771)) << 5)
, (ftnlen)33, (ftnlen)32);
s_copy(input, names + (((i__1 = lsttry + 5) < 206 && 0 <= i__1 ?
i__1 : s_rnge("names", i__1, "stran_", (ftnlen)772)) << 5)
, input_len, (ftnlen)32);
sbget_1__(symbol, names, ptrs, buffer, output, &i__, (ftnlen)33, (
ftnlen)32, (ftnlen)256, output_len);
return 0;
}
}
return 0;
} /* stran_ */
/* Subroutine */ int prcomf_0_(int n__, char *file, char *delim, char *
command, char *error, char *level, ftnlen file_len, ftnlen delim_len,
ftnlen command_len, ftnlen error_len, ftnlen level_len)
{
/* Initialized data */
static integer nest = 0;
/* System generated locals */
integer i__1;
cilist ci__1;
cllist cl__1;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), f_clos(cllist *);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern logical have_(char *, ftnlen);
static integer i__, j;
static char files[80*8];
static integer units[8];
extern /* Subroutine */ int lbuild_(char *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen);
extern integer lastnb_(char *, ftnlen);
static integer iostat;
extern /* Subroutine */ int rstbuf_(void), putbuf_(char *, ftnlen),
txtopr_(char *, integer *, ftnlen);
/* $ Abstract */
/* Keep track of nested command files. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Keywords */
/* PARSE */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- --------------------------------------------------- */
/* FILE I Command file. */
/* DELIM I Symbol delimiting the end of a command. */
/* COMMAND O Command read from FILE. */
/* ERROR O Error flag. */
/* LEVEL O A list of all files currently open. */
/* $ Detailed_Input */
/* FILE is the name of a file from which a sequence of commands */
/* is to be read. These commands may include commands to */
/* read from other files. */
/* DELIM is the character which delimits the end of each */
/* instruction in FILE. */
/* $ Detailed_Output */
/* COMMAND is a command read from the current file. */
/* If no files are currently open, COMMAND = DELIM. */
/* ERROR is a descriptive error message, which is blank when */
/* no error occurs. */
/* LEVEL is a list of the files currently open, in the order */
/* in which they were opened. It is provided for trace- */
/* back purposes. */
/* $ Detailed_Description */
/* PRCOMF opens, reads, and closes sets of (possibly nested) */
/* command files. For example, consider the following command */
/* files. */
/* FILE_A : A1 FILE_B : B1 FILE_C : C1 */
/* A2 START FILE_C C2 */
/* A3 B2 C3 */
/* START FILE_B B3 */
/* A4 B4 */
/* A5 */
/* If the command 'START FILE_A' were issued, we would expect the */
/* following sequence of commands to ensue: */
/* A1, A2, A3, B1, C1, C2, C3, B2, B3, B4, A4, A5. */
/* The first file immediately becomes, ipso facto, the current file. */
/* Subsequently, instructions are read from the current file until */
/* either a START or the end of the file is encountered. Each time */
/* a new START is encountered, the current file (that is, the */
/* location of the next command in the file) is placed on a stack, */
/* and the first command is read from the new file (which then */
/* becomes the current file). Each time the end of the current file */
/* is encountered, the previous file is popped off the top of the */
/* stack to become the current file. This continues until there are */
/* no files remaining on the stack. */
/* On occasion, the user may wish to exit from a file without */
/* reading the rest of the file. In this case, the previous file */
/* is popped off the stack without further ado. */
/* Also, the user may wish to abruptly stop an entire nested */
/* set of files. In this case, all of the files are popped off */
/* the stack, and no further commands are returned. */
/* PRCOMF and its entry points may be used to process any such */
/* set of files. These entry points are: */
/* - PRCLR ( ERROR ) */
/* This clears the stack. It may thus be used to implement */
/* a STOP command. In any case, it must be called before */
/* any of the other entry points are called. */
/* - PRSTRT ( FILE, ERROR ) */
/* This introduces a new file, causing the current file (if */
/* any) to be placed on the stack, and replacing it with FILE. */
/* It may thus be used to implement a START command. */
/* If the file cannot be opened, or the stack is already */
/* full (it can hold up to seven files), ERROR will contain */
/* a descriptive error message upon return. Otherwise, it */
/* will be blank. */
/* - PRREAD ( COMMAND ) */
/* This causes the next command to be read from the current */
/* file. If the end of the current file is reached, the */
/* previous file is popped off the stack, and the next command */
/* from this file is read instead. (If no files remain to be */
/* read, DELIM is returned.) */
/* - PREXIT */
/* This causes the previous file to be popped off the top of */
/* the stack to replace the current file. It may thus be used */
/* to implement an EXIT command. */
/* - PRTRCE ( LEVEL ) */
/* Should an error occur during the execution of a nested */
/* file, it may be helpful to know the sequence in which */
/* the nested files were invoked. PRTRCE returns a list of */
/* the files currently open, in the order in which they were */
/* invoked. */
/* $ Input_Files */
/* All files read by PRCOMF are opened with logical units */
/* determined at run time. */
/* $ Output_Files */
/* None. */
/* $ Input_Common */
/* None. */
/* $ Output_Common */
/* None. */
/* $ Examples */
/* See Detailed_Description. */
/* $ Restrictions */
/* The declared length of ERROR should be at least 80, to avoid */
/* truncationof error messages. */
/* $ Author_and_Institution */
/* W. L. Taber (JPL) */
/* I. M. Underwood (JPL) */
/* $ Version */
/* - Command Loop Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 4, 1994 */
/* Version 1, 6-SEP-1986 */
/* -& */
/* OPTLIB functions */
/* Local variables */
/* NFILES is the maximum number of files that may be open at */
/* any given time. THus, nesting of procedures is limited to */
/* a depth of NFILES. */
/* NEST is the number of files currently open. */
/* FILES are the names of the files on the stack. UNITS are */
/* the logical units to which they are connected. */
switch(n__) {
case 1: goto L_prclr;
case 2: goto L_prstrt;
case 3: goto L_prread;
case 4: goto L_prexit;
case 5: goto L_prtrce;
}
return 0;
/* $ Procedure PRCLR */
L_prclr:
/* $ Abstract */
/* Clear the file stack. */
/* $ 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. */
/* $ Brief_I/O */
/* None. */
/* $ Detailed_Input */
/* None. */
/* $ Detailed_Output */
/* None. */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* None. */
/* $ Detailed_Description */
/* Pop all the files off the stack. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Version */
/* - Command Loop Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 4, 1994 */
/* - */
while(nest > 0) {
cl__1.cerr = 0;
cl__1.cunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 :
s_rnge("units", i__1, "prcomf_", (ftnlen)326)];
cl__1.csta = 0;
f_clos(&cl__1);
--nest;
}
return 0;
/* $ Procedure PRSTRT */
L_prstrt:
/* $ Abstract */
/* Put the current file on the stack, and replace it with 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. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- --------------------------------------------------- */
/* FILE I New command file. */
/* ERROR O Error flag. */
/* $ Detailed_Input */
/* FILE is the new current file from which commands are */
/* to be read. */
/* $ Detailed_Output */
/* ERROR is blank when no error occurs, and otherwise contains */
/* a descriptive message. Possible errors are: */
/* - The stack is full. */
/* - FILE could not be opened. */
/* $ Input_Files */
/* FILE is opened with a logical unit determined at run time. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* None. */
/* $ Detailed_Description */
/* If the stack is full, return an error. Otherwise, try to open */
/* FILE. If an error occurs, return immediately. Otherwise, put */
/* the current file on the stack, and increase the nesting level. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Version */
/* - Command Loop Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 4, 1994 */
/* - */
/* No error yet. */
s_copy(error, " ", error_len, (ftnlen)1);
/* Proceed only if the stack is not full. */
if (nest == 8) {
s_copy(error, "PRSTRT: Command files are nested too deeply.",
error_len, (ftnlen)44);
return 0;
} else {
++nest;
}
/* Get a new logical unit. If none are available, abort. */
txtopr_(file, &units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 : s_rnge(
"units", i__1, "prcomf_", (ftnlen)445)], file_len);
if (have_(error, error_len)) {
--nest;
} else {
s_copy(files + ((i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 : s_rnge(
"files", i__1, "prcomf_", (ftnlen)450)) * 80, file, (ftnlen)
80, file_len);
}
return 0;
/* $ Procedure PRREAD */
L_prread:
/* $ Abstract */
/* Read the next command from the current 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. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- --------------------------------------------------- */
/* DELIM I Character delimiting the end of a command. */
/* COMMAND O Next command from the current file. */
/* $ Detailed_Input */
/* DELIM is the character used to delimit the end of a */
/* command within a command file. */
/* $ Detailed_Output */
/* COMMAND is the next command read from the current file. */
/* If there is no current file, COMMND = DELIM. */
/* $ Input_Files */
/* All files read by PRCOMF are opened with logical units */
/* determined at run time. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* None. */
/* $ Detailed_Description */
/* Attempt to read the next statement from the current file. */
/* If the end of the file is encountered, pop the previous file */
/* off the top of the stack, and try to read from it. Keep this */
/* up until a command is read, or until no files remain open. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Version */
/* - Command Loop Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 4, 1994 */
/* - */
/* Don't even bother unless at least one file is open. */
if (nest == 0) {
s_copy(command, delim, command_len, (ftnlen)1);
return 0;
}
/* Keep trying to read until we run out of files. */
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 : s_rnge(
"units", i__1, "prcomf_", (ftnlen)558)];
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
iostat = do_fio(&c__1, command, command_len);
if (iostat != 0) {
goto L100001;
}
iostat = e_rsfe();
L100001:
while(iostat != 0 && nest > 0) {
cl__1.cerr = 0;
cl__1.cunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 :
s_rnge("units", i__1, "prcomf_", (ftnlen)562)];
cl__1.csta = 0;
f_clos(&cl__1);
--nest;
if (nest >= 1) {
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 :
s_rnge("units", i__1, "prcomf_", (ftnlen)566)];
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100002;
}
iostat = do_fio(&c__1, command, command_len);
if (iostat != 0) {
goto L100002;
}
iostat = e_rsfe();
L100002:
;
}
}
rstbuf_();
if (nest == 0) {
s_copy(command, delim, command_len, (ftnlen)1);
putbuf_(command, command_len);
return 0;
}
putbuf_(command, command_len);
/* Okay, we have something. Keep reading until DELIM is found. */
/* (Or until the file ends.) Add each successive line read to */
/* the end of COMMAND. Do not return the delimiter itself. */
j = 1;
i__ = i_indx(command, delim, command_len, (ftnlen)1);
while(i__ == 0 && iostat == 0) {
j = lastnb_(command, command_len) + 1;
*(unsigned char *)&command[j - 1] = ' ';
++j;
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 :
s_rnge("units", i__1, "prcomf_", (ftnlen)597)];
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100003;
}
iostat = do_fio(&c__1, command + (j - 1), command_len - (j - 1));
if (iostat != 0) {
goto L100003;
}
iostat = e_rsfe();
L100003:
putbuf_(command + (j - 1), command_len - (j - 1));
i__ = i_indx(command, delim, command_len, (ftnlen)1);
}
if (i__ > 0) {
s_copy(command + (i__ - 1), " ", command_len - (i__ - 1), (ftnlen)1);
}
return 0;
/* $ Procedure PREXIT */
L_prexit:
/* $ Abstract */
/* Replace the current file with the one at the top of the stack. */
/* $ 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. */
/* $ Brief_I/O */
/* None. */
/* $ Detailed_Input */
/* None. */
/* $ Detailed_Output */
/* None. */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* None. */
/* $ Detailed_Description */
/* Close the current file. Pop the previous file off the top of */
/* the stack. If there is no current file, of if there are no */
/* files on the stack, that's cool too. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Version */
/* - Command Loop Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 4, 1994 */
/* - */
if (nest > 0) {
cl__1.cerr = 0;
cl__1.cunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 :
s_rnge("units", i__1, "prcomf_", (ftnlen)695)];
cl__1.csta = 0;
f_clos(&cl__1);
--nest;
}
return 0;
/* $ Procedure PRTRCE */
L_prtrce:
/* $ Abstract */
/* Provide a list of the files currently open, in the order in */
/* which they were opened. */
/* $ 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. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- --------------------------------------------------- */
/* LEVEL O List of all files currently open. */
/* $ Detailed_Input */
/* None. */
/* $ Detailed_Output */
/* LEVEL A list of all files that are currently open, in */
/* the order in which they were opened. For example, */
/* if FILE_A starts FILE_B, and FILE_B starts FILE_C, */
/* LEVEL would be 'FILE_A:FILE_B:_FILE_C'. */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* None. */
/* $ Detailed_Description */
/* Just step through the stack, Jack. */
/* $ Examples */
/* See Detailed_Description. */
/* $ Restrictions */
/* LEVEL should be declared to be at least CHARACTER*640 by the */
/* calling program to ensure that enough space is available to */
/* list all open files. */
/* $ Version */
/* - Command Loop Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 4, 1994 */
/* - */
/* Not much to explain. Use LBUILD to build a list, delimited */
/* by colons. */
s_copy(level, " ", level_len, (ftnlen)1);
if (nest > 0) {
lbuild_(files, &nest, ":", level, (ftnlen)80, (ftnlen)1, level_len);
}
return 0;
} /* prcomf_ */
/* $Procedure SCDECD ( Decode spacecraft clock ) */
/* Subroutine */ int scdecd_(integer *sc, doublereal *sclkdp, char *sclkch,
ftnlen sclkch_len)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1;
/* Builtin functions */
double d_nint(doublereal *);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer), i_len(char *, ftnlen);
/* Local variables */
integer part, i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), errdp_(char *,
doublereal *, ftnlen);
doublereal ticks;
extern /* Subroutine */ int scfmt_(integer *, doublereal *, char *,
ftnlen);
doublereal pstop[9999];
extern logical failed_(void);
extern integer lastnb_(char *, ftnlen);
integer prelen;
extern integer lstled_(doublereal *, integer *, doublereal *);
extern /* Subroutine */ int sigerr_(char *, ftnlen);
integer suflen;
extern /* Subroutine */ int scpart_(integer *, integer *, doublereal *,
doublereal *), chkout_(char *, ftnlen), prefix_(char *, integer *,
char *, ftnlen, ftnlen), setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen), suffix_(char *, integer *, char *, ftnlen,
ftnlen);
integer nparts;
doublereal pstart[9999];
extern logical return_(void);
extern /* Subroutine */ int intstr_(integer *, char *, ftnlen);
doublereal ptotls[9999];
char prtstr[5];
/* $ Abstract */
/* Convert double precision encoding of spacecraft clock time into */
/* a character representation. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* SCLK */
/* $ Keywords */
/* CONVERSION */
/* TIME */
/* $ Declarations */
/* $ Abstract */
/* Include file sclk.inc */
/* SPICE private file intended solely for the support of SPICE */
/* routines. Users should not include this file directly due */
/* to the volatile nature of this file */
/* The parameters below define sizes and limits used by */
/* the SCLK system. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Parameters */
/* See the declaration section below. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 2.0.0, 24-MAY-2010 (NJB) */
/* Increased value of maximum coefficient record count */
/* parameter MXCOEF from 10K to 50K. */
/* - SPICELIB Version 1.0.0, 11-FEB-2008 (NJB) */
/* -& */
/* Number of supported SCLK field delimiters: */
/* Supported SCLK string field delimiters: */
/* Maximum number of partitions: */
/* Partition string length. */
/* Since the maximum number of partitions is given by MXPART is */
/* 9999, PRTSTR needs at most 4 characters for the partition number */
/* and one character for the slash. */
/* Maximum number of coefficient records: */
/* Maximum number of fields in an SCLK string: */
/* Length of strings used to represent D.P. */
/* numbers: */
/* Maximum number of supported parallel time systems: */
/* End of include file sclk.inc */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* SC I NAIF spacecraft identification code. */
/* SCLKDP I Encoded representation of a spacecraft clock count. */
/* SCLKCH O Character representation of a clock count. */
/* MXPART P Maximum number of spacecraft clock partitions. */
/* $ Detailed_Input */
/* SC is the NAIF integer code of the spacecraft whose */
/* clock's time is being decoded. */
/* SCLKDP is the double precision encoding of a clock time in */
/* units of ticks since the spacecraft clock start time. */
/* This value does reflect partition information. */
/* An analogy may be drawn between a spacecraft clock */
/* and a standard wall clock. The number of ticks */
/* corresponding to the wall clock string */
/* hh:mm:ss */
/* would be the number of seconds represented by that */
/* time. */
/* For example: */
/* Clock string Number of ticks */
/* ------------ --------------- */
/* 00:00:10 10 */
/* 00:01:00 60 */
/* 00:10:00 600 */
/* 01:00:00 3600 */
/* If SCLKDP contains a fractional part the result */
/* is the same as if SCLKDP had been rounded to the */
/* nearest whole number. */
/* $ Detailed_Output */
/* SCLKCH is the character representation of the clock count. */
/* The exact form that SCLKCH takes depends on the */
/* spacecraft. */
/* Nevertheless, SCLKCH will have the following general */
/* format: */
/* 'pp/sclk_string' */
/* 'pp' is an integer greater than or equal to one and */
/* represents a "partition number". */
/* Each mission is divided into some number of partitions. */
/* A new partition starts when the spacecraft clock */
/* resets, either to zero, or to some other */
/* value. Thus, the first partition for any mission */
/* starts with launch, and ends with the first clock */
/* reset. The second partition starts immediately when */
/* the first stopped, and so on. */
/* In order to be completely unambiguous about a */
/* particular time, you need to specify a partition number */
/* along with the standard clock string. */
/* Information about when partitions occur for different */
/* missions is contained in a spacecraft clock kernel */
/* file which needs to be loaded into the kernel pool */
/* before calling SCDECD. */
/* The routine SCPART may be used to read the partition */
/* start and stop times, in encoded units of ticks, from */
/* the kernel file. */
/* Since the end time of one partition is coincident with */
/* the begin time of the next, two different time strings */
/* with different partition numbers can encode into the */
/* same value. */
/* For example, if partition 1 ends at time t1, and */
/* partition 2 starts at time t2, then */
/* '1/t1' and '2/t2' */
/* will be encoded into the same value, say X. SCDECD */
/* always decodes such values into the latter of the */
/* two partitions. In this example, */
/* CALL SCDECD ( X, SC, CLKSTR ) */
/* will result in */
/* CLKSTR = '2/t2'. */
/* 'sclk_string' is a spacecraft specific clock string, */
/* typically consisting of a number of components */
/* separated by delimiters. */
/* Using Galileo as an example, the full format is */
/* wwwwwwww:xx:y:z */
/* where z is a mod-8 counter (values 0-7) which */
/* increments approximately once every 8 1/3 ms., y is a */
/* mod-10 counter (values 0-9) which increments once */
/* every time z turns over, i.e., approximately once every */
/* 66 2/3 ms., xx is a mod-91 (values 0-90) counter */
/* which increments once every time y turns over, i.e., */
/* once every 2/3 seconds. wwwwwwww is the Real-Time Image */
/* Count (RIM), which increments once every time xx turns */
/* over, i.e., once every 60 2/3 seconds. The roll-over */
/* expression for the RIM is 16777215, which corresponds */
/* to approximately 32 years. */
/* wwwwwwww, xx, y, and z are referred to interchangeably */
/* as the fields or components of the spacecraft clock. */
/* SCLK components may be separated by any of these five */
/* characters: ' ' ':' ',' '-' '.' */
/* The delimiter used is determined by a kernel pool */
/* variable and can be adjusted by the user. */
/* Some spacecraft clock components have offset, or */
/* starting, values different from zero. For example, */
/* with an offset value of 1, a mod 20 counter would */
/* cycle from 1 to 20 instead of from 0 to 19. */
/* See the SCLK required reading for a detailed */
/* description of the Voyager and Mars Observer clock */
/* formats. */
/* $ Parameters */
/* MXPART is the maximum number of spacecraft clock partitions */
/* expected in the kernel file for any one spacecraft. */
/* See the INCLUDE file sclk.inc for this parameter's */
/* value. */
/* $ Exceptions */
/* 1) If kernel variables required by this routine are unavailable, */
/* the error will be diagnosed by routines called by this routine. */
/* SCLKCH will be returned as a blank string in this case. */
/* 2) If the number of partitions in the kernel file for spacecraft */
/* SC exceeds the parameter MXPART, the error */
/* 'SPICE(TOOMANYPARTS)' is signaled. SCLKCH will be returned */
/* as a blank string in this case. */
/* 3) If the encoded value does not fall in the boundaries of the */
/* mission, the error 'SPICE(VALUEOUTOFRANGE)' is signaled. */
/* SCLKCH will be returned as a blank string in this case. */
/* 4) If the declared length of SCLKCH is not large enough to */
/* contain the output clock string the error */
/* 'SPICE(SCLKTRUNCATED)' is signaled either by this routine */
/* or by a routine called by this routine. On output SCLKCH */
/* will contain a portion of the truncated clock string. */
/* $ Files */
/* A kernel file containing spacecraft clock partition information */
/* for the desired spacecraft must be loaded, using the routine */
/* FURNSH, before calling this routine. */
/* $ Particulars */
/* In general, it is difficult to compare spacecraft clock counts */
/* numerically since there are too many clock components for a */
/* single comparison. The routine SCENCD provides a method of */
/* assigning a single double precision number to a spacecraft's */
/* clock count, given one of its character representations. */
/* This routine performs the inverse operation to SCENCD, converting */
/* an encoded double precision number to character format. */
/* To convert the number of ticks since the start of the mission to */
/* a clock format character string, SCDECD: */
/* 1) Determines the spacecraft clock partition that TICKS falls */
/* in. */
/* 2) Subtracts off the number of ticks occurring in previous */
/* partitions, to get the number of ticks since the beginning */
/* of the current partition. */
/* 3) Converts the resulting ticks to clock format and forms the */
/* string */
/* 'partition_number/clock_string' */
/* $ Examples */
/* Double precision encodings of spacecraft clock counts are used to */
/* tag pointing data in the C-kernel. */
/* In the following example, pointing for a sequence of images from */
/* the Voyager 2 narrow angle camera is requested from the C-kernel */
/* using an array of character spacecraft clock counts as input. */
/* The clock counts attached to the output are then decoded to */
/* character and compared with the input strings. */
/* CHARACTER*(25) CLKIN ( 4 ) */
/* CHARACTER*(25) CLKOUT */
/* CHARACTER*(25) CLKTOL */
/* DOUBLE PRECISION TIMEIN */
/* DOUBLE PRECISION TIMOUT */
/* DOUBLE PRECISION CMAT ( 3, 3 ) */
/* INTEGER NPICS */
/* INTEGER SC */
/* DATA NPICS / 4 / */
/* DATA CLKIN / '2/20538:39:768', */
/* . '2/20543:21:768', */
/* . '2/20550:37', */
/* . '2/20561:59' / */
/* DATA CLKTOL / ' 0:01:000' / */
/* C */
/* C The instrument we want pointing for is the Voyager 2 */
/* C narrow angle camera. The reference frame we want is */
/* C J2000. The spacecraft is Voyager 2. */
/* C */
/* INST = -32001 */
/* REF = 'J2000' */
/* SC = -32 */
/* C */
/* C Load the appropriate files. We need */
/* C */
/* C 1) CK file containing pointing data. */
/* C 2) Spacecraft clock kernel file, for SCENCD and SCDECD. */
/* C */
/* CALL CKLPF ( 'VGR2NA.CK' ) */
/* CALL FURNSH ( 'SCLK.KER' ) */
/* C */
/* C Convert the tolerance string to ticks. */
/* C */
/* CALL SCTIKS ( SC, CLKTOL, TOL ) */
/* DO I = 1, NPICS */
/* CALL SCENCD ( SC, CLKIN( I ), TIMEIN ) */
/* CALL CKGP ( INST, TIMEIN, TOL, REF, CMAT, TIMOUT, */
/* . FOUND ) */
/* CALL SCDECD ( SC, TIMOUT, CLKOUT ) */
/* WRITE (*,*) */
/* WRITE (*,*) 'Input s/c clock count: ', CLKIN( I ) */
/* WRITE (*,*) 'Output s/c clock count: ', CLKOUT */
/* WRITE (*,*) 'Output C-Matrix: ', CMAT */
/* END DO */
/* The output from such a program might look like: */
/* Input s/c clock count: 2/20538:39:768 */
/* Output s/c clock count: 2/20538:39:768 */
/* Output C-Matrix: 'first C-matrix' */
/* Input s/c clock count: 2/20543:21:768 */
/* Output s/c clock count: 2/20543:22:768 */
/* Output C-Matrix: 'second C-matrix' */
/* Input s/c clock count: 2/20550:37 */
/* Output s/c clock count: 2/20550:36:768 */
/* Output C-Matrix: 'third C-matrix' */
/* Input s/c clock count: 2/20561:59 */
/* Output s/c clock count: 2/20561:58:768 */
/* Output C-Matrix: 'fourth C-matrix' */
/* $ Restrictions */
/* 1) Assumes that an SCLK kernel file appropriate for the clock */
/* designated by SC is loaded in the kernel pool at the time */
/* this routine is called. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* J.M. Lynch (JPL) */
/* R.E. Thurman (JPL) */
/* $ Version */
/* - SPICELIB Version 2.1.0, 05-FEB-2008 (NJB) */
/* Values of parameter MXPART and PARTLN are now */
/* provided by the INCLUDE file sclk.inc. */
/* - SPICELIB Version 2.0.1, 22-AUG-2006 (EDW) */
/* Replaced references to LDPOOL with references */
/* to FURNSH. */
/* - SPICELIB Version 2.0.0, 17-APR-1992 (JML) (WLT) */
/* The routine was changed to signal an error when SCLKCH is */
/* not long enough to contain the output spacecraft clock */
/* string. */
/* FAILED is now checked after calling SCPART. */
/* References to CLPOOL were deleted. */
/* Miscellaneous minor updates to the header were performed. */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 06-SEP-1990 (JML) (RET) */
/* -& */
/* $ Index_Entries */
/* decode spacecraft_clock */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 10-APR-1992 (JML) (WLT) */
/* The routine was changed to signal an error when SCLKCH is */
/* not long enough to contain the output spacecraft clock */
/* string. Previously, the SCLK routines simply truncated */
/* the clock string on the right. It was determined that */
/* since this truncation could easily go undetected by the */
/* user ( only the leftmost field of a clock string is */
/* required when clock string is used as an input to a */
/* SCLK routine ), it would be better to signal an error */
/* when this happens. */
/* FAILED is checked after calling SCPART in case an */
/* error has occurred reading the kernel file and the */
/* error action is not set to 'abort'. */
/* References to CLPOOL were deleted. */
/* Miscellaneous minor updates to the header were performed. */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SCDECD", (ftnlen)6);
}
/* Use a working copy of the input. */
ticks = d_nint(sclkdp);
s_copy(sclkch, " ", sclkch_len, (ftnlen)1);
/* Read the partition start and stop times (in ticks) for this */
/* mission. Error if there are too many of them. Also need to */
/* check FAILED in case error handling is not in ABORT or */
/* DEFAULT mode. */
scpart_(sc, &nparts, pstart, pstop);
if (failed_()) {
chkout_("SCDECD", (ftnlen)6);
return 0;
}
if (nparts > 9999) {
setmsg_("The number of partitions, #, for spacecraft # exceeds the v"
"alue for parameter MXPART, #.", (ftnlen)88);
errint_("#", &nparts, (ftnlen)1);
errint_("#", sc, (ftnlen)1);
errint_("#", &c__9999, (ftnlen)1);
sigerr_("SPICE(TOOMANYPARTS)", (ftnlen)19);
chkout_("SCDECD", (ftnlen)6);
return 0;
}
/* For each partition, compute the total number of ticks in that */
/* partition plus all preceding partitions. */
d__1 = pstop[0] - pstart[0];
ptotls[0] = d_nint(&d__1);
i__1 = nparts;
for (i__ = 2; i__ <= i__1; ++i__) {
d__1 = ptotls[(i__3 = i__ - 2) < 9999 && 0 <= i__3 ? i__3 : s_rnge(
"ptotls", i__3, "scdecd_", (ftnlen)495)] + pstop[(i__4 = i__
- 1) < 9999 && 0 <= i__4 ? i__4 : s_rnge("pstop", i__4, "scd"
"ecd_", (ftnlen)495)] - pstart[(i__5 = i__ - 1) < 9999 && 0 <=
i__5 ? i__5 : s_rnge("pstart", i__5, "scdecd_", (ftnlen)495)];
ptotls[(i__2 = i__ - 1) < 9999 && 0 <= i__2 ? i__2 : s_rnge("ptotls",
i__2, "scdecd_", (ftnlen)495)] = d_nint(&d__1);
}
/* The partition corresponding to the input ticks is the first one */
/* whose tick total is greater than the input value. The one */
/* exception is when the input ticks is equal to the total number */
/* of ticks represented by all the partitions. In this case the */
/* partition number is the last one, i.e. NPARTS. */
/* Error if TICKS comes before the first partition (that is, if it's */
/* negative), or after the last one. */
if (ticks == ptotls[(i__1 = nparts - 1) < 9999 && 0 <= i__1 ? i__1 :
s_rnge("ptotls", i__1, "scdecd_", (ftnlen)510)]) {
part = nparts;
} else {
part = lstled_(&ticks, &nparts, ptotls) + 1;
}
if (ticks < 0. || part > nparts) {
setmsg_("Value for ticks, #, does not fall in any partition for spac"
"ecraft #.", (ftnlen)68);
errdp_("#", &ticks, (ftnlen)1);
errint_("#", sc, (ftnlen)1);
sigerr_("SPICE(VALUEOUTOFRANGE)", (ftnlen)22);
chkout_("SCDECD", (ftnlen)6);
return 0;
}
/* To get the count in this partition, subtract off the total of */
/* the preceding partition counts and add the beginning count for */
/* this partition. */
if (part == 1) {
ticks += pstart[(i__1 = part - 1) < 9999 && 0 <= i__1 ? i__1 : s_rnge(
"pstart", i__1, "scdecd_", (ftnlen)535)];
} else {
ticks = ticks + pstart[(i__1 = part - 1) < 9999 && 0 <= i__1 ? i__1 :
s_rnge("pstart", i__1, "scdecd_", (ftnlen)537)] - ptotls[(
i__2 = part - 2) < 9999 && 0 <= i__2 ? i__2 : s_rnge("ptotls",
i__2, "scdecd_", (ftnlen)537)];
}
/* Now create the output SCLK clock string. */
/* First convert from ticks to clock string format. */
scfmt_(sc, &ticks, sclkch, sclkch_len);
/* Now convert the partition number to a character string and prefix */
/* it to the output string. */
intstr_(&part, prtstr, (ftnlen)5);
suffix_("/", &c__0, prtstr, (ftnlen)1, (ftnlen)5);
prelen = lastnb_(prtstr, (ftnlen)5);
suflen = lastnb_(sclkch, sclkch_len);
if (i_len(sclkch, sclkch_len) - suflen < prelen) {
setmsg_("Output string too short to contain clock string. Input tick"
" value: #, requires string of length #, but declared length "
"is #.", (ftnlen)124);
errdp_("#", sclkdp, (ftnlen)1);
i__1 = prelen + suflen;
errint_("#", &i__1, (ftnlen)1);
i__1 = i_len(sclkch, sclkch_len);
errint_("#", &i__1, (ftnlen)1);
sigerr_("SPICE(SCLKTRUNCATED)", (ftnlen)20);
chkout_("SCDECD", (ftnlen)6);
return 0;
}
prefix_(prtstr, &c__0, sclkch, (ftnlen)5, sclkch_len);
chkout_("SCDECD", (ftnlen)6);
return 0;
} /* scdecd_ */
/* $Procedure COUNTC ( Count characters in a text file ) */
integer countc_(integer *unit, integer *bline, integer *eline, char *line,
ftnlen line_len)
{
/* System generated locals */
integer ret_val;
cilist ci__1;
alist al__1;
/* Builtin functions */
integer f_rew(alist *), s_rsfe(cilist *), do_fio(integer *, char *,
ftnlen), e_rsfe(void), s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
logical done;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer chars, linect;
extern integer lastnb_(char *, ftnlen);
extern /* Subroutine */ int errfnm_(char *, integer *, ftnlen), sigerr_(
char *, ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen), astrip_(
char *, char *, char *, char *, ftnlen, ftnlen, ftnlen, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Count the characters in a group of lines in a text 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 */
/* None. */
/* $ Keywords */
/* CHARACTERS */
/* FILES */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* UNIT I Logical unit connected to text file. */
/* BLINE I Beginning line number. */
/* ELINE I Ending line number. */
/* LINE I,O Workspace. */
/* COUNTC returns the number of characters. */
/* $ Detailed_Input */
/* UNIT is a logical unit that has been connected to a */
/* text file by the calling program. Use the routine */
/* TXTOPR to open the file for read access and get its */
/* logical unit. A text file is a formatted, */
/* sequential file that contains only printable */
/* characters: ASCII 32-126. */
/* BLINE, */
/* ELINE are line numbers in the text file. BLINE is */
/* the line where the count will begin, and ELINE */
/* is the line where the count will end. The */
/* number of characters in the beginning and ending */
/* lines are included in the total count. */
/* By convention, line 1 is the first line of the file. */
/* LINE on input, is an arbitrary character string whose */
/* contents are ignored. LINE is used to read lines */
/* from the file connected to UNIT; its function */
/* is to determine the maximum length of the lines */
/* that can be read from the file. Lines longer */
/* than the declared length of LINE are truncated */
/* as they are read. */
/* $ Detailed_Output */
/* LINE on output, is undefined. */
/* The function, COUNTC, returns the number of characters in the */
/* group of lines in the file beginning with BLINE and ending with */
/* ELINE. Trailing blanks on a line are not included in the count. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If an error occurs while reading from the input file, */
/* the error SPICE(FILEREADFAILED) is signalled. */
/* 2) If a non-printing ASCII character is encountered during */
/* the count, the error SPICE(INVALIDTEXT) is signalled. */
/* 3) If BLINE is greater than ELINE or if the file does not */
/* contain both of this lines, the error SPICE(CANNOTFINDGRP) */
/* is signalled. */
/* $ Files */
/* See argument UNIT. COUNTC rewinds the text file connected to */
/* UNIT and then steps through the file. The next read statement */
/* after calling COUNTC would return the line after ELINE. */
/* $ Particulars */
/* This routine counts characters in a group of lines in a text */
/* file. Using COUNTC, you can determine in advance how much space */
/* is required to store those characters. */
/* $ Examples */
/* The following code fragment opens an existing text file for */
/* read access and counts the characters that it contains in */
/* the first five lines. We'll assume that the longest line */
/* in the file is 80 characters. */
/* INTEGER COUNTC */
/* INTEGER UNIT */
/* INTEGER N */
/* CHARACTER*(80) LINE */
/* CALL TXTOPR ( 'DATA.TXT', UNIT ) */
/* N = COUNTC ( UNIT, 1, 5, LINE ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* J.E. McLean (JPL) */
/* H.A. Neilan (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.0, 17-MAY-1994 (HAN) */
/* Set the default function value to either 0, 0.0D0, .FALSE., */
/* or blank depending on the type of the function. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 05-APR-1991 (JEM) */
/* -& */
/* $ Index_Entries */
/* count characters in a text file */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
ret_val = 0;
return ret_val;
} else {
chkin_("COUNTC", (ftnlen)6);
ret_val = 0;
}
/* First, see if the line numbers make sense. */
if (*bline > *eline || *bline <= 0) {
setmsg_("The line numbers do not make sense: BLINE = # and ELINE ="
" #.", (ftnlen)62);
errint_("#", bline, (ftnlen)1);
errint_("#", eline, (ftnlen)1);
sigerr_("SPICE(CANNOTFINDGRP)", (ftnlen)20);
chkout_("COUNTC", (ftnlen)6);
return ret_val;
}
/* Read through the file, line by line, beginning with the first */
/* line in the file, checking for I/O errors, and counting */
/* characters in the lines between and including BLINE and ELINE. */
al__1.aerr = 0;
al__1.aunit = *unit;
f_rew(&al__1);
linect = 0;
chars = 0;
done = FALSE_;
while(! done) {
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = *unit;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
iostat = do_fio(&c__1, line, line_len);
if (iostat != 0) {
goto L100001;
}
iostat = e_rsfe();
L100001:
/* An end-of-file condition is indicated by a negative value */
/* for IOSTAT. Any other non-zero value indicates some other */
/* error. If IOSTAT is zero, the read was successful. */
if (iostat > 0) {
setmsg_("Error reading text file named FILENAME.The value of IOS"
"TAT is #.", (ftnlen)64);
errint_("#", &iostat, (ftnlen)1);
errfnm_("FILENAME", unit, (ftnlen)8);
sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
chkout_("COUNTC", (ftnlen)6);
return ret_val;
} else if (iostat < 0) {
setmsg_("Reached end of file unexpectedly at line # in file FILE"
". BLINE = # and ELINE = #.", (ftnlen)82);
errint_("#", &linect, (ftnlen)1);
errint_("#", bline, (ftnlen)1);
errint_("#", eline, (ftnlen)1);
errfnm_("FILE", unit, (ftnlen)4);
sigerr_("SPICE(CANNOTFINDGRP)", (ftnlen)20);
chkout_("COUNTC", (ftnlen)6);
return ret_val;
} else {
/* We've read a line successfully, so add it to the line count. */
/* If this line is in the group delimited by BLINE and ELINE, */
/* count the characters in it, and if this line is ELINE, we're */
/* done. */
++linect;
if (linect >= *bline && linect <= *eline) {
/* Add the number of characters in this line to the count. */
/* If LINE is blank, LASTNB will return 0 which is just */
/* what we want. */
chars += lastnb_(line, line_len);
/* Remove the printable characters from the line. If */
/* any characters remain, signal an error. */
astrip_(line, " ", "~", line, line_len, (ftnlen)1, (ftnlen)1,
line_len);
if (s_cmp(line, " ", line_len, (ftnlen)1) != 0) {
setmsg_("Non-printing ASCII characters were found when c"
"ounting characters on line number # in file FILE"
"NAME.", (ftnlen)100);
errint_("#", &linect, (ftnlen)1);
errfnm_("FILENAME", unit, (ftnlen)8);
sigerr_("SPICE(INVALIDTEXT)", (ftnlen)18);
chkout_("COUNTC", (ftnlen)6);
return ret_val;
}
}
if (linect == *eline) {
done = TRUE_;
}
}
}
/* Assign the final character count. */
ret_val = chars;
chkout_("COUNTC", (ftnlen)6);
return ret_val;
} /* countc_ */
/* $Procedure ASTRIP ( STRIP Ascii characters from a string ) */
/* Subroutine */ int astrip_(char *instr, char *asciib, char *asciie, char *
outstr, ftnlen instr_len, ftnlen asciib_len, ftnlen asciie_len,
ftnlen outstr_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer last, i__, j, k;
extern integer lastnb_(char *, ftnlen);
integer lwrbnd, uprbnd, outlen;
/* $ Abstract */
/* Remove from a character string all characters which fall */
/* between specified starting and ending characters, inclusive. */
/* $ 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 */
/* ASCII, CHARACTER */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* INSTR I Input string. */
/* ASCIIB I First ASCII character in range to be stripped. */
/* ASCIIE I Last ASCII character in range to be stripped. */
/* OUTSTR O Output (stripped) string. */
/* $ Detailed_Input */
/* INSTR Is a character string from which all characters */
/* between ASCIIB and ASCIIE, inclusive, are to be */
/* removed. */
/* ASCIIB Is the first ASCII character in the range of */
/* characters to be removed from the input string. */
/* ASCIIB is itself removed from the string, if */
/* it occurs. */
/* ASCIIE Is the last ASCII character in the range of */
/* characters to be removed from the input string. */
/* ASCIIE is itself removed from the string, if */
/* it occurs. */
/* $ Detailed_Output */
/* OUTSTR Is the input string after all the character */
/* between ASCIIB and ASCIIE, inclusive, have */
/* been removed. */
/* If OUTSTR is not large enough to hold the output */
/* string, it is truncated on the right. */
/* OUTSTR may overwrite INSTR. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* ASTRIP checks each character */
/* in INSTR to determine if it falls between the characters ASCIIB */
/* and ASCIIE. If so this character is removed from the string */
/* (and the string is shortened). Remaining characters are copied */
/* to the output string. */
/* $ Examples */
/* The following examples illustrate the use of ASTRIP. */
/* ASCIIB = 'b' */
/* ASCIIE = 'k' */
/* INSTR = 'Now is the time for all good men to come quick.' */
/* OUTSTR = 'Now s t tm or all oo mn to om qu.' */
/* ASCIIB = 'a' */
/* ASCIIE = 'z' */
/* INSTR = 'SELECT column TIME FROM table TEST' */
/* OUTSTR = 'SELECT TIME FROM TEST' */
/* ASCIIB = 'a' */
/* ASCIIE = 'z' */
/* INSTR = 'this is going to be an empty string' */
/* OUTSTR = ' ' */
/* ASCIIB = '!' */
/* ASCIIE = '!' */
/* INSTR = 'Only 32 more shopping days until Christmas!' */
/* OUTSTR = 'Only 32 more shopping days until Christmas' */
/* ASTRIP may also be used to strip ASCII control characters */
/* (line feeds, tab stops, and so on), as shown in the example */
/* below. */
/* ASCIIB = CHAR ( 0 ) */
/* ASCIIE = CHAR ( 31 ) */
/* CALL ASTRIP ( STRING, ASCIIB, ASCIIE, STRING ) */
/* $ Restrictions */
/* If ASCIIB and ASCIIE are not properly ordered (that is, */
/* if ICHAR(ASCIIB) is not less than or equal to ICHAR(ASCIIE)) */
/* then ASTRIP will not function as described. (In fact, it will */
/* copy the input string to the output string without change.) */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* strip ascii characters from a string */
/* -& */
/* SPICELIB functions */
/* Local Variables */
/* Find the length of the output string. We don't want to */
/* exceed it. */
outlen = i_len(outstr, outstr_len);
/* Find the last non-blank character of the input string. */
last = lastnb_(instr, instr_len);
/* Get the numeric representation of ASCIIB and ASCIIE. */
lwrbnd = *(unsigned char *)asciib;
uprbnd = *(unsigned char *)asciie;
/* Step through INSTR (I) a character at a time, transferring */
/* characters to OUTSTR (J) whenever they fall outside the range */
/* [ASCIIB, ASCIIE]. */
/* If the end of OUTSTR is reached, stop transferring characters */
/* and return. */
j = 0;
i__1 = last;
for (i__ = 1; i__ <= i__1; ++i__) {
k = *(unsigned char *)&instr[i__ - 1];
if (k < lwrbnd || k > uprbnd) {
/* The character is kept. Note that if the user inputs */
/* ASCIIB and ASCIIE in the wrong order this test will */
/* always succeed so that the output string will be */
/* the same as the input string. */
++j;
*(unsigned char *)&outstr[j - 1] = *(unsigned char *)&instr[i__ -
1];
if (j == outlen) {
return 0;
}
}
}
/* Pad the output string with blanks. */
if (j < outlen) {
i__1 = j;
s_copy(outstr + i__1, " ", outstr_len - i__1, (ftnlen)1);
}
return 0;
} /* astrip_ */
/* $Procedure ZZBODBLT ( Private --- Retrieve Built-In Body-Code Maps ) */
/* Subroutine */ int zzbodblt_0_(int n__, integer *room, char *names, char *
nornam, integer *codes, integer *nvals, char *device, char *reqst,
ftnlen names_len, ftnlen nornam_len, ftnlen device_len, ftnlen
reqst_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
address a__1[2], a__2[3];
integer i__1, i__2, i__3[2], i__4[3];
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen), movec_(char *, integer *, char *, ftnlen,
ftnlen), movei_(integer *, integer *, integer *);
extern logical eqstr_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
char zzint[36];
static integer bltcod[563];
static char bltnam[36*563];
extern /* Subroutine */ int orderc_(char *, integer *, integer *, ftnlen);
extern integer lastnb_(char *, ftnlen);
extern /* Subroutine */ int orderi_(integer *, integer *, integer *),
sigerr_(char *, ftnlen), chkout_(char *, ftnlen);
static char bltnor[36*563];
extern /* Subroutine */ int wrline_(char *, char *, ftnlen, ftnlen),
setmsg_(char *, ftnlen), errint_(char *, integer *, ftnlen),
cmprss_(char *, integer *, char *, char *, ftnlen, ftnlen, ftnlen)
;
integer zzocod[563];
char zzline[75];
integer zzonam[563];
extern logical return_(void);
extern /* Subroutine */ int intstr_(integer *, char *, ftnlen);
char zzrqst[4];
extern /* Subroutine */ int zzidmap_(integer *, char *, ftnlen);
/* $ Abstract */
/* SPICE Private routine intended solely for the support of SPICE */
/* routines. Users should not call this routine directly due */
/* to the volatile nature of this routine. */
/* This is the umbrella routine that contains entry points to */
/* access the built-in body name-code mappings. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* BODY */
/* $ Declarations */
/* $ Abstract */
/* This include file lists the parameter collection */
/* defining the number of SPICE ID -> NAME mappings. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* naif_ids.req */
/* $ Keywords */
/* Body mappings. */
/* $ Author_and_Institution */
/* E.D. Wright (JPL) */
/* $ Version */
/* SPICELIB 1.0.0 Thu May 20 07:57:58 2010 (EDW) */
/* A script generates this file. Do not edit by hand. */
/* Edit the creation script to modify the contents of */
/* ZZBODTRN.INC. */
/* Maximum size of a NAME string */
/* Count of default SPICE mapping assignments. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ROOM I ZZBODGET */
/* NAMES O ZZBODGET */
/* NORNAM O ZZBODGET */
/* CODES O ZZBODGET */
/* NVALS O ZZBODGET */
/* DEVICE I ZZBODLST */
/* REQST I ZZBODLST */
/* $ Detailed_Input */
/* See the entry points for a discussion of their arguments. */
/* $ Detailed_Output */
/* See the entry points for a discussion of their arguments. */
/* $ Parameters */
/* See the include file 'zzbodtrn.inc' for the list of parameters */
/* this routine utilizes. */
/* $ Exceptions */
/* 1) The error SPICE(BOGUSENTRY) is signaled if ZZBODBLT is */
/* called directly. */
/* $ Files */
/* None. */
/* $ Particulars */
/* ZZBODBLT should never be called directly, instead access */
/* the entry points: */
/* ZZBODGET Fetch the built-in body name/code list. */
/* ZZBODLST Output the name-ID mapping list. */
/* $ Examples */
/* See ZZBODTRN and its entry points for details. */
/* $ Restrictions */
/* 1) No duplicate entries should appear in the built-in */
/* BLTNAM list. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 2.3.1, 27-FEB-2007 (EDW) */
/* Completed the ZZBODLST decalrations section. */
/* - SPICELIB Version 2.3.0, 17-MAR-2003 (EDW) */
/* Added a call to ZZIDMAP to retrieve the default */
/* mapping list. "zzbodtrn.inc" no longer */
/* contains the default mapping list. */
/* - SPICELIB Version 2.2.0 21-FEB-2003 (BVS) */
/* Changed MER-A and MER-B to MER-1 and MER-2. */
/* - SPICELIB Version 2.1.0 04-DEC-2002 (EDW) */
/* Added new assignments to the default collection: */
/* -226 ROSETTA */
/* 517 CALLIRRHOE */
/* 518 THEMISTO */
/* 519 MAGACLITE */
/* 520 TAYGETE */
/* 521 CHALDENE */
/* 522 HARPALYKE */
/* 523 KALYKE */
/* 524 IOCASTE */
/* 525 ERINOME */
/* 526 ISONOE */
/* 527 PRAXIDIKE */
/* - SPICELIB Version 2.0.0, 23-AUG-2002 (FST) */
/* Initial release. This begins at Version 2.0.0 because */
/* the entry point ZZBODLST was cut out of ZZBODTRN and */
/* placed here at Version 1.0.0. */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 23-AUG-2002 (FST) */
/* The entries following this one were copied from */
/* the version section of ZZBODTRN. SPICELIB has */
/* been changed to ZZBODTRN for convenience in noting */
/* version information relevant for that module. */
/* This was done to carry the history of body name-code */
/* additions with this new umbrella. */
/* Added to the collection: */
/* -236 MESSENGER */
/* - ZZBODTRN Version 3.2.0, 14-AUG-2002 (EDW) */
/* Added the ZZBODKIK entry point. */
/* Moved the NAIF_BODY_NAME/CODE to subroutine */
/* ZZBODKER. No change in logic. */
/* Added logic to enforce the precedence masking; */
/* logic removes duplicate assignments of ZZBODDEF. */
/* Removed the NAMENOTUNIQUE error block. */
/* - ZZBODTRN Version 3.1.5, 27-NOV-2001 (EDW) */
/* Added to the collection: */
/* -200 CONTOUR */
/* -146 LUNAR-A */
/* -135 DRTS-W */
/* Added the subroutine ZZBODLST as an entry point. */
/* The routine outputs the current name-ID mapping */
/* list to some output device. */
/* - ZZBODTRN Version 3.1.0, 17-OCT-2001 (EDW) */
/* To improve clarity, the BEGXX block initialization now */
/* exists in the include file zzbodtrn.inc. */
/* Removed the comments concerning the 851, 852, ... temporary */
/* codes. */
/* Set the WNAMES assignment to NAIF_BODY_CODE, NAIF_BODY_NAME */
/* as a DATA statement. */
/* Edited headers to match information in naif_ids required */
/* reading. */
/* Edited headers, removed typos and bad grammar, clarified */
/* descriptions. */
/* Added to the collection */
/* -41 MARS EXPRESS, MEX */
/* -44 BEAGLE 2, BEAGLE2 */
/* -70 DEEP IMPACT IMPACTOR SPACECRAFT */
/* -94 MO, MARS OBSERVER */
/* -140 DEEP IMPACT FLYBY SPACECRAFT */
/* -172 SLCOMB, STARLIGHT COMBINER */
/* -205 SLCOLL, STARLIGHT COLLECTOR */
/* -253 MER-A */
/* -254 MER-B */
/* Corrected typo, vehicle -188 should properly be MUSES-C, */
/* previous versions listed the name as MUSES-B. */
/* Removed from collection */
/* -84 MARS SURVEYOR 01 LANDER */
/* -154 EOS-PM1 */
/* -200 PLUTO EXPRESS 1, PEX1 */
/* -202 PLUTO EXPRESS 2, PEX2 */
/* - ZZBODTRN Version 3.0.0, 29-MAR-2000 (WLT) */
/* The ID codes for Cluster 1, 2, 3 and 4 were added. The */
/* ID coded for Pluto Express were removed. The ID codes */
/* for Pluto-Kuiper Express, Pluto-Kuiper Express Simulation */
/* and Contour were added. */
/* - ZZBODTRN Version 2.0.0, 26-JAN-1998 (EDW) */
/* The Galileo probe ID -228 replaces the incorrect ID -344. */
/* DSS stations 5 through 65 added to the collection. */
/* Added to the collection */
/* -107 TROPICAL RAINFALL MEASURING MISSION, TRMM */
/* -154, EOS-PM1 */
/* -142 EOS-AM1 */
/* -151 AXAF */
/* -1 GEOTAIL */
/* -13 POLAR */
/* -21 SOHO */
/* -8 WIND */
/* -25 LUNAR PROSPECTOR, LPM */
/* -116 MARS POLAR LANDER, MPL */
/* -127 MARS CLIMATE ORBITER, MCO */
/* -188 MUSES-C */
/* -97 TOPEX/POSEIDON */
/* -6 PIONEER-6, P6 */
/* -7 PIONEER-7, P7 */
/* -20 PIONEER-8, P8 */
/* -23 PIONEER-10, P10 */
/* -24 PIONEER-11, P11 */
/* -178 NOZOMI, PLANET-B */
/* -79 SPACE INFRARED TELESCOPE FACILITY, SIRTF */
/* -29 STARDUST, SDU */
/* -47 GENESIS */
/* -48 HUBBLE SPACE TELESCOPE, HST */
/* -200 PLUTO EXPRESS 1, PEX1 */
/* -202 PLUTO EXPRESS 2, PEX2 */
/* -164 YOHKOH, SOLAR-A */
/* -165 MAP */
/* -166 IMAGE */
/* -53 MARS SURVEYOR 01 ORBITER */
/* 618 PAN */
/* 716 CALIBAN */
/* 717 SYCORAX */
/* -30 DS-1 (low priority) */
/* -58 HALCA */
/* -150 HUYGEN PROBE, CASP */
/* -55 ULS */
/* Modified ZZBODC2N and ZZBODN2C so the user may load an */
/* external IDs kernel to override or supplement the standard */
/* collection. The kernel must be loaded prior a call to */
/* ZZBODC2N or ZZBODN2C. */
/* - ZZBODTRN Version 1.1.0, 22-MAY-1996 (WLT) */
/* Added the id-code for Comet Hyakutake, Comet Hale-Bopp, */
/* Mars 96, Cassini Simulation, MGS Simulation. */
/* - ZZBODTRN Version 1.0.0, 25-SEP-1995 (BVS) */
/* Renamed umbrella subroutine and entry points to */
/* correspond private routine convention (ZZ...). Added IDs for */
/* tracking stations Goldstone (399001), Canberra (399002), */
/* Madrid (399003), Usuda (399004). */
/* - ZZBODTRN Version 2.2.0, 01-AUG-1995 (HAN) */
/* Added the IDs for Near Earth Asteroid Rendezvous (-93), */
/* Mars Pathfinder (-53), Ulysses (-55), VSOP (-58), */
/* Radioastron (-59), Cassini spacecraft (-82), and Cassini */
/* Huygens probe (-150). */
/* Mars Observer (-94) was replaced with Mars Global */
/* Surveyor (-94). */
/* - ZZBODTRN Version 2.1.0, 15-MAR-1995 (KSZ) (HAN) */
/* Two Shoemaker Levy 9 fragments were added, Q1 and P2 */
/* (IDs 50000022 and 50000023). Two asteroids were added, */
/* Eros and Mathilde (IDs 2000433 and 2000253). The */
/* Saturnian satellite Pan (ID 618) was added. */
/* - ZZBODTRN Version 2.0.0, 03-FEB-1995 (NJB) */
/* The Galileo probe (ID -344) has been added to the permanent */
/* collection. */
/* - ZZBODTRN Version 1.0.0, 29-APR-1994 (MJS) */
/* SPICELIB symbol tables are no longer used. Instead, two order */
/* vectors are used to index the NAMES and CODES arrays. Also, */
/* this version does not support reading body name ID pairs from a */
/* file. */
/* - ZZBODTRN Version 2.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - ZZBODTRN Version 2.0.0, 15-JUL-1991 (WLT) */
/* The body id's for the Uranian satellites discovered by Voyager */
/* were modified to conform to those established by the IAU */
/* nomenclature committee. In addition the id's for Gaspra and */
/* Ida were added. */
/* - ZZBODTRN Version 1.0.0, 7-MAR-1991 (WLT) */
/* Some items previously considered errors were removed */
/* and some minor modifications were made to improve the */
/* robustness of the routines. */
/* - ZZBODTRN Version 1.0.0, 28-JUN-1990 (JEM) */
/* -& */
/* SPICELIB Functions */
/* Local Parameters */
/* Local Variables */
/* Saved Variables */
/* Data Statements */
/* Parameter adjustments */
if (names) {
}
if (nornam) {
}
if (codes) {
}
/* Function Body */
switch(n__) {
case 1: goto L_zzbodget;
case 2: goto L_zzbodlst;
}
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZBODBLT", (ftnlen)8);
sigerr_("SPICE(BOGUSENTRY)", (ftnlen)17);
chkout_("ZZBODBLT", (ftnlen)8);
}
return 0;
/* $Procedure ZZBODGET ( Private --- Body-Code Get Built-In List ) */
L_zzbodget:
/* $ 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. */
/* Retrieve a copy of the built-in body name-code mapping lists. */
/* $ 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 */
/* BODY */
/* $ Declarations */
/* INTEGER ROOM */
/* CHARACTER*(*) NAMES ( * ) */
/* CHARACTER*(*) NORNAM ( * ) */
/* INTEGER CODES ( * ) */
/* INTEGER NVALS */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ROOM I Space available in NAMES, NORNAM, and CODES. */
/* NAMES O Array of built-in body names. */
/* NORNAM O Array of normalized built-in body names. */
/* CODES O Array of built-in ID codes for NAMES/NORNAM. */
/* NVALS O Length of NAMES, NORNAM, CODES, and ORDNOM arrays. */
/* $ Detailed_Input */
/* ROOM is the maximum number of entries that NAMES, NORNAM, */
/* and CODES may receive. */
/* $ Detailed_Output */
/* NAMES the array of built-in names. This array is parallel */
/* to NORNAM and CODES. */
/* NORNAM the array of normalized built-in body names. This */
/* array is computed from the NAMES array by compressing */
/* groups of spaces into a single space, left-justifying */
/* the name, and uppercasing the letters. */
/* CODES the array of built-in codes associated with NAMES */
/* and NORNAM entries. */
/* NVALS the number of items returned in NAMES, NORNAM, */
/* and CODES. */
/* $ Parameters */
/* NPERM the number of permanent, or built-in, body name-code */
/* mappings. */
/* $ Exceptions */
/* 1) SPICE(BUG) is signaled if ROOM is less than NPERM, the */
/* amount of space required to store the entire list of */
/* body names and codes. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine simply copies it's local buffered version of the */
/* built-in name-code mappings to the output arguments. */
/* $ Examples */
/* See ZZBODTRN for sample usage. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* $ Version */
/* - SPICELIB Version 2.1.0, 17-MAR-2003 (EDW) */
/* Added a call to ZZIDMAP to retrieve the default */
/* mapping list. "zzbodtrn.inc" no longer */
/* contains the default mapping list. */
/* - SPICELIB Version 2.0.0, 23-AUG-2002 (FST) */
/* -& */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZBODGET", (ftnlen)8);
}
/* On the first invocation compute the normalized forms of BLTNAM */
/* and store them in BLTNOR. */
if (first) {
/* Retrieve the default mapping list. */
zzidmap_(bltcod, bltnam, (ftnlen)36);
for (i__ = 1; i__ <= 563; ++i__) {
ljust_(bltnam + ((i__1 = i__ - 1) < 563 && 0 <= i__1 ? i__1 :
s_rnge("bltnam", i__1, "zzbodblt_", (ftnlen)565)) * 36,
bltnor + ((i__2 = i__ - 1) < 563 && 0 <= i__2 ? i__2 :
s_rnge("bltnor", i__2, "zzbodblt_", (ftnlen)565)) * 36, (
ftnlen)36, (ftnlen)36);
ucase_(bltnor + ((i__1 = i__ - 1) < 563 && 0 <= i__1 ? i__1 :
s_rnge("bltnor", i__1, "zzbodblt_", (ftnlen)566)) * 36,
bltnor + ((i__2 = i__ - 1) < 563 && 0 <= i__2 ? i__2 :
s_rnge("bltnor", i__2, "zzbodblt_", (ftnlen)566)) * 36, (
ftnlen)36, (ftnlen)36);
cmprss_(" ", &c__1, bltnor + ((i__1 = i__ - 1) < 563 && 0 <= i__1
? i__1 : s_rnge("bltnor", i__1, "zzbodblt_", (ftnlen)567))
* 36, bltnor + ((i__2 = i__ - 1) < 563 && 0 <= i__2 ?
i__2 : s_rnge("bltnor", i__2, "zzbodblt_", (ftnlen)567)) *
36, (ftnlen)1, (ftnlen)36, (ftnlen)36);
}
/* Do not do this again. */
first = FALSE_;
}
/* Copy the contents of BLTNAM, BLTNOR, and BLTCOD to the output */
/* arguments, but only if there is sufficient room. */
if (*room < 563) {
setmsg_("Insufficient room to copy the stored body name-code mapping"
"s to the output arguments. Space required is #, but the cal"
"ler supplied #.", (ftnlen)134);
errint_("#", &c__563, (ftnlen)1);
errint_("#", room, (ftnlen)1);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZBODGET", (ftnlen)8);
return 0;
}
movec_(bltnam, &c__563, names, (ftnlen)36, names_len);
movec_(bltnor, &c__563, nornam, (ftnlen)36, nornam_len);
movei_(bltcod, &c__563, codes);
*nvals = 563;
chkout_("ZZBODGET", (ftnlen)8);
return 0;
/* $Procedure ZZBODLST ( Output permanent collection to some device. ) */
L_zzbodlst:
/* $ Abstract */
/* Output the complete list of built-in body/ID mappings to */
/* some output devide. Thw routine generates 2 lists: one */
/* sorted by ID number, one sorted by name. */
/* $ 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 */
/* BODY */
/* $ Declarations */
/* CHARACTER*(*) DEVICE */
/* CHARACTER*(*) REQST */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* DEVICE I Device name to receive the output. */
/* REQST I Data list name to output. */
/* $ Detailed_Input */
/* DEVICE identifies the device to receive the */
/* body/ID mapping list. WRLINE performs the */
/* output function and so DEVICE may have */
/* the values 'SCREEN' (to generate a screen dump), */
/* 'NULL' (do nothing), or a device name (a */
/* file, or any other name valid in a FORTRAN OPEN */
/* statement). */
/* REQST A case insensitive string indicating the data */
/* set to output. REQST may have the value 'ID', */
/* 'NAME', or 'BOTH'. 'ID' outputs the name/ID mapping */
/* ordered by ID number from least to highest value. */
/* 'NAME' outputs the name/ID mapping ordered by ASCII */
/* sort on the name string. 'BOTH' outputs both */
/* ordered lists. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The entry point outputs ordered lists of the name/ID mappings */
/* defined in ZZBODTRN. */
/* $ Examples */
/* 1. Write both sorted lists to screen. */
/* PROGRAM X */
/* CALL ZZBODLST( 'SCREEN', 'BOTH' ) */
/* END */
/* 2. Write an ID number sorted list to a file, "body.txt". */
/* PROGRAM X */
/* CALL ZZBODLST( 'body.txt', 'ID' ) */
/* END */
/* With SCREEN output of the form: */
/* Total number of name/ID mappings: 414 */
/* ID to name mappings. */
/* -550 | M96 */
/* -550 | MARS 96 */
/* -550 | MARS-96 */
/* -550 | MARS96 */
/* -254 | MER-2 */
/* -253 | MER-1 */
/* .. .. */
/* 50000020 | SHOEMAKER-LEVY 9-B */
/* 50000021 | SHOEMAKER-LEVY 9-A */
/* 50000022 | SHOEMAKER-LEVY 9-Q1 */
/* 50000023 | SHOEMAKER-LEVY 9-P2 */
/* Name to ID mappings. */
/* 1978P1 | 901 */
/* 1979J1 | 515 */
/* .. .. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* E.D. Wright (JPL) */
/* $ Version */
/* - SPICELIB Version 2.1.1, 27-FEB-2007 (EDW) */
/* Completed the ZZBODLST declarations section. */
/* - SPICELIB Version 2.1.0, 17-MAR-2003 (EDW) */
/* Added a call to ZZIDMAP to retrieve the default */
/* mapping list. "zzbodtrn.inc" no longer */
/* contains the default mapping list. */
/* - SPICELIB Version 2.0.0, 23-AUG-2002 (FST) */
/* This entry point was moved into ZZBODBLT and some */
/* variable names were changed to refer to variables */
/* in the umbrella. */
/* - SPICELIB Version 1.0.0, 26-NOV-2001 (EDW) */
/* -& */
if (return_()) {
return 0;
} else {
chkin_("ZZBODLST", (ftnlen)8);
}
/* Upper case the ZZRQST value. */
ucase_(reqst, zzrqst, reqst_len, (ftnlen)4);
intstr_(&c__563, zzint, (ftnlen)36);
/* Writing concatenation */
i__3[0] = 34, a__1[0] = "Total number of name/ID mappings: ";
i__3[1] = 36, a__1[1] = zzint;
s_cat(zzline, a__1, i__3, &c__2, (ftnlen)75);
wrline_(device, zzline, device_len, lastnb_(zzline, (ftnlen)75));
/* Retrieve the current set of name/ID mappings */
zzidmap_(bltcod, bltnam, (ftnlen)36);
/* Branch as defined by the value of ZZRQST. 'ID' or 'BOTH'. */
if (eqstr_(zzrqst, "ID", (ftnlen)4, (ftnlen)2) || eqstr_(zzrqst, "BOTH", (
ftnlen)4, (ftnlen)4)) {
orderi_(bltcod, &c__563, zzocod);
wrline_(device, " ", device_len, (ftnlen)1);
wrline_(device, "ID to name mappings.", device_len, (ftnlen)20);
for (i__ = 1; i__ <= 563; ++i__) {
intstr_(&bltcod[(i__2 = zzocod[(i__1 = i__ - 1) < 563 && 0 <=
i__1 ? i__1 : s_rnge("zzocod", i__1, "zzbodblt_", (ftnlen)
812)] - 1) < 563 && 0 <= i__2 ? i__2 : s_rnge("bltcod",
i__2, "zzbodblt_", (ftnlen)812)], zzint, (ftnlen)36);
/* Writing concatenation */
i__4[0] = 36, a__2[0] = zzint;
i__4[1] = 3, a__2[1] = " | ";
i__4[2] = 36, a__2[2] = bltnam + ((i__2 = zzocod[(i__1 = i__ - 1)
< 563 && 0 <= i__1 ? i__1 : s_rnge("zzocod", i__1, "zzbo"
"dblt_", (ftnlen)814)] - 1) < 563 && 0 <= i__2 ? i__2 :
s_rnge("bltnam", i__2, "zzbodblt_", (ftnlen)814)) * 36;
s_cat(zzline, a__2, i__4, &c__3, (ftnlen)75);
wrline_(device, zzline, device_len, lastnb_(zzline, (ftnlen)75));
}
}
/* ... 'NAME' or 'BOTH'. */
if (eqstr_(zzrqst, "NAME", (ftnlen)4, (ftnlen)4) || eqstr_(zzrqst, "BOTH",
(ftnlen)4, (ftnlen)4)) {
orderc_(bltnam, &c__563, zzonam, (ftnlen)36);
wrline_(device, " ", device_len, (ftnlen)1);
wrline_(device, "Name to ID mappings.", device_len, (ftnlen)20);
for (i__ = 1; i__ <= 563; ++i__) {
intstr_(&bltcod[(i__2 = zzonam[(i__1 = i__ - 1) < 563 && 0 <=
i__1 ? i__1 : s_rnge("zzonam", i__1, "zzbodblt_", (ftnlen)
834)] - 1) < 563 && 0 <= i__2 ? i__2 : s_rnge("bltcod",
i__2, "zzbodblt_", (ftnlen)834)], zzint, (ftnlen)36);
/* Writing concatenation */
i__4[0] = 36, a__2[0] = bltnam + ((i__2 = zzonam[(i__1 = i__ - 1)
< 563 && 0 <= i__1 ? i__1 : s_rnge("zzonam", i__1, "zzbo"
"dblt_", (ftnlen)836)] - 1) < 563 && 0 <= i__2 ? i__2 :
s_rnge("bltnam", i__2, "zzbodblt_", (ftnlen)836)) * 36;
i__4[1] = 3, a__2[1] = " | ";
i__4[2] = 36, a__2[2] = zzint;
s_cat(zzline, a__2, i__4, &c__3, (ftnlen)75);
wrline_(device, zzline, device_len, lastnb_(zzline, (ftnlen)75));
}
}
chkout_("ZZBODLST", (ftnlen)8);
return 0;
} /* zzbodblt_ */
/* $Procedure M2DIAG ( META/2 diagnostics formatting utility. ) */
/* Subroutine */ int m2diag_0_(int n__, char *filler, char *begmrk, char *
endmrk, char *string, integer *sb, integer *se, char *messge, ftnlen
filler_len, ftnlen begmrk_len, ftnlen endmrk_len, ftnlen string_len,
ftnlen messge_len)
{
/* Initialized data */
static char fill[80] = " "
" ";
static integer pad = 1;
static char bmark[16] = ".....< ";
static char emark[16] = ">..... ";
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer bpad, b, e;
extern /* Subroutine */ int zzinssub_(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
static integer place;
extern integer lastnb_(char *, ftnlen);
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen);
/* $ Abstract */
/* This routine contains the two entry points M2SERR and M2MARK that */
/* are used by META/2 template matching routines. It serves as */
/* a diagnostic formatting utility. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* UTILITY */
/* $ Declarations */
/* See the entry point headers for description of each of the */
/* input/output arguements. */
/* $ Detailed_Input */
/* See individual entry points. */
/* $ Detailed_Output */
/* See individual entry points. */
/* $ Exceptions */
/* See individual entry points. */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Particulars */
/* This routine is a dummy that serves as an home for the entry */
/* points M2SERR and M2MARK that are utility formatting routines */
/* used by the template matching routines of META/2. */
/* $ Examples */
/* To set the markers and filler used to offset the marked portion */
/* of a command that fails syntax checking, call the routine */
/* M2SERR */
/* To append a marked command to a diagnostic message call M2MARK. */
/* $ Restrictions */
/* See the entry points for appropriate restrictions. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - META/2 Configured Version 2.0.0, 9-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 9, 1994 */
/* - META/2 Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of META/2 */
/* software as of May 3, 1994 */
/* Beta Version 1.0.0, 1-JUN-1988 (WLT) (IMU) */
/* -& */
/* Entry points */
/* M2MARK */
/* M2SERR */
/* SPICELIB functions */
/* Local variables */
switch(n__) {
case 1: goto L_m2serr;
case 2: goto L_m2mark;
}
return 0;
/* $Procedure M2SERR ( Set the META/2 error markers ) */
L_m2serr:
/* $ Abstract */
/* Set the error markers and padding between the end of the error */
/* message and the beginning of the marked copy of the input string */
/* in diagnostic messages. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* The META/2 book. */
/* $ Keywords */
/* UTILITY */
/* $ Declarations */
/* CHARACTER*(*) FILLER */
/* CHARACTER*(*) BEGMRK */
/* CHARACTER*(*) ENDMRK */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* FILLER I string to leave between message and marked string */
/* BEGMRK I String to put at beginning of marked part of string */
/* ENDMRK I String to put at end of marked part of string */
/* $ Detailed_Input */
/* FILLER substring to leave between message and marked string */
/* BEGMRK String to put at beginning of marked part of string */
/* ENDMRK String to put at end of marked part of string */
/* $ Detailed_Output */
/* None. */
/* $ Error_Handling */
/* No errors are detected by this entry point. */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Particulars */
/* This entry point is used to set the space padding between the */
/* diagnostic message produced by a META/2 routine and to */
/* select what strings that will be used to mark the location */
/* of a problem that occured in in the input string when */
/* attempting to match a template. */
/* Since diagnostic messages can be quite long, it is important */
/* to be able to set a space between the end of the diagnostic */
/* and the start of the marked string. If the messages are to */
/* be output through use of some kind of string breaking routine */
/* such as the NAIF routine CUTSTR. By selecting the padding */
/* sufficiently large you can insure that the message will break */
/* before printing the marked string. */
/* $ Examples */
/* When printing error messages it is handy to have the marked */
/* portion of the string appear highlighted. For a machine that */
/* interprets VT100 escape sequences the following markers */
/* might prove very effective. */
/* BEGMRK = '<ESC>[7m' ! Turn on reverse video. */
/* ENDMRK = '<ESC>[0m' ! Turn off reverse video. */
/* SPACE = ' ' */
/* CALL M2SERR ( SPACE, BEGMRK, ENDMRK ) */
/* When an diagnostic message comes back, the following will */
/* code will ensure that the message is broken nicely and that */
/* the marked string begins on a new line. */
/* BEG = 1 */
/* MORE = .TRUE. */
/* DO WHILE ( MORE ) */
/* CALL CUTSTR ( CAUSE, 80, ' ,', BEG, END, MORE ) */
/* WRITE (6,*) CAUSE(BEG:END) */
/* BEG = END + 1 */
/* END DO */
/* Non-printing beginning and ending markers can also be useful */
/* in the event that you want to do your own processing of the */
/* diagnostic message for display. */
/* $ Restrictions */
/* The marking strings will be truncated to the first 16 characters. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - META/2 Configured Version 2.0.0, 9-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 9, 1994 */
/* - META/2 Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of META/2 */
/* software as of May 3, 1994 */
/* Version B1.0.0, 7-APR-1988 (WLT) (IMU) */
/* -& */
/* Computing MIN */
i__1 = 80, i__2 = i_len(filler, filler_len);
pad = min(i__1,i__2);
s_copy(bmark, begmrk, (ftnlen)16, begmrk_len);
s_copy(emark, endmrk, (ftnlen)16, endmrk_len);
s_copy(fill, filler, (ftnlen)80, filler_len);
return 0;
/* $Procedure M2MARK (META/2 Error Marking Utility) */
L_m2mark:
/* $ Abstract */
/* This is a utility routine used for constructing diagnostic */
/* message for META2. It is not intended for genereal consumption. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* UTILITY */
/* $ Declarations */
/* CHARACTER*(*) STRING */
/* INTEGER SB */
/* INTEGER SE */
/* CHARACTER*(*) MESSGE */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* STRING I String to concatenate to end of a partial message */
/* SB I Position of first string character to mark. */
/* SE I Position of last string character to mark. */
/* MESSGE I/O String to append marked string to and return. */
/* $ Detailed_Input */
/* STRING is a string that contains some sequence of characters */
/* that should be marked and then appended to a partially */
/* constructed message string. */
/* SB is the index of the first character in STRING that */
/* should be marked for output with some character string. */
/* SE is the index of the last character in STRING that */
/* should be marked for output with some character string. */
/* MESSGE Is a partially constructed string to which the marked */
/* string should be appended. */
/* $ Detailed_Output */
/* MESSGE is the original string concatenated with the marked */
/* string. */
/* $ Exceptions. */
/* If MESSGE is not long enough to contain everything that should */
/* go into it it will be truncated. */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Particulars */
/* This is a utility routine for use in constructing messages */
/* of the form: */
/* "The input string contained an unrecognized word SPIM. || */
/* >>SPIM<< THE WHEEL." */
/* The inputs to the routine are */
/* The first part of the message */
/* The string that was recognized to have some problem */
/* The index of the first character of the problem. */
/* The index of the last character of the problem. */
/* The actual effect of this routine is to put the string */
/* MESSGE(1: LASTNB(MESSGE) + 1 ) // STRING(1 :SB-1 ) */
/* // BMARK (1 :LASTNB(BMARK)) */
/* // STRING(SB :SE ) */
/* // EMARK (1 :LASTNB(EMARK)) */
/* // STRING(SB+1: ) */
/* Into the string MESSGE. */
/* In fact this is what you would probably do if standard Fortran */
/* allowed you to perform these operations with passed length */
/* character strings. Since you cant't this routine does it for */
/* you cleaning up the appearance of your code and handling all of */
/* the pathologies for you. */
/* $ Examples */
/* Inputs */
/* MESSGE = 'I believe the word "FILW" should have been */
/* "FILE" in the input string. || " */
/* STRING = 'SEND EPHEMERIS TO FILW OUTPUT.DAT' */
/* 123456789012345678901234567890123 */
/* SB = 19 */
/* SE = 22 */
/* BMARK = '>>>' */
/* EMARK = '<<<' */
/* Output */
/* MESSGE = 'I believe the word "FILW" should have been */
/* "FILE" in the input string. || SEND EPHEMERIS */
/* TO >>>FILW<<< OUTPUT.DAT' */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* $ Version */
/* - META/2 Configured Version 2.0.0, 9-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 9, 1994 */
/* - META/2 Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of META/2 */
/* software as of May 3, 1994 */
/* Version B1.0.0, 17-APR-1988 (WLT) */
/* -& */
/* The end of MESSGE looks like */
/* . . . xxx xxxxxx */
/* ^ */
/* | */
/* PLACE = LASTNB(CAUSE)+PAD */
/* After suffixing STRING to CAUSE with one space */
/* it will look like: */
/* . . . xx x xxxxxx string beginning */
/* ^ */
/* | */
/* PLACE + 1 */
/* and the beginning and end of the marked string */
/* will be at PLACE + SB and PLACE+SE respectively. */
b = lastnb_(bmark, (ftnlen)16);
e = lastnb_(emark, (ftnlen)16);
bpad = lastnb_(messge, messge_len) + 1;
if (pad < 1) {
place = lastnb_(messge, messge_len);
} else {
place = lastnb_(messge, messge_len) + pad;
suffix_(string, &pad, messge, string_len, messge_len);
s_copy(messge + (bpad - 1), fill, place - (bpad - 1), pad);
}
if (e > 0) {
i__1 = place + *se + 1;
zzinssub_(messge, emark, &i__1, messge, messge_len, e, messge_len);
}
if (b > 0) {
i__1 = place + *sb;
zzinssub_(messge, bmark, &i__1, messge, messge_len, b, messge_len);
}
return 0;
} /* m2diag_ */
/* $Procedure REPLWD ( Replace a word ) */
/* Subroutine */ int replwd_(char *instr, integer *nth, char *new__, char *
outstr, ftnlen instr_len, ftnlen new_len, ftnlen outstr_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen), i_len(char *, ftnlen);
/* Local variables */
integer f, i__, j, k, l, n, begin, shift;
extern /* Subroutine */ int nthwd_(char *, integer *, char *, integer *,
ftnlen, ftnlen);
char short__[2];
extern /* Subroutine */ int fndnwd_(char *, integer *, integer *, integer
*, ftnlen);
extern integer lastnb_(char *, ftnlen), frstnb_(char *, ftnlen);
/* $ Abstract */
/* Replace the Nth word in a string with a new word. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* ASSIGNMENT, WORD */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* INSTR I Input string. */
/* NTH I Number of the word to be replaced. */
/* NEW I Replacement word. */
/* OUTSTR O Output string. */
/* $ Detailed_Input */
/* INSTR is the input character string, possibly containing */
/* one or more words, where a word is any string of */
/* consecutive non-blank characters delimited by a */
/* blank or by either end of the string. */
/* NTH is the number of the word to be replaced. Words */
/* are numbered from one. If NTH is less than one, */
/* or greater than the number of words in the string, */
/* no replacement is made. */
/* NEW is the word which is to replace the specified word */
/* in the input string. Leading and trailing blanks */
/* are ignored. If the replacement word is blank, */
/* the original word is simply removed. */
/* $ Detailed_Output */
/* OUTSTR is the output string. This is the input string */
/* with the N'th word replaced by the word NEW. */
/* Any blanks originally surrounding the replaced */
/* word are retained. */
/* OUTSTR may overwrite INSTR. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* The effect of this routine is to remove the old word with */
/* REMSUB, and insert the replacement word with INSSUB. */
/* $ Exceptions */
/* Error free. */
/* 1) If NEW is blank, then the Nth word is replaced by a single */
/* space. */
/* $ Files */
/* None. */
/* $ Examples */
/* Let */
/* INSTR = ' Woodsy is the Anti-Pollution Owl.' */
/* and */
/* NEW = ' an ' */
/* then the following values of NTH yield the following strings. */
/* NTH OUTSTR */
/* --- ------------------------------------------ */
/* -1 ' Woodsy is the Anti-Pollution Owl.' */
/* 0 ' Woodsy is the Anti-Pollution Owl.' */
/* 1 ' an is the Anti-Pollution Owl.' */
/* 3 ' Woodsy is an Anti-Pollution Owl.' */
/* 4 ' Woodsy is the an Owl.' */
/* 5 ' Woodsy is the Anti-Pollution an' */
/* 6 ' Woodsy is the Anti-Pollution Owl.' */
/* Note that in the first, second, and last cases, the string */
/* was not changed. Note also that in the next to last case, */
/* the final period was treated as part of the fifth word in the */
/* string. */
/* If NEW is ' ', and NTH is 3, then */
/* OUTSTR = ' Woodsy is Anti-Pollution Owl.' */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) */
/* -& */
/* $ Index_Entries */
/* replace a word */
/* -& */
/* $ Revisions */
/* - Beta Version 1.3.0, 7-MAR-1989 (WLT) */
/* To satisfy complaints about me not having enough to do, */
/* the case of a blank NEW word has been handled. */
/* - Beta Version 1.2.0, 28-FEB-1989 (WLT) */
/* Routine completely rewritten to satify whims of the */
/* NAIF group. */
/* - Beta Version 1.1.1, 17-FEB-1989 (HAN) (NJB) */
/* Contents of the Exceptions section was changed */
/* to "error free" to reflect the decision that the */
/* module will never participate in error handling. */
/* Declaration of the unused variable OUTLEN deleted. */
/* -& */
/* SPICELIB functions */
/* Local Variables */
/* First just shift the input string into the output string, */
/* then do everything in place (for the case when the new */
/* word is longer than the old one. When its shorter we'll */
/* need to change this scheme slightly.) */
s_copy(outstr, instr, outstr_len, instr_len);
/* Where does the word to be replaced begin? If there is none, */
/* just return the original string. */
nthwd_(outstr, nth, short__, &begin, outstr_len, (ftnlen)2);
if (begin == 0) {
return 0;
}
/* Otherwise, find out where it ends as well. */
fndnwd_(instr, &begin, &i__, &j, instr_len);
/* Now insert only the non-blank part of the replacement string. */
/* If the replacement string is blank, don't insert anything. */
if (s_cmp(new__, " ", new_len, (ftnlen)1) != 0) {
f = frstnb_(new__, new_len);
l = lastnb_(new__, new_len);
/* Except in the lucky case that the word to insert is the */
/* same length as the word it's replacing, we will have */
/* to shift right or left by some amount. Compute the */
/* appropriate amount to shift right. */
shift = l - f - (j - i__);
} else {
f = 1;
l = 1;
shift = i__ - j;
}
if (shift > 0) {
/* To shift right in place start at the right most character */
/* of the string and copy the character SHIFT spaces to the */
/* left. */
k = i_len(outstr, outstr_len);
n = k - shift;
while(n > j) {
*(unsigned char *)&outstr[k - 1] = *(unsigned char *)&outstr[n -
1];
--k;
--n;
}
/* Once the appropriate characters have been shifted out */
/* of the way, replace the opened space with the new */
/* word. */
while(f <= l && i__ <= i_len(outstr, outstr_len)) {
*(unsigned char *)&outstr[i__ - 1] = *(unsigned char *)&new__[f -
1];
++f;
++i__;
}
} else {
/* We have a left shift. Fill in the first part of the word */
/* we are replacing with the new one. */
while(f <= l && i__ <= i_len(outstr, outstr_len)) {
*(unsigned char *)&outstr[i__ - 1] = *(unsigned char *)&new__[f -
1];
++f;
++i__;
}
/* Now starting just past the end of the word we are replacing */
/* shift the remainder of string left one character at a time. */
if (shift < 0) {
++j;
while(i__ <= i_len(outstr, outstr_len) && j <= i_len(instr,
instr_len)) {
*(unsigned char *)&outstr[i__ - 1] = *(unsigned char *)&instr[
j - 1];
++i__;
++j;
}
/* Finally pad the string with blanks. */
if (i__ <= i_len(outstr, outstr_len)) {
s_copy(outstr + (i__ - 1), " ", outstr_len - (i__ - 1), (
ftnlen)1);
}
}
}
return 0;
} /* replwd_ */
/* $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 MATCHW ( Match string against wildcard template ) */
logical matchw_(char *string, char *templ, char *wstr, char *wchr, ftnlen
string_len, ftnlen templ_len, ftnlen wstr_len, ftnlen wchr_len)
{
/* System generated locals */
integer i__1;
logical ret_val;
/* Local variables */
integer left, slen, tlen, scur, tcur, i__, j;
extern logical samch_(char *, integer *, char *, integer *, ftnlen,
ftnlen);
integer right, slast, tlast;
extern integer lastnb_(char *, ftnlen), frstnb_(char *, ftnlen);
logical nosubm;
integer sfirst, tfirst;
/* $ Abstract */
/* Determine whether a string is matched by a template containing */
/* wild cards. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* CHARACTER */
/* COMPARE */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* STRING I String to be tested. */
/* TEMPL I Template (with wild cards) to test against STRING. */
/* WSTR I Wild string token. */
/* WCHR I Wild character token. */
/* The function returns .TRUE. if STRING matches TEMPL and otherwise */
/* returns .FALSE. */
/* $ Detailed_Input */
/* STRING is the input character string to be tested for */
/* a match against the input template. Leading and */
/* trailing blanks are ignored. */
/* TEMPL is the input template to be tested for a match */
/* against the input string. TEMPL may contain wild */
/* cards. Leading and trailing blanks are ignored. */
/* WSTR is the wild string token used in the input template. */
/* The wild string token may represent from zero to */
/* any number of characters. */
/* WCHR is the wild character token used in the input */
/* template. The wild character token represents */
/* exactly one character. */
/* $ Detailed_Output */
/* The function is true when the input string matches the input */
/* template, and false otherwise. The string and template match */
/* whenever the template can expand (through replacement of its */
/* wild cards) to become the input string. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* MATCHW ignores leading and trailing blanks in both the string */
/* and the template. All of the following are equivalent (they */
/* all return TRUE). */
/* MATCHW ( 'ALCATRAZ', 'A*Z', '*', '%' ) */
/* MATCHW ( ' ALCATRAZ ', 'A*Z', '*', '%' ) */
/* MATCHW ( 'ALCATRAZ', ' A*Z ', '*', '%' ) */
/* MATCHW ( ' ALCATRAZ ', ' A*Z ', '*', '%' ) */
/* MATCHW is case-sensitive: uppercase characters do not match */
/* lowercase characters, and vice versa. Wild characters match */
/* characters of both cases. */
/* $ Exceptions */
/* Error free. */
/* $ Examples */
/* Let */
/* STRING = ' ABCDEFGHIJKLMNOPQRSTUVWXYZ ' */
/* WSTR = '*' */
/* WCHR = '%' */
/* Then */
/* if TEMPL is '*A*' MATCHW is T */
/* 'A%D*' F */
/* 'A%C*' T */
/* '%A*' F */
/* '%%CD*Z' T */
/* '%%CD' F */
/* 'A*MN*Y*Z' T */
/* 'A*MN*Y*%Z' F */
/* '*BCD*Z*' T */
/* '*bcd*z*' F */
/* ' *BCD*Z* ' T */
/* $ Restrictions */
/* None. */
/* $ Files */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.3.1, 11-NOV-2005 (NJB) */
/* Corrected example calls in header; made other minor */
/* edits to header. */
/* - SPICELIB Version 1.3.0, 08-JUN-1999 (WLT) */
/* Fixed comments in detailed output and example sections. */
/* - SPICELIB Version 1.2.0, 15-MAY-1995 (WLT) */
/* Direct substring comparisons were replaced with the logical */
/* function SAMCH in several cases so as to avoid out of range */
/* errors when examining substrings. */
/* - SPICELIB Version 1.1.0, 17-MAY-1994 (HAN) */
/* Set the default function value to either 0, 0.0D0, .FALSE., */
/* or blank depending on the type of the function. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* match string against wildcard template */
/* test whether a string matches a wildcard template */
/* -& */
/* $ Revisions */
/* - Beta Version 1.1.0, 06-OCT-1988 (WLT) */
/* The old algorithm just did not work. Strings with wild */
/* characters at the beginning or end of the string were not */
/* matched correctly. For example, A% matched APPROX, if the */
/* wild character token was % and the wild string token was */
/* *. Needless to say, a new algorithm was developed. */
/* -& */
/* SPICELIB functions */
/* Local Variables */
/* Set the default function value to be FALSE. */
ret_val = FALSE_;
/* First let's get everybody's measurments. */
sfirst = frstnb_(string, string_len);
slast = lastnb_(string, string_len);
tfirst = frstnb_(templ, templ_len);
tlast = lastnb_(templ, templ_len);
tlen = tlast - tfirst + 1;
slen = slast - sfirst + 1;
scur = max(1,sfirst);
tcur = tfirst;
/* A blank template matches a blank string, and nothing else. */
if (tlast == 0 && slast == 0) {
ret_val = TRUE_;
return ret_val;
} else if (tlast == 0) {
ret_val = FALSE_;
return ret_val;
}
/* The beginning of the string and template must be identical */
/* up to the first occurrence of a wild string. */
while(tcur <= tlast && scur <= slast && ! samch_(templ, &tcur, wstr, &
c__1, templ_len, (ftnlen)1)) {
if (*(unsigned char *)&templ[tcur - 1] != *(unsigned char *)&string[
scur - 1] && *(unsigned char *)&templ[tcur - 1] != *(unsigned
char *)wchr) {
ret_val = FALSE_;
return ret_val;
} else {
++tcur;
++scur;
}
}
/* There are a three ways we could have finished the loop above */
/* without hitting a wild string. */
/* Case 1. Both the string and template ran out of characters at */
/* the same time without running into a wild string in the template. */
if (tcur > tlast && scur > slast) {
ret_val = TRUE_;
return ret_val;
}
/* Case 2. The template ran out of characters while there were still */
/* characters remaining in the in the string. No match. */
if (tcur > tlast && scur <= slast) {
ret_val = FALSE_;
return ret_val;
}
/* Case 3. The string ran out of characters while non-wild characters */
/* remain in the template. */
/* We have to check to see if any non-wild-string characters */
/* remain. If so, we DO NOT have a match. On the other hand if */
/* only wild string characters remain we DO have a match. */
if (tcur <= tlast && scur > slast) {
ret_val = TRUE_;
i__1 = tlast;
for (i__ = tcur; i__ <= i__1; ++i__) {
ret_val = ret_val && *(unsigned char *)&templ[i__ - 1] == *(
unsigned char *)wstr;
}
return ret_val;
}
/* OK. There is only one way that you can get to this point. */
/* It must be the case that characters remain in both the template */
/* (TCUR .LE. TLAST) and the string (SCUR .LE. SLAST). Moreover, */
/* to get out of the first loop you had to hit a wild string */
/* character. Find the first non-wild-string character in the */
/* template. (If there isn't one, we have a match.) */
while(tcur <= tlast && samch_(templ, &tcur, wstr, &c__1, templ_len, (
ftnlen)1)) {
++tcur;
}
if (tcur > tlast) {
ret_val = TRUE_;
return ret_val;
}
/* Still here? Ok. We have a non-wild-string character at TCUR. Call */
/* this position left and look for the right end of the maximum */
/* length substring of TEMPL (starting at left) that does not have */
/* a wild string character. */
left = tcur;
while(tcur <= tlast && ! samch_(templ, &tcur, wstr, &c__1, templ_len, (
ftnlen)1)) {
++tcur;
}
right = tcur - 1;
while(left <= tlast) {
/* First see if there is enough room left in the string to */
/* match TEMPL(LEFT:RIGHT) */
if (slast - scur < right - left) {
ret_val = FALSE_;
return ret_val;
}
/* The substring TEMPL(LEFT:RIGHT) might be the end of the */
/* string. In such a case the ends of STRING must match */
/* exactly with the end of TEMPL. */
if (right == tlast) {
i__ = slast;
j = tlast;
while(j >= left) {
if (samch_(templ, &j, wchr, &c__1, templ_len, (ftnlen)1) ||
samch_(templ, &j, string, &i__, templ_len, string_len)
) {
--j;
--i__;
} else {
ret_val = FALSE_;
return ret_val;
}
}
/* If we made it through the loop, we've got a match. */
ret_val = TRUE_;
return ret_val;
} else {
/* In this case TEMPL(LEFT:RIGHT) is in between wild string */
/* characters. Try to find a substring at or to the right */
/* of SCUR in STRING that matches TEMPL(LEFT:RIGHT) */
nosubm = TRUE_;
while(nosubm) {
i__ = scur;
j = left;
while(j <= right && (samch_(string, &i__, templ, &j,
string_len, templ_len) || samch_(wchr, &c__1, templ, &
j, (ftnlen)1, templ_len))) {
++i__;
++j;
}
/* If J made it past RIGHT, we have a substring match */
if (j > right) {
scur = i__;
nosubm = FALSE_;
/* Otherwise, try the substring starting 1 to the right */
/* of where our last try began. */
} else {
++scur;
/* Make sure there's room to even attempt a match. */
if (slast - scur < right - left) {
ret_val = FALSE_;
return ret_val;
}
}
}
}
/* If you have reached this point there must be something left */
/* in the template and that something must begin with a wild */
/* string character. Hunt for the next substring that doesn't */
/* contain a wild string character. */
while(tcur <= tlast && samch_(templ, &tcur, wstr, &c__1, templ_len, (
ftnlen)1)) {
++tcur;
}
if (tcur > tlast) {
/* All that was left was wild string characters. We've */
/* got a match. */
ret_val = TRUE_;
return ret_val;
}
/* Still here? Ok. We have a non-wild-string character at TCUR. */
/* Call this position left and look for the right end of the */
/* maximum length substring of TEMPL (starting at left) that */
/* does not have a wild string character. */
left = tcur;
while(tcur <= tlast && ! samch_(templ, &tcur, wstr, &c__1, templ_len,
(ftnlen)1)) {
++tcur;
}
right = tcur - 1;
}
return ret_val;
} /* matchw_ */
/* $Procedure ERRDP ( Insert D.P. Number into Error Message Text ) */
/* Subroutine */ int errdp_(char *marker, doublereal *dpnum, ftnlen
marker_len)
{
/* System generated locals */
address a__1[3], a__2[2];
integer i__1, i__2[3], i__3[2];
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen),
s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int dpstr_(doublereal *, integer *, char *,
ftnlen), ljust_(char *, char *, ftnlen, ftnlen);
extern logical allowd_(void);
extern integer lastnb_(char *, ftnlen);
char lngmsg[1840];
extern /* Subroutine */ int getlms_(char *, ftnlen);
extern integer frstnb_(char *, ftnlen);
char dpstrg[21], tmpmsg[1840];
extern /* Subroutine */ int putlms_(char *, ftnlen);
integer strpos;
/* $ Abstract */
/* Substitute a double precision number for the first occurrence of */
/* a marker found in the current long error message. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* ERROR */
/* $ Keywords */
/* ERROR, CONVERSION */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include File: SPICELIB Error Handling Parameters */
/* errhnd.inc Version 2 18-JUN-1997 (WLT) */
/* The size of the long error message was */
/* reduced from 25*80 to 23*80 so that it */
/* will be accepted by the Microsoft Power Station */
/* FORTRAN compiler which has an upper bound */
/* of 1900 for the length of a character string. */
/* errhnd.inc Version 1 29-JUL-1997 (NJB) */
/* Maximum length of the long error message: */
/* Maximum length of the short error message: */
/* End Include File: SPICELIB Error Handling Parameters */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* MARKER I A substring of the error message to be replaced. */
/* DPNUM I The d.p. number to substitute for MARKER. */
/* $ Detailed_Input */
/* MARKER is a character string which marks a position in */
/* the long error message where a character string */
/* representing an double precision number is to be */
/* substituted. Leading and trailing blanks in MARKER */
/* are not significant. */
/* Case IS significant; 'XX' is considered to be */
/* a different marker from 'xx'. */
/* DPNUM is an double precision number whose character */
/* representation will be substituted for the first */
/* occurrence of MARKER in the long error message. */
/* This occurrence of the substring indicated by MARKER */
/* will be removed, and replaced by a character string, */
/* with no leading or trailing blanks, representing */
/* DPNUM. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* LMSGLN is the maximum length of the long error message. See */
/* the include file errhnd.inc for the value of LMSGLN. */
/* $ Exceptions */
/* This routine does not detect any errors. */
/* However, this routine is part of the SPICELIB error */
/* handling mechanism. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The effect of this routine is to update the current long */
/* error message. If no marker is found, (e.g., in the */
/* case that the long error message is blank), the routine */
/* has no effect. If multiple instances of the marker */
/* designated by MARKER are found, only the first one is */
/* replaced. */
/* If the character string resulting from the substitution */
/* exceeds the maximum length of the long error message, the */
/* characters on the right are lost. No error is signalled. */
/* This routine has no effect if changes to the long message */
/* are not allowed. */
/* $ Examples */
/* 1. In this example, the marker is: # */
/* The current long error message is: */
/* 'Invalid operation value. The value was #'. */
/* After the call, */
/* CALL ERRDP ( '#', 5.D0 ) */
/* The long error message becomes: */
/* 'Invalid operation value. The value was 5.0'. */
/* 2. In this example, the marker is: XX */
/* The current long error message is: */
/* 'Left endpoint exceeded right endpoint. The left'// */
/* 'endpoint was: XX. The right endpoint was: XX.' */
/* After the call, */
/* CALL ERRDP ( 'XX', 5.D0 ) */
/* The long error message becomes: */
/* 'Left endpoint exceeded right endpoint. The left'// */
/* 'endpoint was: 5.0. The right endpoint was: XX.' */
/* $ Restrictions */
/* The caller must ensure that the message length, after sub- */
/* stitution is performed, doesn't exceed LMSGLN characters. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 2.2.1, 08-JAN-2014 (BVS) */
/* Fixed header example (5.0 -> 5.D0). */
/* - SPICELIB Version 2.2.0, 29-JUL-2005 (NJB) */
/* Bug fix: increased length of internal string DPSTRG to */
/* handle 3-digit exponents. */
/* - SPICELIB Version 2.1.0, 29-JUL-1997 (NJB) */
/* Bug fix: extraneous leading blank has been removed from */
/* numeric string substituted for marker. */
/* Maximum length of the long error message is now represented */
/* by the parameter LMSGLN. Miscellaneous format changes to the */
/* header, code and in-line comments were made. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (NJB) */
/* -& */
/* $ Index_Entries */
/* insert d.p. number into error message text */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.1.0, 29-JUL-1997 (NJB) */
/* Bug fix: extraneous leading blank has been removed from */
/* numeric string substituted for marker. */
/* Maximum length of the long error message is now represented */
/* by the parameter LMSGLN. Miscellaneous format changes to the */
/* header, code and in-line comments were made. */
/* -& */
/* SPICELIB functions */
/* Local Variables: */
/* Length of DPSTRG is number of significant digits plus 7 */
/* (see DPSTR header) */
/* Executable Code: */
/* Changes to the long error message have to be allowed, or we */
/* do nothing. */
if (! allowd_()) {
return 0;
}
/* MARKER has to have some non-blank characters, or we do nothing. */
if (lastnb_(marker, marker_len) == 0) {
return 0;
}
/* Get a copy of the current long error message. Convert DPNUM */
/* to a character string. Ask for 14 significant digits in */
/* string. */
getlms_(lngmsg, (ftnlen)1840);
dpstr_(dpnum, &c__14, dpstrg, (ftnlen)21);
ljust_(dpstrg, dpstrg, (ftnlen)21, (ftnlen)21);
/* Locate the leftmost occurrence of MARKER, if there is one */
/* (ignoring leading and trailing blanks): */
i__1 = frstnb_(marker, marker_len) - 1;
strpos = i_indx(lngmsg, marker + i__1, (ftnlen)1840, lastnb_(marker,
marker_len) - i__1);
if (strpos == 0) {
return 0;
} else {
/* We put together TMPMSG, a copy of LNGMSG with MARKER */
/* replaced by the character representation of DPNUM: */
if (strpos > 1) {
if (strpos + lastnb_(marker, marker_len) - frstnb_(marker,
marker_len) < lastnb_(lngmsg, (ftnlen)1840)) {
/* There's more of the long message after the marker... */
i__1 = strpos + lastnb_(marker, marker_len) - frstnb_(marker,
marker_len);
/* Writing concatenation */
i__2[0] = strpos - 1, a__1[0] = lngmsg;
i__2[1] = lastnb_(dpstrg, (ftnlen)21), a__1[1] = dpstrg;
i__2[2] = 1840 - i__1, a__1[2] = lngmsg + i__1;
s_cat(tmpmsg, a__1, i__2, &c__3, (ftnlen)1840);
} else {
/* Writing concatenation */
i__3[0] = strpos - 1, a__2[0] = lngmsg;
i__3[1] = lastnb_(dpstrg, (ftnlen)21), a__2[1] = dpstrg;
s_cat(tmpmsg, a__2, i__3, &c__2, (ftnlen)1840);
}
} else {
/* We're starting with the d.p. number, so we know it fits... */
if (lastnb_(marker, marker_len) - frstnb_(marker, marker_len) <
lastnb_(lngmsg, (ftnlen)1840)) {
/* There's more of the long message after the marker... */
i__1 = strpos + lastnb_(marker, marker_len) - frstnb_(marker,
marker_len);
/* Writing concatenation */
i__3[0] = lastnb_(dpstrg, (ftnlen)21), a__2[0] = dpstrg;
i__3[1] = 1840 - i__1, a__2[1] = lngmsg + i__1;
s_cat(tmpmsg, a__2, i__3, &c__2, (ftnlen)1840);
} else {
/* The marker's the whole string: */
s_copy(tmpmsg, dpstrg, (ftnlen)1840, (ftnlen)21);
}
}
/* Update the long message: */
putlms_(tmpmsg, (ftnlen)1840);
}
return 0;
} /* errdp_ */
/* Subroutine */ int pwritf_(real *x, real *y, char *ch, integer *nch,
integer *isiz, integer *ior, integer *icent, ftnlen ch_len)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double cos(doublereal), sin(doublereal);
/* Local variables */
static real xold, yold, size, xorg, yorg;
static integer lstr[69999], nstr;
static real xstr[69999], ystr[69999];
static integer i__;
static char chloc[6666];
static integer nchar;
extern /* Subroutine */ int color_(integer *);
static integer isize;
static real ct;
static integer nchloc;
static real st, xr, yr, xx, yy;
extern integer lastnb_(char *, ftnlen);
extern /* Subroutine */ int zzline_(real *, real *, real *, real *),
zzconv_(char *, integer *, char *, integer *, ftnlen, ftnlen),
zzphys_(real *, real *), zzstro_(char *, integer *, integer *,
real *, real *, integer *, ftnlen);
static real orr;
/* .......................................................................
*/
/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
*/
/* Calculate character width in terms of 1/1000 of the x-width. */
/* Internal Data for PLOTPAK */
isize = *isiz;
if (isize <= 0) {
isize = 8;
} else if (isize == 1) {
isize = 12;
} else if (isize == 2) {
isize = 16;
} else if (isize == 3) {
isize = 24;
}
size = isize * .001f * (zzzplt_1.xpgmax - zzzplt_1.xpgmin);
/* Rotation/scaling factors for digitization */
orr = *ior * .017453292f;
ct = size * cos(orr);
st = size * sin(orr);
/* Base location, in internal coordinates */
xx = *x;
yy = *y;
if (*nch >= 0) {
zzphys_(&xx, &yy);
}
/* Get no. of characters in string. Special option 999 must be checked.
*/
nchar = abs(*nch);
if (nchar == 999) {
i__1 = nchar;
for (i__ = 1; i__ <= i__1; ++i__) {
if (*(unsigned char *)&ch[i__ - 1] == '\0') {
goto L20;
}
/* L10: */
}
L20:
nchar = i__ - 1;
} else if (nchar == 0) {
nchar = lastnb_(ch, ch_len);
}
/* Digitize string into line segments */
zzconv_(ch, &nchar, chloc, &nchloc, ch_len, 6666L);
zzstro_(chloc, &nchloc, &nstr, xstr, ystr, lstr, 6666L);
if (nstr <= 0) {
return 0;
}
/* Find min, max of x and y */
zzzplt_1.xbot = xstr[0];
zzzplt_1.ybot = ystr[0];
zzzplt_1.xtop = zzzplt_1.xbot;
zzzplt_1.ytop = zzzplt_1.ybot;
i__1 = nstr;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing MIN */
r__1 = zzzplt_1.xbot, r__2 = xstr[i__ - 1];
zzzplt_1.xbot = dmin(r__1,r__2);
/* Computing MAX */
r__1 = zzzplt_1.xtop, r__2 = xstr[i__ - 1];
zzzplt_1.xtop = dmax(r__1,r__2);
/* Computing MIN */
r__1 = zzzplt_1.ybot, r__2 = ystr[i__ - 1];
zzzplt_1.ybot = dmin(r__1,r__2);
/* Computing MAX */
r__1 = zzzplt_1.ytop, r__2 = ystr[i__ - 1];
zzzplt_1.ytop = dmax(r__1,r__2);
/* L100: */
}
/* Now compute origin of string, based on centering option; */
/* the origin of the string goes at (XX,YY) */
if (*icent == -1) {
xorg = zzzplt_1.xbot;
yorg = (zzzplt_1.ybot + zzzplt_1.ytop) * .5f;
} else if (*icent == 0) {
xorg = (zzzplt_1.xbot + zzzplt_1.xtop) * .5f;
yorg = (zzzplt_1.ybot + zzzplt_1.ytop) * .5f;
} else if (*icent == 1) {
xorg = zzzplt_1.xtop;
yorg = (zzzplt_1.ybot + zzzplt_1.ytop) * .5f;
} else {
xorg = zzzplt_1.xbot;
yorg = zzzplt_1.ybot;
}
/* Now draw the strokes */
i__1 = nstr;
for (i__ = 1; i__ <= i__1; ++i__) {
if (lstr[i__ - 1] <= 1) {
xr = xx + ct * (xstr[i__ - 1] - xorg) - st * (ystr[i__ - 1] -
yorg);
yr = yy + st * (xstr[i__ - 1] - xorg) + ct * (ystr[i__ - 1] -
yorg);
if (lstr[i__ - 1] == 1) {
zzline_(&xold, &yold, &xr, &yr);
}
xold = xr;
yold = yr;
} else if (lstr[i__ - 1] > 100 && lstr[i__ - 1] <= 107) {
i__2 = lstr[i__ - 1] - 100;
color_(&i__2);
}
/* L200: */
}
zzzplt_1.xphold = xold;
zzzplt_1.yphold = yold;
return 0;
} /* pwritf_ */
/* $Procedure DXTRCT (Extract Double Precision Values From A String) */
/* Subroutine */ int dxtrct_(char *keywd, integer *maxwds, char *string,
integer *nfound, integer *parsed, doublereal *values, ftnlen
keywd_len, ftnlen string_len)
{
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer pntr, i__, j;
doublereal x;
extern integer nblen_(char *, ftnlen);
char error[80];
integer start, fallbk, berase, eerase;
extern /* Subroutine */ int fndnwd_(char *, integer *, integer *, integer
*, ftnlen);
integer length;
extern integer lastnb_(char *, ftnlen);
extern /* Subroutine */ int nparsd_(char *, doublereal *, char *, integer
*, ftnlen, ftnlen);
extern integer wdindx_(char *, char *, ftnlen, ftnlen);
integer positn;
/* $ Abstract */
/* Locate a keyword and succeeding numeric words within a string. */
/* Parse and store the numeric words. Remove the keyword and */
/* numeric words from the input string. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* PARSING, WORD */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* KEYWD I Keyword used to mark start of a set of numbers. */
/* MAXWDS I Maximum number of numeric words that can be parsed */
/* STRING I/O String potentially containing KEYWD and numbers. */
/* NFOUND O Number of numeric words found following the KEYWD. */
/* PARSED O Number of numeric words translated and returned. */
/* VALUES O The double precision values for the numbers. */
/* $ Detailed_Input */
/* KEYWD is a word used to mark the start of a set of numeric */
/* words of interest. */
/* MAXWDS is the maximum number of numeric words that can be */
/* parsed and returned. */
/* STRING is a string potentially containing KEYWD and numbers. */
/* $ Detailed_Output */
/* STRING is the input string stripped of all parsed */
/* numeric words. If there was room available to parse */
/* all of the numeric words associated with KEYWD, the */
/* keyword that marked the beginning of the parsed */
/* numbers in the original string will also be removed. */
/* NFOUND is the number of numeric words that were found */
/* following KEYWD but preceding the next non-numeric */
/* word of the string. If the KEYWD is not present in */
/* the string, NFOUND is returned as -1. If the keyword */
/* is located but the next word in the string is */
/* non-numeric NFOUND will be returned as 0. */
/* PARSED is the number of numeric words that were actually */
/* parsed and stored in the output array VALUES. If no */
/* values are parsed PARSED is returned as 0. */
/* VALUES are the double precision values for the parsed */
/* numeric words that follow the first occurance of the */
/* keyword but precede the next non-numeric word. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* Definitions: */
/* A WORD is a set of consecutive non-blank characters */
/* delimited by blanks or the end of the string */
/* that contains them. */
/* A NUMERIC WORD a word that can be parsed by the */
/* SPICELIB routine NPARSD without error. All */
/* FORTRAN numeric representations are numeric */
/* words. In addition 'PI', 'Pi', 'pI', and 'pi' */
/* are all recognized as having the value: */
/* 3.1415926535897932384626D0 */
/* See NPARSD FOR A a full description of legitimate */
/* numeric words. */
/* Given a string and a keyword this routine locates the first */
/* occurrance of the keyword in the string and returns the double */
/* precision representations of up to MAXWDS succeeding numeric */
/* words. All parsed numeric words are removed from the string. */
/* If every numeric word following KEYWD but preceding the next */
/* non-numeric word is parsed, KEYWD will also be removed from */
/* the string. */
/* If the keyword cannot be located in the string, the variable */
/* NFOUND will be returned as -1 and the string will be unchanged. */
/* In all other cases, some part of the string (possibly all of it) */
/* will be removed. */
/* $ Examples */
/* Input STRING 'LONGITUDE 39.2829 LATITUDE 24.27682' */
/* KEYWD 'LONGITUDE' */
/* MAXWDS 4 */
/* Output: STRING ' LATITUDE 24.27682' */
/* NFOUND 1 */
/* PARSED 1 */
/* VALUES 3.92829D+01 */
/* Input STRING 'THIS IS A BAD STRING FOR NUMBERS' */
/* KEYWD 'RADIUS' */
/* MAXWDS 2 */
/* Output: STRING 'THIS IS A BAD STRING FOR NUMBERS' */
/* NFOUND -1 */
/* PARSED 0 */
/* VALUES (unchanged) */
/* Input STRING 'PRIMES 11 13 17 19 23 NON-PRIMES 12 14 15' */
/* KEYWD 'PRIMES' */
/* MAXWDS 3 */
/* Output: STRING 'PRIMES 19 23 NON-PRIMES 12 14 15' */
/* NFOUND 5 */
/* PARSED 3 */
/* VALUES 1.1D+01 */
/* 1.3D+01 */
/* 1.7D+01 */
/* Input STRING 'PRIMES 11 13 17 19 23 NON-PRIMES 12 14 15' */
/* KEYWD 'PRIMES' */
/* MAXWDS 5 */
/* Output: STRING ' NON-PRIMES 12 14 15' */
/* NFOUND 5 */
/* PARSED 5 */
/* VALUES 1.1D+01 */
/* 1.3D+01 */
/* 1.7D+01 */
/* 1.9D+01 */
/* 2.3D+01 */
/* $ Restrictions */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.1.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.1.0, 23-MAY-1990 (HAN) */
/* The variable FOUND was changed to NFOUND. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* extract d.p. values from a string */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.1.0, 23-MAY-1990 (HAN) */
/* The variable FOUND was changed to NFOUND. Other SPICELIB */
/* routines that use the variable FOUND declare it as a logical. */
/* In order to conform to this convention, FOUND was changed to */
/* NFOUND to indicate that it has an integer value, not a logical */
/* value. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* No keywords or numbers have been located yet. */
*nfound = 0;
*parsed = 0;
/* Locate the keyword within the string and get the length of the */
/* string. */
positn = wdindx_(string, keywd, string_len, keywd_len);
length = lastnb_(string, string_len);
if (positn == 0) {
*nfound = -1;
*parsed = 0;
return 0;
}
/* Set the begin erase marker to the start of the current word */
/* Set the end erase marker to the end of the current word */
berase = positn;
eerase = positn + nblen_(keywd, keywd_len) - 1;
start = eerase + 1;
if (start < length) {
/* Locate the next word and try to parse it ... */
fndnwd_(string, &start, &i__, &j, string_len);
nparsd_(string + (i__ - 1), &x, error, &pntr, j - (i__ - 1), (ftnlen)
80);
if (s_cmp(error, " ", (ftnlen)80, (ftnlen)1) == 0) {
/* ... mark its starting position as a possible starting */
/* point for deletion if we run out of room for parsed numbers. */
fallbk = i__;
eerase = j;
start = j + 1;
++(*nfound);
++(*parsed);
values[*parsed - 1] = x;
}
} else {
s_copy(string + (berase - 1), " ", string_len - (berase - 1), (ftnlen)
1);
return 0;
}
/* Now find all of the succeeding numeric words until we run out of */
/* numeric words or string to look at. */
while(start < length && s_cmp(error, " ", (ftnlen)80, (ftnlen)1) == 0) {
/* Find the next word and try to parse it as a number. */
fndnwd_(string, &start, &i__, &j, string_len);
nparsd_(string + (i__ - 1), &x, error, &pntr, j - (i__ - 1), (ftnlen)
80);
if (s_cmp(error, " ", (ftnlen)80, (ftnlen)1) == 0) {
/* It's a number! Congratulations! */
++(*nfound);
/* If there is room ... */
if (*nfound <= *maxwds) {
/* 1. Increment the counter PARSED. */
/* 2. Load the DP value into the output array. */
/* 3. Set the pointer for the end of the erase */
/* region to be the end of this word. */
++(*parsed);
values[*parsed - 1] = x;
eerase = j;
} else {
/* Set the pointer of the begin erase region to be the */
/* the pointer set up just for this occasion. */
berase = fallbk;
}
/* Set the place to begin looking for the next word to be */
/* at the first character following the end of the current */
/* word. */
start = j + 1;
}
}
/* Remove the parsed words from the string. */
i__ = berase;
j = eerase + 1;
while(j <= length) {
*(unsigned char *)&string[i__ - 1] = *(unsigned char *)&string[j - 1];
++i__;
++j;
}
s_copy(string + (i__ - 1), " ", string_len - (i__ - 1), (ftnlen)1);
return 0;
} /* dxtrct_ */
/* $Procedure REMSUB ( Remove a substring ) */
/* Subroutine */ int remsub_(char *in, integer *left, integer *right, char *
out, ftnlen in_len, ftnlen out_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer i__, j, l, r__;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer inlen;
extern integer lastnb_(char *, ftnlen);
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
integer outlen;
extern logical return_(void);
/* $ Abstract */
/* Remove the substring (LEFT:RIGHT) from a character string. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* ASSIGNMENT, CHARACTER, STRING */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* IN I Input string. */
/* LEFT I Position of first character to be removed. */
/* RIGHT I Position of last character to be removed. */
/* OUT O Output string. */
/* $ Detailed_Input */
/* IN is an input character string, from which a substring */
/* is to be removed. */
/* LEFT, */
/* RIGHT are the ends of the substring to be removed. */
/* $ Detailed_Output */
/* OUT is the output string. This is equivalent to the */
/* string that would be created by the concatenation */
/* OUT = IN(1 : LEFT-1) // IN(RIGHT+1 : ) */
/* If the string is too long to fit into OUT, it is */
/* truncated on the right. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* Move the characters, beginning with RIGHT, one at a time to the */
/* positions immediately following LEFT. This has the same effect */
/* as the concatenation */
/* OUT = IN(1 : LEFT-1) // IN(RIGHT+1 : ) */
/* Because this operation is not standard for strings of length (*), */
/* this routine does not use concatenation. */
/* $ Examples */
/* The following examples illustrate the use of REMSUB. */
/* IN LEFT RIGHT OUT */
/* ----------------- ---- ----- ------------------------ */
/* 'ABCDEFGHIJ' 3 5 'ABFGHIJ' */
/* 'The best rabbit' 5 8 'The rabbit' */
/* 'The other woman' 1 4 'other woman' */
/* 'An Apple a day' 2 2 'A apple a day' */
/* 'An Apple a day' 5 2 An error is signalled. */
/* 'An Apple a day' 0 0 An error is signalled. */
/* 'An Apple a day' -3 3 An error is signalled. */
/* Whenever an error has been signalled, the contents of OUT are */
/* unpredictable. */
/* $ Restrictions */
/* None. */
/* $ Exceptions */
/* If LEFT > RIGHT, RIGHT < 1, LEFT < 1, RIGHT > LEN(IN), or */
/* LEFT > LEN(IN), the error SPICE(INVALIDINDEX) is signalled. */
/* $ Files */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* remove a substring */
/* -& */
/* $ Revisions */
/* - Beta Version 2.0.0, 5-JAN-1989 (HAN) */
/* Error handling was added to detect invalid character */
/* positions. If LEFT > RIGHT, RIGHT < 1, LEFT < 1, */
/* RIGHT > LEN(IN), or LEFT > LEN(IN), an error is signalled. */
/* -& */
/* SPICELIB functions */
/* Other functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("REMSUB", (ftnlen)6);
}
/* If a character position is out of range, signal an error. */
if (*left > *right || *right < 1 || *left < 1 || *right > i_len(in,
in_len) || *left > i_len(in, in_len)) {
setmsg_("Left location was *. Right location was *.", (ftnlen)42);
errint_("*", left, (ftnlen)1);
errint_("*", right, (ftnlen)1);
sigerr_("SPICE(INVALIDINDEX)", (ftnlen)19);
chkout_("REMSUB", (ftnlen)6);
return 0;
} else {
l = *left;
r__ = *right;
}
/* How much of the input string will we use? And how big is the */
/* output string? */
inlen = lastnb_(in, in_len);
outlen = i_len(out, out_len);
/* Copy the first part of the input string. (One character at a */
/* time, in case this is being done in place.) */
/* Computing MIN */
i__2 = l - 1;
i__1 = min(i__2,outlen);
for (i__ = 1; i__ <= i__1; ++i__) {
*(unsigned char *)&out[i__ - 1] = *(unsigned char *)&in[i__ - 1];
}
/* Now move the rest of the string over. */
i__ = l;
j = r__ + 1;
while(i__ <= outlen && j <= inlen) {
*(unsigned char *)&out[i__ - 1] = *(unsigned char *)&in[j - 1];
++i__;
++j;
}
/* Pad with blanks, if necessary. */
if (i__ <= outlen) {
s_copy(out + (i__ - 1), " ", out_len - (i__ - 1), (ftnlen)1);
}
chkout_("REMSUB", (ftnlen)6);
return 0;
} /* remsub_ */
/* $Procedure SPKW17 ( SPK, write a type 17 segment ) */
/* Subroutine */ int spkw17_(integer *handle, integer *body, integer *center,
char *frame, doublereal *first, doublereal *last, char *segid,
doublereal *epoch, doublereal *eqel, doublereal *rapol, doublereal *
decpol, ftnlen frame_len, ftnlen segid_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal a, h__;
integer i__;
doublereal k;
extern /* Subroutine */ int chkin_(char *, ftnlen);
doublereal descr[5];
extern /* Subroutine */ int moved_(doublereal *, integer *, doublereal *);
integer value;
extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen), dafada_(
doublereal *, integer *), dafbna_(integer *, doublereal *, char *,
ftnlen), dafena_(void);
extern logical failed_(void);
doublereal record[12];
extern integer lastnb_(char *, ftnlen);
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen), spkpds_(integer *, integer *, char *, integer *,
doublereal *, doublereal *, doublereal *, ftnlen);
extern logical return_(void);
doublereal ecc;
/* $ Abstract */
/* Write an SPK segment of type 17 given a type 17 data 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 */
/* SPK */
/* $ Keywords */
/* EPHEMERIS */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle of an SPK file open for writing. */
/* BODY I Body code for ephemeris object. */
/* CENTER I Body code for the center of motion of the body. */
/* FRAME I The reference frame of the states. */
/* FIRST I First valid time for which states can be computed. */
/* LAST I Last valid time for which states can be computed. */
/* SEGID I Segment identifier. */
/* EPOCH I Epoch of elements in seconds past J2000 */
/* EQEL I Array of equinoctial elements */
/* RAPOL I Right Ascension of the pole of the reference plane */
/* DECPOL I Declination of the pole of the reference plane */
/* $ Detailed_Input */
/* HANDLE is the file handle of an SPK file that has been */
/* opened for writing. */
/* BODY is the NAIF ID for the body whose states are */
/* to be recorded in an SPK file. */
/* CENTER is the NAIF ID for the center of motion associated */
/* with BODY. */
/* FRAME is the reference frame that states are referenced to, */
/* for example 'J2000'. */
/* FIRST are the bounds on the ephemeris times, expressed as */
/* LAST seconds past J2000. */
/* SEGID is the segment identifier. An SPK segment identifier */
/* may contain up to 40 characters. */
/* EPOCH is the epoch of equinoctial elements in seconds */
/* past the J2000 epoch. */
/* EQEL is an array of 9 double precision numbers that */
/* are the equinoctial elements for some orbit relative */
/* to the equatorial frame of a central body. */
/* ( The z-axis of the equatorial frame is the direction */
/* of the pole of the central body relative to FRAME. */
/* The x-axis is given by the cross product of the */
/* Z-axis of FRAME with the direction of the pole of */
/* the central body. The Y-axis completes a right */
/* handed frame. ) */
/* The specific arrangement of the elements is spelled */
/* out below. The following terms are used in the */
/* discussion of elements of EQEL */
/* INC --- inclination of the orbit */
/* ARGP --- argument of periapse */
/* NODE --- longitude of the ascending node */
/* E --- eccentricity of the orbit */
/* EQEL(1) is the semi-major axis (A) of the orbit in km. */
/* EQEL(2) is the value of H at the specified epoch. */
/* ( E*SIN(ARGP+NODE) ). */
/* EQEL(3) is the value of K at the specified epoch */
/* ( E*COS(ARGP+NODE) ). */
/* EQEL(4) is the mean longitude (MEAN0+ARGP+NODE)at */
/* the epoch of the elements measured in radians. */
/* EQEL(5) is the value of P (TAN(INC/2)*SIN(NODE))at */
/* the specified epoch. */
/* EQEL(6) is the value of Q (TAN(INC/2)*COS(NODE))at */
/* the specified epoch. */
/* EQEL(7) is the rate of the longitude of periapse */
/* (dARGP/dt + dNODE/dt ) at the epoch of */
/* the elements. This rate is assumed to hold */
/* for all time. The rate is measured in */
/* radians per second. */
/* EQEL(8) is the derivative of the mean longitude */
/* ( dM/dt + dARGP/dt + dNODE/dt ). This */
/* rate is assumed to be constant and is */
/* measured in radians/second. */
/* EQEL(9) is the rate of the longitude of the ascending */
/* node ( dNODE/dt). This rate is measured */
/* in radians per second. */
/* RAPOL Right Ascension of the pole of the reference plane */
/* relative to FRAME measured in radians. */
/* DECPOL Declination of the pole of the reference plane */
/* relative to FRAME measured in radians. */
/* $ Detailed_Output */
/* None. A type 17 segment is written to the file attached */
/* to HANDLE. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the semi-major axis is less than or equal to zero, the error */
/* 'SPICE(BADSEMIAXIS)' is signalled. */
/* 2) If the eccentricity of the orbit corresponding to the values */
/* of H and K ( EQEL(2) and EQEL(3) ) is greater than 0.9 the */
/* error 'SPICE(ECCOUTOFRANGE)' is signalled. */
/* 3) If the segment identifier has more than 40 non-blank characters */
/* the error 'SPICE(SEGIDTOOLONG)' is signalled. */
/* 4) If the segment identifier contains non-printing characters */
/* the error 'SPICE(NONPRINTABLECHARS)' is signalled. */
/* 5) If there are inconsistencies in the BODY, CENTER, FRAME or */
/* FIRST and LAST times, the problem will be diagnosed by */
/* a routine in the call tree of this routine. */
/* $ Files */
/* A new type 17 SPK segment is written to the SPK file attached */
/* to HANDLE. */
/* $ Particulars */
/* This routine writes an SPK type 17 data segment to the open SPK */
/* file according to the format described in the type 17 section of */
/* the SPK Required Reading. The SPK file must have been opened with */
/* write access. */
/* $ Examples */
/* Suppose that at time EPOCH you have the classical elements */
/* of some BODY relative to the equatorial frame of some central */
/* body CENTER. These can be converted to equinoctial elements */
/* and stored in an SPK file as a type 17 segment so that this */
/* body can be used within the SPK subsystem of the SPICE system. */
/* Below is a list of the variables used to represent the */
/* classical elements */
/* Variable Meaning */
/* -------- ---------------------------------- */
/* A Semi-major axis in km */
/* ECC Eccentricity of orbit */
/* INC Inclination of orbit */
/* NODE Longitude of the ascending node at epoch */
/* OMEGA Argument of periapse at epoch */
/* M Mean anomaly at epoch */
/* DMDT Mean anomaly rate in radians/second */
/* DNODE Rate of change of longitude of ascending node */
/* in radians/second */
/* DOMEGA Rate of change of argument of periapse in */
/* radians/second */
/* EPOCH is the epoch of the elements in seconds past */
/* the J2000 epoch. */
/* These elements are converted to equinoctial elements (in */
/* the order compatible with type 17) as shown below. */
/* EQEL(1) = A */
/* EQEL(2) = ECC * DSIN ( OMEGA + NODE ) */
/* EQEL(3) = ECC * DCOS ( OMEGA + NODE ) */
/* EQEL(4) = M + OMEGA + NODE */
/* EQEL(5) = TAN(INC/2.0D0) * DSIN(NODE) */
/* EQEL(6) = TAN(INC/2.0D0) * DCOS(NODE) */
/* EQEL(7) = DOMEGA */
/* EQEL(8) = DOMEGA + DMDT + DNODE */
/* EQEL(9) = DNODE */
/* C */
/* C Now add the segment. */
/* C */
/* CALL SPKW17 ( HANDLE, BODY, CENTER, FRAME, FIRST, LAST, */
/* . SEGID, EPOCH, EQEL, RAPOL, DECPOL ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.1, 24-Jun-1999 (WLT) */
/* Corrected typographical errors in the header. */
/* - SPICELIB Version 1.0.0, 8-Jan-1997 (WLT) */
/* -& */
/* $ Index_Entries */
/* Write a type 17 spk segment */
/* -& */
/* SPICELIB Functions */
/* Local Variables */
/* Segment descriptor size */
/* Segment identifier size */
/* SPK data type */
/* Range of printing characters */
/* Number of items in a segment */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
chkin_("SPKW17", (ftnlen)6);
/* Fetch the various entities from the inputs and put them into */
/* the data record, first the epoch. */
record[0] = *epoch;
/* The trajectory pole vector. */
moved_(eqel, &c__9, &record[1]);
record[10] = *rapol;
record[11] = *decpol;
a = record[1];
h__ = record[2];
k = record[3];
ecc = sqrt(h__ * h__ + k * k);
/* Check all the inputs here for obvious failures. It's much */
/* better to check them now and quit than it is to get a bogus */
/* segment into an SPK file and diagnose it later. */
if (a <= 0.) {
setmsg_("The semimajor axis supplied to the SPK type 17 evaluator wa"
"s non-positive. This value must be positive. The value supp"
"lied was #.", (ftnlen)130);
errdp_("#", &a, (ftnlen)1);
sigerr_("SPICE(BADSEMIAXIS)", (ftnlen)18);
chkout_("SPKW17", (ftnlen)6);
return 0;
} else if (ecc > .9) {
setmsg_("The eccentricity supplied for a type 17 segment is greater "
"than 0.9. It must be less than 0.9.The value supplied to th"
"e type 17 evaluator was #. ", (ftnlen)146);
errdp_("#", &ecc, (ftnlen)1);
sigerr_("SPICE(BADECCENTRICITY)", (ftnlen)22);
chkout_("SPKW17", (ftnlen)6);
return 0;
}
/* Make sure the segment identifier is not too long. */
if (lastnb_(segid, segid_len) > 40) {
setmsg_("Segment identifier contains more than 40 characters.", (
ftnlen)52);
sigerr_("SPICE(SEGIDTOOLONG)", (ftnlen)19);
chkout_("SPKW17", (ftnlen)6);
return 0;
}
/* Make sure the segment identifier has only printing characters. */
i__1 = lastnb_(segid, segid_len);
for (i__ = 1; i__ <= i__1; ++i__) {
value = *(unsigned char *)&segid[i__ - 1];
if (value < 32 || value > 126) {
setmsg_("The segment identifier contains the nonprintable charac"
"ter having ascii code #.", (ftnlen)79);
errint_("#", &value, (ftnlen)1);
sigerr_("SPICE(NONPRINTABLECHARS)", (ftnlen)24);
chkout_("SPKW17", (ftnlen)6);
return 0;
}
}
/* All of the obvious checks have been performed on the input */
/* record. Create the segment descriptor. (FIRST and LAST are */
/* checked by SPKPDS as well as consistency between BODY and CENTER). */
spkpds_(body, center, frame, &c__17, first, last, descr, frame_len);
if (failed_()) {
chkout_("SPKW17", (ftnlen)6);
return 0;
}
/* Begin a new segment. */
dafbna_(handle, descr, segid, segid_len);
if (failed_()) {
chkout_("SPKW17", (ftnlen)6);
return 0;
}
dafada_(record, &c__12);
if (! failed_()) {
dafena_();
}
chkout_("SPKW17", (ftnlen)6);
return 0;
} /* spkw17_ */
/* $Procedure SPKW21 ( Write SPK segment, type 21 ) */
/* Subroutine */ int spkw21_(integer *handle, integer *body, integer *center,
char *frame, doublereal *first, doublereal *last, char *segid,
integer *n, integer *dlsize, doublereal *dlines, doublereal *epochs,
ftnlen frame_len, ftnlen segid_len)
{
/* System generated locals */
integer dlines_dim1, dlines_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
integer i__, j;
extern /* Subroutine */ int chkin_(char *, ftnlen);
doublereal descr[5];
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen),
errdp_(char *, doublereal *, ftnlen), dafada_(doublereal *,
integer *), dafbna_(integer *, doublereal *, char *, ftnlen),
dafena_(void);
extern logical failed_(void);
integer chrcod, refcod, maxdim;
extern integer lastnb_(char *, ftnlen);
extern /* Subroutine */ int namfrm_(char *, integer *, ftnlen), sigerr_(
char *, ftnlen), chkout_(char *, ftnlen);
doublereal prvepc;
extern /* Subroutine */ int setmsg_(char *, ftnlen);
integer maxdsz;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen), spkpds_(
integer *, integer *, char *, integer *, doublereal *, doublereal
*, doublereal *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Write a type 21 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 */
/* NAIF_IDS */
/* SPK */
/* TIME */
/* $ Keywords */
/* EPHEMERIS */
/* FILES */
/* $ Declarations */
/* $ Abstract */
/* Declare parameters specific to SPK type 21. */
/* $ 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) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 25-DEC-2013 (NJB) */
/* -& */
/* MAXTRM is the maximum number of terms allowed in each */
/* component of the difference table contained in a type */
/* 21 SPK difference line. MAXTRM replaces the fixed */
/* table parameter value of 15 used in SPK type 1 */
/* segments. */
/* Type 21 segments have variable size. Let MAXDIM be */
/* the dimension of each component of the difference */
/* table within each difference line. Then the size */
/* DLSIZE of the difference line is */
/* ( 4 * MAXDIM ) + 11 */
/* MAXTRM is the largest allowed value of MAXDIM. */
/* End of include file spk21.inc. */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle of an SPK file open for writing. */
/* BODY I NAIF code for an ephemeris object. */
/* CENTER I NAIF 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. */
/* N I Number of difference lines in segment. */
/* DLSIZE I Difference line size. */
/* DLINES I Array of difference lines. */
/* EPOCHS I Coverage end times of difference lines. */
/* MAXTRM P Maximum number of terms per difference table */
/* component. */
/* $ Detailed_Input */
/* HANDLE is the file 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 start and stop times of */
/* the time interval over which the segment defines */
/* the state of BODY. */
/* SEGID is the segment identifier. An SPK segment */
/* identifier may contain up to 40 characters. */
/* N is the number of difference lines in the input */
/* difference line array. */
/* DLSIZE is the size of each difference line data structure */
/* in the difference line array input DLINES. Let */
/* MAXDIM be the dimension of each component of the */
/* difference table within each difference line. Then */
/* the size DLSIZE of the difference line is */
/* ( 4 * MAXDIM ) + 11 */
/* DLINES contains a time-ordered array of difference lines. */
/* The Ith difference line occupies elements (1,I) */
/* through (MAXDIM,I) of DLINES, where MAXDIM is */
/* as described above in the description of DLSIZE. */
/* Each difference line represents the state (x, y, */
/* z, dx/dt, dy/dt, dz/dt, in kilometers and */
/* kilometers per second) of BODY relative to CENTER, */
/* specified relative to FRAME, for an interval of */
/* time. The time interval covered by the Ith */
/* difference line ends at the Ith element of the */
/* array EPOCHS (described below). The interval */
/* covered by the first difference line starts at the */
/* segment start time. */
/* The contents of a difference line are as shown */
/* below: */
/* Dimension Description */
/* --------- ---------------------------------- */
/* 1 Reference epoch of difference line */
/* MAXDIM Stepsize function vector */
/* 1 Reference position vector, x */
/* 1 Reference velocity vector, x */
/* 1 Reference position vector, y */
/* 1 Reference velocity vector, y */
/* 1 Reference position vector, z */
/* 1 Reference velocity vector, z */
/* MAXDIM,3 Modified divided difference */
/* arrays (MDAs) */
/* 1 Maximum integration order plus 1 */
/* 3 Integration order array */
/* The reference position and velocity are those of */
/* BODY relative to CENTER at the reference epoch. */
/* (A difference line is essentially a polynomial */
/* expansion of acceleration about the reference */
/* epoch.) */
/* EPOCHS is an array of epochs corresponding to the members */
/* of the difference line array. The epochs are */
/* specified as seconds past J2000 TDB. */
/* The first difference line covers the time interval */
/* from the segment start time to EPOCHS(1). For */
/* I > 1, the Ith difference line covers the half-open */
/* time interval from, but not including, EPOCHS(I-1) */
/* through EPOCHS(I). */
/* The elements of EPOCHS must be strictly increasing. */
/* $ Detailed_Output */
/* None. See $Particulars for a description of the effect of this */
/* routine. */
/* $ Parameters */
/* MAXTRM is the maximum number of terms allowed in */
/* each component of the difference table */
/* contained in the input argument RECORD. */
/* See the INCLUDE file spk21.inc for the value */
/* of MAXTRM. */
/* $ Exceptions */
/* If any of the following exceptions occur, this routine will return */
/* without creating a new segment. */
/* 1) If FRAME is not a recognized name, the error */
/* SPICE(INVALIDREFFRAME) is signaled. */
/* 2) If the last non-blank character of SEGID occurs past index 40, */
/* the error SPICE(SEGIDTOOLONG) is signaled. */
/* 3) If SEGID contains any nonprintable characters, the error */
/* SPICE(NONPRINTABLECHARS) is signaled. */
/* 4) If the number of difference lines N is not at least one, */
/* the error SPICE(INVALIDCOUNT) will be signaled. */
/* 5) If FIRST is greater than LAST then the error */
/* SPICE(BADDESCRTIMES) will be signaled. */
/* 6) If the elements of the array EPOCHS are not in strictly */
/* increasing order, the error SPICE(TIMESOUTOFORDER) will be */
/* signaled. */
/* 7) If the last epoch EPOCHS(N) is less than LAST, the error */
/* SPICE(COVERAGEGAP) will be signaled. */
/* 8) If DLSIZE is greater than the limit */
/* ( 4 * MAXTRM ) + 11 */
/* the error SPICE(DIFFLINETOOLARGE) will be signaled. If */
/* DLSIZE is less than 71, the error SPICE(DIFFLINETOOSMALL) */
/* will be signaled. */
/* 9) If any value in the step size array of any difference */
/* line is zero, the error SPICE(ZEROSTEP) will be signaled. */
/* $ Files */
/* A new type 21 SPK segment is written to the SPK file attached */
/* to HANDLE. */
/* $ Particulars */
/* This routine writes an SPK type 21 data segment to the open SPK */
/* file according to the format described in the type 21 section of */
/* the SPK Required Reading. The SPK file must have been opened with */
/* write access. */
/* $ Examples */
/* Suppose that you have difference lines and are prepared to */
/* produce a segment of type 21 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_21_SEGMENT' */
/* C */
/* C Write the segment. */
/* C */
/* CALL SPKW21 ( HANDLE, BODY, CENTER, FRAME, */
/* . FIRST, LAST, SEGID, N, */
/* . DLSIZE, DLINES, EPOCHS ) */
/* $ Restrictions */
/* 1) The validity of the difference lines is not checked by */
/* this routine. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 03-FEB-2014 (NJB) */
/* -& */
/* $ Index_Entries */
/* write spk type_21 ephemeris data segment */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* MINDSZ is the minimum MDA size; this is the size */
/* of type 1 MDAs. */
/* Local variables */
/* Local variables */
/* Standard SPICE error handling. */
/* Parameter adjustments */
dlines_dim1 = *dlsize;
dlines_offset = dlines_dim1 + 1;
/* Function Body */
if (return_()) {
return 0;
}
chkin_("SPKW21", (ftnlen)6);
/* Make sure the difference line size is within limits. */
maxdsz = 111;
if (*dlsize > maxdsz) {
setmsg_("The input difference line size is #, while the maximum supp"
"orted by this routine is #. It is possible that this problem"
" is due to your SPICE Toolkit being out of date.", (ftnlen)
167);
errint_("#", dlsize, (ftnlen)1);
errint_("#", &maxdsz, (ftnlen)1);
sigerr_("SPICE(DIFFLINETOOLARGE)", (ftnlen)23);
chkout_("SPKW21", (ftnlen)6);
return 0;
}
if (*dlsize < 71) {
setmsg_("The input difference line size is #, while the minimum supp"
"orted by this routine is #. It is possible that this problem"
" is due to your SPICE Toolkit being out of date.", (ftnlen)
167);
errint_("#", dlsize, (ftnlen)1);
errint_("#", &c__71, (ftnlen)1);
sigerr_("SPICE(DIFFLINETOOSMALL)", (ftnlen)23);
chkout_("SPKW21", (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_("SPKW21", (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_("SPKW21", (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_("SPKW21", (ftnlen)6);
return 0;
}
}
/* The difference line count must be at least one. */
if (*n < 1) {
setmsg_("The difference line count was #; the count must be at least"
" one.", (ftnlen)64);
errint_("#", n, (ftnlen)1);
sigerr_("SPICE(INVALIDCOUNT)", (ftnlen)19);
chkout_("SPKW21", (ftnlen)6);
return 0;
}
/* The segment stop time should be greater than or equal to */
/* the begin time. */
if (*first > *last) {
setmsg_("The segment start time: # is greater than the segment end t"
"ime: #", (ftnlen)65);
errdp_("#", first, (ftnlen)1);
errdp_("#", last, (ftnlen)1);
sigerr_("SPICE(BADDESCRTIMES)", (ftnlen)20);
chkout_("SPKW21", (ftnlen)6);
return 0;
}
/* Make sure the epochs form a strictly increasing sequence. */
prvepc = epochs[0];
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
if (epochs[i__ - 1] <= prvepc) {
setmsg_("EPOCH # having index # is not greater than its predeces"
"sor #.", (ftnlen)61);
errdp_("#", &epochs[i__ - 1], (ftnlen)1);
errint_("#", &i__, (ftnlen)1);
errdp_("#", &epochs[i__ - 2], (ftnlen)1);
sigerr_("SPICE(TIMESOUTOFORDER)", (ftnlen)22);
chkout_("SPKW21", (ftnlen)6);
return 0;
}
prvepc = epochs[i__ - 1];
}
/* Make sure there's no gap between the last difference line */
/* epoch and the end of the time interval defined by the segment */
/* descriptor. */
if (epochs[*n - 1] < *last) {
setmsg_("Segment has coverage gap: segment end time # follows last e"
"poch #.", (ftnlen)66);
errdp_("#", last, (ftnlen)1);
errdp_("#", &epochs[*n - 1], (ftnlen)1);
sigerr_("SPICE(COVERAGEGAP)", (ftnlen)18);
chkout_("SPKW21", (ftnlen)6);
return 0;
}
/* Check the step size vectors in the difference lines. */
maxdim = (*dlsize - 11) / 4;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = maxdim + 1;
for (j = 2; j <= i__2; ++j) {
if (dlines[j + i__ * dlines_dim1 - dlines_offset] == 0.) {
setmsg_("Step size was zero at step size vector index # with"
"in difference line #.", (ftnlen)72);
i__3 = j - 1;
errint_("#", &i__3, (ftnlen)1);
errint_("#", &i__, (ftnlen)1);
sigerr_("SPICE(ZEROSTEP)", (ftnlen)15);
chkout_("SPKW21", (ftnlen)6);
return 0;
}
}
}
/* If we made it this far, we're ready to start writing the segment. */
/* Create the segment descriptor. */
spkpds_(body, center, frame, &c__21, first, last, descr, frame_len);
/* Begin a new segment. */
dafbna_(handle, descr, segid, segid_len);
if (failed_()) {
chkout_("SPKW21", (ftnlen)6);
return 0;
}
/* The type 21 segment structure is shown below: */
/* +-----------------------+ */
/* | Difference line 1 | */
/* +-----------------------+ */
/* | Difference line 2 | */
/* +-----------------------+ */
/* ... */
/* +-----------------------+ */
/* | Difference line N | */
/* +-----------------------+ */
/* | Epoch 1 | */
/* +-----------------------+ */
/* | Epoch 2 | */
/* +-----------------------+ */
/* ... */
/* +-----------------------+ */
/* | Epoch N | */
/* +-----------------------+ */
/* | Epoch 100 | (First directory) */
/* +-----------------------+ */
/* ... */
/* +-----------------------+ */
/* | Epoch (N/100)*100 | (Last directory) */
/* +-----------------------+ */
/* | Max diff table size | */
/* +-----------------------+ */
/* | Number of diff lines | */
/* +-----------------------+ */
i__1 = *n * *dlsize;
dafada_(dlines, &i__1);
dafada_(epochs, n);
i__1 = *n / 100;
for (i__ = 1; i__ <= i__1; ++i__) {
dafada_(&epochs[i__ * 100 - 1], &c__1);
}
d__1 = (doublereal) maxdim;
dafada_(&d__1, &c__1);
d__1 = (doublereal) (*n);
dafada_(&d__1, &c__1);
/* As long as nothing went wrong, end the segment. */
if (! failed_()) {
dafena_();
}
chkout_("SPKW21", (ftnlen)6);
return 0;
} /* spkw21_ */
/* $Procedure CKW01 ( C-Kernel, write segment to C-kernel, data type 1 ) */
/* Subroutine */ int ckw01_(integer *handle, doublereal *begtim, doublereal *
endtim, integer *inst, char *ref, logical *avflag, char *segid,
integer *nrec, doublereal *sclkdp, doublereal *quats, doublereal *
avvs, ftnlen ref_len, ftnlen segid_len)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1;
/* Local variables */
integer ndir, i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), dafps_(integer *,
integer *, doublereal *, integer *, doublereal *);
doublereal descr[5];
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen);
integer index, value;
extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen), dafada_(
doublereal *, integer *), dafbna_(integer *, doublereal *, char *,
ftnlen), dafena_(void);
extern logical failed_(void);
integer refcod;
extern /* Subroutine */ int namfrm_(char *, integer *, ftnlen);
extern integer lastnb_(char *, ftnlen);
doublereal dirent;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
extern logical vzerog_(doublereal *, integer *), return_(void);
doublereal dcd[2];
integer icd[6];
/* $ Abstract */
/* Add a type 1 segment to a C-kernel. */
/* $ 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 */
/* DAF */
/* SCLK */
/* $ Keywords */
/* POINTING */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle of an open CK file. */
/* BEGTIM I The beginning encoded SCLK of the segment. */
/* ENDTIM I The ending encoded SCLK of the segment. */
/* INST I The NAIF instrument ID code. */
/* REF I The reference frame of the segment. */
/* AVFLAG I True if the segment will contain angular velocity. */
/* SEGID I Segment identifier. */
/* NREC I Number of pointing records. */
/* SCLKDP I Encoded SCLK times. */
/* QUATS I SPICE quaternions representing instrument pointing. */
/* AVVS I Angular velocity vectors. */
/* $ Detailed_Input */
/* HANDLE is the handle of the CK file to which the segment will */
/* be written. The file must have been opened with write */
/* access. */
/* BEGTIM is the beginning encoded SCLK time of the segment. This */
/* value should be less than or equal to the first time in */
/* the segment. */
/* ENDTIM is the encoded SCLK time at which the segment ends. */
/* This value should be greater than or equal to the last */
/* time in the segment. */
/* INST is the NAIF integer ID code for the instrument. */
/* REF is a character string which specifies the */
/* reference frame of the segment. This should be one of */
/* the frames supported by the SPICELIB routine NAMFRM */
/* which is an entry point of FRAMEX. */
/* AVFLAG is a logical flag which indicates whether or not the */
/* segment will contain angular velocity. */
/* SEGID is the segment identifier. A CK segment identifier may */
/* contain up to 40 characters. */
/* NREC is the number of pointing instances in the segment. */
/* SCLKDP are the encoded spacecraft clock times associated with */
/* each pointing instance. These times must be strictly */
/* increasing. */
/* QUATS is an array of SPICE-style quaternions representing a */
/* sequence of C-matrices. See the discussion of */
/* quaternion styles in Particulars below. */
/* AVVS are the angular velocity vectors ( optional ). */
/* If AVFLAG is FALSE then this array is ignored by the */
/* routine, however it still must be supplied as part of */
/* the calling sequence. */
/* $ Detailed_Output */
/* None. See Files section. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If HANDLE is not the handle of a C-kernel opened for writing */
/* the error will be diagnosed by routines called by this */
/* routine. */
/* 2) If SEGID is more than 40 characters long, the error */
/* SPICE(SEGIDTOOLONG) is signalled. */
/* 3) If SEGID contains any nonprintable characters, the error */
/* SPICE(NONPRINTABLECHARS) is signalled. */
/* 4) If the first encoded SCLK time is negative then the error */
/* SPICE(INVALIDSCLKTIME) is signalled. If any subsequent times */
/* are negative the error SPICE(TIMESOUTOFORDER) is signalled. */
/* 5) If the encoded SCLK times are not strictly increasing, */
/* the error SPICE(TIMESOUTOFORDER) is signalled. */
/* 6) If BEGTIM is greater than SCLKDP(1) or ENDTIM is less than */
/* SCLKDP(NREC), the error SPICE(INVALIDDESCRTIME) is */
/* signalled. */
/* 7) If the name of the reference frame is not one of those */
/* supported by the routine NAMFRM, the error */
/* SPICE(INVALIDREFFRAME) is signalled. */
/* 8) If NREC, the number of pointing records, is less than or */
/* equal to 0, the error SPICE(INVALIDNUMRECS) is signalled. */
/* 9) If the squared length of any quaternion differes from 1 */
/* by more than 1.0D-2, the error SPICE(NONUNITQUATERNION) is */
/* signalled. */
/* $ Files */
/* This routine adds a type 1 segment to a C-kernel. The C-kernel */
/* may be either a new one or an existing one opened for writing. */
/* $ Particulars */
/* For a detailed description of a type 1 CK segment please see the */
/* CK Required Reading. */
/* This routine relieves the user from performing the repetitive */
/* calls to the DAF routines necessary to construct a CK segment. */
/* Quaternion Styles */
/* ----------------- */
/* There are different "styles" of quaternions used in */
/* science and engineering applications. Quaternion styles */
/* are characterized by */
/* - The order of quaternion elements */
/* - The quaternion multiplication formula */
/* - The convention for associating quaternions */
/* with rotation matrices */
/* Two of the commonly used styles are */
/* - "SPICE" */
/* > Invented by Sir William Rowan Hamilton */
/* > Frequently used in mathematics and physics textbooks */
/* - "Engineering" */
/* > Widely used in aerospace engineering applications */
/* SPICELIB subroutine interfaces ALWAYS use SPICE quaternions. */
/* Quaternions of any other style must be converted to SPICE */
/* quaternions before they are passed to SPICELIB routines. */
/* Relationship between SPICE and Engineering Quaternions */
/* ------------------------------------------------------ */
/* Let M be a rotation matrix such that for any vector V, */
/* M*V */
/* is the result of rotating V by theta radians in the */
/* counterclockwise direction about unit rotation axis vector A. */
/* Then the SPICE quaternions representing M are */
/* (+/-) ( cos(theta/2), */
/* sin(theta/2) A(1), */
/* sin(theta/2) A(2), */
/* sin(theta/2) A(3) ) */
/* while the engineering quaternions representing M are */
/* (+/-) ( -sin(theta/2) A(1), */
/* -sin(theta/2) A(2), */
/* -sin(theta/2) A(3), */
/* cos(theta/2) ) */
/* For both styles of quaternions, if a quaternion q represents */
/* a rotation matrix M, then -q represents M as well. */
/* Given an engineering quaternion */
/* QENG = ( q0, q1, q2, q3 ) */
/* the equivalent SPICE quaternion is */
/* QSPICE = ( q3, -q0, -q1, -q2 ) */
/* Associating SPICE Quaternions with Rotation Matrices */
/* ---------------------------------------------------- */
/* Let FROM and TO be two right-handed reference frames, for */
/* example, an inertial frame and a spacecraft-fixed frame. Let the */
/* symbols */
/* V , V */
/* FROM TO */
/* denote, respectively, an arbitrary vector expressed relative to */
/* the FROM and TO frames. Let M denote the transformation matrix */
/* that transforms vectors from frame FROM to frame TO; then */
/* V = M * V */
/* TO FROM */
/* where the expression on the right hand side represents left */
/* multiplication of the vector by the matrix. */
/* Then if the unit-length SPICE quaternion q represents M, where */
/* q = (q0, q1, q2, q3) */
/* the elements of M are derived from the elements of q as follows: */
/* +- -+ */
/* | 2 2 | */
/* | 1 - 2*( q2 + q3 ) 2*(q1*q2 - q0*q3) 2*(q1*q3 + q0*q2) | */
/* | | */
/* | | */
/* | 2 2 | */
/* M = | 2*(q1*q2 + q0*q3) 1 - 2*( q1 + q3 ) 2*(q2*q3 - q0*q1) | */
/* | | */
/* | | */
/* | 2 2 | */
/* | 2*(q1*q3 - q0*q2) 2*(q2*q3 + q0*q1) 1 - 2*( q1 + q2 ) | */
/* | | */
/* +- -+ */
/* Note that substituting the elements of -q for those of q in the */
/* right hand side leaves each element of M unchanged; this shows */
/* that if a quaternion q represents a matrix M, then so does the */
/* quaternion -q. */
/* To map the rotation matrix M to a unit quaternion, we start by */
/* decomposing the rotation matrix as a sum of symmetric */
/* and skew-symmetric parts: */
/* 2 */
/* M = [ I + (1-cos(theta)) OMEGA ] + [ sin(theta) OMEGA ] */
/* symmetric skew-symmetric */
/* OMEGA is a skew-symmetric matrix of the form */
/* +- -+ */
/* | 0 -n3 n2 | */
/* | | */
/* OMEGA = | n3 0 -n1 | */
/* | | */
/* | -n2 n1 0 | */
/* +- -+ */
/* The vector N of matrix entries (n1, n2, n3) is the rotation axis */
/* of M and theta is M's rotation angle. Note that N and theta */
/* are not unique. */
/* Let */
/* C = cos(theta/2) */
/* S = sin(theta/2) */
/* Then the unit quaternions Q corresponding to M are */
/* Q = +/- ( C, S*n1, S*n2, S*n3 ) */
/* The mappings between quaternions and the corresponding rotations */
/* are carried out by the SPICELIB routines */
/* Q2M {quaternion to matrix} */
/* M2Q {matrix to quaternion} */
/* M2Q always returns a quaternion with scalar part greater than */
/* or equal to zero. */
/* SPICE Quaternion Multiplication Formula */
/* --------------------------------------- */
/* Given a SPICE quaternion */
/* Q = ( q0, q1, q2, q3 ) */
/* corresponding to rotation axis A and angle theta as above, we can */
/* represent Q using "scalar + vector" notation as follows: */
/* s = q0 = cos(theta/2) */
/* v = ( q1, q2, q3 ) = sin(theta/2) * A */
/* Q = s + v */
/* Let Q1 and Q2 be SPICE quaternions with respective scalar */
/* and vector parts s1, s2 and v1, v2: */
/* Q1 = s1 + v1 */
/* Q2 = s2 + v2 */
/* We represent the dot product of v1 and v2 by */
/* <v1, v2> */
/* and the cross product of v1 and v2 by */
/* v1 x v2 */
/* Then the SPICE quaternion product is */
/* Q1*Q2 = s1*s2 - <v1,v2> + s1*v2 + s2*v1 + (v1 x v2) */
/* If Q1 and Q2 represent the rotation matrices M1 and M2 */
/* respectively, then the quaternion product */
/* Q1*Q2 */
/* represents the matrix product */
/* M1*M2 */
/* $ Examples */
/* C */
/* C This example writes a type 1 C-kernel segment for the */
/* C Galileo scan platform to a previously opened file attached to */
/* C HANDLE. */
/* C */
/* C Assume arrays of quaternions, angular velocities, and the */
/* C associated SCLK times are produced elsewhere. */
/* C */
/* . */
/* . */
/* . */
/* C */
/* C The subroutine CKW01 needs the following items for the */
/* C segment descriptor: */
/* C */
/* C 1) SCLK limits of the segment. */
/* C 2) Instrument code. */
/* C 3) Reference frame. */
/* C 4) The angular velocity flag. */
/* C */
/* BEGTIM = SCLK ( 1 ) */
/* ENDTIM = SCLK ( NREC ) */
/* INST = -77001 */
/* REF = 'J2000' */
/* AVFLAG = .TRUE. */
/* SEGID = 'GLL SCAN PLT - DATA TYPE 1' */
/* C */
/* C Write the segment. */
/* C */
/* CALL CKW01 ( HANDLE, BEGTIM, ENDTIM, INST, REF, AVFLAG, */
/* . SEGID, NREC, SCLKDP, QUATS, AVVS ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* K.R. Gehringer (JPL) */
/* N.J. Bachman (JPL) */
/* J.M. Lynch (JPL) */
/* $ Version */
/* - SPICELIB Version 3.0.0, 01-JUN-2010 (NJB) */
/* The check for non-unit quaternions has been replaced */
/* with a check for zero-length quaternions. */
/* - SPICELIB Version 2.2.0, 26-FEB-2008 (NJB) */
/* Updated header; added information about SPICE */
/* quaternion conventions. */
/* Minor typo in a long error message was corrected. */
/* - SPICELIB Version 2.1.0, 22-FEB-1999 (WLT) */
/* Added check to make sure that all quaternions are unit */
/* length to single precision. */
/* - SPICELIB Version 2.0.0, 28-DEC-1993 (WLT) */
/* The routine was upgraded to support non-inertial reference */
/* frames. */
/* - SPICELIB Version 1.1.1, 05-SEP-1993 (KRG) */
/* Removed all references to a specific method of opening the CK */
/* file in the $ Brief_I/O, $ Detailed_Input, $ Exceptions, */
/* $ Files, and $ Examples sections of the header. It is assumed */
/* that a person using this routine has some knowledge of the DAF */
/* system and the methods for obtaining file handles. */
/* - SPICELIB Version 1.1.0, 25-NOV-1992 (JML) */
/* If the number of pointing records is not positive an error */
/* is now signalled. */
/* FAILED is checked after the call to DAFBNA. */
/* The variable HLDCLK was removed from the loop where the times */
/* were checked. */
/* - 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, 30-AUG-1991 (JML) (NJB) */
/* -& */
/* $ Index_Entries */
/* write ck type_1 pointing data segment */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.1.1, 05-SEP-1993 (KRG) */
/* Removed all references to a specific method of opening the CK */
/* file in the $ Brief_I/O, $ Detailed_Input, $ Exceptions, */
/* $ Files, and $ Examples sections of the header. It is assumed */
/* that a person using this routine has some knowledge of the DAF */
/* system and the methods for obtaining file handles. */
/* - SPICELIB Version 1.1.0, 25-NOV-1992 (JML) */
/* If the number of pointing records is not positive an error */
/* is now signalled. */
/* FAILED is checked after the call to DAFBNA. */
/* The variable HLDCLK was removed from the loop where the times */
/* were checked. */
/* - 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, 30-AUG-1991 (JML) (NJB) */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* SIDLEN is the maximum number of characters allowed in a CK */
/* segment identifier. */
/* NDC is the size of a packed CK segment descriptor. */
/* ND is the number of double precision components in a CK */
/* segment descriptor. */
/* NI is the number of integer components in a CK segment */
/* descriptor. */
/* DTYPE is the data type of the segment that this routine */
/* operates on. */
/* FPRINT is the integer value of the first printable ASCII */
/* character. */
/* LPRINT is the integer value of the last printable ASCII */
/* character. */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
chkin_("CKW01", (ftnlen)5);
/* The first thing that we will do is create the segment descriptor. */
/* The structure of the segment descriptor is as follows. */
/* DCD( 1 ) and DCD( 2 ) -- SCLK limits of the segment. */
/* ICD( 1 ) -- Instrument code. */
/* ICD( 2 ) -- Reference frame ID. */
/* ICD( 3 ) -- Data type of the segment. */
/* ICD( 4 ) -- Angular rates flag. */
/* ICD( 5 ) -- Beginning address of segment. */
/* ICD( 6 ) -- Ending address of segment. */
/* Make sure that there is a positive number of pointing records. */
if (*nrec <= 0) {
setmsg_("# is an invalid number of pointing instances for type 1.", (
ftnlen)56);
errint_("#", nrec, (ftnlen)1);
sigerr_("SPICE(INVALIDNUMREC)", (ftnlen)20);
chkout_("CKW01", (ftnlen)5);
return 0;
}
/* Check that the SCLK bounds on the segment are reasonable. */
if (*begtim > sclkdp[0]) {
setmsg_("The first d.p. component of the descriptor is invalid. DCD("
"1) = # and SCLKDP(1) = # ", (ftnlen)84);
errdp_("#", begtim, (ftnlen)1);
errdp_("#", sclkdp, (ftnlen)1);
sigerr_("SPICE(INVALIDDESCRTIME)", (ftnlen)23);
chkout_("CKW01", (ftnlen)5);
return 0;
}
if (*endtim < sclkdp[*nrec - 1]) {
setmsg_("The second d.p. component of the descriptor is invalid. DCD"
"(2) = # and SCLKDP(NREC) = # ", (ftnlen)88);
errdp_("#", endtim, (ftnlen)1);
errdp_("#", &sclkdp[*nrec - 1], (ftnlen)1);
sigerr_("SPICE(INVALIDDESCRTIME)", (ftnlen)23);
chkout_("CKW01", (ftnlen)5);
return 0;
}
dcd[0] = *begtim;
dcd[1] = *endtim;
/* Get the NAIF integer code for the reference frame. */
namfrm_(ref, &refcod, ref_len);
if (refcod == 0) {
setmsg_("The reference frame # is not supported.", (ftnlen)39);
errch_("#", ref, (ftnlen)1, ref_len);
sigerr_("SPICE(INVALIDREFFRAME)", (ftnlen)22);
chkout_("CKW01", (ftnlen)5);
return 0;
}
/* Assign values to the integer components of the segment descriptor. */
icd[0] = *inst;
icd[1] = refcod;
icd[2] = 1;
if (*avflag) {
icd[3] = 1;
} else {
icd[3] = 0;
}
/* Now pack the segment descriptor. */
dafps_(&c__2, &c__6, dcd, icd, descr);
/* Check that all the characters in the segid can be printed. */
i__1 = lastnb_(segid, segid_len);
for (i__ = 1; i__ <= i__1; ++i__) {
value = *(unsigned char *)&segid[i__ - 1];
if (value < 32 || value > 126) {
setmsg_("The segment identifier contains nonprintable characters",
(ftnlen)55);
sigerr_("SPICE(NONPRINTABLECHARS)", (ftnlen)24);
chkout_("CKW01", (ftnlen)5);
return 0;
}
}
/* Also 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_("CKW01", (ftnlen)5);
return 0;
}
/* Now check that the encoded SCLK times are positive and strictly */
/* increasing. */
/* Check that the first time is nonnegative. */
if (sclkdp[0] < 0.) {
setmsg_("The first SCLKDP time: # is negative.", (ftnlen)37);
errdp_("#", sclkdp, (ftnlen)1);
sigerr_("SPICE(INVALIDSCLKTIME)", (ftnlen)22);
chkout_("CKW01", (ftnlen)5);
return 0;
}
/* Now check that the times are ordered properly. */
i__1 = *nrec;
for (i__ = 2; i__ <= i__1; ++i__) {
if (sclkdp[i__ - 1] <= sclkdp[i__ - 2]) {
setmsg_("The SCLKDP times are not strictly increasing. SCLKDP(#)"
" = # and SCLKDP(#) = #.", (ftnlen)78);
errint_("#", &i__, (ftnlen)1);
errdp_("#", &sclkdp[i__ - 1], (ftnlen)1);
i__2 = i__ - 1;
errint_("#", &i__2, (ftnlen)1);
errdp_("#", &sclkdp[i__ - 2], (ftnlen)1);
sigerr_("SPICE(TIMESOUTOFORDER)", (ftnlen)22);
chkout_("CKW01", (ftnlen)5);
return 0;
}
}
/* Make sure that the quaternions are non-zero. This is just */
/* a check for uninitialized data. */
i__1 = *nrec;
for (i__ = 1; i__ <= i__1; ++i__) {
if (vzerog_(&quats[(i__ << 2) - 4], &c__4)) {
setmsg_("The quaternion at index # has magnitude zero.", (ftnlen)
45);
errint_("#", &i__, (ftnlen)1);
sigerr_("SPICE(ZEROQUATERNION)", (ftnlen)21);
chkout_("CKW01", (ftnlen)5);
return 0;
}
}
/* No more checks, begin writing the segment. */
dafbna_(handle, descr, segid, segid_len);
if (failed_()) {
chkout_("CKW01", (ftnlen)5);
return 0;
}
/* Now add the quaternions and optionally, the angular velocity */
/* vectors. */
if (*avflag) {
i__1 = *nrec;
for (i__ = 1; i__ <= i__1; ++i__) {
dafada_(&quats[(i__ << 2) - 4], &c__4);
dafada_(&avvs[i__ * 3 - 3], &c__3);
}
} else {
i__1 = *nrec;
for (i__ = 1; i__ <= i__1; ++i__) {
dafada_(&quats[(i__ << 2) - 4], &c__4);
}
}
/* Add the SCLK times. */
dafada_(sclkdp, nrec);
/* The time tag directory. The Ith element is defined to be the */
/* average of the (I*100)th and the (I*100+1)st SCLK time. */
ndir = (*nrec - 1) / 100;
index = 100;
i__1 = ndir;
for (i__ = 1; i__ <= i__1; ++i__) {
dirent = (sclkdp[index - 1] + sclkdp[index]) / 2.;
dafada_(&dirent, &c__1);
index += 100;
}
/* Finally, the number of records. */
d__1 = (doublereal) (*nrec);
dafada_(&d__1, &c__1);
/* End the segment. */
dafena_();
chkout_("CKW01", (ftnlen)5);
return 0;
} /* ckw01_ */
/* $Procedure SIGDGT ( Retain significant digits ) */
/* Subroutine */ int sigdgt_(char *in, char *out, ftnlen in_len, ftnlen
out_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_indx(char *, char *, ftnlen, ftnlen), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Local variables */
extern integer cpos_(char *, char *, integer *, ftnlen, ftnlen);
integer zero, i__, j, k, l, begin;
char lchar[1];
extern integer lastnb_(char *, ftnlen), frstnb_(char *, ftnlen);
integer end;
/* $ Abstract */
/* Retain only the significant digits in a numeric string. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* CHARACTER, PARSING */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* IN I Input numeric string. */
/* OUT O Numeric string, with insignificant digits removed. */
/* $ Detailed_Input */
/* IN is a numeric string. */
/* $ Detailed_Output */
/* OUT is the same numeric string with insignificant */
/* zeros and spaces removed. The special case '.000...' */
/* becomes just '0'. OUT may overwrite IN. If the */
/* output string is too long, it is truncated on the */
/* right. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* There are only two interesting cases: */
/* 1) There is a decimal point and an exponent immediately */
/* preceded by zero ('...0E', '...0D', '...0e', '...0d') */
/* or by a space ('... E', '... D', '... e', '... d'). */
/* 2) There is a decimal point and no exponent, and the last non- */
/* blank character is a zero ('...0'). */
/* In each of these cases, go to the zero in question, and step */
/* backwards until you find something other than a blank or a zero. */
/* Finally, remove all leading spaces, and all occurrences of more */
/* than one consecutive space within the string. */
/* $ Examples */
/* The following examples illustrate the use of SIGDGT. */
/* '0.123456000000D-04' becomes '0.123456D-04' */
/* ' -9.2100000000000' '-9.21' */
/* ' 13' '13' */
/* ' 00013' '00013' */
/* ' .314 159 265 300 000 e1' '.314 159 265 3e1' */
/* ' 123 45 6' '123 45 6' */
/* ' .000000000' '0' */
/* $ Restrictions */
/* None. */
/* $ Exceptions */
/* Error free. */
/* If IN is a non-numeric string, the contents of OUT are */
/* unpredictable. */
/* $ Files */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) */
/* -& */
/* $ Index_Entries */
/* retain significant digits */
/* -& */
/* $ Revisions */
/* - Beta Version 1.3.0, 21-MAR-1989 (WLT) */
/* Previous fix was unbelievably bad, very buggy. This */
/* has been fixed along with other bugs and non-standard */
/* code has been removed. */
/* - Beta Version 1.2.0, 28-FEB-1989 (WLT) */
/* Reference to INSSUB replaced by SUFFIX */
/* - Beta Version 1.1.1, 17-FEB-1989 (HAN) (NJB) */
/* Declaration of the unused function ISRCHC removed. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Find the first and last non-blank characters in the string. */
/* Computing MAX */
i__1 = 1, i__2 = frstnb_(in, in_len);
begin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = lastnb_(in, in_len);
end = max(i__1,i__2);
*(unsigned char *)lchar = ' ';
/* Trivial case. */
if (begin == end) {
*(unsigned char *)out = *(unsigned char *)&in[begin - 1];
if (i_len(out, out_len) > 1) {
s_copy(out + 1, " ", out_len - 1, (ftnlen)1);
}
/* If there is no decimal point, all zeros are significant. */
} else if (i_indx(in, ".", in_len, (ftnlen)1) == 0) {
l = 1;
k = begin;
while(l <= i_len(out, out_len) && k <= end) {
*(unsigned char *)&out[l - 1] = *(unsigned char *)&in[k - 1];
/* Don't increment L if the last item copied was a space */
/* (we don't want to copy extra spaces). */
if (*(unsigned char *)&in[k - 1] != ' ' || *(unsigned char *)
lchar != ' ') {
++l;
}
*(unsigned char *)lchar = *(unsigned char *)&in[k - 1];
++k;
}
if (l <= i_len(out, out_len)) {
s_copy(out + (l - 1), " ", out_len - (l - 1), (ftnlen)1);
}
} else {
/* Is there is a decimal point and an exponent immediately */
/* preceded by zero ('...0E', '...0D', '...0e', '...0d') or */
/* by a space ('... E', '... D', '... e', '... d')? */
zero = i_indx(in, "0E", in_len, (ftnlen)2);
if (zero == 0) {
zero = i_indx(in, "0D", in_len, (ftnlen)2);
}
if (zero == 0) {
zero = i_indx(in, "0e", in_len, (ftnlen)2);
}
if (zero == 0) {
zero = i_indx(in, "0d", in_len, (ftnlen)2);
}
if (zero == 0) {
zero = i_indx(in, " E", in_len, (ftnlen)2);
}
if (zero == 0) {
zero = i_indx(in, " D", in_len, (ftnlen)2);
}
if (zero == 0) {
zero = i_indx(in, " e", in_len, (ftnlen)2);
}
if (zero == 0) {
zero = i_indx(in, " d", in_len, (ftnlen)2);
}
/* Begin there, and move toward the front of the string until */
/* something other than a blank or a zero is encountered. Then */
/* remove the superfluous characters. */
if (zero > 0) {
j = zero + 1;
i__ = zero;
while(*(unsigned char *)&in[i__ - 1] == '0' || *(unsigned char *)&
in[i__ - 1] == ' ') {
--i__;
}
l = 1;
k = begin;
while(l <= i_len(out, out_len) && k <= i__) {
*(unsigned char *)&out[l - 1] = *(unsigned char *)&in[k - 1];
/* Don't increment L if the last item copied was a space. */
if (*(unsigned char *)&in[k - 1] != ' ' || *(unsigned char *)
lchar != ' ') {
++l;
}
*(unsigned char *)lchar = *(unsigned char *)&in[k - 1];
++k;
}
k = j;
while(l <= i_len(out, out_len) && k <= end) {
*(unsigned char *)&out[l - 1] = *(unsigned char *)&in[k - 1];
/* Increment L only if we don't have two consecutive */
/* spaces. */
if (*(unsigned char *)&in[k - 1] != ' ' || *(unsigned char *)
lchar != ' ') {
++l;
}
*(unsigned char *)lchar = *(unsigned char *)&in[k - 1];
++k;
}
if (l <= i_len(out, out_len)) {
s_copy(out + (l - 1), " ", out_len - (l - 1), (ftnlen)1);
}
/* Is there is a decimal point and no exponent, and is the last */
/* non-blank character a zero ('...0')? Then truncate the string */
/* after the last character that is neither a blank nor a zero. */
} else if (*(unsigned char *)&in[end - 1] == '0' && cpos_(in, "EeDd",
&c__1, in_len, (ftnlen)4) == 0) {
i__ = end;
while(*(unsigned char *)&in[i__ - 1] == '0' || *(unsigned char *)&
in[i__ - 1] == ' ') {
--i__;
}
l = 1;
k = begin;
while(l <= i_len(out, out_len) && k <= i__) {
*(unsigned char *)&out[l - 1] = *(unsigned char *)&in[k - 1];
/* Increment L only if we don't have two consecutive */
/* spaces. */
if (*(unsigned char *)&in[k - 1] != ' ' || *(unsigned char *)
lchar != ' ') {
++l;
}
*(unsigned char *)lchar = *(unsigned char *)&in[k - 1];
++k;
}
if (l <= i_len(out, out_len)) {
s_copy(out + (l - 1), " ", out_len - (l - 1), (ftnlen)1);
}
} else {
l = 1;
k = begin;
while(l <= i_len(out, out_len) && k <= end) {
*(unsigned char *)&out[l - 1] = *(unsigned char *)&in[k - 1];
/* Increment L only if we don't have two consecutive spaces. */
if (*(unsigned char *)&in[k - 1] != ' ' || *(unsigned char *)
lchar != ' ') {
++l;
}
*(unsigned char *)lchar = *(unsigned char *)&in[k - 1];
++k;
}
if (l <= i_len(out, out_len)) {
s_copy(out + (l - 1), " ", out_len - (l - 1), (ftnlen)1);
}
}
}
/* Special case. The string '.0000....' reduces to '.' after the */
/* zeros are removed. */
if (s_cmp(out, ".", out_len, (ftnlen)1) == 0) {
s_copy(out, "0", out_len, (ftnlen)1);
}
return 0;
} /* sigdgt_ */
/* $Procedure REPMD ( Replace marker with double precision number ) */
/* Subroutine */ int repmd_(char *in, char *marker, doublereal *value,
integer *sigdig, char *out, ftnlen in_len, ftnlen marker_len, ftnlen
out_len)
{
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int zzrepsub_(char *, integer *, integer *, char *
, char *, ftnlen, ftnlen, ftnlen), dpstr_(doublereal *, integer *,
char *, ftnlen);
integer mrknbf, subnbf;
extern integer lastnb_(char *, ftnlen);
integer mrknbl, subnbl;
extern integer frstnb_(char *, ftnlen);
integer mrkpsb, mrkpse;
char substr[23];
/* $ Abstract */
/* Replace a marker with 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 */
/* None. */
/* $ Keywords */
/* CHARACTER */
/* CONVERSION */
/* STRING */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* IN I Input string. */
/* MARKER I Marker to be replaced. */
/* VALUE I Replacement value. */
/* SIGDIG I Significant digits in replacement text. */
/* OUT O Output string. */
/* MAXLDP P Maximum length of a DP number. */
/* $ Detailed_Input */
/* IN is an arbitrary character string. */
/* MARKER is an arbitrary character string. The first */
/* occurrence of MARKER in the input string is */
/* to be replaced by VALUE. */
/* Leading and trailing blanks in MARKER are NOT */
/* significant. In particular, no substitution is */
/* performed if MARKER is blank. */
/* VALUE is an arbitrary double precision number. */
/* SIGDIG is the number of significant digits with */
/* which VALUE is to be represented. SIGDIG */
/* must be greater than zero and less than 15. */
/* $ Detailed_Output */
/* OUT is the string obtained by substituting the text */
/* representation of VALUE for the first occurrence */
/* of MARKER in the input string. */
/* The text representation of VALUE is in scientific */
/* notation, having the number of significant digits */
/* specified by SIGDIG. The representation of VALUE */
/* is produced by the routine DPSTR; see that routine */
/* for details concerning the representation of */
/* double precision numbers. */
/* OUT and IN must be identical or disjoint. */
/* $ Parameters */
/* MAXLDP is the maximum expected length of the text */
/* representation of a double precision number. */
/* 23 characters are sufficient to hold any result */
/* returned by DPSTR. (See $Restrictions.) */
/* $ Exceptions */
/* Error Free. */
/* 1) If OUT does not have sufficient length to accommodate the */
/* result of the substitution, the result will be truncated on */
/* the right. */
/* 2) If MARKER is blank, or if MARKER is not a substring of IN, */
/* no substitution is performed. (OUT and IN are identical.) */
/* $ Files */
/* None. */
/* $ Particulars */
/* This is one of a family of related routines for inserting values */
/* into strings. They are typically to construct messages that */
/* are partly fixed, and partly determined at run time. For example, */
/* a message like */
/* 'Fifty-one pictures were found in directory [USER.DATA].' */
/* might be constructed from the fixed string */
/* '#1 pictures were found in directory #2.' */
/* by the calls */
/* CALL REPMCT ( STRING, '#1', N_PICS, 'C', STRING ) */
/* CALL REPMC ( STRING, '#2', DIR_NAME, STRING ) */
/* which substitute the cardinal text 'Fifty-one' and the character */
/* string '[USER.DATA]' for the markers '#1' and '#2' respectively. */
/* The complete list of routines is shown below. */
/* REPMC ( Replace marker with character string value ) */
/* REPMD ( Replace marker with double precision value ) */
/* REPMF ( Replace marker with formatted d.p. value ) */
/* REPMI ( Replace marker with integer value ) */
/* REPMCT ( Replace marker with cardinal text) */
/* REPMOT ( Replace marker with ordinal text ) */
/* $ Examples */
/* 1. Let */
/* IN = 'Invalid operation value. The value was #.' */
/* Then following the call, */
/* CALL REPMD ( IN, '#', 5.0D1, 2, IN ) */
/* IN is */
/* 'Invalid operation value. The value was 5.0E+01.' */
/* 2. Let */
/* IN = 'Left endpoint exceeded right endpoint. The left */
/* endpoint was: XX. The right endpoint was: XX.' */
/* Then following the call, */
/* CALL REPMD ( IN, ' XX ', -5.2D-9, 3, OUT ) */
/* OUT is */
/* 'Left endpoint exceeded right endpoint. The left */
/* endpoint was: -5.20E-09. The right endpoint was: XX.' */
/* 3. Let */
/* IN = 'Invalid operation value. The value was #.' */
/* Then following the call */
/* CALL REPMD ( IN, '#', 5.0D1, 100, IN ) */
/* IN is */
/* 'Invalid operation value. The value was */
/* 5.0000000000000E+01.' */
/* Note that even though 100 digits of precision were requested, */
/* only 14 were returned. */
/* 4. Let */
/* NUM = 23 */
/* CHANCE = 'fair' */
/* SCORE = 4.665D0 */
/* Then following the sequence of calls, */
/* CALL REPMI ( 'There are & routines that have a ' // */
/* . '& chance of meeting your needs.' // */
/* . 'The maximum score was &.', */
/* . '&', */
/* . NUM, */
/* . MSG ) */
/* CALL REPMC ( MSG, '&', CHANCE, MSG ) */
/* CALL REPMD ( MSG, '&', SCORE, 4, MSG ) */
/* MSG is */
/* 'There are 23 routines that have a fair chance of */
/* meeting your needs. The maximum score was 4.665E+00.' */
/* $ Restrictions */
/* 1) The maximum number of significant digits returned is 14. */
/* 2) This routine makes explicit use of the format of the string */
/* returned by DPSTR; should that routine change, substantial */
/* work may be required to bring this routine back up to snuff. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* B.V. Semenov (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.2.0, 23-SEP-2013 (BVS) */
/* Minor efficiency update: the routine now looks up the first */
/* and last non-blank characters only once. */
/* - SPICELIB Version 1.1.0, 15-AUG-2002 (WLT) */
/* The routine is now error free. */
/* - 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, 30-AUG-1990 (NJB) (IMU) */
/* -& */
/* $ Index_Entries */
/* replace marker with d.p. number */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* If MARKER is blank, no substitution is possible. */
if (s_cmp(marker, " ", marker_len, (ftnlen)1) == 0) {
s_copy(out, in, out_len, in_len);
return 0;
}
/* Locate the leftmost occurrence of MARKER, if there is one */
/* (ignoring leading and trailing blanks). If MARKER is not */
/* a substring of IN, no substitution can be performed. */
mrknbf = frstnb_(marker, marker_len);
mrknbl = lastnb_(marker, marker_len);
mrkpsb = i_indx(in, marker + (mrknbf - 1), in_len, mrknbl - (mrknbf - 1));
if (mrkpsb == 0) {
s_copy(out, in, out_len, in_len);
return 0;
}
mrkpse = mrkpsb + mrknbl - mrknbf;
/* Okay, MARKER is non-blank and has been found. Convert the */
/* number to text, and substitute the text for the marker. */
dpstr_(value, sigdig, substr, (ftnlen)23);
subnbf = frstnb_(substr, (ftnlen)23);
subnbl = lastnb_(substr, (ftnlen)23);
if (subnbf != 0 && subnbl != 0) {
zzrepsub_(in, &mrkpsb, &mrkpse, substr + (subnbf - 1), out, in_len,
subnbl - (subnbf - 1), out_len);
}
return 0;
} /* repmd_ */
/* $Procedure OUTMSG ( Output Error Messages ) */
/* Subroutine */ int outmsg_(char *list, ftnlen list_len)
{
/* Initialized data */
static char defmsg[80*4] = "Oh, by the way: The SPICELIB error handling"
" actions are USER-TAILORABLE. You " "can choose whether the To"
"olkit aborts or continues when errors occur, which " "error "
"messages to output, and where to send the output. Please read t"
"he ERROR " "\"Required Reading\" file, or see the routines ERRA"
"CT, ERRDEV, and ERRPRT. ";
static logical first = TRUE_;
/* System generated locals */
address a__1[2], a__2[3];
integer i__1, i__2, i__3[2], i__4[3];
char ch__1[38];
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen),
s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char name__[32], line[80];
logical long__;
char lmsg[1840];
logical expl;
char smsg[25], xmsg[80];
integer i__;
logical trace;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
integer depth, index;
extern integer wdcnt_(char *, ftnlen);
extern /* Subroutine */ int expln_(char *, char *, ftnlen, ftnlen);
extern integer rtrim_(char *, ftnlen);
char versn[80], words[9*5];
integer start;
logical short__;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
char device[255];
integer remain;
static char border[80];
extern /* Subroutine */ int getdev_(char *, ftnlen);
logical dfault;
integer length;
extern /* Subroutine */ int trcdep_(integer *);
extern integer lastnb_(char *, ftnlen);
extern /* Subroutine */ int trcnam_(integer *, char *, ftnlen), lparse_(
char *, char *, integer *, integer *, char *, ftnlen, ftnlen,
ftnlen);
extern logical msgsel_(char *, ftnlen);
integer wrdlen;
extern /* Subroutine */ int getlms_(char *, ftnlen), wrline_(char *, char
*, ftnlen, ftnlen), getsms_(char *, ftnlen), suffix_(char *,
integer *, char *, ftnlen, ftnlen);
char tmpmsg[105];
extern /* Subroutine */ int nextwd_(char *, char *, char *, ftnlen,
ftnlen, ftnlen);
integer numwrd;
char upword[9], outwrd[1840];
extern /* Subroutine */ int tkvrsn_(char *, char *, ftnlen, ftnlen);
logical output;
/* $ Abstract */
/* Output error messages. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* ERROR */
/* $ Keywords */
/* ERROR */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include File: SPICELIB Error Handling Parameters */
/* errhnd.inc Version 2 18-JUN-1997 (WLT) */
/* The size of the long error message was */
/* reduced from 25*80 to 23*80 so that it */
/* will be accepted by the Microsoft Power Station */
/* FORTRAN compiler which has an upper bound */
/* of 1900 for the length of a character string. */
/* errhnd.inc Version 1 29-JUL-1997 (NJB) */
/* Maximum length of the long error message: */
/* Maximum length of the short error message: */
/* End Include File: SPICELIB Error Handling Parameters */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* LIST I A list of error message types. */
/* FILEN P Maximum length of file name. */
/* NAMLEN P Maximum length of module name. See TRCPKG. */
/* LL P Output line length. */
/* $ Detailed_Input */
/* LIST is a list of error message types. A list is a */
/* character string containing one or more words */
/* from the following list, separated by commas. */
/* SHORT */
/* EXPLAIN */
/* LONG */
/* TRACEBACK */
/* DEFAULT */
/* Each type of error message specified in LIST will */
/* be output when an error is detected, if it is */
/* enabled for output. Note that DEFAULT does */
/* NOT refer to the "default message selection," */
/* but rather to a special message that is output */
/* when the error action is 'DEFAULT'. This message */
/* is a statement referring the user to the error */
/* handling documentation. */
/* Messages are never duplicated in the output; for */
/* instance, supplying a value of LIST such as */
/* 'SHORT, SHORT' */
/* does NOT result in the output of two short */
/* messages. */
/* The words in LIST may appear in mixed case; */
/* for example, the call */
/* CALL OUTMSG ( 'ShOrT' ) */
/* will work. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* FILEN is the maximum device name length that can be */
/* accommodated by this routine. */
/* NAMELN is the maximum length of an individual module name. */
/* LL is the maximum line length for the output message. */
/* If the output message string is very long, it is */
/* displayed over several lines, each of which has a */
/* maximum length of LL characters. */
/* $ Exceptions */
/* 1) This routine detects invalid message types in the argument, */
/* LIST. The short error message in this case is */
/* 'SPICE(INVALIDLISTITEM)' */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine is part of the SPICELIB error handling */
/* mechanism. */
/* This routine outputs the error messages specified in LIST that */
/* have been enabled for output (use the SPICELIB routine ERRPRT */
/* to enable or disable output of specified types of error */
/* messages). A border is written out preceding and following the */
/* messages. Output is directed to the current error output device. */
/* $ Examples */
/* 1) Output the short and long error messages: */
/* C */
/* C Output short and long messages: */
/* C */
/* CALL OUTMSG ( 'SHORT, LONG' ) */
/* $ Restrictions */
/* 1) This routine is intended for use by the SPICELIB error */
/* handling mechanism. SPICELIB users are not expected to */
/* need to call this routine. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* K.R. Gehringer (JPL) */
/* H.A. Neilan (JPL) */
/* M.J. Spencer (JPL) */
/* $ Version */
/* - SPICELIB Version 5.27.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 5.26.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 5.25.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 5.24.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 5.23.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 5.22.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 5.21.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 5.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 5.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 5.18.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 5.17.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 5.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 5.15.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 5.14.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 5.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 5.12.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 5.11.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 5.10.0, 01-MAR-2009 (NJB) */
/* Bug fix: truncation of long words in */
/* output has been corrected. Local parameter */
/* TMPLEN was added and is used in declaration */
/* of TMPMSG. */
/* - SPICELIB Version 5.9.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 5.8.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 5.7.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 5.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 5.5.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 5.4.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 5.3.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 5.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 5.1.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 5.1.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 5.1.3, 24-SEP-1999 (NJB) */
/* CSPICE environments were added. Some typos were corrected. */
/* - SPICELIB Version 5.1.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 5.1.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 5.1.0, 13-JAN-1999 (BVS) */
/* ``errhnd.inc'' file was included. Long and short error */
/* message lengths parameter declarations were deleted. Long */
/* and short error message string sizes were changed to those */
/* declared in ``errhnd.inc''. */
/* - SPICELIB Version 5.0.0, 08-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 4.0.0, 09-MAY-1996 (KRG) */
/* Added the toolkit version to the output error message. */
/* Updated this routine to be consistent with the trace package */
/* revisions. This primarily affects the creation of the */
/* traceback string. */
/* Long error messages are now wrapped on word boundaries when */
/* they are longer than the output line length. Note that this */
/* only happens for long error messages obtained from GETLMS, */
/* and not for the error messages displayed by this subroutine */
/* and other error handling subroutines that write their own */
/* error messages. */
/* - SPICELIB Version 3.0.0, 09-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* for the Silicon Graphics, DEC Alpha-OSF/1, and */
/* NeXT platforms. Also, the previous value of 256 for */
/* Unix platforms was changed to 255. */
/* - SPICELIB Version 2.2.0, 12-OCT-1992 (HAN) */
/* Updated module for multiple environments. Moved the parameter */
/* LL to the Declarations section of the header since it's */
/* environment dependent. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 2.1.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 2.1.0, 15-MAY-1991 (MJS) */
/* Module was updated to include the value of LL for the */
/* Macintosh. */
/* - SPICELIB Version 2.0.0, 28-MAR-1991 (NJB) */
/* Work-around for MS Fortran compiler error under DOS 3.10 */
/* was made. Some substring bounds were simplified using RTRIM. */
/* Updates were made to the header to clarify the text and */
/* improve the header's appearance. The default error message */
/* was slightly de-uglified. */
/* The IBM PC version of this routine now uses an output line */
/* length of 78 characters rather than 80. This prevents */
/* wrapping of the message borders and default error message. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (NJB) */
/* -& */
/* $ Index_Entries */
/* None. */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 5.1.0, 13-JAN-1999 (BVS) */
/* ``errhnd.inc'' file was included. Long and short error */
/* message lengths parameter declarations were deleted. Long */
/* and short error message string size were changed to those */
/* declared in ``errhnd.inc''. */
/* - SPICELIB Version 5.0.0, 08-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 4.0.0, 09-MAY-1996 (KRG) */
/* Added the toolkit version to the output error message. */
/* Updated this routine to be consistent with the trace package */
/* revisions. This primarily affects the creation of the */
/* traceback string. */
/* Long error messages are now wrapped on word boundaries when */
/* they are longer than the output line length. Note that this */
/* only happens for long error messages obtained from GETLMS, */
/* and not for the error messages displayed by this subroutine */
/* and other error handling subroutines that write their own */
/* error messages. */
/* - SPICELIB Version 3.0.0, 9-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* for the Silicon Graphics, DEC Alpha-OSF/1, and */
/* NeXT platforms. Also, the previous value of 256 for */
/* Unix platforms was changed to 255. */
/* - SPICELIB Version 2.2.0, 12-OCT-1992 (HAN) */
/* Updated module for multiple environments. Moved the */
/* parameter LL to the Declarations section of the header since */
/* it's environment dependent. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 2.1.0, 15-MAY-1991 (MJS) */
/* Module was updated to include the value of LL for the */
/* Macintosh. */
/* - SPICELIB Version 2.0.0, 28-MAR-1991 (NJB) */
/* 1) Work-around for MS Fortran compiler error under DOS 3.10 */
/* was made. The compiler did not correctly handle code that */
/* concatenated strings whose bounds involved the intrinsic */
/* MAX function. */
/* 2) Some substring bounds were simplified using RTRIM. */
/* 3) Updates were made to the header to clarify the text and */
/* improve the header's appearance. */
/* 4) Declarations were re-organized. */
/* 5) The default error message was slightly de-uglified. */
/* 6) The IBM PC version of this routine now uses an output line */
/* length of 78 characters rather than 80. This prevents */
/* wrapping of the message borders and default error message. */
/* - Beta Version 1.3.0, 19-JUL-1989 (NJB) */
/* Calls to REMSUB removed; blanking and left-justifying used */
/* instead. This was done because REMSUB handles substring */
/* bounds differently than in previous versions, and no longer */
/* handles all possible inputs as required by this routine. */
/* LJUST, which is used now, is error free. */
/* Also, an instance of .LT. was changed to .LE. The old code */
/* caused a line break one character too soon. A minor bug, but */
/* a bug nonetheless. */
/* Also, two substring bounds were changed to ensure that they */
/* remain greater than zero. */
/* - Beta Version 1.2.0, 16-FEB-1989 (NJB) */
/* Warnings added to discourage use of this routine in */
/* non-error-handling code. Parameters section updated to */
/* describe FILEN and NAMLEN. */
/* Declaration of unused function FAILED removed. */
/* - Beta Version 1.1.0, 06-OCT-1988 (NJB) */
/* Test added to ensure substring upper bound is greater than 0. */
/* REMAIN must be greater than 0 when used as the upper bound */
/* for a substring of NAME. Also, substring upper bound in */
/* WRLINE call is now forced to be greater than 0. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* These parameters are system-independent. */
/* Local variables */
/* Saved variables */
/* Initial Values: */
/* Executable Code: */
/* The first time through, set up the output borders. */
if (first) {
first = FALSE_;
for (i__ = 1; i__ <= 80; ++i__) {
*(unsigned char *)&border[i__ - 1] = '=';
}
}
/* No messages are to be output which are not specified */
/* in LIST: */
short__ = FALSE_;
expl = FALSE_;
long__ = FALSE_;
trace = FALSE_;
dfault = FALSE_;
/* We parse the list of message types, and set local flags */
/* indicating which ones are to be output. If we find */
/* a word we don't recognize in the list, we signal an error */
/* and continue parsing the list. */
lparse_(list, ",", &c__5, &numwrd, words, list_len, (ftnlen)1, (ftnlen)9);
i__1 = numwrd;
for (i__ = 1; i__ <= i__1; ++i__) {
ucase_(words + ((i__2 = i__ - 1) < 5 && 0 <= i__2 ? i__2 : s_rnge(
"words", i__2, "outmsg_", (ftnlen)613)) * 9, upword, (ftnlen)
9, (ftnlen)9);
if (s_cmp(upword, "SHORT", (ftnlen)9, (ftnlen)5) == 0) {
short__ = TRUE_;
} else if (s_cmp(upword, "EXPLAIN", (ftnlen)9, (ftnlen)7) == 0) {
expl = TRUE_;
} else if (s_cmp(upword, "LONG", (ftnlen)9, (ftnlen)4) == 0) {
long__ = TRUE_;
} else if (s_cmp(upword, "TRACEBACK", (ftnlen)9, (ftnlen)9) == 0) {
trace = TRUE_;
} else if (s_cmp(upword, "DEFAULT", (ftnlen)9, (ftnlen)7) == 0) {
dfault = TRUE_;
} else {
/* Unrecognized word! This is an error... */
/* We have a special case on our hands; this routine */
/* is itself called by SIGERR, so a recursion error will */
/* result if this routine calls SIGERR. So we output */
/* the error message directly: */
getdev_(device, (ftnlen)255);
wrline_(device, "SPICE(INVALIDLISTITEM)", (ftnlen)255, (ftnlen)22)
;
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
wrline_(device, "OUTMSG: An invalid message type was specified "
"in the type list. ", (ftnlen)255, (ftnlen)65);
/* Writing concatenation */
i__3[0] = 29, a__1[0] = "The invalid message type was ";
i__3[1] = 9, a__1[1] = words + ((i__2 = i__ - 1) < 5 && 0 <= i__2
? i__2 : s_rnge("words", i__2, "outmsg_", (ftnlen)650)) *
9;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)38);
wrline_(device, ch__1, (ftnlen)255, (ftnlen)38);
}
}
/* LIST has been parsed. */
/* Now, we output those error messages that were specified by LIST */
/* and which belong to the set of messages selected for output. */
/* We get the default error output device: */
getdev_(device, (ftnlen)255);
output = short__ && msgsel_("SHORT", (ftnlen)5) || expl && msgsel_("EXPL"
"AIN", (ftnlen)7) || long__ && msgsel_("LONG", (ftnlen)4) || trace
&& msgsel_("TRACEBACK", (ftnlen)9) || dfault && msgsel_("DEFAULT",
(ftnlen)7) && s_cmp(device, "NULL", (ftnlen)255, (ftnlen)4) != 0;
/* We go ahead and output those messages that have been specified */
/* in the list and also are enabled for output. The order of the */
/* cases below IS significant; the order in which the messages */
/* appear in the output depends on it. */
/* If there's nothing to output, we can leave now. */
if (! output) {
return 0;
}
/* Write the starting border: skip a line, write the border, */
/* skip a line. */
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
wrline_(device, border, (ftnlen)255, (ftnlen)80);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
/* Output the toolkit version and skip a line. */
tkvrsn_("TOOLKIT", versn, (ftnlen)7, (ftnlen)80);
/* Writing concatenation */
i__3[0] = 17, a__1[0] = "Toolkit version: ";
i__3[1] = 80, a__1[1] = versn;
s_cat(line, a__1, i__3, &c__2, (ftnlen)80);
wrline_(device, line, (ftnlen)255, (ftnlen)80);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
/* Next, we output the messages specified in the list */
/* that have been enabled. */
/* We start with the short message and its accompanying */
/* explanation. If both are to be output, they are */
/* concatenated into a single message. */
if (short__ && msgsel_("SHORT", (ftnlen)5) && (expl && msgsel_("EXPLAIN",
(ftnlen)7))) {
/* Extract the short message from global storage; then get */
/* the corresponding explanation. */
getsms_(smsg, (ftnlen)25);
expln_(smsg, xmsg, (ftnlen)25, (ftnlen)80);
/* Writing concatenation */
i__4[0] = rtrim_(smsg, (ftnlen)25), a__2[0] = smsg;
i__4[1] = 4, a__2[1] = " -- ";
i__4[2] = 80, a__2[2] = xmsg;
s_cat(tmpmsg, a__2, i__4, &c__3, (ftnlen)105);
wrline_(device, tmpmsg, (ftnlen)255, (ftnlen)105);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
} else if (short__ && msgsel_("SHORT", (ftnlen)5)) {
/* Output the short error message without the explanation. */
getsms_(smsg, (ftnlen)25);
wrline_(device, smsg, (ftnlen)255, (ftnlen)25);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
} else if (expl && msgsel_("EXPLAIN", (ftnlen)7)) {
/* Obtain the explanatory text for the short error */
/* message and output it: */
getsms_(smsg, (ftnlen)25);
expln_(smsg, xmsg, (ftnlen)25, (ftnlen)80);
wrline_(device, xmsg, (ftnlen)255, (ftnlen)80);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
if (long__ && msgsel_("LONG", (ftnlen)4)) {
/* Extract the long message from global storage and */
/* output it: */
getlms_(lmsg, (ftnlen)1840);
/* Get the number of words in the error message. */
numwrd = wdcnt_(lmsg, (ftnlen)1840);
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
start = 1;
/* Format the words into output lines and display them as */
/* needed. */
i__1 = numwrd;
for (i__ = 1; i__ <= i__1; ++i__) {
nextwd_(lmsg, outwrd, lmsg, (ftnlen)1840, (ftnlen)1840, (ftnlen)
1840);
wrdlen = rtrim_(outwrd, (ftnlen)1840);
if (start + wrdlen <= 80) {
s_copy(line + (start - 1), outwrd, 80 - (start - 1), (ftnlen)
1840);
start = start + wrdlen + 1;
} else {
if (wrdlen <= 80) {
/* We had a short word, so just write the line and */
/* continue. */
wrline_(device, line, (ftnlen)255, (ftnlen)80);
start = wrdlen + 2;
s_copy(line, outwrd, (ftnlen)80, (ftnlen)1840);
} else {
/* We got a very long word here, so we break it up and */
/* write it out. We fit as much of it as we an into line */
/* as possible before writing it. */
/* Get the remaining space. If START is > 1 we have at */
/* least one word already in the line, including it's */
/* trailing space, otherwise the line is blank. If line */
/* is empty, we have all of the space available. */
if (start > 1) {
remain = 80 - start;
} else {
remain = 80;
}
/* Now we stuff bits of the word into the output line */
/* until we're done, i.e., until we have a word part */
/* that is less than the output length. First, we */
/* check to see if there is a "significant" amount of */
/* room left in the current output line. If not, we */
/* write it and then begin stuffing the long word into */
/* output lines. */
if (remain < 10) {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
remain = 80;
start = 1;
}
/* Stuff the word a chunk at a time into output lines */
/* and write them. After writing a line, we clear the */
/* part of the long word that we just wrote, left */
/* justifying the remaining part before proceeding. */
while(wrdlen > 80) {
s_copy(line + (start - 1), outwrd, 80 - (start - 1),
remain);
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(outwrd, " ", remain, (ftnlen)1);
ljust_(outwrd, outwrd, (ftnlen)1840, (ftnlen)1840);
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
wrdlen -= remain;
remain = 80;
start = 1;
}
/* If we had a part of the long word left, get set up to */
/* append more words from the error message to the output */
/* line. If we finished the word, WRDLEN .EQ. 0, then */
/* START and LINE have already been initialized. */
if (wrdlen > 0) {
start = wrdlen + 2;
s_copy(line, outwrd, (ftnlen)80, (ftnlen)1840);
}
}
}
}
/* We may need to write the remaining part of a line. */
if (s_cmp(line, " ", (ftnlen)80, (ftnlen)1) != 0) {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
}
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
if (trace && msgsel_("TRACEBACK", (ftnlen)9)) {
/* Extract the traceback from global storage and */
/* output it: */
trcdep_(&depth);
if (depth > 0) {
/* We know we'll be outputting some trace information. */
/* So, write a line telling the reader what's coming. */
wrline_(device, "A traceback follows. The name of the highest l"
"evel module is first.", (ftnlen)255, (ftnlen)68);
/* While there are more names in the traceback */
/* representation, we stuff them into output lines and */
/* write the lines out when they are full. */
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
remain = 80;
i__1 = depth;
for (index = 1; index <= i__1; ++index) {
/* For each module name in the traceback representation, */
/* retrieve module name and stuff it into one or more */
/* lines for output. */
/* Get a name and add the call order sign. We */
/* indicate calling order by a ' --> ' delimiter; e.g. */
/* "A calls B" is indicated by 'A --> B'. */
trcnam_(&index, name__, (ftnlen)32);
length = lastnb_(name__, (ftnlen)32);
/* If it's the first name, just put it into the output */
/* line, otherwise, add the call order sign and put the */
/* name into the output line. */
if (index == 1) {
suffix_(name__, &c__0, line, (ftnlen)32, (ftnlen)80);
remain -= length;
} else {
/* Add the calling order indicator, if it will fit. */
/* If not, write the line and put the indicator as */
/* the first thing on the next line. */
if (remain >= 4) {
suffix_("-->", &c__1, line, (ftnlen)3, (ftnlen)80);
remain += -4;
} else {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(line, "-->", (ftnlen)80, (ftnlen)3);
remain = 77;
}
/* The name fits or it doesn't. If it does, just add */
/* it, if it doesn't, write it, then make the name */
/* the first thing on the next line. */
if (remain >= length) {
suffix_(name__, &c__1, line, (ftnlen)32, (ftnlen)80);
remain = remain - length - 1;
} else {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(line, name__, (ftnlen)80, (ftnlen)32);
remain = 80 - length;
}
}
}
/* At this point, no more names are left in the */
/* trace representation. LINE may still contain */
/* names, or part of a long name. If it does, */
/* we now write it out. */
if (s_cmp(line, " ", (ftnlen)80, (ftnlen)1) != 0) {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
}
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
/* At this point, either we have output the trace */
/* representation, or the trace representation was */
/* empty. */
}
if (dfault && msgsel_("DEFAULT", (ftnlen)7)) {
/* Output the default message: */
for (i__ = 1; i__ <= 4; ++i__) {
wrline_(device, defmsg + ((i__1 = i__ - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("defmsg", i__1, "outmsg_", (ftnlen)971)) *
80, (ftnlen)255, (ftnlen)80);
}
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
/* At this point, we've output all of the enabled messages */
/* that were specified in LIST. At least one message that */
/* was specified was enabled. */
/* Write the ending border out: */
wrline_(device, border, (ftnlen)255, (ftnlen)80);
return 0;
} /* outmsg_ */
/* $Procedure 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_ */
/* $Procedure ZZRVAR ( Private --- Pool, read the next kernel variable ) */
/* Subroutine */ int zzrvar_(integer *namlst, integer *nmpool, char *names,
integer *datlst, integer *dppool, doublereal *dpvals, integer *chpool,
char *chvals, char *varnam, logical *eof, ftnlen names_len, ftnlen
chvals_len, ftnlen varnam_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen), s_rnge(char *, integer, char *, integer),
s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer head, code, itab;
static char name__[132], file[255];
static integer free, begs[132], node;
static char line[132];
static integer tail, ends[132];
static logical even, full;
static integer type__[132], b, e, i__, j, badat;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen), lnkan_(integer *, integer *);
static logical found;
static integer ncomp, lstnb, count;
static char error[255];
static integer iplus;
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int zzcln_(integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer r1, r2;
extern logical failed_(void);
static integer at, datahd, iblank, chnode, icomma, nameat, dpnode;
extern /* Subroutine */ int rdkdat_(char *, logical *, ftnlen), lnkila_(
integer *, integer *, integer *);
static integer iequal;
extern integer lastnb_(char *, ftnlen), lastpc_(char *, ftnlen), lnknfn_(
integer *);
static integer ilparn, irparn, itmark;
static doublereal dvalue;
static integer dirctv, lookat, iquote;
extern integer zzhash_(char *, ftnlen);
static integer number, varlen;
static logical intokn, insepf;
extern logical return_(void);
static logical inquot;
static integer status, vartyp;
extern /* Subroutine */ int chkout_(char *, ftnlen);
static integer nxttok;
extern /* Subroutine */ int rdklin_(char *, integer *, ftnlen), setmsg_(
char *, ftnlen), errint_(char *, integer *, ftnlen), sigerr_(char
*, ftnlen), lnkfsl_(integer *, integer *, integer *), tparse_(
char *, doublereal *, char *, ftnlen, ftnlen), nparsd_(char *,
doublereal *, char *, integer *, 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. */
/* Read the next variable from a SPICE ASCII kernel file into */
/* the kernel pool. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* PRIVATE KERNEL */
/* $ Keywords */
/* FILES */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* NAMLST I/O array of collision resolution list heads. */
/* NMPOOL I/O linked list pool of collision resolution lists. */
/* NAMES I/O array of names of kernel pool variables. */
/* DATLST I/O array of heads of lists of variable values. */
/* DPPOOL I/O linked list pool of pointer lists to d.p. values. */
/* DPVALS I/O array of d.p. kernel pool values. */
/* CHPOOL I/O linked list pool of pointer lists to string values. */
/* CHVALS I/O array of string kernel pool values. */
/* VARNAM O name of variable parsed. */
/* EOF O if TRUE end of input file has been reached. */
/* $ Detailed_Input */
/* NAMLST this collection of arrays together with the hash */
/* NMPOOL function ZZHASH provide the mechanism for storing */
/* NAMES and retrieving kernel pool variables. */
/* DATLST */
/* DPPOOL Given a potential variable name NAME the function */
/* DPVALS ZZHASH(NAME) gives the location in the array in */
/* CHPOOL NAMLST where one should begin looking for the */
/* CHVALS kernel pool variable NAME. */
/* If NAMLST( ZZHASH(NAME) ) is zero, there is no kernel */
/* pool variable corresponding to NAME. If it is non-zero */
/* then NAMLST is the head node of a linked list of names */
/* that evaluate to the same integer under the function */
/* ZZHASH. Letting NODE = NAMLST( ZZHASH(NAME) ) check */
/* NAMES(NODE) for equality with NAME. If there is */
/* no match find the next node ( NMPOOL(NEXT,NODE) ) until */
/* a match occurs or all nodes of the list have been */
/* examined. To insert a new NAME allocate a node NEW from */
/* the free list of NMPOOL and append it to the tail of the */
/* list pointed to by NAMLST ( ZZHASH(NAME) ). */
/* Once a node for NAME is located (call it NAMEAT) */
/* the values for NAME can be found by examining */
/* DATLST(NAMEAT). If zero, no values have yet been */
/* given to NAME. If less than zero, -DATLST(NAMEAT) */
/* is the head node of a list in CHPOOL that gives the */
/* indexes of the values of NAME in CHVALS. If greater */
/* than zero, DATLST(NAMEAT) is the head node of a list */
/* in DPPOOL that gives the indexes of the values of NAME */
/* in DPVALS. */
/* $ Detailed_Output */
/* NAMLST is the same structure as input but updated to */
/* NMPOOL include the next variable read from the current */
/* NAMES active text kernel in RDKER. */
/* DATLST */
/* DPPOOL */
/* DPVALS */
/* CHPOOL */
/* CHVALS */
/* VARNAM is the name of the variable. VARNAM is blank if */
/* no variable is read. */
/* EOF is true when the end of the kernel file has been */
/* reached, and is false otherwise. The kernel file */
/* is closed automatically when the end of the file */
/* is reached. */
/* $ Parameters */
/* LINLEN is the maximum length of a line in the kernel file. */
/* MAXLEN is the maximum length of the variable names that */
/* can be stored in the kernel pool (also set in */
/* pool.f). */
/* $ Exceptions */
/* 1) The error 'SPICE(BADTIMESPEC)' is signaled if a value */
/* beginning with '@' cannot be parsed as a time. */
/* 2) The error 'SPICE(BADVARASSIGN)' is signaled if variable */
/* assignment does not have the form NAME = [(] value [ value ) ]. */
/* 3) The error 'SPICE(KERNELPOOLFULL)' is signaled if there is */
/* no room left in the kernel pool to store another variable */
/* or value. */
/* 4) The error 'SPICE(NONPRINTINGCHAR)' is signaled if the name */
/* in a variable assignment contains a non-printing character. */
/* 5) The error 'SPICE(NUMBEREXPECTED)' is signaled if a value */
/* that is unquoted cannot be parsed as time or number. */
/* 6) The error 'SPICE(TYPEMISMATCH)' is signalled if a variable */
/* has a first value of one type (numeric or character) and */
/* a subsequent component has the other type. */
/* 7) The error 'SPICE(BADVARNAME)' signals if a kernel pool */
/* variable name length exceeds MAXLEN. */
/* $ Files */
/* ZZRVAR reads from the file most recently opened by RDKNEW. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* See POOL (entry point LDPOOL). */
/* $ Restrictions */
/* The input file must be opened and initialized by RDKNEW prior */
/* to the first call to ZZRVAR. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 1.7.0, 08-FEB-2010 (EDW) */
/* Added an error check on the length of the kernel pool variable */
/* name read from the kernel file. */
/* - SPICELIB Version 1.6.0, 06-AUG-2002 (BVS) */
/* Modified to make sure that DO WHILE loop that looks for the */
/* end of string variable value always exits. */
/* - SPICELIB Version 1.5.0, 07-APR-2000 (WLT) */
/* Happy Birthday Alex. Added check to the assignment to CHVALS */
/* so that we cannot store data past the end of the string. */
/* - SPICELIB Version 1.4.0, 22-MAR-1999 (WLT) */
/* Added code to detect and signal an error for empty */
/* vector assignment. */
/* - SPICELIB Version 1.3.0, 16-JAN-1997 (WLT) */
/* The error message regarding the directives allowed */
/* in a keyword = value directive was updated. */
/* - SPICELIB Version 1.1.0, 25-JUN-1996 (WLT) */
/* The error message for unparsed numeric components */
/* was corrected so that it now shows the line and */
/* line number on which the error occurred. */
/* - SPICELIB Version 1.0.0, 20-SEP-1995 (WLT) */
/* -& */
/* SPICELIB functions */
/* Local parameters. */
/* Below are a collection of enumerated lists that are used */
/* to discern what part of the processing we are in and what */
/* kind of entity we are dealing with. First the overall */
/* processing flow of a variable assignment. */
/* Next we have the various types of tokens that can be found */
/* in the parsing of an input line */
/* Q --- quoted (or protected tokens) */
/* NQ --- unquoted tokens */
/* BV --- beginning of a vector */
/* EV --- ending of a vector */
/* EQ --- equal sign */
/* EQP --- equal sign plus */
/* A variable can have one of three types as we process */
/* it. It can have an unknown type UNKNWN, STRTYP or NUMTYP. */
/* The next two parameters indicate which component of a linked */
/* list node point to the previous node and the next node. */
/* The next collection of variables are set up in first pass */
/* through this routine. They would be parameters if FORTRAN */
/* allowed us to do this in a standard way. */
/* The logicals below are used to take apart the tokens in an */
/* input line. */
/* The following logicals are in-line functions that are used */
/* when processing the input strings. */
/* Save everything. */
/* Below are a collection of In-line function definitions that are */
/* intended to make the code a bit easier to write and read. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZRVAR", (ftnlen)6);
}
/* Initializations. */
if (first) {
first = FALSE_;
icomma = ',';
iblank = ' ';
iquote = '\'';
ilparn = '(';
irparn = ')';
iequal = '=';
iplus = '+';
itmark = '@';
itab = 9;
}
/* No variable yet and no parsing errors so far. */
s_copy(name__, " ", (ftnlen)132, (ftnlen)1);
s_copy(error, " ", (ftnlen)255, (ftnlen)1);
ncomp = 0;
/* Get the next data line. Unless something is terribly wrong, */
/* this will begin a new variable definition. We have to read */
/* the whole variable, unless we get an error, in which case */
/* we can quit. */
status = 1;
while(status != 2 && ! failed_()) {
rdkdat_(line, eof, (ftnlen)132);
if (*eof) {
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
/* Find the "tokens" in the input line. As you scan from left */
/* to right along the line, exactly one of the following */
/* conditions is true. */
/* 1) You are in a separator field */
/* 4) You are in a quoted substring */
/* 5) You are in a non-quoted substring that isn't a separator */
/* field. */
/* Stuff between separator fields are regarded as tokens. Note */
/* this includes quoted strings. */
/* In addition we keep track of 3 separators: '=', '(', ')' */
/* Finally, whenever we encounters the separator '=', we back */
/* up and see if it is preceded by a '+', if so we attach */
/* it to the '=' and treat the pair of characters as a single */
/* separator. */
even = TRUE_;
intokn = FALSE_;
inquot = FALSE_;
insepf = TRUE_;
count = 0;
i__ = 0;
while(i__ < i_len(line, (ftnlen)132)) {
/* The current character is either a separator, quote or */
/* some other character. */
++i__;
code = *(unsigned char *)&line[i__ - 1];
if (code == iblank || code == icomma || code == ilparn || code ==
irparn || code == iequal || code == itab) {
/* There are 3 possible states we could be in */
/* Separation Field */
/* A quoted substring with the last quote an odd one. */
/* A quoted substring with the last quote an even one. */
/* A non-quoted token. */
/* In the first two cases nothing changes, but in the */
/* next two cases we transition to a separation field. */
if (intokn || inquot && even) {
inquot = FALSE_;
intokn = FALSE_;
insepf = TRUE_;
}
if (insepf) {
/* We need to see if this is one of the special */
/* separators */
if (code == iequal) {
++count;
begs[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("begs", i__1, "zzrvar_", (ftnlen)555)]
= i__;
type__[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("type", i__1, "zzrvar_", (ftnlen)556)]
= 5;
ends[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("ends", i__1, "zzrvar_", (ftnlen)557)]
= i__;
if (i__ > 1) {
/* Look back at the previous character. */
/* See if it is a plus character. */
i__1 = i__ - 2;
code = *(unsigned char *)&line[i__1];
if (code == iplus) {
/* This is the directive '+=' we need */
/* to set the beginning of this token */
/* to the one before this and adjust */
/* the end of the last token. */
type__[(i__1 = count - 1) < 132 && 0 <= i__1 ?
i__1 : s_rnge("type", i__1, "zzrvar_"
, (ftnlen)573)] = 6;
begs[(i__1 = count - 1) < 132 && 0 <= i__1 ?
i__1 : s_rnge("begs", i__1, "zzrvar_",
(ftnlen)574)] = i__ - 1;
if (begs[(i__1 = count - 2) < 132 && 0 <=
i__1 ? i__1 : s_rnge("begs", i__1,
"zzrvar_", (ftnlen)576)] == ends[(
i__2 = count - 2) < 132 && 0 <= i__2 ?
i__2 : s_rnge("ends", i__2, "zzrvar_"
, (ftnlen)576)]) {
--count;
begs[(i__1 = count - 1) < 132 && 0 <=
i__1 ? i__1 : s_rnge("begs", i__1,
"zzrvar_", (ftnlen)580)] = i__ -
1;
ends[(i__1 = count - 1) < 132 && 0 <=
i__1 ? i__1 : s_rnge("ends", i__1,
"zzrvar_", (ftnlen)581)] = i__;
type__[(i__1 = count - 1) < 132 && 0 <=
i__1 ? i__1 : s_rnge("type", i__1,
"zzrvar_", (ftnlen)582)] = 6;
} else {
ends[(i__1 = count - 2) < 132 && 0 <=
i__1 ? i__1 : s_rnge("ends", i__1,
"zzrvar_", (ftnlen)586)] = ends[(
i__2 = count - 2) < 132 && 0 <=
i__2 ? i__2 : s_rnge("ends", i__2,
"zzrvar_", (ftnlen)586)] - 1;
}
}
}
} else if (code == irparn) {
++count;
begs[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("begs", i__1, "zzrvar_", (ftnlen)597)]
= i__;
ends[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("ends", i__1, "zzrvar_", (ftnlen)598)]
= i__;
type__[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("type", i__1, "zzrvar_", (ftnlen)599)]
= 4;
} else if (code == ilparn) {
++count;
begs[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("begs", i__1, "zzrvar_", (ftnlen)604)]
= i__;
ends[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("ends", i__1, "zzrvar_", (ftnlen)605)]
= i__;
type__[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("type", i__1, "zzrvar_", (ftnlen)606)]
= 3;
}
}
} else if (code == iquote) {
/* There are 3 cases of interest. */
/* We are in a quoted substring already */
/* We are in a separator field */
/* We are in a non-quoted token. */
/* In the first case nothing changes. In the second */
/* two cases we change to being in a quoted substring. */
even = ! even;
if (! inquot) {
insepf = FALSE_;
intokn = FALSE_;
inquot = TRUE_;
++count;
begs[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("begs", i__1, "zzrvar_", (ftnlen)629)] =
i__;
type__[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("type", i__1, "zzrvar_", (ftnlen)630)] = 1;
}
ends[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 : s_rnge(
"ends", i__1, "zzrvar_", (ftnlen)634)] = i__;
} else {
/* This is some character other than a quote, or */
/* separator character. */
/* We are in one of four situations. */
/* 1) We are in a quoted substring with an odd number of */
/* quotes. */
/* 2) We are in a quoted substring with an even number of */
/* quotes. */
/* 2) We are in a separator field */
/* 3) We are in a non-quoted token. */
/* In cases 1 and 3 nothing changes. So we won't check */
/* those cases. */
if (insepf || inquot && even) {
inquot = FALSE_;
insepf = FALSE_;
intokn = TRUE_;
++count;
begs[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("begs", i__1, "zzrvar_", (ftnlen)659)] =
i__;
type__[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("type", i__1, "zzrvar_", (ftnlen)660)] = 2;
}
ends[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 : s_rnge(
"ends", i__1, "zzrvar_", (ftnlen)663)] = i__;
}
}
/* The first word on the first line should be the name of a */
/* variable. The second word should be a directive: = or +=. */
if (status == 1) {
/* There must be at least 3 contributing tokens on this line. */
if (count < 3) {
rdklin_(file, &number, (ftnlen)255);
setmsg_("A kernel variable was not properly formed on line #"
" of the file #. Such an assignment should have the f"
"orm: '<variable name> [+]= <values>'. This line was "
"'#'. ", (ftnlen)160);
r1 = rtrim_(file, (ftnlen)255);
r2 = rtrim_(line, (ftnlen)132);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r1);
errch_("#", line, (ftnlen)1, r2);
sigerr_("SPICE(BADVARASSIGN)", (ftnlen)19);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
/* See if the variable name is legitimate: */
i__1 = begs[0] - 1;
badat = lastpc_(line + i__1, ends[0] - i__1);
if (badat <= ends[0] - begs[0]) {
/* There is a non-printing character in the variable */
/* name. This isn't allowed. */
at = begs[0] + badat;
rdklin_(file, &number, (ftnlen)255);
r1 = rtrim_(file, (ftnlen)255);
setmsg_("There is a non-printing character embedded in line "
"# of the text kernel file #. Non-printing character"
"s are not allowed in kernel variable assignments. T"
"he non-printing character has ASCII code #. ", (
ftnlen)199);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r1);
i__1 = *(unsigned char *)&line[at - 1];
errint_("#", &i__1, (ftnlen)1);
sigerr_("SPICE(NONPRINTINGCHAR)", (ftnlen)22);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
/* Check the variable name length; signal an error */
/* if longer than MAXLEN. */
i__1 = begs[0] - 1;
varlen = i_len(line + i__1, ends[0] - i__1);
if (varlen > 32) {
setmsg_("A kernel pool variable name read from a kernel file"
" exceeds the maximum allowed length #1. The actual l"
"ength of the variable name is #2, the offending vari"
"able name to #3 characters: '#4'.", (ftnlen)188);
errint_("#1", &c__32, (ftnlen)2);
errint_("#2", &varlen, (ftnlen)2);
errint_("#3", &c__132, (ftnlen)2);
i__1 = begs[0] - 1;
errch_("#4", line + i__1, (ftnlen)2, ends[0] - i__1);
sigerr_("SPICE(BADVARNAME)", (ftnlen)17);
}
/* The variable name is ok. How about the directive. */
i__1 = begs[0] - 1;
s_copy(varnam, line + i__1, varnam_len, ends[0] - i__1);
dirctv = type__[1];
/* If this is replacement (=) and not an addition (+=), */
/* delete the values currently associated with the variable. */
/* They will be replaced later. */
if (dirctv != 5 && dirctv != 6) {
rdklin_(file, &number, (ftnlen)255);
setmsg_("A kernel variable was not properly formed on line #"
" of the file #. Such an assignment should have the f"
"orm: '<variable name> [+]= <values>'. More specific"
"ally, the assignment operator did not have one of th"
"e expected forms: '=' or '+='. The line was '#'. ", (
ftnlen)256);
r1 = rtrim_(file, (ftnlen)255);
r2 = rtrim_(line, (ftnlen)132);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r1);
errch_("#", line, (ftnlen)1, r2);
sigerr_("SPICE(BADVARASSIGN)", (ftnlen)19);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
/* Locate this variable name in the name pool or insert it */
/* if it isn't there. The location will be NAMEAT and */
/* we will use the variable FOUND to indicate whether or */
/* not it was already present. */
lookat = zzhash_(varnam, varnam_len);
node = namlst[lookat - 1];
full = lnknfn_(nmpool) <= 0;
found = FALSE_;
/* See if this name (or one colliding with it in the */
/* hash scheme) has already been stored in the name list. */
if (node > 0) {
head = node;
tail = -nmpool[(head << 1) + 11];
while(node > 0 && ! found) {
found = s_cmp(names + (node - 1) * names_len, varnam,
names_len, varnam_len) == 0;
nameat = node;
node = nmpool[(node << 1) + 10];
}
if (! found && ! full) {
/* We didn't find this name on the conflict resolution */
/* list. Allocate a new slot for it. */
lnkan_(nmpool, &node);
lnkila_(&tail, &node, nmpool);
s_copy(names + (node - 1) * names_len, varnam, names_len,
varnam_len);
nameat = node;
}
} else if (! full) {
/* Nothing like this variable name (in the hashing sense) */
/* has been loaded so far. We need to allocate */
/* a name slot for this variable. */
lnkan_(nmpool, &node);
namlst[lookat - 1] = node;
s_copy(names + (node - 1) * names_len, varnam, names_len,
varnam_len);
nameat = node;
}
/* If the name pool was full and we didn't find this name */
/* we've got an error. Diagnose it and return. */
if (full && ! found) {
rdklin_(file, &number, (ftnlen)255);
r1 = rtrim_(file, (ftnlen)255);
setmsg_("The kernel pool does not have room for any more var"
"iables. It filled up at line # of the kernel file #"
". ", (ftnlen)105);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r1);
sigerr_("SPICE(KERNELPOOLFULL)", (ftnlen)21);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
/* Now depending upon the kind of directive, we will need */
/* to remove data and allocate a new list or simply append */
/* data to the existing list. */
if (dirctv == 5) {
/* We are going to dump whatever is associated with */
/* this name and then we will need to allocate a new */
/* linked list for the data. */
vartyp = 3;
if (found) {
/* We need to free the data associated with this */
/* variable. */
datahd = datlst[nameat - 1];
datlst[nameat - 1] = 0;
if (datahd < 0) {
/* This variable was character type we need to */
/* free a linked list from the character data */
/* pool. */
head = -datahd;
tail = -chpool[(head << 1) + 11];
lnkfsl_(&head, &tail, chpool);
} else {
/* This variable was numeric type. We need to */
/* free a linked list from the numeric pool. */
head = datahd;
tail = -dppool[(head << 1) + 11];
lnkfsl_(&head, &tail, dppool);
}
}
} else if (dirctv == 6) {
/* We need to append to the current variable. */
if (found) {
if (datlst[nameat - 1] > 0) {
vartyp = 2;
} else if (datlst[nameat - 1] < 0) {
vartyp = 1;
} else {
vartyp = 3;
}
} else {
vartyp = 3;
}
}
/* If this is a vector, the next thing on the line will be a */
/* left parenthesis. Otherwise, assume that this is a scalar. */
/* If it's a vector, get the first value. If it's a scalar, */
/* plant a bogus right parenthesis, to make the following loop */
/* terminate after one iteration. */
if (type__[2] == 3) {
nxttok = 4;
} else {
nxttok = 3;
++count;
type__[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 : s_rnge(
"type", i__1, "zzrvar_", (ftnlen)950)] = 4;
}
/* For subsequent lines, treat everything as a new value. */
} else {
nxttok = 1;
}
/* We have a value anyway. Store it in the table. */
/* Keep going until the other shoe (the right parenthesis) */
/* drops, or until the end of the line is reached. */
/* Dates begin with @; anything else is presumed to be a number. */
while(type__[(i__1 = nxttok - 1) < 132 && 0 <= i__1 ? i__1 : s_rnge(
"type", i__1, "zzrvar_", (ftnlen)971)] != 4 && nxttok <=
count) {
/* Get the begin and end of this token. */
b = begs[(i__1 = nxttok - 1) < 132 && 0 <= i__1 ? i__1 : s_rnge(
"begs", i__1, "zzrvar_", (ftnlen)975)];
e = ends[(i__1 = nxttok - 1) < 132 && 0 <= i__1 ? i__1 : s_rnge(
"ends", i__1, "zzrvar_", (ftnlen)976)];
if (vartyp == 3) {
/* We need to determine which category of variable we */
/* have by looking at this token and deducing the */
/* type. */
if (type__[(i__1 = nxttok - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("type", i__1, "zzrvar_", (ftnlen)984)] == 1) {
vartyp = 1;
} else if (type__[(i__1 = nxttok - 1) < 132 && 0 <= i__1 ?
i__1 : s_rnge("type", i__1, "zzrvar_", (ftnlen)988)]
== 2) {
vartyp = 2;
} else {
/* This is an error. We should have had one of the */
/* two previous types. */
/* First perform the clean up function. */
zzcln_(&lookat, &nameat, namlst, datlst, nmpool, chpool,
dppool);
rdklin_(file, &number, (ftnlen)255);
r1 = rtrim_(file, (ftnlen)255);
setmsg_("The first item following the assignment operato"
"r should be the value of a variable or a left pa"
"renthesis '(' followed by a value for a variable"
". This is not true on line # of the text kernel "
"file '#'. ", (ftnlen)201);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r1);
sigerr_("SPICE(BADVARASSIGN)", (ftnlen)19);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
}
if (vartyp == 1) {
/* First make sure that this token represents a string. */
if (type__[(i__1 = nxttok - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("type", i__1, "zzrvar_", (ftnlen)1029)] != 1) {
/* First perform the clean up function. */
zzcln_(&lookat, &nameat, namlst, datlst, nmpool, chpool,
dppool);
rdklin_(file, &number, (ftnlen)255);
r1 = rtrim_(varnam, varnam_len);
r2 = rtrim_(file, (ftnlen)255);
setmsg_("The kernel variable # has been set up as a stri"
"ng variable. However, the value that you are at"
"tempting to assign to this variable on line # of"
" the kernel file '#' is not a string value. ", (
ftnlen)187);
errch_("#", varnam, (ftnlen)1, r1);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r2);
sigerr_("SPICE(TYPEMISMATCH)", (ftnlen)19);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
/* Still going? Make sure there is something between */
/* the quotes. */
if (b + 1 >= e) {
/* First perform the clean up function. */
zzcln_(&lookat, &nameat, namlst, datlst, nmpool, chpool,
dppool);
rdklin_(file, &number, (ftnlen)255);
r1 = rtrim_(file, (ftnlen)255);
setmsg_("There is a quoted string with no characters on "
"line # of the text kernel file '#'. ", (ftnlen)83)
;
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r1);
sigerr_("SPICE(TYPEMISMATCH)", (ftnlen)19);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
/* We are ready to go. Allocate a node for this data */
/* item. First make sure there is room to do so. */
free = lnknfn_(chpool);
if (free <= 0) {
rdklin_(file, &number, (ftnlen)255);
r1 = rtrim_(file, (ftnlen)255);
setmsg_("There is no room available for adding another c"
"haracter value to the kernel pool. The characte"
"r values buffer became full at line # of the tex"
"t kernel file '#'. ", (ftnlen)162);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r1);
sigerr_("SPICE(KERNELPOOLFULL)", (ftnlen)21);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
/* Allocate a node for storing this string value: */
lnkan_(chpool, &chnode);
if (datlst[nameat - 1] == 0) {
/* There was no data for this name yet. We make */
/* CHNODE be the head of the data list for this name. */
datlst[nameat - 1] = -chnode;
} else {
/* Put this node after the tail of the current list. */
head = -datlst[nameat - 1];
tail = -chpool[(head << 1) + 11];
lnkila_(&tail, &chnode, chpool);
}
/* Finally insert this data item in the data buffer */
/* at CHNODE. Note any quotes will be doubled so we */
/* have to undo this affect when we store the data. */
s_copy(chvals + (chnode - 1) * chvals_len, " ", chvals_len, (
ftnlen)1);
++ncomp;
/* Adjust end-of-token position (E) if it happens to the */
/* last, non-quote character of the truncated input line. */
/* This has to be done to make sure that all meaningful */
/* characters get moved to the value. */
code = *(unsigned char *)&line[e - 1];
if (! (code == iquote)) {
++e;
}
i__ = 1;
j = b + 1;
while(j < e) {
code = *(unsigned char *)&line[j - 1];
if (code == iquote) {
++j;
}
if (i__ <= i_len(chvals + (chnode - 1) * chvals_len,
chvals_len)) {
*(unsigned char *)&chvals[(chnode - 1) * chvals_len +
(i__ - 1)] = *(unsigned char *)&line[j - 1];
++i__;
++j;
} else {
++j;
}
}
/* That's all for this value. It's now time to loop */
/* back through and get the next value. */
} else {
if (type__[(i__1 = nxttok - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("type", i__1, "zzrvar_", (ftnlen)1175)] != 2) {
/* First perform the clean up function. */
zzcln_(&lookat, &nameat, namlst, datlst, nmpool, chpool,
dppool);
rdklin_(file, &number, (ftnlen)255);
r1 = rtrim_(varnam, varnam_len);
r2 = rtrim_(file, (ftnlen)255);
setmsg_("The kernel variable # has been set up as a nume"
"ric or time variable. However, the value that y"
"ou are attempting to assign to this variable on "
"line # of the kernel file '#' is not a numeric o"
"r time value. ", (ftnlen)205);
errch_("#", varnam, (ftnlen)1, r1);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r2);
sigerr_("SPICE(TYPEMISMATCH)", (ftnlen)19);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
/* Look at the first character to see if we have a time */
/* or a number. */
code = *(unsigned char *)&line[b - 1];
if (code == itmark) {
/* We need to have more than a single character. */
if (e == b) {
/* First perform the clean up function. */
zzcln_(&lookat, &nameat, namlst, datlst, nmpool,
chpool, dppool);
rdklin_(file, &number, (ftnlen)255);
r1 = rtrim_(varnam, varnam_len);
r2 = rtrim_(file, (ftnlen)255);
setmsg_("At character # of line # in the text kerne"
"l file '#' the character '@' appears. This "
"character is reserved for identifying time v"
"alues in assignments to kernel pool variable"
"s. However it is not being used in this fas"
"hion for the variable '#'. ", (ftnlen)246);
errint_("#", &b, (ftnlen)1);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r2);
errch_("#", varnam, (ftnlen)1, r1);
sigerr_("SPICE(BADTIMESPEC)", (ftnlen)18);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
i__1 = b;
tparse_(line + i__1, &dvalue, error, e - i__1, (ftnlen)
255);
if (s_cmp(error, " ", (ftnlen)255, (ftnlen)1) != 0) {
/* First perform the clean up function. */
zzcln_(&lookat, &nameat, namlst, datlst, nmpool,
chpool, dppool);
rdklin_(file, &number, (ftnlen)255);
r1 = rtrim_(file, (ftnlen)255);
lstnb = lastnb_(error, (ftnlen)255);
setmsg_("Encountered '#' while attempting to parse a"
" time on line # of the text kernel file '#'."
" Error message: '#'", (ftnlen)107);
i__1 = b;
errch_("#", line + i__1, (ftnlen)1, e - i__1);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, (ftnlen)255);
errch_("#", error, (ftnlen)1, lstnb);
sigerr_("SPICE(BADTIMESPEC)", (ftnlen)18);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
} else {
nparsd_(line + (b - 1), &dvalue, error, &i__, e - (b - 1),
(ftnlen)255);
if (s_cmp(error, " ", (ftnlen)255, (ftnlen)1) != 0) {
zzcln_(&lookat, &nameat, namlst, datlst, nmpool,
chpool, dppool);
rdklin_(file, &number, (ftnlen)255);
lstnb = lastnb_(error, (ftnlen)255);
setmsg_("Encountered '#' while attempting to parse a"
" number on line # of the text kernel file '#"
"'. Error message: '#'", (ftnlen)109);
errch_("#", line + (b - 1), (ftnlen)1, e - (b - 1));
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, (ftnlen)255);
errch_("#", error, (ftnlen)1, lstnb);
sigerr_("SPICE(NUMBEREXPECTED)", (ftnlen)21);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
}
/* OK. We have a parsed value. See if there is room in */
/* the numeric portion of the pool to store this value. */
free = lnknfn_(dppool);
if (free <= 0) {
rdklin_(file, &number, (ftnlen)255);
r1 = rtrim_(file, (ftnlen)255);
setmsg_("There is no room available for adding another n"
"umeric value to the kernel pool. The numeric va"
"lues buffer became full at line # of the text ke"
"rnel file '#'. ", (ftnlen)158);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r1);
sigerr_("SPICE(KERNELPOOLFULL)", (ftnlen)21);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
/* Allocate a node for storing this numeric value: */
lnkan_(dppool, &dpnode);
if (datlst[nameat - 1] == 0) {
/* There was no data for this name yet. We make */
/* DPNODE be the head of the data list for this name. */
datlst[nameat - 1] = dpnode;
} else {
/* Put this node after the tail of the current list. */
head = datlst[nameat - 1];
tail = -dppool[(head << 1) + 11];
lnkila_(&tail, &dpnode, dppool);
}
/* Finally insert this data item into the numeric buffer. */
dpvals[dpnode - 1] = dvalue;
++ncomp;
}
/* Now process the next token in the list of tokens. */
++nxttok;
}
/* We could have ended the above loop in one of two ways. */
/* 1) NXTTOK now exceeds count. This means we did not reach */
/* an end of vector marker. */
/* 2) We hit an end of vector marker. */
if (nxttok > count) {
status = 3;
} else {
status = 2;
}
}
/* It is possible that we reached this point without actually */
/* assigning a value to the kernel pool variable. This can */
/* happen if there is a vector input of the form NAME = ( ) */
if (ncomp < 1) {
zzcln_(&lookat, &nameat, namlst, datlst, nmpool, chpool, dppool);
rdklin_(file, &number, (ftnlen)255);
r1 = rtrim_(file, (ftnlen)255);
setmsg_("The first item following the assignment operator should be "
"the value of a variable or a left parenthesis '(' followed b"
"y a value for a variable. This is not true on line # of the "
"text kernel file '#'. ", (ftnlen)201);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r1);
sigerr_("SPICE(BADVARASSIGN)", (ftnlen)19);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
/* Return the name of the variable. */
s_copy(name__, varnam, (ftnlen)132, varnam_len);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
} /* zzrvar_ */
/* $Procedure LBUILD ( Build a list in a character string ) */
/* Subroutine */ int lbuild_(char *items, integer *n, char *delim, char *list,
ftnlen items_len, ftnlen delim_len, ftnlen list_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen), s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer dlen, ilen, llen, last, lpos, i__, first;
extern integer lastnb_(char *, ftnlen), frstnb_(char *, ftnlen);
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen);
/* $ Abstract */
/* Build a list of items delimited by a character. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* CHARACTER, LIST, STRING */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ITEMS I Items in the list. */
/* N I Number of items in the list. */
/* DELIM I String used to delimit items. */
/* LIST O List of items delimited by DELIM. */
/* $ Detailed_Input */
/* ITEMS are the items to be combined to make the output */
/* list. Leading and trailing blanks are ignored. */
/* (Only the non-blank parts of the items are used.) */
/* N is the number of items. */
/* DELIM is the string used to delimit the items in the */
/* output list. DELIM may contain any number of */
/* characters, including blanks. */
/* $ Detailed_Output */
/* LIST is the output list, containing the N elements of */
/* ITEMS delimited by DELIM. If LIST is not long enough */
/* to contain the output list, it is truncated on the */
/* right. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* The non-blank parts of the elements of the ITEMS array are */
/* appended to the list, one at a time, separated by DELIM. */
/* $ Examples */
/* The following examples illustrate the operation of LBUILD. */
/* 1) Let */
/* DELIM = ' ' */
/* ITEMS(1) = 'A' */
/* ITEMS(2) = ' number' */
/* ITEMS(3) = 'of' */
/* ITEMS(4) = ' words' */
/* ITEMS(5) = 'separated' */
/* ITEMS(6) = ' by' */
/* ITEMS(7) = 'spaces' */
/* Then */
/* LIST = 'A number of words separated by spaces' */
/* 2) Let */
/* DELIM = '/' */
/* ITEMS(1) = ' ' */
/* ITEMS(2) = ' ' */
/* ITEMS(3) = 'option1' */
/* ITEMS(4) = ' ' */
/* ITEMS(5) = 'option2' */
/* ITEMS(6) = ' ' */
/* ITEMS(7) = ' ' */
/* ITEMS(8) = ' ' */
/* Then */
/* LIST = '//option1//option2///' */
/* 3) Let */
/* DELIM = ' and ' */
/* ITEMS(1) = 'Bob' */
/* ITEMS(2) = 'Carol' */
/* ITEMS(3) = 'Ted' */
/* ITEMS(4) = 'Alice' */
/* Then */
/* LIST = 'Bob and Carol and Ted and Alice' */
/* $ Restrictions */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Author_and_Institution */
/* I.M. Underwood (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) */
/* -& */
/* $ Index_Entries */
/* build a list in a character_string */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Find the non-blank part of each item. Move it to the */
/* end of the list, followed by a delimiter. If the item is */
/* blank, don't move anything but the delimiter. */
/* LPOS is the next position in the output list to be filled. */
/* LLEN is the length of the output list. */
/* DLEN is the length of DELIM. */
/* ILEN is the length of the next item in the list. */
s_copy(list, " ", list_len, (ftnlen)1);
lpos = 1;
llen = i_len(list, list_len);
dlen = i_len(delim, delim_len);
if (*n > 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (lpos <= llen) {
if (s_cmp(items + (i__ - 1) * items_len, " ", items_len, (
ftnlen)1) == 0) {
s_copy(list + (lpos - 1), delim, list_len - (lpos - 1),
delim_len);
lpos += dlen;
} else {
first = frstnb_(items + (i__ - 1) * items_len, items_len);
last = lastnb_(items + (i__ - 1) * items_len, items_len);
ilen = last - first + 1;
s_copy(list + (lpos - 1), items + ((i__ - 1) * items_len
+ (first - 1)), list_len - (lpos - 1), last - (
first - 1));
suffix_(delim, &c__0, list, delim_len, list_len);
lpos = lpos + ilen + dlen;
}
}
}
/* We're at the end of the list. Right now, the list ends in */
/* a delimiter. Drop it. */
if (lpos - dlen <= llen) {
i__1 = lpos - dlen - 1;
s_copy(list + i__1, " ", list_len - i__1, (ftnlen)1);
}
}
return 0;
} /* lbuild_ */
/* $Procedure SPKW15 ( SPK, write a type 15 segment ) */
/* Subroutine */ int spkw15_(integer *handle, integer *body, integer *center,
char *frame, doublereal *first, doublereal *last, char *segid,
doublereal *epoch, doublereal *tp, doublereal *pa, doublereal *p,
doublereal *ecc, doublereal *j2flg, doublereal *pv, doublereal *gm,
doublereal *j2, doublereal *radius, ftnlen frame_len, ftnlen
segid_len)
{
/* System generated locals */
integer i__1;
/* Local variables */
extern /* Subroutine */ int vhat_(doublereal *, doublereal *);
doublereal mypa[3];
extern doublereal vdot_(doublereal *, doublereal *), vsep_(doublereal *,
doublereal *);
extern /* Subroutine */ int vequ_(doublereal *, doublereal *);
doublereal mytp[3];
integer i__;
doublereal angle;
extern /* Subroutine */ int chkin_(char *, ftnlen);
doublereal descr[5];
integer value;
extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen);
extern logical vzero_(doublereal *);
extern /* Subroutine */ int dafada_(doublereal *, integer *), dafbna_(
integer *, doublereal *, char *, ftnlen), dafena_(void);
extern logical failed_(void);
doublereal record[16];
extern integer lastnb_(char *, ftnlen);
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen), spkpds_(integer *, integer *, char *, integer *,
doublereal *, doublereal *, doublereal *, ftnlen);
extern logical return_(void);
extern doublereal dpr_(void);
doublereal dot;
/* $ Abstract */
/* Write an SPK segment of type 15 given a type 15 data 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 */
/* SPK */
/* $ Keywords */
/* EPHEMERIS */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle of an SPK file open for writing. */
/* BODY I Body code for ephemeris object. */
/* CENTER I Body code for the center of motion of the body. */
/* FRAME I The reference frame of the states. */
/* FIRST I First valid time for which states can be computed. */
/* LAST I Last valid time for which states can be computed. */
/* SEGID I Segment identifier. */
/* EPOCH I Epoch of the periapse. */
/* TP I Trajectory pole vector. */
/* PA I Periapsis vector. */
/* P I Semi-latus rectum. */
/* ECC I Eccentricity. */
/* J2FLG I J2 processing flag. */
/* PV I Central body pole vector. */
/* GM I Central body GM. */
/* J2 I Central body J2. */
/* RADIUS I Equatorial radius of central body. */
/* $ Detailed_Input */
/* HANDLE is the file handle of an SPK file that has been */
/* opened for writing. */
/* BODY is the NAIF ID for the body whose states are */
/* to be recorded in an SPK file. */
/* CENTER is the NAIF ID for the center of motion associated */
/* with BODY. */
/* FRAME is the reference frame that states are referenced to, */
/* for example 'J2000'. */
/* FIRST are the bounds on the ephemeris times, expressed as */
/* LAST seconds past J2000. */
/* SEGID is the segment identifier. An SPK segment identifier */
/* may contain up to 40 characters. */
/* EPOCH is the epoch of the orbit elements at periapse */
/* in ephemeris seconds past J2000. */
/* TP is a vector parallel to the angular momentum vector */
/* of the orbit at epoch expressed relative to FRAME. A */
/* unit vector parallel to TP will be stored in the */
/* output segment. */
/* PA is a vector parallel to the position vector of the */
/* trajectory at periapsis of EPOCH expressed relative */
/* to FRAME. A unit vector parallel to PA will be */
/* stored in the output segment. */
/* P is the semi-latus rectum--- p in the equation: */
/* r = p/(1 + ECC*COS(Nu)) */
/* ECC is the eccentricity. */
/* J2FLG is the J2 processing flag describing what J2 */
/* corrections are to be applied when the orbit is */
/* propagated. */
/* All J2 corrections are applied if the value of J2FLG */
/* is not 1, 2 or 3. */
/* If the value of the flag is 3 no corrections are */
/* done. */
/* If the value of the flag is 1 no corrections are */
/* computed for the precession of the line of apsides. */
/* However, regression of the line of nodes is */
/* performed. */
/* If the value of the flag is 2 no corrections are */
/* done for the regression of the line of nodes. */
/* However, precession of the line of apsides is */
/* performed. */
/* Note that J2 effects are computed only if the orbit */
/* is elliptic and does not intersect the central body. */
/* PV is a vector parallel to the north pole vector of the */
/* central body expressed relative to FRAME. A unit */
/* vector parallel to PV will be stored in the output */
/* segment. */
/* GM is the central body GM. */
/* J2 is the central body J2 (dimensionless). */
/* RADIUS is the equatorial radius of the central body. */
/* Units are radians, km, seconds. */
/* $ Detailed_Output */
/* None. A type 15 segment is written to the file attached */
/* to HANDLE. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the eccentricity is less than zero, the error */
/* 'SPICE(BADECCENTRICITY)' will be signaled. */
/* 2) If the semi-latus rectum is 0, the error */
/* 'SPICE(BADLATUSRECTUM)' is signaled. */
/* 3) If the pole vector, trajectory pole vector or periapsis vector */
/* have zero length, the error 'SPICE(BADVECTOR)' is signaled. */
/* 4) If the trajectory pole vector and the periapsis vector are */
/* not orthogonal, the error 'SPICE(BADINITSTATE)' is signaled. */
/* The test for orthogonality is very crude. The routine simply */
/* checks that the dot product of the unit vectors parallel */
/* to the trajectory pole and periapse vectors is less than */
/* 0.00001. This check is intended to catch blunders, not to */
/* enforce orthogonality to double precision capacity. */
/* 5) If the mass of the central body is non-positive, the error */
/* 'SPICE(NONPOSITIVEMASS)' is signaled. */
/* 6) If the radius of the central body is negative, the error */
/* 'SPICE(BADRADIUS)' is signaled. */
/* 7) If the segment identifier has more than 40 non-blank characters */
/* the error 'SPICE(SEGIDTOOLONG)' is signaled. */
/* 8) If the segment identifier contains non-printing characters */
/* the error 'SPICE(NONPRINTABLECHARS)' is signaled. */
/* 9) If there are inconsistencies in the BODY, CENTER, FRAME or */
/* FIRST and LAST times, the problem will be diagnosed by */
/* a routine in the call tree of this routine. */
/* $ Files */
/* A new type 15 SPK segment is written to the SPK file attached */
/* to HANDLE. */
/* $ Particulars */
/* This routine writes an SPK type 15 data segment to the open SPK */
/* file according to the format described in the type 15 section of */
/* the SPK Required Reading. The SPK file must have been opened with */
/* write access. */
/* This routine is provided to provide direct support for the MASL */
/* precessing orbit formulation. */
/* $ Examples */
/* Suppose that at time EPOCH you have the J2000 periapsis */
/* state of some object relative to some central body and would */
/* like to create a type 15 SPK segment to model the motion of */
/* the object using simple regression and precession of the */
/* line of nodes and apsides. The following code fragment */
/* illustrates how you can prepare such a segment. We shall */
/* assume that you have in hand the J2000 direction of the */
/* central body's pole vector, its GM, J2 and equatorial */
/* radius. In addition we assume that you have opened an SPK */
/* file for write access and that it is attached to HANDLE. */
/* (If your state is at an epoch other than periapse the */
/* fragment below will NOT produce a "correct" type 15 segment */
/* for modeling the motion of your object.) */
/* C */
/* C First we get the osculating elements. */
/* C */
/* CALL OSCELT ( STATE, EPOCH, GM, ELTS ) */
/* C */
/* C From these collect the eccentricity and semi-latus rectum. */
/* C */
/* ECC = ELTS ( 2 ) */
/* P = ELTS ( 1 ) * ( 1.0D0 + ECC ) */
/* C */
/* C Next get the trajectory pole vector and the */
/* C periapsis vector. */
/* C */
/* CALL UCRSS ( STATE(1), STATE(4), TP ) */
/* CALL VHAT ( STATE(1), PA ) */
/* C */
/* C Enable both J2 corrections. */
/* C */
/* J2FLG = 0.0D0 */
/* C */
/* C Now add the segment. */
/* C */
/* CALL SPKW15 ( HANDLE, BODY, CENTER, FRAME, FIRST, LAST, */
/* . SEGID, EPOCH, TP, PA, P, ECC, */
/* . J2FLG, PV, GM, J2, RADIUS ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 2.0.0, 29-MAY-2012 (NJB) */
/* Input vectors that nominally have unit length */
/* are mapped to local copies that actually do */
/* have unit length. The applicable inputs are TP, PA, */
/* and PV. The Detailed Input header section was updated */
/* to reflect the change. */
/* Some typos in error messages were corrected. */
/* - SPICELIB Version 1.0.0, 28-NOV-1994 (WLT) */
/* -& */
/* $ Index_Entries */
/* Write a type 15 spk segment */
/* -& */
/* SPICELIB Functions */
/* Local Variables */
/* Segment descriptor size */
/* Segment identifier size */
/* SPK data type */
/* Range of printing characters */
/* Number of items in a segment */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
chkin_("SPKW15", (ftnlen)6);
/* Fetch the various entities from the inputs and put them into */
/* the data record, first the epoch. */
record[0] = *epoch;
/* Convert TP and PA to unit vectors. */
vhat_(pa, mypa);
vhat_(tp, mytp);
/* The trajectory pole vector. */
vequ_(mytp, &record[1]);
/* The periapsis vector. */
vequ_(mypa, &record[4]);
/* Semi-latus rectum ( P in the P/(1 + ECC*COS(Nu) ), */
/* and eccentricity. */
record[7] = *p;
record[8] = *ecc;
/* J2 processing flag. */
record[9] = *j2flg;
/* Central body pole vector. */
vhat_(pv, &record[10]);
/* The central mass, J2 and radius of the central body. */
record[13] = *gm;
record[14] = *j2;
record[15] = *radius;
/* Check all the inputs here for obvious failures. It's much */
/* better to check them now and quit than it is to get a bogus */
/* segment into an SPK file and diagnose it later. */
if (*p <= 0.) {
setmsg_("The semi-latus rectum supplied to the SPK type 15 evaluator"
" was non-positive. This value must be positive. The value s"
"upplied was #.", (ftnlen)133);
errdp_("#", p, (ftnlen)1);
sigerr_("SPICE(BADLATUSRECTUM)", (ftnlen)21);
chkout_("SPKW15", (ftnlen)6);
return 0;
} else if (*ecc < 0.) {
setmsg_("The eccentricity supplied for a type 15 segment is negative"
". It must be non-negative. The value supplied to the type 1"
"5 evaluator was #. ", (ftnlen)138);
errdp_("#", ecc, (ftnlen)1);
sigerr_("SPICE(BADECCENTRICITY)", (ftnlen)22);
chkout_("SPKW15", (ftnlen)6);
return 0;
} else if (*gm <= 0.) {
setmsg_("The mass supplied for the central body of a type 15 segment"
" was non-positive. Masses must be positive. The value suppl"
"ied was #. ", (ftnlen)130);
errdp_("#", gm, (ftnlen)1);
sigerr_("SPICE(NONPOSITIVEMASS)", (ftnlen)22);
chkout_("SPKW15", (ftnlen)6);
return 0;
} else if (vzero_(tp)) {
setmsg_("The trajectory pole vector supplied to SPKW15 had length ze"
"ro. The most likely cause of this problem is an uninitialize"
"d vector.", (ftnlen)128);
sigerr_("SPICE(BADVECTOR)", (ftnlen)16);
chkout_("SPKW15", (ftnlen)6);
return 0;
} else if (vzero_(pa)) {
setmsg_("The periapse vector supplied to SPKW15 had length zero. The"
" most likely cause of this problem is an uninitialized vecto"
"r.", (ftnlen)121);
sigerr_("SPICE(BADVECTOR)", (ftnlen)16);
chkout_("SPKW15", (ftnlen)6);
return 0;
} else if (vzero_(pv)) {
setmsg_("The central pole vector supplied to SPKW15 had length zero."
" The most likely cause of this problem is an uninitialized v"
"ector. ", (ftnlen)126);
sigerr_("SPICE(BADVECTOR)", (ftnlen)16);
chkout_("SPKW15", (ftnlen)6);
return 0;
} else if (*radius < 0.) {
setmsg_("The central body radius was negative. It must be zero or po"
"sitive. The value supplied was #. ", (ftnlen)94);
errdp_("#", radius, (ftnlen)1);
sigerr_("SPICE(BADRADIUS)", (ftnlen)16);
chkout_("SPKW15", (ftnlen)6);
return 0;
}
/* One final check. Make sure the pole and periapse vectors are */
/* orthogonal. (We will use a very crude check but this should */
/* rule out any obvious errors.) */
dot = vdot_(mypa, mytp);
if (abs(dot) > 1e-5) {
angle = vsep_(pa, tp) * dpr_();
setmsg_("The periapsis and trajectory pole vectors are not orthogona"
"l. The angle between them is # degrees. ", (ftnlen)99);
errdp_("#", &angle, (ftnlen)1);
sigerr_("SPICE(BADINITSTATE)", (ftnlen)19);
chkout_("SPKW15", (ftnlen)6);
return 0;
}
/* Make sure the segment identifier is not too long. */
if (lastnb_(segid, segid_len) > 40) {
setmsg_("Segment identifier contains more than 40 characters.", (
ftnlen)52);
sigerr_("SPICE(SEGIDTOOLONG)", (ftnlen)19);
chkout_("SPKW15", (ftnlen)6);
return 0;
}
/* Make sure it has only printing characters. */
i__1 = lastnb_(segid, segid_len);
for (i__ = 1; i__ <= i__1; ++i__) {
value = *(unsigned char *)&segid[i__ - 1];
if (value < 32 || value > 126) {
setmsg_("The segment identifier contains the nonprintable charac"
"ter having ascii code #.", (ftnlen)79);
errint_("#", &value, (ftnlen)1);
sigerr_("SPICE(NONPRINTABLECHARS)", (ftnlen)24);
chkout_("SPKW15", (ftnlen)6);
return 0;
}
}
/* All of the obvious checks have been performed on the input */
/* record. Create the segment descriptor. (FIRST and LAST are */
/* checked by SPKPDS as well as consistency between BODY and CENTER). */
spkpds_(body, center, frame, &c__15, first, last, descr, frame_len);
if (failed_()) {
chkout_("SPKW15", (ftnlen)6);
return 0;
}
/* Begin a new segment. */
dafbna_(handle, descr, segid, segid_len);
if (failed_()) {
chkout_("SPKW15", (ftnlen)6);
return 0;
}
dafada_(record, &c__16);
if (! failed_()) {
dafena_();
}
chkout_("SPKW15", (ftnlen)6);
return 0;
} /* spkw15_ */
