/* $Procedure PARSDO ( Parsing of DATA_ORDER string ) */
/* Subroutine */ int parsdo_(char *line, char *doval, integer *nval, integer *
param, integer *nparam, ftnlen line_len, ftnlen doval_len)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer i__, l;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
char value[12];
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen),
lastnb_(char *, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int nextwd_(char *, char *, char *, ftnlen,
ftnlen, ftnlen), setmsg_(char *, ftnlen), sigerr_(char *, ftnlen),
chkout_(char *, ftnlen);
/* $ Abstract */
/* This routine is a module of the MKSPK program. It parses the */
/* DATA_ORDER value provided in a setup file and forms an array */
/* of indexes of recognizable input parameters contaned in it. */
/* $ 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 */
/* MKSPK User's Guide */
/* $ Keywords */
/* PARSING */
/* $ Declarations */
/* $ Abstract */
/* MKSPK Include File. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Author_and_Institution */
/* N.G. Khavenson (IKI RAS, Russia) */
/* B.V. Semenov (NAIF, JPL) */
/* $ Version */
/* - Version 1.2.0, 16-JAN-2008 (BVS). */
/* Added ETTMWR parameter */
/* - Version 1.1.0, 05-JUN-2001 (BVS). */
/* Added MAXDEG parameter. */
/* - Version 1.0.4, 21-MAR-2001 (BVS). */
/* Added parameter for command line flag '-append' indicating */
/* that appending to an existing output file was requested. */
/* Added corresponding setup file keyword ('APPEND_TO_OUTPUT'.) */
/* Added parameters for yes and no values of this keyword. */
/* - Version 1.0.3, 28-JAN-2000 (BVS). */
/* Added parameter specifying number of supported input data */
/* types and parameter specifying number of supported output SPK */
/* types */
/* - Version 1.0.2, 22-NOV-1999 (NGK). */
/* Added parameters for two-line elements processing. */
/* - Version 1.0.1, 18-MAR-1999 (BVS). */
/* Added usage, help and template displays. Corrected comments. */
/* - Version 1.0.0, 8-SEP-1998 (NGK). */
/* -& */
/* Begin Include Section: MKSPK generic parameters. */
/* Maximum number of states allowed per one segment. */
/* String size allocation parameters */
/* Length of buffer for input text processing */
/* Length of a input text line */
/* Length of file name and comment line */
/* Length of string for keyword value processing */
/* Length of string for word processing */
/* Length of data order parameters string */
/* Length of string reserved as delimiter */
/* Numbers of different parameters */
/* Maximum number of allowed comment lines. */
/* Reserved number of input parameters */
/* Full number of delimiters */
/* Number of delimiters that may appear in time string */
/* Command line flags */
/* Setup file keywords reserved values */
/* Standard YES and NO values for setup file keywords. */
/* Number of supported input data types and input DATA TYPE */
/* reserved values. */
/* Number of supported output SPK data types -- this version */
/* supports SPK types 5, 8, 9, 10, 12, 13, 15 and 17. */
/* End of input record marker */
/* Maximum allowed polynomial degree. The value of this parameter */
/* is consistent with the ones in SPKW* routines. */
/* Special time wrapper tag for input times given as ET seconds past */
/* J2000 */
/* End Include Section: MKSPK generic parameters. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- ---------------------------------------------- */
/* LINE I DATA_ORDER string */
/* DOVAL I Array of recognizable input parameter names */
/* NVAL I Number of recognizable input parameters */
/* PARAM O Array of parameter IDs present in DATA_ORDER */
/* NPARAM O Number of elements in PARAM */
/* $ Detailed_Input */
/* LINE is the DATA_ORDER value that will be parsed. */
/* DOVAL is an array containing complete set recognizable */
/* input parameters (see main module for the current */
/* list). */
/* NVAL is the total number of recognizable input parameters */
/* (number of elements in DOVAL). */
/* $ Detailed_Output */
/* PARAM is an integer array containing indexes of the */
/* recognizable input parameters present in the input */
/* DATA_ORDER value in the order in which they are */
/* provided in that value. */
/* NPARAM is the number of elements in PARAM. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If token in the data order is not recognized, then the */
/* error 'SPICE(BADDATAORDERTOKEN)' will be signalled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This subroutine parses DATA_ORDER string containing names of */
/* input data record parameters in the order in which they appear */
/* in the input records and returns an integer array of the indexes */
/* of the parameters that were found in the string. */
/* $ Examples */
/* Let DATA_ORDER has following value: */
/* LINE = 'EPOCH X Y Z SKIP VX VY VZ' */
/* and DOVAL array contains the following values: */
/* DOVAL(1) = 'EPOCH' */
/* DOVAL(2) = 'X' */
/* DOVAL(3) = 'Y' */
/* DOVAL(4) = 'Z' */
/* DOVAL(5) = 'VX' */
/* DOVAL(6) = 'VY' */
/* DOVAL(7) = 'VZ' */
/* ... */
/* DOVAL(30) = 'SKIP' */
/* Then after parsing we will have on the output: */
/* NPARAM = 8 */
/* PARAM = 1, 2, 3, 4, 30, 5, 6, 7 */
/* $ Restrictions */
/* Because search for a parameter in the DATA_ORDER value is case */
/* sensitive, the DATA_ORDER value and parameter names must be */
/* in the same case (nominally uppercase). */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.G. Khavenson (IKI RAS, Russia) */
/* B.V. Semenov (NAIF, JPL) */
/* $ Version */
/* - Version 1.0.3, 29-MAR-1999 (NGK). */
/* Corrected examples section. */
/* - Version 1.0.2, 18-MAR-1999 (BVS). */
/* Corrected comments. */
/* - Version 1.0.1, 13-JAN-1999 (BVS). */
/* Modified error messages. */
/* - Version 1.0.0, 08-SEP-1998 (NGK). */
/* -& */
/* $ Index_Entries */
/* Parse MKSPK setup DATA_ORDER string. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Size VALUEL declared in the include file. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("PARSDO", (ftnlen)6);
}
/* Assign zero to PARAM array. */
i__1 = *nval;
for (l = 1; l <= i__1; ++l) {
param[l - 1] = 0;
}
/* Reset counter of words on line. */
*nparam = 0;
while(lastnb_(line, line_len) != 0) {
/* Get next word from the line. Value is already uppercase. */
nextwd_(line, value, line, line_len, (ftnlen)12, line_len);
i__ = isrchc_(value, nval, doval, (ftnlen)12, doval_len);
/* Look whether this value is one of the reserved values. */
if (i__ != 0) {
/* This value is OK. Memorize it. */
++(*nparam);
param[*nparam - 1] = i__;
} else {
/* We can not recognize this value. */
setmsg_("Can not recognize token '#' in the value of the setup f"
"ile keyword '#'. Refer to the User's Guide for the progr"
"am for complete list of allowed tokens.", (ftnlen)150);
errch_("#", value, (ftnlen)1, (ftnlen)12);
errch_("#", "DATA_ORDER", (ftnlen)1, (ftnlen)10);
sigerr_("SPICE(BADDATAORDERTOKEN)", (ftnlen)24);
}
}
chkout_("PARSDO", (ftnlen)6);
return 0;
} /* parsdo_ */
/* $Procedure PARCML ( Parse command line ) */
/* Subroutine */ int parcml_(char *line, integer *nkeys, char *clkeys,
logical *clflag, char *clvals, logical *found, char *unprsd, ftnlen
line_len, ftnlen clkeys_len, ftnlen clvals_len, ftnlen unprsd_len)
{
/* System generated locals */
address a__1[2];
integer i__1, i__2[2];
char ch__1[2049];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static char hkey[2048];
static integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen);
static char hline[2048];
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
static integer clidx;
static char lngwd[2048], uline[2048];
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
static integer begpos;
static char hlngwd[2048];
static integer pclidx, endpos;
extern /* Subroutine */ int chkout_(char *, ftnlen), nextwd_(char *, char
*, char *, ftnlen, ftnlen, ftnlen);
extern logical return_(void);
extern integer pos_(char *, char *, integer *, ftnlen, ftnlen);
/* $ Abstract */
/* Parse a command-line like string in the "key value key value ..." */
/* format with keys provided in any order and any letter case */
/* (lower, upper, mixed) and return values of requested keys. */
/* $ 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 */
/* PARSING */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* LINE I/O Input command-line like string. */
/* NKEYS I Number of keys to look for. */
/* CLKEYS I Keys to look for. */
/* CLFLAG O "A particular key found" flags. */
/* CLVALS O Key values. */
/* FOUND O "At least one key found" flag. */
/* UNPRSD O Beginning part of the LINE that was not parsed */
/* LLNSIZ P Size of longest sub-string that can be processed. */
/* $ Detailed_Input */
/* LINE is the input command-line like string in the "key */
/* value key value ..." format. The line should start */
/* with one of the keys provided in CLKEYS as the */
/* routine ignores any words before the first recognized */
/* key. */
/* To avoid limiting the size of the input string that */
/* can be processed, this routine uses LINE as the work */
/* buffer; it modifies LINE in the process of execution, */
/* and sets it to blank before return. */
/* NKEYS is the number of keys to look for provided in the */
/* CLKEYS array. */
/* CLKEYS is an array of keys to look for. Individual keys */
/* must be left-justified string consisting of any */
/* printable the characters except lower-case letters */
/* and blanks. */
/* $ Detailed_Output */
/* LINE is set to blank on the output. */
/* CLFLAG are the "key found" flags; set to TRUE if */
/* corresponding key was found. */
/* CLVALS are the key values; if a key wasn't found, its value */
/* set to a blank string. */
/* FOUND is set to .TRUE. if at least one key was found. */
/* Otherwise it is set to .FALSE. */
/* UNPRSD is the beginning part of the LINE, preceeding the */
/* first recognized key, that was ignored by this */
/* routine. */
/* $ Parameters */
/* LLNSIZ is the size of the internal buffer that holds a */
/* portion of the input string that is being examined. */
/* It limits the maximum total length of a front and */
/* back blank-padded, blank-separated sub-string */
/* containing a key, the value that follows it, and the */
/* next key (e.g. ' key value key ') that this routine */
/* can correctly process. */
/* $ Exceptions */
/* None. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine modifies the input string. It returns it set to */
/* blank. */
/* The case of the keys in the input string is not significant. */
/* The order of keys in the input string is not significant. */
/* If any key appears in the string more than once, only the */
/* last value of that key is returned. */
/* The part of the line from the start up to the first recognized */
/* key is returned in the UNPRSD argument. */
/* $ Examples */
/* If CLKEYS are */
/* CLKEYS(1) = '-SETUP' */
/* CLKEYS(2) = '-TO' */
/* CLKEYS(3) = '-FROM' */
/* CLKEYS(4) = '-HELP' */
/* then: */
/* line '-setup my.file -FROM utc -TO sclk' */
/* will be parsed as */
/* CLFLAG(1) = .TRUE. CLVALS(1) = 'my.file' */
/* CLFLAG(2) = .TRUE. CLVALS(2) = 'utc' */
/* CLFLAG(3) = .TRUE. CLVALS(3) = 'sclk' */
/* CLFLAG(4) = .FALSE. CLVALS(4) = ' ' */
/* UNPRSD = ' ' */
/* FOUND = .TRUE. */
/* line '-bogus -setup my.file -FROM utc -TO sclk' */
/* will be parsed as */
/* CLFLAG(1) = .TRUE. CLVALS(1) = 'my.file' */
/* CLFLAG(2) = .TRUE. CLVALS(2) = 'utc' */
/* CLFLAG(3) = .TRUE. CLVALS(3) = 'sclk' */
/* CLFLAG(4) = .FALSE. CLVALS(4) = ' ' */
/* UNPRSD = '-bogus' */
/* FOUND = .TRUE. */
/* line 'why not -setup my.file -FROM utc -TO sclk' */
/* will be parsed as */
/* CLFLAG(1) = .TRUE. CLVALS(1) = 'my.file' */
/* CLFLAG(2) = .TRUE. CLVALS(2) = 'utc' */
/* CLFLAG(3) = .TRUE. CLVALS(3) = 'sclk' */
/* CLFLAG(4) = .FALSE. CLVALS(4) = ' ' */
/* UNPRSD = 'why not' */
/* FOUND = .TRUE. */
/* line '-SETUP my.file -setup your.file' */
/* will be parsed as */
/* CLFLAG(1) = .TRUE. CLVALS(1) = 'your.file' */
/* CLFLAG(2) = .FALSE. CLVALS(2) = ' ' */
/* CLFLAG(3) = .FALSE. CLVALS(3) = ' ' */
/* CLFLAG(4) = .FALSE. CLVALS(4) = ' ' */
/* UNPRSD = ' ' */
/* FOUND = .TRUE. */
/* line '-setup my.file -SeTuP your.file' */
/* will be parsed as */
/* CLFLAG(1) = .TRUE. CLVALS(1) = 'your.file' */
/* CLFLAG(2) = .FALSE. CLVALS(2) = ' ' */
/* CLFLAG(3) = .FALSE. CLVALS(3) = ' ' */
/* CLFLAG(4) = .FALSE. CLVALS(4) = ' ' */
/* UNPRSD = ' ' */
/* FOUND = .TRUE. */
/* line '-help' */
/* will be parsed as */
/* CLFLAG(1) = .FALSE. CLVALS(1) = ' ' */
/* CLFLAG(2) = .FALSE. CLVALS(2) = ' ' */
/* CLFLAG(3) = .FALSE. CLVALS(3) = ' ' */
/* CLFLAG(4) = .TRUE. CLVALS(4) = ' ' */
/* UNPRSD = ' ' */
/* FOUND = .TRUE. */
/* and so on. */
/* $ Restrictions */
/* This routine cannot process input lines with any ' -key value */
/* -key ' sub-string that is longer than LLNSIZ. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SUPPORT Version 1.0.0, 15-FEB-2012 (BVS) */
/* -& */
/* Local variables. */
/* Save everything to prevent potential memory problems in f2c'ed */
/* version. */
/* SPICELIB functions. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("PARCML", (ftnlen)6);
}
/* Set initial values of keys to blanks and flags to .FALSE. */
i__1 = *nkeys;
for (i__ = 1; i__ <= i__1; ++i__) {
clflag[i__ - 1] = FALSE_;
s_copy(clvals + (i__ - 1) * clvals_len, " ", clvals_len, (ftnlen)1);
}
*found = FALSE_;
/* Parsing loop. We will set the sub-string buffer HLINE to as many */
/* characters from the input line as it will fit, starting with the */
/* initial part of the line on the first iteration and resetting to */
/* sub-strings starting at the first character of each value after */
/* the previous key-value pair was processed, and will pick at HLINE */
/* word by word looking for recognized keys. The loop will */
/* continue until we reach the end of the string -- all key-value */
/* pairs were processed and the sub-string buffer HLINE was set to */
/* blank. */
s_copy(hline, line, (ftnlen)2048, line_len);
pclidx = 0;
clidx = 0;
s_copy(unprsd, line, unprsd_len, line_len);
while(s_cmp(hline, " ", (ftnlen)2048, (ftnlen)1) != 0) {
/* Get next word; uppercase it; look for it in the input keys */
/* array. */
nextwd_(hline, lngwd, hline, (ftnlen)2048, (ftnlen)2048, (ftnlen)2048)
;
ucase_(lngwd, hlngwd, (ftnlen)2048, (ftnlen)2048);
clidx = isrchc_(hlngwd, nkeys, clkeys, (ftnlen)2048, clkeys_len);
/* Is the token that we found a recognized key? */
if (clidx != 0) {
/* Yes, it is. Is it the first key that we have found? */
if (pclidx != 0) {
/* No it is not. We need to save the value of the previous */
/* key. */
/* Compute the begin and end positions of the sub-string */
/* that contains the previous value by looking for the */
/* previous and current keys in the upper-cased remainder of */
/* the input line. */
/* The begin position is the position of the previous key */
/* plus its length. The end position is the position of the */
/* front-n-back blank-padded current key. */
ucase_(line, uline, line_len, (ftnlen)2048);
begpos = pos_(uline, clkeys + (pclidx - 1) * clkeys_len, &
c__1, (ftnlen)2048, rtrim_(clkeys + (pclidx - 1) *
clkeys_len, clkeys_len)) + rtrim_(clkeys + (pclidx -
1) * clkeys_len, clkeys_len);
/* Writing concatenation */
i__2[0] = 1, a__1[0] = " ";
i__2[1] = rtrim_(clkeys + (clidx - 1) * clkeys_len,
clkeys_len), a__1[1] = clkeys + (clidx - 1) *
clkeys_len;
s_cat(hkey, a__1, i__2, &c__2, (ftnlen)2048);
/* Writing concatenation */
i__2[0] = 2048, a__1[0] = uline;
i__2[1] = 1, a__1[1] = " ";
s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2049);
endpos = pos_(ch__1, hkey, &begpos, (ftnlen)2049, rtrim_(hkey,
(ftnlen)2048) + 1);
/* Extract the value, left-justify it, and RTRIM it. Set */
/* "value found" flag to .TRUE. */
s_copy(clvals + (pclidx - 1) * clvals_len, line + (begpos - 1)
, clvals_len, endpos - (begpos - 1));
ljust_(clvals + (pclidx - 1) * clvals_len, clvals + (pclidx -
1) * clvals_len, clvals_len, clvals_len);
s_copy(clvals + (pclidx - 1) * clvals_len, clvals + (pclidx -
1) * clvals_len, clvals_len, rtrim_(clvals + (pclidx
- 1) * clvals_len, clvals_len));
clflag[pclidx - 1] = TRUE_;
/* Check whether we already parsed the whole line. It will */
/* be so if the remainder of the buffer holding the */
/* sub-string that we examine word-by-word is a blank */
/* string. */
if (s_cmp(hline, " ", (ftnlen)2048, (ftnlen)1) != 0) {
/* No, we did not parse the whole line yet. There is */
/* more stuff to parse and we reset the temporary */
/* sub-string buffer to hold the part of the input string */
/* starting with the first character after the current */
/* key -- the end position plus the length of the */
/* current key. */
i__1 = endpos + 1 + rtrim_(clkeys + (clidx - 1) *
clkeys_len, clkeys_len) - 1;
s_copy(hline, line + i__1, (ftnlen)2048, line_len - i__1);
}
/* Now reset the line to its portion starting with the */
/* first character of the current key. */
i__1 = endpos;
s_copy(line, line + i__1, line_len, line_len - i__1);
} else {
/* This is the first key that we have found. Set UNPRSD */
/* to the part of the line from the start to this key. */
ucase_(line, uline, line_len, (ftnlen)2048);
/* Writing concatenation */
i__2[0] = 1, a__1[0] = " ";
i__2[1] = rtrim_(clkeys + (clidx - 1) * clkeys_len,
clkeys_len), a__1[1] = clkeys + (clidx - 1) *
clkeys_len;
s_cat(hkey, a__1, i__2, &c__2, (ftnlen)2048);
/* Writing concatenation */
i__2[0] = 1, a__1[0] = " ";
i__2[1] = 2048, a__1[1] = uline;
s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2049);
begpos = pos_(ch__1, hkey, &c__1, (ftnlen)2049, rtrim_(hkey, (
ftnlen)2048) + 1);
if (begpos <= 1) {
s_copy(unprsd, " ", unprsd_len, (ftnlen)1);
} else {
s_copy(unprsd, line, unprsd_len, begpos - 1);
}
}
/* Save the current key index in as previous. */
pclidx = clidx;
}
}
/* If we found at least one recognized key, we need to save the last */
/* value. */
if (pclidx != 0) {
/* Set "found any" output flag and "found previous key" flags to */
/* .TRUE. */
*found = TRUE_;
clflag[pclidx - 1] = TRUE_;
/* Check if there was any value following the last key (there was */
/* if the non-blank length of what's left in the line starting */
/* with the last key if greater than the non-blank length of the */
/* last key). */
if (rtrim_(line, line_len) > rtrim_(clkeys + (pclidx - 1) *
clkeys_len, clkeys_len)) {
/* Compute begin position of, extract, left justify and */
/* RTRIM the last value. */
ucase_(line, uline, line_len, (ftnlen)2048);
begpos = pos_(uline, clkeys + (pclidx - 1) * clkeys_len, &c__1, (
ftnlen)2048, rtrim_(clkeys + (pclidx - 1) * clkeys_len,
clkeys_len)) + rtrim_(clkeys + (pclidx - 1) * clkeys_len,
clkeys_len);
s_copy(clvals + (pclidx - 1) * clvals_len, line + (begpos - 1),
clvals_len, line_len - (begpos - 1));
ljust_(clvals + (pclidx - 1) * clvals_len, clvals + (pclidx - 1) *
clvals_len, clvals_len, clvals_len);
s_copy(clvals + (pclidx - 1) * clvals_len, clvals + (pclidx - 1) *
clvals_len, clvals_len, rtrim_(clvals + (pclidx - 1) *
clvals_len, clvals_len));
} else {
/* The key was the last thing on the line. So, it's value is */
/* blank. */
s_copy(clvals + (pclidx - 1) * clvals_len, " ", clvals_len, (
ftnlen)1);
}
}
chkout_("PARCML", (ftnlen)6);
return 0;
} /* parcml_ */
/* $Procedure GETFAT ( Get file architecture and type ) */
/* Subroutine */ int getfat_(char *file, char *arch, char *kertyp, ftnlen
file_len, ftnlen arch_len, ftnlen kertyp_len)
{
/* System generated locals */
integer i__1;
cilist ci__1;
olist o__1;
cllist cl__1;
inlist ioin__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen), f_inqu(inlist *), s_rnge(
char *, integer, char *, integer), f_open(olist *), s_rdue(cilist
*), do_uio(integer *, char *, ftnlen), e_rdue(void), f_clos(
cllist *), s_rsfe(cilist *), do_fio(integer *, char *, ftnlen),
e_rsfe(void);
/* Local variables */
integer unit;
extern /* Subroutine */ int zzddhfnh_(char *, integer *, logical *,
ftnlen), zzddhgsd_(char *, integer *, char *, ftnlen, ftnlen),
zzddhnfo_(integer *, char *, integer *, integer *, integer *,
logical *, ftnlen), zzddhhlu_(integer *, char *, logical *,
integer *, ftnlen);
integer i__;
extern integer cardi_(integer *);
char fname[255];
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen);
integer which;
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen);
logical found, exist;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen),
idw2at_(char *, char *, char *, ftnlen, ftnlen, ftnlen);
integer handle;
extern /* Subroutine */ int dafcls_(integer *);
char filarc[32];
extern /* Subroutine */ int dashof_(integer *);
integer intbff;
logical opened;
extern /* Subroutine */ int dafopr_(char *, integer *, ftnlen);
integer intarc;
extern /* Subroutine */ int dashlu_(integer *, integer *);
char idword[12];
integer intamn, number;
logical diropn, notdas;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), getlun_(integer *), setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen), ssizei_(
integer *, integer *), nextwd_(char *, char *, char *, ftnlen,
ftnlen, ftnlen);
char tmpwrd[12];
extern logical return_(void);
integer myunit, handles[106];
extern /* Subroutine */ int zzckspk_(integer *, char *, ftnlen);
/* Fortran I/O blocks */
static cilist io___19 = { 1, 0, 1, 0, 1 };
/* $ Abstract */
/* Determine the architecture and type of SPICE kernels. */
/* $ 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 */
/* KERNEL */
/* UTILITY */
/* $ Declarations */
/* $ Abstract */
/* Parameter declarations for the DAF/DAS handle manager. */
/* $ 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 */
/* DAF, DAS */
/* $ Keywords */
/* PRIVATE */
/* $ Particulars */
/* This include file contains parameters defining limits and */
/* integer codes that are utilized in the DAF/DAS handle manager */
/* routines. */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 2.5.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 2.4.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 2.3.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 2.2.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 2.1.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 2.0.0, 12-APR-2012 (BVS) */
/* Increased FTSIZE (from 1000 to 5000). */
/* - SPICELIB Version 1.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 1.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 1.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 1.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 1.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 1.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 1.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 1.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 1.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 1.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 1.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 1.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 1.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 1.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 1.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 1.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 1.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 1.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 1.0.1, 17-JUL-2002 */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 1.0.0, 07-NOV-2001 */
/* -& */
/* Unit and file table size parameters. */
/* FTSIZE is the maximum number of files (DAS and DAF) that a */
/* user may have open simultaneously. */
/* RSVUNT is the number of units protected from being locked */
/* to a particular handle by ZZDDHHLU. */
/* SCRUNT is the number of units protected for use by scratch */
/* files. */
/* UTSIZE is the maximum number of logical units this manager */
/* will utilize at one time. */
/* Access method enumeration. These parameters are used to */
/* identify which access method is associated with a particular */
/* handle. They need to be synchronized with the STRAMH array */
/* defined in ZZDDHGSD in the following fashion: */
/* STRAMH ( READ ) = 'READ' */
/* STRAMH ( WRITE ) = 'WRITE' */
/* STRAMH ( SCRTCH ) = 'SCRATCH' */
/* STRAMH ( NEW ) = 'NEW' */
/* These values are used in the file table variable FTAMH. */
/* Binary file format enumeration. These parameters are used to */
/* identify which binary file format is associated with a */
/* particular handle. They need to be synchronized with the STRBFF */
/* array defined in ZZDDHGSD in the following fashion: */
/* STRBFF ( BIGI3E ) = 'BIG-IEEE' */
/* STRBFF ( LTLI3E ) = 'LTL-IEEE' */
/* STRBFF ( VAXGFL ) = 'VAX-GFLT' */
/* STRBFF ( VAXDFL ) = 'VAX-DFLT' */
/* These values are used in the file table variable FTBFF. */
/* Some random string lengths... more documentation required. */
/* For now this will have to suffice. */
/* Architecture enumeration. These parameters are used to identify */
/* which file architecture is associated with a particular handle. */
/* They need to be synchronized with the STRARC array defined in */
/* ZZDDHGSD in the following fashion: */
/* STRARC ( DAF ) = 'DAF' */
/* STRARC ( DAS ) = 'DAS' */
/* These values will be used in the file table variable FTARC. */
/* For the following environments, record length is measured in */
/* characters (bytes) with eight characters per double precision */
/* number. */
/* Environment: Sun, Sun FORTRAN */
/* Source: Sun Fortran Programmer's Guide */
/* Environment: PC, MS FORTRAN */
/* Source: Microsoft Fortran Optimizing Compiler User's Guide */
/* Environment: Macintosh, Language Systems FORTRAN */
/* Source: Language Systems FORTRAN Reference Manual, */
/* Version 1.2, page 12-7 */
/* Environment: PC/Linux, g77 */
/* Source: Determined by experiment. */
/* Environment: PC, Lahey F77 EM/32 Version 4.0 */
/* Source: Lahey F77 EM/32 Language Reference Manual, */
/* page 144 */
/* Environment: HP-UX 9000/750, FORTRAN/9000 Series 700 computers */
/* Source: FORTRAN/9000 Reference-Series 700 Computers, */
/* page 5-110 */
/* Environment: NeXT Mach OS (Black Hardware), */
/* Absoft Fortran Version 3.2 */
/* Source: NAIF Program */
/* The following parameter defines the size of a string used */
/* to store a filenames on this target platform. */
/* The following parameter controls the size of the character record */
/* buffer used to read data from non-native files. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* FILE I The name of a file to be examined. */
/* ARCH O The architecture of the kernel file. */
/* KERTYP O The type of the kernel file. */
/* $ Detailed_Input */
/* FILE is the name of a SPICE kernel file whose architecture */
/* and type are desired. */
/* $ Detailed_Output */
/* ARCH is the file architecture of the SPICE kernel file */
/* specified be FILE. If the architecture cannot be */
/* determined or is not recognized the value '?' is */
/* returned. */
/* Architectures currently recognized are: */
/* DAF - The file is based on the DAF architecture. */
/* DAS - The file is based on the DAS architecture. */
/* XFR - The file is in a SPICE transfer file format. */
/* DEC - The file is an old SPICE decimal text file. */
/* ASC -- An ASCII text file. */
/* KPL -- Kernel Pool File (i.e., a text kernel) */
/* TXT -- An ASCII text file. */
/* TE1 -- Text E-Kernel type 1. */
/* ? - The architecture could not be determined. */
/* This variable must be at least 3 characters long. */
/* KERTYP is the type of the SPICE kernel file. If the type */
/* can not be determined the value '?' is returned. */
/* Kernel file types may be any sequence of at most four */
/* printing characters. NAIF has reserved for its use */
/* types which contain all upper case letters. */
/* A file type of 'PRE' means that the file is a */
/* pre-release file. */
/* This variable may be at most 4 characters long. */
/* $ Parameters */
/* RECL is the record length of a binary kernel file. Each */
/* record must be large enough to hold 128 double */
/* precision numbers. The units in which the record */
/* length must be specified vary from environment to */
/* environment. For example, VAX Fortran requires */
/* record lengths to be specified in longwords, */
/* where two longwords equal one double precision */
/* number. */
/* $ Exceptions */
/* 1) If the filename specified is blank, then the error */
/* SPICE(BLANKFILENAME) is signaled. */
/* 2) If any inquire on the filename specified by FILE fails for */
/* some reason, the error SPICE(INQUIREERROR) is signaled. */
/* 3) If the file specified by FILE does not exist, the error */
/* SPICE(FILENOTFOUND) is signaled. */
/* 4) If the file specified by FILE is already open but not through */
/* SPICE interfaces, the error SPICE(EXTERNALOPEN) is signaled. */
/* 5) If an attempt to open the file specified by FILE fails when */
/* this routine requires that it succeed, the error */
/* SPICE(FILEOPENFAILED) is signaled. */
/* 6) If an attempt to read the file specified by FILE fails when */
/* this routine requires that it succeed, the error */
/* SPICE(FILEREADFAILED) is signaled. */
/* 7) Routines in the call tree of this routine may trap and */
/* signal errors. */
/* 8) If the ID word in a DAF based kernel is NAIF/DAF, then the */
/* algorithm GETFAT uses to distinguish between CK and SPK */
/* kernels may result in an indeterminate KERTYP if the SPK or */
/* CK files have invalid first segments. */
/* $ Files */
/* The SPICE kernel file specified by FILE is examined by this */
/* routine to determine its architecture and type. If the file */
/* named by FILE is not connected to a logical unit or loaded */
/* in the handle manager, this routine will OPEN and CLOSE it. */
/* $ Particulars */
/* This subroutine is a support utility routine that determines the */
/* architecture and type of a SPICE kernel file. */
/* $ Examples */
/* Suppose you wish to write a single routine for loading binary */
/* kernels. You can use this routine to determine the type of the */
/* file and then pass the file to the appropriate low level file */
/* loader to handle the actual loading of the file. */
/* CALL GETFAT ( FILE, ARCH, KERTYP ) */
/* IF ( KERTYP .EQ. 'SPK' ) THEN */
/* CALL SPKLEF ( FILE, HANDLE ) */
/* ELSE IF ( KERTYP .EQ. 'CK' ) THEN */
/* CALL CKLPF ( FILE, HANDLE ) */
/* ELSE IF ( KERTYP .EQ. 'EK' ) THEN */
/* CALL EKLEF ( FILE, HANDLE ) */
/* ELSE */
/* WRITE (*,*) 'The file could not be identified as a known' */
/* WRITE (*,*) 'kernel type. Did you load the wrong file' */
/* WRITE (*,*) 'by mistake?' */
/* END IF */
/* $ Restrictions */
/* 1) In order to properly determine the type of DAF based binary */
/* kernels, the routine requires that their first segments and */
/* the meta data necessary to address them are valid. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* F.S. Turner (JPL) */
/* E.D. Wright (JPL) */
/* $ Version */
/* - SPICELIB Version 4.25.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 4.24.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 4.23.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 4.22.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.21.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 4.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 4.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 4.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 4.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 4.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 4.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 4.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 4.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 4.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 4.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 4.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 4.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 4.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 4.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 4.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 4.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 4.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 4.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 4.0.2, 24-APR-2003 (EDW) */
/* Added MAC-OSX-F77 to the list of platforms */
/* that require READONLY to read write protected */
/* kernels. */
/* - SPICELIB Version 4.0.1, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 4.0.0, 22-AUG-2001 (WLT) (FST) (EDW) */
/* Added code so that the architecture and type of open binary */
/* SPICE kernels can be determined. */
/* Added exception for MACPPC_C (CodeWarrior Mac classic). */
/* Reduced RECL value to 12 to prevent expression of */
/* the fseek bug. */
/* - SPICELIB Version 3.2.0, 06-DEC-1999 (WLT) */
/* The heuristics for distinguishing between CK and SPK have */
/* been enhanced so that the routine is no longer requires */
/* that TICKS in C-kernels be positive or integral. */
/* - SPICELIB Version 3.1.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 3.1.3, 22-SEP-1999 (NJB) */
/* CSPICE environments were added. Some typos were corrected. */
/* - SPICELIB Version 3.1.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 3.1.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 3.1.0, 11-FEB-1999 (FST) */
/* Added an integrality check to Test 3. If LASTDP is not */
/* an integral value, then GETFAT simply returns KERTYP = '?', */
/* since it is of an indeterminate type. */
/* - SPICELIB Version 3.0.0, 07-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 2.0.0, 19-DEC-1995 (KRG) */
/* Added several new features to the subroutine: */
/* - Error handling has been enhanced. */
/* - Several new file architectures have been added. */
/* Removed the mention of 1000 characters as a candidate for the */
/* record length of a file. */
/* Added the exception for a blank filename to the header. The */
/* error is signalled, but it was not listed in the header. */
/* Added IOSTAT values to the appropriate error messages. */
/* Non-printing characters are replaced with blanks in the ID */
/* word when it is read. This deals with the case where a */
/* platform allows a text file to be opened as an unformatted */
/* file and the ID word does not completely fill 8 characters. */
/* - SPICELIB Version 1.4.0, 5-JAN-1995 (HAN) */
/* Removed ENV11 since it is now the same as ENV2. */
/* Removed ENV10 since it is the same as the VAX environment. */
/* - SPICELIB Version 1.3.0, 30-AUG-1994 (HAN) */
/* Added two new environments, DEC Alpha/OpenVMS and */
/* Sun/Solaris, to the source master file. */
/* - SPICELIB Version 1.2.0, 25-MAR-1994 (HAN) */
/* Added two new environments, DEC Alpha/OpenVMS and */
/* Sun/Solaris, to the source master file. */
/* - SPICELIB Version 1.1.0, 25-MAR-1994 (HAN) */
/* Modified master source code file to use READONLY on platforms */
/* that support it. Also, changed some local declaration comment */
/* lines to match the standard NAIF template. */
/* - SPICELIB Version 1.0.0, 24-JUL-1993 (WLT) (HAN) (KRG) */
/* -& */
/* $ Index_Entries */
/* determine the architecture and type of a kernel file */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 4.0.0, 22-AUG-2001 (WLT) (FST) */
/* Added code so that the architecture and type of open binary */
/* SPICE kernels can be determined. This uses the new DAF/DAS */
/* handle manager as well as examination of handles of open DAS */
/* files. Currently the handle manager deals only with DAF */
/* files. This routine should be updated again when the DAS */
/* system is integrated with the handle manager. */
/* Some slight changes were required to support ZZDDHFNH on */
/* the VAX environment. This resulted in the addition of */
/* the logical USEFNH that is set to true in most */
/* environments, and never used again other than to allow */
/* the invocation of the ZZDDHFNH module. */
/* - SPICELIB Version 2.0.0, 19-DEC-1995 (KRG) */
/* Added several new features to the subroutine: */
/* - Error handling has been enhanced. */
/* - Several new file architectures have been added. */
/* Removed the mention of 1000 characters as a candidate for the */
/* record length of a file. It seems unlikely that we will */
/* encounter an environment where 1000 characters of storage is */
/* larger than the storage necessary for 128 double precision */
/* numbers; typically there are 8 characters per double precision */
/* number, yeilding 1024 characters. */
/* Added the exception for a blank filename to the header. The */
/* error is signalled, but it was not listed in the header. */
/* Added IOSTAT values to the appropriate error messages. */
/* Non-printing characters are replaced with blanks in the ID */
/* word when it is read. This deals with the case where a */
/* platform allows a text file to be opened as an unformatted */
/* file and the ID word does not completely fill 8 characters. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Set the length of a SPICE kernel file ID word. */
/* Set minimum and maximum values for the range of ASCII printing */
/* characters. */
/* Local Variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("GETFAT", (ftnlen)6);
}
/* Initialize the temporary storage variables that we use. */
s_copy(idword, " ", (ftnlen)12, (ftnlen)1);
/* If the filename we have is blank, signal an error and return. */
if (s_cmp(file, " ", file_len, (ftnlen)1) == 0) {
setmsg_("The file name is blank.", (ftnlen)23);
sigerr_("SPICE(BLANKFILENAME)", (ftnlen)20);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* See if this is a binary file that is currently open */
/* within the SPICE binary file management subsystem. At */
/* the moment, as far as we know, the file is not opened. */
opened = FALSE_;
zzddhfnh_(file, &handle, &found, file_len);
if (found) {
/* If the file was recognized, we need to get the unit number */
/* associated with it. */
zzddhnfo_(&handle, fname, &intarc, &intbff, &intamn, &found, (ftnlen)
255);
/* Translate the architecture ID to a string and retrieve the */
/* logical unit to use with this file. */
zzddhgsd_("ARCH", &intarc, filarc, (ftnlen)4, (ftnlen)32);
zzddhhlu_(&handle, filarc, &c_false, &number, (ftnlen)32);
opened = TRUE_;
} else {
/* We'll do a bit of inquiring before we try opening anything. */
ioin__1.inerr = 1;
ioin__1.infilen = file_len;
ioin__1.infile = file;
ioin__1.inex = ∃
ioin__1.inopen = &opened;
ioin__1.innum = 0;
ioin__1.innamed = 0;
ioin__1.inname = 0;
ioin__1.inacc = 0;
ioin__1.inseq = 0;
ioin__1.indir = 0;
ioin__1.infmt = 0;
ioin__1.inform = 0;
ioin__1.inunf = 0;
ioin__1.inrecl = 0;
ioin__1.innrec = 0;
ioin__1.inblank = 0;
iostat = f_inqu(&ioin__1);
/* Not too likely, but if the INQUIRE statement fails... */
if (iostat != 0) {
setmsg_("IOSTAT error in INQUIRE statement. IOSTAT = #.", (ftnlen)
46);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(INQUIREERROR)", (ftnlen)19);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* Note: the following two tests MUST be performed in the order */
/* in which they appear, since in some environments files that do */
/* not exist are considered to be open. */
if (! exist) {
setmsg_("The kernel file '#' does not exist.", (ftnlen)35);
errch_("#", file, (ftnlen)1, file_len);
sigerr_("SPICE(FILENOTFOUND)", (ftnlen)19);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* If the file is already open, it may be a DAS file. */
if (opened) {
/* At the moment, the handle manager doesn't manage DAS */
/* handles. As a result we need to treat the case of an open */
/* DAS separately. When the Handle Manager is hooked in with */
/* DAS as well as DAF, we should remove the block below. */
/* =================================================== */
/* DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS */
/* vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv */
/* This file may or may not be a DAS file. Until we */
/* have determined otherwise, we assume it is not */
/* a DAS file. */
notdas = TRUE_;
ioin__1.inerr = 1;
ioin__1.infilen = file_len;
ioin__1.infile = file;
ioin__1.inex = 0;
ioin__1.inopen = 0;
ioin__1.innum = &unit;
ioin__1.innamed = 0;
ioin__1.inname = 0;
ioin__1.inacc = 0;
ioin__1.inseq = 0;
ioin__1.indir = 0;
ioin__1.infmt = 0;
ioin__1.inform = 0;
ioin__1.inunf = 0;
ioin__1.inrecl = 0;
ioin__1.innrec = 0;
ioin__1.inblank = 0;
iostat = f_inqu(&ioin__1);
if (iostat != 0) {
setmsg_("IOSTAT error in INQUIRE statement. IOSTAT = #.", (
ftnlen)46);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(INQUIREERROR)", (ftnlen)19);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* Get the set of handles of open DAS files. We will */
/* translate each of these handles to the associated */
/* logical unit. If the tranlation matches the result */
/* of the inquire, this must be a DAS file and we */
/* can proceed to determine the type. */
ssizei_(&c__100, handles);
dashof_(handles);
which = cardi_(handles);
while(which > 0) {
dashlu_(&handles[(i__1 = which + 5) < 106 && 0 <= i__1 ? i__1
: s_rnge("handles", i__1, "getfat_", (ftnlen)654)], &
myunit);
if (unit == myunit) {
number = myunit;
which = 0;
notdas = FALSE_;
} else {
--which;
}
}
/* If we reach this point and do not have a DAS, there */
/* is no point in going on. The user has opened this */
/* file outside the SPICE system. We shall not attempt */
/* to determine its type. */
if (notdas) {
setmsg_("The file '#' is already open.", (ftnlen)29);
errch_("#", file, (ftnlen)1, file_len);
sigerr_("SPICE(EXTERNALOPEN)", (ftnlen)19);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ */
/* DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS */
/* =================================================== */
}
}
/* Open the file with a record length of RECL (the length of the */
/* DAF and DAS records). We assume, for now, that opening the file as */
/* a direct access file will work. */
diropn = TRUE_;
/* If the file is not already open (probably the case that */
/* happens most frequently) we try opening it for direct access */
/* and see if we can locate the idword. */
if (! opened) {
getlun_(&number);
o__1.oerr = 1;
o__1.ounit = number;
o__1.ofnmlen = file_len;
o__1.ofnm = file;
o__1.orl = 1024;
o__1.osta = "OLD";
o__1.oacc = "DIRECT";
o__1.ofm = 0;
o__1.oblnk = 0;
iostat = f_open(&o__1);
/* If we had trouble opening the file, try opening it as a */
/* sequential file. */
if (iostat != 0) {
diropn = FALSE_;
o__1.oerr = 1;
o__1.ounit = number;
o__1.ofnmlen = file_len;
o__1.ofnm = file;
o__1.orl = 0;
o__1.osta = "OLD";
o__1.oacc = "SEQUENTIAL";
o__1.ofm = 0;
o__1.oblnk = 0;
iostat = f_open(&o__1);
/* If we still have problems opening the file, we don't have a */
/* clue about the file architecture and type. */
if (iostat != 0) {
s_copy(arch, "?", arch_len, (ftnlen)1);
s_copy(kertyp, "?", kertyp_len, (ftnlen)1);
setmsg_("Attempt to open the file '#' failed. IOSTAT = #.", (
ftnlen)48);
errch_("#", file, (ftnlen)1, file_len);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEOPENFAILED)", (ftnlen)21);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
}
}
/* We opened the file successfully, so let's try to read from the */
/* file. We need to be sure to use the correct form of the read */
/* statement, depending on whether the file was opened with direct */
/* acces or sequential access. */
if (diropn) {
io___19.ciunit = number;
iostat = s_rdue(&io___19);
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, tmpwrd, (ftnlen)12);
if (iostat != 0) {
goto L100001;
}
iostat = e_rdue();
L100001:
/* If we couldn't read from the file as a direct access file with */
/* a fixed record length, then try to open the file as a */
/* sequential file and read from it. */
if (iostat != 0) {
if (opened) {
/* Something has gone wrong here. The file was opened */
/* as either a DAF or DAS prior to the call to GETFAT. */
/* We retrieved the unit number maintained by the */
/* underlying binary file management system, but we */
/* were unable to read the file as direct access. */
/* There's nothing we can do but abandon our quest to */
/* determine the type of the file. */
setmsg_("The file '#' is opened as a binary SPICE kernel. B"
"ut it cannot be read using a direct access read. The"
" value of IOSTAT returned by the attempted READ is #"
". ", (ftnlen)157);
errch_("#", file, (ftnlen)1, file_len);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* If we reach this point, the file was opened locally */
/* as a direct access file. We could not read it that */
/* way, so we'll try using a sequential read. However, */
/* we first need to close the file and then reopen it */
/* for sequential reading. */
cl__1.cerr = 0;
cl__1.cunit = number;
cl__1.csta = 0;
f_clos(&cl__1);
o__1.oerr = 1;
o__1.ounit = number;
o__1.ofnmlen = file_len;
o__1.ofnm = file;
o__1.orl = 0;
o__1.osta = "OLD";
o__1.oacc = "SEQUENTIAL";
o__1.ofm = 0;
o__1.oblnk = 0;
iostat = f_open(&o__1);
/* If we could not open the file, we don't have a clue about */
/* the file architecture and type. */
if (iostat != 0) {
s_copy(arch, "?", arch_len, (ftnlen)1);
s_copy(kertyp, "?", kertyp_len, (ftnlen)1);
setmsg_("Attempt to open the file '#' failed. IOSTAT = #.", (
ftnlen)48);
errch_("#", file, (ftnlen)1, file_len);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEOPENFAILED)", (ftnlen)21);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* Try to read from the file. */
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = number;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100002;
}
iostat = do_fio(&c__1, tmpwrd, (ftnlen)12);
if (iostat != 0) {
goto L100002;
}
iostat = e_rsfe();
L100002:
;
}
} else {
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = number;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100003;
}
iostat = do_fio(&c__1, tmpwrd, (ftnlen)12);
if (iostat != 0) {
goto L100003;
}
iostat = e_rsfe();
L100003:
;
}
/* If we had an error while reading, we don't recognize this file. */
if (iostat != 0) {
s_copy(arch, "?", arch_len, (ftnlen)1);
s_copy(kertyp, "?", kertyp_len, (ftnlen)1);
cl__1.cerr = 0;
cl__1.cunit = number;
cl__1.csta = 0;
f_clos(&cl__1);
setmsg_("Attempt to read from file '#' failed. IOSTAT = #.", (ftnlen)
49);
errch_("#", file, (ftnlen)1, file_len);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* Close the file (if we opened it here), as we do not need it */
/* to be open any more. */
if (! opened) {
cl__1.cerr = 0;
cl__1.cunit = number;
cl__1.csta = 0;
f_clos(&cl__1);
}
/* At this point, we have a candidate for an ID word. To avoid */
/* difficulties with Fortran I/O and other things, we will now */
/* replace any non printing ASCII characters with blanks. */
for (i__ = 1; i__ <= 12; ++i__) {
if (*(unsigned char *)&tmpwrd[i__ - 1] < 32 || *(unsigned char *)&
tmpwrd[i__ - 1] > 126) {
*(unsigned char *)&tmpwrd[i__ - 1] = ' ';
}
}
/* Identify the architecture and type, if we can. */
ljust_(tmpwrd, tmpwrd, (ftnlen)12, (ftnlen)12);
ucase_(tmpwrd, tmpwrd, (ftnlen)12, (ftnlen)12);
nextwd_(tmpwrd, idword, tmpwrd, (ftnlen)12, (ftnlen)12, (ftnlen)12);
if (s_cmp(idword, "DAFETF", (ftnlen)12, (ftnlen)6) == 0) {
/* We have a DAF encoded transfer file. */
s_copy(arch, "XFR", arch_len, (ftnlen)3);
s_copy(kertyp, "DAF", kertyp_len, (ftnlen)3);
} else if (s_cmp(idword, "DASETF", (ftnlen)12, (ftnlen)6) == 0) {
/* We have a DAS encoded transfer file. */
s_copy(arch, "XFR", arch_len, (ftnlen)3);
s_copy(kertyp, "DAS", kertyp_len, (ftnlen)3);
} else if (s_cmp(idword, "'NAIF/DAF'", (ftnlen)10, (ftnlen)10) == 0) {
/* We have an old DAF decimal text file. */
s_copy(arch, "DEC", arch_len, (ftnlen)3);
s_copy(kertyp, "DAF", kertyp_len, (ftnlen)3);
} else if (s_cmp(idword, "NAIF/DAS", (ftnlen)8, (ftnlen)8) == 0) {
/* We have a pre release DAS binary file. */
s_copy(arch, "DAS", arch_len, (ftnlen)3);
s_copy(kertyp, "PRE", kertyp_len, (ftnlen)3);
} else {
/* Get the architecture and type from the ID word, if we can. */
idw2at_(idword, arch, kertyp, (ftnlen)8, arch_len, kertyp_len);
}
/* If the architecture is DAF and the type is unknown, '?', then we */
/* have either an SPK file, a CK file, or something we don't */
/* understand. Let's check it out. */
if (s_cmp(arch, "DAF", arch_len, (ftnlen)3) == 0 && s_cmp(kertyp, "?",
kertyp_len, (ftnlen)1) == 0) {
/* We have a DAF file and we do not know what the type is. This */
/* situation can occur for older SPK and CK files, before the ID */
/* word was used to store type information. */
/* We use Bill's (WLT'S) magic heuristics to determine the type */
/* of the file. */
/* Open the file and pass the handle to the private routine */
/* that deals with the dirty work. */
dafopr_(file, &handle, file_len);
zzckspk_(&handle, kertyp, kertyp_len);
dafcls_(&handle);
}
chkout_("GETFAT", (ftnlen)6);
return 0;
} /* getfat_ */
/* $Procedure OUTMSG ( Output Error Messages ) */
/* Subroutine */ int outmsg_(char *list, ftnlen list_len)
{
/* Initialized data */
static char defmsg[80*4] = "Oh, by the way: The SPICELIB error handling"
" actions are USER-TAILORABLE. You " "can choose whether the To"
"olkit aborts or continues when errors occur, which " "error "
"messages to output, and where to send the output. Please read t"
"he ERROR " "\"Required Reading\" file, or see the routines ERRA"
"CT, ERRDEV, and ERRPRT. ";
static logical first = TRUE_;
/* System generated locals */
address a__1[2], a__2[3];
integer i__1, i__2, i__3[2], i__4[3];
char ch__1[38];
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen),
s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char name__[32], line[80];
logical long__;
char lmsg[1840];
logical expl;
char smsg[25], xmsg[80];
integer i__;
logical trace;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
integer depth, index;
extern integer wdcnt_(char *, ftnlen);
extern /* Subroutine */ int expln_(char *, char *, ftnlen, ftnlen);
extern integer rtrim_(char *, ftnlen);
char versn[80], words[9*5];
integer start;
logical short__;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
char device[255];
integer remain;
static char border[80];
extern /* Subroutine */ int getdev_(char *, ftnlen);
logical dfault;
integer length;
extern /* Subroutine */ int trcdep_(integer *);
extern integer lastnb_(char *, ftnlen);
extern /* Subroutine */ int trcnam_(integer *, char *, ftnlen), lparse_(
char *, char *, integer *, integer *, char *, ftnlen, ftnlen,
ftnlen);
extern logical msgsel_(char *, ftnlen);
integer wrdlen;
extern /* Subroutine */ int getlms_(char *, ftnlen), wrline_(char *, char
*, ftnlen, ftnlen), getsms_(char *, ftnlen), suffix_(char *,
integer *, char *, ftnlen, ftnlen);
char tmpmsg[105];
extern /* Subroutine */ int nextwd_(char *, char *, char *, ftnlen,
ftnlen, ftnlen);
integer numwrd;
char upword[9], outwrd[1840];
extern /* Subroutine */ int tkvrsn_(char *, char *, ftnlen, ftnlen);
logical output;
/* $ Abstract */
/* Output error messages. */
/* $ 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 */
/* ERROR */
/* $ Keywords */
/* ERROR */
/* $ 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. */
/* Include File: SPICELIB Error Handling Parameters */
/* errhnd.inc Version 2 18-JUN-1997 (WLT) */
/* The size of the long error message was */
/* reduced from 25*80 to 23*80 so that it */
/* will be accepted by the Microsoft Power Station */
/* FORTRAN compiler which has an upper bound */
/* of 1900 for the length of a character string. */
/* errhnd.inc Version 1 29-JUL-1997 (NJB) */
/* Maximum length of the long error message: */
/* Maximum length of the short error message: */
/* End Include File: SPICELIB Error Handling Parameters */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* LIST I A list of error message types. */
/* FILEN P Maximum length of file name. */
/* NAMLEN P Maximum length of module name. See TRCPKG. */
/* LL P Output line length. */
/* $ Detailed_Input */
/* LIST is a list of error message types. A list is a */
/* character string containing one or more words */
/* from the following list, separated by commas. */
/* SHORT */
/* EXPLAIN */
/* LONG */
/* TRACEBACK */
/* DEFAULT */
/* Each type of error message specified in LIST will */
/* be output when an error is detected, if it is */
/* enabled for output. Note that DEFAULT does */
/* NOT refer to the "default message selection," */
/* but rather to a special message that is output */
/* when the error action is 'DEFAULT'. This message */
/* is a statement referring the user to the error */
/* handling documentation. */
/* Messages are never duplicated in the output; for */
/* instance, supplying a value of LIST such as */
/* 'SHORT, SHORT' */
/* does NOT result in the output of two short */
/* messages. */
/* The words in LIST may appear in mixed case; */
/* for example, the call */
/* CALL OUTMSG ( 'ShOrT' ) */
/* will work. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* FILEN is the maximum device name length that can be */
/* accommodated by this routine. */
/* NAMELN is the maximum length of an individual module name. */
/* LL is the maximum line length for the output message. */
/* If the output message string is very long, it is */
/* displayed over several lines, each of which has a */
/* maximum length of LL characters. */
/* $ Exceptions */
/* 1) This routine detects invalid message types in the argument, */
/* LIST. The short error message in this case is */
/* 'SPICE(INVALIDLISTITEM)' */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine is part of the SPICELIB error handling */
/* mechanism. */
/* This routine outputs the error messages specified in LIST that */
/* have been enabled for output (use the SPICELIB routine ERRPRT */
/* to enable or disable output of specified types of error */
/* messages). A border is written out preceding and following the */
/* messages. Output is directed to the current error output device. */
/* $ Examples */
/* 1) Output the short and long error messages: */
/* C */
/* C Output short and long messages: */
/* C */
/* CALL OUTMSG ( 'SHORT, LONG' ) */
/* $ Restrictions */
/* 1) This routine is intended for use by the SPICELIB error */
/* handling mechanism. SPICELIB users are not expected to */
/* need to call this routine. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* K.R. Gehringer (JPL) */
/* H.A. Neilan (JPL) */
/* M.J. Spencer (JPL) */
/* $ Version */
/* - SPICELIB Version 5.27.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 5.26.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 5.25.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 5.24.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 5.23.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 5.22.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 5.21.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 5.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 5.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 5.18.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 5.17.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 5.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 5.15.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 5.14.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 5.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 5.12.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 5.11.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 5.10.0, 01-MAR-2009 (NJB) */
/* Bug fix: truncation of long words in */
/* output has been corrected. Local parameter */
/* TMPLEN was added and is used in declaration */
/* of TMPMSG. */
/* - SPICELIB Version 5.9.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 5.8.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 5.7.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 5.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 5.5.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 5.4.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 5.3.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 5.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 5.1.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 5.1.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 5.1.3, 24-SEP-1999 (NJB) */
/* CSPICE environments were added. Some typos were corrected. */
/* - SPICELIB Version 5.1.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 5.1.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 5.1.0, 13-JAN-1999 (BVS) */
/* ``errhnd.inc'' file was included. Long and short error */
/* message lengths parameter declarations were deleted. Long */
/* and short error message string sizes were changed to those */
/* declared in ``errhnd.inc''. */
/* - SPICELIB Version 5.0.0, 08-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 4.0.0, 09-MAY-1996 (KRG) */
/* Added the toolkit version to the output error message. */
/* Updated this routine to be consistent with the trace package */
/* revisions. This primarily affects the creation of the */
/* traceback string. */
/* Long error messages are now wrapped on word boundaries when */
/* they are longer than the output line length. Note that this */
/* only happens for long error messages obtained from GETLMS, */
/* and not for the error messages displayed by this subroutine */
/* and other error handling subroutines that write their own */
/* error messages. */
/* - SPICELIB Version 3.0.0, 09-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* for the Silicon Graphics, DEC Alpha-OSF/1, and */
/* NeXT platforms. Also, the previous value of 256 for */
/* Unix platforms was changed to 255. */
/* - SPICELIB Version 2.2.0, 12-OCT-1992 (HAN) */
/* Updated module for multiple environments. Moved the parameter */
/* LL to the Declarations section of the header since it's */
/* environment dependent. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 2.1.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 2.1.0, 15-MAY-1991 (MJS) */
/* Module was updated to include the value of LL for the */
/* Macintosh. */
/* - SPICELIB Version 2.0.0, 28-MAR-1991 (NJB) */
/* Work-around for MS Fortran compiler error under DOS 3.10 */
/* was made. Some substring bounds were simplified using RTRIM. */
/* Updates were made to the header to clarify the text and */
/* improve the header's appearance. The default error message */
/* was slightly de-uglified. */
/* The IBM PC version of this routine now uses an output line */
/* length of 78 characters rather than 80. This prevents */
/* wrapping of the message borders and default error message. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (NJB) */
/* -& */
/* $ Index_Entries */
/* None. */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 5.1.0, 13-JAN-1999 (BVS) */
/* ``errhnd.inc'' file was included. Long and short error */
/* message lengths parameter declarations were deleted. Long */
/* and short error message string size were changed to those */
/* declared in ``errhnd.inc''. */
/* - SPICELIB Version 5.0.0, 08-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 4.0.0, 09-MAY-1996 (KRG) */
/* Added the toolkit version to the output error message. */
/* Updated this routine to be consistent with the trace package */
/* revisions. This primarily affects the creation of the */
/* traceback string. */
/* Long error messages are now wrapped on word boundaries when */
/* they are longer than the output line length. Note that this */
/* only happens for long error messages obtained from GETLMS, */
/* and not for the error messages displayed by this subroutine */
/* and other error handling subroutines that write their own */
/* error messages. */
/* - SPICELIB Version 3.0.0, 9-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* for the Silicon Graphics, DEC Alpha-OSF/1, and */
/* NeXT platforms. Also, the previous value of 256 for */
/* Unix platforms was changed to 255. */
/* - SPICELIB Version 2.2.0, 12-OCT-1992 (HAN) */
/* Updated module for multiple environments. Moved the */
/* parameter LL to the Declarations section of the header since */
/* it's environment dependent. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 2.1.0, 15-MAY-1991 (MJS) */
/* Module was updated to include the value of LL for the */
/* Macintosh. */
/* - SPICELIB Version 2.0.0, 28-MAR-1991 (NJB) */
/* 1) Work-around for MS Fortran compiler error under DOS 3.10 */
/* was made. The compiler did not correctly handle code that */
/* concatenated strings whose bounds involved the intrinsic */
/* MAX function. */
/* 2) Some substring bounds were simplified using RTRIM. */
/* 3) Updates were made to the header to clarify the text and */
/* improve the header's appearance. */
/* 4) Declarations were re-organized. */
/* 5) The default error message was slightly de-uglified. */
/* 6) The IBM PC version of this routine now uses an output line */
/* length of 78 characters rather than 80. This prevents */
/* wrapping of the message borders and default error message. */
/* - Beta Version 1.3.0, 19-JUL-1989 (NJB) */
/* Calls to REMSUB removed; blanking and left-justifying used */
/* instead. This was done because REMSUB handles substring */
/* bounds differently than in previous versions, and no longer */
/* handles all possible inputs as required by this routine. */
/* LJUST, which is used now, is error free. */
/* Also, an instance of .LT. was changed to .LE. The old code */
/* caused a line break one character too soon. A minor bug, but */
/* a bug nonetheless. */
/* Also, two substring bounds were changed to ensure that they */
/* remain greater than zero. */
/* - Beta Version 1.2.0, 16-FEB-1989 (NJB) */
/* Warnings added to discourage use of this routine in */
/* non-error-handling code. Parameters section updated to */
/* describe FILEN and NAMLEN. */
/* Declaration of unused function FAILED removed. */
/* - Beta Version 1.1.0, 06-OCT-1988 (NJB) */
/* Test added to ensure substring upper bound is greater than 0. */
/* REMAIN must be greater than 0 when used as the upper bound */
/* for a substring of NAME. Also, substring upper bound in */
/* WRLINE call is now forced to be greater than 0. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* These parameters are system-independent. */
/* Local variables */
/* Saved variables */
/* Initial Values: */
/* Executable Code: */
/* The first time through, set up the output borders. */
if (first) {
first = FALSE_;
for (i__ = 1; i__ <= 80; ++i__) {
*(unsigned char *)&border[i__ - 1] = '=';
}
}
/* No messages are to be output which are not specified */
/* in LIST: */
short__ = FALSE_;
expl = FALSE_;
long__ = FALSE_;
trace = FALSE_;
dfault = FALSE_;
/* We parse the list of message types, and set local flags */
/* indicating which ones are to be output. If we find */
/* a word we don't recognize in the list, we signal an error */
/* and continue parsing the list. */
lparse_(list, ",", &c__5, &numwrd, words, list_len, (ftnlen)1, (ftnlen)9);
i__1 = numwrd;
for (i__ = 1; i__ <= i__1; ++i__) {
ucase_(words + ((i__2 = i__ - 1) < 5 && 0 <= i__2 ? i__2 : s_rnge(
"words", i__2, "outmsg_", (ftnlen)613)) * 9, upword, (ftnlen)
9, (ftnlen)9);
if (s_cmp(upword, "SHORT", (ftnlen)9, (ftnlen)5) == 0) {
short__ = TRUE_;
} else if (s_cmp(upword, "EXPLAIN", (ftnlen)9, (ftnlen)7) == 0) {
expl = TRUE_;
} else if (s_cmp(upword, "LONG", (ftnlen)9, (ftnlen)4) == 0) {
long__ = TRUE_;
} else if (s_cmp(upword, "TRACEBACK", (ftnlen)9, (ftnlen)9) == 0) {
trace = TRUE_;
} else if (s_cmp(upword, "DEFAULT", (ftnlen)9, (ftnlen)7) == 0) {
dfault = TRUE_;
} else {
/* Unrecognized word! This is an error... */
/* We have a special case on our hands; this routine */
/* is itself called by SIGERR, so a recursion error will */
/* result if this routine calls SIGERR. So we output */
/* the error message directly: */
getdev_(device, (ftnlen)255);
wrline_(device, "SPICE(INVALIDLISTITEM)", (ftnlen)255, (ftnlen)22)
;
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
wrline_(device, "OUTMSG: An invalid message type was specified "
"in the type list. ", (ftnlen)255, (ftnlen)65);
/* Writing concatenation */
i__3[0] = 29, a__1[0] = "The invalid message type was ";
i__3[1] = 9, a__1[1] = words + ((i__2 = i__ - 1) < 5 && 0 <= i__2
? i__2 : s_rnge("words", i__2, "outmsg_", (ftnlen)650)) *
9;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)38);
wrline_(device, ch__1, (ftnlen)255, (ftnlen)38);
}
}
/* LIST has been parsed. */
/* Now, we output those error messages that were specified by LIST */
/* and which belong to the set of messages selected for output. */
/* We get the default error output device: */
getdev_(device, (ftnlen)255);
output = short__ && msgsel_("SHORT", (ftnlen)5) || expl && msgsel_("EXPL"
"AIN", (ftnlen)7) || long__ && msgsel_("LONG", (ftnlen)4) || trace
&& msgsel_("TRACEBACK", (ftnlen)9) || dfault && msgsel_("DEFAULT",
(ftnlen)7) && s_cmp(device, "NULL", (ftnlen)255, (ftnlen)4) != 0;
/* We go ahead and output those messages that have been specified */
/* in the list and also are enabled for output. The order of the */
/* cases below IS significant; the order in which the messages */
/* appear in the output depends on it. */
/* If there's nothing to output, we can leave now. */
if (! output) {
return 0;
}
/* Write the starting border: skip a line, write the border, */
/* skip a line. */
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
wrline_(device, border, (ftnlen)255, (ftnlen)80);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
/* Output the toolkit version and skip a line. */
tkvrsn_("TOOLKIT", versn, (ftnlen)7, (ftnlen)80);
/* Writing concatenation */
i__3[0] = 17, a__1[0] = "Toolkit version: ";
i__3[1] = 80, a__1[1] = versn;
s_cat(line, a__1, i__3, &c__2, (ftnlen)80);
wrline_(device, line, (ftnlen)255, (ftnlen)80);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
/* Next, we output the messages specified in the list */
/* that have been enabled. */
/* We start with the short message and its accompanying */
/* explanation. If both are to be output, they are */
/* concatenated into a single message. */
if (short__ && msgsel_("SHORT", (ftnlen)5) && (expl && msgsel_("EXPLAIN",
(ftnlen)7))) {
/* Extract the short message from global storage; then get */
/* the corresponding explanation. */
getsms_(smsg, (ftnlen)25);
expln_(smsg, xmsg, (ftnlen)25, (ftnlen)80);
/* Writing concatenation */
i__4[0] = rtrim_(smsg, (ftnlen)25), a__2[0] = smsg;
i__4[1] = 4, a__2[1] = " -- ";
i__4[2] = 80, a__2[2] = xmsg;
s_cat(tmpmsg, a__2, i__4, &c__3, (ftnlen)105);
wrline_(device, tmpmsg, (ftnlen)255, (ftnlen)105);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
} else if (short__ && msgsel_("SHORT", (ftnlen)5)) {
/* Output the short error message without the explanation. */
getsms_(smsg, (ftnlen)25);
wrline_(device, smsg, (ftnlen)255, (ftnlen)25);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
} else if (expl && msgsel_("EXPLAIN", (ftnlen)7)) {
/* Obtain the explanatory text for the short error */
/* message and output it: */
getsms_(smsg, (ftnlen)25);
expln_(smsg, xmsg, (ftnlen)25, (ftnlen)80);
wrline_(device, xmsg, (ftnlen)255, (ftnlen)80);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
if (long__ && msgsel_("LONG", (ftnlen)4)) {
/* Extract the long message from global storage and */
/* output it: */
getlms_(lmsg, (ftnlen)1840);
/* Get the number of words in the error message. */
numwrd = wdcnt_(lmsg, (ftnlen)1840);
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
start = 1;
/* Format the words into output lines and display them as */
/* needed. */
i__1 = numwrd;
for (i__ = 1; i__ <= i__1; ++i__) {
nextwd_(lmsg, outwrd, lmsg, (ftnlen)1840, (ftnlen)1840, (ftnlen)
1840);
wrdlen = rtrim_(outwrd, (ftnlen)1840);
if (start + wrdlen <= 80) {
s_copy(line + (start - 1), outwrd, 80 - (start - 1), (ftnlen)
1840);
start = start + wrdlen + 1;
} else {
if (wrdlen <= 80) {
/* We had a short word, so just write the line and */
/* continue. */
wrline_(device, line, (ftnlen)255, (ftnlen)80);
start = wrdlen + 2;
s_copy(line, outwrd, (ftnlen)80, (ftnlen)1840);
} else {
/* We got a very long word here, so we break it up and */
/* write it out. We fit as much of it as we an into line */
/* as possible before writing it. */
/* Get the remaining space. If START is > 1 we have at */
/* least one word already in the line, including it's */
/* trailing space, otherwise the line is blank. If line */
/* is empty, we have all of the space available. */
if (start > 1) {
remain = 80 - start;
} else {
remain = 80;
}
/* Now we stuff bits of the word into the output line */
/* until we're done, i.e., until we have a word part */
/* that is less than the output length. First, we */
/* check to see if there is a "significant" amount of */
/* room left in the current output line. If not, we */
/* write it and then begin stuffing the long word into */
/* output lines. */
if (remain < 10) {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
remain = 80;
start = 1;
}
/* Stuff the word a chunk at a time into output lines */
/* and write them. After writing a line, we clear the */
/* part of the long word that we just wrote, left */
/* justifying the remaining part before proceeding. */
while(wrdlen > 80) {
s_copy(line + (start - 1), outwrd, 80 - (start - 1),
remain);
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(outwrd, " ", remain, (ftnlen)1);
ljust_(outwrd, outwrd, (ftnlen)1840, (ftnlen)1840);
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
wrdlen -= remain;
remain = 80;
start = 1;
}
/* If we had a part of the long word left, get set up to */
/* append more words from the error message to the output */
/* line. If we finished the word, WRDLEN .EQ. 0, then */
/* START and LINE have already been initialized. */
if (wrdlen > 0) {
start = wrdlen + 2;
s_copy(line, outwrd, (ftnlen)80, (ftnlen)1840);
}
}
}
}
/* We may need to write the remaining part of a line. */
if (s_cmp(line, " ", (ftnlen)80, (ftnlen)1) != 0) {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
}
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
if (trace && msgsel_("TRACEBACK", (ftnlen)9)) {
/* Extract the traceback from global storage and */
/* output it: */
trcdep_(&depth);
if (depth > 0) {
/* We know we'll be outputting some trace information. */
/* So, write a line telling the reader what's coming. */
wrline_(device, "A traceback follows. The name of the highest l"
"evel module is first.", (ftnlen)255, (ftnlen)68);
/* While there are more names in the traceback */
/* representation, we stuff them into output lines and */
/* write the lines out when they are full. */
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
remain = 80;
i__1 = depth;
for (index = 1; index <= i__1; ++index) {
/* For each module name in the traceback representation, */
/* retrieve module name and stuff it into one or more */
/* lines for output. */
/* Get a name and add the call order sign. We */
/* indicate calling order by a ' --> ' delimiter; e.g. */
/* "A calls B" is indicated by 'A --> B'. */
trcnam_(&index, name__, (ftnlen)32);
length = lastnb_(name__, (ftnlen)32);
/* If it's the first name, just put it into the output */
/* line, otherwise, add the call order sign and put the */
/* name into the output line. */
if (index == 1) {
suffix_(name__, &c__0, line, (ftnlen)32, (ftnlen)80);
remain -= length;
} else {
/* Add the calling order indicator, if it will fit. */
/* If not, write the line and put the indicator as */
/* the first thing on the next line. */
if (remain >= 4) {
suffix_("-->", &c__1, line, (ftnlen)3, (ftnlen)80);
remain += -4;
} else {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(line, "-->", (ftnlen)80, (ftnlen)3);
remain = 77;
}
/* The name fits or it doesn't. If it does, just add */
/* it, if it doesn't, write it, then make the name */
/* the first thing on the next line. */
if (remain >= length) {
suffix_(name__, &c__1, line, (ftnlen)32, (ftnlen)80);
remain = remain - length - 1;
} else {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(line, name__, (ftnlen)80, (ftnlen)32);
remain = 80 - length;
}
}
}
/* At this point, no more names are left in the */
/* trace representation. LINE may still contain */
/* names, or part of a long name. If it does, */
/* we now write it out. */
if (s_cmp(line, " ", (ftnlen)80, (ftnlen)1) != 0) {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
}
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
/* At this point, either we have output the trace */
/* representation, or the trace representation was */
/* empty. */
}
if (dfault && msgsel_("DEFAULT", (ftnlen)7)) {
/* Output the default message: */
for (i__ = 1; i__ <= 4; ++i__) {
wrline_(device, defmsg + ((i__1 = i__ - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("defmsg", i__1, "outmsg_", (ftnlen)971)) *
80, (ftnlen)255, (ftnlen)80);
}
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
/* At this point, we've output all of the enabled messages */
/* that were specified in LIST. At least one message that */
/* was specified was enabled. */
/* Write the ending border out: */
wrline_(device, border, (ftnlen)255, (ftnlen)80);
return 0;
} /* outmsg_ */
/* $Procedure PARCML ( Parse command line) */
/* Subroutine */ int parcml_(char *line, integer *maxkey, char *clkeys,
logical *clflag, char *clvals, logical *found, ftnlen line_len,
ftnlen clkeys_len, ftnlen clvals_len)
{
/* System generated locals */
address a__1[2];
integer i__1, i__2[2];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static char hkey[1024];
static integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen);
static char hline[1024];
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
static integer clidx;
static char uline[1024], lngwd[1024];
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
static integer begpos, pclidx;
static char hlngwd[1024];
static integer endpos;
extern /* Subroutine */ int chkout_(char *, ftnlen), nextwd_(char *, char
*, char *, ftnlen, ftnlen, ftnlen);
extern logical return_(void);
extern integer pos_(char *, char *, integer *, ftnlen, ftnlen);
/* $ Abstract */
/* This routine parses "command-line" looking line and returns */
/* values of requested keys. */
/* $ 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 */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* LINE I Input line. */
/* MAXKEY I Number of keys. */
/* CLKEYS I Keys. */
/* CLFLAG O "Key-found" flags. */
/* CLVALS O Key values. */
/* FOUND O Flag indicating that at least one key was found. */
/* $ Detailed_Input */
/* LINE Input line in a format "-key value -key value ..." */
/* MAXKEY Total number of keys to look for. */
/* CLKEYS Keys to look for; uppercased. */
/* $ Detailed_Output */
/* CLFLAG Flags set TRUE if corresponding key was found. */
/* CLVALS Values key; if key wasn't found, value set to */
/* blank string. */
/* FOUND .TRUE. if at least one key was found. */
/* Otherwise -- .FALSE. */
/* $ Parameters */
/* TBD. */
/* $ Exceptions */
/* TBD */
/* $ Files */
/* None. */
/* $ Particulars */
/* TBD */
/* $ Examples */
/* Let CLKEYS be */
/* CLKEYS(1) = '-SETUP' */
/* CLKEYS(2) = '-TO' */
/* CLKEYS(3) = '-FROM' */
/* CLKEYS(4) = '-HELP' */
/* then: */
/* line '-setup my.file -from utc -to sclk' */
/* will be parsed as */
/* CLFLAG(1) = .TRUE. CLVALS(1) = 'my.file' */
/* CLFLAG(2) = .TRUE. CLVALS(2) = 'utc' */
/* CLFLAG(3) = .TRUE. CLVALS(3) = 'sclk' */
/* CLFLAG(4) = .FALSE. CLVALS(4) = ' ' */
/* FOUND = .TRUE. */
/* line '-setup my.file -setup your.file' */
/* will be parsed as */
/* CLFLAG(1) = .TRUE. CLVALS(1) = 'your.file' */
/* CLFLAG(2) = .FALSE. CLVALS(2) = ' ' */
/* CLFLAG(3) = .FALSE. CLVALS(3) = ' ' */
/* CLFLAG(4) = .FALSE. CLVALS(4) = ' ' */
/* FOUND = .TRUE. */
/* line '-setup my.file -SeTuP your.file' */
/* will be parsed as */
/* CLFLAG(1) = .TRUE. CLVALS(1) = 'your.file' */
/* CLFLAG(2) = .FALSE. CLVALS(2) = ' ' */
/* CLFLAG(3) = .FALSE. CLVALS(3) = ' ' */
/* CLFLAG(4) = .FALSE. CLVALS(4) = ' ' */
/* FOUND = .TRUE. */
/* line '-help' */
/* will be parsed as */
/* CLFLAG(1) = .FALSE. CLVALS(1) = ' ' */
/* CLFLAG(2) = .FALSE. CLVALS(2) = ' ' */
/* CLFLAG(3) = .FALSE. CLVALS(3) = ' ' */
/* CLFLAG(4) = .TRUE. CLVALS(4) = ' ' */
/* FOUND = .TRUE. */
/* and so on. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - Alpha Version 1.0.0, 12-SEP-2008 (BVS) */
/* -& */
/* Save everything to prevent potential memory problems in f2c'ed */
/* version. */
/* SPICELIB functions. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("PARCML", (ftnlen)6);
}
/* Command line parse loop. Set initial values to blanks. */
i__1 = *maxkey;
for (i__ = 1; i__ <= i__1; ++i__) {
clflag[i__ - 1] = FALSE_;
s_copy(clvals + (i__ - 1) * clvals_len, " ", clvals_len, (ftnlen)1);
}
*found = FALSE_;
s_copy(hline, line, (ftnlen)1024, line_len);
pclidx = 0;
clidx = 0;
while(s_cmp(hline, " ", (ftnlen)1024, (ftnlen)1) != 0) {
/* Get next word, uppercase it. */
nextwd_(hline, lngwd, hline, (ftnlen)1024, (ftnlen)1024, (ftnlen)1024)
;
ucase_(lngwd, hlngwd, (ftnlen)1024, (ftnlen)1024);
clidx = isrchc_(hlngwd, maxkey, clkeys, (ftnlen)1024, clkeys_len);
/* Is the token that we found a command line key? */
if (clidx != 0) {
/* Is it the first key that we have found? */
if (pclidx != 0) {
/* It's not. Save value of the previous key. Compute begin */
/* and end position of substring that contains this */
/* value. */
ucase_(line, uline, line_len, (ftnlen)1024);
begpos = pos_(uline, clkeys + (pclidx - 1) * clkeys_len, &
c__1, (ftnlen)1024, rtrim_(clkeys + (pclidx - 1) *
clkeys_len, clkeys_len)) + rtrim_(clkeys + (pclidx -
1) * clkeys_len, clkeys_len);
/* Writing concatenation */
i__2[0] = 1, a__1[0] = " ";
i__2[1] = rtrim_(clkeys + (clidx - 1) * clkeys_len,
clkeys_len), a__1[1] = clkeys + (clidx - 1) *
clkeys_len;
s_cat(hkey, a__1, i__2, &c__2, (ftnlen)1024);
endpos = pos_(uline, hkey, &begpos, (ftnlen)1024, rtrim_(hkey,
(ftnlen)1024) + 1);
/* Extract the value, left-justify and RTRIM it. Set */
/* "value present" flag to .TRUE. */
s_copy(clvals + (pclidx - 1) * clvals_len, line + (begpos - 1)
, clvals_len, endpos - (begpos - 1));
ljust_(clvals + (pclidx - 1) * clvals_len, clvals + (pclidx -
1) * clvals_len, clvals_len, clvals_len);
s_copy(clvals + (pclidx - 1) * clvals_len, clvals + (pclidx -
1) * clvals_len, clvals_len, rtrim_(clvals + (pclidx
- 1) * clvals_len, clvals_len));
clflag[pclidx - 1] = TRUE_;
/* Check whether we already parsed the whole line. */
if (s_cmp(hline, " ", (ftnlen)1024, (ftnlen)1) != 0) {
/* We are not at the end of the command line. There is */
/* more stuff to parse and we put this stuff to */
/* the HLINE. */
i__1 = endpos + 1 + rtrim_(clkeys + (clidx - 1) *
clkeys_len, clkeys_len) - 1;
s_copy(hline, line + i__1, (ftnlen)1024, line_len - i__1);
}
/* Now reset our line and previous index. */
i__1 = endpos;
s_copy(line, line + i__1, line_len, line_len - i__1);
}
/* Save current key index in as previous. */
pclidx = clidx;
}
}
/* We need to save the last value. */
if (pclidx != 0) {
*found = TRUE_;
/* Save the last value. */
clflag[pclidx - 1] = TRUE_;
if (rtrim_(line, line_len) > rtrim_(clkeys + (pclidx - 1) *
clkeys_len, clkeys_len)) {
/* Compute begin position of, extract, left justify and */
/* RTRIM the last value. */
ucase_(line, uline, line_len, (ftnlen)1024);
begpos = pos_(uline, clkeys + (pclidx - 1) * clkeys_len, &c__1, (
ftnlen)1024, rtrim_(clkeys + (pclidx - 1) * clkeys_len,
clkeys_len)) + rtrim_(clkeys + (pclidx - 1) * clkeys_len,
clkeys_len);
s_copy(clvals + (pclidx - 1) * clvals_len, line + (begpos - 1),
clvals_len, line_len - (begpos - 1));
ljust_(clvals + (pclidx - 1) * clvals_len, clvals + (pclidx - 1) *
clvals_len, clvals_len, clvals_len);
s_copy(clvals + (pclidx - 1) * clvals_len, clvals + (pclidx - 1) *
clvals_len, clvals_len, rtrim_(clvals + (pclidx - 1) *
clvals_len, clvals_len));
} else {
/* The key is the last thing on the line. So, it's value */
/* is blank. */
s_copy(clvals + (pclidx - 1) * clvals_len, " ", clvals_len, (
ftnlen)1);
}
}
chkout_("PARCML", (ftnlen)6);
return 0;
} /* parcml_ */
/* $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_ */
/* Subroutine */ int shosym_(char *templt, ftnlen templt_len)
{
/* System generated locals */
integer i__1, i__2, i__3;
/* 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 name__[32], line[132];
integer ncol, item[3];
logical tran;
integer size[3];
char rest[132];
integer i__, n, r__, space[3];
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen),
repmc_(char *, char *, char *, char *, ftnlen, ftnlen, ftnlen,
ftnlen);
char value[2000];
integer width[3];
extern /* Subroutine */ int stran_(char *, char *, logical *, ftnlen,
ftnlen);
extern integer rtrim_(char *, ftnlen);
logical justr[3];
integer lmarge, pagewd;
char spcial[1*3];
extern /* Subroutine */ int pagscn_(char *, ftnlen);
char margin[32], messge[132];
extern /* Subroutine */ int pagset_(char *, integer *, ftnlen), tabrpt_(
integer *, integer *, integer *, integer *, logical *, logical *,
char *, integer *, integer *, U_fp, ftnlen);
char myline[132];
extern /* Subroutine */ int pagrst_(void), nspmrg_(char *, ftnlen),
symget_(char *, char *, ftnlen, ftnlen);
char frstwd[32];
extern /* Subroutine */ int nspglr_(integer *, integer *), nextwd_(char *,
char *, char *, ftnlen, ftnlen, ftnlen), sympat_(char *, ftnlen),
nspwln_(char *, ftnlen);
extern /* Subroutine */ int retsym_();
logical presrv[3];
extern /* Subroutine */ int setsym_(char *, char *, char *, ftnlen,
ftnlen, ftnlen);
char def[2000];
extern /* Subroutine */ int nicepr_1__(char *, char *, S_fp, ftnlen,
ftnlen);
r__ = rtrim_(templt, templt_len);
sympat_(templt, r__);
symget_(name__, def, (ftnlen)32, (ftnlen)2000);
nspmrg_(margin, (ftnlen)32);
if (s_cmp(name__, " ", (ftnlen)32, (ftnlen)1) == 0) {
s_copy(messge, "There are no symbols that match the template \"#\".",
(ftnlen)132, (ftnlen)49);
repmc_(messge, "#", templt, messge, (ftnlen)132, (ftnlen)1, r__, (
ftnlen)132);
nicepr_1__(messge, margin, (S_fp)nspwln_, (ftnlen)132, (ftnlen)32);
return 0;
}
/* If still here there are some matching symbols. Set up the */
/* standard defaults. */
s_copy(line, "=========================================================="
"================================================================"
"==============================================", (ftnlen)132, (
ftnlen)168);
presrv[0] = TRUE_;
presrv[1] = TRUE_;
presrv[2] = TRUE_;
lmarge = 1;
space[0] = 2;
space[1] = 2;
space[2] = 2;
*(unsigned char *)&spcial[0] = ' ';
*(unsigned char *)&spcial[1] = ' ';
*(unsigned char *)&spcial[2] = ' ';
justr[0] = FALSE_;
justr[1] = FALSE_;
justr[2] = FALSE_;
/* Get the width of the page and based upon that determine */
/* the basic table style that will be used to display the */
/* symbol definition. */
nspglr_(&n, &pagewd);
width[0] = 14;
width[1] = 30;
width[2] = 30;
size[0] = 1;
size[1] = 1;
size[2] = 1;
item[0] = 1;
item[1] = 2;
item[2] = 3;
ncol = 3;
/* Adjust all of the columns */
i__1 = ncol;
for (i__ = 1; i__ <= i__1; ++i__) {
width[(i__2 = i__ - 1) < 3 && 0 <= i__2 ? i__2 : s_rnge("width", i__2,
"shosym_", (ftnlen)156)] = width[(i__3 = i__ - 1) < 3 && 0 <=
i__3 ? i__3 : s_rnge("width", i__3, "shosym_", (ftnlen)156)]
* pagewd / 80;
}
pagewd = 0;
i__1 = ncol;
for (i__ = 1; i__ <= i__1; ++i__) {
pagewd = width[(i__2 = i__ - 1) < 3 && 0 <= i__2 ? i__2 : s_rnge(
"width", i__2, "shosym_", (ftnlen)162)] + space[(i__3 = i__ -
1) < 3 && 0 <= i__3 ? i__3 : s_rnge("space", i__3, "shosym_",
(ftnlen)162)] + pagewd;
}
pagewd -= space[(i__1 = ncol - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge("space"
, i__1, "shosym_", (ftnlen)165)];
nspwln_(" ", (ftnlen)1);
nspwln_("Symbols Matching Request: ", (ftnlen)26);
nspwln_(" ", (ftnlen)1);
pagrst_();
pagset_("PAGEWIDTH", &pagewd, (ftnlen)9);
pagscn_("BODY", (ftnlen)4);
setsym_("Symbol Name", "Definition", "Expanded Value", (ftnlen)11, (
ftnlen)10, (ftnlen)14);
tabrpt_(&ncol, item, size, width, justr, presrv, spcial, &lmarge, space, (
U_fp)retsym_, (ftnlen)1);
s_copy(myline, line, (ftnlen)132, pagewd);
nspwln_(myline, (ftnlen)132);
while(s_cmp(name__, " ", (ftnlen)32, (ftnlen)1) != 0) {
/* Expand this symbol until there's nothing left to do. */
s_copy(value, def, (ftnlen)2000, (ftnlen)2000);
tran = TRUE_;
while(tran) {
nextwd_(def, frstwd, rest, (ftnlen)2000, (ftnlen)32, (ftnlen)132);
ucase_(frstwd, frstwd, (ftnlen)32, (ftnlen)32);
if (s_cmp(frstwd, "DEFINE", (ftnlen)32, (ftnlen)6) != 0 && s_cmp(
frstwd, "UNDEFINE", (ftnlen)32, (ftnlen)8) != 0) {
stran_(value, value, &tran, (ftnlen)2000, (ftnlen)2000);
} else {
tran = FALSE_;
}
}
setsym_(name__, def, value, (ftnlen)32, (ftnlen)2000, (ftnlen)2000);
tabrpt_(&ncol, item, size, width, justr, presrv, spcial, &lmarge,
space, (U_fp)retsym_, (ftnlen)1);
symget_(name__, def, (ftnlen)32, (ftnlen)2000);
}
nspwln_(" ", (ftnlen)1);
return 0;
} /* shosym_ */
/* $Procedure LDKLST ( Loads Kernels Listed In a String) */
/* Subroutine */ int ldklst_(char *klist, ftnlen klist_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
static char hname[1024];
extern /* Subroutine */ int chkin_(char *, ftnlen);
static char hline[5120];
extern /* Subroutine */ int nextwd_(char *, char *, char *, ftnlen,
ftnlen, ftnlen), furnsh_(char *, ftnlen), chkout_(char *, ftnlen);
/* $ Abstract */
/* Load kernels listed in a 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. */
/* $ Required_Reading */
/* FRMDIFF User's Guide. */
/* $ Keywords */
/* TBD. */
/* $ Declarations */
/* $ Abstract */
/* Include Section: FRMDIFF Global 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. */
/* $ Author_and_Institution */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - Version 1.0.0, 09-DEC-2008 (BVS). */
/* -& */
/* Program name and version. */
/* Command line keys. */
/* Command line key values. */
/* Max and min number orientations that the program can handle. */
/* Default number orientations. */
/* Maximum number of IDs in a CK or a binary PCK file */
/* Line size parameters. */
/* Version, help, usage and header display parameters. */
/* DAF descriptor size and component counts. */
/* Cell lower boundary. */
/* Maximum allowed number of coverage windows. */
/* Smallest allowed step. */
/* Fraction of step to be used as pad at the end of intervals. */
/* End of FRMDIFF parameters. */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* KLIST I Kernel list. */
/* $ Detailed_Input */
/* KLIST is a string containing space-delimited list of */
/* kernels names. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* See include file. */
/* $ Exceptions */
/* 1) If FURNSH cannot load a kernel, it or routines in its calling */
/* tree signal an error. */
/* $ Files */
/* Each of the files listed in the input string is loaded using */
/* FURNSH. */
/* $ Particulars */
/* This routine extracts individual kernels names from the input */
/* space-delimited list and load each kernel using FURNSH. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* Each word in the input string must be a name of an existing file. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - Version 1.0.0, 30-JUN-2008 (BVS). */
/* -& */
/* Local variables. */
/* HLINE is declared 5*LINSIZ to accommodate a string produced */
/* by concatenation of up to 5 strings with LINSIZ length. */
/* HNAME is declared LINSIZ because a individual file name cannot be */
/* longer than LINSIZ. */
/* Save everything to prevent potential memory problems in f2c'ed */
/* version. */
/* Check in. */
chkin_("LDKLST", (ftnlen)6);
/* Load kernel one by one in a loop. */
s_copy(hline, klist, (ftnlen)5120, klist_len);
while(s_cmp(hline, " ", (ftnlen)5120, (ftnlen)1) != 0) {
nextwd_(hline, hname, hline, (ftnlen)5120, (ftnlen)1024, (ftnlen)5120)
;
furnsh_(hname, (ftnlen)1024);
}
/* Check out. */
chkout_("LDKLST", (ftnlen)6);
return 0;
} /* ldklst_ */
