/* $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_ */
/* Subroutine */ int rdstmn_(char *prmpt, char *delim, char *stmt, ftnlen
prmpt_len, ftnlen delim_len, ftnlen stmt_len)
{
/* Initialized data */
static char blank[132] = " "
" "
" ";
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen), i_indx(char *, char *,
ftnlen, ftnlen);
/* Local variables */
char line[132];
extern logical batch_(void);
char space[1];
integer prlen;
extern integer rtrim_(char *, ftnlen);
char myprm[132];
extern /* Subroutine */ int replch_(char *, char *, char *, char *,
ftnlen, ftnlen, ftnlen, ftnlen), suffix_(char *, integer *, char *
, ftnlen, ftnlen), prompt_(char *, char *, ftnlen, ftnlen);
char tab[1];
integer end;
/* Read a statement entered on one or more lines. */
/* VARIABLE I/O DESCRIPTION */
/* PRMPT I Prompt for input. If PRMPT is not blank, */
/* the cursor is positioned one space after the */
/* last non-blank character. Successive lines */
/* are indented by the length of PRMPT. */
/* DELIM I Statement delimiter. RDSTMN will continue */
/* to read until the either the delimiter or */
/* a blank line is entered. */
/* STMT O The statement entered, up to but not */
/* including the delimiter. If RDSTMN is */
/* terminated by the entry of a blank line, */
/* STMT is blank. */
/* $ Version */
/* - Command Loop Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 4, 1994 */
/* 7 February 1986, I.M. Underwood */
/* - */
/* SPICELIB functions */
/* Local variables */
/* Read the first statement. Use the prompt. Return immediately */
/* if a blank line or an error is encountered. */
if (batch_()) {
s_copy(stmt, " ", stmt_len, (ftnlen)1);
return 0;
}
prlen = rtrim_(prmpt, prmpt_len) + 1;
s_copy(myprm, prmpt, (ftnlen)132, prmpt_len);
s_copy(line, " ", (ftnlen)132, (ftnlen)1);
*(unsigned char *)space = ' ';
*(unsigned char *)tab = '\t';
prompt_(myprm, line, prlen, (ftnlen)132);
if (s_cmp(line, " ", (ftnlen)132, (ftnlen)1) == 0) {
s_copy(stmt, " ", stmt_len, (ftnlen)1);
return 0;
} else {
s_copy(stmt, line, stmt_len, (ftnlen)132);
}
/* Get rid of any of those nasty old tabs. */
replch_(line, tab, space, line, (ftnlen)132, (ftnlen)1, (ftnlen)1, (
ftnlen)132);
/* Read succeeding lines. Indent to the length of the original */
/* prompt. Add the input line to the current statement. Quit when: */
/* - A delimiter is encountered. (Return the statement */
/* up to the delimiter.) */
/* - A blank line or an error is encountered. (Return */
/* a blank statement.) */
while(i_indx(stmt, delim, stmt_len, (ftnlen)1) == 0) {
prompt_(blank, line, prlen, (ftnlen)132);
replch_(line, tab, space, line, (ftnlen)132, (ftnlen)1, (ftnlen)1, (
ftnlen)132);
if (s_cmp(line, " ", (ftnlen)132, (ftnlen)1) == 0) {
s_copy(stmt, " ", stmt_len, (ftnlen)1);
return 0;
} else {
suffix_(line, &c__1, stmt, (ftnlen)132, stmt_len);
}
}
/* If we made it to here, we encountered a delimiter. Take the */
/* entire statement up to the character before the delimiter. */
end = i_indx(stmt, delim, stmt_len, (ftnlen)1);
s_copy(stmt + (end - 1), " ", stmt_len - (end - 1), (ftnlen)1);
return 0;
} /* rdstmn_ */
/* $Procedure CNFIRM_1 ( Return status of a yes/no query ) */
/* Subroutine */ int cnfirm_1__(char *prmpt, logical *torf, ftnlen prmpt_len)
{
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
logical yesno;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
char respns[256];
extern /* Subroutine */ int prompt_(char *, char *, ftnlen, ftnlen);
/* $ Abstract */
/* Return the .TRUE./.FALSE. status of a query which has a yes/no */
/* response. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* PARSING */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* PRMPT I The prompt used to elicit a yes/no response. */
/* TORF O The truth value of a yes/no response. */
/* $ Detailed_Input */
/* PRMPT The prompt which is used to elicit a yes/no response. */
/* $ Detailed_Output */
/* TORF A logical flag which indicates the truth value of a */
/* yes/no response to a continue/try again prompt. If the */
/* response was equivalent to yes, TORF = .TRUE.. If the */
/* response was equivalent to no, TORF = .FALSE.. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* 1) Any input value that is not equivalent to 'Y', 'YES', 'N' */
/* or 'NO' (or lower case equivalents), will cause the routine */
/* to redisplay the prompt. A yes/no response MUST be given, */
/* there are no implicit values for any other response. */
/* $ Files */
/* None. */
/* $ Particulars */
/* Often a program needs to ask whether or not a user wishes */
/* to exercise some option. This routine simplifies the task */
/* of converting the answer to a logical value. */
/* If the response to a yes/no question is logically equivalent */
/* to 'YES' the variable TORF will be set to a value of .TRUE. */
/* If the response to a yes/no question is logically equivalent */
/* to 'NO' the variable TORF will be set to a value of .FALSE. */
/* Any other response will cause the routine to redisplay the */
/* prompt. */
/* $ Examples */
/* Suppose you need to ask a user whether or not diagnostic */
/* information about the behaviour of a program should be */
/* written to a file. Using this routine, you can easily */
/* take the action desired and avoid the details of parsing */
/* the user's answer. */
/* PRMPT = 'Log information to a file? (Yes/No) ' */
/* OK = .FALSE. */
/* CALL CONFRM( PRMPT, OK ) */
/* IF ( OK ) THEN */
/* ...enable recording diagnostics in the log file. */
/* ELSE */
/* ...disable recording of diagnostics. */
/* END IF */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - META/2 Configured Version 2.0.0, 9-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 9, 1994 */
/* - META/2 Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of META/2 */
/* software as of May 3, 1994 */
/* - Beta Version 1.0.0, 09-SEP-1992 (KRG) */
/* -& */
/* $ Index_Entries */
/* prompt with a yes/no query and return logical response */
/* -& */
/* SPICELIB functions */
/* None. */
/* Local Parameters */
/* Local Variables */
/* Do while we have not gotten a yes/no response */
yesno = FALSE_;
while(! yesno) {
/* Prompt for a response */
prompt_(prmpt, respns, prmpt_len, (ftnlen)256);
/* Left justify the response string, RESPNS, and convert it to */
/* uppercase. */
ljust_(respns, respns, (ftnlen)256, (ftnlen)256);
ucase_(respns, respns, (ftnlen)256, (ftnlen)256);
if (s_cmp(respns, "Y", (ftnlen)256, (ftnlen)1) == 0 || s_cmp(respns,
"YES", (ftnlen)256, (ftnlen)3) == 0) {
*torf = TRUE_;
yesno = TRUE_;
} else if (s_cmp(respns, "N", (ftnlen)256, (ftnlen)1) == 0 || s_cmp(
respns, "NO", (ftnlen)256, (ftnlen)2) == 0) {
*torf = FALSE_;
yesno = TRUE_;
}
}
return 0;
} /* cnfirm_1__ */
/* $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__ */
