/* $Procedure WNINSD ( Insert an interval into a DP window ) */
/* Subroutine */ int wninsd_(doublereal *left, doublereal *right, doublereal *
window)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Local variables */
integer card, size, i__, j;
extern integer cardd_(doublereal *);
extern /* Subroutine */ int chkin_(char *, ftnlen), errdp_(char *,
doublereal *, ftnlen);
extern integer sized_(doublereal *);
extern /* Subroutine */ int scardd_(integer *, doublereal *), excess_(
integer *, char *, ftnlen), sigerr_(char *, ftnlen), chkout_(char
*, ftnlen), setmsg_(char *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Insert an interval into a double precision window. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* WINDOWS */
/* $ Keywords */
/* WINDOWS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* LEFT, */
/* RIGHT I Left, right endpoints of new interval. */
/* WINDOW I,O Input, output window. */
/* $ Detailed_Input */
/* LEFT, */
/* RIGHT are the left and right endpoints of the interval */
/* to be inserted. */
/* WINDOW on input, is a window containing zero or more */
/* intervals. */
/* $ Detailed_Output */
/* WINDOW on output, is the original window following the */
/* insertion of the interval from LEFT to RIGHT. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* This routine inserts the interval from LEFT to RIGHT into the */
/* input window. If the new interval overlaps any of the intervals */
/* in the window, the intervals are merged. Thus, the cardinality */
/* of the input window can actually decrease as the result of an */
/* insertion. However, because inserting an interval that is */
/* disjoint from the other intervals in the window can increase the */
/* cardinality of the window, the routine signals an error. */
/* This is the only unary routine to signal an error. No */
/* other unary routine can increase the number of intervals in */
/* the input window. */
/* $ Examples */
/* Let WINDOW contain the intervals */
/* [ 1, 3 ] [ 7, 11 ] [ 23, 27 ] */
/* Then the following series of calls */
/* CALL WNINSD ( 5, 5, WINDOW ) (1) */
/* CALL WNINSD ( 4, 8, WINDOW ) (2) */
/* CALL WNINSD ( 0, 30, WINDOW ) (3) */
/* produces the following series of windows */
/* [ 1, 3 ] [ 5, 5 ] [ 7, 11 ] [ 23, 27 ] (1) */
/* [ 1, 3 ] [ 4, 11 ] [ 23, 27 ] (2) */
/* [ 0, 30 ] (3) */
/* $ Exceptions */
/* 1) If LEFT is greater than RIGHT, the error SPICE(BADENDPOINTS) is */
/* signalled. */
/* 2) If the insertion of the interval causes an excess of elements, */
/* the error SPICE(WINDOWEXCESS) is signalled. */
/* $ Files */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - Beta Version 1.3.0, 04-MAR-1993 (KRG) */
/* There was a bug when moving the intervals in the cell */
/* to the right when inserting a new interval to the left */
/* of the left most interval. the incrementing in the DO */
/* loop was incorrect. */
/* The loop used to read: */
/* DO J = I-1, CARD */
/* WINDOW(J+2) = WINDOW(J) */
/* END DO */
/* which squashed everything to the right of the first interval */
/* with the values of the first interval. */
/* The loop now reads: */
/* DO J = CARD, I-1, -1 */
/* WINDOW(J+2) = WINDOW(J) */
/* END DO */
/* which correctly scoots the elements in reverse order, */
/* preserving their values. */
/* - 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 */
/* insert an interval into a d.p. window */
/* -& */
/* $ Revisions */
/* - Beta Version 1.3.0, 04-MAR-1993 (KRG) */
/* There was a bug when moving the intervals in the cell */
/* to the right when inserting a new interval to the left */
/* of the left most interval. the incrementing in the DO */
/* loop was incorrect. */
/* The loop used to read: */
/* DO J = I-1, CARD */
/* WINDOW(J+2) = WINDOW(J) */
/* END DO */
/* which squashed everything to the right of the first interval */
/* with the values of the first interval. */
/* The loop now reads: */
/* DO J = CARD, I-1, -1 */
/* WINDOW(J+2) = WINDOW(J) */
/* END DO */
/* which correctly scoots the elements in reverse order, */
/* preserving their values. */
/* - Beta Version 1.2.0, 27-FEB-1989 (HAN) */
/* Due to the calling sequence and functionality changes */
/* in the routine EXCESS, the method of signalling an */
/* excess of elements needed to be changed. */
/* - Beta Version 1.1.0, 17-FEB-1989 (HAN) (NJB) */
/* Contents of the Required_Reading section was */
/* changed from "None." to "WINDOWS". Also, the */
/* declaration of the unused variable K was removed. */
/* -& */
/* SPICELIB functions */
/* Local Variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("WNINSD", (ftnlen)6);
}
/* Get the size and cardinality of the window. */
size = sized_(window);
card = cardd_(window);
/* Let's try the easy cases first. No input interval? No change. */
/* Signal that an error has occurred and set the error message. */
if (*left > *right) {
setmsg_("Left endpoint was *. Right endpoint was *.", (ftnlen)42);
errdp_("*", left, (ftnlen)1);
errdp_("*", right, (ftnlen)1);
sigerr_("SPICE(BADENDPOINTS)", (ftnlen)19);
chkout_("WNINSD", (ftnlen)6);
return 0;
/* Empty window? Input interval later than the end of the window? */
/* Just insert the interval, if there's room. */
} else if (card == 0 || *left > window[card + 5]) {
if (size >= card + 2) {
i__1 = card + 2;
scardd_(&i__1, window);
window[card + 6] = *left;
window[card + 7] = *right;
} else {
excess_(&c__2, "window", (ftnlen)6);
sigerr_("SPICE(WINDOWEXCESS)", (ftnlen)19);
}
chkout_("WNINSD", (ftnlen)6);
return 0;
}
/* Now on to the tougher cases. */
/* Skip intervals which lie completely to the left of the input */
/* interval. (The index I will always point to the right endpoint */
/* of an interval). */
i__ = 2;
while(i__ <= card && window[i__ + 5] < *left) {
i__ += 2;
}
/* There are three ways this can go. The new interval can: */
/* 1) lie entirely between the previous interval and the next. */
/* 2) overlap the next interval, but no others. */
/* 3) overlap more than one interval. */
/* Only the first case can possibly cause an overflow, since the */
/* other two cases require existing intervals to be merged. */
/* Case (1). If there's room, move succeeding intervals back and */
/* insert the new one. If there isn't room, signal an error. */
if (*right < window[i__ + 4]) {
if (size >= card + 2) {
i__1 = i__ - 1;
for (j = card; j >= i__1; --j) {
window[j + 7] = window[j + 5];
}
i__1 = card + 2;
scardd_(&i__1, window);
window[i__ + 4] = *left;
window[i__ + 5] = *right;
} else {
excess_(&c__2, "window", (ftnlen)6);
sigerr_("SPICE(WINDOWEXCESS)", (ftnlen)19);
chkout_("WNINSD", (ftnlen)6);
return 0;
}
/* Cases (2) and (3). */
} else {
/* The left and right endpoints of the new interval may or */
/* may not replace the left and right endpoints of the existing */
/* interval. */
/* Computing MIN */
d__1 = *left, d__2 = window[i__ + 4];
window[i__ + 4] = min(d__1,d__2);
/* Computing MAX */
d__1 = *right, d__2 = window[i__ + 5];
window[i__ + 5] = max(d__1,d__2);
/* Skip any intervals contained in the one we modified. */
/* (Like I, J always points to the right endpoint of an */
/* interval.) */
j = i__ + 2;
while(j <= card && window[j + 5] <= window[i__ + 5]) {
j += 2;
}
/* If the modified interval extends into the next interval, */
/* merge the two. (The modified interval grows to the right.) */
if (j <= card && window[i__ + 5] >= window[j + 4]) {
window[i__ + 5] = window[j + 5];
j += 2;
}
/* Move the rest of the intervals forward to take up the */
/* spaces left by the absorbed intervals. */
while(j <= card) {
i__ += 2;
window[i__ + 4] = window[j + 4];
window[i__ + 5] = window[j + 5];
j += 2;
}
scardd_(&i__, window);
}
chkout_("WNINSD", (ftnlen)6);
return 0;
} /* wninsd_ */
/* $Procedure SYPOPD ( Pop a value from a particular symbol ) */
/* Subroutine */ int sypopd_(char *name__, char *tabsym, integer *tabptr,
doublereal *tabval, doublereal *value, logical *found, ftnlen
name_len, ftnlen tabsym_len)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer nval, nptr, nsym;
extern integer cardc_(char *, ftnlen), cardd_(doublereal *), cardi_(
integer *);
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern integer sumai_(integer *, integer *);
extern /* Subroutine */ int scardc_(integer *, char *, ftnlen), scardd_(
integer *, doublereal *), remlac_(integer *, integer *, char *,
integer *, ftnlen);
extern integer bsrchc_(char *, integer *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int remlad_(integer *, integer *, doublereal *,
integer *), scardi_(integer *, integer *), remlai_(integer *,
integer *, integer *, integer *);
integer locval;
extern /* Subroutine */ int chkout_(char *, ftnlen);
integer locsym;
extern logical return_(void);
/* $ Abstract */
/* Pop a value associated with a particular symbol in a double */
/* precision symbol table. The first value associated with the */
/* symbol is removed, and subsequent values are moved forward. */
/* $ 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 */
/* SYMBOLS */
/* $ Keywords */
/* SYMBOLS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* NAME I Name of the symbol whose associated value is to be */
/* popped. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL I/O Components of the symbol table. */
/* VALUE O Value that was popped. */
/* FOUND O True if the symbol exists, false if it does not. */
/* $ Detailed_Input */
/* NAME is the name of the symbol whose associated value is to */
/* be popped. If NAME is not in the symbol table, FOUND is */
/* false. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL are the components of a double precision symbol table. */
/* $ Detailed_Output */
/* TABSYM, */
/* TABPTR, */
/* TABVAL are the components of a double precision symbol table. */
/* The value is removed from the symbol table, and the */
/* remaining values associated with the symbol are moved */
/* forward in the value table. If no other values are */
/* associated with the symbol, the symbol is removed from */
/* the symbol table. */
/* VALUE is the value that was popped. This value was the first */
/* value in the symbol table that was associated with the */
/* symbol NAME. */
/* FOUND is true if NAME is in the symbol table, otherwise */
/* it is false. */
/* $ Parameters */
/* None. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Particulars */
/* If there are no remaining values associated with the symbol */
/* after VALUE has been popped, the symbol is removed from the */
/* symbol table. */
/* $ Examples */
/* The contents of the symbol table are: */
/* BODY4_POLE_RA --> 3.17681D2 */
/* 1.08D-1 */
/* 0.0D0 */
/* DELTA_T_A --> 3.2184D1 */
/* K --> 1.657D-3 */
/* MEAN_ANOM --> 6.239996D0 */
/* 1.99096871D-7 */
/* ORBIT_ECC --> 1.671D-2 */
/* The call, */
/* CALL SYPOPD ( 'MEAN_ANOM', TABSYM, TABPTR, TABVAL, VALUE, FOUND ) */
/* modifies the contents of the symbol table to be: */
/* BODY4_POLE_RA --> 3.17681D2 */
/* 1.08D-1 */
/* 0.0D0C */
/* DELTA_T_A --> 3.2184D1 */
/* K --> 1.657D-3 */
/* MEAN_ANOM --> 1.99096871D-7 */
/* ORBIT_ECC --> 1.671D-2 */
/* FOUND is TRUE, and VALUE is 6.239996D0. */
/* The next call, */
/* CALL SYPOPD ( 'K', TABSYM, TABPTR, TABVAL, VALUE, FOUND ) */
/* modifies the contents of the symbol table to be: */
/* BODY4_POLE_RA --> 3.17681D2 */
/* 1.08D-1 */
/* 0.0D0C */
/* DELTA_T_A --> 3.2184D1 */
/* MEAN_ANOM --> 1.99096871D-7 */
/* ORBIT_ECC --> 1.671D-2 */
/* FOUND is TRUE, and VALUE is 1.657D-3. Note that because */
/* "K" had only one value associated with it, it was removed */
/* from the symbol table. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) (HAN) */
/* -& */
/* $ Index_Entries */
/* pop a value from a particular symbol */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SYPOPD", (ftnlen)6);
}
/* How many symbols to start with? */
nsym = cardc_(tabsym, tabsym_len);
nptr = cardi_(tabptr);
nval = cardd_(tabval);
/* Is this symbol even in the table? */
locsym = bsrchc_(name__, &nsym, tabsym + tabsym_len * 6, name_len,
tabsym_len);
/* If it's not in the table, it's definitely a problem. */
if (locsym == 0) {
*found = FALSE_;
/* If it is in the table, we can proceed without fear of overflow. */
} else {
*found = TRUE_;
/* Begin by saving and removing the initial value for this */
/* symbol from the value table. */
i__1 = locsym - 1;
locval = sumai_(&tabptr[6], &i__1) + 1;
*value = tabval[locval + 5];
remlad_(&c__1, &locval, &tabval[6], &nval);
scardd_(&nval, tabval);
/* If this was the sole value for the symbol, remove the */
/* symbol from the name and pointer tables. Otherwise just */
/* decrement the dimension. */
if (tabptr[locsym + 5] == 1) {
remlac_(&c__1, &locsym, tabsym + tabsym_len * 6, &nsym,
tabsym_len);
scardc_(&nsym, tabsym, tabsym_len);
remlai_(&c__1, &locsym, &tabptr[6], &nptr);
scardi_(&nptr, tabptr);
} else {
--tabptr[locsym + 5];
}
}
chkout_("SYPOPD", (ftnlen)6);
return 0;
} /* sypopd_ */
/* $Procedure SETD ( Compare double precision sets ) */
logical setd_(doublereal *a, char *op, doublereal *b, ftnlen op_len)
{
/* System generated locals */
logical ret_val;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer cond, carda, cardb;
extern integer cardd_(doublereal *);
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
integer condab, condoa, condob, indexa, condeq, indexb, condgt, condlt;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Given a relational operator, compare two double precision sets. */
/* $ 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 */
/* CELLS, SETS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* A I First set. */
/* OP I Comparison operator. */
/* B I Second set. */
/* The function returns the result of the comparison: A (OP) B. */
/* $ Detailed_Input */
/* A is a set. */
/* OP is a comparison operator, indicating the way in */
/* which the input sets are to be compared. OP may */
/* be any of the following: */
/* Operator Meaning */
/* -------- ------------------------------------- */
/* '=' A = B is true if A and B are equal */
/* (contain the same elements). */
/* '<>' A <> B is true if A and B are not */
/* equal. */
/* '<=' A <= B is true if A is a subset of B. */
/* '<' A < B is true if A is a proper subset */
/* of B. */
/* '>=' A >= B is true if B is a subset of A. */
/* '>' A > B is true if B is a proper subset */
/* of A. */
/* '&' A & B is true if A and B have one or */
/* more elements in common. (The */
/* intersection of the two sets in */
/* non-empty.) */
/* '~' A ~ B is true if A and B are disjoint */
/* sets. */
/* B is a set. */
/* $ Detailed_Output */
/* The function returns the result of the comparison: A (OP) B. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* 1) In the following example, SETx is used to repeat an operation */
/* for as long as the integer set FINISHED remains a proper */
/* subset of the integer set PLANNED. */
/* DO WHILE ( SETx ( FINISHED, '<', PLANNED ) ) */
/* . */
/* . */
/* END DO */
/* 2) In the following example, let the integer sets A, B, and C */
/* contain the elements listed below. Let E be an empty integer */
/* set. */
/* A B C */
/* --- --- --- */
/* 1 1 1 */
/* 2 3 3 */
/* 3 */
/* 4 */
/* Then all of the following expressions are true. */
/* SETI ( B, '=', C ) "B is equal to C" */
/* SETI ( A, '<>', C ) "A is not equal to C" */
/* SETI ( A, '>', B ) "A is a proper superset of B" */
/* SETI ( B, '<=', C ) "B is a subset of C" */
/* SETI ( C, '<=', B ) "C is a subset of B" */
/* SETI ( A, '<=', A ) "A is a subset of A" */
/* SETI ( E, '<=', B ) "E is a subset of B" */
/* SETI ( E, '<', B ) "E is a proper subset of B" */
/* SETI ( E, '<=', E ) "E is a subset of E" */
/* SETI ( A, '&', B ) "A has elements in common with B." */
/* SETI ( B, '&', C ) "B has elements in common with C." */
/* And all of the following are false. */
/* SETI ( B, '<>', C ) "B is not equal to C" */
/* SETI ( A, '=', C ) "A is equal to C" */
/* SETI ( A, '<', B ) "A is a proper subset of B" */
/* SETI ( B, '<', C ) "B is a proper subset of C" */
/* SETI ( B, '>=', A ) "B is a superset of A" */
/* SETI ( A, '>', A ) "A is a proper superset of A" */
/* SETI ( E, '>=', A ) "E is a superset of A" */
/* SETI ( E, '<', E ) "E is a proper subset of E" */
/* SETI ( A, '~', B ) "A and B are disjoint sets." */
/* $ Restrictions */
/* None. */
/* $ Exceptions */
/* If the set relational operator is not recognized, the error */
/* SPICE(INVALIDOPERATION) is signalled. */
/* $ Files */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (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, 31-JAN-1990 (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* compare d.p. sets */
/* -& */
/* $ Revisions */
/* - Beta Version 2.0.0, 11-JAN-1989 (WLT) (HAN) */
/* The old version was not compatible with the error handling */
/* mechanism. Taking the difference of sets A and B caused an */
/* overflow of the set DIFF, whose dimension was one. The method of */
/* determining the function value has been redesigned, and the */
/* difference of the sets is no longer computed. */
/* The new routine recognizes two new operators, '~' and '&'. */
/* If the operator is not recognized, an error is now signalled. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
ret_val = FALSE_;
return ret_val;
} else {
chkin_("SETD", (ftnlen)4);
ret_val = FALSE_;
}
/* Obtain the cardinality of the sets. */
carda = cardd_(a);
cardb = cardd_(b);
/* The easiest way to compare two sets is to list them side by side */
/* as shown below: */
/* Set A Set B */
/* ----- ----- */
/* 1 1 */
/* 2 */
/* 3 3 */
/* 4 4 */
/* 5 */
/* 6 */
/* 7 7 */
/* When listed this way, one can easily determine intersections, */
/* differences, and unions. Moreover, to determine if one set */
/* is a subset of another, if they are equal, etc, one can just */
/* inspect the two lists. */
/* We can mimick this in an algorithm. The main trick is to figure */
/* out how to list the sets in this way. Once we know how to */
/* list them, we can simply adapt the listing algorithm to get */
/* a comparison algorithm. */
/* By the time we get this far, we know that our sets have distinct */
/* elements and they are ordered. To write out the list above, */
/* we start at the beginning of both sets (they're ordered, */
/* remember?). Look at the next element of A and the next element */
/* of B ( to start out ``next'' means ``first'' ). If the item */
/* from A is smaller it should be written and space should be left */
/* in the B column. If they are the same write them both. Otherwise, */
/* the item from B is smaller, so leave space in the A column and */
/* write the item from B. Continue until you run out of items in */
/* one of the sets. Then just write down all those remaining in the */
/* other set in the appropriate column. This is what the loop */
/* below does. */
/* NEXTA = 1 */
/* NEXTB = 1 */
/* DO WHILE ( ( NEXTA .LT. CARD(A) ) */
/* . .AND. ( NEXTB .LT. CARD(B) ) ) */
/* IF ( A(NEXTA) .LT. B(NEXTB) ) THEN */
/* WRITE (UNIT,*) A(NEXTA), SPACES */
/* NEXTA = NEXTA + 1 */
/* ELSE IF ( A(NEXTA) .EQ. B(NEXTB) ) THEN */
/* WRITE (UNIT,*) A(NEXTA), B(NEXTB) */
/* NEXTA = NEXTA + 1 */
/* NEXTB = NEXTB + 1 */
/* ELSE */
/* WRITE (UNIT,*) SPACES, B(NEXTB) */
/* NEXTB = NEXTB + 1 */
/* END IF */
/* END DO */
/* DO NEXTA = 1, CARD(A) */
/* WRITE (UNIT,*) A(NEXTA),SPACES */
/* END DO */
/* DO NEXTB = 1, CARD(B) */
/* WRITE (UNIT,*) B(NEXTB),SPACES */
/* END DO */
/* This also gives us a way to compare the elements of the two */
/* sets one item at a time. Instead of writing the items, we */
/* can make a decision as to whether or not the sets have the */
/* relationship we are interested in. */
/* At the beginning of the loop we assume that the two sets are */
/* related in the way we want. Once the comparison has been made */
/* we can decide if they are still related in that way. If not, */
/* we can RETURN .FALSE. Using psuedo-code the loop is modified */
/* as shown below. */
/* NEXTA = 1 */
/* NEXTB = 1 */
/* DO WHILE ( ( NEXTA .LT. CARD(A) ) */
/* . .AND. ( NEXTB .LT. CARD(B) ) ) */
/* IF ( A(NEXTA) .LT. B(NEXTB) ) THEN */
/* RELATED = RELATIONSHIP_OF_INTEREST(A<B) */
/* NEXTA = NEXTA + 1 */
/* ELSE IF ( A(NEXTA) .EQ. B(NEXTB) ) THEN */
/* RELATED = RELATIONSHIP_OF_INTEREST(A=B) */
/* NEXTA = NEXTA + 1 */
/* NEXTB = NEXTB + 1 */
/* ELSE */
/* RELATED = RELATIONSHIP_OF_INTEREST(A>B) */
/* NEXTB = NEXTB + 1 */
/* END IF */
/* IF ( SURE_NOW(RELATED) ) THEN */
/* RETURN with the correct value. */
/* ELSE */
/* Keep going. */
/* END IF */
/* END DO */
/* Using the cardinality of the two sets, some function */
/* values can be determined right away. If the cardinality */
/* is not enough, we need to set up some conditions for the */
/* loop which compares the individual elements of the sets. */
/* A cannot be a proper subset of B if the cardinality of A is */
/* greater than or equal to the cardinality of B. */
if (s_cmp(op, "<", op_len, (ftnlen)1) == 0) {
if (carda >= cardb) {
ret_val = FALSE_;
chkout_("SETD", (ftnlen)4);
return ret_val;
} else {
condlt = 0;
condeq = 1;
condgt = 1;
condoa = 0;
condob = 1;
condab = 1;
}
/* A cannot be a subset of B if A contains more elements than B. */
} else if (s_cmp(op, "<=", op_len, (ftnlen)2) == 0) {
if (carda > cardb) {
ret_val = FALSE_;
chkout_("SETD", (ftnlen)4);
return ret_val;
} else {
condlt = 0;
condeq = 1;
condgt = 1;
condoa = 0;
condob = 1;
condab = 1;
}
/* If the cardinality of the two sets is not equal, there's no way */
/* that the two sets could be equal. */
} else if (s_cmp(op, "=", op_len, (ftnlen)1) == 0) {
if (carda != cardb) {
ret_val = FALSE_;
chkout_("SETD", (ftnlen)4);
return ret_val;
} else {
condlt = 0;
condeq = 1;
condgt = 0;
condoa = 0;
condob = 0;
condab = 1;
}
/* If the cardinality of the two sets is not equal, the sets */
/* are not equal. */
} else if (s_cmp(op, "<>", op_len, (ftnlen)2) == 0) {
if (carda != cardb) {
ret_val = TRUE_;
chkout_("SETD", (ftnlen)4);
return ret_val;
} else {
condlt = 2;
condeq = 1;
condgt = 2;
condoa = 0;
condob = 0;
condab = 0;
}
/* B cannot be a proper subset of A if the cardinality of A is less */
/* than or equal to the cardinality of B. */
} else if (s_cmp(op, ">", op_len, (ftnlen)1) == 0) {
if (carda <= cardb) {
ret_val = FALSE_;
chkout_("SETD", (ftnlen)4);
return ret_val;
} else {
condlt = 1;
condeq = 1;
condgt = 0;
condoa = 1;
condob = 0;
condab = 1;
}
/* B cannot be a subset of A if B contains more elements than A. */
} else if (s_cmp(op, ">=", op_len, (ftnlen)2) == 0) {
if (carda < cardb) {
ret_val = FALSE_;
chkout_("SETD", (ftnlen)4);
return ret_val;
} else {
condlt = 1;
condeq = 1;
condgt = 0;
condoa = 1;
condob = 0;
condab = 1;
}
/* If the cardinality of one of the sets is zero, they can't */
/* possibly have any elements in common. */
} else if (s_cmp(op, "&", op_len, (ftnlen)1) == 0) {
if (carda == 0 || cardb == 0) {
ret_val = FALSE_;
chkout_("SETD", (ftnlen)4);
return ret_val;
} else {
condlt = 1;
condeq = 2;
condgt = 1;
condoa = 0;
condob = 0;
}
/* If either A or B is the null set, the two sets are disjoint. */
} else if (s_cmp(op, "~", op_len, (ftnlen)1) == 0) {
if (carda == 0 || cardb == 0) {
ret_val = TRUE_;
chkout_("SETD", (ftnlen)4);
return ret_val;
} else {
condlt = 1;
condeq = 0;
condgt = 1;
condoa = 1;
condob = 1;
}
/* If the relational operator is not recognized, signal an */
/* error. */
} else {
setmsg_("Relational operator, *, is not recognized.", (ftnlen)42);
errch_("*", op, (ftnlen)1, op_len);
sigerr_("SPICE(INVALIDOPERATION)", (ftnlen)23);
chkout_("SETD", (ftnlen)4);
return ret_val;
}
/* Initialize counters used for checking the elements of the sets. */
indexa = 1;
indexb = 1;
cond = 0;
/* If we've come this far we need to check the elements of the */
/* sets to determine the function value. */
while(indexa <= carda && indexb <= cardb) {
if (a[indexa + 5] < b[indexb + 5]) {
cond = condlt;
++indexa;
} else if (a[indexa + 5] == b[indexb + 5]) {
cond = condeq;
++indexa;
++indexb;
} else {
cond = condgt;
++indexb;
}
/* At this point, there are several cases which allow us to */
/* determine the function value without continuing to compare */
/* the elements of the sets: */
/* 1. If the operator is '~' and a common element was found, */
/* the sets are not disjoint ( COND = 0 ). */
/* 2. If the operator is '&' and a common element was found, */
/* the sets have at least one common element ( COND = 2 ). */
/* 3. If the sets are being compared for containment, and the */
/* first element of the "contained" set is less than the first */
/* element of the "containing" set, the "contained" set */
/* cannot be a subset of the "containing" set ( COND = 0 ). */
/* 4. If the operator is '=' and the elements being compared are */
/* not equal, the sets are not equal ( COND = 0 ). */
/* 5. If the operator is '<>' and the elements being compared are */
/* not equal, the sets are not equal ( COND = 2 ). */
if (cond == 0) {
ret_val = FALSE_;
chkout_("SETD", (ftnlen)4);
return ret_val;
} else if (cond == 2) {
ret_val = TRUE_;
chkout_("SETD", (ftnlen)4);
return ret_val;
}
}
/* We've exited the loop, so now we need to make a decision based on */
/* what's left over. */
/* We've gone through all of set B and there are elements left in */
/* A. */
if (indexa <= carda) {
cond = condoa;
/* We've gone through all of set A and there are elements left in */
/* B. */
} else if (indexb <= cardb) {
cond = condob;
/* We've gone through both the sets. */
} else {
cond = condab;
}
/* Determine the value of SETD from the results. */
ret_val = cond == 1;
chkout_("SETD", (ftnlen)4);
return ret_val;
} /* setd_ */
/* $Procedure ZZGFWSTS ( Private --- GF, sift first window thru second ) */
/* Subroutine */ int zzgfwsts_(doublereal *wndw1, doublereal *wndw2, char *
inclsn, doublereal *wndw3, ftnlen inclsn_len)
{
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
logical keep, left, open;
integer begp1, begp2, begp3, endp1, endp2, endp3, size1, size2;
extern integer cardd_(doublereal *);
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
logical right;
extern integer sized_(doublereal *);
extern /* Subroutine */ int scardd_(integer *, doublereal *);
char locinc[2];
logical closed;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), ssized_(integer *, doublereal *), setmsg_(char *, ftnlen)
, errint_(char *, integer *, ftnlen), cmprss_(char *, integer *,
char *, char *, ftnlen, ftnlen, ftnlen);
integer maxpts, ovflow;
extern logical return_(void);
/* $ Abstract */
/* SPICE Private routine intended solely for the support of SPICE */
/* routines. Users should not call this routine directly due */
/* to the volatile nature of this routine. */
/* Determine those intervals of the first window that are */
/* properly contained in an interval of the second. */
/* $ 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 */
/* INTERVALS, WINDOWS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- --------------------------------------------------- */
/* WNDW1 I Input window 1. */
/* WNDW2 I Input window 2. */
/* INCLSN I Flag indicating inclusion desired. */
/* WNDW3 I/O Result of sifting WNDW1 through WNDW2. */
/* $ Detailed_Input */
/* WNDW1 is an initialized SPICELIB window */
/* WNDW2 is an initialized SPICELIB window */
/* INCLSN is a string indicating how intervals of WNDW1 must */
/* be contained in WNDW2. Allowed values are: '[]', '(]', */
/* '[)', and '()', where a square bracket represents a */
/* closed interval and a curved bracket an open interval. */
/* Suppose that [a,b] is an interval of WNDW1 and that */
/* [c,d] is an interval of WNDW2. Then the table below */
/* shows the tests used to determine the inclusion of */
/* [a,b] in the interval from c to d. */
/* [] --- [a,b] is contained in [c,d] */
/* (] --- [a,b] is contained in (c,d] */
/* [) --- [a,b] is contained in [c,d) */
/* () --- [a,b] is contained in (c,d) */
/* if INCLSN is not one of these four values, the */
/* error SPICE(UNKNOWNINCLUSION) is signaled. */
/* WNDW3 is an initialized SPICELIB window, used on input */
/* only for the purpose of determining the amount */
/* of space declared for use in WNDW3. */
/* $ Detailed_Output */
/* WNDW3 is a window consisting those of intervals in WNDW1 */
/* that are wholly contained in some interval of WNDW2. */
/* $ Parameters */
/* LBCELL is the SPICELIB cell lower bound. */
/* $ Exceptions */
/* 1) If the window WNDW3 does not have sufficient space to */
/* contain the sifting of WNDW1 through WNDW2 the error */
/* 'SPICE(OUTOFROOM)' is signaled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine allows the user to specify two closed subsets of the */
/* real line and to find the intervals of one that are contained */
/* within the intervals of another. The subsets of the real line */
/* are assumed to be made up of disjoint unions of closed intervals. */
/* $ Examples */
/* Suppose that WNDW1 and WNDW2 are described by the tables below. */
/* WNDW1 WNDW2 */
/* 12.3 12.8 11.7 13.5 */
/* 17.8 20.4 17.2 18.3 */
/* 21.4 21.7 18.5 22.6 */
/* 38.2 39.8 40.1 45.6 */
/* 44.0 59.9 */
/* Then WNDW3 will be given by: */
/* WNDW3 */
/* 12.3 12.8 */
/* 21.4 21.7 */
/* $ Restrictions */
/* The set WNDW3 must not overwrite WNDW1 or WNDW2. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* L.S. Elson (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.1, 08-DEC-2010 (EDW) */
/* Edit to replaced term "schedule" with "window." */
/* - SPICELIB Version 1.0.0, 05-MAR-2009 (NJB) (LSE) (WLT) */
/* -& */
/* $ Index_Entries */
/* find window intervals contained in an interval of another */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local Variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
chkin_("ZZGFWSTS", (ftnlen)8);
/* Store the maximum number of endpoints that can be loaded into */
/* WNDW3 */
maxpts = sized_(wndw3);
ssized_(&maxpts, wndw3);
/* Find the number of endpoints in each of the input windows. */
size1 = cardd_(wndw1);
size2 = cardd_(wndw2);
/* Initialize the place holders for each of the input windows. */
begp1 = 1;
begp2 = 1;
endp1 = 2;
endp2 = 2;
begp3 = -1;
endp3 = 0;
cmprss_(" ", &c__0, inclsn, locinc, (ftnlen)1, inclsn_len, (ftnlen)2);
open = s_cmp(locinc, "()", (ftnlen)2, (ftnlen)2) == 0;
left = s_cmp(locinc, "[)", (ftnlen)2, (ftnlen)2) == 0;
right = s_cmp(locinc, "(]", (ftnlen)2, (ftnlen)2) == 0;
closed = s_cmp(locinc, "[]", (ftnlen)2, (ftnlen)2) == 0;
if (! (open || left || right || closed)) {
setmsg_("The value of the inclusion flag must be one of the followin"
"g: '[]', '[)', '(]', or '()'. However the value supplied wa"
"s '#'. ", (ftnlen)126);
errch_("#", inclsn, (ftnlen)1, inclsn_len);
sigerr_("SPICE(UNKNOWNINCLUSION)", (ftnlen)23);
chkout_("ZZGFWSTS", (ftnlen)8);
return 0;
}
/* We haven't had a chance to overflow yet. */
ovflow = 0;
while(begp1 < size1 && begp2 < size2) {
/* Using the current interval endpoints determine the overlap of */
/* the two intervals. */
if (wndw1[endp1 + 5] < wndw2[begp2 + 5]) {
/* the end of the first interval precedes the beginning of the */
/* second */
begp1 += 2;
endp1 += 2;
} else if (wndw2[endp2 + 5] < wndw1[begp1 + 5]) {
/* the end of the second interval precedes the beginning of the */
/* first */
begp2 += 2;
endp2 += 2;
} else {
/* the intervals intersect. Is the first contained in the */
/* second? */
if (closed) {
keep = wndw1[begp1 + 5] >= wndw2[begp2 + 5] && wndw1[endp1 +
5] <= wndw2[endp2 + 5];
} else if (open) {
keep = wndw1[begp1 + 5] > wndw2[begp2 + 5] && wndw1[endp1 + 5]
< wndw2[endp2 + 5];
} else if (left) {
keep = wndw1[begp1 + 5] >= wndw2[begp2 + 5] && wndw1[endp1 +
5] < wndw2[endp2 + 5];
} else if (right) {
keep = wndw1[begp1 + 5] > wndw2[begp2 + 5] && wndw1[endp1 + 5]
<= wndw2[endp2 + 5];
}
if (keep) {
begp3 += 2;
endp3 += 2;
if (begp3 < maxpts) {
/* Adequate room is left in WNDW3 to include this */
/* interval */
wndw3[begp3 + 5] = wndw1[begp1 + 5];
wndw3[endp3 + 5] = wndw1[endp1 + 5];
} else {
ovflow += 2;
}
}
/* Determine which window pointers to increment */
if (wndw1[endp1 + 5] < wndw2[endp2 + 5]) {
/* The first interval lies before the end of the second */
begp1 += 2;
endp1 += 2;
} else if (wndw2[endp2 + 5] < wndw1[endp1 + 5]) {
/* The second interval lies before the end of the first */
begp2 += 2;
endp2 += 2;
} else {
/* The first and second intervals end at the same place */
begp1 += 2;
endp1 += 2;
begp2 += 2;
endp2 += 2;
}
}
}
if (ovflow > 0) {
setmsg_("The output window does not have sufficient memory to contai"
"n the result of sifting the two given windows. The output wi"
"ndow requires space for # more values than what has been pro"
"vided. ", (ftnlen)186);
errint_("#", &ovflow, (ftnlen)1);
sigerr_("SPICE(OUTOFROOM)", (ftnlen)16);
} else {
scardd_(&endp3, wndw3);
}
chkout_("ZZGFWSTS", (ftnlen)8);
return 0;
} /* zzgfwsts_ */
/* $Procedure REMOVD ( Remove an item from a double precision set ) */
/* Subroutine */ int removd_(doublereal *item, doublereal *a)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer card, i__;
extern integer cardd_(doublereal *);
extern /* Subroutine */ int chkin_(char *, ftnlen);
logical in;
extern /* Subroutine */ int scardd_(integer *, doublereal *);
extern integer bsrchd_(doublereal *, integer *, doublereal *);
extern /* Subroutine */ int chkout_(char *, ftnlen);
extern logical return_(void);
integer loc;
/* $ Abstract */
/* Remove an item from a double precision 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 */
/* SETS */
/* $ Keywords */
/* CELLS, SETS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ITEM I Item to be removed. */
/* A I/O Removal set. */
/* ERROR O Error flag. */
/* $ Detailed_Input */
/* ITEM is an item which is to be removed from the */
/* specified set. ITEM may or may not already */
/* be an element of the set. */
/* A is a set. */
/* On input, A may or may not contain the input item */
/* as an element. */
/* $ Detailed_Output */
/* A on output contains the difference of the input set */
/* and the input item. If the item is not an element of */
/* the set, the set is not changed. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* In the following example, the element 'PLUTO' is removed from */
/* the character set PLANETS and inserted into the character set */
/* ASTEROIDS. */
/* CALL REMOVC ( 'PLUTO', PLANETS ) */
/* CALL INSRTC ( 'PLUTO', ASTEROIDS, ERROR ) */
/* If 'PLUTO' is not an element of PLANETS, then the contents of */
/* PLANETS are not changed. Similarly, if 'PLUTO' is already an */
/* element of ASTEROIDS, the contents of ASTEROIDS remain unchanged. */
/* Because inserting an element into a set can increase the */
/* cardinality of the set, the insertion routines return an */
/* error flag. The flag is blank if the set is large enough to */
/* hold the new element. Otherwise, a message (constructed by */
/* the cell routine EXCESS) is returned. */
/* $ Restrictions */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Files */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* C.A. Curzon (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (CAC) (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* remove an item from a d.p. set */
/* -& */
/* $ Revisions */
/* - Beta Version 2.0.0, 13-MAR-1989 (NJB) */
/* Now participates in error handling. References to RETURN, */
/* CHKIN, and CHKOUT added. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard error handling: */
if (return_()) {
return 0;
} else {
chkin_("REMOVD", (ftnlen)6);
}
/* What is the cardinality of the set? */
card = cardd_(a);
/* Determine the location (if any) of the item within the set. */
loc = bsrchd_(item, &card, &a[6]);
/* Is the item in the set? If so, it needs to be removed. */
in = loc > 0;
if (in) {
/* Move succeeding elements forward to take up the slack left */
/* by the departing element. And update the cardinality for */
/* future reference. */
i__1 = card - 1;
for (i__ = loc; i__ <= i__1; ++i__) {
a[i__ + 5] = a[i__ + 6];
}
i__1 = card - 1;
scardd_(&i__1, a);
}
chkout_("REMOVD", (ftnlen)6);
return 0;
} /* removd_ */
/* $Procedure WNEXTD ( Extract the endpoints from a DP window ) */
/* Subroutine */ int wnextd_(char *side, doublereal *window, ftnlen side_len)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer card, i__;
extern integer cardd_(doublereal *);
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen), sigerr_(char *, ftnlen), chkout_(char *, ftnlen)
, setmsg_(char *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Extract the left or right endpoints from a double precision */
/* window. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* WINDOWS */
/* $ Keywords */
/* WINDOWS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* SIDE I Extract left ('L') or right ('R') endpoints. */
/* WINDOW I,O Window to be extracted. */
/* $ Detailed_Input */
/* SIDE indicates whether the left or right endpoints of */
/* the intervals in the window are to be extracted. */
/* 'L', 'l' Left endpoints. */
/* 'R', 'r' Right endpoints. */
/* If SIDE is not recognized, the input window is */
/* not changed. */
/* WINDOW on input, is a window containing zero or more */
/* intervals. */
/* $ Detailed_Output */
/* WINDOW on output, is the collection of singleton intervals */
/* containing either the left or the right endpoints */
/* of the intervals in the original window. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* This routine replaces every interval in the input window with */
/* the singleton interval containing one of the endpoints of the */
/* interval. */
/* $ Examples */
/* Let WINDOW contain the intervals */
/* [ 1, 3 ] [ 7, 11 ] [ 23, 27 ] [ 29, 29 ] */
/* Then the call */
/* CALL WNEXTD ( 'L', WINDOW ) */
/* produces the window */
/* [ 1, 1 ] [ 7, 7 ] [ 23, 23 ] [ 29, 29 ] */
/* And the call */
/* CALL WNEXTD ( 'R', WINDOW ) */
/* produces the window */
/* [ 3, 3 ] [ 11, 11 ] [ 27, 27 ] [ 29, 29 ] */
/* $ Exceptions */
/* 1) If the endpoint specification, SIDE, is not recognized, the */
/* error SPICE(INVALIDENDPNTSPEC) is signalled. */
/* $ Files */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* extract the endpoints from a d.p. window */
/* -& */
/* $ Revisions */
/* - Beta Version 1.2.0, 24-FEB-1989 (HAN) */
/* Added calls to CHKIN and CHKOUT. Error handling was added to */
/* detect invalid endpoint specification. The previous version */
/* did not signal an error if SIDE was not 'R', 'r', 'L', or 'l'. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("WNEXTD", (ftnlen)6);
}
/* Get the cardinality of the window. (The size is not important; */
/* this routine can't create any new intervals.) */
card = cardd_(window);
/* Step through the window, keeping one endpoint from each interval. */
/* For the sake of efficiency, we have separate loops for the two */
/* possible values of SIDE. */
if (*(unsigned char *)side == 'L' || *(unsigned char *)side == 'l') {
i__1 = card;
for (i__ = 1; i__ <= i__1; i__ += 2) {
window[i__ + 6] = window[i__ + 5];
}
} else if (*(unsigned char *)side == 'R' || *(unsigned char *)side == 'r')
{
i__1 = card;
for (i__ = 1; i__ <= i__1; i__ += 2) {
window[i__ + 5] = window[i__ + 6];
}
} else {
setmsg_("SIDE was *.", (ftnlen)11);
errch_("*", side, (ftnlen)1, (ftnlen)1);
sigerr_("SPICE(INVALIDENDPNTSPEC)", (ftnlen)24);
}
chkout_("WNEXTD", (ftnlen)6);
return 0;
} /* wnextd_ */
/* $Procedure WNCARD ( Cardinality of a double precision window ) */
integer wncard_(doublereal *window)
{
/* System generated locals */
integer ret_val;
/* Local variables */
extern logical even_(integer *);
extern integer cardd_(doublereal *);
extern /* Subroutine */ int chkin_(char *, ftnlen), sigerr_(char *,
ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen),
errint_(char *, integer *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Return the cardinality (number of intervals) of a double */
/* precision window. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* WINDOWS */
/* $ Keywords */
/* WINDOWS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* WINDOW I Input window. */
/* The function returns the cardinality of the input window. */
/* $ Detailed_Input */
/* WINDOW is a window containing zero or more intervals. */
/* $ Detailed_Output */
/* The function returns the cardinality of (number of intervals in) */
/* the input window. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the number of elements in WINDOW is not even */
/* the error SPICE(INVALIDSIZE) signals. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The window cardinality (WNCARD) function simply wraps a CARD call */
/* then divides the result by 2. A common error when using the SPICE */
/* windows function is to use the CARDD value as the number of */
/* window intervals rather than the CARDD/2 value. */
/* $ Examples */
/* INTEGER LBCELL */
/* PARAMETER ( LBCELL = -5 ) */
/* INTEGER WNSIZE */
/* PARAMETER ( WNSIZE = 10 ) */
/* DOUBLE PRECISION WINDOW ( LBCELL:WNSIZE ) */
/* DOUBLE PRECISION LEFT */
/* DOUBLE PRECISION RIGHT */
/* INTEGER WNCARD */
/* INTEGER I */
/* Validate the window with size WNSIZE and zero elements. */
/* CALL WNVALD( WNSIZE, 0, WINDOW ) */
/* Insert the intervals */
/* [ 1, 3 ] [ 7, 11 ] [ 23, 27 ] */
/* into WINDOW. */
/* CALL WNINSD( 1.D0, 3.D0, WINDOW ) */
/* CALL WNINSD( 7.D0, 11.D0, WINDOW ) */
/* CALL WNINSD( 23.D0, 27.D0, WINDOW ) */
/* Loop over the number of intervals in WINDOW, output */
/* the LEFT and RIGHT endpoints for each interval. */
/* DO I=1, WNCARD(WINDOW) */
/* CALL WNFETD( WINDOW, I, LEFT, RIGHT ) */
/* WRITE(*,*) 'Interval', I, ' [', LEFT, RIGHT, ']' */
/* END DO */
/* The code outputs: */
/* Interval 1 [ 1. 3.] */
/* Interval 2 [ 7. 11.] */
/* Interval 3 [ 23. 27.] */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* E.D. Wright (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.1, 24-APR-2010 (EDW) */
/* Minor edit to code comments eliminating typo. */
/* - SPICELIB Version 1.0.0, 10-AUG-2007 (EDW) */
/* -& */
/* $ Index_Entries */
/* cardinality of a d.p. window */
/* -& */
/* SPICELIB functions */
if (return_()) {
ret_val = 0;
return ret_val;
} else {
chkin_("WNCARD", (ftnlen)6);
}
ret_val = cardd_(window);
/* Confirm the cardinality as an even integer. */
if (! even_(&ret_val)) {
setmsg_("Invalid window size, a window should have an even number of"
" elements. The size was #.", (ftnlen)85);
errint_("#", &ret_val, (ftnlen)1);
sigerr_("SPICE(INVALIDSIZE)", (ftnlen)18);
chkout_("WNCARD", (ftnlen)6);
ret_val = 0;
return ret_val;
}
/* Set return value. Cardinality in a SPICE window sense */
/* means the number of intervals, half the cell */
/* cardinality value. */
ret_val /= 2;
chkout_("WNCARD", (ftnlen)6);
return ret_val;
} /* wncard_ */
/* $Procedure SUMCK ( Summarize a CK file ) */
/* Subroutine */ int sumck_(integer *handle, char *binfnm, char *lpsfnm, char
*sclfnm, logical *logfil, integer *loglun, ftnlen binfnm_len, ftnlen
lpsfnm_len, ftnlen sclfnm_len)
{
/* Initialized data */
static char menutl[20] = "CK Summary Options ";
static char menuvl[20*6] = "QUIT " "Skip "
"ENTIRE_FILE " "BY_INSTRUMENT_ID " "BY_UTC_INTERVAL "
" " "BY_SCLK_INTERVAL ";
static char menutx[40*6] = "Quit, returning to main menu. "
"Skip " "Summarize entire fil"
"e. " "Summarize by NAIF instrument ID code. "
"Summarize by UTC time interval. " "Summarize by SCLK ti"
"me interval. ";
static char menunm[1*6] = "Q" "." "F" "I" "U" "S";
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen), s_wsle(cilist *), e_wsle(void), do_lio(integer *,
integer *, char *, ftnlen);
/* Local variables */
static logical done;
static char line[255];
extern /* Subroutine */ int sct2e_(integer *, doublereal *, doublereal *);
extern integer cardd_(doublereal *);
static doublereal beget;
static char segid[40];
extern /* Subroutine */ int chkin_(char *, ftnlen);
static char bsclk[32];
static doublereal endet;
static char esclk[32];
extern /* Subroutine */ int repmc_(char *, char *, char *, char *, ftnlen,
ftnlen, ftnlen, ftnlen);
static char separ[80];
static logical found;
extern /* Subroutine */ int repmi_(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen), ckgss_(char *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, integer *,
integer *, ftnlen), reset_(void);
static logical error;
extern /* Subroutine */ int ckwss_(integer *, char *, integer *, integer *
, integer *, integer *, doublereal *, doublereal *, ftnlen);
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int utc2et_(char *, doublereal *, ftnlen),
et2utc_(doublereal *, char *, integer *, char *, ftnlen, ftnlen),
daffna_(logical *);
extern logical failed_(void);
static integer segbad;
extern /* Subroutine */ int scdecd_(integer *, doublereal *, char *,
ftnlen), dafbfs_(integer *);
static integer segead;
static doublereal begscl;
extern /* Subroutine */ int scardd_(integer *, doublereal *), scencd_(
integer *, char *, doublereal *, ftnlen);
static logical segfnd;
static doublereal endscl;
static char begutc[32];
extern /* Subroutine */ int cnfirm_(char *, logical *, ftnlen), getchr_(
char *, char *, logical *, logical *, char *, ftnlen, ftnlen,
ftnlen);
static logical haveit;
static char endutc[32];
static integer segfrm;
static doublereal segbtm, segetm;
static integer instid, segins;
static doublereal segint[8];
static logical anyseg;
extern /* Subroutine */ int getint_(char *, integer *, logical *, logical
*, char *, ftnlen, ftnlen);
static char errmsg[320], option[20], sumsep[80];
extern logical return_(void);
static char fnmout[255], sclout[255];
static integer missin;
static char lpsout[255];
static integer menuop, segrts;
static char tmpstr[80];
static integer segtyp;
static doublereal intrvl[8], intsct[8];
static logical contnu, tryagn;
extern /* Subroutine */ int ssized_(integer *, doublereal *), writln_(
char *, integer *, ftnlen), getopt_(char *, integer *, char *,
char *, integer *, ftnlen, ftnlen, ftnlen), wninsd_(doublereal *,
doublereal *, doublereal *), wnintd_(doublereal *, doublereal *,
doublereal *);
static char typout[255];
extern /* Subroutine */ int chkout_(char *, ftnlen);
/* Fortran I/O blocks */
static cilist io___23 = { 0, 6, 0, 0, 0 };
static cilist io___24 = { 0, 6, 0, 0, 0 };
static cilist io___25 = { 0, 6, 0, 0, 0 };
static cilist io___26 = { 0, 6, 0, 0, 0 };
static cilist io___27 = { 0, 6, 0, 0, 0 };
static cilist io___28 = { 0, 6, 0, 0, 0 };
static cilist io___29 = { 0, 6, 0, 0, 0 };
static cilist io___30 = { 0, 6, 0, 0, 0 };
static cilist io___32 = { 0, 6, 0, 0, 0 };
static cilist io___33 = { 0, 6, 0, 0, 0 };
static cilist io___34 = { 0, 6, 0, 0, 0 };
static cilist io___36 = { 0, 6, 0, 0, 0 };
static cilist io___37 = { 0, 6, 0, 0, 0 };
static cilist io___38 = { 0, 6, 0, 0, 0 };
static cilist io___39 = { 0, 6, 0, 0, 0 };
static cilist io___41 = { 0, 6, 0, 0, 0 };
static cilist io___42 = { 0, 6, 0, 0, 0 };
static cilist io___43 = { 0, 6, 0, 0, 0 };
static cilist io___44 = { 0, 6, 0, 0, 0 };
static cilist io___46 = { 0, 6, 0, 0, 0 };
static cilist io___47 = { 0, 6, 0, 0, 0 };
static cilist io___48 = { 0, 6, 0, 0, 0 };
static cilist io___49 = { 0, 6, 0, 0, 0 };
static cilist io___51 = { 0, 6, 0, 0, 0 };
static cilist io___52 = { 0, 6, 0, 0, 0 };
static cilist io___53 = { 0, 6, 0, 0, 0 };
static cilist io___54 = { 0, 6, 0, 0, 0 };
static cilist io___56 = { 0, 6, 0, 0, 0 };
static cilist io___57 = { 0, 6, 0, 0, 0 };
static cilist io___58 = { 0, 6, 0, 0, 0 };
static cilist io___59 = { 0, 6, 0, 0, 0 };
static cilist io___60 = { 0, 6, 0, 0, 0 };
static cilist io___61 = { 0, 6, 0, 0, 0 };
static cilist io___62 = { 0, 6, 0, 0, 0 };
static cilist io___63 = { 0, 6, 0, 0, 0 };
static cilist io___65 = { 0, 6, 0, 0, 0 };
static cilist io___66 = { 0, 6, 0, 0, 0 };
static cilist io___67 = { 0, 6, 0, 0, 0 };
static cilist io___68 = { 0, 6, 0, 0, 0 };
static cilist io___70 = { 0, 6, 0, 0, 0 };
static cilist io___71 = { 0, 6, 0, 0, 0 };
static cilist io___72 = { 0, 6, 0, 0, 0 };
static cilist io___73 = { 0, 6, 0, 0, 0 };
static cilist io___75 = { 0, 6, 0, 0, 0 };
static cilist io___76 = { 0, 6, 0, 0, 0 };
static cilist io___77 = { 0, 6, 0, 0, 0 };
static cilist io___78 = { 0, 6, 0, 0, 0 };
static cilist io___80 = { 0, 6, 0, 0, 0 };
/* $ Abstract */
/* Summarize 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. */
/* $ Declarations */
/* Set the number of double precision components in an unpacked CK */
/* descriptor. */
/* Set the number of integer components in an unpacked CK descriptor. */
/* Set the size of a packed CK descriptor. */
/* Set the length of a CK segment identifier. */
/* Set the value for the lower bound of the CELL data type. */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle of the SPK file to be summarized. */
/* LOGFIL I Write the summary to a log file and to screen? */
/* LOGLUN I Logical unit connected to the log file. */
/* NDC P Number of d.p. components in SPK descriptor. */
/* NIC P Number of integer components in SPK descriptor. */
/* NC P Size of packed SPK descriptor. */
/* IDSIZ P Length of SPK segment identifier. */
/* LBCELL P Lower bound for the SPICELIB CELL data structure. */
/* $ Detailed_Input */
/* HANDLE is the integer handle of the CK file to be summarized. */
/* LOGFIL if TRUE means that the summary will be written to */
/* a log file as well as displayed on the terminal */
/* screen. Otherwise, the summary will not be written */
/* to a log file. */
/* LOGLUN is the logical unit connected to a log file to which */
/* the summary is to be written if LOGFIL is TRUE. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* NDC is the number of double precision components in an */
/* unpacked SPK descriptor. */
/* NIC is the number of integer components in an unpacked */
/* SPK descriptor. */
/* NC is the size of a packed SPK descriptor. */
/* IDSIZ is the length of an SPK segment identifier. */
/* LBCELL is the lower bound for the SPICELIB CELL data */
/* structure. */
/* $ Exceptions */
/* None. */
/* $ Files */
/* The CK file to be summarized is referred throughout this routine */
/* by its handle. The file should already be opened for read. */
/* $ Particulars */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* M.J. Spencer (JPL) */
/* J.E. McLean (JPL) */
/* R.E. Thurman (JPL) */
/* $ Version */
/* - Beta Version 5.0.0 21-JUL-1995 (KRG) */
/* Added several arguments to the call of this subroutine and */
/* made other modifications to allow it to perform its own */
/* formatting of the summary, including filenames and separators. */
/* - Beta Version 4.0.0 11-APR-1994 (KRG) */
/* Modified this routine to make use of new routines to get and */
/* format and write CK segment summaries. */
/* Added a missing $ Index_Entries header section. */
/* Fixed a few typos in the header. */
/* The routine DISPC is now obsolete. It is no longer used. */
/* - Beta Version 3.0.0 22-MAR-1993 (KRG) */
/* 1) Changed the names of the variables TOFILE and UNIT to LOGFIL */
/* and LOGLUN, respectively. */
/* 2) Updated the program to use the menuing subroutine GETOPT */
/* which removes the need for the routine QSUMC. Redesigned */
/* the case sructure of the code to facilitate the use of the */
/* menuing routine. */
/* 3) Rearranged some of thee initializations that were performed, */
/* moved several calls to SCARDD outside the main loop, etc. */
/* 5) Performed some general cleanup as deemed necessary. */
/* - Beta Version 2.1.0 20-NOV-1991 (MJS) */
/* Checked FAILED function in main loop. */
/* - Beta Version 2.0.0 17-JUN-1991 (JEM) */
/* 1. Added the arguments TOFILE and UNIT. Previously the */
/* summary was only displayed on the terminal screen. */
/* Now, if requested by TOFILE, the summary is also */
/* written to the file connected to UNIT. */
/* 2. A user may cancel a task selected in QSUMC and */
/* select another. */
/* - SPICELIB Version 1.1.0 31-AUG-1990 (JEM) */
/* This routine was updated due to changes in the CK and */
/* SCLK design. Also, several implementation-specific */
/* parameters were moved from the header to the local */
/* parameters section. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (RET) */
/* -& */
/* $ Index_Entries */
/* summarize the segments in a binary ck file */
/* -& */
/* $ Revisions */
/* - Beta Version 5.0.0 21-JUL-1995 (KRG) */
/* Added several arguments to the call of this subroutine and */
/* made other modifications to allow it to perform its own */
/* formatting of the summary, including filenames and separators. */
/* - Beta Version 4.0.0 11-APR-1994 (KRG) */
/* Modified this routine to make use of new routines to get and */
/* format and write CK segment summaries. */
/* Added a missing $ Index_Entries header section. */
/* Fixed a few typos in the header. */
/* The routine DISPC is now obsolete. It is no longer used. */
/* - Beta Version 3.0.0 22-MAR-1993 (KRG) */
/* 1) Changed the names of the variables TOFILE and UNIT to LOGFIL */
/* and LOGLUN, respectively. */
/* 2) Updated the program to use the menuing subroutine GETOPT */
/* which removes the need for the routine QSUMC. Redesigned */
/* the case sructure of the code to facilitate the use of the */
/* menuing routine. */
/* 3) Rearranged some of thee initializations that were performed, */
/* moved several calls to SCARDD outside the main loop, etc. */
/* 5) Performed some general cleanup as deemed necessary. */
/* - Beta Version 2.1.0 20-NOV-1991 (MJS) */
/* Checked FAILED function in main loop. In the previous version, */
/* if any time conversion produced an error, the summary would go */
/* in an endless loop. */
/* - Beta Version 2.0.0 22-MAY-1991 (JEM) */
/* 1. In addition to adding the arguments TOFILE and UNIT to */
/* the calling sequence, the following code changes were */
/* made. The two new arguments were added to the calling */
/* sequence of DISPC as well. If TOFILE is true, a */
/* description of the type of summary is written to the */
/* output file before calling DISPC to write the summary. */
/* If no segments are found, the message is written to the */
/* output file as well as the terminal screen when */
/* TOFILE is true. */
/* 2. QSUMC was changed. 'NONE' is now a possible task */
/* returned from QSUMC and means a task was selected, */
/* then cancelled. QSUMC is called repeatedly until the */
/* task returned is something other than NONE. In */
/* this way the user is able to select another task. */
/* - SPICELIB Version 1.1.0 31-AUG-1990 (JEM) */
/* This routine was updated to handle these changes to the */
/* C-kernel design: */
/* 1. Ephemeris time is no longer included in CK files. */
/* All data is associated with spacecraft clock time only. */
/* The segment descriptor no longer contains the */
/* start and stop ET. Thus, the number of double */
/* precision components (NDC) is now two instead of four. */
/* 2. Segments may now contain rate information, along with */
/* pointing data. The segment descriptor contains a flag */
/* that indicates whether or not the segment includes */
/* rate information. Thus, the number of integer */
/* components (NIC) is now six instead of five. */
/* This version of SUMCK converts encoded SCLK times to ET for */
/* comparison with input times which are converted from UTC to ET. */
/* This routine was also updated to handle these changes to the */
/* SCLK design: */
/* 1. The name of the routine that encodes spacecraft */
/* clock time was changed from ENSCLK to SCENCD, and */
/* the order of arguments in the calling sequence */
/* was changed. */
/* 2. Instrument ID codes are now negative integers to */
/* avoid conflict with other body id codes. */
/* The parameters that pertain to the CK file architecture, */
/* like the number of double precision components in the */
/* segment descriptor (NDC), were moved from the header */
/* to the local parameter section. These parameters are */
/* implementation specific. Further, the user is not invited */
/* to change them, nor are they needed in any argument */
/* declaration. Thus they do not belong in the header. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Set value for a separator */
/* Set up the instrument ID code prompt. */
/* Set up the spacecraft ID code prompt. */
/* Set up the SCLK time string prompt. */
/* Set up labels for various output things. */
/* Set up the UTC time string prompt. */
/* Set the length for a line of text. */
/* Set the length for an output line. */
/* Set the length for an error message. */
/* Set the length for a UTC time string. */
/* Set the precision for the fractional part of UTC times. */
/* Set a length for the option values. */
/* Set a length for the title of a menu. */
/* Set the length of the text description of an option on a menu. */
/* The number of options available on the main menu. */
/* Parameter for the standard output unit. */
/* Local variables */
/* Save everything to keep control happy. */
/* Initial Values */
/* Define the menu title ... */
/* Define the menu option values ... */
/* Define the menu descriptive text for each option ... */
/* Define the menu option names ... */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SUMCK", (ftnlen)5);
}
/* Initialize the separator. */
s_copy(separ, "*********************************************************"
"***********************", (ftnlen)80, (ftnlen)80);
/* Initialize the segment separator. */
s_copy(sumsep, "--------------------------------------------------------"
"------------------------", (ftnlen)80, (ftnlen)80);
/* Set the sizes of the window cells that we will use if the file */
/* is to be summarized by time. */
ssized_(&c__2, intrvl);
ssized_(&c__2, segint);
ssized_(&c__2, intsct);
/* Initialize a few things before we start. */
instid = 0;
done = FALSE_;
while(! done) {
/* Initialize those things we reuse on every iteration. */
contnu = TRUE_;
writln_(" ", &c__6, (ftnlen)1);
getopt_(menutl, &c__6, menunm, menutx, &menuop, (ftnlen)20, (ftnlen)1,
(ftnlen)40);
if (failed_()) {
contnu = FALSE_;
}
if (contnu) {
/* Perform all of the setup necessary to perform the summary. */
/* This include prompting for input values required, etc. */
repmc_("Summary for CK file: #", "#", binfnm, fnmout, (ftnlen)22,
(ftnlen)1, binfnm_len, (ftnlen)255);
repmc_("Leapseconds File : #", "#", lpsfnm, lpsout, (ftnlen)22,
(ftnlen)1, lpsfnm_len, (ftnlen)255);
repmc_("SCLK File : #", "#", sclfnm, sclout, (ftnlen)22,
(ftnlen)1, sclfnm_len, (ftnlen)255);
s_copy(option, menuvl + ((i__1 = menuop - 1) < 6 && 0 <= i__1 ?
i__1 : s_rnge("menuvl", i__1, "sumck_", (ftnlen)553)) *
20, (ftnlen)20, (ftnlen)20);
if (s_cmp(option, "QUIT", (ftnlen)20, (ftnlen)4) == 0) {
contnu = FALSE_;
done = TRUE_;
} else if (s_cmp(option, "ENTIRE_FILE", (ftnlen)20, (ftnlen)11) ==
0) {
/* Summarize the entire file. */
repmc_("Summary Type : #", "#", "Entire File", typout, (
ftnlen)22, (ftnlen)1, (ftnlen)11, (ftnlen)255);
} else if (s_cmp(option, "BY_INSTRUMENT_ID", (ftnlen)20, (ftnlen)
16) == 0) {
/* Summarize for a specified body. */
/* First, we need to get the instrument ID code. */
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___23);
e_wsle();
s_wsle(&io___24);
do_lio(&c__9, &c__1, "Enter the desired NAIF instrument "
"code.", (ftnlen)39);
e_wsle();
s_wsle(&io___25);
e_wsle();
getint_("Instrument ID code? ", &instid, &haveit, &error,
errmsg, (ftnlen)20, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___26);
e_wsle();
s_wsle(&io___27);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___28);
e_wsle();
s_wsle(&io___29);
do_lio(&c__9, &c__1, "A NAIF instrument ID code "
"must be entered for this option.", (
ftnlen)58);
e_wsle();
}
if (! haveit || error) {
s_wsle(&io___30);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)
20);
if (! tryagn) {
contnu = FALSE_;
}
}
} else {
tryagn = FALSE_;
}
}
/* Write the type of summary to the log file if we need to. */
if (contnu) {
s_copy(tmpstr, "By Instrument ID #", (ftnlen)80, (ftnlen)
18);
repmc_("Summary Type : #", "#", tmpstr, typout, (
ftnlen)22, (ftnlen)1, (ftnlen)80, (ftnlen)255);
repmi_(typout, "#", &instid, typout, (ftnlen)255, (ftnlen)
1, (ftnlen)255);
}
} else if (s_cmp(option, "BY_UTC_INTERVAL", (ftnlen)20, (ftnlen)
15) == 0) {
/* Summarize for given UTC time interval. */
/* First, we need to get the UTC time string for the */
/* begin time. */
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___32);
e_wsle();
s_wsle(&io___33);
do_lio(&c__9, &c__1, "Enter the desired beginning UTC ti"
"me.", (ftnlen)37);
e_wsle();
s_wsle(&io___34);
e_wsle();
getchr_("UTC time? ", begutc, &haveit, &error, errmsg, (
ftnlen)10, (ftnlen)32, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___36);
e_wsle();
s_wsle(&io___37);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___38);
e_wsle();
s_wsle(&io___39);
do_lio(&c__9, &c__1, "A beginning UTC time strin"
"g must be entered for this option.", (
ftnlen)60);
e_wsle();
}
} else {
tryagn = FALSE_;
}
/* We now have the beginning time in UTC, so attempt */
/* to convert it to ET. If the conversion fails, we */
/* need to immediately reset the error handling so that */
/* we can continue processing. Remember, we are in a */
/* menuing subroutine, and we are not allowed to exit */
/* on an error: we must go back to the menu. thus the */
/* need for a resetting of the error handler here. If */
/* we got to here, there were no errors, so as long as */
/* we maintain that status, everything will be hunky */
/* dory. We also convert the ET back into UTC to get */
/* a consistent format for display. */
if (haveit) {
utc2et_(begutc, &beget, (ftnlen)32);
et2utc_(&beget, "C", &c__3, begutc, (ftnlen)1, (
ftnlen)32);
if (failed_()) {
reset_();
error = TRUE_;
}
}
/* Check to see if they want to try and enter the */
/* beginning UTC time string again. */
if (! haveit || error) {
s_wsle(&io___41);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)20);
if (! tryagn) {
contnu = FALSE_;
}
}
}
/* Now, if we can, we need to get the UTC time string for */
/* the end time. */
if (contnu) {
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___42);
e_wsle();
s_wsle(&io___43);
do_lio(&c__9, &c__1, "Enter the desired ending UTC t"
"ime.", (ftnlen)34);
e_wsle();
s_wsle(&io___44);
e_wsle();
getchr_("UTC time? ", endutc, &haveit, &error, errmsg,
(ftnlen)10, (ftnlen)32, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___46);
e_wsle();
s_wsle(&io___47);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___48);
e_wsle();
s_wsle(&io___49);
do_lio(&c__9, &c__1, "An ending UTC time str"
"ing must be entered for this option.",
(ftnlen)58);
e_wsle();
}
} else {
tryagn = FALSE_;
}
/* We now have the ending time in UTC, so attempt */
/* to convert it to ET. If the conversion fails, we */
/* need to immediately reset the error handling so */
/* that we can continue processing. Remember, we are */
/* in a menuing subroutine, and we are not allowed */
/* to exit on an error: we must go back to the menu. */
/* thus the need for a resetting of the error handler */
/* here. If we got to here, there were no errors, so */
/* as long as we maintain that status, everything */
/* will be hunky dory. We also convert the ET back */
/* into UTC to get a consistent format for display. */
if (haveit) {
utc2et_(endutc, &endet, (ftnlen)32);
et2utc_(&endet, "C", &c__3, endutc, (ftnlen)1, (
ftnlen)32);
if (failed_()) {
reset_();
error = TRUE_;
}
}
/* Check to see if they want to try and enter the */
/* beginning UTC time string again. */
if (! haveit || error) {
s_wsle(&io___51);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)
20);
if (! tryagn) {
contnu = FALSE_;
}
} else {
tryagn = FALSE_;
}
}
}
/* Create an interval out of the begin and end ET times, */
/* if we can. */
if (contnu) {
scardd_(&c__0, intrvl);
wninsd_(&beget, &endet, intrvl);
if (failed_()) {
contnu = FALSE_;
}
}
/* Write the type of summary to the output file, if we can. */
if (contnu) {
s_copy(tmpstr, "By # Time Interval #", (ftnlen)80, (
ftnlen)20);
repmc_("Summary Type : #", "#", tmpstr, typout, (
ftnlen)22, (ftnlen)1, (ftnlen)80, (ftnlen)255);
repmc_(typout, "#", "UTC", typout, (ftnlen)255, (ftnlen)1,
(ftnlen)3, (ftnlen)255);
repmc_(typout, "#", "(#, #)", typout, (ftnlen)255, (
ftnlen)1, (ftnlen)6, (ftnlen)255);
repmc_(typout, "#", begutc, typout, (ftnlen)255, (ftnlen)
1, (ftnlen)32, (ftnlen)255);
repmc_(typout, "#", endutc, typout, (ftnlen)255, (ftnlen)
1, (ftnlen)32, (ftnlen)255);
}
} else if (s_cmp(option, "BY_SCLK_INTERVAL", (ftnlen)20, (ftnlen)
16) == 0) {
/* Summarize for given SCLK time interval. */
/* First, we need to get spacecraft ID code. */
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___52);
e_wsle();
s_wsle(&io___53);
do_lio(&c__9, &c__1, "Enter the desired NAIF spacecraft "
"ID code.", (ftnlen)42);
e_wsle();
s_wsle(&io___54);
e_wsle();
getint_("Spacecraft ID code? ", &missin, &haveit, &error,
errmsg, (ftnlen)20, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___56);
e_wsle();
s_wsle(&io___57);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___58);
e_wsle();
s_wsle(&io___59);
do_lio(&c__9, &c__1, "A NAIF spacecraft ID code "
"must be entered for this option.", (
ftnlen)58);
e_wsle();
}
if (! haveit || error) {
s_wsle(&io___60);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)
20);
if (! tryagn) {
contnu = FALSE_;
}
}
} else {
tryagn = FALSE_;
}
}
/* Now, we need to get the SCLK time string for the */
/* begin time. */
if (contnu) {
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___61);
e_wsle();
s_wsle(&io___62);
do_lio(&c__9, &c__1, "Enter the desired beginning SC"
"LK time.", (ftnlen)38);
e_wsle();
s_wsle(&io___63);
e_wsle();
getchr_("SCLK time? ", bsclk, &haveit, &error, errmsg,
(ftnlen)11, (ftnlen)32, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___65);
e_wsle();
s_wsle(&io___66);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___67);
e_wsle();
s_wsle(&io___68);
do_lio(&c__9, &c__1, "A beginning SCLK time "
"string must be entered for this opti"
"on.", (ftnlen)61);
e_wsle();
}
} else {
tryagn = FALSE_;
}
/* We now have the beginning time in SCLK, so attempt */
/* to convert it to ET. If the conversion fails, we */
/* need to immediately reset the error handling so */
/* that we can continue processing. Remember, we are */
/* in a menuing subroutine, and we are not allowed to */
/* exit on an error: we must go back to the menu. thus */
/* the need for a resetting of the error handler here. */
/* If we got to here, there were no errors, so as long */
/* as we maintain that status, everything will be */
/* hunky dory. We also convert the ET back into SCLK, */
/* and UTC to get a consistent format for display. */
if (haveit) {
scencd_(&missin, bsclk, &begscl, (ftnlen)32);
sct2e_(&missin, &begscl, &beget);
et2utc_(&beget, "C", &c__3, begutc, (ftnlen)1, (
ftnlen)32);
scdecd_(&missin, &begscl, bsclk, (ftnlen)32);
if (failed_()) {
reset_();
error = TRUE_;
}
}
/* Check to see if they want to try and enter the */
/* beginning UTC time string again. */
if (! haveit || error) {
s_wsle(&io___70);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)
20);
if (! tryagn) {
contnu = FALSE_;
}
}
}
}
/* Now, if we can, we need to get the UTC time string for */
/* the end time. */
if (contnu) {
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___71);
e_wsle();
s_wsle(&io___72);
do_lio(&c__9, &c__1, "Enter the desired ending SCLK "
"time.", (ftnlen)35);
e_wsle();
s_wsle(&io___73);
e_wsle();
getchr_("SCLK time? ", esclk, &haveit, &error, errmsg,
(ftnlen)11, (ftnlen)32, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___75);
e_wsle();
s_wsle(&io___76);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___77);
e_wsle();
s_wsle(&io___78);
do_lio(&c__9, &c__1, "An ending SCLK time st"
"ring must be entered for this option."
, (ftnlen)59);
e_wsle();
}
} else {
tryagn = FALSE_;
}
/* We now have the ending time in UTC, so attempt */
/* to convert it to ET. If the conversion fails, we */
/* need to immediately reset the error handling so */
/* that we can continue processing. Remember, we are */
/* in a menuing subroutine, and we are not allowed */
/* to exit on an error: we must go back to the menu. */
/* thus the need for a resetting of the error handler */
/* here. If we got to here, there were no errors, so */
/* as long as we maintain that status, everything */
/* will be hunky dory. We also convert the ET back */
/* into UTC to get a consistent format for display. */
if (haveit) {
scencd_(&missin, esclk, &endscl, (ftnlen)32);
sct2e_(&missin, &endscl, &endet);
et2utc_(&endet, "C", &c__3, endutc, (ftnlen)1, (
ftnlen)32);
scdecd_(&missin, &endscl, esclk, (ftnlen)32);
if (failed_()) {
reset_();
error = TRUE_;
}
}
/* Check to see if they want to try and enter the */
/* ending SCLK time string again. */
if (! haveit || error) {
s_wsle(&io___80);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)
20);
if (! tryagn) {
contnu = FALSE_;
}
} else {
tryagn = FALSE_;
}
}
}
/* Create an interval out of the begin and end ET times, */
/* if we can. */
if (contnu) {
scardd_(&c__0, intrvl);
wninsd_(&beget, &endet, intrvl);
if (failed_()) {
contnu = FALSE_;
}
}
/* Write the type of summary to the output file, if we can. */
if (contnu) {
s_copy(tmpstr, "By # Time Interval #", (ftnlen)80, (
ftnlen)20);
repmc_("Summary Type : #", "#", tmpstr, typout, (
ftnlen)22, (ftnlen)1, (ftnlen)80, (ftnlen)255);
repmc_(typout, "#", "SCLK", typout, (ftnlen)255, (ftnlen)
1, (ftnlen)4, (ftnlen)255);
repmc_(typout, "#", "(#, #)", typout, (ftnlen)255, (
ftnlen)1, (ftnlen)6, (ftnlen)255);
repmc_(typout, "#", bsclk, typout, (ftnlen)255, (ftnlen)1,
(ftnlen)32, (ftnlen)255);
repmc_(typout, "#", esclk, typout, (ftnlen)255, (ftnlen)1,
(ftnlen)32, (ftnlen)255);
}
}
/* Now, if we can, search through the file from the beginning. */
/* Keep track of whether or not any segments satisfy the search */
/* criteria. */
if (contnu) {
writln_(" ", &c__6, (ftnlen)1);
writln_(separ, &c__6, (ftnlen)80);
writln_(" ", &c__6, (ftnlen)1);
writln_(fnmout, &c__6, (ftnlen)255);
writln_(lpsout, &c__6, (ftnlen)255);
writln_(sclout, &c__6, (ftnlen)255);
writln_(typout, &c__6, (ftnlen)255);
writln_(" ", &c__6, (ftnlen)1);
if (*logfil) {
writln_(" ", loglun, (ftnlen)1);
writln_(separ, loglun, (ftnlen)80);
writln_(" ", loglun, (ftnlen)1);
writln_(fnmout, loglun, (ftnlen)255);
writln_(lpsout, loglun, (ftnlen)255);
writln_(sclout, loglun, (ftnlen)255);
writln_(typout, loglun, (ftnlen)255);
writln_(" ", loglun, (ftnlen)1);
}
anyseg = FALSE_;
dafbfs_(handle);
daffna_(&found);
while(found && contnu) {
/* On each iteration of the loop, we have not found */
/* anything initially. */
segfnd = FALSE_;
scardd_(&c__0, intsct);
scardd_(&c__0, segint);
/* Get the descriptor of the segment. */
ckgss_(segid, &segins, &segfrm, &segtyp, &segrts, &segbtm,
&segetm, &segbad, &segead, (ftnlen)40);
/* Check to see if the current segment satisfies the */
/* current search criteria. */
if (s_cmp(option, "ENTIRE_FILE", (ftnlen)20, (ftnlen)11)
== 0) {
segfnd = TRUE_;
} else if (s_cmp(option, "BY_INSTRUMENT_ID", (ftnlen)20, (
ftnlen)16) == 0) {
segfnd = instid == segins;
} else if (s_cmp(option, "BY_UTC_INTERVAL", (ftnlen)20, (
ftnlen)15) == 0) {
/* Create an interval out of the epochs in the */
/* segment. */
missin = segins / 1000;
sct2e_(&missin, &segbtm, &beget);
sct2e_(&missin, &segetm, &endet);
wninsd_(&beget, &endet, segint);
/* Intersect it with the input interval. */
wnintd_(segint, intrvl, intsct);
if (failed_()) {
reset_();
contnu = FALSE_;
} else {
segfnd = cardd_(intsct) > 0;
}
} else if (s_cmp(option, "BY_SCLK_INTERVAL", (ftnlen)20, (
ftnlen)16) == 0) {
/* Create an interval out of the epochs in the */
/* segment. */
if (missin == segins / 1000) {
sct2e_(&missin, &segbtm, &beget);
sct2e_(&missin, &segetm, &endet);
wninsd_(&beget, &endet, segint);
/* Intersect it with the input interval. */
wnintd_(segint, intrvl, intsct);
if (failed_()) {
reset_();
contnu = FALSE_;
} else {
segfnd = cardd_(intsct) > 0;
}
} else {
segfnd = FALSE_;
}
}
if (contnu && segfnd) {
anyseg = TRUE_;
/* Display the segment summary. */
writln_(sumsep, &c__6, (ftnlen)80);
if (*logfil) {
writln_(sumsep, loglun, (ftnlen)80);
}
ckwss_(&c__6, segid, &segins, &segfrm, &segtyp, &
segrts, &segbtm, &segetm, (ftnlen)40);
if (*logfil) {
ckwss_(loglun, segid, &segins, &segfrm, &segtyp, &
segrts, &segbtm, &segetm, (ftnlen)40);
}
writln_(sumsep, &c__6, (ftnlen)80);
if (*logfil) {
writln_(sumsep, loglun, (ftnlen)80);
}
}
/* Find that next segment. */
daffna_(&found);
if (failed_()) {
contnu = FALSE_;
}
}
}
/* Better say something if no segments were matching the */
/* search criteria were found. */
if (contnu && ! anyseg) {
s_copy(line, "No matching segments were found.", (ftnlen)255,
(ftnlen)32);
writln_(line, &c__6, (ftnlen)255);
if (*logfil) {
writln_(line, loglun, (ftnlen)255);
}
}
if (contnu) {
writln_(" ", &c__6, (ftnlen)1);
writln_(separ, &c__6, (ftnlen)80);
writln_(" ", &c__6, (ftnlen)1);
if (*logfil) {
writln_(" ", loglun, (ftnlen)1);
writln_(separ, loglun, (ftnlen)80);
writln_(" ", loglun, (ftnlen)1);
}
}
}
/* If anything failed, rset the error handling so that we can */
/* redisplay the menu and keep doing things. */
if (failed_()) {
reset_();
}
}
chkout_("SUMCK", (ftnlen)5);
return 0;
} /* sumck_ */
/* $Procedure INTERD ( Intersect two double precision sets ) */
/* Subroutine */ int interd_(doublereal *a, doublereal *b, doublereal *c__)
{
integer over, acard, bcard, ccard;
extern integer cardd_(doublereal *);
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer csize;
extern integer sized_(doublereal *);
extern /* Subroutine */ int scardd_(integer *, doublereal *);
integer apoint, bpoint;
extern /* Subroutine */ int excess_(integer *, char *, ftnlen), sigerr_(
char *, ftnlen), chkout_(char *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Intersect two double precision sets to form a third 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 */
/* None. */
/* $ Keywords */
/* CELLS, SETS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* A I First input set. */
/* B I Second input set. */
/* C O Intersection of A and B. */
/* $ Detailed_Input */
/* A is a set. */
/* B is a set, distinct from A. */
/* $ Detailed_Output */
/* C is a set, distinct from sets A and B, which */
/* contains the intersection of A and B (that is, */
/* all of the elements which are in A, AND in B). */
/* If the size (maximum cardinality) of C is smaller */
/* than the cardinality of the intersection of A and B, */
/* then only as many items as will fit in C are */
/* included, and an error is signalled. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* The INTERSECTION of two sets contains every element */
/* which is in the first set AND in the second set. */
/* {a,b} intersect {c,d} = {} */
/* {a,b,c} {b,c,d} {b,c} */
/* {a,b,c,d} {} {} */
/* {} {a,b,c,d} {} */
/* {} {} {} */
/* The following call */
/* CALL INTERC ( PLANETS, ASTEROIDS, RESULT ) */
/* places the intersection of the character sets PLANETS and */
/* ASTEROIDS into the character set RESULT. */
/* The output set must be distinct from both of the input sets. */
/* For example, the following calls are invalid. */
/* CALL INTERI ( CURRENT, NEW, CURRENT ) */
/* CALL INTERI ( NEW, CURRENT, CURRENT ) */
/* In each of the examples above, whether or not the subroutine */
/* signals an error, the results will almost certainly be wrong. */
/* Nearly the same effect can be achieved, however, by placing the */
/* result into a temporary set, which is immediately copied back */
/* into one of the input sets, as shown below. */
/* CALL INTERI ( CURRENT, NEW, TEMP ) */
/* CALL COPYI ( TEMP, NEW ) */
/* $ Restrictions */
/* None. */
/* $ Exceptions */
/* 1) If the intersection of the two sets causes an excess of */
/* elements, the error SPICE(SETEXCESS) is signalled. */
/* $ Files */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* C.A. Curzon (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (CAC) (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* intersect two d.p. sets */
/* -& */
/* $ Revisions */
/* - Beta Version 1.1.0, 06-JAN-1989 (NJB) */
/* Calling protocol of EXCESS changed. Call to SETMSG removed. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Set up the error processing. */
if (return_()) {
return 0;
}
chkin_("INTERD", (ftnlen)6);
/* Find the cardinality of the input sets, and the allowed size */
/* of the output set. */
acard = cardd_(a);
bcard = cardd_(b);
csize = sized_(c__);
/* Begin with the input pointers at the first elements of the */
/* input sets. The cardinality of the output set is zero. */
/* And there is no overflow so far. */
apoint = 1;
bpoint = 1;
ccard = 0;
over = 0;
/* When the end of either input set is reached, we're done. */
while(apoint <= acard && bpoint <= bcard) {
/* If there is still space in the output set, fill it */
/* as necessary. */
if (ccard < csize) {
if (a[apoint + 5] == b[bpoint + 5]) {
++ccard;
c__[ccard + 5] = a[apoint + 5];
++apoint;
++bpoint;
} else if (a[apoint + 5] < b[bpoint + 5]) {
++apoint;
} else if (b[bpoint + 5] < a[apoint + 5]) {
++bpoint;
}
/* Otherwise, stop folling the array, but continue to count the */
/* number of elements in excess of the size of the output set. */
} else {
if (a[apoint + 5] == b[bpoint + 5]) {
++over;
++apoint;
++bpoint;
} else if (a[apoint + 5] < b[bpoint + 5]) {
++apoint;
} else if (b[bpoint + 5] < a[apoint + 5]) {
++bpoint;
}
}
}
/* Set the cardinality of the output set. */
scardd_(&ccard, c__);
/* Report any excess. */
if (over > 0) {
excess_(&over, "set", (ftnlen)3);
sigerr_("SPICE(SETEXCESS)", (ftnlen)16);
}
chkout_("INTERD", (ftnlen)6);
return 0;
} /* interd_ */
/* $Procedure WNCOMD ( Complement a DP window ) */
/* Subroutine */ int wncomd_(doublereal *left, doublereal *right, doublereal *
window, doublereal *result)
{
integer card, i__;
extern integer cardd_(doublereal *);
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern logical failed_(void);
extern /* Subroutine */ int scardd_(integer *, doublereal *), sigerr_(
char *, ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen),
wninsd_(doublereal *, doublereal *, doublereal *);
extern logical return_(void);
/* $ Abstract */
/* Determine the complement of a double precision window with */
/* respect to the interval [LEFT,RIGHT]. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* WINDOWS */
/* $ Keywords */
/* WINDOWS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* LEFT, */
/* RIGHT I Left, right endpoints of complement interval. */
/* WINDOW I Input window. */
/* RESULT O Complement of WINDOW with respect to [LEFT,RIGHT]. */
/* $ Detailed_Input */
/* LEFT, */
/* RIGHT are the left and right endpoints of the complement */
/* interval. */
/* WINDOW is the window to be complemented. */
/* $ Detailed_Output */
/* RESULT is the output window, containing the complement */
/* of WINDOW with respect to the interval from LEFT */
/* to RIGHT. If the output window is not large enough */
/* to contain the result, as many intervals as will */
/* fit are returned. */
/* RESULT must be distinct from WINDOW. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* Mathematically, the complement of a window contains those */
/* points that are not contained in the window. That is, the */
/* complement of the set of closed intervals */
/* [ a(1), b(1) ], [ a(2), b(2) ], ..., [ a(n), b(n) ] */
/* is the set of open intervals */
/* ( -inf, a(1) ), ( b(1), a(2) ), ..., ( b(n), +inf ) */
/* Because Fortran offers no satisfactory representation of */
/* infinity, we must take the complement with respect to a */
/* finite interval. */
/* In addition, Fortran offers no satisfactory floating point */
/* representation of open intervals. Therefore, the complement */
/* of a floating point window is closure of the set theoretical */
/* complement. In short, the floating point complement of the */
/* window */
/* [ a(1), b(1) ], [ a(2), b(2) ], ..., [ a(n), b(n) ] */
/* with respect to the interval from LEFT to RIGHT is the */
/* intersection of the windows */
/* ( -inf, a(1) ], [ b(1), a(2) ], ..., [ b(n), +inf ) */
/* and */
/* [ LEFT, RIGHT ] */
/* Note that floating point intervals of measure zero (singleton */
/* intervals) in the original window are replaced by gaps of */
/* measure zero, which are filled. Thus, complementing a floating */
/* point window twice does not necessarily yield the original */
/* window. */
/* $ Examples */
/* Let WINDOW contain the intervals */
/* [ 1, 3 ] [ 7, 11 ] [ 23, 27 ] */
/* Then the floating point complement of WINDOW with respect */
/* to [2,20] contains the intervals */
/* [ 3, 7 ] [ 11, 20 ] */
/* and the complement with respect to [ 0, 100 ] contains */
/* [ 0, 1 ] [ 3, 7 ] [ 11, 23 ] [ 27, 100 ] */
/* $ Exceptions */
/* If LEFT is greater than RIGHT, the error SPICE(BADENDPOINTS) is */
/* signalled. */
/* $ Files */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* complement a d.p. window */
/* -& */
/* $ Revisions */
/* - Beta Version 1.1.0, 17-FEB-1989 (HAN) (NJB) */
/* Contents of the Required_Reading section was */
/* changed from "None." to "WINDOWS". Also, the */
/* declaration of the unused variable J was removed. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Set up the error processing. */
if (return_()) {
return 0;
}
chkin_("WNCOMD", (ftnlen)6);
/* Get the cardinality of the input window. */
card = cardd_(window);
/* Empty out the result window before proceeding. */
scardd_(&c__0, result);
/* Check to see if the input interval is valid. If it is not, signal */
/* an error and return. */
if (*left > *right) {
setmsg_("WNCOMD: Left endpoint may not exceed right endpoint.", (
ftnlen)52);
sigerr_("SPICE(BADENDPOINTS)", (ftnlen)19);
chkout_("WNCOMD", (ftnlen)6);
return 0;
}
/* There are two trivial cases: the window is empty, or it does not */
/* intersect the input interval. In either case, the complement is */
/* the entire interval. */
if (card == 0 || window[6] >= *right || window[card + 5] <= *left) {
wninsd_(left, right, result);
chkout_("WNCOMD", (ftnlen)6);
return 0;
}
/* Let WINDOW represent the set of intervals */
/* [a1,b1], [a2,b2], ..., [aN,bN] */
/* Then the closure of the complement of WINDOW in the reals is */
/* (-infinity,a1], [b1,a2], [b2,a3], ..., [bN, infinity) */
/* Thus the sequence of endpoints of WINDOW is also the sequence */
/* of finite endpoints of its complement. Moreover, these endpoints */
/* are simply "shifted" from their original positions in WINDOW. */
/* This makes finding the complement of WINDOW with respect to */
/* a given interval almost trivial. */
/* Find the first right not less than the beginning of the input */
/* interval. */
i__ = 2;
while(i__ <= card && window[i__ + 5] < *left) {
i__ += 2;
}
/* If the beginning of the input interval doesn't split an interval */
/* in the input window, the complement begins with LEFT. */
if (i__ <= card && window[i__ + 4] > *left) {
wninsd_(left, &window[i__ + 4], result);
}
/* Start schlepping endpoints [b(i),a(i+1)] from the input window */
/* to the output window. Stop when we find one of our new right */
/* endpoints exceeds the end of the input interval. */
while(! failed_() && i__ < card && window[i__ + 6] < *right) {
wninsd_(&window[i__ + 5], &window[i__ + 6], result);
i__ += 2;
}
/* If the end of the input interval doesn't split an interval */
/* in the input window, the complement ends with RIGHT. */
if (i__ <= card && window[i__ + 5] < *right) {
wninsd_(&window[i__ + 5], right, result);
}
chkout_("WNCOMD", (ftnlen)6);
return 0;
} /* wncomd_ */
/* $Procedure INSRTD ( Insert an item into a double precision set ) */
/* Subroutine */ int insrtd_(doublereal *item, doublereal *a)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer card, last, size, i__;
extern integer cardd_(doublereal *);
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern integer sized_(doublereal *);
logical in;
extern /* Subroutine */ int scardd_(integer *, doublereal *);
extern integer lstled_(doublereal *, integer *, doublereal *);
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Insert an item into a double precision 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 */
/* SETS */
/* $ Keywords */
/* CELLS */
/* SETS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ITEM I Item to be inserted. */
/* A I/O Insertion set. */
/* $ Detailed_Input */
/* ITEM is an item which is to be inserted into the */
/* specified set. ITEM may or may not already */
/* be an element of the set. */
/* A is a set. */
/* On input, A may or may not contain the input item */
/* as an element. */
/* $ Detailed_Output */
/* A on output contains the union of the input set and */
/* the singleton set containing the input item, unless */
/* there was not sufficient room in the set for the */
/* item to be included, in which case the set is not */
/* changed and an error is signaled. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the insertion of the element into the set causes an excess */
/* of elements, the error SPICE(SETEXCESS) is signaled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* In the following example, the element 'PLUTO' is removed from */
/* the character set PLANETS and inserted into the character set */
/* ASTEROIDS. */
/* CALL REMOVC ( 'PLUTO', PLANETS ) */
/* CALL INSRTC ( 'PLUTO', ASTEROIDS ) */
/* If 'PLUTO' is not an element of PLANETS, then the contents of */
/* PLANETS are not changed. Similarly, if 'PLUTO' is already an */
/* element of ASTEROIDS, the contents of ASTEROIDS remain unchanged. */
/* Because inserting an element into a set can increase the */
/* cardinality of the set, an error may occur in the insertion */
/* routines. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* C.A. Curzon (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 2.0.0, 01-NOV-2005 (NJB) */
/* Code was modified slightly to keep logical structure parallel */
/* to that of INSRTC. */
/* Long error message was updated to include size of */
/* set into which insertion was attempted. */
/* - 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 (CAC) (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* insert an item into a d.p. set */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 01-NOV-2005 (NJB) */
/* Code was modified slightly to keep logical structure parallel */
/* to that of INSRTC. */
/* Long error message was updated to include size of set into */
/* which insertion was attempted. */
/* - Beta Version 1.1.0, 06-JAN-1989 (NJB) */
/* Calling protocol of EXCESS changed. Call to SETMSG removed. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Set up the error processing. */
if (return_()) {
return 0;
}
chkin_("INSRTD", (ftnlen)6);
/* What are the size and cardinality of the set? */
size = sized_(a);
card = cardd_(a);
/* Find the last element of the set which would come before the */
/* input item. This will be the item itself, if it is already an */
/* element of the set. */
last = lstled_(item, &card, &a[6]);
/* Is the item already in the set? If not, it needs to be inserted. */
if (last > 0) {
in = a[last + 5] == *item;
} else {
in = FALSE_;
}
if (! in) {
/* If there is room in the set for the new element, then move */
/* the succeeding elements back to make room. And update the */
/* cardinality for future reference. */
if (card < size) {
i__1 = last + 1;
for (i__ = card; i__ >= i__1; --i__) {
a[i__ + 6] = a[i__ + 5];
}
a[last + 6] = *item;
i__1 = card + 1;
scardd_(&i__1, a);
} else {
setmsg_("An element could not be inserted into the set due to la"
"ck of space; set size is #.", (ftnlen)82);
errint_("#", &size, (ftnlen)1);
sigerr_("SPICE(SETEXCESS)", (ftnlen)16);
}
}
chkout_("INSRTD", (ftnlen)6);
return 0;
} /* insrtd_ */
