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