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