/* Subroutine */ int chunk_(char *buffer, integer *first, integer *last,
ftnlen buffer_len)
{
/* Initialized data */
static char terms[32*24] = "|endliteral " "!endliter"
"al " "@chapter " "@se"
"ction " "@setvarsize "
"@var " "@setparamsize "
" " "@param " "@literal "
" " "@literalitem " "@literalparam "
" " "@literalvar " "@exliteral"
" " "@exliteralitem " "@exl"
"iteralparam " "@exliteralvar "
"@newlist " "@newpage "
" " "@numitem " "@paritem "
" " "@symitem " "@moreparam "
" " "@morevar " " "
" ";
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
char cseq[32];
extern integer cpos_(char *, char *, integer *, ftnlen, ftnlen);
integer term, i__, j;
extern integer cardc_(char *, ftnlen);
integer begin;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer index;
extern integer ncpos_(char *, char *, integer *, ftnlen, ftnlen);
integer nterm;
extern integer ltrim_(char *, ftnlen);
integer endbuf;
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen),
touchi_(integer *);
extern /* Subroutine */ int chkout_(char *, ftnlen);
extern logical return_(void);
integer end;
/* Find the next `chunk' of a FORTeX source buffer. The chunk begins */
/* sometime after BUFFER(FIRST), and ends at BUFFER(LAST). */
/* $ Revisions */
/* - Faketex version 1.3.0 5-DEC-1995 WLT */
/* Set I = TOUCHI( I ) in the IF ( RETURN() ) block so that buggy */
/* compilers won't complain that it isn't used. */
/* - Faketex version 1.2.0 17-NOV-1995 NJB */
/* Data statement for TERMS broken up into multiple statements */
/* to avoid violation of continuation limit on Sun. */
/* - Faketex version 1.1.0 16-MAY-1994 NJB */
/* Substring bounds on line 106 safeguarded to stay in range. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling */
if (return_()) {
i__ = 0;
i__ = touchi_(&i__);
return 0;
} else {
chkin_("CHUNK", (ftnlen)5);
}
/* Because we can safely assume that the first line of the chunk */
/* is not inside a literal section, we can skip blank lines and */
/* @newpage directives with impunity to find the beginning of the */
/* chunk. */
endbuf = cardc_(buffer, buffer_len);
j = ltrim_(buffer + (*first + 5) * buffer_len, buffer_len);
while(*first < endbuf && (s_cmp(buffer + (*first + 5) * buffer_len, " ",
buffer_len, (ftnlen)1) == 0 || s_cmp(buffer + ((*first + 5) *
buffer_len + (j - 1)), "@newpage", buffer_len - (j - 1), (ftnlen)
8) == 0)) {
++(*first);
}
*last = *first;
/* A literal chunk may be terminated only by an explicit end marker */
/* (|endliteral or !endliteral) or the end of the buffer. A normal */
/* chunk is terminated by the beginning of another chunk, a */
/* blank line, or a @newpage. */
/* Computing MAX */
i__1 = 1, i__2 = ncpos_(buffer + (*first + 5) * buffer_len, " ", &c__1,
buffer_len, (ftnlen)2);
begin = max(i__1,i__2);
/* Computing MAX */
i__1 = begin, i__2 = cpos_(buffer + (*first + 5) * buffer_len, " {", &
begin, buffer_len, (ftnlen)2) - 1;
end = max(i__1,i__2);
s_copy(cseq, buffer + ((*first + 5) * buffer_len + (begin - 1)), (ftnlen)
32, end - (begin - 1));
if (s_cmp(cseq, "@literal", (ftnlen)8, (ftnlen)8) == 0) {
term = 1;
nterm = 1;
} else if (s_cmp(cseq, "@exliteral", (ftnlen)10, (ftnlen)10) == 0) {
term = 2;
nterm = 1;
} else {
term = 3;
nterm = 22;
}
/* Check subsequent lines until the proper terminator or the end */
/* of the buffer is reached. */
index = 0;
while(index == 0 && *last < endbuf) {
++(*last);
if (s_cmp(buffer + (*last + 5) * buffer_len, " ", buffer_len, (ftnlen)
1) == 0) {
s_copy(cseq, " ", (ftnlen)32, (ftnlen)1);
} else {
begin = ncpos_(buffer + (*last + 5) * buffer_len, " ", &c__1,
buffer_len, (ftnlen)2);
/* Computing MAX */
i__1 = begin, i__2 = cpos_(buffer + (*last + 5) * buffer_len,
" {", &begin, buffer_len, (ftnlen)2) - 1;
end = max(i__1,i__2);
s_copy(cseq, buffer + ((*last + 5) * buffer_len + (begin - 1)), (
ftnlen)32, end - (begin - 1));
}
index = isrchc_(cseq, &nterm, terms + (((i__1 = term - 1) < 24 && 0 <=
i__1 ? i__1 : s_rnge("terms", i__1, "chunk_", (ftnlen)193))
<< 5), (ftnlen)32, (ftnlen)32);
}
/* Only a literal section retains the line that terminates it. */
if (term > 2 && *last != endbuf) {
--(*last);
}
chkout_("CHUNK", (ftnlen)5);
return 0;
} /* chunk_ */
/* $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 SYNTHI ( Return the Nth component of a symbol ) */
/* Subroutine */ int synthi_(char *name__, integer *nth, char *tabsym,
integer *tabptr, integer *tabval, integer *value, logical *found,
ftnlen name_len, ftnlen tabsym_len)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer nsym;
extern integer cardc_(char *, ftnlen);
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern integer sumai_(integer *, integer *), bsrchc_(char *, integer *,
char *, ftnlen, ftnlen);
integer locval;
extern /* Subroutine */ int chkout_(char *, ftnlen);
integer locsym;
extern logical return_(void);
/* $ Abstract */
/* Return the Nth component of a particular symbol in an integer */
/* symbol table. */
/* $ 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 Nth component is to be */
/* returned. */
/* NTH I Index of the value to be returned. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL I Components of the symbol table. */
/* VALUE O Nth value associated with the symbol. */
/* FOUND O True if the Nth value of the symbol exists, false */
/* if it does not. */
/* $ Detailed_Input */
/* NAME is the name of the symbol whose Nth component is to be */
/* returned. If NAME is not in the symbol table, FOUND is */
/* false. */
/* NTH is the index of the component to be returned. If the */
/* value of NTH is out of range ( NTH < 1 or NTH is */
/* greater than the dimension of the symbol ) FOUND is */
/* false. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL are the components of an integer symbol table. */
/* The symbol table is not modified by this subroutine. */
/* $ Detailed_Output */
/* VALUES is the NTH component of the symbol NAME. */
/* FOUND is true if NAME is in the symbol table and the NTH */
/* component of NAME exists. Otherwise FOUND is false. */
/* $ Parameters */
/* None. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Particulars */
/* Two conditions will cause the value of FOUND to be false: */
/* 1) The symbol NAME is not in the symbol table. */
/* 2) NTH is out of range ( NTH < 1 or NTH is greater than the */
/* dimension of the symbol ). */
/* $ Examples */
/* The contents of the symbol table are: */
/* books --> 5 */
/* erasers --> 6 */
/* pencils --> 12 */
/* 24 */
/* pens --> 10 */
/* 12 */
/* 24 */
/* The calls, */
/* CALL SYNTHI ( 'pens', 2, TABSYM, TABPTR, TABVAL, VALUE, */
/* . FOUND ) */
/* CALL SYNTHI ( 'pencils', 3, TABSYM, TABPTR, TABVAL, VALUE, */
/* . FOUND ) */
/* CALL SYNTHI ( 'chairs', 1, TABPTR, TABVAL, TABVAL, VALUE, */
/* . FOUND ) */
/* return the values of VALUE and FOUND corresponding to NAME and */
/* NTH: */
/* NAME NTH VALUE FOUND */
/* ---------- ----- ------- ------- */
/* pens 2 12 TRUE */
/* pencils FALSE */
/* chairs FALSE */
/* $ 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 */
/* fetch nth value associated with a symbol */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SYNTHI", (ftnlen)6);
}
/* How many symbols to start with? */
nsym = cardc_(tabsym, tabsym_len);
/* 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 the value of NTH is out of range, that's a problem too. */
} else if (*nth < 1 || *nth > tabptr[locsym + 5]) {
*found = FALSE_;
/* Otherwise, we can proceed without fear of error. Merely locate */
/* and return the appropriate component from the values table. */
} else {
*found = TRUE_;
i__1 = locsym - 1;
locval = sumai_(&tabptr[6], &i__1) + *nth;
*value = tabval[locval + 5];
}
chkout_("SYNTHI", (ftnlen)6);
return 0;
} /* synthi_ */
/* $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 SYORDD ( Order the components of a single symbol ) */
/* Subroutine */ int syordd_(char *name__, char *tabsym, integer *tabptr,
doublereal *tabval, ftnlen name_len, ftnlen tabsym_len)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer nsym;
extern integer cardc_(char *, ftnlen);
integer n;
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern integer sumai_(integer *, integer *), bsrchc_(char *, integer *,
char *, ftnlen, ftnlen);
extern /* Subroutine */ int shelld_(integer *, doublereal *);
integer locval;
extern /* Subroutine */ int chkout_(char *, ftnlen);
integer locsym;
extern logical return_(void);
/* $ Abstract */
/* Order the components of a single symbol in a double precision */
/* symbol table. The components are sorted in increasing order. */
/* $ 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 components are to be */
/* ordered. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL I/O Components of the symbol table. */
/* $ Detailed_Input */
/* NAME is the name of the symbol whose components are to be */
/* ordered. If NAME is not in the symbol table, the symbol */
/* table is not modified. */
/* 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 components of the symbol are sorted in increasing */
/* order. */
/* $ Parameters */
/* None. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Particulars */
/* If the symbol NAME is not in the symbol table, the symbol table */
/* is not modified. */
/* $ 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 SYORDD ( 'BODY4_POLE_RA', TABSYM, TABPTR, TABVAL ) */
/* modifies the contents of the symbol table to be: */
/* BODY4_POLE_RA --> 0.0D0 */
/* 1.08D-1 */
/* 3.17681D2 */
/* DELTA_T_A --> 3.2184D1 */
/* K --> 1.657D-3 */
/* MEAN_ANOM --> 6.239996D0 */
/* 1.99096871D-7 */
/* ORBIT_ECC --> 1.671D-2 */
/* Note that the call, */
/* CALL SYORDD ( 'BODY4_PRIME', TABSYM, TABPTR, TABVAL ) */
/* will not modify the symbol table because the symbol "BODY4_PRIME" */
/* 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 */
/* order the components of a single symbol */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SYORDD", (ftnlen)6);
}
/* How many symbols? */
nsym = cardc_(tabsym, tabsym_len);
/* Is this symbol even in the table? */
locsym = bsrchc_(name__, &nsym, tabsym + tabsym_len * 6, name_len,
tabsym_len);
/* If so, sort the components in place. */
if (locsym > 0) {
i__1 = locsym - 1;
locval = sumai_(&tabptr[6], &i__1) + 1;
n = tabptr[locsym + 5];
shelld_(&tabptr[locsym + 5], &tabval[locval + 5]);
}
chkout_("SYORDD", (ftnlen)6);
return 0;
} /* syordd_ */
/* $Procedure SYDIMI ( Return the dimension of a symbol ) */
integer sydimi_(char *name__, char *tabsym, integer *tabptr, integer *tabval,
ftnlen name_len, ftnlen tabsym_len)
{
/* System generated locals */
integer ret_val;
/* Local variables */
integer nsym;
extern integer cardc_(char *, ftnlen);
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern integer bsrchc_(char *, integer *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int chkout_(char *, ftnlen);
integer locsym;
extern logical return_(void);
/* $ Abstract */
/* Return the dimension of a particular symbol in an integer symbol */
/* table. If the symbol is not found, the function returns the */
/* value zero. */
/* $ 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 dimension is desired. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL I/O Components of the symbol table. */
/* The function returns the dimension of the symbol NAME. If NAME is */
/* not in the symbol table, the function returns the value zero. */
/* $ Detailed_Input */
/* NAME is the name of the symbol whose dimension is to be */
/* returned. If the symbol is not in the symbol table, the */
/* function returns the value zero. This function is case */
/* sensitive, NAME must match a symbol exactly. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL are the components of an integer symbol table. */
/* The table may or may not contain the symbol NAME. */
/* $ Detailed_Output */
/* The function returns the dimension of the symbol NAME. The */
/* dimension of a symbol is the number of values associated with */
/* that symbol. If NAME is not in the symbol table, the function */
/* returns the value zero. */
/* $ Parameters */
/* None. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* The contents of the symbol table are: */
/* books --> 5 */
/* 8 */
/* erasers --> 6 */
/* pencils --> 12 */
/* pens --> 10 */
/* 12 */
/* 24 */
/* Let NUMVAL be equal to the dimension of the symbols in the table. */
/* The following code returns the values of NUMVAL indicated in the */
/* table. */
/* NUMVAL = SYDIMI ( 'books', TABSYM, TABPTR, TABVAL ) */
/* NUMVAL = SYDIMI ( 'pencils', TABSYM, TABPTR, TABVAL ) */
/* NUMVAL = SYDIMI ( 'pens', TABSYM, TABPTR, TABVAL ) */
/* NUMVAL = SYDIMI ( 'erasers', TABSYM, TABPTR, TABVAL ) */
/* NUMVAL = SYDIMI ( 'tablets', TABSYM, TABPTR, TABVAL ) */
/* ----SYMBOL----------NUMVAL------ */
/* | books | 2 | */
/* | pencils | 1 | */
/* | pens | 3 | */
/* | erasers | 1 | */
/* | tablets | 0 | */
/* -------------------------------- */
/* Note that the dimension of "tablets" is zero. This is due to the */
/* fact that "tablets" 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.1.0, 17-MAY-1994 (HAN) */
/* If the value of the function RETURN is TRUE upon execution of */
/* this module, this function is assigned a default value of */
/* either 0, 0.0D0, .FALSE., or blank depending on the type of */
/* the function. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) (HAN) */
/* -& */
/* $ Index_Entries */
/* fetch the dimension of a symbol */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling */
if (return_()) {
ret_val = 0;
return ret_val;
} else {
chkin_("SYDIMI", (ftnlen)6);
}
/* How many symbols to start with? */
nsym = cardc_(tabsym, tabsym_len);
/* 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, return zero. Otherwise, look up */
/* the dimension directly. */
if (locsym == 0) {
ret_val = 0;
} else {
ret_val = tabptr[locsym + 5];
}
chkout_("SYDIMI", (ftnlen)6);
return ret_val;
} /* sydimi_ */
/* $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_ */
/* $Procedure SYFETC ( Fetch the Nth symbol in the table ) */
/* Subroutine */ int syfetc_(integer *nth, char *tabsym, integer *tabptr,
char *tabval, char *name__, logical *found, ftnlen tabsym_len, ftnlen
tabval_len, ftnlen name_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer nsym;
extern integer cardc_(char *, ftnlen);
extern /* Subroutine */ int chkin_(char *, ftnlen), chkout_(char *,
ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Fetch the Nth symbol in a character symbol table. */
/* $ 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 */
/* -------- --- -------------------------------------------------- */
/* NTH I Index of symbol to be fetched. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL I Components of the symbol table. */
/* NAME O Name of the NTH symbol in the symbol table. */
/* FOUND O True if the NTH symbol is in the symbol table, */
/* false if it is not. */
/* $ Detailed_Input */
/* NTH is the index of the symbol to be fetched. If the NTH */
/* symbol does not exist, FOUND is FALSE. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL are the components of a character symbol table. */
/* The NTH symbol may or may not be in the symbol */
/* table. The symbol table is not modified by this */
/* subroutine. */
/* $ Detailed_Output */
/* NAME is the name of the NTH symbol in the symbol table. */
/* FOUND is true if the NTH symbol is in the symbol table. */
/* If the NTH symbol is not in the table, FOUND is false. */
/* $ Parameters */
/* None. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* The contents of the symbol table are: */
/* BOHR --> HYDROGEN ATOM */
/* EINSTEIN --> SPECIAL RELATIVITY */
/* PHOTOELECTRIC EFFECT */
/* BROWNIAN MOTION */
/* FERMI --> NUCLEAR FISSION */
/* The calls, */
/* CALL SYFETC ( 2, TABSYM, TABPTR, TABVAL, NAME, FOUND ) */
/* CALL SYFETC ( 3, TABSYM, TABPTR, TABVAL, NAME, FOUND ) */
/* CALL SYFETC ( -1, TABSYM, TABPTR, TABVAL, NAME, FOUND ) */
/* CALL SYFETC ( 4, TABSYM, TABPTR, TABVAL, NAME, FOUND ) */
/* result in the values for NAME and FOUND: */
/* NAME FOUND */
/* ---------- ----- */
/* EINSTEIN TRUE */
/* FERMI TRUE */
/* FALSE */
/* FALSE */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* 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 */
/* fetch the nth symbol in the table */
/* -& */
/* $ Revisions */
/* - Beta Version 1.1.0, 17-FEB-1989 (NJB) */
/* Declaration of the unused variable SUMAI removed. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SYFETC", (ftnlen)6);
}
/* How many symbols to start with? */
nsym = cardc_(tabsym, tabsym_len);
/* If the value of NTH is out of range, that's a problem. */
if (*nth < 1 || *nth > nsym) {
*found = FALSE_;
/* Otherwise, we can proceed without fear of error. Merely locate */
/* and return the appropriate component from the values table. */
} else {
*found = TRUE_;
s_copy(name__, tabsym + (*nth + 5) * tabsym_len, name_len, tabsym_len)
;
}
chkout_("SYFETC", (ftnlen)6);
return 0;
} /* syfetc_ */
/* $Procedure SYSELD ( Select a subset of the values of a symbol ) */
/* Subroutine */ int syseld_(char *name__, integer *begin, integer *end, char
*tabsym, integer *tabptr, doublereal *tabval, doublereal *values,
logical *found, ftnlen name_len, ftnlen tabsym_len)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer nsym;
extern integer cardc_(char *, ftnlen);
integer n;
extern /* Subroutine */ int chkin_(char *, ftnlen), moved_(doublereal *,
integer *, doublereal *);
extern integer sumai_(integer *, integer *), bsrchc_(char *, integer *,
char *, ftnlen, ftnlen);
integer locval;
extern /* Subroutine */ int chkout_(char *, ftnlen);
integer locsym;
extern logical return_(void);
/* $ Abstract */
/* Select a subset of the values associated with a particular */
/* symbol in a double precision symbol table. */
/* $ 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 values are to */
/* be returned. */
/* BEGIN I Index of the first associated value to be returned. */
/* END I Index of the last associated value to be returned. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL I Components of the symbol table. */
/* VALUES O Subset of the values associated with the symbol */
/* NAME. */
/* FOUND O True if the subset of values exists. */
/* $ Detailed_Input */
/* NAME is the name of the symbol whose subset of associated */
/* values to be returned. If NAME is not in the symbol */
/* table, FOUND is false. */
/* BEGIN is the index of the first associated value to be */
/* returned. If BEGIN is out of range (BEGIN < 1 or */
/* BEGIN > END) FOUND is false. */
/* END is the index of the last associated value to be */
/* returned. If END is out of range (END < 1 or */
/* END > is greater than the dimension of NAME) */
/* FOUND is false. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL are components of the double precision symbol table. */
/* $ Detailed_Output */
/* VALUES is a subset of the values associated with the */
/* symbol NAME. If the subset specified by BEGIN and */
/* END exists, as many values as will fit in VALUES */
/* are returned. If the subset does not exist, no */
/* values are returned and FOUND is false. */
/* FOUND is true if the subset of values is exists. */
/* FOUND is false if BEGIN < 1, BEGIN > END, END < 1, */
/* END > the dimension of NAME, or NAME is not */
/* in the symbol table. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) This subroutine does not check to see if the output array */
/* VALUES is large enough to hold the selected set of values. */
/* The caller must provide the required space. */
/* $ Files */
/* None. */
/* $ Particulars */
/* FOUND will be false if the bounds of the subset specified by */
/* BEGIN and END are out of range. Values of BEGIN and END which */
/* specify bounds out of range are BEGIN < 1, BEGIN > END, */
/* END < 1, or END > the dimension of NAME. FOUND is also false */
/* if the symbol NAME is not in 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 */
/* Let the dimension of the array VALUES be 3. */
/* The ouput values of VALUES and FOUND for the input values of */
/* NAME, BEGIN, and END are contained in this table: */
/* NAME BEGIN END VALUES FOUND */
/* ------------- ----- --- --------------------- ------- */
/* MEAN_ANOM 1 2 6.239996D0 TRUE */
/* 1.99096871D-7 */
/* BODY4_POLE_RA 1 3 3.17681D2 */
/* 1.08D-1 */
/* 0.0D0 */
/* BODY4_PRIME 1 3 FALSE */
/* MEAN_ANOM 2 1 FALSE */
/* ORBIT_ECC 1 -2 FALSE */
/* K 1 5 FALSE */
/* ---------------------------------------------------------------- */
/* Note that FOUND is FALSE for examples 3 through 6 because: */
/* - In the 3rd example, the symbol 'BODY4_PRIME' is not in the */
/* symbol table. */
/* - In the 4th example, BEGIN > END. */
/* - In the 5th example, END < 0. */
/* - In the 6th example, END is greater than the dimension of the */
/* symbol 'K'. */
/* $ Restrictions */
/* 1) See Exceptions section. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.2, 03-NOV-2005 (NJB) */
/* Various header corrections were made. In particular, */
/* the header no longer asserts that this routine will */
/* "return as many values as will fit" in the output array */
/* VALUES. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) (HAN) */
/* -& */
/* $ Index_Entries */
/* select a subset of the values of a symbol */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SYSELD", (ftnlen)6);
}
/* How many symbols to start with? */
nsym = cardc_(tabsym, tabsym_len);
/* 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_;
} else {
/* We could still have a problem: do these components exist? */
/* Does this request even make sense? */
n = tabptr[locsym + 5];
if (*begin >= 1 && *begin <= n && *end >= 1 && *end <= n && *begin <=
*end) {
*found = TRUE_;
i__1 = locsym - 1;
locval = sumai_(&tabptr[6], &i__1) + 1;
i__1 = *end - *begin + 1;
moved_(&tabval[locval + *begin + 4], &i__1, values);
} else {
*found = FALSE_;
}
}
chkout_("SYSELD", (ftnlen)6);
return 0;
} /* syseld_ */
/* $Procedure DISPLY ( BRIEF Display Summary ) */
/* Subroutine */ int disply_(char *fmtpic, logical *tdsp, logical *gdsp,
logical *obnam, integer *objlis, char *winsym, integer *winptr,
doublereal *winval, char *timtyp, char *kertyp, ftnlen fmtpic_len,
ftnlen winsym_len, ftnlen timtyp_len, ftnlen kertyp_len)
{
/* System generated locals */
address a__1[3];
integer i__1, i__2, i__3[3], i__4, i__5;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
static char name__[64];
static logical same;
static char line[132];
static integer nobj, objn[2], sobj, size;
static char rest[132];
static integer b, e, i__, j;
extern integer cardc_(char *, ftnlen);
static integer s;
extern /* Subroutine */ int chkin_(char *, ftnlen);
static char names[64*100006];
static logical found, group;
extern integer rtrim_(char *, ftnlen);
static integer n1, n2;
static char p1[8], p2[8];
static integer start;
static char header[132*2], wd[8];
extern integer objact_(integer *);
extern /* Subroutine */ int maknam_(integer *, integer *, logical *, char
*, char *, ftnlen, ftnlen), appndc_(char *, char *, ftnlen,
ftnlen);
static integer object[3], remain;
extern /* Subroutine */ int objget_(integer *, integer *, integer *),
objrem_(integer *, integer *), rmaini_(integer *, integer *,
integer *, integer *);
static char timlbl[8];
static integer npline;
extern /* Subroutine */ int objnth_(integer *, integer *, integer *,
logical *), prname_(integer *, integer *, char *, char *, char *,
integer *, char *, char *, ftnlen, ftnlen, ftnlen, ftnlen, ftnlen)
;
static doublereal filwin[1006];
static integer nlines, objtmp[2];
extern integer touchi_(integer *);
extern /* Subroutine */ int distim_(char *, doublereal *, char *, char *,
ftnlen, ftnlen, ftnlen);
static integer widest;
extern integer objsiz_(integer *);
extern /* Subroutine */ int chkout_(char *, ftnlen), objnxt_(integer *,
integer *, integer *, logical *), nextwd_(char *, char *, char *,
ftnlen, ftnlen, ftnlen);
static integer ngroup;
extern /* Subroutine */ int sygetd_(char *, char *, integer *, doublereal
*, integer *, doublereal *, logical *, ftnlen, ftnlen), ssizec_(
integer *, char *, ftnlen);
extern logical return_(void);
static doublereal lstwin[1006];
static char timstr[64];
extern /* Subroutine */ int writit_(char *, ftnlen);
static logical fnd;
static integer obj[2];
/* $ Abstract */
/* Display BRIEF summary. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* None. */
/* $ Declarations */
/* $ 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. */
/* $ Author_and_Institution */
/* W.L. Taber (NAIF) */
/* B.V. Semenov (NAIF) */
/* $ Version */
/* - BRIEF Version 3.0.0, 14-JAN-2008 (BVS) */
/* Increased MAXBOD to 100,000 (from 20,000). */
/* Increased CMDSIZ to 25,000 (from 4,000). */
/* Updated version string and changed its format to */
/* '#.#.#, Month DD, YYYY' (from '#.#.#'). */
/* - BRIEF Version 1.0.0, 14-MAR-1996 (WLT) */
/* Initial release. */
/* -& */
/* The Version is stored as a string. */
/* MAXUSE is the maximum number of bodies that can be explicitly */
/* specified on the command line for brief summaries. */
/* The longest command line that can be accommodated is */
/* given by CMDSIZ */
/* The maximum number of bodies that can be summarized is stored */
/* in the parameter MAXBOD */
/* The average number of intervals per body */
/* The largest expected window */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* FMTPIC I Body name/ID format picture (see BRIEF.PGM) */
/* TDSP I Tabular display flag */
/* GDSP I Grouping display flag */
/* OBNAM I Name ordering flag */
/* OBJLIS I List of object (?) */
/* WINSYM I Symbol table with object attributes (?) */
/* WINPTR I Symbol table with object attributes (?) */
/* WINVAL I Symbol table with object attributes (?) */
/* TIMTYP I Output time type (see DISTIM.FOR) */
/* KERTYP I Kernel type (SPK, PCK) */
/* $ Detailed_Input */
/* See Brief_I/O. */
/* $ Detailed_Output */
/* This routine return no outputs. Instead it prints summary of */
/* provided input information to STDOUT. */
/* $ Parameters */
/* LBCELL. */
/* $ Exceptions */
/* 1) Errors may be signaled by routines in the calling tree of */
/* this routine. */
/* $ Files */
/* TBD. */
/* $ Particulars */
/* TBD. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* This routine must not be called by any routines except BRIEF's */
/* main program. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* B.V. Semenov (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - BRIEF Version 2.0.0, 22-OCT-2007 (BVS) */
/* Added output time type to the argument list. Changed to */
/* call DISTIM to format output time and provide time system */
/* label for the summary table header. */
/* - BRIEF Version 1.0.0, 14-MAR-1996 (WLT) */
/* Bill's initial version. */
/* -& */
/* $ Index_Entries */
/* display summary by BRIEF */
/* -& */
/* SPICELIB functions */
/* Parameters */
/* Local Variables. */
/* SPICELIB Calls */
/* Saved variables */
/* The SAVE statement that appears here causes f2c to create */
/* local variables with static duration. This enables the CSPICE */
/* version of brief to run under cygwin. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("DISPLY", (ftnlen)6);
}
/* Get time system label for the table header. */
distim_(timtyp, &c_b3, timlbl, timstr, timtyp_len, (ftnlen)8, (ftnlen)64);
/* Set local grouping flag. */
group = ! (*tdsp) || *gdsp;
/* First take apart the format picture to see what */
/* the various components are. */
nextwd_(fmtpic, p1, rest, fmtpic_len, (ftnlen)8, (ftnlen)132);
nextwd_(rest, wd, rest, (ftnlen)132, (ftnlen)8, (ftnlen)132);
nextwd_(rest, p2, rest, (ftnlen)132, (ftnlen)8, (ftnlen)132);
size = 1;
if (s_cmp(p2, " ", (ftnlen)8, (ftnlen)1) != 0) {
size = 3;
}
/* Find out the width of the widest name. */
nobj = objact_(objlis);
sobj = objsiz_(objlis);
/* If we don't have any objects to display then */
/* we just return. */
if (nobj == 0) {
chkout_("DISPLY", (ftnlen)6);
return 0;
}
objnth_(objlis, &c__1, obj, &found);
widest = 0;
while(found) {
objget_(obj, objlis, object);
objnxt_(obj, objlis, objn, &found);
prname_(object, &sobj, p1, wd, p2, &size, kertyp, name__, (ftnlen)8, (
ftnlen)8, (ftnlen)8, kertyp_len, (ftnlen)64);
/* Computing MAX */
i__1 = widest, i__2 = rtrim_(name__, (ftnlen)64);
widest = max(i__1,i__2);
obj[0] = objn[0];
obj[1] = objn[1];
}
/* Are we going to group by window? If not, this is pretty */
/* easy. Just display stuff. */
if (*tdsp && ! (*gdsp)) {
s = widest + 3;
e = s + 32;
if (s_cmp(kertyp, "SPK", kertyp_len, (ftnlen)3) == 0) {
s_copy(line, "Bodies", (ftnlen)132, (ftnlen)6);
} else if (s_cmp(kertyp, "PCK", kertyp_len, (ftnlen)3) == 0) {
s_copy(line, "Frames", (ftnlen)132, (ftnlen)6);
} else {
s_copy(line, "IDs", (ftnlen)132, (ftnlen)3);
}
/* Writing concatenation */
i__3[0] = 19, a__1[0] = "Start of Interval (";
i__3[1] = rtrim_(timlbl, (ftnlen)8), a__1[1] = timlbl;
i__3[2] = 1, a__1[2] = ")";
s_cat(line + (s - 1), a__1, i__3, &c__3, 132 - (s - 1));
/* Writing concatenation */
i__3[0] = 17, a__1[0] = "End of Interval (";
i__3[1] = rtrim_(timlbl, (ftnlen)8), a__1[1] = timlbl;
i__3[2] = 1, a__1[2] = ")";
s_cat(line + (e - 1), a__1, i__3, &c__3, 132 - (e - 1));
writit_(line, (ftnlen)132);
s_copy(line, "-------", (ftnlen)132, (ftnlen)7);
s_copy(line + (s - 1), "-----------------------------", 132 - (s - 1),
(ftnlen)29);
s_copy(line + (e - 1), "-----------------------------", 132 - (e - 1),
(ftnlen)29);
writit_(line, (ftnlen)132);
objnth_(objlis, &c__1, obj, &found);
n1 = 0;
while(found) {
s_copy(line, " ", (ftnlen)132, (ftnlen)1);
objget_(obj, objlis, object);
prname_(object, &sobj, p1, wd, p2, &size, kertyp, line, (ftnlen)8,
(ftnlen)8, (ftnlen)8, kertyp_len, (ftnlen)132);
maknam_(object, &sobj, obnam, kertyp, name__, kertyp_len, (ftnlen)
64);
sygetd_(name__, winsym, winptr, winval, &n2, &filwin[6], &found, (
ftnlen)64, winsym_len);
if (n2 == n1) {
same = TRUE_;
i__ = 1;
while(same && i__ <= n1) {
same = filwin[(i__1 = i__ + 5) < 1006 && 0 <= i__1 ? i__1
: s_rnge("filwin", i__1, "disply_", (ftnlen)340)]
== lstwin[(i__2 = i__ + 5) < 1006 && 0 <= i__2 ?
i__2 : s_rnge("lstwin", i__2, "disply_", (ftnlen)
340)];
++i__;
}
} else {
same = FALSE_;
}
if (! same) {
i__1 = n2;
for (i__ = 1; i__ <= i__1; i__ += 2) {
distim_(timtyp, &filwin[(i__2 = i__ + 5) < 1006 && 0 <=
i__2 ? i__2 : s_rnge("filwin", i__2, "disply_", (
ftnlen)352)], timlbl, line + (s - 1), timtyp_len,
(ftnlen)8, 132 - (s - 1));
distim_(timtyp, &filwin[(i__2 = i__ + 6) < 1006 && 0 <=
i__2 ? i__2 : s_rnge("filwin", i__2, "disply_", (
ftnlen)353)], timlbl, line + (e - 1), timtyp_len,
(ftnlen)8, 132 - (e - 1));
writit_(line, (ftnlen)132);
s_copy(line, " ", (ftnlen)132, (ftnlen)1);
lstwin[(i__2 = i__ + 5) < 1006 && 0 <= i__2 ? i__2 :
s_rnge("lstwin", i__2, "disply_", (ftnlen)356)] =
filwin[(i__4 = i__ + 5) < 1006 && 0 <= i__4 ?
i__4 : s_rnge("filwin", i__4, "disply_", (ftnlen)
356)];
lstwin[(i__2 = i__ + 6) < 1006 && 0 <= i__2 ? i__2 :
s_rnge("lstwin", i__2, "disply_", (ftnlen)357)] =
filwin[(i__4 = i__ + 6) < 1006 && 0 <= i__4 ?
i__4 : s_rnge("filwin", i__4, "disply_", (ftnlen)
357)];
n1 = n2;
}
} else {
i__1 = s + 11;
s_copy(line + i__1, "Same coverage as previous object ", 132
- i__1, (ftnlen)33);
writit_(line, (ftnlen)132);
}
objnxt_(obj, objlis, objtmp, &found);
obj[0] = touchi_(objtmp);
obj[1] = touchi_(&objtmp[1]);
}
} else if (*tdsp && *gdsp) {
s = widest + 3;
e = s + 32;
if (s_cmp(kertyp, "SPK", kertyp_len, (ftnlen)3) == 0) {
s_copy(line, "Bodies", (ftnlen)132, (ftnlen)6);
} else if (s_cmp(kertyp, "PCK", kertyp_len, (ftnlen)3) == 0) {
s_copy(line, "Frames", (ftnlen)132, (ftnlen)6);
} else {
s_copy(line, "IDs", (ftnlen)132, (ftnlen)3);
}
/* Writing concatenation */
i__3[0] = 19, a__1[0] = "Start of Interval (";
i__3[1] = rtrim_(timlbl, (ftnlen)8), a__1[1] = timlbl;
i__3[2] = 1, a__1[2] = ")";
s_cat(line + (s - 1), a__1, i__3, &c__3, 132 - (s - 1));
/* Writing concatenation */
i__3[0] = 17, a__1[0] = "End of Interval (";
i__3[1] = rtrim_(timlbl, (ftnlen)8), a__1[1] = timlbl;
i__3[2] = 1, a__1[2] = ")";
s_cat(line + (e - 1), a__1, i__3, &c__3, 132 - (e - 1));
writit_(line, (ftnlen)132);
s_copy(line, "-------", (ftnlen)132, (ftnlen)7);
s_copy(line + (s - 1), "-----------------------------", 132 - (s - 1),
(ftnlen)29);
s_copy(line + (e - 1), "-----------------------------", 132 - (e - 1),
(ftnlen)29);
writit_(line, (ftnlen)132);
objnth_(objlis, &c__1, obj, &found);
while(found) {
s_copy(line, " ", (ftnlen)132, (ftnlen)1);
objget_(obj, objlis, object);
prname_(object, &sobj, p1, wd, p2, &size, kertyp, line, (ftnlen)8,
(ftnlen)8, (ftnlen)8, kertyp_len, (ftnlen)132);
maknam_(object, &sobj, obnam, kertyp, name__, kertyp_len, (ftnlen)
64);
sygetd_(name__, winsym, winptr, winval, &n1, &filwin[6], &found, (
ftnlen)64, winsym_len);
i__1 = n1;
for (i__ = 1; i__ <= i__1; i__ += 2) {
distim_(timtyp, &filwin[(i__2 = i__ + 5) < 1006 && 0 <= i__2 ?
i__2 : s_rnge("filwin", i__2, "disply_", (ftnlen)416)
], timlbl, line + (s - 1), timtyp_len, (ftnlen)8, 132
- (s - 1));
distim_(timtyp, &filwin[(i__2 = i__ + 6) < 1006 && 0 <= i__2 ?
i__2 : s_rnge("filwin", i__2, "disply_", (ftnlen)417)
], timlbl, line + (e - 1), timtyp_len, (ftnlen)8, 132
- (e - 1));
writit_(line, (ftnlen)132);
s_copy(line, " ", (ftnlen)132, (ftnlen)1);
lstwin[(i__2 = i__ + 5) < 1006 && 0 <= i__2 ? i__2 : s_rnge(
"lstwin", i__2, "disply_", (ftnlen)420)] = filwin[(
i__4 = i__ + 5) < 1006 && 0 <= i__4 ? i__4 : s_rnge(
"filwin", i__4, "disply_", (ftnlen)420)];
lstwin[(i__2 = i__ + 6) < 1006 && 0 <= i__2 ? i__2 : s_rnge(
"lstwin", i__2, "disply_", (ftnlen)421)] = filwin[(
i__4 = i__ + 6) < 1006 && 0 <= i__4 ? i__4 : s_rnge(
"filwin", i__4, "disply_", (ftnlen)421)];
}
objnxt_(obj, objlis, objn, &fnd);
objrem_(obj, objlis);
obj[0] = objn[0];
obj[1] = objn[1];
while(fnd) {
s_copy(line, " ", (ftnlen)132, (ftnlen)1);
objget_(obj, objlis, object);
prname_(object, &sobj, p1, wd, p2, &size, kertyp, line, (
ftnlen)8, (ftnlen)8, (ftnlen)8, kertyp_len, (ftnlen)
132);
maknam_(object, &sobj, obnam, kertyp, name__, kertyp_len, (
ftnlen)64);
sygetd_(name__, winsym, winptr, winval, &n2, &filwin[6], &
found, (ftnlen)64, winsym_len);
if (n2 == n1) {
same = TRUE_;
i__ = 1;
while(same && i__ <= n1) {
same = filwin[(i__1 = i__ + 5) < 1006 && 0 <= i__1 ?
i__1 : s_rnge("filwin", i__1, "disply_", (
ftnlen)445)] == lstwin[(i__2 = i__ + 5) <
1006 && 0 <= i__2 ? i__2 : s_rnge("lstwin",
i__2, "disply_", (ftnlen)445)];
++i__;
}
} else {
same = FALSE_;
}
if (same) {
i__1 = s + 11;
s_copy(line + i__1, "Same coverage as previous object ",
132 - i__1, (ftnlen)33);
writit_(line, (ftnlen)132);
}
objnxt_(obj, objlis, objn, &fnd);
if (same) {
objrem_(obj, objlis);
}
obj[0] = objn[0];
obj[1] = objn[1];
}
objnth_(objlis, &c__1, obj, &found);
}
} else {
objnth_(objlis, &c__1, obj, &found);
while(found) {
ssizec_(&c_b78, names, (ftnlen)64);
objget_(obj, objlis, object);
prname_(object, &sobj, p1, wd, p2, &size, kertyp, name__, (ftnlen)
8, (ftnlen)8, (ftnlen)8, kertyp_len, (ftnlen)64);
appndc_(name__, names, (ftnlen)64, (ftnlen)64);
/* Look up the window associated with this object. */
maknam_(object, &sobj, obnam, kertyp, name__, kertyp_len, (ftnlen)
64);
sygetd_(name__, winsym, winptr, winval, &n1, &lstwin[6], &fnd, (
ftnlen)64, winsym_len);
/* Fetch the next object. */
objnxt_(obj, objlis, objn, &fnd);
objrem_(obj, objlis);
obj[0] = objn[0];
obj[1] = objn[1];
while(fnd) {
objget_(obj, objlis, object);
maknam_(object, &sobj, obnam, kertyp, name__, kertyp_len, (
ftnlen)64);
sygetd_(name__, winsym, winptr, winval, &n2, &filwin[6], &fnd,
(ftnlen)64, winsym_len);
/* See if this window is the same as the current */
/* window under considerations. */
if (n1 == n2) {
same = TRUE_;
i__ = 1;
while(same && i__ <= n1) {
same = filwin[(i__1 = i__ + 5) < 1006 && 0 <= i__1 ?
i__1 : s_rnge("filwin", i__1, "disply_", (
ftnlen)520)] == lstwin[(i__2 = i__ + 5) <
1006 && 0 <= i__2 ? i__2 : s_rnge("lstwin",
i__2, "disply_", (ftnlen)520)];
++i__;
}
} else {
same = FALSE_;
}
objnxt_(obj, objlis, objn, &fnd);
if (same) {
objrem_(obj, objlis);
prname_(object, &sobj, p1, wd, p2, &size, kertyp, name__,
(ftnlen)8, (ftnlen)8, (ftnlen)8, kertyp_len, (
ftnlen)64);
appndc_(name__, names, (ftnlen)64, (ftnlen)64);
}
obj[0] = objn[0];
obj[1] = objn[1];
}
ngroup = cardc_(names, (ftnlen)64);
if (ngroup == 1) {
if (s_cmp(kertyp, "SPK", kertyp_len, (ftnlen)3) == 0) {
s_copy(line, "Body: ", (ftnlen)132, (ftnlen)6);
start = 7;
} else if (s_cmp(kertyp, "PCK", kertyp_len, (ftnlen)3) == 0) {
s_copy(line, "Frame: ", (ftnlen)132, (ftnlen)7);
start = 8;
} else {
s_copy(line, "ID: ", (ftnlen)132, (ftnlen)4);
start = 5;
}
} else {
if (s_cmp(kertyp, "SPK", kertyp_len, (ftnlen)3) == 0) {
s_copy(line, "Bodies: ", (ftnlen)132, (ftnlen)8);
start = 9;
} else if (s_cmp(kertyp, "PCK", kertyp_len, (ftnlen)3) == 0) {
s_copy(line, "Frames: ", (ftnlen)132, (ftnlen)8);
start = 9;
} else {
s_copy(line, "IDs: ", (ftnlen)132, (ftnlen)5);
start = 6;
}
}
npline = (80 - widest - start) / (widest + 2) + 1;
rmaini_(&ngroup, &npline, &nlines, &remain);
if (remain != 0) {
++nlines;
}
i__1 = nlines;
for (j = 1; j <= i__1; ++j) {
b = start;
i__2 = ngroup;
i__4 = nlines;
for (i__ = j; i__4 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
i__4) {
s_copy(line + (b - 1), names + (((i__5 = i__ + 5) <
100006 && 0 <= i__5 ? i__5 : s_rnge("names", i__5,
"disply_", (ftnlen)580)) << 6), 132 - (b - 1), (
ftnlen)64);
b = b + widest + 2;
}
writit_(line, (ftnlen)132);
s_copy(line, " ", (ftnlen)132, (ftnlen)1);
}
s = start;
e = start + 36;
s_copy(header, " ", (ftnlen)132, (ftnlen)1);
s_copy(header + 132, " ", (ftnlen)132, (ftnlen)1);
/* Writing concatenation */
i__3[0] = 19, a__1[0] = "Start of Interval (";
i__3[1] = rtrim_(timlbl, (ftnlen)8), a__1[1] = timlbl;
i__3[2] = 1, a__1[2] = ")";
s_cat(header + (s - 1), a__1, i__3, &c__3, 132 - (s - 1));
/* Writing concatenation */
i__3[0] = 17, a__1[0] = "End of Interval (";
i__3[1] = rtrim_(timlbl, (ftnlen)8), a__1[1] = timlbl;
i__3[2] = 1, a__1[2] = ")";
s_cat(header + (e - 1), a__1, i__3, &c__3, 132 - (e - 1));
s_copy(header + (s + 131), "-----------------------------", 132 -
(s - 1), (ftnlen)29);
s_copy(header + (e + 131), "-----------------------------", 132 -
(e - 1), (ftnlen)29);
writit_(header, (ftnlen)132);
writit_(header + 132, (ftnlen)132);
i__1 = n1;
for (i__ = 1; i__ <= i__1; i__ += 2) {
s_copy(line, " ", (ftnlen)132, (ftnlen)1);
distim_(timtyp, &lstwin[(i__4 = i__ + 5) < 1006 && 0 <= i__4 ?
i__4 : s_rnge("lstwin", i__4, "disply_", (ftnlen)608)
], timlbl, line + (s - 1), timtyp_len, (ftnlen)8, 132
- (s - 1));
distim_(timtyp, &lstwin[(i__4 = i__ + 6) < 1006 && 0 <= i__4 ?
i__4 : s_rnge("lstwin", i__4, "disply_", (ftnlen)609)
], timlbl, line + (e - 1), timtyp_len, (ftnlen)8, 132
- (e - 1));
writit_(line, (ftnlen)132);
}
writit_(" ", (ftnlen)1);
objnth_(objlis, &c__1, obj, &found);
}
}
/* All done. */
chkout_("DISPLY", (ftnlen)6);
return 0;
} /* disply_ */
/* $Procedure SYPOPC ( Pop a value from a particular symbol ) */
/* Subroutine */ int sypopc_(char *name__, char *tabsym, integer *tabptr,
char *tabval, char *value, logical *found, ftnlen name_len, ftnlen
tabsym_len, ftnlen tabval_len, ftnlen value_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer nval, nptr, nsym;
extern integer cardc_(char *, ftnlen), cardi_(integer *);
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern integer sumai_(integer *, integer *);
extern /* Subroutine */ int scardc_(integer *, char *, ftnlen), remlac_(
integer *, integer *, char *, integer *, ftnlen);
extern integer bsrchc_(char *, integer *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int 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 character */
/* 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 character symbol table. */
/* $ Detailed_Output */
/* TABSYM, */
/* TABPTR, */
/* TABVAL are the components of a character 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: */
/* BOHR --> HYDROGEN ATOM */
/* EINSTEIN --> SPECIAL RELATIVITY */
/* PHOTOELECTRIC EFFECT */
/* BROWNIAN MOTION */
/* FERMI --> NUCLEAR FISSION */
/* The call, */
/* CALL SYPOPC ( 'EINSTEIN', TABSYM, TABPTR, TABVAL, VALUE, FOUND ) */
/* modifies the contents of the symbol table to be: */
/* BOHR --> HYDROGEN ATOM */
/* EINSTEIN --> PHOTOELECTRIC EFFECT */
/* BROWNIAN MOTION */
/* FERMI --> NUCLEAR FISSION */
/* FOUND is TRUE, and VALUE is 'SPECIAL RELATIVITY'. */
/* The next call, */
/* CALL SYPOPC ( 'FERMI', TABSYM, TABPTR, TABVAL, VALUE, FOUND ) */
/* modifies the contents of the symbol table to be: */
/* BOHR --> HYDROGEN ATOM */
/* EINSTEIN --> SPECIAL RELATIVITY */
/* PHOTOELECTRIC EFFECT */
/* BROWNIAN MOTION */
/* FOUND is TRUE, and VALUE is 'NUCLEAR FISSION'. Note that because */
/* "FERMI" 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_("SYPOPC", (ftnlen)6);
}
/* How many symbols to start with? */
nsym = cardc_(tabsym, tabsym_len);
nptr = cardi_(tabptr);
nval = cardc_(tabval, tabval_len);
/* 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;
s_copy(value, tabval + (locval + 5) * tabval_len, value_len,
tabval_len);
remlac_(&c__1, &locval, tabval + tabval_len * 6, &nval, tabval_len);
scardc_(&nval, tabval, tabval_len);
/* 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_("SYPOPC", (ftnlen)6);
return 0;
} /* sypopc_ */
/* $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_ */
/* Subroutine */ int kerman_0_(int n__, char *commnd, char *infile__, char *
error, ftnlen commnd_len, ftnlen infile_len, ftnlen error_len)
{
/* Initialized data */
static integer nfiles = 0;
static logical first = TRUE_;
static char synval[80*9] = " "
" " " "
" " " "
" "
" " " "
" " " "
" " " "
" "
" " "EK #word[ekfile] "
" " "LEAPSECONDS #word[leapfile] "
" " "SCLK KERNEL #word[sc"
"lkfile] ";
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Local variables */
static integer need;
static char file[127], name__[32];
static integer clen;
extern logical have_(char *, ftnlen);
static integer left, reqd, nseg;
static char indx[4], pval[32*4];
static integer hits;
static char size[32], type__[32];
static logical quit;
extern /* Subroutine */ int zzeksinf_(integer *, integer *, char *,
integer *, char *, integer *, ftnlen, ftnlen);
static integer i__, j, k;
extern integer cardc_(char *, ftnlen);
static integer l, n;
extern /* Subroutine */ int clgai_(integer *, char *, integer *, integer *
, ftnlen), clgac_(integer *, char *, char *, ftnlen, ftnlen);
static integer r__;
static char cname[80], break__[80];
static integer headr[5];
extern /* Subroutine */ int eklef_(char *, integer *, ftnlen), clnid_(
integer *, integer *, logical *);
static integer space;
extern logical match_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int chkin_(char *, ftnlen);
static integer tcode, ncomc;
extern /* Subroutine */ int ekuef_(integer *);
static char rname[6], tname[32];
extern /* Subroutine */ int repmc_(char *, char *, char *, char *, ftnlen,
ftnlen, ftnlen, ftnlen), clnew_(char *, integer *, integer *,
integer *, integer *, integer *, logical *, logical *, integer *,
ftnlen);
static logical found;
static integer csize, ncols, ncomr;
static logical cnull;
static integer right, width[5], ctype;
extern integer ltrim_(char *, ftnlen);
static integer count;
extern integer rtrim_(char *, ftnlen);
static integer sizes[5];
static char style[80];
extern /* Subroutine */ int clnum_(integer *);
static logical justr[5];
extern /* Subroutine */ int m2chck_(char *, char *, integer *, char *,
char *, ftnlen, ftnlen, ftnlen, ftnlen), m2getc_(char *, char *,
logical *, char *, ftnlen, ftnlen, ftnlen), m2ints_(integer *,
char *, integer *, char *, ftnlen, ftnlen);
static integer id, nb;
static char bs[1];
extern logical m2xist_(char *, ftnlen);
static integer nh, sb, handle;
static char ifname[60], tabnam[64], tabcol[80*506], rnamec[7], cnames[64*
100];
static integer handls[20], segdsc[24];
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen),
eknseg_(integer *);
extern /* Subroutine */ int gcolmn_();
extern integer isrchi_(integer *, integer *, integer *);
extern /* Subroutine */ int pagput_(char *, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int nspwln_(char *, ftnlen);
static char synkey[32*9];
static integer synptr[9];
static char ekfils[127*20], thisfl[127], messge[300], idword[8];
static integer cdscrs[1100] /* was [11][100] */, widest, totalc, nresvr,
nresvc;
static logical cindxd;
static char spcial[4*5], lsttab[32];
static integer colids[506], lmarge, ordvec[500];
static logical presrv[5];
extern /* Subroutine */ int replch_(char *, char *, char *, char *,
ftnlen, ftnlen, ftnlen, ftnlen), prefix_(char *, integer *, char *
, ftnlen, ftnlen), chkout_(char *, ftnlen), expool_(char *,
logical *, ftnlen), repmct_(char *, char *, integer *, char *,
char *, ftnlen, ftnlen, ftnlen, ftnlen), clunld_(integer *),
ldpool_(char *, ftnlen);
static integer nid;
extern /* Subroutine */ int dasfnh_(char *, integer *, ftnlen);
static integer col, seg, ids[5];
extern /* Subroutine */ int remlac_(integer *, integer *, char *, integer
*, ftnlen), nspglr_(integer *, integer *), nspmrg_(char *, ftnlen)
, suffix_(char *, integer *, char *, ftnlen, ftnlen), pagrst_(
void), pagset_(char *, integer *, ftnlen), ssizec_(integer *,
char *, ftnlen), ssizei_(integer *, integer *), appndc_(char *,
char *, ftnlen, ftnlen), appndi_(integer *, integer *), pagscn_(
char *, ftnlen), scolmn_(integer *, integer *, char *, ftnlen),
tabrpt_(integer *, integer *, integer *, integer *, logical *,
logical *, char *, integer *, integer *, U_fp, ftnlen), orderc_(
char *, integer *, integer *, ftnlen);
extern integer pos_(char *, char *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int pagsft_(void), dasrfr_(integer *, char *,
char *, integer *, integer *, integer *, integer *, ftnlen,
ftnlen), nspshc_(integer *, logical *), bbputc_1__(char *, char *,
integer *, char *, ftnlen, ftnlen, ftnlen), nicepr_1__(char *,
char *, S_fp, ftnlen, ftnlen);
/* Version 2.4.0, 26-SEP-2005 */
/* Minor bug fix: replaced FILE with INFILE in the RTRIM call */
/* constructing "The file # is not listed ..." error message. */
/* Version 2.3.0, 21-JUN-1999 */
/* Added RETURN before first entry points. */
/* Version 2.2.0, 22-APR-1997 */
/* Declared PAGPUT external */
/* Version 2.1.0 14-SEP-1995 */
/* Variable INDEX removed. */
/* Version 2.0.0 23-AUG-1995 */
/* The widest string in a string column is no longer supplied */
/* by the EK summary stuff. We just set the value WIDEST */
/* to 24. */
/* This routine handles the loading of E-kernels, leapsecond and */
/* SCLK kernels. */
/* Passable routines */
/* Parameters that contain the routine name for use in check-in, */
/* check-out, and error messages. */
/* SPICELIB functions */
/* E-kernel functions */
/* Meta/2 Functions */
/* Interface to the SPICELIB error handling. */
/* Ek include files. */
/* +============================================================== */
/* $ 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. */
/* Include Section: EK Column Descriptor Parameters */
/* ekcoldsc.inc Version 6 23-AUG-1995 (NJB) */
/* Note: The column descriptor size parameter CDSCSZ is */
/* declared separately in the include section CDSIZE$INC.FOR. */
/* Offset of column descriptors, relative to start of segment */
/* integer address range. This number, when added to the last */
/* integer address preceding the segment, yields the DAS integer */
/* base address of the first column descriptor. Currently, this */
/* offset is exactly the size of a segment descriptor. The */
/* parameter SDSCSZ, which defines the size of a segment descriptor, */
/* is declared in the include file eksegdsc.inc. */
/* Size of column descriptor */
/* Indices of various pieces of column descriptors: */
/* CLSIDX is the index of the column's class code. (We use the */
/* word `class' to distinguish this item from the column's data */
/* type.) */
/* TYPIDX is the index of the column's data type code (CHR, INT, DP, */
/* or TIME). The type is actually implied by the class, but it */
/* will frequently be convenient to look up the type directly. */
/* LENIDX is the index of the column's string length value, if the */
/* column has character type. A value of IFALSE in this element of */
/* the descriptor indicates that the strings have variable length. */
/* SIZIDX is the index of the column's element size value. This */
/* descriptor element is meaningful for columns with fixed-size */
/* entries. For variable-sized columns, this value is IFALSE. */
/* NAMIDX is the index of the base address of the column's name. */
/* IXTIDX is the data type of the column's index. IXTIDX */
/* contains a type value only if the column is indexed. For columns */
/* that are not indexed, the location IXTIDX contains the boolean */
/* value IFALSE. */
/* IXPIDX is a pointer to the column's index. IXTPDX contains a */
/* meaningful value only if the column is indexed. The */
/* interpretation of the pointer depends on the data type of the */
/* index. */
/* NFLIDX is the index of a flag indicating whether nulls are */
/* permitted in the column. The value at location NFLIDX is */
/* ITRUE if nulls are permitted and IFALSE otherwise. */
/* ORDIDX is the index of the column's ordinal position in the */
/* list of columns belonging to the column's parent segment. */
/* METIDX is the index of the column's integer metadata pointer. */
/* This pointer is a DAS integer address. */
/* The last position in the column descriptor is reserved. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Column Descriptor Parameters */
/* $ 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. */
/* Include Section: EK Segment Descriptor Parameters */
/* eksegdsc.inc Version 8 06-NOV-1995 (NJB) */
/* All `base addresses' referred to below are the addresses */
/* *preceding* the item the base applies to. This convention */
/* enables simplied address calculations in many cases. */
/* Size of segment descriptor. Note: the include file ekcoldsc.inc */
/* must be updated if this parameter is changed. The parameter */
/* CDOFF in that file should be kept equal to SDSCSZ. */
/* Index of the segment type code: */
/* Index of the segment's number. This number is the segment's */
/* index in the list of segments contained in the EK to which */
/* the segment belongs. */
/* Index of the DAS integer base address of the segment's integer */
/* meta-data: */
/* Index of the DAS character base address of the table name: */
/* Index of the segment's column count: */
/* Index of the segment's record count: */
/* Index of the root page number of the record tree: */
/* Index of the root page number of the character data page tree: */
/* Index of the root page number of the double precision data page */
/* tree: */
/* Index of the root page number of the integer data page tree: */
/* Index of the `modified' flag: */
/* Index of the `initialized' flag: */
/* Index of the shadowing flag: */
/* Index of the companion file handle: */
/* Index of the companion segment number: */
/* The next three items are, respectively, the page numbers of the */
/* last character, d.p., and integer data pages allocated by the */
/* segment: */
/* The next three items are, respectively, the page-relative */
/* indices of the last DAS word in use in the segment's */
/* last character, d.p., and integer data pages: */
/* Index of the DAS character base address of the column name list: */
/* The last descriptor element is reserved for future use. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Segment Descriptor Parameters */
/* $ 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. */
/* Include Section: EK Boolean Enumerated Type */
/* ekbool.inc Version 1 21-DEC-1994 (NJB) */
/* Within the EK system, boolean values sometimes must be */
/* represented by integer or character codes. The codes and their */
/* meanings are listed below. */
/* Integer code indicating `true': */
/* Integer code indicating `false': */
/* Character code indicating `true': */
/* Character code indicating `false': */
/* End Include Section: EK Boolean Enumerated Type */
/* +============================================================== */
/* Meta/2 syntax definition variables. */
/* $ 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. */
/* Include Section: EK Data Types */
/* ektype.inc Version 1 27-DEC-1994 (NJB) */
/* Within the EK system, data types of EK column contents are */
/* represented by integer codes. The codes and their meanings */
/* are listed below. */
/* Integer codes are also used within the DAS system to indicate */
/* data types; the EK system makes no assumptions about compatibility */
/* between the codes used here and those used in the DAS system. */
/* Character type: */
/* Double precision type: */
/* Integer type: */
/* `Time' type: */
/* Within the EK system, time values are represented as ephemeris */
/* seconds past J2000 (TDB), and double precision numbers are used */
/* to store these values. However, since time values require special */
/* treatment both on input and output, and since the `TIME' column */
/* has a special role in the EK specification and code, time values */
/* are identified as a type distinct from double precision numbers. */
/* End Include Section: EK Data Types */
/* E-kernel column type definitions */
/* INTEGER CH */
/* PARAMETER ( CH = 1 ) */
/* INTEGER DP */
/* PARAMETER ( DP = 2 ) */
/* INTEGER INT */
/* PARAMETER ( INT = 3 ) */
/* INTEGER TIME */
/* PARAMETER ( TIME = 4 ) */
/* Local Parameters */
/* FILSIZ is the maximum number of characters allowed for a */
/* filename */
/* LNGSIZ is the maximum number of characters allowed for */
/* use in reporting the columns associated with a given */
/* file. */
/* MAXFIL is the maximum number of E-kernels that can be loaded */
/* at any one time. */
/* NNAMES is the maximum number of names/headings that can appear */
/* in a report of loaded files and columns. */
/* MAXCOL is the maximum number of columns that may be present */
/* in any segment of an E-kernel */
/* LNSIZE is the standard text line length. */
/* Initialization logical */
/* Loaded file database (shared between entry points) */
/* Local Variables */
/* INTEGER IFALSE */
/* PARAMETER ( IFALSE = -1 ) */
/* Variables needed by NSPEKS */
/* Save everything. */
/* Initial Values */
/* Parameter adjustments */
if (error) {
}
/* Function Body */
switch(n__) {
case 1: goto L_nspld;
case 2: goto L_nspuld;
case 3: goto L_nspeks;
case 4: goto L_nspekc;
}
return 0;
/* Load an E-, leapsecond, or sclk kernel. */
L_nspld:
/* Standard Spicelib error handling. */
s_copy(rname, "NSPLD", (ftnlen)6, (ftnlen)5);
s_copy(rnamec, "NSPLD:", (ftnlen)7, (ftnlen)6);
if (return_()) {
return 0;
}
chkin_(rname, (ftnlen)6);
/* On the first pass establish the syntax that this routine */
/* is responsible for recognizing. */
if (first) {
first = FALSE_;
*(unsigned char *)bs = '@';
for (i__ = 1; i__ <= 100; ++i__) {
s_copy(cnames + (((i__1 = i__ - 1) < 100 && 0 <= i__1 ? i__1 :
s_rnge("cnames", i__1, "kerman_", (ftnlen)361)) << 6),
" ", (ftnlen)64, (ftnlen)1);
}
for (i__ = 1; i__ <= 3; ++i__) {
replch_(synval + ((i__1 = i__ + 5) < 9 && 0 <= i__1 ? i__1 :
s_rnge("synval", i__1, "kerman_", (ftnlen)366)) * 80,
"#", bs, synval + ((i__2 = i__ + 5) < 9 && 0 <= i__2 ?
i__2 : s_rnge("synval", i__2, "kerman_", (ftnlen)366)) *
80, (ftnlen)80, (ftnlen)1, (ftnlen)1, (ftnlen)80);
}
m2ints_(&c__3, synkey, synptr, synval, (ftnlen)32, (ftnlen)80);
}
/* See if this command matches a known syntax. If it doesn't */
/* there is no point in hanging around. */
m2chck_(commnd, synkey, synptr, synval, error, commnd_len, (ftnlen)32, (
ftnlen)80, error_len);
if (have_(error, error_len)) {
prefix_(rnamec, &c__1, error, (ftnlen)7, error_len);
chkout_(rname, (ftnlen)6);
return 0;
}
if (m2xist_("ekfile", (ftnlen)6)) {
/* We need to have a leapseconds kernel loaded before */
/* we can load an E-kernel. */
expool_("DELTET/DELTA_AT", &found, (ftnlen)15);
if (! found) {
s_copy(error, "Before an E-kernel can be loaded, you must load a"
" leapseconds kernel. ", error_len, (ftnlen)71);
chkout_(rname, (ftnlen)6);
return 0;
}
m2getc_("ekfile", commnd, &found, file, (ftnlen)6, commnd_len, (
ftnlen)127);
/* See if we already have this file. */
if (isrchc_(file, &nfiles, ekfils, (ftnlen)127, (ftnlen)127) > 0) {
chkout_(rname, (ftnlen)6);
return 0;
}
/* Make sure there is room for this file. */
if (nfiles == 20) {
s_copy(error, "The maximum number of E-kernels that can loaded a"
"t open by INSPEKT at one time is #. That number has alr"
"eady been reached. You will need to unload one of the fi"
"les that have already been loaded before you will be abl"
"e to load any other files. ", error_len, (ftnlen)244);
repmct_(error, "#", &c__20, "L", error, error_len, (ftnlen)1, (
ftnlen)1, error_len);
prefix_(rnamec, &c__1, error, (ftnlen)7, error_len);
chkout_(rname, (ftnlen)6);
return 0;
}
/* Load the file as an e-kernel. */
eklef_(file, &handle, rtrim_(file, (ftnlen)127));
if (have_(error, error_len)) {
prefix_(rnamec, &c__1, error, (ftnlen)7, error_len);
chkout_(rname, (ftnlen)6);
return 0;
}
/* Store the name of this file. */
++nfiles;
s_copy(ekfils + ((i__1 = nfiles - 1) < 20 && 0 <= i__1 ? i__1 :
s_rnge("ekfils", i__1, "kerman_", (ftnlen)442)) * 127, file, (
ftnlen)127, (ftnlen)127);
/* Determine how many segments are in the file we just loaded. */
nseg = eknseg_(&handle);
/* For each segment in the newly loaded file ... */
i__1 = nseg;
for (seg = 1; seg <= i__1; ++seg) {
s_copy(tabnam, " ", (ftnlen)64, (ftnlen)1);
for (i__ = 1; i__ <= 100; ++i__) {
s_copy(cnames + (((i__2 = i__ - 1) < 100 && 0 <= i__2 ? i__2 :
s_rnge("cnames", i__2, "kerman_", (ftnlen)457)) << 6)
, " ", (ftnlen)64, (ftnlen)1);
}
zzeksinf_(&handle, &seg, tabnam, segdsc, cnames, cdscrs, (ftnlen)
64, (ftnlen)64);
/* Add each column name to the list of columns held by the */
/* column manager. */
ncols = segdsc[4];
i__2 = ncols;
for (col = 1; col <= i__2; ++col) {
/* We need to make the column name include table it */
/* belongs to (a fully qualified column name). */
prefix_(".", &c__0, cnames + (((i__3 = col - 1) < 100 && 0 <=
i__3 ? i__3 : s_rnge("cnames", i__3, "kerman_", (
ftnlen)475)) << 6), (ftnlen)1, (ftnlen)64);
prefix_(tabnam, &c__0, cnames + (((i__3 = col - 1) < 100 && 0
<= i__3 ? i__3 : s_rnge("cnames", i__3, "kerman_", (
ftnlen)476)) << 6), (ftnlen)64, (ftnlen)64);
cindxd = cdscrs[(i__3 = col * 11 - 6) < 1100 && 0 <= i__3 ?
i__3 : s_rnge("cdscrs", i__3, "kerman_", (ftnlen)478)]
!= -1;
cnull = cdscrs[(i__3 = col * 11 - 4) < 1100 && 0 <= i__3 ?
i__3 : s_rnge("cdscrs", i__3, "kerman_", (ftnlen)479)]
!= -1;
ctype = cdscrs[(i__3 = col * 11 - 10) < 1100 && 0 <= i__3 ?
i__3 : s_rnge("cdscrs", i__3, "kerman_", (ftnlen)481)]
;
clen = cdscrs[(i__3 = col * 11 - 9) < 1100 && 0 <= i__3 ?
i__3 : s_rnge("cdscrs", i__3, "kerman_", (ftnlen)482)]
;
csize = cdscrs[(i__3 = col * 11 - 8) < 1100 && 0 <= i__3 ?
i__3 : s_rnge("cdscrs", i__3, "kerman_", (ftnlen)483)]
;
/* This is what used to be here, but the item NBLIDX */
/* vanished by design. We now just set this so something */
/* reasonable. 24 seemed like the reasonable thing at */
/* the time. (See the column manager and do a bit of */
/* code diving to see what this is used for.) */
/* WIDEST = CDSCRS ( NBLIDX, COL ) */
widest = 24;
clnew_(cnames + (((i__3 = col - 1) < 100 && 0 <= i__3 ? i__3 :
s_rnge("cnames", i__3, "kerman_", (ftnlen)496)) << 6)
, &handle, &ctype, &clen, &widest, &csize, &cindxd, &
cnull, &id, (ftnlen)64);
}
}
/* If anything went wrong, unload the file. */
if (have_(error, error_len)) {
prefix_(rnamec, &c__1, error, (ftnlen)7, error_len);
ekuef_(&handle);
clunld_(&handle);
--nfiles;
chkout_(rname, (ftnlen)6);
return 0;
}
} else if (m2xist_("leapfile", (ftnlen)8)) {
m2getc_("leapfile", commnd, &found, file, (ftnlen)8, commnd_len, (
ftnlen)127);
ldpool_(file, (ftnlen)127);
bbputc_1__("POST", "LEAPSECONDS", &c__1, file, (ftnlen)4, (ftnlen)11,
(ftnlen)127);
} else if (m2xist_("sclkfile", (ftnlen)8)) {
m2getc_("sclkfile", commnd, &found, file, (ftnlen)8, commnd_len, (
ftnlen)127);
ldpool_(file, (ftnlen)127);
bbputc_1__("APPEND", "SCLK", &c__1, file, (ftnlen)6, (ftnlen)4, (
ftnlen)127);
} else {
s_copy(error, "The input command was unrecognized and somehow got to"
" an \"impossible\" place in KERMAN.FOR", error_len, (ftnlen)
89);
}
if (have_(error, error_len)) {
prefix_(rnamec, &c__1, error, (ftnlen)7, error_len);
chkout_(rname, (ftnlen)6);
return 0;
}
chkout_(rname, (ftnlen)6);
return 0;
/* Unload an E-kernel from the list of known files. */
L_nspuld:
s_copy(rname, "NSPULD", (ftnlen)6, (ftnlen)6);
s_copy(rnamec, "NSPULD:", (ftnlen)7, (ftnlen)7);
if (return_()) {
return 0;
}
chkin_(rname, (ftnlen)6);
j = isrchc_(infile__, &nfiles, ekfils, infile_len, (ftnlen)127);
if (j == 0) {
s_copy(error, "The file # is not listed among those files that have "
"been loaded. ", error_len, (ftnlen)66);
repmc_(error, "#", infile__, error, error_len, (ftnlen)1, rtrim_(
infile__, infile_len), error_len);
chkout_(rname, (ftnlen)6);
return 0;
}
/* Get the handle associated with this file. */
dasfnh_(infile__, &handle, rtrim_(infile__, infile_len));
if (have_(error, error_len)) {
chkout_(rname, (ftnlen)6);
return 0;
}
/* Now unload the file, and detach its handle from any columns to */
/* which it might be attached. */
ekuef_(&handle);
clunld_(&handle);
/* Finally remove this file from our internal list of files. */
remlac_(&c__1, &j, ekfils, &nfiles, (ftnlen)127);
chkout_(rname, (ftnlen)6);
return 0;
/* Create a report regarding currently loaded kernels/columns. */
L_nspeks:
/* Version 2.0 Aug 3, 1995 */
/* This routine was rewritten to provide a more friendly */
/* kernel summary. */
/* ---B. Taber */
/* This routine displays the currently loaded E-kernels. */
s_copy(rname, "NSPEKS", (ftnlen)6, (ftnlen)6);
s_copy(rnamec, "NSPEKS:", (ftnlen)7, (ftnlen)7);
if (return_()) {
return 0;
}
/* write (*,*) 'Checking in:' */
chkin_(rname, (ftnlen)6);
if (nfiles <= 0) {
nspwln_(" ", (ftnlen)1);
nspwln_("There are no E-kernels loaded now.", (ftnlen)34);
nspwln_(" ", (ftnlen)1);
chkout_(rname, (ftnlen)6);
return 0;
}
/* First thing we do is set up the NICEPR_1 style string */
/* to be used in creation of summary headers. */
/* write (*,*) 'Fetching margins: ' */
nspglr_(&left, &right);
nspmrg_(style, (ftnlen)80);
suffix_("FLAG", &c__1, style, (ftnlen)4, (ftnlen)80);
suffix_("E-kernel:", &c__1, style, (ftnlen)9, (ftnlen)80);
/* Reset the output page, title frequency and header frequency */
/* values. */
/* write (*,*) 'Resetting page and setting up page attributes:' */
pagrst_();
pagset_("TITLEFREQUENCY", &c__0, (ftnlen)14);
pagset_("HEADERFREQUENCY", &c__0, (ftnlen)15);
pagset_("NOSPACEFOOTER", &c__1, (ftnlen)13);
pagset_("FOOTERFREQUENCY", &c_n1, (ftnlen)15);
s_copy(pval, "CH", (ftnlen)32, (ftnlen)2);
s_copy(pval + 32, "D.P.", (ftnlen)32, (ftnlen)4);
s_copy(pval + 64, "INTEGER", (ftnlen)32, (ftnlen)7);
s_copy(pval + 96, "TIME", (ftnlen)32, (ftnlen)4);
lmarge = 1;
space = 1;
/* Next we set up the the column id codes, sizes, */
/* default widths, justifications, component preservation, */
/* and special marker attributes for each column. */
headr[0] = 1;
headr[1] = 2;
headr[2] = 3;
headr[3] = 4;
headr[4] = 5;
sizes[0] = 1;
sizes[1] = 1;
sizes[2] = 1;
sizes[3] = 1;
sizes[4] = 1;
width[0] = 16;
width[1] = 16;
width[2] = 8;
width[3] = 8;
width[4] = 6;
need = width[0] + width[1] + width[2] + width[3] + width[4] + 4;
right = min(right,need);
pagset_("PAGEWIDTH", &right, (ftnlen)9);
reqd = width[2] + width[3] + width[4] + 4;
/* If the page width is less than default needed, we reset the */
/* widths of the first two columns so they will fit in available */
/* space. */
if (right < need) {
width[0] = (right - reqd) / 2;
width[1] = width[0];
}
justr[0] = FALSE_;
justr[1] = FALSE_;
justr[2] = FALSE_;
justr[3] = TRUE_;
justr[4] = TRUE_;
presrv[0] = TRUE_;
presrv[1] = TRUE_;
presrv[2] = TRUE_;
presrv[3] = TRUE_;
presrv[4] = TRUE_;
s_copy(spcial, " ", (ftnlen)4, (ftnlen)1);
s_copy(spcial + 4, " ", (ftnlen)4, (ftnlen)1);
s_copy(spcial + 8, " ", (ftnlen)4, (ftnlen)1);
s_copy(spcial + 12, " ", (ftnlen)4, (ftnlen)1);
s_copy(spcial + 16, " ", (ftnlen)4, (ftnlen)1);
/* write (*,*) 'Starting file loop:' */
i__1 = nfiles;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Get the handle associated with this file, and get the */
/* number of ID's currently known. */
dasfnh_(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 : s_rnge(
"ekfils", i__2, "kerman_", (ftnlen)738)) * 127, &handle, (
ftnlen)127);
clnum_(&nid);
/* write (*,*) 'File: ', I, 'Handle: ', HANDLE */
/* Now empty out the table/column data for this file. */
/* write (*,*) 'Empty out the column collector.' */
ssizec_(&c__500, tabcol, (ftnlen)80);
ssizei_(&c__500, colids);
/* Cycle over all column id's to determine if they */
/* are attached to this particular file. */
/* write (*,*) 'Beginning Column search: ', NID, ' Columns' */
i__2 = nid;
for (j = 1; j <= i__2; ++j) {
clnid_(&j, &id, &found);
clgai_(&id, "HANDLES", &nh, handls, (ftnlen)7);
if (isrchi_(&handle, &nh, handls) > 0) {
/* This column is associated with this file. Store */
/* its name and id-code for the next section of code. */
/* write (*,*) 'Column id and associated handle match.' */
clgac_(&id, "NAME", cname, (ftnlen)4, (ftnlen)80);
appndc_(cname, tabcol, (ftnlen)80, (ftnlen)80);
appndi_(&id, colids);
}
}
/* Layout the pages. We perform a soft page reset */
/* so that the various sections will be empty. */
/* Note this doesn't affect frequency parameter */
/* or other geometry attributes of pages. */
/* write (*,*) 'Creating page: Title:' */
pagscn_("TITLE", (ftnlen)5);
pagput_(" ", (ftnlen)1);
pagput_("Summary of Loaded E-kernels", (ftnlen)27);
pagput_(" ", (ftnlen)1);
/* write (*,*) 'Creating page: Header' */
/* Set up the various items needed for the report header. */
pagscn_("HEADER", (ftnlen)6);
pagput_(" ", (ftnlen)1);
nicepr_1__(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("ekfils", i__2, "kerman_", (ftnlen)791)) * 127, style,
(S_fp)pagput_, (ftnlen)127, (ftnlen)80);
pagput_(" ", (ftnlen)1);
scolmn_(&c__1, &c__1, "Table Name", (ftnlen)10);
scolmn_(&c__2, &c__1, "Column Name", (ftnlen)11);
scolmn_(&c__3, &c__1, "Type", (ftnlen)4);
scolmn_(&c__4, &c__1, "Size", (ftnlen)4);
scolmn_(&c__5, &c__1, "Index", (ftnlen)5);
/* write (*,*) 'Creating page: Column headings' */
tabrpt_(&c__5, headr, sizes, width, justr, presrv, spcial, &lmarge, &
space, (U_fp)gcolmn_, (ftnlen)4);
s_copy(break__, "==================================================="
"=============================", (ftnlen)80, (ftnlen)80);
pagput_(break__, right);
/* Now set the page section to the body portion for */
/* preparing to fill in the e-kernel summary. */
/* write (*,*) 'Creating page: Body of report:' */
pagscn_("BODY", (ftnlen)4);
n = cardc_(tabcol, (ftnlen)80);
orderc_(tabcol + 480, &n, ordvec, (ftnlen)80);
s_copy(lsttab, " ", (ftnlen)32, (ftnlen)1);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
k = ordvec[(i__3 = j - 1) < 500 && 0 <= i__3 ? i__3 : s_rnge(
"ordvec", i__3, "kerman_", (ftnlen)826)];
clgac_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 : s_rnge(
"colids", i__3, "kerman_", (ftnlen)828)], "TABLE", tname,
(ftnlen)5, (ftnlen)32);
clgac_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 : s_rnge(
"colids", i__3, "kerman_", (ftnlen)829)], "NAME", cname, (
ftnlen)4, (ftnlen)80);
clgac_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 : s_rnge(
"colids", i__3, "kerman_", (ftnlen)830)], "SIZE", size, (
ftnlen)4, (ftnlen)32);
clgac_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 : s_rnge(
"colids", i__3, "kerman_", (ftnlen)831)], "INDEXED", indx,
(ftnlen)7, (ftnlen)4);
/* Note: There is only one type associated with each */
/* handle. Thus TCODE does not need to be an array. */
clgai_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 : s_rnge(
"colids", i__3, "kerman_", (ftnlen)836)], "TYPE", &count,
&tcode, (ftnlen)4);
if (s_cmp(tname, lsttab, (ftnlen)32, (ftnlen)32) == 0) {
s_copy(tname, " ", (ftnlen)32, (ftnlen)1);
} else if (s_cmp(lsttab, " ", (ftnlen)32, (ftnlen)1) != 0) {
pagput_(" ", (ftnlen)1);
s_copy(lsttab, tname, (ftnlen)32, (ftnlen)32);
} else {
s_copy(lsttab, tname, (ftnlen)32, (ftnlen)32);
}
nb = pos_(cname, ".", &c__1, (ftnlen)80, (ftnlen)1) + 1;
s_copy(name__, cname + (nb - 1), (ftnlen)32, 80 - (nb - 1));
if (tcode == 1) {
clgac_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 :
s_rnge("colids", i__3, "kerman_", (ftnlen)852)],
"TYPE", type__, (ftnlen)4, (ftnlen)32);
sb = pos_(type__, "*", &c__1, (ftnlen)32, (ftnlen)1);
s_copy(pval, "CH", (ftnlen)32, (ftnlen)2);
suffix_(type__ + (sb - 1), &c__0, pval, 32 - (sb - 1), (
ftnlen)32);
}
scolmn_(&c__6, &c__1, tname, (ftnlen)32);
scolmn_(&c__7, &c__1, name__, (ftnlen)32);
scolmn_(&c__8, &c__1, pval + (((i__3 = tcode - 1) < 4 && 0 <=
i__3 ? i__3 : s_rnge("pval", i__3, "kerman_", (ftnlen)860)
) << 5), (ftnlen)32);
scolmn_(&c__9, &c__1, size, (ftnlen)32);
scolmn_(&c__10, &c__1, indx, (ftnlen)4);
ids[0] = 6;
ids[1] = 7;
ids[2] = 8;
ids[3] = 9;
ids[4] = 10;
/* write (*,*) 'Creating next row:' */
/* write (*,*) TNAME */
/* write (*,*) NAME */
/* write (*,*) PVAL(TCODE) */
/* write (*,*) SIZE */
/* write (*,*) INDX */
tabrpt_(&c__5, ids, sizes, width, justr, presrv, spcial, &lmarge,
&space, (U_fp)gcolmn_, (ftnlen)4);
/* write (*,*) 'Row created.' */
}
/* Do a soft page reset so for the next file to be displayed */
/* write (*,*) 'Performing soft page reset.' */
pagsft_();
pagrst_();
pagset_("TITLEFREQUENCY", &c_n1, (ftnlen)14);
pagset_("HEADERFREQUENCY", &c__0, (ftnlen)15);
pagset_("NOSPACEFOOTER", &c__1, (ftnlen)13);
pagset_("FOOTERFREQUENCY", &c_n1, (ftnlen)15);
}
chkout_(rname, (ftnlen)6);
return 0;
/* $Procedure NSPEKC ( Inspekt the comments from EK files ) */
L_nspekc:
/* This entry point examines each file that matches the */
/* template given by INFILE and if comments exist for the */
/* file, they are displayed. */
/* Version 1.0.0 25-AUG-1995 (WLT) */
chkin_("NSPEKC", (ftnlen)6);
totalc = 0;
s_copy(thisfl, " ", (ftnlen)127, (ftnlen)1);
/* We might not need the style string, but it doesn't hurt to */
/* get it. */
nspmrg_(style, (ftnlen)80);
/* If there are no loaded E-kernels say so and return. */
if (nfiles == 0) {
s_copy(messge, "There are no E-kernels loaded now. ", (ftnlen)300, (
ftnlen)35);
nicepr_1__(messge, style, (S_fp)nspwln_, (ftnlen)300, (ftnlen)80);
chkout_("NSPEKC", (ftnlen)6);
return 0;
}
/* Count the number of characters present in the files */
/* that match the template. */
r__ = rtrim_(infile__, infile_len);
l = ltrim_(infile__, infile_len);
i__1 = nfiles;
for (i__ = 1; i__ <= i__1; ++i__) {
if (match_(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("ekfils", i__2, "kerman_", (ftnlen)945)) * 127,
infile__ + (l - 1), (ftnlen)127, r__ - (l - 1))) {
dasfnh_(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("ekfils", i__2, "kerman_", (ftnlen)947)) * 127, &
handle, (ftnlen)127);
dasrfr_(&handle, idword, ifname, &nresvr, &nresvc, &ncomr, &ncomc,
(ftnlen)8, (ftnlen)60);
totalc += ncomc;
++hits;
s_copy(thisfl, ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ?
i__2 : s_rnge("ekfils", i__2, "kerman_", (ftnlen)955)) *
127, (ftnlen)127, (ftnlen)127);
}
}
/* If we didn't get any characters there several possible */
/* reasons. We can look at HITS to see why and form a */
/* grammatically reasonable message. */
if (totalc == 0) {
if (hits == 0) {
s_copy(messge, "There are no E-kernels loaded whose file name ma"
"tches the supplied template '#'.", (ftnlen)300, (ftnlen)
80);
repmc_(messge, "#", infile__ + (l - 1), messge, (ftnlen)300, (
ftnlen)1, r__ - (l - 1), (ftnlen)300);
} else if (hits == 1) {
s_copy(messge, "There are no comments present in the file '#'. ",
(ftnlen)300, (ftnlen)47);
repmc_(messge, "#", thisfl, messge, (ftnlen)300, (ftnlen)1, (
ftnlen)127, (ftnlen)300);
} else if (hits == 2) {
s_copy(messge, "There are no comments present in either of the #"
" files that match the supplied template. ", (ftnlen)300, (
ftnlen)89);
repmct_(messge, "#", &hits, "L", messge, (ftnlen)300, (ftnlen)1, (
ftnlen)1, (ftnlen)300);
} else {
s_copy(messge, "There are no comments present in any of the # fi"
"les that match the supplied template. ", (ftnlen)300, (
ftnlen)86);
repmct_(messge, "#", &hits, "L", messge, (ftnlen)300, (ftnlen)1, (
ftnlen)1, (ftnlen)300);
}
nicepr_1__(messge, style, (S_fp)nspwln_, (ftnlen)300, (ftnlen)80);
chkout_("NSPEKC", (ftnlen)6);
return 0;
}
/* Ok. We've got something. Set up the output page to receive */
/* the comments a file at a time. */
suffix_("FLAG E-kernel:", &c__1, style, (ftnlen)14, (ftnlen)80);
i__1 = nfiles;
for (i__ = 1; i__ <= i__1; ++i__) {
if (match_(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("ekfils", i__2, "kerman_", (ftnlen)1012)) * 127,
infile__ + (l - 1), (ftnlen)127, r__ - (l - 1))) {
dasfnh_(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("ekfils", i__2, "kerman_", (ftnlen)1014)) * 127, &
handle, (ftnlen)127);
dasrfr_(&handle, idword, ifname, &nresvr, &nresvc, &ncomr, &ncomc,
(ftnlen)8, (ftnlen)60);
if (ncomc == 0) {
s_copy(messge, "# contains no comments.", (ftnlen)300, (
ftnlen)23);
repmc_(messge, "#", ekfils + ((i__2 = i__ - 1) < 20 && 0 <=
i__2 ? i__2 : s_rnge("ekfils", i__2, "kerman_", (
ftnlen)1023)) * 127, messge, (ftnlen)300, (ftnlen)1, (
ftnlen)127, (ftnlen)300);
nspwln_(" ", (ftnlen)1);
nicepr_1__(messge, style, (S_fp)nspwln_, (ftnlen)300, (ftnlen)
80);
} else {
pagrst_();
pagscn_("HEADER", (ftnlen)6);
pagset_("TITLEFREQUENCY", &c__0, (ftnlen)14);
pagset_("HEADERFREQUENCY", &c__0, (ftnlen)15);
pagset_("NOSPACEFOOTER", &c__1, (ftnlen)13);
pagset_("FOOTERFREQUENCY", &c_n1, (ftnlen)15);
pagput_(" ", (ftnlen)1);
nicepr_1__(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ?
i__2 : s_rnge("ekfils", i__2, "kerman_", (ftnlen)1038)
) * 127, style, (S_fp)pagput_, (ftnlen)127, (ftnlen)
80);
pagput_(" ", (ftnlen)1);
nspshc_(&handle, &quit);
if (quit) {
nspwln_(" ", (ftnlen)1);
chkout_("NSPEKC", (ftnlen)6);
return 0;
}
}
}
}
nspwln_(" ", (ftnlen)1);
chkout_("NSPEKC", (ftnlen)6);
return 0;
} /* kerman_ */
/* $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 STRAN */
/* Subroutine */ int stran_0_(int n__, char *input, char *output, logical *
tran, ftnlen input_len, ftnlen output_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen), i_indx(char *, char *,
ftnlen, ftnlen), s_rnge(char *, integer, char *, integer), i_len(
char *, ftnlen);
/* Local variables */
static integer ldef, leno, vdim, slot, lout, lsym, ptrs[810], i__, j;
extern integer cardc_(char *, ftnlen);
static integer l, n;
static logical check[200];
extern logical batch_(void);
static integer place;
extern /* Subroutine */ int lcase_(char *, char *, ftnlen, ftnlen);
static char delim[1];
extern /* Subroutine */ int chkin_(char *, ftnlen);
static integer nname;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
static char names[32*206];
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen),
geteq_(char *, ftnlen);
extern integer ncpos_(char *, char *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int nthwd_(char *, integer *, char *, integer *,
ftnlen, ftnlen);
static char symbl[33];
static integer psize;
extern integer rtrim_(char *, ftnlen);
static logical checkd[200];
extern logical failed_(void);
static char alphab[32];
extern /* Subroutine */ int getdel_(char *, ftnlen);
extern logical matchm_(char *, char *, char *, char *, char *, char *,
ftnlen, ftnlen, ftnlen, ftnlen, ftnlen, ftnlen);
static char buffer[256*52];
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen),
lastnb_(char *, ftnlen);
static logical gotone;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), repsub_(char *, integer *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen);
static char equote[1];
extern /* Subroutine */ int setmsg_(char *, ftnlen);
static char resvrd[32*12], symbol[33], pattrn[80];
static integer nxtchr;
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen), rdstmn_(char *, char *, char *, ftnlen, ftnlen, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int sbget_1__(char *, char *, integer *, char *,
char *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), nthuqw_(char *
, integer *, char *, char *, integer *, ftnlen, ftnlen, ftnlen);
static char myprmt[80];
extern /* Subroutine */ int sbrem_1__(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
static integer lsttry;
extern /* Subroutine */ int sbset_1__(char *, char *, char *, integer *,
char *, ftnlen, ftnlen, ftnlen, ftnlen);
static char def[1024];
static integer loc;
static char key[32];
static logical new__;
extern /* Subroutine */ int sbinit_1__(integer *, integer *, integer *,
char *, integer *, char *, ftnlen, ftnlen);
/* $ Abstract */
/* Translate the symbols in an input string. */
/* $ 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. */
/* $ Keywords */
/* PARSE */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* INPUT I Input string containing symbols to be translated. */
/* OUTPUT O Output string, with all symbols translated. */
/* $ Detailed_Input */
/* INPUT is the input string to be translated. INPUT may contain */
/* any number of known symbols. */
/* $ Detailed_Output */
/* OUTPUT is the translation of the input string. The first */
/* of the symbols in INPUT will have been translated. */
/* When INPUT is either a DEFINE or an UNDEFINE command, */
/* OUTPUT is blank. */
/* OUTPUT may overwrite INPUT. */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* None. */
/* $ Exceptions */
/* The following exceptions are detected by this routine: */
/* 1) Attempt to define or undefine a symbol that does */
/* not begin with a letter. */
/* 2) Attempt to define or undefine a symbol that ends with */
/* a question mark '?' . */
/* 3) Failure to specify a symbol to define or undefine. */
/* 4) Attempting to define a reserved word. The reserved */
/* words are: */
/* 'START' */
/* 'STOP' */
/* 'EXIT' */
/* 'INQUIRE' */
/* 'SHOW' */
/* 'DEFINE' */
/* 'SHOW' */
/* 'UNDEFINE' */
/* 'HELP' */
/* In all of the above cases OUTPUT is set to blank and TRAN to */
/* FALSE. No new symbol is placed in the table of symbol */
/* definitions. */
/* In all of these cases the error BAD_SYMBOL_SPC is signalled. */
/* 5) Recursive symbol definitions are detected and disallowed. */
/* A long error message diagnosing the problem is set and */
/* the error RECURSIVE_SYMBOL is signalled. */
/* 5) Overflow of the input command caused by symbol resolution. */
/* In this case the OUTPUT is left at the state it had reached */
/* prior to the overflow condition and TRAN is returned as */
/* FALSE. The error SYMBOL_OVERFLOW is signalled. */
/* $ Detailed_Description */
/* A new symbol may be defined with the DEFINE command. The */
/* syntax is: */
/* DEFINE <symbol> <definition> */
/* where <symbol> is a valid symbol name and <definition> is any */
/* valid definition. The DEFINE command, the symbol name, and the */
/* definition are delimited by blanks. */
/* When a symbol is defined, the symbol and definition are inserted */
/* into the symbol table. */
/* An existing symbol may be removed from the table with the */
/* UNDEFINE command. The syntax is: */
/* UNDEFINE <symbol> */
/* where <symbol> is the name of an existing symbol. The UNDEFINE */
/* command and the symbol name are delimited by blanks. */
/* If the input string does not contain a definition statement, */
/* STRANS searches the input string for potential symbol names. */
/* When a valid symbol is encountered, it is removed from the */
/* string and replaced by the corresponding definition. This */
/* continues until no untranslated symbols remain. */
/* $ Examples */
/* Suppose that we are given the following definitions: */
/* DEFINE BODIES PLANET AND SATS */
/* DEFINE EUROPA 502 */
/* DEFINE GANYMEDE 503 */
/* DEFINE IO 501 */
/* DEFINE JUPITER 599 */
/* DEFINE PLANET JUPITER */
/* DEFINE CALLISTO 504 */
/* DEFINE SATS IO EUROPA GANYMEDE CALLISTO */
/* Then the string 'BODIES AND SOULS' would translate, */
/* at various stages, to: */
/* 'PLANET AND SATS AND SOULS' */
/* 'JUPITER AND SATS AND SOULS' */
/* '599 AND SATS AND SOULS' */
/* '599 AND IO EUROPA GANYMEDE CALLISTO AND SOULS' */
/* '599 AND 501 EUROPA GANYMEDE CALLISTO AND SOULS' */
/* '599 AND 501 502 GANYMEDE CALLISTO AND SOULS' */
/* '599 AND 501 502 503 CALLISTO AND SOULS' */
/* '599 AND 501 502 503 504 AND SOULS' */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* I. M. Underwood (JPL) */
/* $ Version_and_Date */
/* Version 1.2.0 29-Aug-1996 (WLT) */
/* Fixed the error message for the case in which someone */
/* tries to create a symbol that is more than 32 characters */
/* in length. */
/* Version 1.1, 14-SEP-1995 */
/* Reference to unused variable WORD deleted. */
/* Version 1, 8-SEP-1986 */
/* -& */
/* SPICELIB Functions */
/* Other supporting functions */
/* The following parameters are used to define our table */
/* of symbol translations. */
/* Longest allowed symbol name is given by WDSIZE */
/* Maximum number of allowed symbols is MAXN */
/* The longest we expect any symbol to be is MAXL characters */
/* The average number of characters per symbol is AVGL */
/* Finally, here are the arrays used to hold the symbol translations. */
/* Here's the storage we need for the reserved words. */
switch(n__) {
case 1: goto L_sympat;
case 2: goto L_symget;
}
/* Set up all of the data structures and special strings in */
/* the first pass through the routine. */
if (return_()) {
return 0;
}
chkin_("STRAN", (ftnlen)5);
if (first) {
first = FALSE_;
vdim = 51;
psize = 804;
nname = 200;
sbinit_1__(&nname, &psize, &vdim, names, ptrs, buffer, (ftnlen)32, (
ftnlen)256);
s_copy(resvrd, "START", (ftnlen)32, (ftnlen)5);
s_copy(resvrd + 32, "STOP", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 64, "EXIT", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 96, "INQUIRE", (ftnlen)32, (ftnlen)7);
s_copy(resvrd + 128, "SHOW", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 160, "DEFINE", (ftnlen)32, (ftnlen)6);
s_copy(resvrd + 192, "SHOW", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 224, "UNDEFINE", (ftnlen)32, (ftnlen)8);
s_copy(resvrd + 256, "HELP", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 288, "RECALL", (ftnlen)32, (ftnlen)6);
s_copy(resvrd + 320, "DO", (ftnlen)32, (ftnlen)2);
s_copy(resvrd + 352, "EDIT", (ftnlen)32, (ftnlen)4);
s_copy(alphab, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", (ftnlen)32, (ftnlen)26);
}
/* Find out what the special marker character is for suppressing */
/* symbol evaluation. */
geteq_(equote, (ftnlen)1);
/* Is this a definition statement? The presence of DEFINE, INQUIRE or */
/* UNDEFINE at the beginning of the string will confirm this. */
nthwd_(input, &c__1, key, &loc, input_len, (ftnlen)32);
ucase_(key, key, (ftnlen)32, (ftnlen)32);
/* The keyword must be followed by a valid symbol name. */
if (s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0 || s_cmp(key, "INQU"
"IRE", (ftnlen)32, (ftnlen)7) == 0 || s_cmp(key, "UNDEFINE", (
ftnlen)32, (ftnlen)8) == 0) {
nthwd_(input, &c__2, symbl, &loc, input_len, (ftnlen)33);
ucase_(symbl, symbol, (ftnlen)33, (ftnlen)33);
l = rtrim_(symbol, (ftnlen)33);
if (s_cmp(symbol, " ", (ftnlen)33, (ftnlen)1) == 0) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
setmsg_("The \"#\" command must be followed by the name of the s"
"ymbol that you want to #. ", (ftnlen)79);
errch_("#", key, (ftnlen)1, (ftnlen)32);
lcase_(key, key, (ftnlen)32, (ftnlen)32);
errch_("#", key, (ftnlen)1, (ftnlen)32);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (i_indx(alphab, symbol, (ftnlen)32, (ftnlen)1) == 0) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
lcase_(key, key, (ftnlen)32, (ftnlen)32);
setmsg_("You cannot # \"#\". Symbols must begin with a letter ("
"A-Z) ", (ftnlen)58);
errch_("#", key, (ftnlen)1, (ftnlen)32);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (l > 32) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
lcase_(key, key, (ftnlen)32, (ftnlen)32);
setmsg_("You cannot # \"#...\". Symbols may not be longer than "
"32 characters in length.", (ftnlen)77);
errch_("#", key, (ftnlen)1, (ftnlen)32);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (*(unsigned char *)&symbol[l - 1] == '?') {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
lcase_(key, key, (ftnlen)32, (ftnlen)32);
setmsg_("You cannot # \"#\". Symbols may not end with a questio"
"n mark '?'. ", (ftnlen)65);
errch_("#", key, (ftnlen)1, (ftnlen)32);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if ((s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0 || s_cmp(
key, "INQUIRE", (ftnlen)32, (ftnlen)7) == 0) && isrchc_(
symbol, &c__12, resvrd, (ftnlen)33, (ftnlen)32) > 0) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
setmsg_("The word '#' is a reserved word. You may not redefine i"
"t. ", (ftnlen)58);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
}
}
if (s_cmp(key, "INQUIRE", (ftnlen)32, (ftnlen)7) == 0) {
/* First of all we, can only INQUIRE for symbol definitions */
/* if the program is not running in "batch" mode. */
if (batch_()) {
setmsg_("You've attempted to INQUIRE for the value of a symbol w"
"hile the program is running in \"batch\" mode. You can I"
"NQUIRE for a symbol value only if you are running in INT"
"ERACTIVE mode. ", (ftnlen)180);
sigerr_("WRONG_MODE", (ftnlen)10);
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* See if there is anything following the symbol that is */
/* to be defined. This will be used as our prompt value. */
/* Computing MAX */
i__3 = loc + l;
i__1 = loc + l, i__2 = ncpos_(input, " ", &i__3, input_len, (ftnlen)1)
;
nxtchr = max(i__1,i__2);
if (s_cmp(input + (nxtchr - 1), " ", input_len - (nxtchr - 1), (
ftnlen)1) != 0) {
s_copy(myprmt, input + (nxtchr - 1), (ftnlen)80, input_len - (
nxtchr - 1));
} else {
s_copy(myprmt, "Enter definition for", (ftnlen)80, (ftnlen)20);
suffix_(symbol, &c__1, myprmt, (ftnlen)33, (ftnlen)80);
suffix_(">", &c__1, myprmt, (ftnlen)1, (ftnlen)80);
}
getdel_(delim, (ftnlen)1);
rdstmn_(myprmt, delim, def, (ftnlen)80, (ftnlen)1, (ftnlen)1024);
sbset_1__(symbol, def, names, ptrs, buffer, (ftnlen)33, (ftnlen)1024,
(ftnlen)32, (ftnlen)256);
}
/* If this is a definition, and the symbol already exists in the */
/* symbol table, simply replace the existing definition with the */
/* string following the symbol name. If this is a new symbol, */
/* find the first symbol in the list that should follow the new */
/* one. Move the rest of the symbols back, and insert the new one */
/* at this point. */
if (s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0) {
/* Computing MAX */
i__3 = loc + l;
i__1 = loc + l, i__2 = ncpos_(input, " ", &i__3, input_len, (ftnlen)1)
;
nxtchr = max(i__1,i__2);
sbset_1__(symbol, input + (nxtchr - 1), names, ptrs, buffer, (ftnlen)
33, input_len - (nxtchr - 1), (ftnlen)32, (ftnlen)256);
}
if (s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0 || s_cmp(key, "INQU"
"IRE", (ftnlen)32, (ftnlen)7) == 0) {
if (failed_()) {
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* Now check for a recursive definition. To do this we have */
/* two parallel arrays to the NAMES array of the string */
/* buffer. The first array CHECK is used to indicate that */
/* in the course of the definition resolution of the */
/* new symbol, another symbol shows up. The second array */
/* called CHECKD indicats whether or not we have examined this */
/* existing symbol to see if contains the newly created */
/* symbol as part of its definition. */
/* So far we have nothing to check and haven't checked anything. */
n = cardc_(names, (ftnlen)32);
i__1 = n;
for (j = 1; j <= i__1; ++j) {
check[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge("check",
i__2, "stran_", (ftnlen)545)] = FALSE_;
checkd[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge("checkd",
i__2, "stran_", (ftnlen)546)] = FALSE_;
}
/* Find the location of our new symbol in the NAMES cell. */
place = isrchc_(symbol, &n, names + 192, (ftnlen)33, (ftnlen)32);
new__ = TRUE_;
while(new__) {
/* Look up the definition currently associated with */
/* the symbol we are checking. */
sbget_1__(symbol, names, ptrs, buffer, def, &i__, (ftnlen)33, (
ftnlen)32, (ftnlen)256, (ftnlen)1024);
j = 1;
nthuqw_(def, &j, equote, symbol, &loc, (ftnlen)1024, (ftnlen)1, (
ftnlen)33);
while(loc > 0) {
ucase_(symbol, symbol, (ftnlen)33, (ftnlen)33);
slot = isrchc_(symbol, &n, names + 192, (ftnlen)33, (ftnlen)
32);
/* If the word is located in the same place as the */
/* symbol we've just defined, we've introduced */
/* a recursive symbol definition. Remove this */
/* symbol and diagnose the error. */
if (slot == place) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
s_copy(symbol, names + (((i__1 = place + 5) < 206 && 0 <=
i__1 ? i__1 : s_rnge("names", i__1, "stran_", (
ftnlen)582)) << 5), (ftnlen)33, (ftnlen)32);
sbrem_1__(symbol, names, ptrs, buffer, (ftnlen)33, (
ftnlen)32, (ftnlen)256);
setmsg_("The definition of '#' is recursive. Recursivel"
"y defined symbol definitions are not allowed. ", (
ftnlen)93);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("RECURSIVE_SYMBOL", (ftnlen)16);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (slot > 0) {
/* Otherwise if this word is in the names list */
/* we may need to check this symbol to see if */
/* it lists the just defined symbol in its definition. */
if (checkd[(i__1 = slot - 1) < 200 && 0 <= i__1 ? i__1 :
s_rnge("checkd", i__1, "stran_", (ftnlen)602)]) {
check[(i__1 = slot - 1) < 200 && 0 <= i__1 ? i__1 :
s_rnge("check", i__1, "stran_", (ftnlen)603)]
= FALSE_;
} else {
check[(i__1 = slot - 1) < 200 && 0 <= i__1 ? i__1 :
s_rnge("check", i__1, "stran_", (ftnlen)605)]
= TRUE_;
}
}
/* Locate the next unquoted word in the definition. */
++j;
nthuqw_(def, &j, equote, symbol, &loc, (ftnlen)1024, (ftnlen)
1, (ftnlen)33);
}
/* See if there are any new items to check. If there */
/* are create a new value for symbol, and mark the */
/* new item as being checked. */
new__ = FALSE_;
i__1 = n;
for (j = 1; j <= i__1; ++j) {
if (check[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge(
"check", i__2, "stran_", (ftnlen)625)] && ! new__) {
s_copy(symbol, names + (((i__2 = j + 5) < 206 && 0 <=
i__2 ? i__2 : s_rnge("names", i__2, "stran_", (
ftnlen)626)) << 5), (ftnlen)33, (ftnlen)32);
check[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge(
"check", i__2, "stran_", (ftnlen)627)] = FALSE_;
checkd[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge(
"checkd", i__2, "stran_", (ftnlen)628)] = TRUE_;
new__ = TRUE_;
}
}
}
/* If we get to this point, we have a new non-recursively */
/* defined symbol. */
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* If this is a deletion, and the symbol already exists in the */
/* symbol table, simply move the symbols that follow toward the */
/* front of the table. */
if (s_cmp(key, "UNDEFINE", (ftnlen)32, (ftnlen)8) == 0) {
sbrem_1__(symbol, names, ptrs, buffer, (ftnlen)33, (ftnlen)32, (
ftnlen)256);
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* This is not a definition statement. Look for potential symbols. */
/* Try to resolve the first symbol in the string by substituting the */
/* corresponding definition for the existing symbol. */
s_copy(output, input, output_len, input_len);
*tran = FALSE_;
j = 1;
nthuqw_(output, &j, equote, symbol, &loc, output_len, (ftnlen)1, (ftnlen)
33);
while(! (*tran) && s_cmp(symbol, " ", (ftnlen)33, (ftnlen)1) != 0) {
ucase_(symbol, symbol, (ftnlen)33, (ftnlen)33);
sbget_1__(symbol, names, ptrs, buffer, def, &i__, (ftnlen)33, (ftnlen)
32, (ftnlen)256, (ftnlen)1024);
if (i__ > 0) {
lsym = lastnb_(symbol, (ftnlen)33);
ldef = lastnb_(def, (ftnlen)1024) + 1;
lout = lastnb_(output, output_len);
leno = i_len(output, output_len);
if (lout - lsym + ldef > leno) {
*tran = FALSE_;
setmsg_("As a result of attempting to resolve the symbols in"
" the input command, the command has overflowed the a"
"llocated memory. This is may be due to unintentional"
"ly using symbols that you had not intended to use. "
"You may protect portions of your string from symbol "
"evaluation by enclosing that portion of your string "
"between the character # as in 'DO #THIS PART WITHOUT"
" SYMBOLS#' . ", (ftnlen)376);
errch_("#", equote, (ftnlen)1, (ftnlen)1);
errch_("#", equote, (ftnlen)1, (ftnlen)1);
errch_("#", equote, (ftnlen)1, (ftnlen)1);
sigerr_("SYMBOL_OVERFLOW", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
}
i__1 = loc + lsym - 1;
repsub_(output, &loc, &i__1, def, output, output_len, ldef,
output_len);
*tran = TRUE_;
} else {
++j;
}
nthuqw_(output, &j, equote, symbol, &loc, output_len, (ftnlen)1, (
ftnlen)33);
}
chkout_("STRAN", (ftnlen)5);
return 0;
/* The following entry point allows us to set up a search */
/* of defined symbols that match a wild-card pattern. It must */
/* be called prior to getting any symbol definitions. */
L_sympat:
lsttry = 0;
s_copy(pattrn, input, (ftnlen)80, input_len);
return 0;
/* The following entry point fetches the next symbol and its */
/* definition for the next SYMBOL whose name */
/* matches a previously supplied template via the entry point */
/* above --- SYMPAT. */
/* If there is no matching symbol, we get back blanks. Note */
/* that no translation of the definition is performed. */
L_symget:
s_copy(input, " ", input_len, (ftnlen)1);
s_copy(output, " ", output_len, (ftnlen)1);
n = cardc_(names, (ftnlen)32);
while(lsttry < n) {
++lsttry;
gotone = matchm_(names + (((i__1 = lsttry + 5) < 206 && 0 <= i__1 ?
i__1 : s_rnge("names", i__1, "stran_", (ftnlen)767)) << 5),
pattrn, "*", "%", "~", "|", (ftnlen)32, (ftnlen)80, (ftnlen)1,
(ftnlen)1, (ftnlen)1, (ftnlen)1);
if (gotone) {
s_copy(symbol, names + (((i__1 = lsttry + 5) < 206 && 0 <= i__1 ?
i__1 : s_rnge("names", i__1, "stran_", (ftnlen)771)) << 5)
, (ftnlen)33, (ftnlen)32);
s_copy(input, names + (((i__1 = lsttry + 5) < 206 && 0 <= i__1 ?
i__1 : s_rnge("names", i__1, "stran_", (ftnlen)772)) << 5)
, input_len, (ftnlen)32);
sbget_1__(symbol, names, ptrs, buffer, output, &i__, (ftnlen)33, (
ftnlen)32, (ftnlen)256, output_len);
return 0;
}
}
return 0;
} /* stran_ */
/* $Procedure PODDGC ( Pod, duplicate group, character ) */
/* Subroutine */ int poddgc_(char *pod, ftnlen pod_len)
{
integer need, have;
extern integer cardc_(char *, ftnlen);
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern integer sizec_(char *, ftnlen);
extern /* Subroutine */ int podaec_(char *, integer *, char *, ftnlen,
ftnlen), podbgc_(char *, ftnlen), podonc_(char *, integer *,
integer *, ftnlen);
integer offset, number;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Begin a new group within a pod, containing the same elements */
/* as the active group. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* PODS */
/* $ Keywords */
/* ARRAYS */
/* CELLS */
/* PODS */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* POD I,O Pod. */
/* $ Detailed_Input */
/* POD on input, is an arbitrary pod. */
/* $ Detailed_Output */
/* POD on output, is the same pod, in which the active */
/* group has been sealed, and a new active group */
/* (containing the same elements as the previous group) */
/* begun. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If POD does not have sufficient free space to create */
/* the new group, the pod is not changed, and the error */
/* SPICE(TOOMANYPEAS) is signalled. (If the active group */
/* contains no elements, there must be sufficient free */
/* space for the new group to contain at least one element.) */
/* $ Files */
/* None. */
/* $ Particulars */
/* There are two ways to create a new group within a pod. */
/* PODBG (begin group) seals the current contents of the pod, */
/* and creates a new active group containing no elements. */
/* PODDG (duplicate group) also seals the current contents */
/* of the pod, but places a copy of the previous active */
/* group into the new active group. */
/* In both cases, the active group and all previous groups are */
/* unavailable so long as the new group exists. */
/* The active group of a pod may be removed by any of the */
/* following routines: PODEG (end group), PODCG (close group), */
/* or PODRG (replace group). */
/* $ Examples */
/* Let the active group of POD be located in elements 21 */
/* through 40. Then following the call */
/* CALL PODBGC ( POD ) */
/* the active group is located in elements 42 through 41. */
/* In other words, element 41 has been appropriated by the */
/* pod itself, and the active group is empty. */
/* However, following the call */
/* CALL PODDG ( POD ) */
/* the active group is located in elements 42 through 61, */
/* and contains the same elements as the previous active */
/* group. */
/* $ Restrictions */
/* 1) In any pod, only the active group should be accessed, */
/* and its location should always be determined by PODBE */
/* or PODON. Never assume that the active group begins */
/* at POD(1). */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - Beta Version 1.0.0, 15-JUL-1989 (WLT) (IMU) */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("PODDGC", (ftnlen)6);
}
/* How many spaces are needed? One for bookkeeping, and one for */
/* each of the elements in the active group. (If there are no */
/* elements, then one for future use.) */
podonc_(pod, &offset, &number, pod_len);
have = sizec_(pod, pod_len);
need = cardc_(pod, pod_len) + 1 + max(1,number);
if (have < need) {
sigerr_("SPICE(TOOMANYPEAS)", (ftnlen)18);
chkout_("PODDGC", (ftnlen)6);
return 0;
}
/* Go ahead and create a new (empty) group. */
podbgc_(pod, pod_len);
/* Append the old group (still in the same place) to the pod. */
/* (Somewhat incestuous, but practical.) Kids, don't try this */
/* at home: you aren't supposed to know that existing groups */
/* arent't changed by the addition of new ones. */
podaec_(pod + (offset + 6) * pod_len, &number, pod, pod_len, pod_len);
chkout_("PODDGC", (ftnlen)6);
return 0;
} /* poddgc_ */
