/* $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_ */