コード例 #1
0
ファイル: spca2b.c プロジェクト: Dbelsa/coft
/* $Procedure SPCA2B ( SPK and CK, ASCII to binary ) */
/* Subroutine */ int spca2b_(char *text, char *binary, ftnlen text_len, 
	ftnlen binary_len)
{
    /* System generated locals */
    cllist cl__1;

    /* Builtin functions */
    integer f_clos(cllist *);

    /* Local variables */
    integer unit;
    extern /* Subroutine */ int chkin_(char *, ftnlen), spct2b_(integer *, 
	    char *, ftnlen), chkout_(char *, ftnlen);
    extern logical return_(void);
    extern /* Subroutine */ int txtopr_(char *, integer *, ftnlen);

/* $ Abstract */

/*     Convert a text (ASCII) format SPK or CK file to an equivalent */
/*     binary file, including comments. */

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

/*     SPC */

/* $ Keywords */

/*     FILES */

/* $ Declarations */
/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     TEXT       I   Name of an existing text format SPK or CK file. */
/*     BINARY     I   Name of a binary SPK or CK file to be created. */

/* $ Detailed_Input */

/*     TEXT        is the name of an existing text format SPK or CK */
/*                 file that may contain comments in the appropriate */
/*                 SPC format, as written by SPCB2A or SPCB2T.  This */
/*                 file is unchanged by calling SPCA2B. */

/*     BINARY      is the name of a binary SPK or CK file to be created. */
/*                 The binary file contains the same data and comments */
/*                 as the text file, but in the binary format required */
/*                 for use with the SPICELIB reader subroutines. */

/* $ Detailed_Output */

/*     None. */

/* $ Parameters */

/*     None. */

/* $ Files */

/*     See arguments TEXT and BINARY above. */

/* $ Exceptions */

/*     1) If there is an IOSTAT error while opening, reading, */
/*        or writing a file, a routine that SPCA2B calls will */
/*        diagnose and signal an error. */

/*     2) If the text file is not in the correct format, a */
/*        routine that SPCA2B calls will diagnose and signal */
/*        an error. */

/* $ Particulars */

/*     The SPICELIB SPK and CK reader subroutines read binary files. */
/*     However, because different computing environments have different */
/*     binary representations of numbers, you must convert SPK and CK */
/*     files to text format when porting from one system to another. */
/*     After converting the file to text, you can transfer it using */
/*     a transfer protocol program like Kermit or FTP.  Then, convert */
/*     the text file back to binary format. */

/*     The following is a list of the SPICELIB routines that convert */
/*     SPK and CK files between binary and text format: */

/*        SPCA2B    converts text to binary.  It opens the text file, */
/*                  creates a new binary file, and closes both files. */

/*        SPCB2A    converts binary to text.  It opens the binary file, */
/*                  creates a new text file, and closes both files. */

/*        SPCT2B    converts text to binary.  It creates a new binary */
/*                  file and closes it.  The text file is open on */
/*                  entrance and exit. */

/*        SPCB2T    converts binary to text.  It opens the binary */
/*                  file and closes it.  The text file is open on */
/*                  entrance and exit */

/*     See the SPC required reading for more information */
/*     about SPC routines and the SPK and CK file formats. */

/* $ Examples */

/*     This is an example of how to use SPCB2A and SPCA2B for */
/*     transferring files.  Suppose A.BSP is a binary SPK file in */
/*     environment 1; to transfer it to environment 2, follow */
/*     these three steps: */

/*        1) Call SPCB2A within a program in environment 1 to convert */
/*           the file to text: */

/*              CALL SPCB2A ( 'A.BSP', 'A.TSP' ) */

/*        2) Transfer the text file from environment 1 to environment 2 */
/*           using FTP, Kermit, or some other file transfer utility, */
/*           for example, */

/*              ftp> put A.TSP */

/*        3) Call SPCA2B within a program in environment 2 to convert */
/*           the file to binary on the new machine, */

/*              CALL SPCA2B ( 'A.TSP', 'A.BSP' ) */

/* $ Restrictions */

/*     1)  This routine assumes that the data and comments in the */
/*         text format SPK or CK file come from a binary file */
/*         and were written by one of the routines SPCB2A or SPCB2T. */
/*         Data and/or comments written any other way may not be */
/*         in the correct format and, therefore, may not be handled */
/*         properly. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     J.E. McLean    (JPL) */
/*     H.A. Neilan    (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.1.1, 10-MAR-1992 (WLT) */

/*        Comment section for permuted index source lines was added */
/*        following the header. */

/* -    SPICELIB Version 1.1.0, 05-SEP-1991 (HAN) */

/*        Removed declarations of unused variables. */

/* -    SPICELIB Version 1.0.0, 05-APR-1991 (JEM) */

/* -& */
/* $ Index_Entries */

/*     ascii spk or ck to binary */

/* -& */

/*     SPICELIB functions */


/*     Local parameters */

/*     Local variables */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    } else {
	chkin_("SPCA2B", (ftnlen)6);
    }

/*     Open the text file with read access.  SPCT2B will */
/*     create the binary file and write the data and comments */
/*     to it.  Then we close the text file, and we're done. */

    txtopr_(text, &unit, text_len);
    spct2b_(&unit, binary, binary_len);
    cl__1.cerr = 0;
    cl__1.cunit = unit;
    cl__1.csta = 0;
    f_clos(&cl__1);
    chkout_("SPCA2B", (ftnlen)6);
    return 0;
} /* spca2b_ */
コード例 #2
0
/* Subroutine */ int prcomf_0_(int n__, char *file, char *delim, char *
	command, char *error, char *level, ftnlen file_len, ftnlen delim_len, 
	ftnlen command_len, ftnlen error_len, ftnlen level_len)
{
    /* Initialized data */

    static integer nest = 0;

    /* System generated locals */
    integer i__1;
    cilist ci__1;
    cllist cl__1;

    /* Builtin functions */
    integer s_rnge(char *, integer, char *, integer), f_clos(cllist *);
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
    integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
	     i_indx(char *, char *, ftnlen, ftnlen);

    /* Local variables */
    extern logical have_(char *, ftnlen);
    static integer i__, j;
    static char files[80*8];
    static integer units[8];
    extern /* Subroutine */ int lbuild_(char *, integer *, char *, char *, 
	    ftnlen, ftnlen, ftnlen);
    extern integer lastnb_(char *, ftnlen);
    static integer iostat;
    extern /* Subroutine */ int rstbuf_(void), putbuf_(char *, ftnlen), 
	    txtopr_(char *, integer *, ftnlen);


/* $ Abstract */

/*     Keep track of nested command files. */

/* $ Disclaimer */

/*     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/*     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/*     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/*     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/*     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/*     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/*     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/*     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/*     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/*     SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */

/*     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/*     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/*     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/*     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/*     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/*     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */

/*     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/*     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/*     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/*     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */

/* $ Keywords */

/*     PARSE */

/* $ Declarations */
/* $ Brief_I/O */

/*     VARIABLE  I/O  DESCRIPTION */
/*     --------  ---  --------------------------------------------------- */
/*     FILE       I   Command file. */
/*     DELIM      I   Symbol delimiting the end of a command. */
/*     COMMAND    O   Command read from FILE. */
/*     ERROR      O   Error flag. */
/*     LEVEL      O   A list of all files currently open. */

/* $ Detailed_Input */

/*     FILE       is the name of a file from which a sequence of commands */
/*                is to be read. These commands may include commands to */
/*                read from other files. */

/*     DELIM      is the character which delimits the end of each */
/*                instruction in FILE. */

/* $ Detailed_Output */

/*     COMMAND    is a command read from the current file. */
/*                If no files are currently open, COMMAND = DELIM. */

/*     ERROR      is a descriptive error message, which is blank when */
/*                no error occurs. */

/*     LEVEL      is a list of the files currently open, in the order */
/*                in which they were opened. It is provided for trace- */
/*                back purposes. */

/* $ Detailed_Description */

/*     PRCOMF opens, reads, and closes sets of (possibly nested) */
/*     command files. For example, consider the following command */
/*     files. */

/*        FILE_A : A1             FILE_B : B1               FILE_C : C1 */
/*                 A2                      START FILE_C              C2 */
/*                 A3                      B2                        C3 */
/*                 START FILE_B            B3 */
/*                 A4                      B4 */
/*                 A5 */

/*     If the command 'START FILE_A' were issued, we would expect the */
/*     following sequence of commands to ensue: */

/*        A1, A2, A3, B1, C1, C2, C3, B2, B3, B4, A4, A5. */

/*     The first file immediately becomes, ipso facto, the current file. */
/*     Subsequently, instructions are read from the current file until */
/*     either a START or the end of the file is encountered. Each time */
/*     a new START is encountered, the current file (that is, the */
/*     location of the next command in the file) is placed on a stack, */
/*     and the first command is read from the new file (which then */
/*     becomes the current file). Each time the end of the current file */
/*     is encountered, the previous file is popped off the top of the */
/*     stack to become the current file. This continues until there are */
/*     no files remaining on the stack. */

/*     On occasion, the user may wish to exit from a file without */
/*     reading the rest of the file. In this case, the previous file */
/*     is popped off the stack without further ado. */

/*     Also, the user may wish to abruptly stop an entire nested */
/*     set of files. In this case, all of the files are popped off */
/*     the stack, and no further commands are returned. */

/*     PRCOMF and its entry points may be used to process any such */
/*     set of files. These entry points are: */

/*        - PRCLR ( ERROR ) */

/*          This clears the stack. It may thus be used to implement */
/*          a STOP command. In any case, it must be called before */
/*          any of the other entry points are called. */

/*        - PRSTRT ( FILE, ERROR ) */

/*          This introduces a new file, causing the current file (if */
/*          any) to be placed on the stack, and replacing it with FILE. */
/*          It may thus be used to implement a START command. */

/*          If the file cannot be opened, or the stack is already */
/*          full (it can hold up to seven files), ERROR will contain */
/*          a descriptive error message upon return. Otherwise, it */
/*          will be blank. */

/*        - PRREAD ( COMMAND ) */

/*          This causes the next command to be read from the current */
/*          file. If the end of the current file is reached, the */
/*          previous file is popped off the stack, and the next command */
/*          from this file is read instead. (If no files remain to be */
/*          read, DELIM is returned.) */

/*        - PREXIT */

/*          This causes the previous file to be popped off the top of */
/*          the stack to replace the current file. It may thus be used */
/*          to implement an EXIT command. */

/*        - PRTRCE ( LEVEL ) */

/*          Should an error occur during the execution of a nested */
/*          file, it may be helpful to know the sequence in which */
/*          the nested files were invoked. PRTRCE returns a list of */
/*          the files currently open, in the order in which they were */
/*          invoked. */

/* $ Input_Files */

/*     All files read by PRCOMF are opened with logical units */
/*     determined at run time. */

/* $ Output_Files */

/*     None. */

/* $ Input_Common */

/*     None. */

/* $ Output_Common */

/*     None. */

/* $ Examples */

/*     See Detailed_Description. */

/* $ Restrictions */

/*     The declared length of ERROR should be at least 80, to avoid */
/*     truncationof error messages. */

/* $ Author_and_Institution */

/*     W. L. Taber     (JPL) */
/*     I. M. Underwood (JPL) */

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


/*     Version 1, 6-SEP-1986 */

/* -& */

/*   OPTLIB functions */


/*     Local variables */


/*     NFILES is the maximum number of files that may be open at */
/*     any given time. THus, nesting of procedures is limited to */
/*     a depth of NFILES. */


/*     NEST is the number of files currently open. */


/*     FILES are the names of the files on the stack. UNITS are */
/*     the logical units to which they are connected. */

    switch(n__) {
	case 1: goto L_prclr;
	case 2: goto L_prstrt;
	case 3: goto L_prread;
	case 4: goto L_prexit;
	case 5: goto L_prtrce;
	}

    return 0;

/* $ Procedure PRCLR */


L_prclr:

/* $ Abstract */

/*     Clear the file stack. */

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

/* $ Brief_I/O */

/*     None. */

/* $ Detailed_Input */

/*     None. */

/* $ Detailed_Output */

/*     None. */

/* $ Input_Files */

/*     None. */

/* $ Output_Files */

/*     None. */

/* $ Input_Output_Common */

/*     None. */

/* $ Detailed_Description */

/*     Pop all the files off the stack. */

/* $ Examples */

/*     None. */

/* $ Restrictions */

/*     None. */
/* $ 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 */

/* - */
    while(nest > 0) {
	cl__1.cerr = 0;
	cl__1.cunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 : 
		s_rnge("units", i__1, "prcomf_", (ftnlen)326)];
	cl__1.csta = 0;
	f_clos(&cl__1);
	--nest;
    }
    return 0;

/* $ Procedure PRSTRT */


L_prstrt:

/* $ Abstract */

/*     Put the current file on the stack, and replace it with 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. */

/* $ Brief_I/O */

/*     VARIABLE  I/O  DESCRIPTION */
/*     --------  ---  --------------------------------------------------- */
/*     FILE       I   New command file. */
/*     ERROR      O   Error flag. */

/* $ Detailed_Input */

/*     FILE       is the new current file from which commands are */
/*                to be read. */

/* $ Detailed_Output */

/*     ERROR      is blank when no error occurs, and otherwise contains */
/*                a descriptive message. Possible errors are: */

/*                     - The stack is full. */

/*                     - FILE could not be opened. */

/* $ Input_Files */

/*     FILE is opened with a logical unit determined at run time. */

/* $ Output_Files */

/*     None. */

/* $ Input_Output_Common */

/*     None. */

/* $ Detailed_Description */

/*     If the stack is full, return an error. Otherwise, try to open */
/*     FILE. If an error occurs, return immediately. Otherwise, put */
/*     the current file on the stack, and increase the nesting level. */

/* $ Examples */

/*     None. */

/* $ Restrictions */

/*     None. */

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

/* - */

/*     No error yet. */

    s_copy(error, " ", error_len, (ftnlen)1);

/*     Proceed only if the stack is not full. */

    if (nest == 8) {
	s_copy(error, "PRSTRT: Command files are nested too deeply.", 
		error_len, (ftnlen)44);
	return 0;
    } else {
	++nest;
    }

/*     Get a new logical unit. If none are available, abort. */

    txtopr_(file, &units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 : s_rnge(
	    "units", i__1, "prcomf_", (ftnlen)445)], file_len);
    if (have_(error, error_len)) {
	--nest;
    } else {
	s_copy(files + ((i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 : s_rnge(
		"files", i__1, "prcomf_", (ftnlen)450)) * 80, file, (ftnlen)
		80, file_len);
    }
    return 0;

/* $ Procedure PRREAD */


L_prread:

/* $ Abstract */

/*     Read the next command from the current 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. */

/* $ Brief_I/O */

/*     VARIABLE  I/O  DESCRIPTION */
/*     --------  ---  --------------------------------------------------- */
/*     DELIM      I   Character delimiting the end of a command. */
/*     COMMAND    O   Next command from the current file. */

/* $ Detailed_Input */

/*     DELIM      is the character used to delimit the end of a */
/*                command within a command file. */

/* $ Detailed_Output */

/*     COMMAND    is the next command read from the current file. */
/*                If there is no current file, COMMND = DELIM. */

/* $ Input_Files */

/*     All files read by PRCOMF are opened with logical units */
/*     determined at run time. */

/* $ Output_Files */

/*     None. */

/* $ Input_Output_Common */

/*     None. */

/* $ Detailed_Description */

/*     Attempt to read the next statement from the current file. */
/*     If the end of the file is encountered, pop the previous file */
/*     off the top of the stack, and try to read from it. Keep this */
/*     up until a command is read, or until no files remain open. */


/* $ Examples */

/*     None. */

/* $ Restrictions */

/*     None. */

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

/* - */

/*     Don't even bother unless at least one file is open. */

    if (nest == 0) {
	s_copy(command, delim, command_len, (ftnlen)1);
	return 0;
    }

/*     Keep trying to read until we run out of files. */

    ci__1.cierr = 1;
    ci__1.ciend = 1;
    ci__1.ciunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 : s_rnge(
	    "units", i__1, "prcomf_", (ftnlen)558)];
    ci__1.cifmt = "(A)";
    iostat = s_rsfe(&ci__1);
    if (iostat != 0) {
	goto L100001;
    }
    iostat = do_fio(&c__1, command, command_len);
    if (iostat != 0) {
	goto L100001;
    }
    iostat = e_rsfe();
L100001:
    while(iostat != 0 && nest > 0) {
	cl__1.cerr = 0;
	cl__1.cunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 : 
		s_rnge("units", i__1, "prcomf_", (ftnlen)562)];
	cl__1.csta = 0;
	f_clos(&cl__1);
	--nest;
	if (nest >= 1) {
	    ci__1.cierr = 1;
	    ci__1.ciend = 1;
	    ci__1.ciunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 : 
		    s_rnge("units", i__1, "prcomf_", (ftnlen)566)];
	    ci__1.cifmt = "(A)";
	    iostat = s_rsfe(&ci__1);
	    if (iostat != 0) {
		goto L100002;
	    }
	    iostat = do_fio(&c__1, command, command_len);
	    if (iostat != 0) {
		goto L100002;
	    }
	    iostat = e_rsfe();
L100002:
	    ;
	}
    }
    rstbuf_();
    if (nest == 0) {
	s_copy(command, delim, command_len, (ftnlen)1);
	putbuf_(command, command_len);
	return 0;
    }
    putbuf_(command, command_len);

/*     Okay, we have something. Keep reading until DELIM is found. */
/*     (Or until the file ends.) Add each successive line read to */
/*     the end of COMMAND. Do not return the delimiter itself. */

    j = 1;
    i__ = i_indx(command, delim, command_len, (ftnlen)1);
    while(i__ == 0 && iostat == 0) {
	j = lastnb_(command, command_len) + 1;
	*(unsigned char *)&command[j - 1] = ' ';
	++j;
	ci__1.cierr = 1;
	ci__1.ciend = 1;
	ci__1.ciunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 : 
		s_rnge("units", i__1, "prcomf_", (ftnlen)597)];
	ci__1.cifmt = "(A)";
	iostat = s_rsfe(&ci__1);
	if (iostat != 0) {
	    goto L100003;
	}
	iostat = do_fio(&c__1, command + (j - 1), command_len - (j - 1));
	if (iostat != 0) {
	    goto L100003;
	}
	iostat = e_rsfe();
L100003:
	putbuf_(command + (j - 1), command_len - (j - 1));
	i__ = i_indx(command, delim, command_len, (ftnlen)1);
    }
    if (i__ > 0) {
	s_copy(command + (i__ - 1), " ", command_len - (i__ - 1), (ftnlen)1);
    }
    return 0;

/* $ Procedure PREXIT */


L_prexit:

/* $ Abstract */

/*     Replace the current file with the one at the top of the stack. */

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

/* $ Brief_I/O */

/*     None. */

/* $ Detailed_Input */

/*     None. */

/* $ Detailed_Output */

/*     None. */

/* $ Input_Files */

/*     None. */

/* $ Output_Files */

/*     None. */

/* $ Input_Output_Common */

/*     None. */

/* $ Detailed_Description */

/*     Close the current file. Pop the previous file off the top of */
/*     the stack. If there is no current file, of if there are no */
/*     files on the stack, that's cool too. */

/* $ Examples */

/*     None. */

/* $ Restrictions */

/*     None. */
/* $ 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 */

/* - */
    if (nest > 0) {
	cl__1.cerr = 0;
	cl__1.cunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 : 
		s_rnge("units", i__1, "prcomf_", (ftnlen)695)];
	cl__1.csta = 0;
	f_clos(&cl__1);
	--nest;
    }
    return 0;

/* $ Procedure PRTRCE */


L_prtrce:

/* $ Abstract */

/*     Provide a list of the files currently open, in the order in */
/*     which they were opened. */

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

/* $ Brief_I/O */

/*     VARIABLE  I/O  DESCRIPTION */
/*     --------  ---  --------------------------------------------------- */
/*     LEVEL      O   List of all files currently open. */

/* $ Detailed_Input */

/*     None. */

/* $ Detailed_Output */

/*     LEVEL      A list of all files that are currently open, in */
/*                the order in which they were opened. For example, */
/*                if FILE_A starts FILE_B, and FILE_B starts FILE_C, */
/*                LEVEL would be 'FILE_A:FILE_B:_FILE_C'. */

/* $ Input_Files */

/*     None. */

/* $ Output_Files */

/*     None. */

/* $ Input_Output_Common */

/*     None. */

/* $ Detailed_Description */

/*     Just step through the stack, Jack. */

/* $ Examples */

/*     See Detailed_Description. */

/* $ Restrictions */

/*     LEVEL should be declared to be at least CHARACTER*640 by the */
/*     calling program to ensure that enough space is available to */
/*     list all open files. */
/* $ 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 */

/* - */

/*     Not much to explain. Use LBUILD to build a list, delimited */
/*     by colons. */

    s_copy(level, " ", level_len, (ftnlen)1);
    if (nest > 0) {
	lbuild_(files, &nest, ":", level, (ftnlen)80, (ftnlen)1, level_len);
    }
    return 0;
} /* prcomf_ */
コード例 #3
0
ファイル: dafa2b.c プロジェクト: haisamido/GMAT
/* $Procedure DAFA2B ( DAF, ASCII to binary ) */
/* Subroutine */ int dafa2b_(char *ascii, char *binary, integer *resv, ftnlen 
	ascii_len, ftnlen binary_len)
{
    /* System generated locals */
    cllist cl__1;

    /* Builtin functions */
    integer f_clos(cllist *);

    /* Local variables */
    integer unit;
    extern /* Subroutine */ int chkin_(char *, ftnlen), daft2b_(integer *, 
	    char *, integer *, ftnlen);
    extern logical failed_(void);
    extern /* Subroutine */ int chkout_(char *, ftnlen);
    extern logical return_(void);
    extern /* Subroutine */ int txtopr_(char *, integer *, ftnlen);

/* $ Abstract */

/*     Convert an ASCII (text) DAF to an equivalent binary DAF. */
/*     (Obsolete, maintained for backward compatibility only.) */

/* $ Disclaimer */

/*     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/*     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/*     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/*     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/*     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/*     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/*     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/*     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/*     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/*     SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */

/*     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/*     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/*     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/*     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/*     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/*     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */

/*     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/*     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/*     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/*     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */

/* $ Required_Reading */

/*     DAF */

/* $ Keywords */

/*     FILES */

/* $ Declarations */
/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     ASCII      I   Name of an existing ASCII (text) DAF. */
/*     BINARY     I   Name of a binary DAF to be created. */
/*     RESV       I   Number of records to reserve. */

/* $ Detailed_Input */

/*     ASCII       is the name of an existing ASCII (text) DAF. */

/*     BINARY      is the name of the binary DAF to be created. */
/*                 The binary DAF contains the same data as the */
/*                 ASCII DAF, but in a form more suitable for use */
/*                 by application programs. */

/*     RESV        is the number of records to be reserved in the */
/*                 binary DAF. */

/* $ Detailed_Output */

/*     None. */

/* $ Parameters */

/*     None. */

/* $ Files */

/*     See arguments ASCII, BINARY. */

/* $ Exceptions */

/*     None. */

/*     Errors are detected and signalled by routines called by this */
/*     routine. */

/* $ Particulars */

/*     This routine has been made obsolete by the new DAF text to binary */
/*     conversion routine DAFTB. This routine remains available for */
/*     reasons of backward compatibility. We strongly recommend that the */
/*     conversion routine DAFTB be used for any new software development. */
/*     Please see the header of the routine DAFTB for details. */

/*     This routine is used for converting older DAF text files, which */
/*     use a decimal format for numbers, into their equivalent binary */
/*     formats. Note that the routine DAFTB makes use of a text file */
/*     format that is incompatible with the text file format expected by */
/*     the routines called by this routine. */

/*     Note that you must select the number of records to be reserved */
/*     in the binary DAF. The contents of reserved records are ignored */
/*     by the normal transfer process. */

/* $ Examples */

/*     DAFB2A and DAFA2B are typically used to transfer files. */
/*     If file A.DAF is a binary DAF in environment 1, it */
/*     can be transferred to environment 2 in three steps. */

/*        1) Convert it to ASCII, */

/*              CALL DAFB2A ( 'A.DAF', 'A.ASCII' ) */

/*        2) Transfer the ASCII file, using FTP, Kermit, or some other */
/*           file transfer utility, */

/*              ftp> put a.ascii */

/*        3) Convert it to binary on the new machine, */

/*              CALL DAFA2B ( 'A.ASCII', 'A.DAF', RESV ) */

/*     Note that DAFB2A and DAFA2B work in any standard Fortran-77 */
/*     environment. */

/* $ Restrictions */

/*     DAFA2B cannot be executed while any other DAF is open */
/*     for writing. */

/* $ Literature_References */

/*     NAIF Document 167.0, "Double Precision Array Files (DAF) */
/*     Specification and User's Guide" */

/* $ Author_and_Institution */

/*     K.R. Gehringer  (JPL) */
/*     I.M. Underwood  (JPL) */

/* $ Version */

/* -    SPICELIB Version 2.0.0, 30-SEP-1993 (KRG) */

/*        This routine was completely rewritten to make use of the */
/*        routines DAFT2B and TXTOPR, for converting a text file to */
/*        binary and opening a text file. It now simply calls the */
/*        routine DAFT2B after opening the text file. */

/*        Added a statement to the $ Particulars section to the effect */
/*        that this routine has been made obsolete by the introduction of */
/*        the routine DAFTB, and that the use of the new routine is */
/*        strongly recommended for new software development. */

/*        Modified the $ Abstract section to reflect the fact that this */
/*        routine is obsolete. */

/* -    SPICELIB Version 1.0.2, 10-MAR-1992 (WLT) */

/*        Comment section for permuted index source lines was added */
/*        following the header. */

/* -    SPICELIB Version 1.0.1, 22-MAR-1990 (HAN) */

/*        Literature references added to the header. */

/* -    SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) */

/* -& */
/* $ Index_Entries */

/*     ascii daf to binary */

/* -& */
/* $ Revisions */

/* -    SPICELIB Version 2.0.0, 30-SEP-1993 (KRG) */

/*        This routine was completely rewritten to make use of the */
/*        routines DAFT2B and TXTOPR, for converting a text file to */
/*        binary and opening a text file. It now simply calls the */
/*        routine DAFT2B after opening the text file. */

/*        Added a statement to the $ Particulars section to the effect */
/*        that this routine has been made obsolete by the introduction of */
/*        the routine DAFTB, and that the use of the new routine is */
/*        strongly recommended for new software development. */

/*        Modified the $ Abstract section to reflect the fact that this */
/*        routine is obsolete. */

/* -    SPICELIB Version 1.0.2, 10-MAR-1992 (WLT) */

/*        Comment section for permuted index source lines was added */
/*        following the header. */

/* -    SPICELIB Version 1.0.1, 22-MAR-1990 (HAN) */

/*        Literature references added to the header. */

/* -    SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) */

/* -& */

/*     SPICELIB functions */


/*     Local variables */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    } else {
	chkin_("DAFA2B", (ftnlen)6);
    }

/*     Open the ASCII file for reading. If an error occurs, then check */
/*     out and return. An appropriate error message will have already */
/*     been set. */

    txtopr_(ascii, &unit, ascii_len);
    if (failed_()) {
	chkout_("DAFA2B", (ftnlen)6);
	return 0;
    }

/*     Call DAFT2B to perform the conversion. If it fails, then just */
/*     check out and return, as an appropriate error message should have */
/*     already been set. Also close the text file that we opened. */

    daft2b_(&unit, binary, resv, binary_len);
    if (failed_()) {
	cl__1.cerr = 0;
	cl__1.cunit = unit;
	cl__1.csta = 0;
	f_clos(&cl__1);
	chkout_("DAFA2B", (ftnlen)6);
	return 0;
    }

/*     Close the file. */

    cl__1.cerr = 0;
    cl__1.cunit = unit;
    cl__1.csta = 0;
    f_clos(&cl__1);
    chkout_("DAFA2B", (ftnlen)6);
    return 0;
} /* dafa2b_ */
コード例 #4
0
ファイル: rdcmd.c プロジェクト: Rileybrains/NASA_Intern_SPICE
/* $Procedure      RDCMD (Read command file) */
/* Subroutine */ int rdcmd_(char *cmdfil, char *cmdsym, integer *cmdptr, char 
	*cmdval, ftnlen cmdfil_len, ftnlen cmdsym_len, ftnlen cmdval_len)
{
    /* Initialized data */

    static char kwds1[32*2] = "LEAPSECONDS_KERNEL  1  1        " "SPK_KERNEL"
	    "          1  1000     ";
    static char kwds2[32*5] = "SOURCE_SPK_KERNEL   1  1000     " "LOG_FILE  "
	    "          0  1        " "BODIES              0  1        " "BEGI"
	    "N_TIME          0  1000     " "INCLUDE_TEXT_FILE   0  1000     ";
    static char kwds3[32*3] = "BODIES              0  1        " "BEGIN_TIME"
	    "          0  1000     " "INCLUDE_COMMENTS    0  1        ";
    static char kwds4[32*1] = "END_TIME            1  1        ";

    /* System generated locals */
    cilist ci__1;

    /* Builtin functions */
    integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void);

    /* Local variables */
    static char line[350];
    static integer unit;
    extern /* Subroutine */ int chkin_(char *, ftnlen), cperr_(char *, 
	    integer *, ftnlen), repmi_(char *, char *, integer *, char *, 
	    ftnlen, ftnlen, ftnlen);
    static char tabval[32*26];
    extern /* Subroutine */ int evalcp_(char *, logical *, char *, integer *, 
	    char *, logical *, ftnlen, ftnlen, ftnlen), initcp_(char *, 
	    integer *, char *, char *, ftnlen, ftnlen, ftnlen);
    static char reason[160];
    extern /* Subroutine */ int sigerr_(char *, ftnlen);
    static integer tabptr[26];
    extern /* Subroutine */ int prefix_(char *, integer *, char *, ftnlen, 
	    ftnlen);
    static char tabsym[32*26];
    extern /* Subroutine */ int ssizec_(integer *, char *, ftnlen), chkout_(
	    char *, ftnlen);
    static integer linnum, iostat;
    extern /* Subroutine */ int setmsg_(char *, ftnlen), ssizei_(integer *, 
	    integer *);
    extern logical return_(void);
    extern /* Subroutine */ int syputc_(char *, char *, integer *, char *, 
	    integer *, char *, ftnlen, ftnlen, ftnlen, ftnlen), txtopr_(char *
	    , integer *, ftnlen);
    static logical eof, err;

/* $ Abstract */

/*     Parse the command 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. */

/* $ Required_Reading */

/*     None. */

/* $ Keywords */

/*     None. */

/* $ Declarations */
/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     CMDFIL     I   Name of command file. */
/*     CMDSYM, */
/*     CMDPTR, */
/*     CMDVAL     O   Command symbol table. */

/* $ Detailed_Input */

/*     CMDFIL     is the name of the command file. */

/* $ Detailed_Output */

/*     CMDSYM, */
/*     CMDPTR, */
/*     CMDVAL     is the command symbol table. */

/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     1) An error is signaled if the file cannot be parsed */
/*        successfully. */

/* $ Files */

/*     None. */

/* $ Particulars */

/*     None. */

/* $ Examples */

/*     None. */

/* $ Restrictions */

/*     None. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     M.J. Spencer   (JPL) */

/* $ Version */

/* -    Beta Version 1.1.0, 17-JAN-2014 (BVS) */

/*        Increased LINLEN from 120 to 350 (350 = 300 characters for */
/*        value consistent with VALLEN in CPARSE_2 and the main program */
/*        + 50 more characters for the keyword name, =, and blanks.) */

/*        Increased maximum counts of child values in KWDS* from 300 to */
/*        1000 for all values. */

/*        Saved all variables. */

/* -    Beta Version 1.0.0, 26-JAN-1994 (MJS) */

/* -& */

/*     SPICELIB functions */


/*     Other functions */


/*     Local parameters */


/*     Local variables */


/*     Save all. */


/*     Initial values */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    } else {
	chkin_("RDCMD", (ftnlen)5);
    }

/*     Initialize the parser. */

    ssizec_(&c__20, tabsym, (ftnlen)32);
    ssizei_(&c__20, tabptr);
    ssizec_(&c__20, tabval, (ftnlen)32);
    syputc_("HEAD", kwds1, &c__2, tabsym, tabptr, tabval, (ftnlen)4, (ftnlen)
	    32, (ftnlen)32, (ftnlen)32);
    syputc_("SPK_KERNEL", kwds2, &c__5, tabsym, tabptr, tabval, (ftnlen)10, (
	    ftnlen)32, (ftnlen)32, (ftnlen)32);
    syputc_("SOURCE_SPK_KERNEL", kwds3, &c__3, tabsym, tabptr, tabval, (
	    ftnlen)17, (ftnlen)32, (ftnlen)32, (ftnlen)32);
    syputc_("BEGIN_TIME", kwds4, &c__1, tabsym, tabptr, tabval, (ftnlen)10, (
	    ftnlen)32, (ftnlen)32, (ftnlen)32);
    initcp_(tabsym, tabptr, tabval, "HEAD", (ftnlen)32, (ftnlen)32, (ftnlen)4)
	    ;

/*     Open the command file, and parse its contents */

    txtopr_(cmdfil, &unit, cmdfil_len);
    eof = FALSE_;
    err = FALSE_;
    while(! eof && ! err) {
	ci__1.cierr = 1;
	ci__1.ciend = 1;
	ci__1.ciunit = unit;
	ci__1.cifmt = "(A)";
	iostat = s_rsfe(&ci__1);
	if (iostat != 0) {
	    goto L100001;
	}
	iostat = do_fio(&c__1, line, (ftnlen)350);
	if (iostat != 0) {
	    goto L100001;
	}
	iostat = e_rsfe();
L100001:
	eof = iostat != 0;
	evalcp_(line, &eof, cmdsym, cmdptr, cmdval, &err, (ftnlen)350, 
		cmdsym_len, cmdval_len);
    }
    if (err) {
	cperr_(reason, &linnum, (ftnlen)160);
	repmi_(reason, "#", &linnum, reason, (ftnlen)160, (ftnlen)1, (ftnlen)
		160);
	prefix_(":", &c__1, reason, (ftnlen)1, (ftnlen)160);
	prefix_(cmdfil, &c__0, reason, cmdfil_len, (ftnlen)160);
	setmsg_(reason, (ftnlen)160);
	sigerr_("SPICE(CMDPARSEERROR)", (ftnlen)20);
	chkout_("RDCMD", (ftnlen)5);
	return 0;
    }
    chkout_("RDCMD", (ftnlen)5);
    return 0;
} /* rdcmd_ */
コード例 #5
0
/* $Procedure   COMMNT ( Comment utility program ) */
/* Main program */ MAIN__(void)
{
    /* Initialized data */

    static logical insbln = TRUE_;
    static char maintl[20] = "COMMNT Options      ";
    static char mainvl[20*5] = "QUIT                " "ADD_COMMENTS        " 
	    "READ_COMMENTS       " "EXTRACT_COMMENTS    " "DELETE_COMMENTS  "
	    "   ";
    static char maintx[40*5] = "Quit.                                   " 
	    "Add comments to a binary file.          " "Read the comments in"
	    " a binary file.     " "Extract comments from a binary file.    " 
	    "Delete the comments in a binary file.   ";
    static char mainnm[1*5] = "Q" "A" "R" "E" "D";

    /* System generated locals */
    address a__1[3];
    integer i__1[3], i__2, i__3, i__4, i__5;
    cllist cl__1;

    /* Builtin functions */
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
	     char **, integer *, integer *, ftnlen);
    integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *, 
	    ftnlen, ftnlen), f_clos(cllist *);

    /* Local variables */
    static char arch[3];
    static logical done;
    static char line[1000];
    static logical more;
    static integer iopt;
    static char type__[4];
    static integer i__;
    extern /* Subroutine */ int dasdc_(integer *);
    extern integer cardi_(integer *);
    static integer r__;
    extern /* Subroutine */ int spcac_(integer *, integer *, char *, char *, 
	    ftnlen, ftnlen), chkin_(char *, ftnlen), spcec_(integer *, 
	    integer *), spcdc_(integer *), errch_(char *, char *, ftnlen, 
	    ftnlen), repmc_(char *, char *, char *, char *, ftnlen, ftnlen, 
	    ftnlen, ftnlen), reset_(void);
    extern integer rtrim_(char *, ftnlen);
    extern logical failed_(void);
    extern /* Subroutine */ int dafhof_(integer *);
    static integer handle;
    extern /* Subroutine */ int dafcls_(integer *), dasacu_(integer *, char *,
	     char *, logical *, integer *, ftnlen, ftnlen), cleari_(integer *,
	     integer *), delfil_(char *, ftnlen), dasecu_(integer *, integer *
	    , logical *), scardi_(integer *, integer *), dashof_(integer *);
    static logical fileok;
    extern /* Subroutine */ int clcomm_(void), getfat_(char *, char *, char *,
	     ftnlen, ftnlen, ftnlen), cnfirm_(char *, logical *, ftnlen);
    static char fnmtbl[128*2], messag[1000], errmsg[320], messgs[1000*7], 
	    option[20], prmtbl[80*2], statbl[3*2];
    extern logical exists_(char *, ftnlen);
    static integer comlun;
    static char status[1000*2];
    static integer numfnm;
    static char prmpts[80*2];
    static integer numopn, opnset[7], tblidx[2];
    static logical comnts, contnu, ndfnms, tryagn;
    extern /* Subroutine */ int tkvrsn_(char *, char *, ftnlen, ftnlen), 
	    erract_(char *, char *, ftnlen, ftnlen), errprt_(char *, char *, 
	    ftnlen, ftnlen), tostdo_(char *, ftnlen), ssizei_(integer *, 
	    integer *), getopt_(char *, integer *, char *, char *, integer *, 
	    ftnlen, ftnlen, ftnlen), getfnm_(char *, char *, char *, logical *
	    , char *, ftnlen, ftnlen, ftnlen, ftnlen), setmsg_(char *, ftnlen)
	    , sigerr_(char *, ftnlen), txtopr_(char *, integer *, ftnlen), 
	    dafopw_(char *, integer *, ftnlen), dasopw_(char *, integer *, 
	    ftnlen), dascls_(integer *), dafopr_(char *, integer *, ftnlen), 
	    spcrfl_(integer *, char *, logical *, ftnlen), spcrnl_(char *, 
	    logical *, ftnlen), dasopr_(char *, integer *, ftnlen), txtopn_(
	    char *, integer *, ftnlen), chkout_(char *, ftnlen);
    static logical eoc;
    static char tkv[12];

/* $ Abstract */

/*     NAIF Toolkit utility program for adding, reading, extracting, */
/*     and deleting comments from a binary 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. */

/* $ Required_Reading */

/*     SPC */
/*     DAS */

/* $ Author_and_Institution */

/*     W.L. Taber     (JPL) */
/*     K.R. Gehringer (JPL) */
/*     J.E. McLean    (JPL) */
/*     M.J. Spencer   (JPL) */

/* $ Version */

/* -    Version 6.0.1, 08-MAY-2001 (BVS) */

/*       Increased LINLEN from 255 to 1000 to make it consistent */
/*       with SPICELIB's SPC* and SUPPORT's DAF* internal line sizes. */

/* -    Version 5.0.1, 21-JUL-1997 (WLT) */

/*       Modified the banner at start up so that the version of the */
/*       toolkit used to link COMMNT will be displayed. */

/*       In addition all WRITE statements were replaced by calls to */
/*       TOSTDO. */

/* -    Version 5.0.0, 05-MAY-1994 (KRG) */

/*       Modified the program to use the new file type identification */
/*       capability that was added to spicelib. No file type menu is */
/*       necessary now, as the file type is determined during the */
/*       execution of the program. */

/*       The prompts for the begin and end markers used to extract a */
/*       subset of text lines from an input comment file which were then */
/*       placed into the comment area of a SPICE binary kernel file have */
/*       been removed. The entire input comment file is now placed into */
/*       the comment area of the binary kernel file. This change */
/*       simplifies the user interaction with the program. */

/*       Added support for the new PCK binary kernel files. */

/*       If an error occurs during the extraction of comments to a file, */
/*       the file that was being created is deleted. We cannot know */
/*       whether the file had been successfully created before the error */
/*       occurred. */

/* -    Version 4.0.0, 11-DEC-1992 (KRG) */

/*        Added code to support the E-Kernel, and redesigned the */
/*        user interface. */

/* -    Version 3.1.0, 19-NOV-1991 (MJS) */

/*        Variable QUIT initialized to FALSE. */

/* -    Version 3.0.1, 10-AUG-1991 (CHA) (NJB) */

/*        Updated comments to reflect status as a Toolkit */
/*        utility program.  Message indicating that no comments */
/*        were found in the specified file was changed to include */
/*        the file name. */

/* -    Version 2.0.0, 28-JUN-1991 (JEM) */

/*        The option to read the comments from the comment */
/*        area of a binary SPK or CK was added to the menu. */

/* -    Version 1.0.0, 05-APR-1991 (JEM) */

/* -& */

/*     SPICELIB functions */


/*     Parameters */

/*     Set the version of the comment program. This should be updated */
/*     every time a change is made, and it should agree with the */
/*     version number in the header. */


/*     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. */


/*     Lower bound for a SPICELIB CELL data structure. */


/*     Maximum number of open binary files allowed. */


/*     Set a value for a replacement marker. */


/*     Set a value for a filename prompt. */


/*     File types */


/*     Set a value for the length of a text line. */


/*     Set a value for the length of an error message. */


/*     Set a value for the length of a filename. */


/*     Set a length for the prompts in the prompt table. */


/*     Set a length for the status of a file: 'OLD' or 'NEW'. */


/*     Set the length for the architecture of a file. */


/*     Set the length for the type of a file. */


/*     Set a length for the option values. */


/*     Set a length for the title of a menu. */


/*     Set a length for an option name (what is typed to select it) */
/*     for a menu. */


/*     Set the length of the text description of an option on a menu. */


/*     The number of options available on the main menu. */


/*     Set up some mnemonics for indexing the prompts in the prompt */
/*     table. */


/*     Set the maximum size of the filename table: this must be the */
/*     number of distinct ``types'' of files that the program may */
/*     require. */


/*     Set up some mnemonics for indexing the messages in the message */
/*     table. */


/*     Set the maximum size of the message table: There should be a */
/*     message for each ``type'' of action that the program can take. */


/*     Set up some mnemonics for the OK and not OK status messages. */


/*     Set the maximum number of status messages that are available. */


/*     We need to have TKVLEN characters to hold the current version */
/*     of the toolkit. */


/*     Variables */


/*     We want to insert a blank line between additions if there are */
/*     already comments in the binary file. We indicate this by giving */
/*     the variable INSBLN the value .TRUE.. */


/*     Define the main menu title ... */


/*     Define the main menu option values ... */


/*     Define the main menu descriptive text for each option ... */


/*     Define the main menu option names ... */


/*     Register the COMMNT main program with the SPICELIB error handler. */

    chkin_("COMMNT", (ftnlen)6);
    clcomm_();
    tkvrsn_("TOOLKIT", tkv, (ftnlen)7, (ftnlen)12);
    r__ = rtrim_(tkv, (ftnlen)12);

/*     Set the error action to 'RETURN'. We don't want the program */
/*     to abort if an error is signalled. We check FAILED where */
/*     necessary. If an error is signalled, we'll just handle the */
/*     error, display an appropriate message, then call RESET at the */
/*     end of the loop to continue. */

    erract_("SET", "RETURN", (ftnlen)3, (ftnlen)6);

/*     Set the error messages that we want to have displayed. We will */
/*     diaplay the SPICELIB short and long error messages. This is done */
/*     to ensure that some sort of an error message is displayed if an */
/*     error occurs. In several places, long error messages are not set, */
/*     so if only the long error messages were displayed, it would be */
/*     possible to have an error signalled and not see any error */
/*     information. This is not a very useful thing. */

    errprt_("SET", "NONE, SHORT, LONG, TRACEBACK", (ftnlen)3, (ftnlen)28);

/*     Set up the prompt table for the different types of files. */

    s_copy(prmtbl + 80, "Enter the name of the comment file to be #.", (
	    ftnlen)80, (ftnlen)43);
    s_copy(prmtbl, "Enter the name of the binary file.", (ftnlen)80, (ftnlen)
	    34);

/*     Set up the message table for the different ``types'' of */
/*     operations. The message table contains generic messages which will */
/*     have their missing parts filled in after the option and file type */
/*     havve been selected. */

    s_copy(messgs, "Reading the comment area of the # file.", (ftnlen)1000, (
	    ftnlen)39);
    s_copy(messgs + 1000, "Adding comments to the # file.", (ftnlen)1000, (
	    ftnlen)30);
    s_copy(messgs + 2000, "Extracting comments from the # file.", (ftnlen)
	    1000, (ftnlen)36);
    s_copy(messgs + 3000, "Deleting the comment area of # file.", (ftnlen)
	    1000, (ftnlen)36);
    s_copy(messgs + 4000, "Quitting the program.", (ftnlen)1000, (ftnlen)21);
    s_copy(messgs + 5000, "The comments were successfully #.", (ftnlen)1000, (
	    ftnlen)33);
    s_copy(messgs + 6000, "The comments were NOT successfully #.", (ftnlen)
	    1000, (ftnlen)37);

/*     Display a brief commercial with the name of the program and the */
/*     version. */

    s_copy(line, "   Welcome to COMMNT Version: #", (ftnlen)1000, (ftnlen)31);
    repmc_(line, "#", "6.0.1", line, (ftnlen)1000, (ftnlen)1, (ftnlen)5, (
	    ftnlen)1000);
    tostdo_(" ", (ftnlen)1);
    tostdo_(line, (ftnlen)1000);
/* Writing concatenation */
    i__1[0] = 23, a__1[0] = "        (Spice Toolkit ";
    i__1[1] = r__, a__1[1] = tkv;
    i__1[2] = 1, a__1[2] = ")";
    s_cat(line, a__1, i__1, &c__3, (ftnlen)1000);
    tostdo_(line, (ftnlen)1000);
    tostdo_(" ", (ftnlen)1);

/*     Initialize the CELL oriented set for collecting open DAF or DAS */
/*     files in the event of an error. */

    ssizei_(&c__1, opnset);

/*     While there is still more to do ... */

    done = FALSE_;
    while(! done) {

/*        We initialize a few things here, so that they get reset for */
/*        every trip through the loop. */

/*        Initialize the logical flags that we use. */

	comnts = FALSE_;
	contnu = TRUE_;
	eoc = FALSE_;
	ndfnms = FALSE_;

/*        Initialize the filename table, ... */

	s_copy(fnmtbl, " ", (ftnlen)128, (ftnlen)1);
	s_copy(fnmtbl + 128, " ", (ftnlen)128, (ftnlen)1);

/*        the file status table, ... */

	s_copy(statbl, " ", (ftnlen)3, (ftnlen)1);
	s_copy(statbl + 3, " ", (ftnlen)3, (ftnlen)1);

/*        the table indices, ... */

	tblidx[0] = 0;
	tblidx[1] = 0;

/*        set the number of file names to zero, ... */

	numfnm = 0;

/*        the prompts in the prompt table, ... */

	s_copy(prmpts, " ", (ftnlen)80, (ftnlen)1);
	s_copy(prmpts + 80, " ", (ftnlen)80, (ftnlen)1);

/*        the message, and the option. */

	s_copy(messag, " ", (ftnlen)1000, (ftnlen)1);
	s_copy(option, " ", (ftnlen)20, (ftnlen)1);

/*        Set the status messages. */

	s_copy(status, messgs + 5000, (ftnlen)1000, (ftnlen)1000);
	s_copy(status + 1000, messgs + 6000, (ftnlen)1000, (ftnlen)1000);

/*        Get the option to be performed from the main menu. */

	getopt_(maintl, &c__5, mainnm, maintx, &iopt, (ftnlen)20, (ftnlen)1, (
		ftnlen)40);
	s_copy(option, mainvl + ((i__2 = iopt - 1) < 5 && 0 <= i__2 ? i__2 : 
		s_rnge("mainvl", i__2, "commnt_", (ftnlen)502)) * 20, (ftnlen)
		20, (ftnlen)20);

/*        Set up the messages and other information for the option */
/*        selected. */

	if (contnu) {
	    if (s_cmp(option, "ADD_COMMENTS", (ftnlen)20, (ftnlen)12) == 0) {
		ndfnms = TRUE_;
		numfnm = 2;
		s_copy(messag, messgs + 1000, (ftnlen)1000, (ftnlen)1000);
		tblidx[0] = 2;
		s_copy(prmpts, prmtbl + 80, (ftnlen)80, (ftnlen)80);
		repmc_(prmpts, "#", "added", prmpts, (ftnlen)80, (ftnlen)1, (
			ftnlen)5, (ftnlen)80);
		s_copy(statbl + 3, "OLD", (ftnlen)3, (ftnlen)3);
		tblidx[1] = 1;
		s_copy(prmpts + 80, prmtbl, (ftnlen)80, (ftnlen)80);
		s_copy(statbl, "OLD", (ftnlen)3, (ftnlen)3);

/*              Set the operation status messages. */

		s_copy(status, messgs + 5000, (ftnlen)1000, (ftnlen)1000);
		repmc_(status, "#", "added", status, (ftnlen)1000, (ftnlen)1, 
			(ftnlen)5, (ftnlen)1000);
		s_copy(status + 1000, messgs + 6000, (ftnlen)1000, (ftnlen)
			1000);
		repmc_(status + 1000, "#", "added", status + 1000, (ftnlen)
			1000, (ftnlen)1, (ftnlen)5, (ftnlen)1000);
	    } else if (s_cmp(option, "READ_COMMENTS", (ftnlen)20, (ftnlen)13) 
		    == 0) {
		ndfnms = TRUE_;
		numfnm = 1;
		s_copy(messag, messgs, (ftnlen)1000, (ftnlen)1000);
		tblidx[0] = 1;
		s_copy(prmpts, prmtbl, (ftnlen)80, (ftnlen)80);
		s_copy(statbl, "OLD", (ftnlen)3, (ftnlen)3);

/*              Set the operation status messages. */

		s_copy(status, messgs + 5000, (ftnlen)1000, (ftnlen)1000);
		repmc_(status, "#", "read", status, (ftnlen)1000, (ftnlen)1, (
			ftnlen)4, (ftnlen)1000);
		s_copy(status + 1000, messgs + 6000, (ftnlen)1000, (ftnlen)
			1000);
		repmc_(status + 1000, "#", "read", status + 1000, (ftnlen)
			1000, (ftnlen)1, (ftnlen)4, (ftnlen)1000);
	    } else if (s_cmp(option, "EXTRACT_COMMENTS", (ftnlen)20, (ftnlen)
		    16) == 0) {
		ndfnms = TRUE_;
		numfnm = 2;
		s_copy(messag, messgs + 2000, (ftnlen)1000, (ftnlen)1000);
		tblidx[0] = 1;
		s_copy(prmpts, prmtbl, (ftnlen)80, (ftnlen)80);
		s_copy(statbl, "OLD", (ftnlen)3, (ftnlen)3);
		tblidx[1] = 2;
		s_copy(prmpts + 80, prmtbl + 80, (ftnlen)80, (ftnlen)80);
		repmc_(prmpts + 80, "#", "created", prmpts + 80, (ftnlen)80, (
			ftnlen)1, (ftnlen)7, (ftnlen)80);
		s_copy(statbl + 3, "NEW", (ftnlen)3, (ftnlen)3);

/*              Set the operation status messages. */

		s_copy(status, messgs + 5000, (ftnlen)1000, (ftnlen)1000);
		repmc_(status, "#", "extracted", status, (ftnlen)1000, (
			ftnlen)1, (ftnlen)9, (ftnlen)1000);
		s_copy(status + 1000, messgs + 6000, (ftnlen)1000, (ftnlen)
			1000);
		repmc_(status + 1000, "#", "extracted", status + 1000, (
			ftnlen)1000, (ftnlen)1, (ftnlen)9, (ftnlen)1000);
	    } else if (s_cmp(option, "DELETE_COMMENTS", (ftnlen)20, (ftnlen)
		    15) == 0) {
		ndfnms = TRUE_;
		numfnm = 1;
		s_copy(messag, messgs + 3000, (ftnlen)1000, (ftnlen)1000);
		tblidx[0] = 1;
		s_copy(prmpts, prmtbl, (ftnlen)80, (ftnlen)80);
		s_copy(statbl, "OLD", (ftnlen)3, (ftnlen)3);

/*              Set the operation status messages. */

		s_copy(status, messgs + 5000, (ftnlen)1000, (ftnlen)1000);
		repmc_(status, "#", "deleted", status, (ftnlen)1000, (ftnlen)
			1, (ftnlen)7, (ftnlen)1000);
		s_copy(status + 1000, messgs + 6000, (ftnlen)1000, (ftnlen)
			1000);
		repmc_(status + 1000, "#", "deleted", status + 1000, (ftnlen)
			1000, (ftnlen)1, (ftnlen)7, (ftnlen)1000);
	    } else if (s_cmp(option, "QUIT", (ftnlen)20, (ftnlen)4) == 0) {
		s_copy(messag, messgs + 4000, (ftnlen)1000, (ftnlen)1000);
	    }
	}

/*        Collect any filenames that we may need. */

	if (contnu && ndfnms) {

/*           we always need at least one filename if we get to here. */

	    i__ = 1;
	    more = TRUE_;
	    while(more) {
		fileok = FALSE_;
		tryagn = TRUE_;
		while(tryagn) {
		    tostdo_(" ", (ftnlen)1);
		    tostdo_(prmpts + ((i__2 = i__ - 1) < 2 && 0 <= i__2 ? 
			    i__2 : s_rnge("prmpts", i__2, "commnt_", (ftnlen)
			    614)) * 80, (ftnlen)80);
		    tostdo_(" ", (ftnlen)1);
		    getfnm_("Filename? ", statbl + ((i__3 = tblidx[(i__2 = 
			    i__ - 1) < 2 && 0 <= i__2 ? i__2 : s_rnge("tblidx"
			    , i__2, "commnt_", (ftnlen)617)] - 1) < 2 && 0 <= 
			    i__3 ? i__3 : s_rnge("statbl", i__3, "commnt_", (
			    ftnlen)617)) * 3, fnmtbl + (((i__5 = tblidx[(i__4 
			    = i__ - 1) < 2 && 0 <= i__4 ? i__4 : s_rnge("tbl"
			    "idx", i__4, "commnt_", (ftnlen)617)] - 1) < 2 && 
			    0 <= i__5 ? i__5 : s_rnge("fnmtbl", i__5, "commn"
			    "t_", (ftnlen)617)) << 7), &fileok, errmsg, (
			    ftnlen)10, (ftnlen)3, (ftnlen)128, (ftnlen)320);

/*                 If the filename is OK, increment the filename index */
/*                 and leave the try again loop. Otherwise, write out the */
/*                 error message, and give the opportunity to go around */
/*                 again. */

		    if (fileok) {
			++i__;
			tryagn = FALSE_;
		    } else {
			tostdo_(" ", (ftnlen)1);
			tostdo_(errmsg, (ftnlen)320);
			tostdo_(" ", (ftnlen)1);
			cnfirm_("Try again? (Yes/No) ", &tryagn, (ftnlen)20);
			if (! tryagn) {
			    contnu = FALSE_;
			    more = FALSE_;
			}
		    }
		}
		if (i__ > numfnm) {
		    more = FALSE_;
		}
	    }
	}

/*        Get the file architecture and type. */

	if (contnu && ndfnms) {
	    getfat_(fnmtbl, arch, type__, (ftnlen)128, (ftnlen)3, (ftnlen)4);
	    if (failed_()) {
		contnu = FALSE_;
	    }
	}

/*        Check to see that we got back a valid architecture and type. */

	if (contnu && ndfnms) {
	    if (s_cmp(arch, "?", (ftnlen)3, (ftnlen)1) == 0 || s_cmp(type__, 
		    "?", (ftnlen)4, (ftnlen)1) == 0) {
		contnu = FALSE_;
		setmsg_("The architecture and type of the binary file '#' co"
			"uld not be determined. A common error is to give the"
			" name of a text file instead of the name of a binary"
			" file.", (ftnlen)161);
		errch_("#", fnmtbl, (ftnlen)1, (ftnlen)128);
		sigerr_("SPICE(BADFILEFORMAT)", (ftnlen)20);
	    }
	}

/*        Customize the message. We know we can do this, because we */
/*        need files, and so we don't have the QUIT message. */

	if (contnu && ndfnms) {
	    repmc_(messag, "#", type__, messag, (ftnlen)1000, (ftnlen)1, (
		    ftnlen)4, (ftnlen)1000);
	}

/*        Process the option that was selected so long ago. */

	if (contnu) {
	    if (s_cmp(option, "QUIT", (ftnlen)20, (ftnlen)4) == 0) {
		tostdo_(" ", (ftnlen)1);
		tostdo_(messag, (ftnlen)1000);
		tostdo_(" ", (ftnlen)1);
		done = TRUE_;
	    } else if (s_cmp(option, "ADD_COMMENTS", (ftnlen)20, (ftnlen)12) 
		    == 0) {
		tostdo_(" ", (ftnlen)1);
		tostdo_(messag, (ftnlen)1000);
		s_copy(line, "From File: #", (ftnlen)1000, (ftnlen)12);
		repmc_(line, "#", fnmtbl + 128, line, (ftnlen)1000, (ftnlen)1,
			 (ftnlen)128, (ftnlen)1000);
		tostdo_(" ", (ftnlen)1);
		tostdo_(line, (ftnlen)1000);
		s_copy(line, "To File  : #", (ftnlen)1000, (ftnlen)12);
		repmc_(line, "#", fnmtbl, line, (ftnlen)1000, (ftnlen)1, (
			ftnlen)128, (ftnlen)1000);
		tostdo_(line, (ftnlen)1000);

/*              Open the text file which contains the comments to be */
/*              added to the binary file. */

		txtopr_(fnmtbl + 128, &comlun, (ftnlen)128);
		if (! failed_()) {
		    if (s_cmp(type__, "CK", (ftnlen)4, (ftnlen)2) == 0) {

/*                    Open the binary file, add the comments, and close */
/*                    the binary file. */

			dafopw_(fnmtbl, &handle, (ftnlen)128);
			spcac_(&handle, &comlun, " ", " ", (ftnlen)1, (ftnlen)
				1);
			dafcls_(&handle);
		    } else if (s_cmp(type__, "PCK", (ftnlen)4, (ftnlen)3) == 
			    0) {

/*                    Open the binary file, add the comments, and close */
/*                    the binary file. */

			dafopw_(fnmtbl, &handle, (ftnlen)128);
			spcac_(&handle, &comlun, " ", " ", (ftnlen)1, (ftnlen)
				1);
			dafcls_(&handle);
		    } else if (s_cmp(type__, "SPK", (ftnlen)4, (ftnlen)3) == 
			    0) {

/*                    Open the binary file, add the comments, and close */
/*                    the binary file. */

			dafopw_(fnmtbl, &handle, (ftnlen)128);
			spcac_(&handle, &comlun, " ", " ", (ftnlen)1, (ftnlen)
				1);
			dafcls_(&handle);
		    } else if (s_cmp(type__, "EK", (ftnlen)4, (ftnlen)2) == 0)
			     {

/*                    Open the binary file, add the comments, and close */
/*                    the binary file. */

			dasopw_(fnmtbl, &handle, (ftnlen)128);
			dasacu_(&comlun, " ", " ", &insbln, &handle, (ftnlen)
				1, (ftnlen)1);
			dascls_(&handle);
		    }

/*                 Close the comment file. */

		    cl__1.cerr = 0;
		    cl__1.cunit = comlun;
		    cl__1.csta = 0;
		    f_clos(&cl__1);
		}

/*              Display the status of the operation that was selected. */

		tostdo_(" ", (ftnlen)1);
		if (failed_()) {
		    tostdo_(status + 1000, (ftnlen)1000);
		} else {
		    tostdo_(status, (ftnlen)1000);
		}
	    } else if (s_cmp(option, "READ_COMMENTS", (ftnlen)20, (ftnlen)13) 
		    == 0) {
		tostdo_(" ", (ftnlen)1);
		tostdo_(messag, (ftnlen)1000);
		s_copy(line, "File: #", (ftnlen)1000, (ftnlen)7);
		repmc_(line, "#", fnmtbl, line, (ftnlen)1000, (ftnlen)1, (
			ftnlen)128, (ftnlen)1000);
		tostdo_(" ", (ftnlen)1);
		tostdo_(line, (ftnlen)1000);
		tostdo_(" ", (ftnlen)1);
		if (s_cmp(type__, "CK", (ftnlen)4, (ftnlen)2) == 0) {

/*                 Open the binary file, read the comments, and close */
/*                 the binary file. */

		    dafopr_(fnmtbl, &handle, (ftnlen)128);

/*                 The comments are read a line at a time and displayed */
/*                 on the screen. */

		    spcrfl_(&handle, line, &eoc, (ftnlen)1000);
		    if (! failed_()) {
			if (eoc) {
			    tostdo_("There were no comments found in the fil"
				    "e.", (ftnlen)41);
			}
			while(! eoc && ! failed_()) {
			    tostdo_(line, (ftnlen)1000);
			    spcrnl_(line, &eoc, (ftnlen)1000);
			}
		    }
		    dafcls_(&handle);
		} else if (s_cmp(type__, "PCK", (ftnlen)4, (ftnlen)3) == 0) {

/*                 Open the binary file, read the comments, and close */
/*                 the binary file. */

		    dafopr_(fnmtbl, &handle, (ftnlen)128);

/*                 The comments are read a line at a time and displayed */
/*                 on the screen. */

		    spcrfl_(&handle, line, &eoc, (ftnlen)1000);
		    if (! failed_()) {
			if (eoc) {
			    tostdo_("There were no commentfound in the file.",
				     (ftnlen)39);
			}
			while(! eoc && ! failed_()) {
			    tostdo_(line, (ftnlen)1000);
			    spcrnl_(line, &eoc, (ftnlen)1000);
			}
		    }
		    dafcls_(&handle);
		} else if (s_cmp(type__, "SPK", (ftnlen)4, (ftnlen)3) == 0) {

/*                 Open the binary file, read the comments, and close */
/*                 the binary file. */

		    dafopr_(fnmtbl, &handle, (ftnlen)128);

/*                 The comments are read a line at a time and displayed */
/*                 on the screen. */

		    spcrfl_(&handle, line, &eoc, (ftnlen)1000);
		    if (! failed_()) {
			if (eoc) {
			    tostdo_("There were no comments found in the fil"
				    "e.", (ftnlen)41);
			}
			while(! eoc && ! failed_()) {
			    tostdo_(line, (ftnlen)1000);
			    spcrnl_(line, &eoc, (ftnlen)1000);
			}
		    }
		    dafcls_(&handle);
		} else if (s_cmp(type__, "EK", (ftnlen)4, (ftnlen)2) == 0) {

/*                 Open the binary file, read the comments, and close */
/*                 the binary file. */

		    dasopr_(fnmtbl, &handle, (ftnlen)128);
		    dasecu_(&handle, &c__6, &comnts);
		    dascls_(&handle);
		    if (! comnts) {
			s_copy(line, "There were no comments found in the fi"
				"le.", (ftnlen)1000, (ftnlen)41);
			tostdo_(line, (ftnlen)1000);
		    }
		}

/*              Display the status of the operation that was selected. */

		tostdo_(" ", (ftnlen)1);
		if (failed_()) {
		    tostdo_(status + 1000, (ftnlen)1000);
		} else {
		    tostdo_(status, (ftnlen)1000);
		}
	    } else if (s_cmp(option, "EXTRACT_COMMENTS", (ftnlen)20, (ftnlen)
		    16) == 0) {
		tostdo_(" ", (ftnlen)1);
		tostdo_(messag, (ftnlen)1000);
		s_copy(line, "From File: #", (ftnlen)1000, (ftnlen)12);
		repmc_(line, "#", fnmtbl, line, (ftnlen)1000, (ftnlen)1, (
			ftnlen)128, (ftnlen)1000);
		tostdo_(" ", (ftnlen)1);
		tostdo_(line, (ftnlen)1000);
		s_copy(line, "To File  : #", (ftnlen)1000, (ftnlen)12);
		repmc_(line, "#", fnmtbl + 128, line, (ftnlen)1000, (ftnlen)1,
			 (ftnlen)128, (ftnlen)1000);
		tostdo_(line, (ftnlen)1000);

/*              Open the text file. */

		txtopn_(fnmtbl + 128, &comlun, (ftnlen)128);
		if (! failed_()) {
		    if (s_cmp(type__, "CK", (ftnlen)4, (ftnlen)2) == 0) {

/*                    Open the binary file, extract the comments, and */
/*                    close the binary file. */

			dafopr_(fnmtbl, &handle, (ftnlen)128);
			spcec_(&handle, &comlun);
			dafcls_(&handle);
		    } else if (s_cmp(type__, "PCK", (ftnlen)4, (ftnlen)3) == 
			    0) {

/*                    Open the binary file, extract the comments, and */
/*                    close the binary file. */

			dafopr_(fnmtbl, &handle, (ftnlen)128);
			spcec_(&handle, &comlun);
			dafcls_(&handle);
		    } else if (s_cmp(type__, "SPK", (ftnlen)4, (ftnlen)3) == 
			    0) {

/*                    Open the binary file, extract the comments, and */
/*                    close the binary file. */

			dafopr_(fnmtbl, &handle, (ftnlen)128);
			spcec_(&handle, &comlun);
			dafcls_(&handle);
		    } else if (s_cmp(type__, "EK", (ftnlen)4, (ftnlen)2) == 0)
			     {

/*                    Open the binary file, extract the comments, and */
/*                    close the binary file. */

			dasopr_(fnmtbl, &handle, (ftnlen)128);
			dasecu_(&handle, &comlun, &comnts);
			dascls_(&handle);
			if (! comnts) {
			    s_copy(line, "There were no comments found in th"
				    "e file.", (ftnlen)1000, (ftnlen)41);
			    tostdo_(line, (ftnlen)1000);
			}
		    }

/*                 Close the text file that we opened. */

		    cl__1.cerr = 0;
		    cl__1.cunit = comlun;
		    cl__1.csta = 0;
		    f_clos(&cl__1);
		}

/*              Display the status of the operation that was selected. */

		tostdo_(" ", (ftnlen)1);
		if (failed_()) {
		    tostdo_(status + 1000, (ftnlen)1000);
		} else {
		    tostdo_(status, (ftnlen)1000);
		}
	    } else if (s_cmp(option, "DELETE_COMMENTS", (ftnlen)20, (ftnlen)
		    15) == 0) {
		tostdo_(" ", (ftnlen)1);
		tostdo_(messag, (ftnlen)1000);
		s_copy(line, "File: #", (ftnlen)1000, (ftnlen)7);
		repmc_(line, "#", fnmtbl, line, (ftnlen)1000, (ftnlen)1, (
			ftnlen)128, (ftnlen)1000);
		tostdo_(" ", (ftnlen)1);
		tostdo_(line, (ftnlen)1000);
		if (s_cmp(type__, "CK", (ftnlen)4, (ftnlen)2) == 0) {

/*                 Open the binary file, delete the comments, and close */
/*                 the binary file. */

		    dafopw_(fnmtbl, &handle, (ftnlen)128);
		    spcdc_(&handle);
		    dafcls_(&handle);
		} else if (s_cmp(type__, "PCK", (ftnlen)4, (ftnlen)3) == 0) {

/*                 Open the binary file, delete the comments, and close */
/*                 the binary file. */

		    dafopw_(fnmtbl, &handle, (ftnlen)128);
		    spcdc_(&handle);
		    dafcls_(&handle);
		} else if (s_cmp(type__, "SPK", (ftnlen)4, (ftnlen)3) == 0) {

/*                 Open the binary file, delete the comments, and close */
/*                 the binary file. */

		    dafopw_(fnmtbl, &handle, (ftnlen)128);
		    spcdc_(&handle);
		    dafcls_(&handle);
		} else if (s_cmp(type__, "EK", (ftnlen)4, (ftnlen)2) == 0) {

/*                 Open the binary file, delete the comments, and close */
/*                 the binary file. */

		    dasopw_(fnmtbl, &handle, (ftnlen)128);
		    dasdc_(&handle);
		    dascls_(&handle);
		}

/*              Display the status of the operation that was selected. */

		tostdo_(" ", (ftnlen)1);
		if (failed_()) {
		    tostdo_(status + 1000, (ftnlen)1000);
		} else {
		    tostdo_(status, (ftnlen)1000);
		}
	    }
	}

/*        If anything failed, close any binary files that might still be */
/*        open and reset the error handling before getting the next */
/*        option. */

	if (failed_()) {

/*           Before we can attempt to perform any clean up actions if an */
/*           error occurred, we need to reset the SPICELIB error handling */
/*           mechanism so that we can call the SPICELIB routines that we */
/*           need to. */

	    reset_();

/*           Clear out any binary file handles in the open set, OPNSET. */

	    scardi_(&c__0, opnset);
	    cleari_(&c__1, &opnset[6]);

/*           Get the handles for any DAF files which may still be open. */

	    dafhof_(opnset);
	    numopn = cardi_(opnset);
	    if (numopn > 0) {
		i__2 = numopn;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    dafcls_(&opnset[(i__3 = i__ + 5) < 7 && 0 <= i__3 ? i__3 :
			     s_rnge("opnset", i__3, "commnt_", (ftnlen)1100)])
			    ;
		}
	    }

/*           Clear out any binary file handles in the open set, OPNSET. */

	    scardi_(&c__0, opnset);
	    cleari_(&c__1, &opnset[6]);

/*           Get the handles for any DAS files which may still be open. */

	    dashof_(opnset);
	    numopn = cardi_(opnset);
	    if (numopn > 0) {
		i__2 = numopn;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    dascls_(&opnset[(i__3 = i__ + 5) < 7 && 0 <= i__3 ? i__3 :
			     s_rnge("opnset", i__3, "commnt_", (ftnlen)1121)])
			    ;
		}
	    }

/*           If there was an error and we were extracting comments to a */
/*           file, then we should delete the file that was created, */
/*           because we do not know whether the extraction was completed */
/*           successfully. */

	    if (s_cmp(option, "EXTRACT_COMMENTS", (ftnlen)20, (ftnlen)16) == 
		    0) {
		if (exists_(fnmtbl + 128, (ftnlen)128)) {
		    delfil_(fnmtbl + 128, (ftnlen)128);
		}
	    }

/*           Finally, reset the error handling, and go get the next */
/*           option. This is just to be sure. */

	    reset_();
	}
    }
    chkout_("COMMNT", (ftnlen)6);
    return 0;
} /* MAIN__ */