/* $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 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 META_2 ( Percy's interface to META_0 ) */ /* Subroutine */ int meta_2__0_(int n__, char *command, char *temps, integer * ntemps, char *temp, integer *btemp, char *error, ftnlen command_len, ftnlen temps_len, ftnlen temp_len, ftnlen error_len) { /* Initialized data */ static logical pass1 = TRUE_; static char margns[128] = "LEFT 1 RIGHT 75 " " " " "; static char keynam[6*10] = "1 " "2 " "3 " "4 " "5 " "6 " "7 " "8 " "9 " "10 "; /* System generated locals */ address a__1[5]; integer i__1, i__2[5]; /* Builtin functions */ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsle(cilist *), e_wsle( void); /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); integer do_lio(integer *, integer *, char *, ftnlen); /* Local variables */ extern /* Subroutine */ int getopt_1__(char *, integer *, char *, integer *, char *, integer *, char *, char *, ftnlen, ftnlen, ftnlen, ftnlen, ftnlen); static integer sbeg; static char mode[16], pick[32]; static integer b, e, i__, j; extern integer cardc_(char *, ftnlen); extern logical batch_(void); static integer score; static logical fixit; extern integer rtrim_(char *, ftnlen); static char style[128]; static integer m2code; static char tryit[600]; extern /* Subroutine */ int m2gmch_(char *, char *, char *, integer *, logical *, integer *, logical *, integer *, integer *, char *, ftnlen, ftnlen, ftnlen, ftnlen), m2rcvr_(integer *, integer *, char *, ftnlen), scardc_(integer *, char *, ftnlen); static integer bscore, cutoff; static logical reason; extern /* Subroutine */ int prefix_(char *, integer *, char *, ftnlen, ftnlen), ssizec_(integer *, char *, ftnlen), repsub_(char *, integer *, integer *, char *, char *, ftnlen, ftnlen, ftnlen); static logical intrct; extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen, ftnlen); static char thnwds[32*7], kwords[32*16]; extern /* Subroutine */ int cmprss_(char *, integer *, char *, char *, ftnlen, ftnlen, ftnlen), prepsn_(char *, ftnlen); static logical pssthn; static char questn[80]; extern /* Subroutine */ int niceio_3__(char *, integer *, char *, ftnlen, ftnlen), cnfirm_1__(char *, logical *, ftnlen); /* Fortran I/O blocks */ static cilist io___19 = { 0, 6, 0, 0, 0 }; static cilist io___20 = { 0, 6, 0, 0, 0 }; static cilist io___21 = { 0, 6, 0, 0, 0 }; static cilist io___22 = { 0, 6, 0, 0, 0 }; static cilist io___23 = { 0, 6, 0, 0, 0 }; static cilist io___27 = { 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___31 = { 0, 6, 0, 0, 0 }; /* $ Abstract */ /* Given a collection of acceptable syntax's and a statement */ /* (COMMAND) this routine determines if the statement is */ /* syntactically correct. */ /* $ Disclaimer */ /* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */ /* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */ /* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */ /* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */ /* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */ /* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */ /* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */ /* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */ /* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */ /* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */ /* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */ /* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */ /* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */ /* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */ /* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */ /* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */ /* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */ /* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */ /* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */ /* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */ /* $ Required_Reading */ /* The META/2 Book. */ /* $ Keywords */ /* COMPARE */ /* PARSING */ /* SEARCH */ /* $ Declarations */ /* $ Brief_I/O */ /* VARIABLE I/O DESCRIPTION */ /* -------- --- -------------------------------------------------- */ /* COMMAND I A candidate PERCY command. */ /* TEMPS I A collection of language definition statements */ /* NTEMPS I The number of definition statements */ /* TEMP - Work space required for comparison of statements. */ /* BTEMP O The first of the def statements that best matches. */ /* ERROR O Non-blank if none of the def's match. */ /* $ Detailed_Input */ /* COMMAND A candidate PERCY command. */ /* TEMPS A collection of language definition statements */ /* NTEMPS The number of definition statements */ /* TEMP Work space required for comparison of statements. */ /* TEMP should be declared to have the same length */ /* as the character strings that make up TEMPS. */ /* $ Detailed_Output */ /* BTEMP The first of the def statements that best matches. */ /* ERROR Non-blank if none of the def's match. */ /* $ Files */ /* None. */ /* $ Exceptions */ /* None. */ /* $ Particulars */ /* Later. */ /* $ Examples */ /* Later. */ /* $ Restrictions */ /* $ Literature_References */ /* None. */ /* $ Author_and_Institution */ /* H.A. Neilan (JPL) */ /* W.L. Taber (JPL) */ /* I.M. Underwood (JPL) */ /* $ Version */ /* - META/2 Configured Version 3.0.0, 11-AUG-1995 (WLT) */ /* The control flow through this routine was modified */ /* so that it will now re-try all templates (starting */ /* with the best previous match) if a spelling error */ /* is encountered. This should fix the confused */ /* responses that META/2 gave occassionally before. */ /* - META/2 Configured Version 2.0.0, 9-MAY-1994 (WLT) */ /* This is the configured version of the Command Loop */ /* software as of May 9, 1994 */ /* - META/2 Configured Version 2.0.0, 9-MAY-1994 */ /* Added a pretty print formatting capability to the */ /* error diagnostics. */ /* - META/2 Configured Version 1.0.0, 3-MAY-1994 (WLT) */ /* This is the configured version of META/2 */ /* software as of May 3, 1994 */ /* - Beta Version 2.0.0, 14-JAN-1993 (HAN) */ /* Assigned the value 'INTERACTIVE' to the variable MODE, and */ /* replaced calls to VTLIB routines with calls to more */ /* portable routines. */ /* - Beta Version 1.0.0, 13-JUL-1988 (WLT) (IMU) */ /* -& */ /* Spice Functions */ /* Local variables. */ /* Saved variables */ /* Initial values */ /* Parameter adjustments */ if (temps) { } if (error) { } /* Function Body */ switch(n__) { case 1: goto L_m2marg; } /* %&END_DECLARATIONS */ /* Take care of first pass initializations. */ if (pass1) { pass1 = FALSE_; ssizec_(&c__1, thnwds, (ftnlen)32); scardc_(&c__0, thnwds, (ftnlen)32); ssizec_(&c__10, kwords, (ftnlen)32); scardc_(&c__0, kwords, (ftnlen)32); /* Determine if were in batch or interactive mode. */ if (batch_()) { s_copy(mode, "BATCH", (ftnlen)16, (ftnlen)5); } else { s_copy(mode, "INTERACTIVE", (ftnlen)16, (ftnlen)11); } } intrct = s_cmp(mode, "BATCH", (ftnlen)16, (ftnlen)5) != 0; s_copy(style, margns, (ftnlen)128, (ftnlen)128); suffix_("NEWLINE /cr VTAB /vt HARDSPACE , ", &c__1, style, (ftnlen)33, ( ftnlen)128); i__ = 0; bscore = -1; m2code = -1; cutoff = 72; reason = TRUE_; /* Look through the templates until we get a match or we */ /* run out of templates to try. */ i__1 = *ntemps; for (i__ = 1; i__ <= i__1; ++i__) { score = 0; s_copy(temp, temps + (i__ - 1) * temps_len, temp_len, temps_len); sbeg = 1; m2code = 0; m2gmch_(temp, thnwds, command, &sbeg, &reason, &cutoff, &pssthn, & m2code, &score, error, temp_len, (ftnlen)32, command_len, error_len); /* If M2CODE comes back zero, we are done with the work */ /* of this routine. */ if (m2code == 0) { *btemp = i__; return 0; } if (score > bscore) { bscore = score; *btemp = i__; } } /* If we get here, we know we didn't have a match. Examine the */ /* highest scoring template to get available diagnostics */ /* about the mismatch. */ s_copy(temp, temps + (*btemp - 1) * temps_len, temp_len, temps_len); sbeg = 1; fixit = TRUE_; m2code = 0; m2gmch_(temp, thnwds, command, &sbeg, &c_true, &cutoff, &pssthn, &m2code, &score, error, temp_len, (ftnlen)32, command_len, error_len); /* If we are in interactiive mode and we have a spelling error, we */ /* can attempt to fix it. Note this occurs only if the M2CODE */ /* is less than 100 mod 10000. */ while(m2code % 10000 < 100 && intrct && fixit) { /* Construct a friendly message; display it; and */ /* get the user's response as to whether or not the */ /* command should be modified. */ s_copy(tryit, error, (ftnlen)600, error_len); prefix_("Hmmmm.,,,", &c__1, tryit, (ftnlen)9, (ftnlen)600); suffix_("/cr/cr I can repair this if you like.", &c__0, tryit, ( ftnlen)37, (ftnlen)600); s_wsle(&io___19); e_wsle(); niceio_3__(tryit, &c__6, style, (ftnlen)600, (ftnlen)128); s_wsle(&io___20); e_wsle(); s_wsle(&io___21); e_wsle(); s_wsle(&io___22); e_wsle(); s_wsle(&io___23); e_wsle(); m2rcvr_(&b, &e, kwords, (ftnlen)32); if (cardc_(kwords, (ftnlen)32) == 1) { /* Writing concatenation */ i__2[0] = 17, a__1[0] = "Should I change \""; i__2[1] = e - (b - 1), a__1[1] = command + (b - 1); i__2[2] = 6, a__1[2] = "\" to \""; i__2[3] = rtrim_(kwords + 192, (ftnlen)32), a__1[3] = kwords + 192; i__2[4] = 3, a__1[4] = "\" ?"; s_cat(questn, a__1, i__2, &c__5, (ftnlen)80); cnfirm_1__(questn, &fixit, rtrim_(questn, (ftnlen)80)); } else { cnfirm_1__("Should I fix it?", &fixit, (ftnlen)16); } /* If the user has elected to have us fix the command */ /* we have a few things to do... */ if (fixit) { /* Look up the suggested fixes. If there is more than */ /* one possibility, see which one the user thinks is */ /* best. Otherwise, no more questions for now. */ m2rcvr_(&b, &e, kwords, (ftnlen)32); if (cardc_(kwords, (ftnlen)32) > 1) { i__1 = cardc_(kwords, (ftnlen)32) - 4; for (i__ = 1; i__ <= i__1; ++i__) { s_wsle(&io___27); e_wsle(); } i__1 = cardc_(kwords, (ftnlen)32); getopt_1__("Which word did you mean?", &i__1, keynam, &c__6, kwords + 192, &c__32, kwords + 192, pick, (ftnlen)24, (ftnlen)6, (ftnlen)32, (ftnlen)32, (ftnlen)32); } else { s_copy(pick, kwords + 192, (ftnlen)32, (ftnlen)32); } /* Make the requested repairs on the command, and */ /* redisplay the command. */ repsub_(command, &b, &e, pick, command, command_len, (ftnlen)32, command_len); cmprss_(" ", &c__1, command, command, (ftnlen)1, command_len, command_len); s_wsle(&io___29); do_lio(&c__9, &c__1, " ", (ftnlen)1); e_wsle(); s_wsle(&io___30); do_lio(&c__9, &c__1, " ", (ftnlen)1); e_wsle(); niceio_3__(command, &c__6, style, command_len, (ftnlen)128); s_wsle(&io___31); e_wsle(); /* Look through the templates again until we get a match or we */ /* run out of templates to try. Note however, that this time */ /* we will start in a different spot. We already have a best */ /* matching template. We'll start our search for a match */ /* there and simulate a circular list of templates so that */ /* we can examine all of them if necessary. */ s_copy(error, " ", error_len, (ftnlen)1); s_copy(error + error_len, " ", error_len, (ftnlen)1); bscore = -1; m2code = -1; cutoff = 72; reason = TRUE_; j = *btemp - 1; i__1 = *ntemps; for (i__ = 1; i__ <= i__1; ++i__) { /* Get the index of the next template to examine. */ ++j; while(j > *ntemps) { j -= *ntemps; } /* Set the template, score for this template, spot to */ /* begin examining it and the M2CODE so far. */ s_copy(temp, temps + (j - 1) * temps_len, temp_len, temps_len) ; sbeg = 1; score = 0; m2code = 0; m2gmch_(temp, thnwds, command, &sbeg, &reason, &cutoff, & pssthn, &m2code, &score, error, temp_len, (ftnlen)32, command_len, error_len); /* If we get back a zero M2CODE we've got a match */ /* This routine's work is done. */ if (m2code == 0) { *btemp = i__; return 0; } /* Hmmph. No match. See if we've got a better */ /* matching score so far and then go on to the next */ /* template if any are left. */ if (score > bscore) { bscore = score; *btemp = i__; } } /* If we made it to this point the command doesn't properly */ /* match any of the templates. Get the best match and */ /* determine the diagnostics for this template. */ s_copy(temp, temps + (*btemp - 1) * temps_len, temp_len, temps_len); sbeg = 1; m2code = 0; score = 0; m2gmch_(temp, thnwds, command, &sbeg, &reason, &cutoff, &pssthn, & m2code, &score, error, temp_len, (ftnlen)32, command_len, error_len); } } /* If you get to this point. We didn't have a match set up */ /* the second level of mismatch diagnostics using the best */ /* matching template. (BTEMP already points to it.) */ s_copy(temp, temps + (*btemp - 1) * temps_len, temp_len, temps_len); cmprss_(" ", &c__1, temp, temp, (ftnlen)1, temp_len, temp_len); prepsn_(temp, temp_len); prepsn_(error + error_len, error_len); prefix_("/cr/cr(-3:-3) ", &c__1, error + error_len, (ftnlen)14, error_len) ; prefix_(temp, &c__1, error + error_len, temp_len, error_len); prefix_("/cr/cr(3:3) ", &c__1, error + error_len, (ftnlen)12, error_len); prefix_("a command with the following syntax:", &c__3, error + error_len, (ftnlen)36, error_len); prefix_("I Believe you were trying to enter", &c__1, error + error_len, ( ftnlen)34, error_len); prefix_("META/2:", &c__1, error + error_len, (ftnlen)7, error_len); return 0; /* The following entry point allows user's to adjust the margins */ /* of the META/2 error messages. */ L_m2marg: s_copy(margns, temp, (ftnlen)128, temp_len); return 0; } /* meta_2__ */
/* $Procedure PODREC ( Pod, remove elements, character ) */ /* Subroutine */ int podrec_(integer *n, integer *loc, char *pod, ftnlen pod_len) { /* System generated locals */ integer i__1; /* Local variables */ extern /* Subroutine */ int chkin_(char *, ftnlen), scardc_(integer *, char *, ftnlen), remlac_(integer *, integer *, char *, integer *, ftnlen), podonc_(char *, integer *, integer *, ftnlen); integer offset, number; extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *, ftnlen); extern logical return_(void); integer end; /* $ Abstract */ /* Remove elements beginning at a specified location within the */ /* active group of a pod. */ /* $ 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 */ /* ARRAY */ /* CELLS */ /* PODS */ /* $ Declarations */ /* $ Brief_I/O */ /* Variable I/O Description */ /* -------- --- -------------------------------------------------- */ /* N I Number of elements to remove. */ /* LOC I Location of first element to be removed. */ /* POD I,O Pod. */ /* $ Detailed_Input */ /* N is the number of elements to be removed from the */ /* active group of POD. */ /* LOC is the location (within the active group of the pod) */ /* of the first element to be removed. */ /* POD on input, is a pod. */ /* $ Detailed_Output */ /* POD on output, is the same pod, the active group of */ /* which contains the elements preceding and following */ /* the removed elements. */ /* $ Parameters */ /* None. */ /* $ Exceptions */ /* 1) If N is not positive, the pod is not changed. */ /* 2) If the location of the last element to be removed (LOC+N-1) */ /* is greater than the number of elements in the active group, */ /* the pod is not changed, and the error SPICE(NOTENOUGHPEAS) */ /* is signalled. */ /* 3) If the location specified for location is not in the range */ /* [1,NC], where NC is the number of elements in the active */ /* group of the pod, the pod is not changed, and the error */ /* SPICE(BADPODLOCATION) is signalled. */ /* $ Files */ /* None. */ /* $ Particulars */ /* This routine allows you to remove elements from the active */ /* group of a pod without having to worry about checking for */ /* impossible requests beforehand, or updating the cardinality */ /* afterwards. */ /* $ Examples */ /* Elements can be removed from the active group of a pod */ /* by hand, */ /* CALL PODONC ( POD, OFFSET, NUMBER ) */ /* END = OFFSET + NUMBER */ /* CALL REMLAC ( N, OFFSET + LOC, POD(1), END ) */ /* CALL SCARDC ( END, POD ) */ /* However, this is tedious, and it gets worse when you have to */ /* check for impossible requests. PODRE accomplishes the same thing, */ /* CALL PODIEC ( N, LOC, POD ) */ /* more simply, and with error-handling built in. */ /* $ 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 variables */ /* Standard SPICE error handling. */ if (return_()) { return 0; } else { chkin_("PODREC", (ftnlen)6); } /* Three things can go `wrong': */ /* 1) No items to remove. */ /* 2) Too many items to remove. */ /* 3) No place to remove them from. */ podonc_(pod, &offset, &number, pod_len); if (*n < 1) { chkout_("PODREC", (ftnlen)6); return 0; } else if (*loc + *n - 1 > number) { setmsg_("LOC = #; N = #; there are only # elements.", (ftnlen)42); errint_("#", loc, (ftnlen)1); errint_("#", n, (ftnlen)1); errint_("#", &number, (ftnlen)1); sigerr_("SPICE(NOTENOUGHPEAS)", (ftnlen)20); chkout_("PODREC", (ftnlen)6); return 0; } else if (*loc < 1 || *loc > number) { setmsg_("Location (#) must be in the range [1,#].", (ftnlen)40); errint_("#", loc, (ftnlen)1); errint_("#", &number, (ftnlen)1); sigerr_("SPICE(BADPODLOCATION)", (ftnlen)21); chkout_("PODREC", (ftnlen)6); return 0; } /* No problem. This is just like $Examples, above. */ end = offset + number; i__1 = offset + *loc; remlac_(n, &i__1, pod + pod_len * 6, &end, pod_len); scardc_(&end, pod, pod_len); chkout_("PODREC", (ftnlen)6); return 0; } /* podrec_ */
/* $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 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 REMOVC ( Remove an item from a character set ) */ /* Subroutine */ int removc_(char *item, char *a, ftnlen item_len, ftnlen a_len) { /* System generated locals */ integer i__1; /* Builtin functions */ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ integer card, i__; extern integer cardc_(char *, ftnlen); extern /* Subroutine */ int chkin_(char *, ftnlen); logical in; extern /* Subroutine */ int scardc_(integer *, char *, ftnlen); extern integer bsrchc_(char *, integer *, char *, ftnlen, ftnlen); extern /* Subroutine */ int chkout_(char *, ftnlen); extern logical return_(void); integer loc; /* $ Abstract */ /* Remove an item from 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 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 character 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_("REMOVC", (ftnlen)6); } /* What is the cardinality of the set? */ card = cardc_(a, a_len); /* Determine the location (if any) of the item within the set. */ loc = bsrchc_(item, &card, a + a_len * 6, item_len, a_len); /* 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__) { s_copy(a + (i__ + 5) * a_len, a + (i__ + 6) * a_len, a_len, a_len) ; } i__1 = card - 1; scardc_(&i__1, a, a_len); } chkout_("REMOVC", (ftnlen)6); return 0; } /* removc_ */