/* Subroutine */ int writit_(char *line, ftnlen line_len)
{
extern /* Subroutine */ int writln_(char *, integer *, ftnlen);
writln_(line, &c__6, line_len);
return 0;
} /* writit_ */
/* $Procedure GETOPT ( Get an option from a menu ) */
/* Subroutine */ int getopt_(char *title, integer *nopt, char *optnam, char *
opttxt, integer *option, ftnlen title_len, ftnlen optnam_len, ftnlen
opttxt_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
logical done;
char line[80];
integer iopt, i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen), repmc_(char *, char *, char *, char *, ftnlen,
ftnlen, ftnlen, ftnlen);
logical okequ;
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
char prmpt[80];
extern logical failed_(void);
logical ok, okdigi;
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
logical okalph;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
extern logical return_(void);
extern /* Subroutine */ int writln_(char *, integer *, ftnlen), prompt_(
char *, char *, ftnlen, ftnlen);
char msg[80];
/* $ Abstract */
/* Display a list of options in a standard menu format and get */
/* an option from a user returning the corresponding index of */
/* the option selected. */
/* $ 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 */
/* -------- --- -------------------------------------------------- */
/* TITLE I Title for the menu. */
/* NOPT I Number of options available. */
/* OPTNAM I Names for the options. */
/* OPTTXT I Brief text describing an option. */
/* OPTVAL I The value returned when its option is selected. */
/* OPTION O The number of the option selected. */
/* $ Detailed_Input */
/* TITLE Title for the option menu. */
/* NOPT The number of menu options to be displayed. */
/* OPTNAM A list of single character names for the menu options. */
/* These are the names used to select an option. The names */
/* must each be a single alphanumeric character. All names */
/* must be upper case if they are characters. */
/* If the option names is a period, '.', then a blank line */
/* is to be displayed at that position in the menu list. */
/* OPTTXT A list of character strings which contain brief */
/* descriptions for each of the menu options. These */
/* character strings should be kept relatively short. */
/* Please note that the lengths of the option names, OPTNAM, and */
/* the descriptive text for each option, OPTTXT, should be kept */
/* reasonable, they both need to fit on the same output line with */
/* a width of 80 characters. 13 characters out of the 80 available */
/* are used for spacing and menu presentation, so there are 67 */
/* characters available for the option name and the descriptive text */
/* combined. */
/* $ Detailed_Output */
/* OPTION The index of the option selected from the menu. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the number of options, NOPT, is not > 0, the error */
/* SPICE(INVALIDARGUMENT) will be signalled. */
/* 2) If the option names are not all upper case alphanumeric */
/* characters, the error SPICE(BADOPTIONNAME) will be signalled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine will display a menu of options in a standardized */
/* format, promting for the selection of one of the listed options. */
/* This routine will not return to the caller until one of the */
/* supplied options has been selected or an error occurs. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* This routine makes explicit use fo the ASCII character sequence. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* $ Version */
/* - Beta Version 4.2.0, 18-DEC-2010 (EDW) */
/* Declared PROMPT as EXTERNAL. Eliminated unneeded Revisions */
/* section. */
/* - Beta Version 4.1.0, 05-JUL-1995 (KRG) */
/* Removed the initial blank line that was printed before the */
/* title of the menu. The calling program should determine the */
/* whitespace requirements for the appearance of the menu */
/* displayed by this routine. */
/* - Beta Version 4.0.0, 25-APR-1994 (KRG) */
/* Modified the routine to output the index into the list of menu */
/* options rather than a character string representing the option */
/* selected. Also removed several calling arguments that were not */
/* needed anymore. */
/* Added the capability of inserting a blank line into the menu. */
/* This is done by placing a period, '.', into the option name */
/* location where the blank line lshould occur. */
/* Added the missing $ Index_Entries section to the header. */
/* Clarified a few of the comments in the header. */
/* - Beta Version 3.0.0, 03-SEP-1992 (KRG) */
/* -& */
/* $ Index_Entries */
/* display a menu and get a user's selection */
/* -& */
/* SPICELIB functions */
/* Local Parameters */
/* Mnemonic for the standard output. */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("GETOPT", (ftnlen)6);
}
/* Check to make sure that the number of menu options is positive. */
/* if it is not, then signal an error with an appropriate error */
/* message. */
if (*nopt < 1) {
setmsg_("The number of options was not positive: #.", (ftnlen)42);
errint_("#", nopt, (ftnlen)1);
sigerr_("SPICE(INVALIDARGUMENT)", (ftnlen)22);
chkout_("GETOPT", (ftnlen)6);
return 0;
}
/* Initialize the option prompt. */
s_copy(prmpt, " ", (ftnlen)80, (ftnlen)1);
s_copy(prmpt + 3, "Option: ", (ftnlen)77, (ftnlen)8);
/* Check to make sure that all of the option names are alphanumeric */
/* and uppercase. The only exception is the period, which signals a */
/* blank line. */
ok = TRUE_;
i__1 = *nopt;
for (i__ = 1; i__ <= i__1; ++i__) {
okdigi = *(unsigned char *)&optnam[(i__ - 1) * optnam_len] >= '0' && *
(unsigned char *)&optnam[(i__ - 1) * optnam_len] <= '9';
okalph = *(unsigned char *)&optnam[(i__ - 1) * optnam_len] >= 'A' && *
(unsigned char *)&optnam[(i__ - 1) * optnam_len] <= 'Z';
okequ = *(unsigned char *)&optnam[(i__ - 1) * optnam_len] == '.';
ok = ok && (okdigi || okalph || okequ);
if (! ok) {
setmsg_("An illegal option name was found: option #, name '#'. ",
(ftnlen)54);
errint_("#", &i__, (ftnlen)1);
sigerr_("SPICE(ILLEGALOPTIONNAME)", (ftnlen)24);
chkout_("GETOPT", (ftnlen)6);
return 0;
}
}
/* Do until we get a valid option. */
done = FALSE_;
while(! done) {
/* Display the menu title if it is non blank */
if (s_cmp(title, " ", title_len, (ftnlen)1) != 0) {
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
s_copy(line + 9, "#", (ftnlen)71, (ftnlen)1);
repmc_(line, "#", title, line, (ftnlen)80, (ftnlen)1, title_len, (
ftnlen)80);
writln_(line, &c__6, (ftnlen)80);
}
/* Display the menu and read in an option. */
writln_(" ", &c__6, (ftnlen)1);
i__1 = *nopt;
for (i__ = 1; i__ <= i__1; ++i__) {
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
if (s_cmp(optnam + (i__ - 1) * optnam_len, ".", optnam_len, (
ftnlen)1) != 0) {
s_copy(line + 3, "( # ) #", (ftnlen)77, (ftnlen)7);
repmc_(line, "#", optnam + (i__ - 1) * optnam_len, line, (
ftnlen)80, (ftnlen)1, optnam_len, (ftnlen)80);
repmc_(line, "#", opttxt + (i__ - 1) * opttxt_len, line, (
ftnlen)80, (ftnlen)1, opttxt_len, (ftnlen)80);
}
writln_(line, &c__6, (ftnlen)80);
}
writln_(" ", &c__6, (ftnlen)1);
i__ = rtrim_(prmpt, (ftnlen)80) + 1;
prompt_(prmpt, line, i__, (ftnlen)80);
if (failed_()) {
chkout_("GETOPT", (ftnlen)6);
return 0;
}
/* Initialize the option value to zero, invalid option. */
iopt = 0;
if (s_cmp(line, " ", (ftnlen)80, (ftnlen)1) == 0) {
writln_(" ", &c__6, (ftnlen)1);
} else {
ljust_(line, line, (ftnlen)80, (ftnlen)80);
ucase_(line, line, (ftnlen)80, (ftnlen)80);
/* Check to make sure that the option we got is a valid */
/* candidate: It must be alpha numeric. */
okdigi = *(unsigned char *)line >= '0' && *(unsigned char *)line
<= '9';
okalph = *(unsigned char *)line >= 'A' && *(unsigned char *)line
<= 'Z';
ok = okdigi || okalph;
/* If we got a valid candidate for an option, see if it is one */
/* of the options that we are supplying. */
if (ok) {
iopt = isrchc_(line, nopt, optnam, (ftnlen)1, optnam_len);
ok = iopt != 0;
}
if (! ok) {
s_copy(msg, "'#' was not a valid option. Please try again.", (
ftnlen)80, (ftnlen)45);
repmc_(msg, "#", line, msg, (ftnlen)80, (ftnlen)1, (ftnlen)1,
(ftnlen)80);
writln_(" ", &c__6, (ftnlen)1);
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
s_copy(line + 3, "***", (ftnlen)77, (ftnlen)3);
writln_(line, &c__6, (ftnlen)80);
s_copy(line + 3, "*** #", (ftnlen)77, (ftnlen)5);
repmc_(line, "#", msg, line, (ftnlen)80, (ftnlen)1, (ftnlen)
80, (ftnlen)80);
writln_(line, &c__6, (ftnlen)80);
s_copy(line + 3, "***", (ftnlen)77, (ftnlen)3);
writln_(line, &c__6, (ftnlen)80);
writln_(" ", &c__6, (ftnlen)1);
} else {
*option = iopt;
done = TRUE_;
}
}
}
chkout_("GETOPT", (ftnlen)6);
return 0;
} /* getopt_ */
/* $Procedure ZZGFRPWK ( Geometry finder report work done on a task ) */
/* Subroutine */ int zzgfrpwk_0_(int n__, integer *unit, doublereal *total,
doublereal *freq, integer *tcheck, char *begin, char *end, doublereal
*incr, ftnlen begin_len, ftnlen end_len)
{
/* Initialized data */
static integer calls = 0;
static integer stdout = 6;
static doublereal step = 0.;
static doublereal svincr = 0.;
static integer svunit = 6;
static integer check = 1;
static doublereal done = 0.;
static doublereal entire = 0.;
static char finish[13] = " ";
static logical first = TRUE_;
static integer ls = 1;
static doublereal lstsec = 0.;
static char start[55] = " "
" ";
/* System generated locals */
address a__1[5];
integer i__1[5];
doublereal d__1, d__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
/* Local variables */
doublereal tvec[6];
extern /* Subroutine */ int zzgfdsps_(integer *, char *, char *, integer *
, ftnlen, ftnlen), zzcputim_(doublereal *), chkin_(char *, ftnlen)
, dpfmt_(doublereal *, char *, char *, ftnlen, ftnlen), stdio_(
char *, integer *, ftnlen);
extern integer rtrim_(char *, ftnlen);
extern doublereal brcktd_(doublereal *, doublereal *, doublereal *);
doublereal fractn;
char messge[78];
doublereal cursec;
char prcent[10];
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen);
extern logical return_(void);
extern /* Subroutine */ int writln_(char *, integer *, ftnlen);
/* $ Abstract */
/* The entry points under this routine allows one to easily monitor */
/* the status of job in progress. */
/* $ 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 */
/* GF */
/* $ Keywords */
/* UTILITY */
/* REPORT */
/* WORK */
/* $ Declarations */
/* $ Abstract */
/* SPICE private include file intended solely for the support of */
/* SPICE routines. Users should not include this routine in their */
/* source code due to the volatile nature of this file. */
/* This file contains private, global parameter declarations */
/* for the SPICELIB Geometry Finder (GF) subsystem. */
/* $ 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 */
/* GF */
/* $ Keywords */
/* GEOMETRY */
/* ROOT */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* E.D. Wright (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 17-FEB-2009 (NJB) (EDW) */
/* -& */
/* The set of supported coordinate systems */
/* System Coordinates */
/* ---------- ----------- */
/* Rectangular X, Y, Z */
/* Latitudinal Radius, Longitude, Latitude */
/* Spherical Radius, Colatitude, Longitude */
/* RA/Dec Range, Right Ascension, Declination */
/* Cylindrical Radius, Longitude, Z */
/* Geodetic Longitude, Latitude, Altitude */
/* Planetographic Longitude, Latitude, Altitude */
/* Below we declare parameters for naming coordinate systems. */
/* User inputs naming coordinate systems must match these */
/* when compared using EQSTR. That is, user inputs must */
/* match after being left justified, converted to upper case, */
/* and having all embedded blanks removed. */
/* Below we declare names for coordinates. Again, user */
/* inputs naming coordinates must match these when */
/* compared using EQSTR. */
/* Note that the RA parameter value below matches */
/* 'RIGHT ASCENSION' */
/* when extra blanks are compressed out of the above value. */
/* Parameters specifying types of vector definitions */
/* used for GF coordinate searches: */
/* All string parameter values are left justified, upper */
/* case, with extra blanks compressed out. */
/* POSDEF indicates the vector is defined by the */
/* position of a target relative to an observer. */
/* SOBDEF indicates the vector points from the center */
/* of a target body to the sub-observer point on */
/* that body, for a given observer and target. */
/* SOBDEF indicates the vector points from the center */
/* of a target body to the surface intercept point on */
/* that body, for a given observer, ray, and target. */
/* Number of workspace windows used by ZZGFREL: */
/* Number of additional workspace windows used by ZZGFLONG: */
/* Index of "existence window" used by ZZGFCSLV: */
/* Progress report parameters: */
/* MXBEGM, */
/* MXENDM are, respectively, the maximum lengths of the progress */
/* report message prefix and suffix. */
/* Note: the sum of these lengths, plus the length of the */
/* "percent complete" substring, should not be long enough */
/* to cause wrap-around on any platform's terminal window. */
/* Total progress report message length upper bound: */
/* End of file zzgf.inc. */
/* $ Brief_I/O */
/* VARIABLE I/O Entry points */
/* -------- --- -------------------------------------------------- */
/* UNIT I-O ZZGFWKUN, ZZGFWKMO */
/* TOTAL I-O ZZGFTSWK, ZZGFWKAD, ZZGFWKMO */
/* FREQ I-O ZZGFTSWK, ZZGFWKAD, ZZGFWKMO */
/* TCHECK I-O ZZGFTSWK, ZZGFWKAD, ZZGFWKMO */
/* BEGIN I-O ZZGFTSWK, ZZGFWKAD, ZZGFWKMO */
/* END I-O ZZGFTSWK, ZZGFWKAD, ZZGFWKMO */
/* INCR I-O ZZGFWKIN, ZZGFWKMO */
/* $ Detailed_Input */
/* See the headers of the entry points. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* MXBEGM, */
/* MXENDM, */
/* MXMSG are, respectively, the maximum lengths of the progress */
/* message prefix, progress message suffix, and the */
/* complete message. */
/* $ Exceptions */
/* If this routine is called directly, the error SPICE(BOGUSENTRY) */
/* is signaled. */
/* See the entry points for descriptions of exceptions they detect. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The entry points under this routine are designed to allow one to */
/* easily build into his/her application a monitoring facility */
/* that reports how work on a particular task is proceeding. */
/* There are five entry points: ZZGFTSWK, ZZGFWKIN, ZZGFWKAD, */
/* ZZGFWKUN, and ZZGFWKMO. */
/* The first entry point ZZGFTSWK is used to initialize the reporter. */
/* It is used to tell the reporter "I have some work to do. This is */
/* how much, and this is how often I want you to report on the */
/* progress of the task." */
/* The second entry point ZZGFWKIN is used to tell the reporter "I've */
/* just finished some of the task I told you about with ZZGFTSWK. */
/* This is how much I've just done." (As in real life, the amount */
/* of work you've just done can be negative.) The reporter uses */
/* this information together with the information input in ZZGFTSWK */
/* to decide whether and how much work to report as finished. The */
/* reports will be sent to the current output device. */
/* The third entry point, ZZGFWKAD, adjusts the frequency with which */
/* work progress is reported. */
/* The fourth entry point ZZGFWKUN also is used for testing. It is */
/* used to send the output to the file connected to a specified */
/* logical unit. */
/* The fifth entry point ZZGFWKMO is used for testing. It returns */
/* the saved search parameters. */
/* A more detailed description of each entry point is provided in its */
/* associated header. */
/* $ Examples */
/* A typical use of ZZGFRPWK might be as follows. */
/* C */
/* C Compute how much work is to be done and put it in TOTAL */
/* C */
/* code */
/* computing */
/* how */
/* much */
/* work */
/* to */
/* do */
/* . */
/* . */
/* . */
/* TOTAL = <the amount of work to do> */
/* C */
/* C Tell the work reporter to report work completed every */
/* C 3 seconds. (The third argument in ZZGFTSWK is explained */
/* C in the header for ZZGFTSWK.) */
/* C */
/* FREQUENCY = 3.0D0 */
/* BEGIN = 'Current work status: ' */
/* END = 'completed. ' */
/* CALL ZZGFTSWK ( TOTAL, FREQUENCY, 1, BEGIN, END ) */
/* DO WHILE ( THERE_IS_MORE_WORK_TO_DO ) */
/* code that */
/* performs */
/* the work to */
/* be done */
/* AMOUNT = amount of work done in this loop pass */
/* CALL ZZGFWKIN ( AMOUNT ) */
/* END DO */
/* $ Restrictions */
/* You can use this routine to report progress on only one task at */
/* a time. The work reporter must be initialized using ZZGFTSWK */
/* before calling ZZGFWKIN. Failure to do this may lead to */
/* unexpected results. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* L.S. Elson (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0 17-FEB-2009 (NJB) (LSE) (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* GF low-level progress report umbrella */
/* -& */
/* SPICELIB Functions */
/* Local variables */
/* Saved variables */
/* Initial values */
switch(n__) {
case 1: goto L_zzgftswk;
case 2: goto L_zzgfwkin;
case 3: goto L_zzgfwkad;
case 4: goto L_zzgfwkun;
case 5: goto L_zzgfwkmo;
}
chkin_("ZZGFRPWK", (ftnlen)8);
sigerr_("SPICE(BOGUSENTRY)", (ftnlen)17);
chkout_("ZZGFRPWK", (ftnlen)8);
return 0;
/* $Procedure ZZGFTSWK ( Geometry finder total sum of work to be done. ) */
L_zzgftswk:
/* $ Abstract */
/* Initialize the work progress utility. This is required prior to */
/* use of the routine that performs the actual reporting. */
/* $ 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 */
/* GF */
/* $ Keywords */
/* UTILITY */
/* REPORT */
/* WORK */
/* $ Declarations */
/* DOUBLE PRECISION TOTAL */
/* DOUBLE PRECISION FREQ */
/* INTEGER TCHECK */
/* CHARACTER*(*) BEGIN */
/* CHARACTER*(*) END */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* TOTAL I A measure of the total amount of work to be done. */
/* FREQ I How often the work progress should be reported. */
/* TCHECK I How often to sample the system clock. */
/* BEGIN I First part of the output message. */
/* END I Last part of the output message. */
/* $ Detailed_Input */
/* UNIT is a logical unit connected to the output stream */
/* to which the progress report should be sent. */
/* Normally UNIT is set to the standard output unit, */
/* which can be obtained by calling the SPICELIB */
/* routine STDIO. Unit can be a logical unit connected */
/* to a file; this feature supports testing. */
/* TOTAL is a measure of the total amount of work to be done */
/* by the routine(s) that will be using this facility. */
/* It is expected (but not required) that TOTAL is a */
/* positive number. */
/* FREQ is the how often the work progress should be reported */
/* in seconds. If FREQ = 5 then a work progress report */
/* will be sent to the output device approximately every */
/* 5 seconds. Since writing to the output device takes */
/* time, the smaller FREQ is set, the greater the overhead */
/* taken up by the work reporter will be. ( A value of 2 */
/* or greater should not burden your application */
/* appreciably ) */
/* TCHECK is an integer used to the tell the reporter how often */
/* to sample the system clock. If TCHECK = 7, then on */
/* every seventh call to ZZGFWKIN, the system clock will */
/* be sampled to determine if FREQ seconds have elapsed */
/* since the last report time. Sampling the system clock */
/* takes time. Not a lot of time, but it does take time. */
/* If ZZGFWKIN is being called from a loop that does not */
/* take a lot of time for each pass, the sampling of */
/* the system clock can become a significant overhead */
/* cost in itself. On the VAX the sampling of the */
/* system clock used here takes about 37 double precision */
/* multiplies. If thousands of multiplies take place */
/* between calls to ZZGFWKIN, the sampling time is */
/* insignificant. On the other hand, if only a hundred or */
/* so multiplies occur between calls to ZZGFWKIN, the */
/* sampling of the system clock can become a significant */
/* fraction of your overhead. TCHECK allows you to */
/* tailor the work reporter to your application. */
/* If a non-positive value for TCHECK is entered, a value */
/* of 1 will be used instead of the input value. */
/* BEGIN Is the first part of the output message that will be */
/* constructed for shipment to the output device. This */
/* message will have the form: */
/* BEGIN // xx.x% // END */
/* where xx.x is the percentage of the job completed when */
/* the output message is sent to the output device. */
/* END is the second part of the output message that will be */
/* constructed and sent to the output device (see above). */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Standard SPICE error handling. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This entry point is used to initialize parameters that will */
/* be used by ZZGFWKIN. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* See the header for this module */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* L.S. Elson (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0 17-FEB-2009 (NJB) (LSE) (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* GF low-level initialize progress report */
/* -& */
if (return_()) {
return 0;
}
chkin_("ZZGFTSWK", (ftnlen)8);
/* On the first pass, obtain the logical unit for */
/* standard output. */
if (first) {
stdio_("STDOUT", &stdout, (ftnlen)6);
/* The output unit is STDOUT unless the caller */
/* sets it to something else. */
svunit = stdout;
first = FALSE_;
}
/* Save the inputs and set the amount of work done to 0 */
entire = *total;
/* Computing MIN */
d__1 = 3600., d__2 = max(0.,*freq);
step = min(d__1,d__2);
check = max(1,*tcheck);
s_copy(start, begin, (ftnlen)55, begin_len);
s_copy(finish, end, (ftnlen)13, end_len);
done = 0.;
/* Set the timer. */
zzcputim_(tvec);
lstsec = tvec[3] * 3600. + tvec[4] * 60. + tvec[5];
/* Set the increment counter */
calls = 0;
/* Compose the output message. */
ls = rtrim_(start, (ftnlen)55);
/* Writing concatenation */
i__1[0] = ls, a__1[0] = start;
i__1[1] = 1, a__1[1] = " ";
i__1[2] = 7, a__1[2] = " 0.00%";
i__1[3] = 1, a__1[3] = " ";
i__1[4] = 13, a__1[4] = finish;
s_cat(messge, a__1, i__1, &c__5, (ftnlen)78);
/* Display a blank line, make sure we don't overwrite anything */
/* at the bottom of the screen. The display the message. */
if (svunit == stdout) {
zzgfdsps_(&c__1, messge, "A", &c__0, (ftnlen)78, (ftnlen)1);
} else {
/* Write the message without special carriage control. */
writln_(" ", &svunit, (ftnlen)1);
writln_(" ", &svunit, (ftnlen)1);
writln_(messge, &svunit, (ftnlen)78);
}
chkout_("ZZGFTSWK", (ftnlen)8);
return 0;
/* $Procedure ZZGFWKIN ( Geometry finder work finished increment ) */
L_zzgfwkin:
/* $ Abstract */
/* Let the work reporter know that an increment of work has just */
/* been completed. */
/* $ 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 */
/* GF */
/* $ Keywords */
/* UTILITY */
/* REPORT */
/* WORK */
/* $ Declarations */
/* DOUBLE PRECISION INCR */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* INCR I An amount of work just completed. */
/* $ Detailed_Input */
/* INCR is some amount of work that has been completed since */
/* the last call to ZZGFWKIN. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Standard SPICE error handling. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This entry point is used to report work that has been done since */
/* initialization was performed using ZZGFTSWK or since the last */
/* call to ZZGFWKIN. The work reporter uses this information */
/* together with samples of the system clock to report how much of */
/* the total job has been completed. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* See the header for this module */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* L.S. Elson (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0 17-FEB-2009 (NJB) (LSE) (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* ZZGF low-level progress report increment */
/* -& */
if (return_()) {
return 0;
}
chkin_("ZZGFWKIN", (ftnlen)8);
svincr = *incr;
done += *incr;
++calls;
if (entire == 0.) {
chkout_("ZZGFWKIN", (ftnlen)8);
return 0;
}
if (calls >= check) {
calls = 0;
zzcputim_(tvec);
cursec = tvec[3] * 3600. + tvec[4] * 60. + tvec[5];
if ((d__1 = cursec - lstsec, abs(d__1)) >= step) {
lstsec = cursec;
/* Report how much work has been done. */
d__1 = done / entire * 100.;
fractn = brcktd_(&d__1, &c_b19, &c_b20);
dpfmt_(&fractn, "xxx.xx", prcent, (ftnlen)6, (ftnlen)10);
*(unsigned char *)&prcent[6] = '%';
/* Writing concatenation */
i__1[0] = ls, a__1[0] = start;
i__1[1] = 1, a__1[1] = " ";
i__1[2] = 7, a__1[2] = prcent;
i__1[3] = 1, a__1[3] = " ";
i__1[4] = rtrim_(finish, (ftnlen)13), a__1[4] = finish;
s_cat(messge, a__1, i__1, &c__5, (ftnlen)78);
if (svunit == stdout) {
zzgfdsps_(&c__0, messge, "A", &c__0, (ftnlen)78, (ftnlen)1);
} else {
/* Write the message without special carriage control. */
writln_(messge, &svunit, (ftnlen)78);
}
}
}
chkout_("ZZGFWKIN", (ftnlen)8);
return 0;
/* $Procedure ZZGFWKAD ( Geometry finder work reporting adjustment ) */
L_zzgfwkad:
/* $ Abstract */
/* Adjust the frequency with which work progress is reported. */
/* $ 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 */
/* GF */
/* $ Keywords */
/* UTILITY */
/* REPORT */
/* WORK */
/* $ Declarations */
/* DOUBLE PRECISION FREQ */
/* INTEGER TCHECK */
/* CHARACTER*(*) BEGIN */
/* CHARACTER*(*) END */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* TOTAL I A measure of the total amount of work to be done. */
/* FREQ I How often the work progress should be reported. */
/* BEGIN I First part of the output message. */
/* END I Last part of the output message. */
/* $ Detailed_Input */
/* FREQ is the how often the work progress should be reported */
/* in seconds. If FREQ = 5 then a work progress report */
/* will be sent to the output device approximately every */
/* 5 seconds. Since writing to the output device takes */
/* time, the smaller FREQ is set, the greater the overhead */
/* taken up by the work reporter will be. ( A value of 2 */
/* or greater should not burden your application */
/* appreciably ) */
/* TCHECK is an integer used to the tell the reporter how often */
/* to sample the system clock. If TCHECK = 7, then on */
/* every seventh call to ZZGFWKIN, the system clock will */
/* be sampled to determine if FREQ seconds have elapsed */
/* since the last report time. Sampling the system clock */
/* takes time. Not a lot of time, but it does take time. */
/* If ZZGFWKIN is being called from a loop that does not */
/* take a lot of time for each pass, the sampling of */
/* the system clock can become a significant overhead */
/* cost in itself. On the VAX the sampling of the */
/* system clock used here takes about 37 double precision */
/* multiplies. If thousands of multiplies take place */
/* between calls to ZZGFWKIN, the sampling time is */
/* insignificant. On the other hand, if only a hundred or */
/* so multiplies occur between calls to ZZGFWKIN, the */
/* sampling of the system clock can become a significant */
/* fraction of your overhead. TCHECK allows you to */
/* tailor the work reporter to your application. */
/* If a non-positive value for TCHECK is entered, a value */
/* of 1 will be used instead of the input value. */
/* BEGIN Is the first part of the output message that will be */
/* constructed for shipment to the output device. This */
/* message will have the form: */
/* BEGIN // xx.x% // END */
/* where xx.x is the percentage of the job completed when */
/* the output message is sent to the output device. */
/* END is the second part of the output message that will be */
/* constructed and sent to the output device (see above). */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* 1) If TCHECK is less than 1, the value 1 is stored. */
/* 2) If FREQ is less than 0.1, the value 0.1 is stored. */
/* If FREQ is greater than 3600, the value 3600 is stored. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This entry point exists to modify the reporting frequency set */
/* up by an initial call to ZZGFTSWK. In this way one can override */
/* how often reporting of work increments is performed, without */
/* causing the screen to be modified (which happens if a new */
/* call to ZZGFTSWK is made.) */
/* It exists primarily as a back door to existing code */
/* that calls ZZGFTSWK in a rigid way. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* See the header for this module. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* L.S. Elson (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0 17-FEB-2009 (NJB) (LSE) (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* GF low-level progress report adjust frequency */
/* -& */
/* Computing MIN */
d__1 = 3600., d__2 = max(0.,*freq);
step = min(d__1,d__2);
check = max(1,*tcheck);
s_copy(start, begin, (ftnlen)55, begin_len);
s_copy(finish, end, (ftnlen)13, end_len);
return 0;
/* $Procedure ZZGFWUN ( Geometry finder set work report output unit ) */
L_zzgfwkun:
/* $ Abstract */
/* Set the output unit for the progress report. */
/* $ 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 */
/* GF */
/* $ Keywords */
/* UTILITY */
/* REPORT */
/* WORK */
/* $ Declarations */
/* INTEGER UNIT */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* UNIT I Output logical unit. */
/* $ Detailed_Input */
/* UNIT Logical unit of a text file open for write access. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* The file designated by UNIT should be a text file opened by the */
/* calling application. */
/* $ Particulars */
/* This routine can be called before ZZGFTSWK to set the output */
/* logical unit to that of a text file. */
/* This entry point exists to support testing of the higher-level */
/* GF progress reporting routines */
/* GFREPI */
/* GFREPU */
/* GFREPF */
/* This routine enables TSPICE to send the output report to */
/* a specified file. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0 17-FEB-2009 (NJB) */
/* -& */
/* $ Index_Entries */
/* GF low-level progress report output select unit */
/* -& */
/* On the first pass, obtain the logical unit for */
/* standard output. */
if (first) {
stdio_("STDOUT", &stdout, (ftnlen)6);
first = FALSE_;
}
svunit = *unit;
return 0;
/* $Procedure ZZGFWKMO ( Geometry finder work reporting monitor ) */
L_zzgfwkmo:
/* $ Abstract */
/* Return saved progress report 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. */
/* $ Required_Reading */
/* GF */
/* $ Keywords */
/* UTILITY */
/* REPORT */
/* WORK */
/* $ Declarations */
/* INTEGER UNIT */
/* DOUBLE PRECISION TOTAL */
/* DOUBLE PRECISION FREQ */
/* INTEGER TCHECK */
/* CHARACTER*(*) BEGIN */
/* CHARACTER*(*) END */
/* DOUBLE PRECISION INCR */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* UNIT O Output logical unit. */
/* TOTAL O A measure of the total amount of work to be done. */
/* FREQ O How often the work progress should be reported. */
/* TCHECK O Number of calls between system time check. */
/* BEGIN O First part of the output message. */
/* END O Last part of the output message. */
/* INCR O Last progress increment. */
/* $ Detailed_Input */
/* None. */
/* $ Detailed_Output */
/* UNIT, */
/* TOTAL, */
/* FREQ, */
/* TCHECK, */
/* BEGIN, */
/* END, */
/* INCR are the most recent values of these */
/* variables passed in via calls to ZZGFTSWK, */
/* ZZGFWKIN, or ZZGFWKAD. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This entry point exists to support testing of the higher-level */
/* GF progress reporting routines */
/* GFREPI */
/* GFREPU */
/* GFREPF */
/* This routine enables TSPICE to determine the values passed */
/* in to entry points of this package by those routines. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0 17-FEB-2009 (NJB) */
/* -& */
/* $ Index_Entries */
/* GF low-level progress report monitor */
/* -& */
*unit = svunit;
*total = entire;
*freq = step;
*tcheck = check;
s_copy(begin, start, begin_len, (ftnlen)55);
s_copy(end, finish, end_len, (ftnlen)13);
*incr = svincr;
return 0;
} /* zzgfrpwk_ */
/* $Procedure SUMCK ( Summarize a CK file ) */
/* Subroutine */ int sumck_(integer *handle, char *binfnm, char *lpsfnm, char
*sclfnm, logical *logfil, integer *loglun, ftnlen binfnm_len, ftnlen
lpsfnm_len, ftnlen sclfnm_len)
{
/* Initialized data */
static char menutl[20] = "CK Summary Options ";
static char menuvl[20*6] = "QUIT " "Skip "
"ENTIRE_FILE " "BY_INSTRUMENT_ID " "BY_UTC_INTERVAL "
" " "BY_SCLK_INTERVAL ";
static char menutx[40*6] = "Quit, returning to main menu. "
"Skip " "Summarize entire fil"
"e. " "Summarize by NAIF instrument ID code. "
"Summarize by UTC time interval. " "Summarize by SCLK ti"
"me interval. ";
static char menunm[1*6] = "Q" "." "F" "I" "U" "S";
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen), s_wsle(cilist *), e_wsle(void), do_lio(integer *,
integer *, char *, ftnlen);
/* Local variables */
static logical done;
static char line[255];
extern /* Subroutine */ int sct2e_(integer *, doublereal *, doublereal *);
extern integer cardd_(doublereal *);
static doublereal beget;
static char segid[40];
extern /* Subroutine */ int chkin_(char *, ftnlen);
static char bsclk[32];
static doublereal endet;
static char esclk[32];
extern /* Subroutine */ int repmc_(char *, char *, char *, char *, ftnlen,
ftnlen, ftnlen, ftnlen);
static char separ[80];
static logical found;
extern /* Subroutine */ int repmi_(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen), ckgss_(char *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, integer *,
integer *, ftnlen), reset_(void);
static logical error;
extern /* Subroutine */ int ckwss_(integer *, char *, integer *, integer *
, integer *, integer *, doublereal *, doublereal *, ftnlen);
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int utc2et_(char *, doublereal *, ftnlen),
et2utc_(doublereal *, char *, integer *, char *, ftnlen, ftnlen),
daffna_(logical *);
extern logical failed_(void);
static integer segbad;
extern /* Subroutine */ int scdecd_(integer *, doublereal *, char *,
ftnlen), dafbfs_(integer *);
static integer segead;
static doublereal begscl;
extern /* Subroutine */ int scardd_(integer *, doublereal *), scencd_(
integer *, char *, doublereal *, ftnlen);
static logical segfnd;
static doublereal endscl;
static char begutc[32];
extern /* Subroutine */ int cnfirm_(char *, logical *, ftnlen), getchr_(
char *, char *, logical *, logical *, char *, ftnlen, ftnlen,
ftnlen);
static logical haveit;
static char endutc[32];
static integer segfrm;
static doublereal segbtm, segetm;
static integer instid, segins;
static doublereal segint[8];
static logical anyseg;
extern /* Subroutine */ int getint_(char *, integer *, logical *, logical
*, char *, ftnlen, ftnlen);
static char errmsg[320], option[20], sumsep[80];
extern logical return_(void);
static char fnmout[255], sclout[255];
static integer missin;
static char lpsout[255];
static integer menuop, segrts;
static char tmpstr[80];
static integer segtyp;
static doublereal intrvl[8], intsct[8];
static logical contnu, tryagn;
extern /* Subroutine */ int ssized_(integer *, doublereal *), writln_(
char *, integer *, ftnlen), getopt_(char *, integer *, char *,
char *, integer *, ftnlen, ftnlen, ftnlen), wninsd_(doublereal *,
doublereal *, doublereal *), wnintd_(doublereal *, doublereal *,
doublereal *);
static char typout[255];
extern /* Subroutine */ int chkout_(char *, ftnlen);
/* Fortran I/O blocks */
static cilist io___23 = { 0, 6, 0, 0, 0 };
static cilist io___24 = { 0, 6, 0, 0, 0 };
static cilist io___25 = { 0, 6, 0, 0, 0 };
static cilist io___26 = { 0, 6, 0, 0, 0 };
static cilist io___27 = { 0, 6, 0, 0, 0 };
static cilist io___28 = { 0, 6, 0, 0, 0 };
static cilist io___29 = { 0, 6, 0, 0, 0 };
static cilist io___30 = { 0, 6, 0, 0, 0 };
static cilist io___32 = { 0, 6, 0, 0, 0 };
static cilist io___33 = { 0, 6, 0, 0, 0 };
static cilist io___34 = { 0, 6, 0, 0, 0 };
static cilist io___36 = { 0, 6, 0, 0, 0 };
static cilist io___37 = { 0, 6, 0, 0, 0 };
static cilist io___38 = { 0, 6, 0, 0, 0 };
static cilist io___39 = { 0, 6, 0, 0, 0 };
static cilist io___41 = { 0, 6, 0, 0, 0 };
static cilist io___42 = { 0, 6, 0, 0, 0 };
static cilist io___43 = { 0, 6, 0, 0, 0 };
static cilist io___44 = { 0, 6, 0, 0, 0 };
static cilist io___46 = { 0, 6, 0, 0, 0 };
static cilist io___47 = { 0, 6, 0, 0, 0 };
static cilist io___48 = { 0, 6, 0, 0, 0 };
static cilist io___49 = { 0, 6, 0, 0, 0 };
static cilist io___51 = { 0, 6, 0, 0, 0 };
static cilist io___52 = { 0, 6, 0, 0, 0 };
static cilist io___53 = { 0, 6, 0, 0, 0 };
static cilist io___54 = { 0, 6, 0, 0, 0 };
static cilist io___56 = { 0, 6, 0, 0, 0 };
static cilist io___57 = { 0, 6, 0, 0, 0 };
static cilist io___58 = { 0, 6, 0, 0, 0 };
static cilist io___59 = { 0, 6, 0, 0, 0 };
static cilist io___60 = { 0, 6, 0, 0, 0 };
static cilist io___61 = { 0, 6, 0, 0, 0 };
static cilist io___62 = { 0, 6, 0, 0, 0 };
static cilist io___63 = { 0, 6, 0, 0, 0 };
static cilist io___65 = { 0, 6, 0, 0, 0 };
static cilist io___66 = { 0, 6, 0, 0, 0 };
static cilist io___67 = { 0, 6, 0, 0, 0 };
static cilist io___68 = { 0, 6, 0, 0, 0 };
static cilist io___70 = { 0, 6, 0, 0, 0 };
static cilist io___71 = { 0, 6, 0, 0, 0 };
static cilist io___72 = { 0, 6, 0, 0, 0 };
static cilist io___73 = { 0, 6, 0, 0, 0 };
static cilist io___75 = { 0, 6, 0, 0, 0 };
static cilist io___76 = { 0, 6, 0, 0, 0 };
static cilist io___77 = { 0, 6, 0, 0, 0 };
static cilist io___78 = { 0, 6, 0, 0, 0 };
static cilist io___80 = { 0, 6, 0, 0, 0 };
/* $ Abstract */
/* Summarize a CK 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. */
/* $ Declarations */
/* Set the number of double precision components in an unpacked CK */
/* descriptor. */
/* Set the number of integer components in an unpacked CK descriptor. */
/* Set the size of a packed CK descriptor. */
/* Set the length of a CK segment identifier. */
/* Set the value for the lower bound of the CELL data type. */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle of the SPK file to be summarized. */
/* LOGFIL I Write the summary to a log file and to screen? */
/* LOGLUN I Logical unit connected to the log file. */
/* NDC P Number of d.p. components in SPK descriptor. */
/* NIC P Number of integer components in SPK descriptor. */
/* NC P Size of packed SPK descriptor. */
/* IDSIZ P Length of SPK segment identifier. */
/* LBCELL P Lower bound for the SPICELIB CELL data structure. */
/* $ Detailed_Input */
/* HANDLE is the integer handle of the CK file to be summarized. */
/* LOGFIL if TRUE means that the summary will be written to */
/* a log file as well as displayed on the terminal */
/* screen. Otherwise, the summary will not be written */
/* to a log file. */
/* LOGLUN is the logical unit connected to a log file to which */
/* the summary is to be written if LOGFIL is TRUE. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* NDC is the number of double precision components in an */
/* unpacked SPK descriptor. */
/* NIC is the number of integer components in an unpacked */
/* SPK descriptor. */
/* NC is the size of a packed SPK descriptor. */
/* IDSIZ is the length of an SPK segment identifier. */
/* LBCELL is the lower bound for the SPICELIB CELL data */
/* structure. */
/* $ Exceptions */
/* None. */
/* $ Files */
/* The CK file to be summarized is referred throughout this routine */
/* by its handle. The file should already be opened for read. */
/* $ Particulars */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* M.J. Spencer (JPL) */
/* J.E. McLean (JPL) */
/* R.E. Thurman (JPL) */
/* $ Version */
/* - Beta Version 5.0.0 21-JUL-1995 (KRG) */
/* Added several arguments to the call of this subroutine and */
/* made other modifications to allow it to perform its own */
/* formatting of the summary, including filenames and separators. */
/* - Beta Version 4.0.0 11-APR-1994 (KRG) */
/* Modified this routine to make use of new routines to get and */
/* format and write CK segment summaries. */
/* Added a missing $ Index_Entries header section. */
/* Fixed a few typos in the header. */
/* The routine DISPC is now obsolete. It is no longer used. */
/* - Beta Version 3.0.0 22-MAR-1993 (KRG) */
/* 1) Changed the names of the variables TOFILE and UNIT to LOGFIL */
/* and LOGLUN, respectively. */
/* 2) Updated the program to use the menuing subroutine GETOPT */
/* which removes the need for the routine QSUMC. Redesigned */
/* the case sructure of the code to facilitate the use of the */
/* menuing routine. */
/* 3) Rearranged some of thee initializations that were performed, */
/* moved several calls to SCARDD outside the main loop, etc. */
/* 5) Performed some general cleanup as deemed necessary. */
/* - Beta Version 2.1.0 20-NOV-1991 (MJS) */
/* Checked FAILED function in main loop. */
/* - Beta Version 2.0.0 17-JUN-1991 (JEM) */
/* 1. Added the arguments TOFILE and UNIT. Previously the */
/* summary was only displayed on the terminal screen. */
/* Now, if requested by TOFILE, the summary is also */
/* written to the file connected to UNIT. */
/* 2. A user may cancel a task selected in QSUMC and */
/* select another. */
/* - SPICELIB Version 1.1.0 31-AUG-1990 (JEM) */
/* This routine was updated due to changes in the CK and */
/* SCLK design. Also, several implementation-specific */
/* parameters were moved from the header to the local */
/* parameters section. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (RET) */
/* -& */
/* $ Index_Entries */
/* summarize the segments in a binary ck file */
/* -& */
/* $ Revisions */
/* - Beta Version 5.0.0 21-JUL-1995 (KRG) */
/* Added several arguments to the call of this subroutine and */
/* made other modifications to allow it to perform its own */
/* formatting of the summary, including filenames and separators. */
/* - Beta Version 4.0.0 11-APR-1994 (KRG) */
/* Modified this routine to make use of new routines to get and */
/* format and write CK segment summaries. */
/* Added a missing $ Index_Entries header section. */
/* Fixed a few typos in the header. */
/* The routine DISPC is now obsolete. It is no longer used. */
/* - Beta Version 3.0.0 22-MAR-1993 (KRG) */
/* 1) Changed the names of the variables TOFILE and UNIT to LOGFIL */
/* and LOGLUN, respectively. */
/* 2) Updated the program to use the menuing subroutine GETOPT */
/* which removes the need for the routine QSUMC. Redesigned */
/* the case sructure of the code to facilitate the use of the */
/* menuing routine. */
/* 3) Rearranged some of thee initializations that were performed, */
/* moved several calls to SCARDD outside the main loop, etc. */
/* 5) Performed some general cleanup as deemed necessary. */
/* - Beta Version 2.1.0 20-NOV-1991 (MJS) */
/* Checked FAILED function in main loop. In the previous version, */
/* if any time conversion produced an error, the summary would go */
/* in an endless loop. */
/* - Beta Version 2.0.0 22-MAY-1991 (JEM) */
/* 1. In addition to adding the arguments TOFILE and UNIT to */
/* the calling sequence, the following code changes were */
/* made. The two new arguments were added to the calling */
/* sequence of DISPC as well. If TOFILE is true, a */
/* description of the type of summary is written to the */
/* output file before calling DISPC to write the summary. */
/* If no segments are found, the message is written to the */
/* output file as well as the terminal screen when */
/* TOFILE is true. */
/* 2. QSUMC was changed. 'NONE' is now a possible task */
/* returned from QSUMC and means a task was selected, */
/* then cancelled. QSUMC is called repeatedly until the */
/* task returned is something other than NONE. In */
/* this way the user is able to select another task. */
/* - SPICELIB Version 1.1.0 31-AUG-1990 (JEM) */
/* This routine was updated to handle these changes to the */
/* C-kernel design: */
/* 1. Ephemeris time is no longer included in CK files. */
/* All data is associated with spacecraft clock time only. */
/* The segment descriptor no longer contains the */
/* start and stop ET. Thus, the number of double */
/* precision components (NDC) is now two instead of four. */
/* 2. Segments may now contain rate information, along with */
/* pointing data. The segment descriptor contains a flag */
/* that indicates whether or not the segment includes */
/* rate information. Thus, the number of integer */
/* components (NIC) is now six instead of five. */
/* This version of SUMCK converts encoded SCLK times to ET for */
/* comparison with input times which are converted from UTC to ET. */
/* This routine was also updated to handle these changes to the */
/* SCLK design: */
/* 1. The name of the routine that encodes spacecraft */
/* clock time was changed from ENSCLK to SCENCD, and */
/* the order of arguments in the calling sequence */
/* was changed. */
/* 2. Instrument ID codes are now negative integers to */
/* avoid conflict with other body id codes. */
/* The parameters that pertain to the CK file architecture, */
/* like the number of double precision components in the */
/* segment descriptor (NDC), were moved from the header */
/* to the local parameter section. These parameters are */
/* implementation specific. Further, the user is not invited */
/* to change them, nor are they needed in any argument */
/* declaration. Thus they do not belong in the header. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Set value for a separator */
/* Set up the instrument ID code prompt. */
/* Set up the spacecraft ID code prompt. */
/* Set up the SCLK time string prompt. */
/* Set up labels for various output things. */
/* Set up the UTC time string prompt. */
/* Set the length for a line of text. */
/* Set the length for an output line. */
/* Set the length for an error message. */
/* Set the length for a UTC time string. */
/* Set the precision for the fractional part of UTC times. */
/* Set a length for the option values. */
/* Set a length for the title of a menu. */
/* Set the length of the text description of an option on a menu. */
/* The number of options available on the main menu. */
/* Parameter for the standard output unit. */
/* Local variables */
/* Save everything to keep control happy. */
/* Initial Values */
/* Define the menu title ... */
/* Define the menu option values ... */
/* Define the menu descriptive text for each option ... */
/* Define the menu option names ... */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SUMCK", (ftnlen)5);
}
/* Initialize the separator. */
s_copy(separ, "*********************************************************"
"***********************", (ftnlen)80, (ftnlen)80);
/* Initialize the segment separator. */
s_copy(sumsep, "--------------------------------------------------------"
"------------------------", (ftnlen)80, (ftnlen)80);
/* Set the sizes of the window cells that we will use if the file */
/* is to be summarized by time. */
ssized_(&c__2, intrvl);
ssized_(&c__2, segint);
ssized_(&c__2, intsct);
/* Initialize a few things before we start. */
instid = 0;
done = FALSE_;
while(! done) {
/* Initialize those things we reuse on every iteration. */
contnu = TRUE_;
writln_(" ", &c__6, (ftnlen)1);
getopt_(menutl, &c__6, menunm, menutx, &menuop, (ftnlen)20, (ftnlen)1,
(ftnlen)40);
if (failed_()) {
contnu = FALSE_;
}
if (contnu) {
/* Perform all of the setup necessary to perform the summary. */
/* This include prompting for input values required, etc. */
repmc_("Summary for CK file: #", "#", binfnm, fnmout, (ftnlen)22,
(ftnlen)1, binfnm_len, (ftnlen)255);
repmc_("Leapseconds File : #", "#", lpsfnm, lpsout, (ftnlen)22,
(ftnlen)1, lpsfnm_len, (ftnlen)255);
repmc_("SCLK File : #", "#", sclfnm, sclout, (ftnlen)22,
(ftnlen)1, sclfnm_len, (ftnlen)255);
s_copy(option, menuvl + ((i__1 = menuop - 1) < 6 && 0 <= i__1 ?
i__1 : s_rnge("menuvl", i__1, "sumck_", (ftnlen)553)) *
20, (ftnlen)20, (ftnlen)20);
if (s_cmp(option, "QUIT", (ftnlen)20, (ftnlen)4) == 0) {
contnu = FALSE_;
done = TRUE_;
} else if (s_cmp(option, "ENTIRE_FILE", (ftnlen)20, (ftnlen)11) ==
0) {
/* Summarize the entire file. */
repmc_("Summary Type : #", "#", "Entire File", typout, (
ftnlen)22, (ftnlen)1, (ftnlen)11, (ftnlen)255);
} else if (s_cmp(option, "BY_INSTRUMENT_ID", (ftnlen)20, (ftnlen)
16) == 0) {
/* Summarize for a specified body. */
/* First, we need to get the instrument ID code. */
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___23);
e_wsle();
s_wsle(&io___24);
do_lio(&c__9, &c__1, "Enter the desired NAIF instrument "
"code.", (ftnlen)39);
e_wsle();
s_wsle(&io___25);
e_wsle();
getint_("Instrument ID code? ", &instid, &haveit, &error,
errmsg, (ftnlen)20, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___26);
e_wsle();
s_wsle(&io___27);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___28);
e_wsle();
s_wsle(&io___29);
do_lio(&c__9, &c__1, "A NAIF instrument ID code "
"must be entered for this option.", (
ftnlen)58);
e_wsle();
}
if (! haveit || error) {
s_wsle(&io___30);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)
20);
if (! tryagn) {
contnu = FALSE_;
}
}
} else {
tryagn = FALSE_;
}
}
/* Write the type of summary to the log file if we need to. */
if (contnu) {
s_copy(tmpstr, "By Instrument ID #", (ftnlen)80, (ftnlen)
18);
repmc_("Summary Type : #", "#", tmpstr, typout, (
ftnlen)22, (ftnlen)1, (ftnlen)80, (ftnlen)255);
repmi_(typout, "#", &instid, typout, (ftnlen)255, (ftnlen)
1, (ftnlen)255);
}
} else if (s_cmp(option, "BY_UTC_INTERVAL", (ftnlen)20, (ftnlen)
15) == 0) {
/* Summarize for given UTC time interval. */
/* First, we need to get the UTC time string for the */
/* begin time. */
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___32);
e_wsle();
s_wsle(&io___33);
do_lio(&c__9, &c__1, "Enter the desired beginning UTC ti"
"me.", (ftnlen)37);
e_wsle();
s_wsle(&io___34);
e_wsle();
getchr_("UTC time? ", begutc, &haveit, &error, errmsg, (
ftnlen)10, (ftnlen)32, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___36);
e_wsle();
s_wsle(&io___37);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___38);
e_wsle();
s_wsle(&io___39);
do_lio(&c__9, &c__1, "A beginning UTC time strin"
"g must be entered for this option.", (
ftnlen)60);
e_wsle();
}
} else {
tryagn = FALSE_;
}
/* We now have the beginning time in UTC, so attempt */
/* to convert it to ET. If the conversion fails, we */
/* need to immediately reset the error handling so that */
/* we can continue processing. Remember, we are in a */
/* menuing subroutine, and we are not allowed to exit */
/* on an error: we must go back to the menu. thus the */
/* need for a resetting of the error handler here. If */
/* we got to here, there were no errors, so as long as */
/* we maintain that status, everything will be hunky */
/* dory. We also convert the ET back into UTC to get */
/* a consistent format for display. */
if (haveit) {
utc2et_(begutc, &beget, (ftnlen)32);
et2utc_(&beget, "C", &c__3, begutc, (ftnlen)1, (
ftnlen)32);
if (failed_()) {
reset_();
error = TRUE_;
}
}
/* Check to see if they want to try and enter the */
/* beginning UTC time string again. */
if (! haveit || error) {
s_wsle(&io___41);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)20);
if (! tryagn) {
contnu = FALSE_;
}
}
}
/* Now, if we can, we need to get the UTC time string for */
/* the end time. */
if (contnu) {
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___42);
e_wsle();
s_wsle(&io___43);
do_lio(&c__9, &c__1, "Enter the desired ending UTC t"
"ime.", (ftnlen)34);
e_wsle();
s_wsle(&io___44);
e_wsle();
getchr_("UTC time? ", endutc, &haveit, &error, errmsg,
(ftnlen)10, (ftnlen)32, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___46);
e_wsle();
s_wsle(&io___47);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___48);
e_wsle();
s_wsle(&io___49);
do_lio(&c__9, &c__1, "An ending UTC time str"
"ing must be entered for this option.",
(ftnlen)58);
e_wsle();
}
} else {
tryagn = FALSE_;
}
/* We now have the ending time in UTC, so attempt */
/* to convert it to ET. If the conversion fails, we */
/* need to immediately reset the error handling so */
/* that we can continue processing. Remember, we are */
/* in a menuing subroutine, and we are not allowed */
/* to exit on an error: we must go back to the menu. */
/* thus the need for a resetting of the error handler */
/* here. If we got to here, there were no errors, so */
/* as long as we maintain that status, everything */
/* will be hunky dory. We also convert the ET back */
/* into UTC to get a consistent format for display. */
if (haveit) {
utc2et_(endutc, &endet, (ftnlen)32);
et2utc_(&endet, "C", &c__3, endutc, (ftnlen)1, (
ftnlen)32);
if (failed_()) {
reset_();
error = TRUE_;
}
}
/* Check to see if they want to try and enter the */
/* beginning UTC time string again. */
if (! haveit || error) {
s_wsle(&io___51);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)
20);
if (! tryagn) {
contnu = FALSE_;
}
} else {
tryagn = FALSE_;
}
}
}
/* Create an interval out of the begin and end ET times, */
/* if we can. */
if (contnu) {
scardd_(&c__0, intrvl);
wninsd_(&beget, &endet, intrvl);
if (failed_()) {
contnu = FALSE_;
}
}
/* Write the type of summary to the output file, if we can. */
if (contnu) {
s_copy(tmpstr, "By # Time Interval #", (ftnlen)80, (
ftnlen)20);
repmc_("Summary Type : #", "#", tmpstr, typout, (
ftnlen)22, (ftnlen)1, (ftnlen)80, (ftnlen)255);
repmc_(typout, "#", "UTC", typout, (ftnlen)255, (ftnlen)1,
(ftnlen)3, (ftnlen)255);
repmc_(typout, "#", "(#, #)", typout, (ftnlen)255, (
ftnlen)1, (ftnlen)6, (ftnlen)255);
repmc_(typout, "#", begutc, typout, (ftnlen)255, (ftnlen)
1, (ftnlen)32, (ftnlen)255);
repmc_(typout, "#", endutc, typout, (ftnlen)255, (ftnlen)
1, (ftnlen)32, (ftnlen)255);
}
} else if (s_cmp(option, "BY_SCLK_INTERVAL", (ftnlen)20, (ftnlen)
16) == 0) {
/* Summarize for given SCLK time interval. */
/* First, we need to get spacecraft ID code. */
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___52);
e_wsle();
s_wsle(&io___53);
do_lio(&c__9, &c__1, "Enter the desired NAIF spacecraft "
"ID code.", (ftnlen)42);
e_wsle();
s_wsle(&io___54);
e_wsle();
getint_("Spacecraft ID code? ", &missin, &haveit, &error,
errmsg, (ftnlen)20, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___56);
e_wsle();
s_wsle(&io___57);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___58);
e_wsle();
s_wsle(&io___59);
do_lio(&c__9, &c__1, "A NAIF spacecraft ID code "
"must be entered for this option.", (
ftnlen)58);
e_wsle();
}
if (! haveit || error) {
s_wsle(&io___60);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)
20);
if (! tryagn) {
contnu = FALSE_;
}
}
} else {
tryagn = FALSE_;
}
}
/* Now, we need to get the SCLK time string for the */
/* begin time. */
if (contnu) {
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___61);
e_wsle();
s_wsle(&io___62);
do_lio(&c__9, &c__1, "Enter the desired beginning SC"
"LK time.", (ftnlen)38);
e_wsle();
s_wsle(&io___63);
e_wsle();
getchr_("SCLK time? ", bsclk, &haveit, &error, errmsg,
(ftnlen)11, (ftnlen)32, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___65);
e_wsle();
s_wsle(&io___66);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___67);
e_wsle();
s_wsle(&io___68);
do_lio(&c__9, &c__1, "A beginning SCLK time "
"string must be entered for this opti"
"on.", (ftnlen)61);
e_wsle();
}
} else {
tryagn = FALSE_;
}
/* We now have the beginning time in SCLK, so attempt */
/* to convert it to ET. If the conversion fails, we */
/* need to immediately reset the error handling so */
/* that we can continue processing. Remember, we are */
/* in a menuing subroutine, and we are not allowed to */
/* exit on an error: we must go back to the menu. thus */
/* the need for a resetting of the error handler here. */
/* If we got to here, there were no errors, so as long */
/* as we maintain that status, everything will be */
/* hunky dory. We also convert the ET back into SCLK, */
/* and UTC to get a consistent format for display. */
if (haveit) {
scencd_(&missin, bsclk, &begscl, (ftnlen)32);
sct2e_(&missin, &begscl, &beget);
et2utc_(&beget, "C", &c__3, begutc, (ftnlen)1, (
ftnlen)32);
scdecd_(&missin, &begscl, bsclk, (ftnlen)32);
if (failed_()) {
reset_();
error = TRUE_;
}
}
/* Check to see if they want to try and enter the */
/* beginning UTC time string again. */
if (! haveit || error) {
s_wsle(&io___70);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)
20);
if (! tryagn) {
contnu = FALSE_;
}
}
}
}
/* Now, if we can, we need to get the UTC time string for */
/* the end time. */
if (contnu) {
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___71);
e_wsle();
s_wsle(&io___72);
do_lio(&c__9, &c__1, "Enter the desired ending SCLK "
"time.", (ftnlen)35);
e_wsle();
s_wsle(&io___73);
e_wsle();
getchr_("SCLK time? ", esclk, &haveit, &error, errmsg,
(ftnlen)11, (ftnlen)32, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___75);
e_wsle();
s_wsle(&io___76);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___77);
e_wsle();
s_wsle(&io___78);
do_lio(&c__9, &c__1, "An ending SCLK time st"
"ring must be entered for this option."
, (ftnlen)59);
e_wsle();
}
} else {
tryagn = FALSE_;
}
/* We now have the ending time in UTC, so attempt */
/* to convert it to ET. If the conversion fails, we */
/* need to immediately reset the error handling so */
/* that we can continue processing. Remember, we are */
/* in a menuing subroutine, and we are not allowed */
/* to exit on an error: we must go back to the menu. */
/* thus the need for a resetting of the error handler */
/* here. If we got to here, there were no errors, so */
/* as long as we maintain that status, everything */
/* will be hunky dory. We also convert the ET back */
/* into UTC to get a consistent format for display. */
if (haveit) {
scencd_(&missin, esclk, &endscl, (ftnlen)32);
sct2e_(&missin, &endscl, &endet);
et2utc_(&endet, "C", &c__3, endutc, (ftnlen)1, (
ftnlen)32);
scdecd_(&missin, &endscl, esclk, (ftnlen)32);
if (failed_()) {
reset_();
error = TRUE_;
}
}
/* Check to see if they want to try and enter the */
/* ending SCLK time string again. */
if (! haveit || error) {
s_wsle(&io___80);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)
20);
if (! tryagn) {
contnu = FALSE_;
}
} else {
tryagn = FALSE_;
}
}
}
/* Create an interval out of the begin and end ET times, */
/* if we can. */
if (contnu) {
scardd_(&c__0, intrvl);
wninsd_(&beget, &endet, intrvl);
if (failed_()) {
contnu = FALSE_;
}
}
/* Write the type of summary to the output file, if we can. */
if (contnu) {
s_copy(tmpstr, "By # Time Interval #", (ftnlen)80, (
ftnlen)20);
repmc_("Summary Type : #", "#", tmpstr, typout, (
ftnlen)22, (ftnlen)1, (ftnlen)80, (ftnlen)255);
repmc_(typout, "#", "SCLK", typout, (ftnlen)255, (ftnlen)
1, (ftnlen)4, (ftnlen)255);
repmc_(typout, "#", "(#, #)", typout, (ftnlen)255, (
ftnlen)1, (ftnlen)6, (ftnlen)255);
repmc_(typout, "#", bsclk, typout, (ftnlen)255, (ftnlen)1,
(ftnlen)32, (ftnlen)255);
repmc_(typout, "#", esclk, typout, (ftnlen)255, (ftnlen)1,
(ftnlen)32, (ftnlen)255);
}
}
/* Now, if we can, search through the file from the beginning. */
/* Keep track of whether or not any segments satisfy the search */
/* criteria. */
if (contnu) {
writln_(" ", &c__6, (ftnlen)1);
writln_(separ, &c__6, (ftnlen)80);
writln_(" ", &c__6, (ftnlen)1);
writln_(fnmout, &c__6, (ftnlen)255);
writln_(lpsout, &c__6, (ftnlen)255);
writln_(sclout, &c__6, (ftnlen)255);
writln_(typout, &c__6, (ftnlen)255);
writln_(" ", &c__6, (ftnlen)1);
if (*logfil) {
writln_(" ", loglun, (ftnlen)1);
writln_(separ, loglun, (ftnlen)80);
writln_(" ", loglun, (ftnlen)1);
writln_(fnmout, loglun, (ftnlen)255);
writln_(lpsout, loglun, (ftnlen)255);
writln_(sclout, loglun, (ftnlen)255);
writln_(typout, loglun, (ftnlen)255);
writln_(" ", loglun, (ftnlen)1);
}
anyseg = FALSE_;
dafbfs_(handle);
daffna_(&found);
while(found && contnu) {
/* On each iteration of the loop, we have not found */
/* anything initially. */
segfnd = FALSE_;
scardd_(&c__0, intsct);
scardd_(&c__0, segint);
/* Get the descriptor of the segment. */
ckgss_(segid, &segins, &segfrm, &segtyp, &segrts, &segbtm,
&segetm, &segbad, &segead, (ftnlen)40);
/* Check to see if the current segment satisfies the */
/* current search criteria. */
if (s_cmp(option, "ENTIRE_FILE", (ftnlen)20, (ftnlen)11)
== 0) {
segfnd = TRUE_;
} else if (s_cmp(option, "BY_INSTRUMENT_ID", (ftnlen)20, (
ftnlen)16) == 0) {
segfnd = instid == segins;
} else if (s_cmp(option, "BY_UTC_INTERVAL", (ftnlen)20, (
ftnlen)15) == 0) {
/* Create an interval out of the epochs in the */
/* segment. */
missin = segins / 1000;
sct2e_(&missin, &segbtm, &beget);
sct2e_(&missin, &segetm, &endet);
wninsd_(&beget, &endet, segint);
/* Intersect it with the input interval. */
wnintd_(segint, intrvl, intsct);
if (failed_()) {
reset_();
contnu = FALSE_;
} else {
segfnd = cardd_(intsct) > 0;
}
} else if (s_cmp(option, "BY_SCLK_INTERVAL", (ftnlen)20, (
ftnlen)16) == 0) {
/* Create an interval out of the epochs in the */
/* segment. */
if (missin == segins / 1000) {
sct2e_(&missin, &segbtm, &beget);
sct2e_(&missin, &segetm, &endet);
wninsd_(&beget, &endet, segint);
/* Intersect it with the input interval. */
wnintd_(segint, intrvl, intsct);
if (failed_()) {
reset_();
contnu = FALSE_;
} else {
segfnd = cardd_(intsct) > 0;
}
} else {
segfnd = FALSE_;
}
}
if (contnu && segfnd) {
anyseg = TRUE_;
/* Display the segment summary. */
writln_(sumsep, &c__6, (ftnlen)80);
if (*logfil) {
writln_(sumsep, loglun, (ftnlen)80);
}
ckwss_(&c__6, segid, &segins, &segfrm, &segtyp, &
segrts, &segbtm, &segetm, (ftnlen)40);
if (*logfil) {
ckwss_(loglun, segid, &segins, &segfrm, &segtyp, &
segrts, &segbtm, &segetm, (ftnlen)40);
}
writln_(sumsep, &c__6, (ftnlen)80);
if (*logfil) {
writln_(sumsep, loglun, (ftnlen)80);
}
}
/* Find that next segment. */
daffna_(&found);
if (failed_()) {
contnu = FALSE_;
}
}
}
/* Better say something if no segments were matching the */
/* search criteria were found. */
if (contnu && ! anyseg) {
s_copy(line, "No matching segments were found.", (ftnlen)255,
(ftnlen)32);
writln_(line, &c__6, (ftnlen)255);
if (*logfil) {
writln_(line, loglun, (ftnlen)255);
}
}
if (contnu) {
writln_(" ", &c__6, (ftnlen)1);
writln_(separ, &c__6, (ftnlen)80);
writln_(" ", &c__6, (ftnlen)1);
if (*logfil) {
writln_(" ", loglun, (ftnlen)1);
writln_(separ, loglun, (ftnlen)80);
writln_(" ", loglun, (ftnlen)1);
}
}
}
/* If anything failed, rset the error handling so that we can */
/* redisplay the menu and keep doing things. */
if (failed_()) {
reset_();
}
}
chkout_("SUMCK", (ftnlen)5);
return 0;
} /* sumck_ */
/* $Procedure SPASUM ( SPACIT, summarize binary file ) */
/* Subroutine */ int spasum_(logical *logfil, integer *loglun)
{
/* Initialized data */
static logical lpsldd = FALSE_;
static logical sclldd = FALSE_;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
char arch[3], line[255], type__[4];
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
logical ndlps;
extern /* Subroutine */ int sumck_(integer *, char *, char *, char *,
logical *, integer *, ftnlen, ftnlen, ftnlen), sumek_(integer *,
char *, logical *, integer *, ftnlen);
char prmpt[80];
extern logical failed_(void);
integer handle;
extern /* Subroutine */ int dafcls_(integer *);
char binfnm[128];
logical fileok;
extern /* Subroutine */ int getfat_(char *, char *, char *, ftnlen,
ftnlen, ftnlen), dafopr_(char *, integer *, ftnlen);
logical ndsclk;
extern /* Subroutine */ int dascls_(integer *);
static char sclfnm[128];
char bfstat[3];
extern /* Subroutine */ int dasopr_(char *, integer *, ftnlen), sigerr_(
char *, ftnlen);
char lfstat[3];
static char lpsfnm[128];
extern /* Subroutine */ int chkout_(char *, ftnlen), setmsg_(char *,
ftnlen), sumpck_(integer *, char *, char *, logical *, integer *,
ftnlen, ftnlen);
char sfstat[3];
extern /* Subroutine */ int furnsh_(char *, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int writln_(char *, integer *, ftnlen), sumspk_(
integer *, char *, char *, logical *, integer *, ftnlen, ftnlen),
getfnm_1__(char *, char *, char *, logical *, ftnlen, ftnlen,
ftnlen);
/* $ Abstract */
/* SPACIT utility subroutine used to summarize the segments in SPICE */
/* data kernel files. This subroutine is for use only be the SPACIT */
/* program. Use it at your own risk. */
/* $ 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 */
/* -------- --- -------------------------------------------------- */
/* LOGFIL I Logical flag indicating a log file is being kept. */
/* LOGLUN I The logical unit of the log file. */
/* $ Detailed_Input */
/* LOGFIL Logical flag indicating a log file is being kept. This */
/* Variable has the value of .TRUE. if a log file is being */
/* written, and a value of .FALSE. otherwise. */
/* LOGLUN The logical unit of the log file. If LOGFIL has the */
/* value .TRUE. then LOGLUN will be the Fortran logical */
/* unit of the log file. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Files */
/* None. */
/* $ Particulars */
/* xxx */
/* $ Examples */
/* xxx */
/* $ Restrictions */
/* xxx */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* K.R. Gehringer (JPL) */
/* $ Version */
/* - Beta Version 2.1.0, 02-OCT-2006 (BVS) */
/* Replaced LDPOOL with FURNSH. */
/* - Beta Version 2.0.0, 14-MAR-1997 (WLT) */
/* The routine was enhanced to provide a diagnostic in the */
/* event that the type of the file does belong to EK, CK, SPK */
/* or PCK */
/* - Beta Version 1.0.0, 11-JUL-1995 (KRG) */
/* -& */
/* $ Index_Entries */
/* spacit convert binary to transfer */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Set values for the NAIF SPICE file types */
/* Set a value for the logical unit which represents the standard */
/* output device, commonly a terminal. A value of 6 is widely used, */
/* but the Fortran standard does not specify a value, so it may be */
/* different for different Fortran implementations. */
/* Set a value for the length of an input text line. */
/* Set a value for the length of a filename. */
/* Set a length for the prompt. */
/* Set a length for the status of a file: 'OLD' or 'NEW'. */
/* Set the length for the type of a file. */
/* Set the length for the architecture of a file. */
/* Local variables */
/* Saved values */
/* Initial values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SPASUM", (ftnlen)6);
}
s_copy(bfstat, "OLD", (ftnlen)3, (ftnlen)3);
fileok = FALSE_;
s_copy(prmpt, " Binary file : ", (ftnlen)80, (ftnlen)21);
getfnm_1__(prmpt, bfstat, binfnm, &fileok, (ftnlen)80, (ftnlen)3, (ftnlen)
128);
if (failed_()) {
chkout_("SPASUM", (ftnlen)6);
return 0;
}
getfat_(binfnm, arch, type__, (ftnlen)128, (ftnlen)3, (ftnlen)4);
if (failed_()) {
chkout_("SPASUM", (ftnlen)6);
return 0;
}
if (s_cmp(arch, "?", (ftnlen)3, (ftnlen)1) == 0 || s_cmp(type__, "?", (
ftnlen)4, (ftnlen)1) == 0) {
setmsg_("The architecture and type of the file '#' could not be dete"
"rmined.", (ftnlen)66);
errch_("#", binfnm, (ftnlen)1, (ftnlen)128);
sigerr_("SPICE(BADFILEFORMAT)", (ftnlen)20);
chkout_("SPASUM", (ftnlen)6);
return 0;
} else if (s_cmp(arch, "DAF", (ftnlen)3, (ftnlen)3) != 0 && s_cmp(arch,
"DAS", (ftnlen)3, (ftnlen)3) != 0) {
setmsg_("The file '#' was not a binary SPICE file. In order to summa"
"rize a file it must be a binary CK, EK, PCK, or SPK file.", (
ftnlen)116);
errch_("#", binfnm, (ftnlen)1, (ftnlen)128);
sigerr_("SPICE(IMPROPERFILE)", (ftnlen)19);
chkout_("SPASUM", (ftnlen)6);
return 0;
}
if (s_cmp(type__, "PRE", (ftnlen)4, (ftnlen)3) == 0) {
s_copy(type__, "EK", (ftnlen)4, (ftnlen)2);
}
if (lpsldd || s_cmp(type__, "EK", (ftnlen)4, (ftnlen)2) == 0) {
ndlps = FALSE_;
} else {
ndlps = TRUE_;
}
ndsclk = FALSE_;
if (! sclldd && s_cmp(type__, "CK", (ftnlen)4, (ftnlen)2) == 0) {
ndsclk = TRUE_;
}
if (ndlps) {
s_copy(lfstat, "OLD", (ftnlen)3, (ftnlen)3);
fileok = FALSE_;
s_copy(prmpt, " Leapseconds file: ", (ftnlen)80, (ftnlen)21);
getfnm_1__(prmpt, lfstat, lpsfnm, &fileok, (ftnlen)80, (ftnlen)3, (
ftnlen)128);
if (failed_()) {
chkout_("SPASUM", (ftnlen)6);
return 0;
}
}
if (ndsclk) {
s_copy(sfstat, "OLD", (ftnlen)3, (ftnlen)3);
fileok = FALSE_;
s_copy(prmpt, " SCLK file : ", (ftnlen)80, (ftnlen)21);
getfnm_1__(prmpt, sfstat, sclfnm, &fileok, (ftnlen)80, (ftnlen)3, (
ftnlen)128);
if (failed_()) {
chkout_("SPASUM", (ftnlen)6);
return 0;
}
}
writln_(" ", &c__6, (ftnlen)1);
if (ndlps) {
s_copy(line, " Loading the Leapseconds kernel file. Please wait ..."
, (ftnlen)255, (ftnlen)55);
writln_(line, &c__6, (ftnlen)255);
furnsh_(lpsfnm, (ftnlen)128);
if (failed_()) {
chkout_("SPASUM", (ftnlen)6);
return 0;
}
lpsldd = TRUE_;
}
if (ndsclk) {
s_copy(line, " Loading the SCLK kernel file. Please wait ...", (
ftnlen)255, (ftnlen)48);
writln_(line, &c__6, (ftnlen)255);
furnsh_(sclfnm, (ftnlen)128);
if (failed_()) {
chkout_("SPASUM", (ftnlen)6);
return 0;
}
sclldd = TRUE_;
}
writln_(" ", &c__6, (ftnlen)1);
if (*logfil) {
writln_(" ", loglun, (ftnlen)1);
}
if (s_cmp(type__, "CK", (ftnlen)4, (ftnlen)2) == 0) {
/* Summarize a binary CK file. */
dafopr_(binfnm, &handle, (ftnlen)128);
if (failed_()) {
chkout_("SPASUM", (ftnlen)6);
return 0;
}
sumck_(&handle, binfnm, lpsfnm, sclfnm, logfil, loglun, (ftnlen)128, (
ftnlen)128, (ftnlen)128);
dafcls_(&handle);
} else if (s_cmp(type__, "SPK", (ftnlen)4, (ftnlen)3) == 0) {
/* Summarize a binary SPK file. */
dafopr_(binfnm, &handle, (ftnlen)128);
if (failed_()) {
chkout_("SPASUM", (ftnlen)6);
return 0;
}
sumspk_(&handle, binfnm, lpsfnm, logfil, loglun, (ftnlen)128, (ftnlen)
128);
dafcls_(&handle);
} else if (s_cmp(type__, "PCK", (ftnlen)4, (ftnlen)3) == 0) {
/* Summarize a binary PCK file. */
dafopr_(binfnm, &handle, (ftnlen)128);
if (failed_()) {
chkout_("SPASUM", (ftnlen)6);
return 0;
}
sumpck_(&handle, binfnm, lpsfnm, logfil, loglun, (ftnlen)128, (ftnlen)
128);
dafcls_(&handle);
} else if (s_cmp(type__, "EK", (ftnlen)4, (ftnlen)2) == 0) {
/* Summarize a binary EK file. */
dasopr_(binfnm, &handle, (ftnlen)128);
sumek_(&handle, binfnm, logfil, loglun, (ftnlen)128);
dascls_(&handle);
} else {
setmsg_("The specified file is not of a \"type\" that can be summari"
"zed. The types of files that can be summarized are: CK, EK, "
"PCK, and SPK. According to the type in the internal id-word"
" of the file, this file has type: '#'. You will need to get"
" an upgrade of SPACIT to summarize this file. ", (ftnlen)283);
errch_("#", type__, (ftnlen)1, (ftnlen)4);
sigerr_("SPICE(UNKNOWNTYPE)", (ftnlen)18);
chkout_("SPASUM", (ftnlen)6);
return 0;
}
chkout_("SPASUM", (ftnlen)6);
return 0;
} /* spasum_ */
/* $Procedure GETFNM_1 ( Get a filename from standard input ) */
/* Subroutine */ int getfnm_1__(char *prmpt, char *fstat, char *fname,
logical *valid, ftnlen prmpt_len, ftnlen fstat_len, ftnlen fname_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
address a__1[2];
integer i__1, i__2[2];
char ch__1[1], ch__2[81];
/* 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 */
extern integer cpos_(char *, char *, integer *, ftnlen, ftnlen);
integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen), errch_(char *, char *, ftnlen, ftnlen), reset_(
void);
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
static char badchr[162];
extern logical failed_(void);
char oldact[10];
extern /* Subroutine */ int cnfirm_(char *, logical *, ftnlen), erract_(
char *, char *, ftnlen, ftnlen);
integer length;
extern integer lastnb_(char *, ftnlen);
char myfnam[1000];
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen);
logical tryagn, myvlid;
extern logical exists_(char *, ftnlen), return_(void);
extern /* Subroutine */ int prompt_(char *, char *, ftnlen, ftnlen),
writln_(char *, integer *, ftnlen);
char status[3], myprmt[80];
/* $ Abstract */
/* This routine prompts the user for a valid filename. */
/* $ 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 */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* PRMPT I The prompt to use when asking for the filename. */
/* FSTAT I Status of the file: 'OLD' or 'NEW'. */
/* FNAME O A valid filename typed in by the user. */
/* VALID O A logical flag indicating a valid filename. */
/* PRMLEN P Maximum length allowed for a prompt before */
/* truncation. */
/* $ Detailed_Input */
/* PRMPT is a character string that will be displayed from the */
/* current cursor position that informs a user that input */
/* is expected. Prompts should be fairly short, since we */
/* need to declare some local storage. The current maximum */
/* length of a prompt is given by the parameter PRMLEN. */
/* FSTAT This is the status of the filename entered. It should */
/* be 'OLD' when prompting for the filename of a file which */
/* already exists, and 'NEW' when prompting for the */
/* filename of a file which does not already exist or is to */
/* be over written. */
/* $ Detailed_Output */
/* FNAME is a character string that contains a valid filename */
/* typed in by the user. A valid filename is defined */
/* simply to be a nonblank character string with no */
/* embedded blanks, nonprinting characters, or characters */
/* having decimal values > 126. */
/* VALID A logical flag which indicates whether or not the */
/* filename entered is valid, i.e., a nonblank character */
/* string with no leading or embedded blanks, which */
/* satisfies the constraints for validity imposed. */
/* $ Parameters */
/* PRMLEN The maximum length for an input prompt string. */
/* $ Exceptions */
/* 1) If the input file status is not equal to 'NEW' or 'OLD' after */
/* being left justified and converted to upper case, the error */
/* SPICE(INVALIDARGUMENT) will be signalled. The error handling */
/* is then reset. */
/* 2) If the filename entered at the prompt is blank, the error */
/* SPICE(BLANKFILENAME) will be signalled. The error handling is */
/* then reset. */
/* 3) If the filename contains an illegal character, a nonprinting */
/* character or embedded blanks, the error */
/* SPICE(ILLEGALCHARACTER) will be signalled. */
/* 4) If the file status is equal to 'OLD' after being left */
/* justified and converted to upper case and the file specified */
/* by the filename entered at the prompt does not exist, the */
/* error SPICE(FILEDOESNOTEXIST) will be signalled. */
/* 5) If the file status is equal to 'NEW' after being left */
/* justified and converted to upper case and the file specified */
/* by the filename entered at the prompt already exists, the */
/* error SPICE(FILEALREADYEXISTS) will be signalled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This is a utility that allows you to "easily" request a valid, */
/* filename from a program user. At a high level, it frees you */
/* from the peculiarities of a particular FORTRAN's implementation */
/* of cursor control. */
/* A valid filename is defined as a nonblank character string with */
/* no embedded blanks, nonprinting characters, or characters with */
/* decimal values > 126. Leading blanks are removed, and trailing */
/* blanks are ignored. */
/* If an invalid filename is entered, this routine provides a */
/* descriptive error message and halts the execution of the */
/* process which called it by using a Fortran STOP. */
/* $ Examples */
/* EXAMPLE 1: */
/* FNAME = ' ' */
/* PRMPT = 'Filename? ' */
/* FSTAT = 'OLD' */
/* CALL GETFNM_1( PRMPT, FSTAT, FNAME, VALID ) */
/* The user sees the following displayed on the screen: */
/* Filename? _ */
/* where the underbar, '_', represents the cursor position. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* $ Version */
/* - SPICELIB Version 6.17.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 6.16.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 6.15.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 6.14.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 6.13.0, 14-DEC-2010 (EDW) */
/* Declared PROMPT as EXTERNAL. */
/* Unfied Version and Revision sections, eliminated Revision */
/* section. Corrected error in 09-DEC-1999 Version entry. */
/* Version ID changed to 6.0.9 from 7.0.0. */
/* - Beta Version 6.12.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - Beta Version 6.11.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - Beta Version 6.10.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - Beta Version 6.9.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - Beta Version 6.8.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - Beta Version 6.7.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - Beta Version 6.6.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - Beta Version 6.5.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - Beta Version 6.4.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - Beta Version 6.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - Beta Version 6.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - Beta Version 6.1.1, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - Beta Version 6.1.0, 16-AUG-2000 (WLT) */
/* Added PC-LINUX environment */
/* - Beta Version 6.0.9, 09-DEC-1999 (WLT) */
/* This routine now calls EXPFNM_2 only UNIX environments */
/* - Beta Version 6.0.0, 20-JAN-1998 (NJB) */
/* Now calls EXPFNM_2 to attempt to expand environment variables. */
/* Fixed a typo or two at various places in the header. */
/* - Beta Version 5.1.0, 31-JAN-1996 (KRG) */
/* Fixed a pedantic Fortran syntax error dealing with input */
/* strings that are dimensioned CHARACTER*(*). */
/* A local character string is now declared, and a parameter, */
/* PRMLEN, has been added to the interface description for this */
/* subroutine. PRMLEN defines the maximum length allowed for a */
/* prompt before it is truncated. */
/* - Beta Version 5.0.0, 05-JUL-1995 (KRG) */
/* Modified the routine to handle all of its own error messages */
/* and error conditions. The routine now signals an error */
/* immediately resetting the error handling when an exceptional */
/* condition is encountered. This is done so that input attempts */
/* may continue until a user decides to stop trying. */
/* Added several exceptions to the $ Exceptions section of the */
/* header. */
/* - Beta Version 4.0.1, 25-APR-1994 (KRG) */
/* Removed some incorrect comments from the $ Particulars section */
/* of the header. Something about a looping structure that is not */
/* a part of the code now, if it ever was. */
/* Fixed a typo or two at various places in the header. */
/* - Beta Version 4.0.0, 29-SEP-1993 (KRG) */
/* Added the character reperesnted by decimal 127 to the BADCHR. */
/* It should have been there, but it wasn't. */
/* - Beta Version 3.0.0, 10-SEP-1993 (KRG) */
/* Made the file status variable FSTAT case insensitive. */
/* Added code to the file status .EQ. 'NEW' case to set the */
/* valid flag to .FALSE. and set an appropriate error message */
/* about the file already existing. */
/* - Beta Version 2.0.0, 02-APR-1993 (KRG) */
/* The variable BADCHR was not saved which caused problems on */
/* some computers. This variable is now saved. */
/* - Beta Version 1.0.0, 01-JUN-1992 (KRG) */
/* -& */
/* $ Index_Entries */
/* prompt for a filename with error handling */
/* -& */
/* SPICELIB Functions */
/* Local Parameters */
/* Maximum length of a filename. */
/* Length of an error action */
/* Local Variables */
/* Saved Variables */
/* Initial Values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("GETFNM_1", (ftnlen)8);
}
/* We are going to be signalling errors and resetting the error */
/* handling, so we need to be in RETURN mode. First we get the */
/* current mode and save it, then we set the mode to return. Upon */
/* leaving the subroutine, we will restore the error handling mode */
/* that was in effect when we entered. */
erract_("GET", oldact, (ftnlen)3, (ftnlen)10);
erract_("SET", "RETURN", (ftnlen)3, (ftnlen)6);
/* If this is the first time this routine has been called, */
/* initialize the ``bad character'' string. */
if (first) {
first = FALSE_;
for (i__ = 0; i__ <= 32; ++i__) {
i__1 = i__;
*(unsigned char *)&ch__1[0] = i__;
s_copy(badchr + i__1, ch__1, i__ + 1 - i__1, (ftnlen)1);
}
for (i__ = 1; i__ <= 129; ++i__) {
i__1 = i__ + 32;
*(unsigned char *)&ch__1[0] = i__ + 126;
s_copy(badchr + i__1, ch__1, i__ + 33 - i__1, (ftnlen)1);
}
}
/* Left justify and convert the file status to upper case for */
/* comparisons. */
ljust_(fstat, status, fstat_len, (ftnlen)3);
ucase_(status, status, (ftnlen)3, (ftnlen)3);
/* Check to see if we have a valid status for the filename. */
if (s_cmp(status, "OLD", (ftnlen)3, (ftnlen)3) != 0 && s_cmp(status,
"NEW", (ftnlen)3, (ftnlen)3) != 0) {
setmsg_("The file status '#' was not valid. The file status must hav"
"e a value of 'NEW' or 'OLD'.", (ftnlen)87);
errch_("#", status, (ftnlen)1, (ftnlen)3);
sigerr_("SPICE(INVALIDARGUMENT)", (ftnlen)22);
chkout_("GETFNM_1", (ftnlen)8);
return 0;
}
/* Store the input value for the prompt into our local value. We do */
/* this for pedantic Fortran compilers that issue warnings for */
/* CHARACTER*(*) variables used with concatenation. */
s_copy(myprmt, prmpt, (ftnlen)80, prmpt_len);
/* Read in a potential filename, and test it for validity. */
tryagn = TRUE_;
while(tryagn) {
/* Set the value of the valid flag to .TRUE.. We assume that the */
/* name entered will be a valid one. */
myvlid = TRUE_;
/* Get the filename. */
if (s_cmp(myprmt, " ", (ftnlen)80, (ftnlen)1) == 0) {
prompt_("Filename? ", myfnam, (ftnlen)10, (ftnlen)1000);
} else {
/* Writing concatenation */
i__2[0] = lastnb_(myprmt, (ftnlen)80), a__1[0] = myprmt;
i__2[1] = 1, a__1[1] = " ";
s_cat(ch__2, a__1, i__2, &c__2, (ftnlen)81);
prompt_(ch__2, myfnam, lastnb_(myprmt, (ftnlen)80) + 1, (ftnlen)
1000);
}
if (failed_()) {
myvlid = FALSE_;
}
if (myvlid) {
if (s_cmp(myfnam, " ", (ftnlen)1000, (ftnlen)1) == 0) {
myvlid = FALSE_;
setmsg_("The filename entered was blank.", (ftnlen)31);
sigerr_("SPICE(BLANKFILENAME)", (ftnlen)20);
}
}
if (myvlid) {
/* Left justify the filename. */
ljust_(myfnam, myfnam, (ftnlen)1000, (ftnlen)1000);
/* Check for bad characters in the filename. */
length = lastnb_(myfnam, (ftnlen)1000);
i__ = cpos_(myfnam, badchr, &c__1, length, (ftnlen)162);
if (i__ > 0) {
myvlid = FALSE_;
setmsg_("The filename entered contains non printing characte"
"rs or embedded blanks.", (ftnlen)73);
sigerr_("SPICE(ILLEGALCHARACTER)", (ftnlen)23);
}
}
if (myvlid) {
/* We know that the filename that was entered was nonblank and */
/* had no bad characters. So, now we take care of the status */
/* question. */
if (s_cmp(status, "OLD", (ftnlen)3, (ftnlen)3) == 0) {
if (! exists_(myfnam, rtrim_(myfnam, (ftnlen)1000))) {
myvlid = FALSE_;
setmsg_("A file with the name '#' does not exist.", (
ftnlen)40);
errch_("#", myfnam, (ftnlen)1, (ftnlen)1000);
sigerr_("SPICE(FILEDOESNOTEXIST)", (ftnlen)23);
}
} else if (s_cmp(status, "NEW", (ftnlen)3, (ftnlen)3) == 0) {
if (exists_(myfnam, rtrim_(myfnam, (ftnlen)1000))) {
myvlid = FALSE_;
setmsg_("A file with the name '#' already exists.", (
ftnlen)40);
errch_("#", myfnam, (ftnlen)1, (ftnlen)1000);
sigerr_("SPICE(FILEALREADYEXISTS)", (ftnlen)24);
}
}
}
if (myvlid) {
tryagn = FALSE_;
} else {
writln_(" ", &c__6, (ftnlen)1);
cnfirm_("Try again? (Yes/No) ", &tryagn, (ftnlen)20);
writln_(" ", &c__6, (ftnlen)1);
if (tryagn) {
reset_();
}
}
}
/* At this point, we have done the best we can. If the status */
/* was new, we might still have an invalid filename, but the */
/* exact reasons for its invalidity are system dependent, and */
/* therefore hard to test. */
*valid = myvlid;
if (*valid) {
s_copy(fname, myfnam, fname_len, rtrim_(myfnam, (ftnlen)1000));
}
/* Restore the error action. */
erract_("SET", oldact, (ftnlen)3, (ftnlen)10);
chkout_("GETFNM_1", (ftnlen)8);
return 0;
} /* getfnm_1__ */
