/* $Procedure ZZGAPOOL ( Private: get agent set for watched variable ) */ /* Subroutine */ int zzgapool_(char *varnam, char *wtvars, integer *wtptrs, integer *wtpool, char *wtagnt, char *agtset, ftnlen varnam_len, ftnlen wtvars_len, ftnlen wtagnt_len, ftnlen agtset_len) { /* System generated locals */ integer i__1; /* Builtin functions */ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ integer node; extern integer cardc_(char *, ftnlen); extern /* Subroutine */ int chkin_(char *, ftnlen); extern integer sizec_(char *, ftnlen); extern /* Subroutine */ int scardc_(integer *, char *, ftnlen), validc_( integer *, integer *, char *, ftnlen); extern integer bsrchc_(char *, integer *, char *, ftnlen, ftnlen); integer nfetch; extern /* Subroutine */ int chkout_(char *, ftnlen); extern integer lnknxt_(integer *, integer *); extern logical return_(void); integer loc; /* $ 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. */ /* Return a SPICE set containing the names of agents watching */ /* a specified kernel variable. */ /* $ 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 */ /* KERNEL */ /* $ Keywords */ /* KERNEL */ /* PRIVATE */ /* UTILITY */ /* $ Declarations */ /* $ Brief_I/O */ /* VARIABLE I/O DESCRIPTION */ /* -------- --- -------------------------------------------------- */ /* VARNAM I Kernel variable name. */ /* WTVARS I Watched kernel variable set. */ /* WTPTRS I Pointers from variables into the watch pool. */ /* WTPOOL I Watch pool used for managing agent names. */ /* WTAGNT I Array of agent names. */ /* AGTSET O Set of agents for VARNAM. */ /* $ Detailed_Input */ /* VARNAM is the name of a kernel variable. */ /* WTVARS is a SPICE set containing the contents of the kernel */ /* pool watcher system's set WTVARS. */ /* WTPTRS is an array containing the contents of the kernel */ /* pool watcher system's array WTPTRS. */ /* WTPOOL is a SPICE doubly linked list pool containing the */ /* contents of the kernel pool watcher system's pool */ /* WTPOOL. */ /* WTAGNT is an array containing the contents of the kernel */ /* pool watcher system's array WTAGNT. */ /* $ Detailed_Output */ /* AGTSET is a SPICE set containing the names of the agents */ /* associated with the kernel variable designated by */ /* VARNAM. */ /* $ Parameters */ /* None. */ /* $ Exceptions */ /* 1) If the output set AGTSET is too small to hold the set of */ /* agents watching VARNAM, the error will be diagnosed by routines */ /* in the call tree of this routine. */ /* $ Files */ /* None. */ /* $ Particulars */ /* This routine is not part of the SPICELIB API. This routine */ /* may be removed in a later version of the SPICE Toolkit, or */ /* its interface may change. */ /* SPICE-based application code should not call this routine. */ /* $ Examples */ /* See POOL entry point SWPOOL. */ /* $ Restrictions */ /* 1) This is a private routine. See $Particulars above. */ /* 2) Contents of the input arrays are assumed to be valid. */ /* The output returned by this routine is meaningless */ /* otherwise. */ /* $ Literature_References */ /* None. */ /* $ Author_and_Institution */ /* N.J. Bachman (JPL) */ /* $ Version */ /* - SPICELIB Version 1.0.0, 17-MAR-2009 (NJB) */ /* -& */ /* $ Index_Entries */ /* get agent set for watched kernel variable */ /* -& */ /* $ Revisions */ /* None. */ /* -& */ /* SPICELIB functions */ /* Local variables */ if (return_()) { return 0; } chkin_("ZZGAPOOL", (ftnlen)8); /* The output agent set is empty until we find any */ /* agents. */ scardc_(&c__0, agtset, agtset_len); /* Find the location of VARNAM in the set of watched */ /* variables. */ i__1 = cardc_(wtvars, wtvars_len); loc = bsrchc_(varnam, &i__1, wtvars + wtvars_len * 6, varnam_len, wtvars_len); if (loc == 0) { /* This variable is not watched. The agent set is */ /* empty. */ chkout_("ZZGAPOOL", (ftnlen)8); return 0; } /* Set NODE to the head node of the agent list for VARNAM. */ /* Traverse the agent list for VARNAM. Collect the agents */ /* as an unordered list, then turn the list into a set. */ node = wtptrs[loc - 1]; nfetch = 0; while(node > 0) { ++nfetch; s_copy(agtset + (nfetch + 5) * agtset_len, wtagnt + (node - 1) * wtagnt_len, agtset_len, wtagnt_len); node = lnknxt_(&node, wtpool); } i__1 = sizec_(agtset, agtset_len); validc_(&i__1, &nfetch, agtset, agtset_len); chkout_("ZZGAPOOL", (ftnlen)8); return 0; } /* zzgapool_ */
/* $Procedure LPARSS ( Parse a list of items; return a set. ) */ /* Subroutine */ int lparss_(char *list, char *delims, char *set, ftnlen list_len, ftnlen delims_len, ftnlen set_len) { /* Builtin functions */ integer s_cmp(char *, char *, ftnlen, ftnlen), i_indx(char *, char *, ftnlen, ftnlen); /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ char bchr[1], echr[1]; integer nmax, b, e, n; extern /* Subroutine */ int chkin_(char *, ftnlen); logical valid; extern integer sizec_(char *, ftnlen); extern logical failed_(void); extern /* Subroutine */ int scardc_(integer *, char *, ftnlen), validc_( integer *, integer *, char *, ftnlen); extern integer lastnb_(char *, ftnlen); extern /* Subroutine */ int chkout_(char *, ftnlen), insrtc_(char *, char *, ftnlen, ftnlen); extern logical return_(void); integer eol; /* $ Abstract */ /* Parse a list of items delimited by multiple delimiters, */ /* placing the resulting items into a set. */ /* $ Disclaimer */ /* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */ /* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */ /* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */ /* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */ /* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */ /* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */ /* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */ /* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */ /* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */ /* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */ /* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */ /* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */ /* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */ /* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */ /* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */ /* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */ /* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */ /* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */ /* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */ /* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */ /* $ Required_Reading */ /* CELLS */ /* SETS */ /* $ Keywords */ /* CHARACTER */ /* PARSING */ /* SETS */ /* $ Declarations */ /* $ Brief_I/O */ /* VARIABLE I/O DESCRIPTION */ /* -------- --- -------------------------------------------------- */ /* LIST I List of items delimited by DELIMS on input. */ /* DELIMS I Single characters which delimit items. */ /* SET O Items in the list, validated, left justified. */ /* $ Detailed_Input */ /* LIST is a list of items delimited by any one of the */ /* characters in the string DELIMS. Consecutive */ /* delimiters, and delimiters at the beginning and */ /* end of the list, are considered to delimit blank */ /* items. A blank list is considered to contain */ /* a single (blank) item. */ /* DELIMS contains the individual characters which delimit */ /* the items in the list. These may be any ASCII */ /* characters, including blanks. */ /* However, by definition, consecutive blanks are NOT */ /* considered to be consecutive delimiters. Nor are */ /* a blank and any other delimiter considered to be */ /* consecutive delimiters. In addition, leading and */ /* trailing blanks are ignored. */ /* $ Detailed_Output */ /* SET is a set containing the items in the list, left */ /* justified. Any item in the list too long to fit */ /* into an element of SET is truncated on the right. */ /* The size of the set must be initialized prior */ /* to calling LPARSS. */ /* $ Parameters */ /* None. */ /* $ Exceptions */ /* 1) If the size of the set is not large enough to accommodate all */ /* of the items in the set, the error is diagnosed by routines in */ /* the call tree of this routine. */ /* 2) If the string length of ITEMS is too short to accommodate */ /* an item, the item will be truncated on the right. */ /* 3) If the string length of ITEMS is too short to permit encoding */ /* of integers via ENCHAR, the error is diagnosed by routines in */ /* the call tree of this routine. */ /* $ Files */ /* None. */ /* $ Particulars */ /* None. */ /* $ Examples */ /* The following examples illustrate the operation of LPARSS. */ /* 1) Let */ /* LIST = 'A number of words separated by */ /* spaces.' */ /* DELIMS = ' ,.' */ /* SIZE (SET) = 20 */ /* Then */ /* CARDC (SET) = 8 */ /* SET (1) = ' ' */ /* SET (2) = 'A' */ /* SET (3) = 'by' */ /* SET (4) = 'number' */ /* SET (5) = 'of' */ /* SET (6) = 'separated' */ /* SET (7) = 'spaces' */ /* SET (8) = 'words' */ /* 2) Let */ /* LIST = ' 1986-187// 13:15:12.184 ' */ /* DELIMS = ' ,/-:' */ /* SIZE (SET) = 20 */ /* Then */ /* CARDC (SET) = 6 */ /* SET (1) = ' ' */ /* SET (2) = '12.184' */ /* SET (3) = '13' */ /* SET (4) = '15' */ /* SET (5) = '187' */ /* SET (6) = '1986' */ /* 3) Let LIST = ' ,This, is, ,an,, example, ' */ /* DELIMS = ' ,' */ /* SIZE (SET) = 20 */ /* Then */ /* CARDC (SET) = 5 */ /* SET (1) = ' ' */ /* SET (2) = 'This' */ /* SET (3) = 'an' */ /* SET (4) = 'example' */ /* SET (5) = 'is' */ /* 4) Let LIST = 'Mary had a little lamb, little lamb */ /* whose fleece was white as snow.' */ /* DELIMS = ' ,.' */ /* SIZE (SET) = 6 */ /* An error would be signaled because the set is not */ /* large enough to accommodate all of the items in the */ /* list. */ /* 5) Let LIST = '1 2 3 4 5 6 7 8 9 10.' */ /* DELIMS = ' .' */ /* SIZE (SET) = 10 */ /* An error would be signaled because the set is not */ /* large enough to accommodate all of the items in the */ /* list. Note that delimiters at the end (or beginning) */ /* of list are considered to delimit blank items. */ /* 6) Let LIST = '1 2 3 4 5 6 7 8 9 10.' */ /* DELIMS = '.' */ /* SIZE (SET) = 10 */ /* Then */ /* CARDC (SET) = 2 */ /* SET (1) = ' ' */ /* SET (2) = '1 2 3 4 5 6 7 8 9 10' */ /* $ Restrictions */ /* None. */ /* $ Author_and_Institution */ /* N.J. Bachman (JPL) */ /* H.A. Neilan (JPL) */ /* I.M. Underwood (JPL) */ /* $ Literature_References */ /* None. */ /* $ Version */ /* - SPICELIB Version 1.1.0, 26-OCT-2005 (NJB) */ /* Bug fix: code was modified to avoid out-of-range */ /* substring bound conditions. */ /* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */ /* Comment section for permuted index source lines was added */ /* following the header. */ /* - SPICELIB Version 1.0.0, 31-JAN-1990 (HAN) (IMU) */ /* -& */ /* $ Index_Entries */ /* parse a list of items and return a set */ /* -& */ /* $ Revisions */ /* - SPICELIB Version 1.1.0, 26-OCT-2005 (NJB) */ /* Bug fix: code was modified to avoid out-of-range */ /* substring bound conditions. The previous version */ /* of this routine used DO WHILE statements of the form */ /* DO WHILE ( ( B .LE. EOL ) */ /* . .AND. ( LIST(B:B) .EQ. BLANK ) ) */ /* Such statements can cause index range violations when the */ /* index B is greater than the length of the string LIST. */ /* Whether or not such violations occur is platform-dependent. */ /* - Beta Version 2.0.0, 10-JAN-1989 (HAN) */ /* Error handling was added, and old error flags and their */ /* checks were removed. An error is signaled if the set */ /* is not large enough to accommodate all of the items in */ /* the list. */ /* The header documentation was updated to reflect the error */ /* handling changes, and more examples were added. */ /* -& */ /* SPICELIB functions */ /* Local parameters */ /* Local variables */ /* Standard SPICE error handling. */ if (return_()) { return 0; } else { chkin_("LPARSS", (ftnlen)6); } /* Because speed is essential in many list parsing applications, */ /* LPARSS, like LPARSE, parses the input list in a single pass. */ /* What follows is nearly identical to LPARSE, except the FORTRAN */ /* INDEX function is used to test for delimiters, instead of testing */ /* each character for simple equality. Also, the items are inserted */ /* into a set instead of simply placed at the end of an array. */ /* No items yet. */ n = 0; /* What is the size of the set? */ nmax = sizec_(set, set_len); /* The array has not been validated yet. */ valid = FALSE_; /* Blank list contains a blank item. No need to validate. */ if (s_cmp(list, " ", list_len, (ftnlen)1) == 0) { scardc_(&c__0, set, set_len); insrtc_(" ", set, (ftnlen)1, set_len); valid = TRUE_; } else { /* Eliminate trailing blanks. EOL is the last non-blank */ /* character in the list. */ eol = lastnb_(list, list_len); /* As the King said to Alice: 'Begin at the beginning. */ /* Continue until you reach the end. Then stop.' */ /* When searching for items, B is the beginning of the current */ /* item; E is the end. E points to the next non-blank delimiter, */ /* if any; otherwise E points to either the last character */ /* preceding the next item, or to the last character of the list. */ b = 1; while(b <= eol) { /* Skip any blanks before the next item or delimiter. */ /* At this point in the loop, we know */ /* B <= EOL */ *(unsigned char *)bchr = *(unsigned char *)&list[b - 1]; while(b <= eol && *(unsigned char *)bchr == 32) { ++b; if (b <= eol) { *(unsigned char *)bchr = *(unsigned char *)&list[b - 1]; } } /* At this point B is the index of the next non-blank */ /* character BCHR, or else */ /* B == EOL + 1 */ /* The item ends at the next delimiter. */ e = b; if (e <= eol) { *(unsigned char *)echr = *(unsigned char *)&list[e - 1]; } else { *(unsigned char *)echr = ' '; } while(e <= eol && i_indx(delims, echr, delims_len, (ftnlen)1) == 0) { ++e; if (e <= eol) { *(unsigned char *)echr = *(unsigned char *)&list[e - 1]; } } /* (This is different from LPARSE. If the delimiter was */ /* a blank, find the next non-blank character. If it's not */ /* a delimiter, back up. This prevents constructions */ /* like 'a , b', where the delimiters are blank and comma, */ /* from being interpreted as three items instead of two. */ /* By definition, consecutive blanks, or a blank and any */ /* other delimiter, do not count as consecutive delimiters.) */ if (e <= eol && *(unsigned char *)echr == 32) { /* Find the next non-blank character. */ while(e <= eol && *(unsigned char *)echr == 32) { ++e; if (e <= eol) { *(unsigned char *)echr = *(unsigned char *)&list[e - 1]; } } if (e <= eol) { if (i_indx(delims, echr, delims_len, (ftnlen)1) == 0) { /* We're looking at a non-delimiter character. */ /* E is guaranteed to be > 1 if we're here, so the */ /* following subtraction is valid. */ --e; } } } /* The item now lies between B and E. Unless, of course, B and */ /* E are the same character; this can happen if the list */ /* starts or ends with a non-blank delimiter, or if we have */ /* stumbled upon consecutive delimiters. */ if (! valid) { /* If the array has not been validated, it's just an */ /* array, and we can insert items directly into it. */ /* Unless it's full, in which case we validate now and */ /* insert later. */ if (n < nmax) { ++n; if (e > b) { s_copy(set + (n + 5) * set_len, list + (b - 1), set_len, e - 1 - (b - 1)); } else { s_copy(set + (n + 5) * set_len, " ", set_len, (ftnlen) 1); } } else { validc_(&nmax, &nmax, set, set_len); valid = TRUE_; } } /* Once the set has been validated, the strings are inserted */ /* into the set if there's room. If there is not enough room */ /* in the set, let INSRTC signal the error. */ if (valid) { if (e > b) { insrtc_(list + (b - 1), set, e - 1 - (b - 1), set_len); } else { insrtc_(" ", set, (ftnlen)1, set_len); } if (failed_()) { chkout_("LPARSS", (ftnlen)6); return 0; } } /* If there are more items to be found, continue with the */ /* character following E (which is a delimiter). */ b = e + 1; } /* If the array has not yet been validated, validate it before */ /* returning. */ if (! valid) { validc_(&nmax, &n, set, set_len); } /* If the list ended with a (non-blank) delimiter, insert a */ /* blank item into the set. If there isn't any room, signal */ /* an error. */ if (i_indx(delims, list + (eol - 1), delims_len, (ftnlen)1) != 0) { insrtc_(" ", set, (ftnlen)1, set_len); /* If INSRTC failed to insert the blank because the set */ /* was already full, INSRTC will have signaled an error. */ /* No action is necessary here. */ } } chkout_("LPARSS", (ftnlen)6); return 0; } /* lparss_ */
/* $Procedure APPNDC ( Append an item to a character cell ) */ /* Subroutine */ int appndc_(char *item, char *cell, ftnlen item_len, ftnlen cell_len) { /* Builtin functions */ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ extern integer cardc_(char *, ftnlen); extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *, ftnlen, ftnlen); extern integer sizec_(char *, ftnlen); extern /* Subroutine */ int scardc_(integer *, char *, ftnlen); integer nwcard; extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen); extern logical return_(void); /* $ Abstract */ /* Append an item to a character cell. */ /* $ 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 */ /* $ Keywords */ /* CELLS */ /* $ Declarations */ /* $ Brief_I/O */ /* VARIABLE I/O DESCRIPTION */ /* -------- --- -------------------------------------------------- */ /* ITEM I The item to append. */ /* CELL I/O The cell to which ITEM will be appended. */ /* $ Detailed_Input */ /* ITEM is a character string which is to be appended to CELL. */ /* CELL is a character cell to which ITEM will be appended. */ /* $ Detailed_Output */ /* CELL is a character cell in which the last element is ITEM. */ /* $ Parameters */ /* None. */ /* $ Files */ /* None. */ /* $ Exceptions */ /* 1) If the cell is not large enough to accommodate the addition */ /* of a new element, the error SPICE(CELLTOOSMALL) is signalled. */ /* 2) If the length of the item is longer than the length of the */ /* cell, ITEM is truncated on the right. */ /* $ Particulars */ /* None. */ /* $ Examples */ /* In the following example, the item 'PLUTO' is appended to */ /* the character cell PLANETS. */ /* Before appending 'PLUTO', the cell contains: */ /* PLANETS (1) = 'MERCURY' */ /* PLANETS (2) = 'VENUS' */ /* PLANETS (3) = 'EARTH' */ /* PLANTES (4) = 'MARS' */ /* PLANETS (5) = 'JUPITER' */ /* PLANETS (6) = 'SATURN' */ /* PLANETS (7) = 'URANUS' */ /* PLANETS (8) = 'NEPTUNE' */ /* The call */ /* CALL APPNDC ( 'PLUTO', PLANETS ) */ /* appends the element 'PLUTO' at the location PLANETS (9), and the */ /* cardinality is updated. */ /* If the cell is not big enough to accomodate the addition of */ /* the item, an error is signalled. In this case, the cell is not */ /* altered. */ /* $ Restrictions */ /* None. */ /* $ Literature_References */ /* None. */ /* $ Author_and_Institution */ /* H.A. Neilan (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 (HAN) */ /* -& */ /* $ Index_Entries */ /* append an item to a character cell */ /* -& */ /* SPICELIB functions */ /* Local variables */ /* Standard SPICE error handling. */ if (return_()) { return 0; } else { chkin_("APPNDC", (ftnlen)6); } /* Check to see if the cell can accomodate the addition of a */ /* new item. If there is room, append the item to the cell and */ /* reset the cardinality. If the cell cannot accomodate the */ /* addition of a new item, signal an error. */ nwcard = cardc_(cell, cell_len) + 1; if (nwcard <= sizec_(cell, cell_len)) { s_copy(cell + (nwcard + 5) * cell_len, item, cell_len, item_len); scardc_(&nwcard, cell, cell_len); } else { setmsg_("The cell cannot accomodate the addition of the item *.", ( ftnlen)54); errch_("*", item, (ftnlen)1, item_len); sigerr_("SPICE(CELLTOOSMALL)", (ftnlen)19); } chkout_("APPNDC", (ftnlen)6); return 0; } /* appndc_ */
/* $Procedure UNIONC ( Union two character sets ) */ /* Subroutine */ int unionc_(char *a, char *b, char *c__, ftnlen a_len, ftnlen b_len, ftnlen c_len) { /* System generated locals */ integer i__1, i__2, i__3; /* Builtin functions */ integer i_len(char *, ftnlen); /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); integer s_cmp(char *, char *, ftnlen, ftnlen); logical l_lt(char *, char *, ftnlen, ftnlen), l_gt(char *, char *, ftnlen, ftnlen); /* Local variables */ integer over, acard, bcard; extern integer cardc_(char *, ftnlen); integer ccard; extern /* Subroutine */ int chkin_(char *, ftnlen); extern integer sizec_(char *, ftnlen); integer csize; extern /* Subroutine */ int scardc_(integer *, char *, ftnlen); integer apoint, bpoint; extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, ftnlen), excess_(integer *, char *, ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *, ftnlen); extern logical return_(void); /* $ Abstract */ /* Union two character 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 */ /* SETS */ /* $ Keywords */ /* CELLS, SETS */ /* $ Declarations */ /* $ Brief_I/O */ /* VARIABLE I/O DESCRIPTION */ /* -------- --- -------------------------------------------------- */ /* A I First input set. */ /* B I Second input set. */ /* C O Union 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 union of A and B (that is, all of */ /* the elements which are in A or B or both). */ /* If the size (maximum cardinality) of C is smaller */ /* than the cardinality of the union 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 UNION of two sets contains every element which is */ /* in the first set, or in the second set, or in both sets. */ /* {a,b} union {c,d} = {a,b,c,d} */ /* {a,b,c} {b,c,d} {a,b,c,d} */ /* {a,b,c,d} {} {a,b,c,d} */ /* {} {a,b,c,d} {a,b,c,d} */ /* {} {} {} */ /* The following call */ /* CALL UNIONC ( PLANETS, ASTEROIDS, RESULT ) */ /* places the union 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 UNIONI ( CURRENT, NEW, CURRENT ) */ /* CALL UNIONI ( 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 UNIONI ( CURRENT, NEW, TEMP ) */ /* CALL COPYI ( TEMP, NEW ) */ /* $ Restrictions */ /* None. */ /* $ Exceptions */ /* 1) If the union of the two sets causes an excess of elements, the */ /* error SPICE(SETEXCESS) is signalled. */ /* 2) If length of the elements of the output set is < the */ /* maximum of the lengths of the elements of the input */ /* sets, the error SPICE(ELEMENTSTOOSHORT) 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.1.0, 18-JUN-1999 (WLT) */ /* Made CHKOUT calls consistent with CHKIN. */ /* - 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 */ /* union two character sets */ /* -& */ /* $ Revisions */ /* - Beta Version 2.0.0, 05-JAN-1989 (NJB) */ /* Error signalled if output set elements are not long enough. */ /* Length must be at least max of lengths of input elements. */ /* Also, calling protocol for EXCESS has been changed. */ /* -& */ /* SPICELIB functions */ /* Local variables */ /* Set up the error processing. */ if (return_()) { return 0; } chkin_("UNIONC", (ftnlen)6); /* Make sure output set elements are long enough. */ /* Computing MAX */ i__1 = i_len(a, a_len), i__2 = i_len(b, b_len); if (i_len(c__, c_len) < max(i__1,i__2)) { setmsg_("Length of output cell is #. Length required to contain res" "ult is #.", (ftnlen)68); i__1 = i_len(c__, c_len); errint_("#", &i__1, (ftnlen)1); /* Computing MAX */ i__2 = i_len(a, a_len), i__3 = i_len(b, b_len); i__1 = max(i__2,i__3); errint_("#", &i__1, (ftnlen)1); sigerr_("SPICE(ELEMENTSTOOSHORT)", (ftnlen)23); chkout_("UNIONC", (ftnlen)6); return 0; } /* Find the cardinality of the input sets, and the allowed size */ /* of the output set. */ acard = cardc_(a, a_len); bcard = cardc_(b, b_len); csize = sizec_(c__, c_len); /* 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 ends of both input sets are 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 (apoint > acard) { ++ccard; s_copy(c__ + (ccard + 5) * c_len, b + (bpoint + 5) * b_len, c_len, b_len); ++bpoint; } else if (bpoint > bcard) { ++ccard; s_copy(c__ + (ccard + 5) * c_len, a + (apoint + 5) * a_len, c_len, a_len); ++apoint; } else if (s_cmp(a + (apoint + 5) * a_len, b + (bpoint + 5) * b_len, a_len, b_len) == 0) { ++ccard; s_copy(c__ + (ccard + 5) * c_len, a + (apoint + 5) * a_len, c_len, a_len); ++apoint; ++bpoint; } else if (l_lt(a + (apoint + 5) * a_len, b + (bpoint + 5) * b_len, a_len, b_len)) { ++ccard; s_copy(c__ + (ccard + 5) * c_len, a + (apoint + 5) * a_len, c_len, a_len); ++apoint; } else if (l_gt(a + (apoint + 5) * a_len, b + (bpoint + 5) * b_len, a_len, b_len)) { ++ccard; s_copy(c__ + (ccard + 5) * c_len, b + (bpoint + 5) * b_len, c_len, b_len); ++bpoint; } /* Otherwise, stop filling the array, but continue to count the */ /* number of elements in excess of the size of the output set. */ } else { if (apoint > acard) { ++over; ++bpoint; } else if (bpoint > bcard) { ++over; ++apoint; } else if (s_cmp(a + (apoint + 5) * a_len, b + (bpoint + 5) * b_len, a_len, b_len) == 0) { ++over; ++apoint; ++bpoint; } else if (l_lt(a + (apoint + 5) * a_len, b + (bpoint + 5) * b_len, a_len, b_len)) { ++over; ++apoint; } else if (l_gt(a + (apoint + 5) * a_len, b + (bpoint + 5) * b_len, a_len, b_len)) { ++over; ++bpoint; } } } /* Set the cardinality of the output set. */ scardc_(&ccard, c__, c_len); /* Report any excess. */ if (over > 0) { excess_(&over, "set", (ftnlen)3); sigerr_("SPICE(SETEXCESS)", (ftnlen)16); } chkout_("UNIONC", (ftnlen)6); return 0; } /* unionc_ */
/* $Procedure INSRTC ( Insert an item into a character set ) */ /* Subroutine */ int insrtc_(char *item, char *a, ftnlen item_len, ftnlen a_len) { /* System generated locals */ integer i__1, i__2; /* Builtin functions */ integer i_len(char *, ftnlen), s_cmp(char *, char *, ftnlen, ftnlen); /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ integer card, slen, last, size, i__; extern integer cardc_(char *, ftnlen); extern /* Subroutine */ int chkin_(char *, ftnlen); extern integer sizec_(char *, ftnlen); logical in; extern /* Subroutine */ int scardc_(integer *, char *, ftnlen); extern integer lstlec_(char *, integer *, char *, ftnlen, ftnlen); 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 character 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. If ITEM is longer than the */ /* length SLEN of the elements of A, only the substring */ /* consisting of the first SLEN characters of ITEM will */ /* be inserted into the set; any trailing non-blank */ /* characters in ITEM are ignored. */ /* 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 item into the set causes an excess */ /* of elements, the error SPICE(SETEXCESS) is signaled. */ /* 2) If the item to be inserted has greater length than the string */ /* length of the elements of the set, the item will be truncated */ /* on the right when it is inserted. The insertion point of */ /* the element will be determined by the comparison of the */ /* truncated item to members of the set. If, after truncation, */ /* the item to be inserted matches an element already present */ /* in the set, no insertion occurs. */ /* $ 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. */ /* $ Literature_References */ /* None. */ /* $ Restrictions */ /* 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) */ /* Bug fix: when the item to be inserted would, after */ /* truncation to the set's string length, match an item */ /* already in the set, no insertion is performed. Previously */ /* the truncated string was inserted, corrupting the set. */ /* 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 character set */ /* -& */ /* $ Revisions */ /* - SPICELIB Version 2.0.0, 01-NOV-2005 (NJB) */ /* Bug fix: when the item to be inserted would, after */ /* truncation to the set's string length, match an item */ /* already in the set, no insertion is performed. Previously */ /* the truncated string was inserted, corrupting the set. */ /* 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_("INSRTC", (ftnlen)6); /* What are the size and cardinality of the set? */ size = sizec_(a, a_len); card = cardc_(a, a_len); /* When we insert an item into the set, any trailing characters */ /* that don't fit are truncated. So in deciding where to insert */ /* the item, we ignore any characters that won't remain after */ /* insertion. */ /* We're going to consider only the initial substring of ITEM */ /* whose length doesn't exceed the string length of the set's */ /* members. */ /* Computing MIN */ i__1 = i_len(item, item_len), i__2 = i_len(a + a_len * 6, a_len); slen = min(i__1,i__2); /* 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 = lstlec_(item, &card, a + a_len * 6, slen, a_len); /* Is the item already in the set? If not, it needs to be inserted. */ if (last > 0) { in = s_cmp(a + (last + 5) * a_len, item, a_len, slen) == 0; } 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__) { s_copy(a + (i__ + 6) * a_len, a + (i__ + 5) * a_len, a_len, a_len); } s_copy(a + (last + 6) * a_len, item, a_len, slen); i__1 = card + 1; scardc_(&i__1, a, a_len); } 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_("INSRTC", (ftnlen)6); return 0; } /* insrtc_ */
/* $Procedure SYDUPC ( Create a duplicate of a symbol ) */ /* Subroutine */ int sydupc_(char *name__, char *copy, char *tabsym, integer * tabptr, char *tabval, ftnlen name_len, ftnlen copy_len, ftnlen tabsym_len, ftnlen tabval_len) { /* System generated locals */ integer i__1; /* Builtin functions */ integer s_cmp(char *, char *, ftnlen, ftnlen); /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ integer nval, nptr, nsym, i__; extern integer cardc_(char *, ftnlen), cardi_(integer *); extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *, ftnlen, ftnlen); extern integer sizec_(char *, ftnlen), sumai_(integer *, integer *), sizei_(integer *); extern /* Subroutine */ int scardc_(integer *, char *, ftnlen), remlac_( integer *, integer *, char *, integer *, ftnlen), scardi_(integer *, integer *), inslac_(char *, integer *, integer *, char *, integer *, ftnlen, ftnlen); integer dimval[2]; extern /* Subroutine */ int inslai_(integer *, integer *, integer *, integer *, integer *); integer locval[2]; extern integer lstlec_(char *, integer *, char *, ftnlen, ftnlen); extern /* Subroutine */ int sigerr_(char *, ftnlen); integer newval; extern /* Subroutine */ int chkout_(char *, ftnlen), setmsg_(char *, ftnlen); integer locsym[2]; logical oldsym[2]; extern logical return_(void); integer newsym; /* $ Abstract */ /* Create a duplicate of a symbol within a character symbol table. */ /* If a symbol with the new name already exists, its components */ /* are replaced. */ /* $ 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 to be duplicated. */ /* COPY I Name of the new symbol. */ /* TABSYM, */ /* TABPTR, */ /* TABVAL I/O Components of the symbol table. */ /* $ Detailed_Input */ /* NAME is the name of the symbol to be duplicated. The */ /* components associated with NAME will be given to the */ /* new symbol COPY. If NAME is not in the symbol table, */ /* no duplicate symbol can be made. */ /* COPY is the name of the new symbol. If a symbol with the */ /* name COPY already exists in the symbol table, its */ /* components are replaced by the components of NAME. */ /* TABSYM, */ /* TABPTR, */ /* TABVAL are the components of a character symbol table. */ /* $ Detailed_Output */ /* TABSYM, */ /* TABPTR, */ /* TABVAL are the components of a character symbol table. */ /* On output, the symbol table contains a new symbol COPY */ /* whose components are the same as the components of */ /* NAME. */ /* $ Parameters */ /* None. */ /* $ Files */ /* None. */ /* $ Exceptions */ /* 1) If the symbol NAME is not in the symbol table, the error */ /* SPICE(NOSUCHSYMBOL) is signalled. */ /* 2) If duplication of the symbol causes an overflow in the */ /* name table, the error SPICE(NAMETABLEFULL) is signalled. */ /* 3) If duplication of the symbol causes an overflow in the */ /* pointer table, the error SPICE(POINTERTABLEFULL) is signalled. */ /* 4) If duplication of the symbol causes an overflow in the */ /* value table, the error SPICE(VALUETABLEFULL) is signalled. */ /* $ Particulars */ /* If the symbol NAME is not in the symbol table, no duplicate symbol */ /* can be made. */ /* If the symbol COPY is already in the symbol table, its components */ /* are replaced by the components of NAME. */ /* $ Examples */ /* The contents of the symbol table are: */ /* BOHR --> HYDROGEN ATOM */ /* EINSTEIN --> SPECIAL RELATIVITY */ /* PHOTOELECTRIC EFFECT */ /* BROWNIAN MOTION */ /* FERMI --> NUCLEAR FISSION */ /* The code, */ /* CALL SYDUPC ( 'FERMI', 'HAHN', TABSYM, TABPTR, TABVAL ) */ /* produces the symbol table: */ /* BOHR --> HYDROGEN ATOM */ /* EINSTEIN --> SPECIAL RELATIVITY */ /* PHOTOELECTRIC EFFECT */ /* BROWNIAN MOTION */ /* FERMI --> NUCLEAR FISSION */ /* HAHN --> NUCLEAR FISSION */ /* The code, */ /* CALL SYDUPC ( 'STRASSMAN', 'HAHN', TABSYM, TABPTR, TABVAL ) */ /* produces the error SPICE(NOSUCHSYMBOL) because the symbol */ /* "STRASSMAN" is not in 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 */ /* create a duplicate of a symbol */ /* -& */ /* SPICELIB functions */ /* Local variables */ /* Standard SPICE error handling. */ if (return_()) { return 0; } else { chkin_("SYDUPC", (ftnlen)6); } /* How many symbols to start with? */ nsym = cardc_(tabsym, tabsym_len); nptr = cardi_(tabptr); nval = cardc_(tabval, tabval_len); /* Where do these symbols belong? Are they already in the table? */ locsym[0] = lstlec_(name__, &nsym, tabsym + tabsym_len * 6, name_len, tabsym_len); locsym[1] = lstlec_(copy, &nsym, tabsym + tabsym_len * 6, copy_len, tabsym_len); oldsym[0] = locsym[0] != 0 && s_cmp(tabsym + (locsym[0] + 5) * tabsym_len, name__, tabsym_len, name_len) == 0; oldsym[1] = locsym[1] != 0 && s_cmp(tabsym + (locsym[1] + 5) * tabsym_len, copy, tabsym_len, copy_len) == 0; /* If the original symbol is not in the table, we can't make a copy. */ if (! oldsym[0]) { setmsg_("SYDUPC: The symbol to be duplicated, #, is not in the symbo" "l table.", (ftnlen)67); errch_("#", name__, (ftnlen)1, name_len); sigerr_("SPICE(NOSUCHSYMBOL)", (ftnlen)19); /* Otherwise, we need to know the dimension, to check for overflow. */ } else { i__1 = locsym[0] - 1; locval[0] = sumai_(&tabptr[6], &i__1) + 1; dimval[0] = tabptr[locsym[0] + 5]; /* If the new symbol already exists, we need to know its dimension */ /* too, for the same reason. */ if (oldsym[1]) { i__1 = locsym[1] - 1; locval[1] = sumai_(&tabptr[6], &i__1) + 1; dimval[1] = tabptr[locsym[1] + 5]; newsym = 0; } else { locval[1] = sumai_(&tabptr[6], &locsym[1]) + 1; dimval[1] = 0; newsym = 1; } newval = dimval[0] - dimval[1]; /* Can we make a copy without overflow? */ if (nsym + newsym > sizec_(tabsym, tabsym_len)) { setmsg_("SYDUPC: Duplication of the symbol # causes an overflow " "in the name table.", (ftnlen)73); errch_("#", name__, (ftnlen)1, name_len); sigerr_("SPICE(NAMETABLEFULL)", (ftnlen)20); } else if (nptr + newsym > sizei_(tabptr)) { setmsg_("SYDUPC: Duplication of the symbol # causes an overflow " "in the pointer table.", (ftnlen)76); errch_("#", name__, (ftnlen)1, name_len); sigerr_("SPICE(POINTERTABLEFULL)", (ftnlen)23); } else if (nval + newval > sizec_(tabval, tabval_len)) { setmsg_("SYDUPC: Duplication of the symbol # causes an overflow " "in the value table.", (ftnlen)74); errch_("#", name__, (ftnlen)1, name_len); sigerr_("SPICE(VALUETABLEFULL)", (ftnlen)21); /* Looks like we can. */ } else { /* If the copy exists, remove the current contents and */ /* change the dimension. Otherwise add the new name and */ /* dimension to the name and pointer tables. */ if (dimval[1] > 0) { remlac_(&dimval[1], &locval[1], tabval + tabval_len * 6, & nval, tabval_len); scardc_(&nval, tabval, tabval_len); tabptr[locsym[1] + 5] = dimval[0]; if (locval[0] > locval[1]) { locval[0] -= dimval[1]; } } else { i__1 = locsym[1] + 1; inslac_(copy, &c__1, &i__1, tabsym + tabsym_len * 6, &nsym, copy_len, tabsym_len); scardc_(&nsym, tabsym, tabsym_len); i__1 = locsym[1] + 1; inslai_(dimval, &c__1, &i__1, &tabptr[6], &nptr); scardi_(&nptr, tabptr); } /* In either case, allocate space for the new symbol values, */ /* and copy them in one by one. (INSLAx won't work if the */ /* copy is earlier in the table than the original.) */ i__1 = locval[1]; for (i__ = nval; i__ >= i__1; --i__) { s_copy(tabval + (i__ + dimval[0] + 5) * tabval_len, tabval + ( i__ + 5) * tabval_len, tabval_len, tabval_len); } if (locval[0] > locval[1]) { locval[0] += dimval[0]; } i__1 = dimval[0] - 1; for (i__ = 0; i__ <= i__1; ++i__) { s_copy(tabval + (locval[1] + i__ + 5) * tabval_len, tabval + ( locval[0] + i__ + 5) * tabval_len, tabval_len, tabval_len); } i__1 = nval + dimval[0]; scardc_(&i__1, tabval, tabval_len); } } chkout_("SYDUPC", (ftnlen)6); return 0; } /* sydupc_ */
/* $Procedure PODDGC ( Pod, duplicate group, character ) */ /* Subroutine */ int poddgc_(char *pod, ftnlen pod_len) { integer need, have; extern integer cardc_(char *, ftnlen); extern /* Subroutine */ int chkin_(char *, ftnlen); extern integer sizec_(char *, ftnlen); extern /* Subroutine */ int podaec_(char *, integer *, char *, ftnlen, ftnlen), podbgc_(char *, ftnlen), podonc_(char *, integer *, integer *, ftnlen); integer offset, number; extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, ftnlen); extern logical return_(void); /* $ Abstract */ /* Begin a new group within a pod, containing the same elements */ /* as the active group. */ /* $ 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 */ /* PODS */ /* $ Keywords */ /* ARRAYS */ /* CELLS */ /* PODS */ /* $ Declarations */ /* $ Brief_I/O */ /* Variable I/O Description */ /* -------- --- -------------------------------------------------- */ /* POD I,O Pod. */ /* $ Detailed_Input */ /* POD on input, is an arbitrary pod. */ /* $ Detailed_Output */ /* POD on output, is the same pod, in which the active */ /* group has been sealed, and a new active group */ /* (containing the same elements as the previous group) */ /* begun. */ /* $ Parameters */ /* None. */ /* $ Exceptions */ /* 1) If POD does not have sufficient free space to create */ /* the new group, the pod is not changed, and the error */ /* SPICE(TOOMANYPEAS) is signalled. (If the active group */ /* contains no elements, there must be sufficient free */ /* space for the new group to contain at least one element.) */ /* $ Files */ /* None. */ /* $ Particulars */ /* There are two ways to create a new group within a pod. */ /* PODBG (begin group) seals the current contents of the pod, */ /* and creates a new active group containing no elements. */ /* PODDG (duplicate group) also seals the current contents */ /* of the pod, but places a copy of the previous active */ /* group into the new active group. */ /* In both cases, the active group and all previous groups are */ /* unavailable so long as the new group exists. */ /* The active group of a pod may be removed by any of the */ /* following routines: PODEG (end group), PODCG (close group), */ /* or PODRG (replace group). */ /* $ Examples */ /* Let the active group of POD be located in elements 21 */ /* through 40. Then following the call */ /* CALL PODBGC ( POD ) */ /* the active group is located in elements 42 through 41. */ /* In other words, element 41 has been appropriated by the */ /* pod itself, and the active group is empty. */ /* However, following the call */ /* CALL PODDG ( POD ) */ /* the active group is located in elements 42 through 61, */ /* and contains the same elements as the previous active */ /* group. */ /* $ Restrictions */ /* 1) In any pod, only the active group should be accessed, */ /* and its location should always be determined by PODBE */ /* or PODON. Never assume that the active group begins */ /* at POD(1). */ /* $ Literature_References */ /* None. */ /* $ Author_and_Institution */ /* W.L. Taber (JPL) */ /* I.M. Underwood (JPL) */ /* $ Version */ /* - Beta Version 1.0.0, 15-JUL-1989 (WLT) (IMU) */ /* -& */ /* SPICELIB functions */ /* Local parameters */ /* Local variables */ /* Standard SPICE error handling. */ if (return_()) { return 0; } else { chkin_("PODDGC", (ftnlen)6); } /* How many spaces are needed? One for bookkeeping, and one for */ /* each of the elements in the active group. (If there are no */ /* elements, then one for future use.) */ podonc_(pod, &offset, &number, pod_len); have = sizec_(pod, pod_len); need = cardc_(pod, pod_len) + 1 + max(1,number); if (have < need) { sigerr_("SPICE(TOOMANYPEAS)", (ftnlen)18); chkout_("PODDGC", (ftnlen)6); return 0; } /* Go ahead and create a new (empty) group. */ podbgc_(pod, pod_len); /* Append the old group (still in the same place) to the pod. */ /* (Somewhat incestuous, but practical.) Kids, don't try this */ /* at home: you aren't supposed to know that existing groups */ /* arent't changed by the addition of new ones. */ podaec_(pod + (offset + 6) * pod_len, &number, pod, pod_len, pod_len); chkout_("PODDGC", (ftnlen)6); return 0; } /* poddgc_ */