/* $ Procedure CONVBT ( Convert Kernel file from binary to text ) */
/* Subroutine */ int convbt_(char *binfil, char *txtfil, ftnlen binfil_len,
ftnlen txtfil_len)
{
/* System generated locals */
cllist cl__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen), f_clos(cllist *), s_wsle(
cilist *), do_lio(integer *, integer *, char *, ftnlen), e_wsle(
void);
/* Local variables */
extern /* Subroutine */ int dafbt_(char *, integer *, ftnlen);
char farch[3];
extern /* Subroutine */ int chkin_(char *, ftnlen), spcec_(integer *,
integer *), dasbt_(char *, integer *, ftnlen), errch_(char *,
char *, ftnlen, ftnlen);
char ftype[4];
extern logical failed_(void);
integer handle;
extern /* Subroutine */ int dafcls_(integer *), getfat_(char *, char *,
char *, ftnlen, ftnlen, ftnlen), dafopr_(char *, integer *,
ftnlen), sigerr_(char *, ftnlen), chkout_(char *, ftnlen),
setmsg_(char *, ftnlen);
integer iostat;
logical comnts;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int txtopn_(char *, integer *, ftnlen);
integer txtlun;
/* Fortran I/O blocks */
static cilist io___7 = { 1, 0, 0, 0, 0 };
static cilist io___8 = { 1, 0, 0, 0, 0 };
/* $ Abstract */
/* Convert a SPICE binary file to an equivalent text file format. */
/* NOTE: This routine is currently for use ONLY with the SPACIT */
/* utility program. Use it at your own risk. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* CONVERSION */
/* FILES */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* BINFIL I Name of an existing SPICE binary file. */
/* TXTFIL I Name of the text file to be created. */
/* $ Detailed_Input */
/* None. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* 1) */
/* $ Particulars */
/* This routine accepts as inputs the name of a binary file to be */
/* converted to text and the name of the text file to be created. */
/* The binary file must already exist and the text file must not */
/* exist for this routine to work correctly. The architecture and the */
/* file type are determined and then an appropriate file conversion */
/* is performed. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* 1) */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* $ Version */
/* - Beta Version 3.2.0, 30-AUG-1994 (KRG) */
/* Improved the error diagnostics when incorrect inputs are */
/* provided, e.g., a transfer filename instead of a binary kernel */
/* filename. */
/* - Beta Version 3.1.0, 12-AUG-1994 (KRG) */
/* Fixed a minor bug that would occur when formatting a long error */
/* message. ERRFNM was called with a logical unit that had already */
/* been closed. */
/* - Beta Version 3.0.0, 22-APR-1994 (KRG) */
/* Made updates to the routine to make use of the new SPICE */
/* capability of determining binary kernel file types at run time. */
/* Removed the arguments for the file architecture and file type */
/* from the calling list. This information was no longer */
/* necessary. */
/* Rearranged some of the code to make it easier to understand. */
/* Added a new error: if the architecture or type are not */
/* recognized, we can't process the file. */
/* - Beta Version 2.0.0, 28-JAN-1994 (KRG) */
/* -& */
/* $ Index_Entries */
/* convert binary SPICE files to text */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Begin and end markers in the file for the comment area. */
/* File types that are recognized. */
/* Length of a file architecture. */
/* Maximum length for a file type. */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("CONVBT", (ftnlen)6);
}
/* Initialize the file architecture and the file type. */
s_copy(farch, " ", (ftnlen)3, (ftnlen)1);
s_copy(ftype, " ", (ftnlen)4, (ftnlen)1);
/* Get the architecture and type of the binary file. */
getfat_(binfil, farch, ftype, binfil_len, (ftnlen)3, (ftnlen)4);
if (failed_()) {
/* If there was an error getting the file architecture, just */
/* return. An appropriate error message should have been set. */
/* So, all we need to do here is return to the caller. */
chkout_("CONVBT", (ftnlen)6);
return 0;
}
/* Check to see that we got back a valid architecture and type. */
/* Open the text file for output, obtaining a Fortran logical */
/* unit. */
txtopn_(txtfil, &txtlun, txtfil_len);
if (failed_()) {
/* If there was an error opening the text file, just return. */
/* An appropriate error message should have been set by TXTOPN. */
/* So, all we need to do here is return to the caller. */
chkout_("CONVBT", (ftnlen)6);
return 0;
}
/* Process the files based on their binary architectures */
if (s_cmp(farch, "DAF", (ftnlen)3, (ftnlen)3) == 0) {
/* If the file is a NAIF SPK, CK, or PCK binary file, it may have */
/* a comment area. So set the COMNTS flag appropriately. */
comnts = s_cmp(ftype, "SPK", (ftnlen)4, (ftnlen)3) == 0;
comnts = comnts || s_cmp(ftype, "CK", (ftnlen)4, (ftnlen)2) == 0;
comnts = comnts || s_cmp(ftype, "PCK", (ftnlen)4, (ftnlen)3) == 0;
/* First, convert the data portion of the binary file to text. */
/* We only support the latest and greatest text file format for */
/* conversion of the binary files to text. */
dafbt_(binfil, &txtlun, binfil_len);
if (failed_()) {
/* If an error occurred while attempting to convert the */
/* data portion of the DAF file to text, we need to close */
/* the text file and return to the caller. We will delete */
/* the text file when we close it. */
cl__1.cerr = 0;
cl__1.cunit = txtlun;
cl__1.csta = "DELETE";
f_clos(&cl__1);
chkout_("CONVBT", (ftnlen)6);
return 0;
}
/* The DAF file may or may not have a comment area. If it is a */
/* NAIF SPICE kernel file, then it does and we need to deal with */
/* it. Otherwise we do nothing. */
if (comnts) {
/* We need to open the binary DAF file so that we can extract */
/* the comments from its comment area and place them in the */
/* text file. */
dafopr_(binfil, &handle, binfil_len);
if (failed_()) {
/* If an error occurred, we need to close the text file and */
/* return to the caller. We will delete the text file when */
/* we close it. */
cl__1.cerr = 0;
cl__1.cunit = txtlun;
cl__1.csta = "DELETE";
f_clos(&cl__1);
chkout_("CONVBT", (ftnlen)6);
return 0;
}
/* Write the begin comments marker to the text file. */
io___7.ciunit = txtlun;
iostat = s_wsle(&io___7);
if (iostat != 0) {
goto L100001;
}
iostat = do_lio(&c__9, &c__1, "~NAIF/SPC BEGIN COMMENTS~", (
ftnlen)25);
if (iostat != 0) {
goto L100001;
}
iostat = e_wsle();
L100001:
if (iostat != 0) {
/* An error occurred, so close both the text and binary */
/* files, set an appropriate error message, and return to */
/* the caller. The text file is deleted when it is closed. */
cl__1.cerr = 0;
cl__1.cunit = txtlun;
cl__1.csta = "DELETE";
f_clos(&cl__1);
dafcls_(&handle);
setmsg_("Error writing the begin comments marker to the text"
" file: #. IOSTAT = #.", (ftnlen)72);
errch_("#", txtfil, (ftnlen)1, txtfil_len);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEWRITEFAILED)", (ftnlen)22);
chkout_("CONVBT", (ftnlen)6);
return 0;
}
/* Extract the comment area of the binary file to the text */
/* file. */
spcec_(&handle, &txtlun);
if (failed_()) {
/* If the comment extraction failed, then an appropriate */
/* error message should have already been set, so close */
/* the text and binary files and return to the caller. The */
/* text file is deleted when it is closed. */
cl__1.cerr = 0;
cl__1.cunit = txtlun;
cl__1.csta = "DELETE";
f_clos(&cl__1);
chkout_("CONVBT", (ftnlen)6);
return 0;
}
/* Write the end comments marker. */
io___8.ciunit = txtlun;
iostat = s_wsle(&io___8);
if (iostat != 0) {
goto L100002;
}
iostat = do_lio(&c__9, &c__1, "~NAIF/SPC END COMMENTS~", (ftnlen)
23);
if (iostat != 0) {
goto L100002;
}
iostat = e_wsle();
L100002:
if (iostat != 0) {
/* An error occurred, so close both the text and binary */
/* files, set an appropriate error message, and return to */
/* the caller. The text file is deleted when it is closed. */
cl__1.cerr = 0;
cl__1.cunit = txtlun;
cl__1.csta = "DELETE";
f_clos(&cl__1);
dafcls_(&handle);
setmsg_("Error writing the end comments marker to the text f"
"ile: #. IOSTAT = #.", (ftnlen)70);
errch_("#", txtfil, (ftnlen)1, txtfil_len);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEWRITEFAILED)", (ftnlen)22);
chkout_("CONVBT", (ftnlen)6);
return 0;
}
/* Close the binary DAF file that we opened to extract the */
/* comments. */
dafcls_(&handle);
}
} else if (s_cmp(farch, "DAS", (ftnlen)3, (ftnlen)3) == 0) {
/* DAS files are easy. Everything is integrated into the files */
/* so we do not need to worry about comments or reserved records */
/* or anything. We just convert it. */
/* Convert the data portion of the binary file to text. We */
/* only support the latest and greatest text file format for */
/* conversion of the binary files to text. */
dasbt_(binfil, &txtlun, binfil_len);
if (failed_()) {
/* If an error occurred while attempting to convert the */
/* DAS file to text, we need to close the text file and */
/* return to the caller. We will delete the text file */
/* when we close it. */
cl__1.cerr = 0;
cl__1.cunit = txtlun;
cl__1.csta = "DELETE";
f_clos(&cl__1);
chkout_("CONVBT", (ftnlen)6);
return 0;
}
} else if (s_cmp(farch, "XFR", (ftnlen)3, (ftnlen)3) == 0) {
/* This is an error case, most likely caused by reading a transfer */
/* file by accident. So signal an appropriate error. */
cl__1.cerr = 0;
cl__1.cunit = txtlun;
cl__1.csta = "DELETE";
f_clos(&cl__1);
setmsg_("The file '#' appears to be a transfer file and not a binary"
" kernel file.", (ftnlen)72);
errch_("#", binfil, (ftnlen)1, binfil_len);
sigerr_("SPICE(NOTABINARYKERNEL)", (ftnlen)23);
chkout_("CONVBT", (ftnlen)6);
return 0;
} else if (s_cmp(farch, "DEC", (ftnlen)3, (ftnlen)3) == 0) {
/* This is an error case, most likely caused by reading a transfer */
/* file by accident. So signal an appropriate error. */
cl__1.cerr = 0;
cl__1.cunit = txtlun;
cl__1.csta = "DELETE";
f_clos(&cl__1);
setmsg_("The file '#' appears to be a decimal transfer file and not "
"a binary kernel file.", (ftnlen)80);
errch_("#", binfil, (ftnlen)1, binfil_len);
sigerr_("SPICE(NOTABINARYKERNEL)", (ftnlen)23);
chkout_("CONVBT", (ftnlen)6);
return 0;
} else {
/* This is the catch all error case. At this point, we didn't */
/* match any of the files whose architecture and types are */
/* recognized. So, we toss our hands in the air and signal an */
/* error. */
cl__1.cerr = 0;
cl__1.cunit = txtlun;
cl__1.csta = "DELETE";
f_clos(&cl__1);
setmsg_("The architecture and type of the file '#' were not recogniz"
"ed.", (ftnlen)62);
errch_("#", binfil, (ftnlen)1, binfil_len);
sigerr_("SPICE(BADFILEFORMAT)", (ftnlen)20);
chkout_("CONVBT", (ftnlen)6);
return 0;
}
/* Close the text file that was created. */
cl__1.cerr = 0;
cl__1.cunit = txtlun;
cl__1.csta = 0;
f_clos(&cl__1);
chkout_("CONVBT", (ftnlen)6);
return 0;
} /* convbt_ */
/* $Procedure SPKCOV ( SPK coverage ) */
/* Subroutine */ int spkcov_(char *spk, integer *idcode, doublereal *cover,
ftnlen spk_len)
{
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
char arch[80];
extern /* Subroutine */ int dafgs_(doublereal *), chkin_(char *, ftnlen);
doublereal descr[5];
extern /* Subroutine */ int dafus_(doublereal *, integer *, integer *,
doublereal *, integer *), errch_(char *, char *, ftnlen, ftnlen);
logical found;
doublereal dc[2];
integer ic[6];
extern /* Subroutine */ int daffna_(logical *);
extern logical failed_(void);
extern /* Subroutine */ int dafbfs_(integer *);
integer handle;
extern /* Subroutine */ int dafcls_(integer *), getfat_(char *, char *,
char *, ftnlen, ftnlen, ftnlen), dafopr_(char *, integer *,
ftnlen), sigerr_(char *, ftnlen), chkout_(char *, ftnlen),
setmsg_(char *, ftnlen), wninsd_(doublereal *, doublereal *,
doublereal *);
char kertyp[80];
extern logical return_(void);
/* $ Abstract */
/* Find the coverage window for a specified ephemeris object in a */
/* specified SPK 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 */
/* CELLS */
/* DAF */
/* SPK */
/* TIME */
/* WINDOWS */
/* $ Keywords */
/* EPHEMERIS */
/* TIME */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* SPK I Name of SPK file. */
/* IDCODE I ID code of ephemeris object. */
/* COVER I/O Window giving coverage in SPK for IDCODE. */
/* $ Detailed_Input */
/* SPK is the name of an SPK file. */
/* IDCODE is the integer ID code of an object for which */
/* ephemeris data are expected to exist in the */
/* specified SPK file. */
/* COVER is an initialized SPICELIB window data structure. */
/* COVER optionally may contain coverage data on */
/* input; on output, the data already present in */
/* COVER will be combined with coverage found for the */
/* object designated by IDCODE in the file SPK. */
/* If COVER contains no data on input, its size and */
/* cardinality still must be initialized. */
/* $ Detailed_Output */
/* COVER is a SPICELIB window data structure which */
/* represents the merged coverage for IDCODE. This is */
/* the set of time intervals for which data for */
/* IDCODE are present in the file SPK, merged with */
/* the set of time intervals present in COVER on */
/* input. The merged coverage is represented as the */
/* union of one or more disjoint time intervals. The */
/* window COVER contains the pairs of endpoints of */
/* these intervals. */
/* The interval endpoints contained in COVER are */
/* ephemeris times, expressed as seconds past J2000 */
/* TDB. */
/* See the Examples section below for a complete */
/* example program showing how to retrieve the */
/* endpoints from COVER. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the input file has transfer format, the error */
/* SPICE(INVALIDFORMAT) is signaled. */
/* 2) If the input file is not a transfer file but has architecture */
/* other than DAF, the error SPICE(BADARCHTYPE) is signaled. */
/* 3) If the input file is a binary DAF file of type other than */
/* SPK, the error SPICE(BADFILETYPE) is signaled. */
/* 4) If the SPK file cannot be opened or read, the error will */
/* be diagnosed by routines called by this routine. The output */
/* window will not be modified. */
/* 5) If the size of the output window argument COVER is */
/* insufficient to contain the actual number of intervals in the */
/* coverage window for IDCODE, the error will be diagnosed by */
/* routines called by this routine. */
/* $ Files */
/* This routine reads an SPK file. */
/* $ Particulars */
/* This routine provides an API via which applications can determine */
/* the coverage a specified SPK file provides for a specified */
/* ephemeris object. */
/* $ Examples */
/* 1) This example demonstrates combined usage of SPKCOV and the */
/* related SPK utility SKOBJ. */
/* Display the coverage for each object in a specified SPK file. */
/* Find the set of objects in the file; for each object, find */
/* and display the coverage. */
/* PROGRAM IDCOV */
/* IMPLICIT NONE */
/* C */
/* C SPICELIB functions */
/* C */
/* INTEGER CARDI */
/* INTEGER WNCARD */
/* C */
/* C Local parameters */
/* C */
/* C */
/* C Declare the coverage window. Make enough room */
/* C for MAXIV intervals. */
/* C */
/* INTEGER FILSIZ */
/* PARAMETER ( FILSIZ = 255 ) */
/* INTEGER LBCELL */
/* PARAMETER ( LBCELL = -5 ) */
/* INTEGER MAXIV */
/* PARAMETER ( MAXIV = 1000 ) */
/* INTEGER WINSIZ */
/* PARAMETER ( WINSIZ = 2 * MAXIV ) */
/* INTEGER TIMLEN */
/* PARAMETER ( TIMLEN = 50 ) */
/* INTEGER MAXOBJ */
/* PARAMETER ( MAXOBJ = 1000 ) */
/* C */
/* C Local variables */
/* C */
/* CHARACTER*(FILSIZ) LSK */
/* CHARACTER*(FILSIZ) SPK */
/* CHARACTER*(TIMLEN) TIMSTR */
/* DOUBLE PRECISION B */
/* DOUBLE PRECISION COVER ( LBCELL : WINSIZ ) */
/* DOUBLE PRECISION E */
/* INTEGER I */
/* INTEGER IDS ( LBCELL : MAXOBJ ) */
/* INTEGER J */
/* INTEGER NIV */
/* C */
/* C Load a leapseconds kernel for output time conversion. */
/* C SPKCOV itself does not require a leapseconds kernel. */
/* C */
/* CALL PROMPT ( 'Name of leapseconds kernel > ', LSK ) */
/* CALL FURNSH ( LSK ) */
/* C */
/* C Get name of SPK file. */
/* C */
/* CALL PROMPT ( 'Name of SPK file > ', SPK ) */
/* C */
/* C Initialize the set IDS. */
/* C */
/* CALL SSIZEI ( MAXOBJ, IDS ) */
/* C */
/* C Initialize the window COVER. */
/* C */
/* CALL SSIZED ( WINSIZ, COVER ) */
/* C */
/* C Find the set of objects in the SPK file. */
/* C */
/* CALL SPKOBJ ( SPK, IDS ) */
/* C */
/* C We want to display the coverage for each object. Loop */
/* C over the contents of the ID code set, find the coverage */
/* C for each item in the set, and display the coverage. */
/* C */
/* DO I = 1, CARDI( IDS ) */
/* C */
/* C Find the coverage window for the current */
/* C object. Empty the coverage window each time */
/* C so we don't include data for the previous object. */
/* C */
/* CALL SCARDD ( 0, COVER ) */
/* CALL SPKCOV ( SPK, IDS(I), COVER ) */
/* C */
/* C Get the number of intervals in the coverage */
/* C window. */
/* C */
/* NIV = WNCARD ( COVER ) */
/* C */
/* C Display a simple banner. */
/* C */
/* WRITE (*,*) '========================================' */
/* WRITE (*,*) 'Coverage for object ', IDS(I) */
/* C */
/* C Convert the coverage interval start and stop */
/* C times to TDB calendar strings. */
/* C */
/* DO J = 1, NIV */
/* C */
/* C Get the endpoints of the Jth interval. */
/* C */
/* CALL WNFETD ( COVER, J, B, E ) */
/* C */
/* C Convert the endpoints to TDB calendar */
/* C format time strings and display them. */
/* C */
/* CALL TIMOUT ( B, */
/* . 'YYYY MON DD HR:MN:SC.### ' // */
/* . '(TDB) ::TDB', */
/* . TIMSTR ) */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Interval: ', J */
/* WRITE (*,*) 'Start: ', TIMSTR */
/* CALL TIMOUT ( E, */
/* . 'YYYY MON DD HR:MN:SC.### ' // */
/* . '(TDB) ::TDB', */
/* . TIMSTR ) */
/* WRITE (*,*) 'Stop: ', TIMSTR */
/* WRITE (*,*) ' ' */
/* END DO */
/* WRITE (*,*) '========================================' */
/* END DO */
/* END */
/* 2) Find the coverage for the object designated by IDCODE */
/* provided by the set of SPK files loaded via a metakernel. */
/* (The metakernel must also specify a leapseconds kernel.) */
/* PROGRAM METCOV */
/* IMPLICIT NONE */
/* C */
/* C SPICELIB functions */
/* C */
/* INTEGER WNCARD */
/* C */
/* C Local parameters */
/* C */
/* INTEGER LBCELL */
/* PARAMETER ( LBCELL = -5 ) */
/* INTEGER FILSIZ */
/* PARAMETER ( FILSIZ = 255 ) */
/* INTEGER LNSIZE */
/* PARAMETER ( LNSIZE = 80 ) */
/* INTEGER MAXCOV */
/* PARAMETER ( MAXCOV = 100000 ) */
/* INTEGER TIMLEN */
/* PARAMETER ( TIMLEN = 50 ) */
/* C */
/* C Local variables */
/* C */
/* CHARACTER*(FILSIZ) FILE */
/* CHARACTER*(LNSIZE) IDCH */
/* CHARACTER*(FILSIZ) META */
/* CHARACTER*(FILSIZ) SOURCE */
/* CHARACTER*(TIMLEN) TIMSTR */
/* CHARACTER*(LNSIZE) TYPE */
/* DOUBLE PRECISION B */
/* DOUBLE PRECISION COVER ( LBCELL : 2*MAXCOV ) */
/* DOUBLE PRECISION E */
/* INTEGER COUNT */
/* INTEGER HANDLE */
/* INTEGER I */
/* INTEGER IDCODE */
/* INTEGER NIV */
/* LOGICAL FOUND */
/* C */
/* C Prompt for the metakernel name; load the metakernel. */
/* C The metakernel lists the SPK files whose coverage */
/* C for IDCODE we'd like to determine. The metakernel */
/* C must also specify a leapseconds kernel. */
/* C */
/* CALL PROMPT ( 'Enter name of metakernel > ', META ) */
/* CALL FURNSH ( META ) */
/* C */
/* C Get the ID code of interest. */
/* C */
/* CALL PROMPT ( 'Enter ID code > ', IDCH ) */
/* CALL PRSINT ( IDCH, IDCODE ) */
/* C */
/* C Initialize the coverage window. */
/* C */
/* CALL SSIZED ( MAXCOV, COVER ) */
/* C */
/* C Find out how many kernels are loaded. Loop over the */
/* C kernels: for each loaded SPK file, add its coverage */
/* C for IDCODE, if any, to the coverage window. */
/* C */
/* CALL KTOTAL ( 'SPK', COUNT ) */
/* DO I = 1, COUNT */
/* CALL KDATA ( I, 'SPK', FILE, TYPE, */
/* . SOURCE, HANDLE, FOUND ) */
/* CALL SPKCOV ( FILE, IDCODE, COVER ) */
/* END DO */
/* C */
/* C Display results. */
/* C */
/* C Get the number of intervals in the coverage */
/* C window. */
/* C */
/* NIV = WNCARD ( COVER ) */
/* C */
/* C Display a simple banner. */
/* C */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Coverage for object ', IDCODE */
/* C */
/* C Convert the coverage interval start and stop */
/* C times to TDB calendar strings. */
/* C */
/* DO I = 1, NIV */
/* C */
/* C Get the endpoints of the Ith interval. */
/* C */
/* CALL WNFETD ( COVER, I, B, E ) */
/* C */
/* C Convert the endpoints to TDB calendar */
/* C format time strings and display them. */
/* C */
/* CALL TIMOUT ( B, */
/* . 'YYYY MON DD HR:MN:SC.### ' // */
/* . '(TDB) ::TDB', */
/* . TIMSTR ) */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Interval: ', I */
/* WRITE (*,*) 'Start: ', TIMSTR */
/* CALL TIMOUT ( E, */
/* . 'YYYY MON DD HR:MN:SC.### ' // */
/* . '(TDB) ::TDB', */
/* . TIMSTR ) */
/* WRITE (*,*) 'Stop: ', TIMSTR */
/* WRITE (*,*) ' ' */
/* END DO */
/* END */
/* $ Restrictions */
/* 1) If an error occurs while this routine is updating the window */
/* COVER, the window may be corrupted. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.2, 01-JUL-2014 (NJB) */
/* Added new index entries. */
/* - SPICELIB Version 1.0.1, 30-NOV-2007 (NJB) */
/* Corrected bug in first program in header Examples section: */
/* program now empties the coverage window prior to collecting */
/* data for the current object. Updated examples to use WNCARD */
/* rather than CARDD. */
/* - SPICELIB Version 1.0.0, 30-DEC-2004 (NJB) */
/* -& */
/* $ Index_Entries */
/* get coverage window for spk_object */
/* get coverage start and stop time for spk_object */
/* get coverage start and stop time for ephemeris_object */
/* get coverage start and stop time for body */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
chkin_("SPKCOV", (ftnlen)6);
/* See whether GETFAT thinks we've got a binary SPK file. */
/* If not, indicate the specific problem. */
getfat_(spk, arch, kertyp, spk_len, (ftnlen)80, (ftnlen)80);
if (s_cmp(arch, "XFR", (ftnlen)80, (ftnlen)3) == 0) {
setmsg_("Input file # has architecture #. The file must be a binary "
"SPK file to be readable by this routine. If the input file "
"is an SPK file in transfer format, run TOBIN on the file to "
"convert it to binary format.", (ftnlen)207);
errch_("#", spk, (ftnlen)1, spk_len);
errch_("#", arch, (ftnlen)1, (ftnlen)80);
sigerr_("SPICE(INVALIDFORMAT)", (ftnlen)20);
chkout_("SPKCOV", (ftnlen)6);
return 0;
} else if (s_cmp(arch, "DAF", (ftnlen)80, (ftnlen)3) != 0) {
setmsg_("Input file # has architecture #. The file must be a binary "
"SPK file to be readable by this routine. Binary SPK files h"
"ave DAF architecture. If you expected the file to be a bina"
"ry SPK file, the problem may be due to the file being an old"
" non-native file lacking binary file format information. It'"
"s also possible the file has been corrupted.", (ftnlen)343);
errch_("#", spk, (ftnlen)1, spk_len);
errch_("#", arch, (ftnlen)1, (ftnlen)80);
sigerr_("SPICE(INVALIDARCHTYPE)", (ftnlen)22);
chkout_("SPKCOV", (ftnlen)6);
return 0;
} else if (s_cmp(kertyp, "SPK", (ftnlen)80, (ftnlen)3) != 0) {
setmsg_("Input file # has file type #. The file must be a binary SPK"
" file to be readable by this routine. If you expected the fi"
"le to be a binary SPK file, the problem may be due to the fi"
"le being an old non-native file lacking binary file format i"
"nformation. It's also possible the file has been corrupted.",
(ftnlen)298);
errch_("#", spk, (ftnlen)1, spk_len);
errch_("#", kertyp, (ftnlen)1, (ftnlen)80);
sigerr_("SPICE(INVALIDFILETYPE)", (ftnlen)22);
chkout_("SPKCOV", (ftnlen)6);
return 0;
}
/* Open the file for reading. */
dafopr_(spk, &handle, spk_len);
if (failed_()) {
chkout_("SPKCOV", (ftnlen)6);
return 0;
}
/* We will examine each segment descriptor in the file, and */
/* we'll update our coverage bounds according to the data found */
/* in these descriptors. */
/* Start a forward search. */
dafbfs_(&handle);
/* Find the next DAF array. */
daffna_(&found);
while(found && ! failed_()) {
/* Fetch and unpack the segment descriptor. */
dafgs_(descr);
dafus_(descr, &c__2, &c__6, dc, ic);
if (ic[0] == *idcode) {
/* This segment is for the body of interest. Insert the */
/* coverage bounds into the coverage window. */
wninsd_(dc, &dc[1], cover);
}
daffna_(&found);
}
/* Release the file. */
dafcls_(&handle);
chkout_("SPKCOV", (ftnlen)6);
return 0;
} /* spkcov_ */
/* $Procedure CKCOV ( CK coverage ) */
/* Subroutine */ int ckcov_(char *ck, integer *idcode, logical *needav, char *
level, doublereal *tol, char *timsys, doublereal *cover, ftnlen
ck_len, ftnlen level_len, ftnlen timsys_len)
{
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), s_rnge(char *, integer,
char *, integer);
/* Local variables */
char arch[80];
logical avok;
extern /* Subroutine */ int sct2e_(integer *, doublereal *, doublereal *);
integer i__;
extern /* Subroutine */ int dafgs_(doublereal *);
integer clkid;
extern /* Subroutine */ int chkin_(char *, ftnlen);
doublereal descr[5];
extern /* Subroutine */ int dafus_(doublereal *, integer *, integer *,
doublereal *, integer *), errch_(char *, char *, ftnlen, ftnlen);
doublereal dctol[2];
logical istdb, found;
extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen);
integer dtype;
extern logical eqstr_(char *, char *, ftnlen, ftnlen);
doublereal dc[2];
integer ic[6];
extern /* Subroutine */ int daffna_(logical *);
extern logical failed_(void);
extern /* Subroutine */ int dafbfs_(integer *);
doublereal et;
integer handle, segbeg;
extern /* Subroutine */ int dafcls_(integer *), ckmeta_(integer *, char *,
integer *, ftnlen);
integer segend;
extern /* Subroutine */ int getfat_(char *, char *, char *, ftnlen,
ftnlen, ftnlen), dafopr_(char *, integer *, ftnlen), sigerr_(char
*, ftnlen);
logical seglvl;
extern /* Subroutine */ int chkout_(char *, ftnlen), setmsg_(char *,
ftnlen), wninsd_(doublereal *, doublereal *, doublereal *),
errint_(char *, integer *, ftnlen);
char kertyp[80];
extern logical return_(void);
extern /* Subroutine */ int zzckcv01_(integer *, integer *, integer *,
integer *, doublereal *, char *, doublereal *, ftnlen), zzckcv02_(
integer *, integer *, integer *, integer *, doublereal *, char *,
doublereal *, ftnlen), zzckcv03_(integer *, integer *, integer *,
integer *, doublereal *, char *, doublereal *, ftnlen), zzckcv04_(
integer *, integer *, integer *, integer *, doublereal *, char *,
doublereal *, ftnlen), zzckcv05_(integer *, integer *, integer *,
integer *, doublereal *, doublereal *, char *, doublereal *,
ftnlen);
/* $ Abstract */
/* Find the coverage window for a specified object in a specified CK */
/* file. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* CELLS */
/* DAF */
/* CK */
/* TIME */
/* WINDOWS */
/* $ Keywords */
/* POINTING */
/* TIME */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* CK I Name of CK file. */
/* IDCODE I ID code of object. */
/* NEEDAV I Flag indicating whether angular velocity is needed. */
/* LEVEL I Coverage level: 'SEGMENT' OR 'INTERVAL'. */
/* TOL I Tolerance in ticks. */
/* TIMSYS I Time system used to represent coverage. */
/* COVER I/O Window giving coverage for IDCODE. */
/* $ Detailed_Input */
/* CK is the name of a C-kernel. */
/* IDCODE is the integer ID code of an object, normally */
/* a spacecraft structure or instrument, for which */
/* pointing data are expected to exist in the */
/* specified CK file. */
/* NEEDAV is a logical variable indicating whether only */
/* segments having angular velocity are to be */
/* considered when determining coverage. When */
/* NEEDAV is .TRUE., segments without angular */
/* velocity don't contribute to the coverage */
/* window; when NEEDAV is .FALSE., all segments for */
/* IDCODE may contribute to the coverage window. */
/* LEVEL is the level (granularity) at which the coverage */
/* is examined. Allowed values and corresponding */
/* meanings are: */
/* 'SEGMENT' The output coverage window */
/* contains intervals defined by the */
/* start and stop times of segments */
/* for the object designated by */
/* IDCODE. */
/* 'INTERVAL' The output coverage window */
/* contains interpolation intervals */
/* of segments for the object */
/* designated by IDCODE. For type 1 */
/* segments, which don't have */
/* interpolation intervals, each */
/* epoch associated with a pointing */
/* instance is treated as a singleton */
/* interval; these intervals are */
/* added to the coverage window. */
/* All interpolation intervals are */
/* considered to lie within the */
/* segment bounds for the purpose of */
/* this summary: if an interpolation */
/* interval extends beyond the */
/* segment coverage interval, only */
/* its intersection with the segment */
/* coverage interval is considered to */
/* contribute to the total coverage. */
/* TOL is a tolerance value expressed in ticks of the */
/* spacecraft clock associated with IDCODE. Before */
/* each interval is inserted into the coverage */
/* window, the interval is intersected with the */
/* segment coverage interval, then if the */
/* intersection is non-empty, it is expanded by TOL: */
/* the left endpoint of the intersection interval is */
/* reduced by TOL and the right endpoint is increased */
/* by TOL. Adjusted interval endpoints, when */
/* expressed as encoded SCLK, never are less than */
/* zero ticks. Any intervals that overlap as a */
/* result of the expansion are merged. */
/* The coverage window returned when TOL > 0 */
/* indicates the coverage provided by the file to the */
/* CK readers CKGPAV and CKGP when that value of TOL */
/* is passed to them as an input. */
/* TIMSYS is a string indicating the time system used */
/* in the output coverage window. TIMSYS may */
/* have the values: */
/* 'SCLK' Elements of COVER are expressed in */
/* encoded SCLK ("ticks"), where the */
/* clock is associated with the object */
/* designated by IDCODE. */
/* 'TDB' Elements of COVER are expressed as */
/* seconds past J2000 TDB. */
/* COVER is an initialized SPICELIB window data structure. */
/* COVER optionally may contain coverage data on */
/* input; on output, the data already present in */
/* COVER will be combined with coverage found for the */
/* object designated by IDCODE in the file CK. */
/* If COVER contains no data on input, its size and */
/* cardinality still must be initialized. */
/* $ Detailed_Output */
/* COVER is a SPICELIB window data structure which */
/* represents the merged coverage for IDCODE. When */
/* the coverage level is 'INTERVAL', this is the set */
/* of time intervals for which data for IDCODE are */
/* present in the file CK, merged with the set of */
/* time intervals present in COVER on input. The */
/* merged coverage is represented as the union of one */
/* or more disjoint time intervals. The window COVER */
/* contains the pairs of endpoints of these */
/* intervals. */
/* When the coverage level is 'SEGMENT', COVER is */
/* computed in a manner similar to that described */
/* above, but the coverage intervals used in the */
/* computation are those of segments rather than */
/* interpolation intervals within segments. */
/* When TOL is > 0, the intervals comprising the */
/* coverage window for IDCODE are expanded by TOL and */
/* any intervals overlapping as a result are merged. */
/* The resulting window is returned in COVER. The */
/* expanded window in no case extends beyond the */
/* segment bounds in either direction by more than */
/* TOL. */
/* The interval endpoints contained in COVER are */
/* encoded spacecraft clock times if TIMSYS is */
/* 'SCLK'; otherwise the times are converted from */
/* encoded spacecraft clock to seconds past J2000 */
/* TDB. */
/* See the Examples section below for a complete */
/* example program showing how to retrieve the */
/* endpoints from COVER. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the input file has transfer format, the error */
/* SPICE(INVALIDFORMAT) is signaled. */
/* 2) If the input file is not a transfer file but has architecture */
/* other than DAF, the error SPICE(BADARCHTYPE) is signaled. */
/* 3) If the input file is a binary DAF file of type other than */
/* CK, the error SPICE(BADFILETYPE) is signaled. */
/* 4) If the CK file cannot be opened or read, the error will */
/* be diagnosed by routines called by this routine. The output */
/* window will not be modified. */
/* 5) If the size of the output WINDOW argument COVER is */
/* insufficient to contain the actual number of intervals in the */
/* coverage window for IDCODE, the error will be diagnosed by */
/* routines called by this routine. */
/* 6) If TOL is negative, the error SPICE(VALUEOUTOFRANGE) is */
/* signaled. */
/* 7) If LEVEL is not recognized, the error SPICE(INVALIDOPTION) */
/* is signaled. */
/* 8) If TIMSYS is not recognized, the error SPICE(NOTSUPPORTED) */
/* is signaled. */
/* 9) If a time conversion error occurs, the error will be */
/* diagnosed by a routine in the call tree of this routine. */
/* 10) If the output time system is TDB, the CK subsystem must be */
/* able to map IDCODE to the ID code of the associated */
/* spacecraft clock. If this mapping cannot be performed, the */
/* error will be diagnosed by a routine in the call tree of this */
/* routine. */
/* $ Files */
/* This routine reads a C-kernel. */
/* If the output time system is 'TDB', then a leapseconds kernel */
/* and an SCLK kernel for the spacecraft clock associated with */
/* IDCODE must be loaded before this routine is called. */
/* If the ID code of the clock associated with IDCODE is not */
/* equal to */
/* IDCODE / 1000 */
/* then the kernel variable */
/* CK_<IDCODE>_SCLK */
/* must be present in the kernel pool to identify the clock */
/* associated with IDCODE. This variable must contain the ID code */
/* to be used for conversion between SCLK and TDB. Normally this */
/* variable is provided in a text kernel loaded via FURNSH. */
/* $ Particulars */
/* This routine provides an API via which applications can determine */
/* the coverage a specified CK file provides for a specified */
/* object. */
/* $ Examples */
/* 1) Display the interval-level coverage for each object in a */
/* specified CK file. Use tolerance of zero ticks. Do not */
/* request angular velocity. Express the results in the TDB time */
/* system. */
/* Find the set of objects in the file. Loop over the contents */
/* of the ID code set: find the coverage for each item in the */
/* set and display the coverage. */
/* PROGRAM CKCVR */
/* IMPLICIT NONE */
/* C */
/* C SPICELIB functions */
/* C */
/* INTEGER WNCARD */
/* INTEGER CARDI */
/* C */
/* C Local parameters */
/* C */
/* C */
/* C Declare the coverage window. Make enough room */
/* C for MAXIV intervals. */
/* C */
/* INTEGER FILSIZ */
/* PARAMETER ( FILSIZ = 255 ) */
/* INTEGER LBCELL */
/* PARAMETER ( LBCELL = -5 ) */
/* INTEGER MAXIV */
/* PARAMETER ( MAXIV = 100000 ) */
/* INTEGER WINSIZ */
/* PARAMETER ( WINSIZ = 2 * MAXIV ) */
/* INTEGER TIMLEN */
/* PARAMETER ( TIMLEN = 50 ) */
/* INTEGER MAXOBJ */
/* PARAMETER ( MAXOBJ = 1000 ) */
/* C */
/* C Local variables */
/* C */
/* CHARACTER*(FILSIZ) CK */
/* CHARACTER*(FILSIZ) LSK */
/* CHARACTER*(FILSIZ) SCLK */
/* CHARACTER*(TIMLEN) TIMSTR */
/* DOUBLE PRECISION B */
/* DOUBLE PRECISION COVER ( LBCELL : WINSIZ ) */
/* DOUBLE PRECISION E */
/* INTEGER I */
/* INTEGER IDS ( LBCELL : MAXOBJ ) */
/* INTEGER J */
/* INTEGER NIV */
/* C */
/* C Load a leapseconds kernel and SCLK kernel for output */
/* C time conversion. Note that we assume a single spacecraft */
/* C clock is associated with all of the objects in the CK. */
/* C */
/* CALL PROMPT ( 'Name of leapseconds kernel > ', LSK ) */
/* CALL FURNSH ( LSK ) */
/* CALL PROMPT ( 'Name of SCLK kernel > ', SCLK ) */
/* CALL FURNSH ( SCLK ) */
/* C */
/* C Get name of CK file. */
/* C */
/* CALL PROMPT ( 'Name of CK file > ', CK ) */
/* C */
/* C Initialize the set IDS. */
/* C */
/* CALL SSIZEI ( MAXOBJ, IDS ) */
/* C */
/* C Initialize the window COVER. */
/* C */
/* CALL SSIZED ( WINSIZ, COVER ) */
/* C */
/* C Find the set of objects in the CK file. */
/* C */
/* CALL CKOBJ ( CK, IDS ) */
/* C */
/* C We want to display the coverage for each object. Loop */
/* C over the contents of the ID code set, find the coverage */
/* C for each item in the set, and display the coverage. */
/* C */
/* DO I = 1, CARDI( IDS ) */
/* C */
/* C Find the coverage window for the current */
/* C object. Empty the coverage window each time */
/* C so we don't include data for the previous object. */
/* C */
/* CALL SCARDD ( 0, COVER ) */
/* CALL CKCOV ( CK, IDS(I), .FALSE., */
/* . 'INTERVAL', 0.D0, 'TDB', COVER ) */
/* C */
/* C Get the number of intervals in the coverage */
/* C window. */
/* C */
/* NIV = WNCARD( COVER ) */
/* C */
/* C Display a simple banner. */
/* C */
/* WRITE (*,*) '========================================' */
/* WRITE (*,*) 'Coverage for object ', IDS(I) */
/* C */
/* C Convert the coverage interval start and stop */
/* C times to TDB calendar strings. */
/* C */
/* DO J = 1, NIV */
/* C */
/* C Get the endpoints of the Jth interval. */
/* C */
/* CALL WNFETD ( COVER, J, B, E ) */
/* C */
/* C Convert the endpoints to TDB calendar */
/* C format time strings and display them. */
/* C */
/* CALL TIMOUT ( B, */
/* . 'YYYY MON DD HR:MN:SC.###### ' // */
/* . '(TDB) ::TDB', */
/* . TIMSTR ) */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Interval: ', J */
/* WRITE (*,*) 'Start: ', TIMSTR */
/* CALL TIMOUT ( E, */
/* . 'YYYY MON DD HR:MN:SC.###### ' // */
/* . '(TDB) ::TDB', */
/* . TIMSTR ) */
/* WRITE (*,*) 'Stop: ', TIMSTR */
/* WRITE (*,*) ' ' */
/* END DO */
/* WRITE (*,*) '========================================' */
/* END DO */
/* END */
/* 2) Find the segment-level coverage for the object designated by */
/* IDCODE provided by the set of CK files loaded via a */
/* metakernel. (The metakernel must also specify leapseconds and */
/* SCLK kernels.) Use tolerance of zero ticks. Do not request */
/* angular velocity. Express the results in the TDB time system. */
/* PROGRAM CKMET */
/* IMPLICIT NONE */
/* C */
/* C SPICELIB functions */
/* C */
/* INTEGER WNCARD */
/* C */
/* C Local parameters */
/* C */
/* INTEGER LBCELL */
/* PARAMETER ( LBCELL = -5 ) */
/* INTEGER FILSIZ */
/* PARAMETER ( FILSIZ = 255 ) */
/* INTEGER LNSIZE */
/* PARAMETER ( LNSIZE = 80 ) */
/* INTEGER MAXCOV */
/* PARAMETER ( MAXCOV = 100000 ) */
/* INTEGER TIMLEN */
/* PARAMETER ( TIMLEN = 50 ) */
/* C */
/* C Local variables */
/* C */
/* CHARACTER*(FILSIZ) FILE */
/* CHARACTER*(LNSIZE) IDCH */
/* CHARACTER*(FILSIZ) META */
/* CHARACTER*(FILSIZ) SOURCE */
/* CHARACTER*(TIMLEN) TIMSTR */
/* CHARACTER*(LNSIZE) TYPE */
/* DOUBLE PRECISION B */
/* DOUBLE PRECISION COVER ( LBCELL : 2*MAXCOV ) */
/* DOUBLE PRECISION E */
/* INTEGER COUNT */
/* INTEGER HANDLE */
/* INTEGER I */
/* INTEGER IDCODE */
/* INTEGER NIV */
/* LOGICAL FOUND */
/* C */
/* C Prompt for the metakernel name; load the metakernel. */
/* C The metakernel lists the CK files whose coverage */
/* C for IDCODE we'd like to determine. The metakernel */
/* C must also specify a leapseconds kernel and an SCLK */
/* C kernel for the clock associated with IDCODE. */
/* C */
/* CALL PROMPT ( 'Enter name of metakernel > ', META ) */
/* CALL FURNSH ( META ) */
/* C */
/* C Get the ID code of interest. */
/* C */
/* CALL PROMPT ( 'Enter ID code > ', IDCH ) */
/* CALL PRSINT ( IDCH, IDCODE ) */
/* C */
/* C Initialize the coverage window. */
/* C */
/* CALL SSIZED ( MAXCOV, COVER ) */
/* C */
/* C Find out how many kernels are loaded. Loop over the */
/* C kernels: for each loaded CK file, add its coverage */
/* C for IDCODE, if any, to the coverage window. */
/* C */
/* CALL KTOTAL ( 'CK', COUNT ) */
/* DO I = 1, COUNT */
/* CALL KDATA ( I, 'CK', FILE, TYPE, */
/* . SOURCE, HANDLE, FOUND ) */
/* CALL CKCOV ( FILE, IDCODE, .FALSE., */
/* . 'SEGMENT', 0.0, 'TDB', COVER ) */
/* END DO */
/* C */
/* C Display results. */
/* C */
/* C Get the number of intervals in the coverage */
/* C window. */
/* C */
/* NIV = WNCARD( COVER ) */
/* C */
/* C Display a simple banner. */
/* C */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Coverage for object ', IDCODE */
/* C */
/* C Convert the coverage interval start and stop */
/* C times to TDB calendar strings. */
/* C */
/* DO I = 1, NIV */
/* C */
/* C Get the endpoints of the Ith interval. */
/* C */
/* CALL WNFETD ( COVER, I, B, E ) */
/* C */
/* C Convert the endpoints to TDB calendar */
/* C format time strings and display them. */
/* C */
/* CALL TIMOUT ( B, */
/* . 'YYYY MON DD HR:MN:SC.###### ' // */
/* . '(TDB) ::TDB', */
/* . TIMSTR ) */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Interval: ', I */
/* WRITE (*,*) 'Start: ', TIMSTR */
/* CALL TIMOUT ( E, */
/* . 'YYYY MON DD HR:MN:SC.###### ' // */
/* . '(TDB) ::TDB', */
/* . TIMSTR ) */
/* WRITE (*,*) 'Stop: ', TIMSTR */
/* WRITE (*,*) ' ' */
/* END DO */
/* END */
/* $ Restrictions */
/* 1) When this routine is used to accumulate coverage for IDCODE */
/* provided by multiple CK files, the inputs NEEDAV, LEVEL, TOL, */
/* and TIMSYS must have the same values for all files in order */
/* for the result to be meaningful. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.1, 30-NOV-2007 (NJB) */
/* Corrected bug in first program in header Examples section: */
/* program now empties the coverage window prior to collecting */
/* data for the current object. Updated examples to use WNCARD */
/* rather than CARDD. */
/* - SPICELIB Version 1.0.0, 07-JAN-2005 (NJB) */
/* -& */
/* $ Index_Entries */
/* get coverage window for ck object */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
chkin_("CKCOV", (ftnlen)5);
/* Check tolerance value. */
if (*tol < 0.) {
setmsg_("Tolerance must be non-negative; actual value was #.", (
ftnlen)51);
errdp_("#", tol, (ftnlen)1);
sigerr_("SPICE(VALUEOUTOFRANGE)", (ftnlen)22);
chkout_("CKCOV", (ftnlen)5);
return 0;
}
/* Use a logical flag to indicate whether this is a segment-level */
/* coverage description. */
seglvl = eqstr_(level, "SEGMENT", level_len, (ftnlen)7);
/* Check coverage level keyword. */
if (! (seglvl || eqstr_(level, "INTERVAL", level_len, (ftnlen)8))) {
setmsg_("Allowed values of LEVEL are # and #; actual value was #.", (
ftnlen)56);
errch_("#", "SEGMENT", (ftnlen)1, (ftnlen)7);
errch_("#", "INTERVAL", (ftnlen)1, (ftnlen)8);
errch_("#", level, (ftnlen)1, level_len);
sigerr_("SPICE(INVALIDOPTION)", (ftnlen)20);
chkout_("CKCOV", (ftnlen)5);
return 0;
}
/* See whether GETFAT thinks we've got a CK file. */
getfat_(ck, arch, kertyp, ck_len, (ftnlen)80, (ftnlen)80);
if (s_cmp(arch, "XFR", (ftnlen)80, (ftnlen)3) == 0) {
setmsg_("Input file # has architecture #. The file must be a binary "
"CK file to be readable by this routine. If the input file i"
"s an CK file in transfer format, run TOBIN on the file to co"
"nvert it to binary format.", (ftnlen)205);
errch_("#", ck, (ftnlen)1, ck_len);
errch_("#", arch, (ftnlen)1, (ftnlen)80);
sigerr_("SPICE(INVALIDFORMAT)", (ftnlen)20);
chkout_("CKCOV", (ftnlen)5);
return 0;
} else if (s_cmp(arch, "DAF", (ftnlen)80, (ftnlen)3) != 0) {
setmsg_("Input file # has architecture #. The file must be a binary "
"CK file to be readable by this routine. Binary CK files hav"
"e DAF architecture. If you expected the file to be a binary"
" CK file, the problem may be due to the file being an old no"
"n-native file lacking binary file format information. It's a"
"lso possible the file has been corrupted.", (ftnlen)340);
errch_("#", ck, (ftnlen)1, ck_len);
errch_("#", arch, (ftnlen)1, (ftnlen)80);
sigerr_("SPICE(INVALIDARCHTYPE)", (ftnlen)22);
chkout_("CKCOV", (ftnlen)5);
return 0;
} else if (s_cmp(kertyp, "CK", (ftnlen)80, (ftnlen)2) != 0) {
setmsg_("Input file # has file type #. The file must be a binary CK "
"file to be readable by this routine. If you expected the fil"
"e to be a binary CK file, the problem may be due to the file"
" being an old non-native file lacking binary file format inf"
"ormation. It's also possible the file has been corrupted.", (
ftnlen)296);
errch_("#", ck, (ftnlen)1, ck_len);
errch_("#", kertyp, (ftnlen)1, (ftnlen)80);
sigerr_("SPICE(INVALIDFILETYPE)", (ftnlen)22);
chkout_("CKCOV", (ftnlen)5);
return 0;
}
/* Set a logical flag indicating whether the time systm is SCLK. */
istdb = eqstr_(timsys, "TDB", timsys_len, (ftnlen)3);
/* Check time system. */
if (! istdb) {
if (! eqstr_(timsys, "SCLK", timsys_len, (ftnlen)4)) {
setmsg_("Time system spec TIMSYS was #; allowed values are SCLK "
"and TDB.", (ftnlen)63);
errch_("#", timsys, (ftnlen)1, timsys_len);
sigerr_("SPICE(NOTSUPPORTED)", (ftnlen)19);
chkout_("CKCOV", (ftnlen)5);
return 0;
}
}
/* If the output time system is TDB, find the clock ID associated */
/* with IDCODE. */
if (istdb) {
ckmeta_(idcode, "SCLK", &clkid, (ftnlen)4);
if (failed_()) {
chkout_("CKCOV", (ftnlen)5);
return 0;
}
}
/* Open the file for reading. */
dafopr_(ck, &handle, ck_len);
if (failed_()) {
chkout_("CKCOV", (ftnlen)5);
return 0;
}
/* We will examine each segment descriptor in the file, and */
/* we'll update our coverage bounds according to the data found */
/* in these descriptors. */
/* If TOL > 0, we'll apply TOL after we've found the coverage */
/* for the zero-tolerance case. */
/* If the time system is TDB, we'll convert the times to TDB */
/* at the end of this routine. */
/* Start a forward search. */
dafbfs_(&handle);
/* Find the next DAF array. */
daffna_(&found);
while(found) {
/* Note: we check FAILED() at the bottom of this loop; this */
/* routine returns if FAILED() returns .TRUE. at that point. */
/* Fetch and unpack the segment descriptor. */
dafgs_(descr);
dafus_(descr, &c__2, &c__6, dc, ic);
/* Let AVOK indicate whether the segment satisfies the */
/* angular velocity restriction. */
avok = ic[3] == 1 || ! (*needav);
if (ic[0] == *idcode && avok) {
/* This segment is for the body of interest. If angular */
/* velocity is needed, this segment has it. */
if (seglvl) {
/* This is a segment-level summary. */
/* Insert the coverage bounds into the coverage window. */
/* Adjust the interval using the tolerance. */
/* Computing MAX */
d__1 = dc[0] - *tol;
dctol[0] = max(d__1,0.);
dctol[1] = dc[1] + *tol;
/* Convert the time to TDB if necessary. */
if (istdb) {
/* Convert the time bounds to TDB before inserting */
/* into the window. */
for (i__ = 1; i__ <= 2; ++i__) {
sct2e_(&clkid, &dctol[(i__1 = i__ - 1) < 2 && 0 <=
i__1 ? i__1 : s_rnge("dctol", i__1, "ckcov_",
(ftnlen)868)], &et);
dctol[(i__1 = i__ - 1) < 2 && 0 <= i__1 ? i__1 :
s_rnge("dctol", i__1, "ckcov_", (ftnlen)869)]
= et;
}
}
if (dctol[0] <= dctol[1]) {
wninsd_(dctol, &dctol[1], cover);
}
} else {
/* We're looking for an interval-level coverage window. */
/* This information must be retrieved in a */
/* data-type-dependent fashion. The coverage routines */
/* we'll call will, if necessary, adjust intervals by TOL */
/* and convert interval times to TDB. */
dtype = ic[2];
segbeg = ic[4];
segend = ic[5];
if (dtype == 1) {
zzckcv01_(&handle, &segbeg, &segend, &clkid, tol, timsys,
cover, timsys_len);
} else if (dtype == 2) {
zzckcv02_(&handle, &segbeg, &segend, &clkid, tol, timsys,
cover, timsys_len);
} else if (dtype == 3) {
zzckcv03_(&handle, &segbeg, &segend, &clkid, tol, timsys,
cover, timsys_len);
} else if (dtype == 4) {
zzckcv04_(&handle, &segbeg, &segend, &clkid, tol, timsys,
cover, timsys_len);
} else if (dtype == 5) {
/* Note: this calling sequence is exceptional; the */
/* segment bounds are an input. */
zzckcv05_(&handle, &segbeg, &segend, &clkid, dc, tol,
timsys, cover, timsys_len);
} else {
setmsg_("Supported CK data types are 1, 2, 3, 4, 5. Dat"
"a type of segment: #. This problem may indicate "
"that you need to update your SPICE Toolkit.", (
ftnlen)138);
errint_("#", &dtype, (ftnlen)1);
sigerr_("SPICE(NOTSUPPORTED)", (ftnlen)19);
chkout_("CKCOV", (ftnlen)5);
return 0;
}
}
}
daffna_(&found);
if (failed_()) {
chkout_("CKCOV", (ftnlen)5);
return 0;
}
}
/* COVER now represents the coverage of the entire file at the */
/* granularity indicated by LEVEL, combined with the coverage */
/* contained in COVER on input. */
/* Release the file. */
dafcls_(&handle);
chkout_("CKCOV", (ftnlen)5);
return 0;
} /* ckcov_ */
/* $Procedure SPASUM ( SPACIT, summarize binary file ) */
/* Subroutine */ int spasum_(logical *logfil, integer *loglun)
{
/* Initialized data */
static logical lpsldd = FALSE_;
static logical sclldd = FALSE_;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
char arch[3], line[255], type__[4];
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
logical ndlps;
extern /* Subroutine */ int sumck_(integer *, char *, char *, char *,
logical *, integer *, ftnlen, ftnlen, ftnlen), sumek_(integer *,
char *, logical *, integer *, ftnlen);
char prmpt[80];
extern logical failed_(void);
integer handle;
extern /* Subroutine */ int dafcls_(integer *);
char binfnm[128];
logical fileok;
extern /* Subroutine */ int getfat_(char *, char *, char *, ftnlen,
ftnlen, ftnlen), dafopr_(char *, integer *, ftnlen);
logical ndsclk;
extern /* Subroutine */ int dascls_(integer *);
static char sclfnm[128];
char bfstat[3];
extern /* Subroutine */ int dasopr_(char *, integer *, ftnlen), sigerr_(
char *, ftnlen);
char lfstat[3];
static char lpsfnm[128];
extern /* Subroutine */ int chkout_(char *, ftnlen), setmsg_(char *,
ftnlen), sumpck_(integer *, char *, char *, logical *, integer *,
ftnlen, ftnlen);
char sfstat[3];
extern /* Subroutine */ int furnsh_(char *, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int writln_(char *, integer *, ftnlen), sumspk_(
integer *, char *, char *, logical *, integer *, ftnlen, ftnlen),
getfnm_1__(char *, char *, char *, logical *, ftnlen, ftnlen,
ftnlen);
/* $ Abstract */
/* SPACIT utility subroutine used to summarize the segments in SPICE */
/* data kernel files. This subroutine is for use only be the SPACIT */
/* program. Use it at your own risk. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* None. */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* LOGFIL I Logical flag indicating a log file is being kept. */
/* LOGLUN I The logical unit of the log file. */
/* $ Detailed_Input */
/* LOGFIL Logical flag indicating a log file is being kept. This */
/* Variable has the value of .TRUE. if a log file is being */
/* written, and a value of .FALSE. otherwise. */
/* LOGLUN The logical unit of the log file. If LOGFIL has the */
/* value .TRUE. then LOGLUN will be the Fortran logical */
/* unit of the log file. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Files */
/* None. */
/* $ Particulars */
/* xxx */
/* $ Examples */
/* xxx */
/* $ Restrictions */
/* xxx */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* K.R. Gehringer (JPL) */
/* $ Version */
/* - Beta Version 2.1.0, 02-OCT-2006 (BVS) */
/* Replaced LDPOOL with FURNSH. */
/* - Beta Version 2.0.0, 14-MAR-1997 (WLT) */
/* The routine was enhanced to provide a diagnostic in the */
/* event that the type of the file does belong to EK, CK, SPK */
/* or PCK */
/* - Beta Version 1.0.0, 11-JUL-1995 (KRG) */
/* -& */
/* $ Index_Entries */
/* spacit convert binary to transfer */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Set values for the NAIF SPICE file types */
/* Set a value for the logical unit which represents the standard */
/* output device, commonly a terminal. A value of 6 is widely used, */
/* but the Fortran standard does not specify a value, so it may be */
/* different for different Fortran implementations. */
/* Set a value for the length of an input text line. */
/* Set a value for the length of a filename. */
/* Set a length for the prompt. */
/* Set a length for the status of a file: 'OLD' or 'NEW'. */
/* Set the length for the type of a file. */
/* Set the length for the architecture of a file. */
/* Local variables */
/* Saved values */
/* Initial values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SPASUM", (ftnlen)6);
}
s_copy(bfstat, "OLD", (ftnlen)3, (ftnlen)3);
fileok = FALSE_;
s_copy(prmpt, " Binary file : ", (ftnlen)80, (ftnlen)21);
getfnm_1__(prmpt, bfstat, binfnm, &fileok, (ftnlen)80, (ftnlen)3, (ftnlen)
128);
if (failed_()) {
chkout_("SPASUM", (ftnlen)6);
return 0;
}
getfat_(binfnm, arch, type__, (ftnlen)128, (ftnlen)3, (ftnlen)4);
if (failed_()) {
chkout_("SPASUM", (ftnlen)6);
return 0;
}
if (s_cmp(arch, "?", (ftnlen)3, (ftnlen)1) == 0 || s_cmp(type__, "?", (
ftnlen)4, (ftnlen)1) == 0) {
setmsg_("The architecture and type of the file '#' could not be dete"
"rmined.", (ftnlen)66);
errch_("#", binfnm, (ftnlen)1, (ftnlen)128);
sigerr_("SPICE(BADFILEFORMAT)", (ftnlen)20);
chkout_("SPASUM", (ftnlen)6);
return 0;
} else if (s_cmp(arch, "DAF", (ftnlen)3, (ftnlen)3) != 0 && s_cmp(arch,
"DAS", (ftnlen)3, (ftnlen)3) != 0) {
setmsg_("The file '#' was not a binary SPICE file. In order to summa"
"rize a file it must be a binary CK, EK, PCK, or SPK file.", (
ftnlen)116);
errch_("#", binfnm, (ftnlen)1, (ftnlen)128);
sigerr_("SPICE(IMPROPERFILE)", (ftnlen)19);
chkout_("SPASUM", (ftnlen)6);
return 0;
}
if (s_cmp(type__, "PRE", (ftnlen)4, (ftnlen)3) == 0) {
s_copy(type__, "EK", (ftnlen)4, (ftnlen)2);
}
if (lpsldd || s_cmp(type__, "EK", (ftnlen)4, (ftnlen)2) == 0) {
ndlps = FALSE_;
} else {
ndlps = TRUE_;
}
ndsclk = FALSE_;
if (! sclldd && s_cmp(type__, "CK", (ftnlen)4, (ftnlen)2) == 0) {
ndsclk = TRUE_;
}
if (ndlps) {
s_copy(lfstat, "OLD", (ftnlen)3, (ftnlen)3);
fileok = FALSE_;
s_copy(prmpt, " Leapseconds file: ", (ftnlen)80, (ftnlen)21);
getfnm_1__(prmpt, lfstat, lpsfnm, &fileok, (ftnlen)80, (ftnlen)3, (
ftnlen)128);
if (failed_()) {
chkout_("SPASUM", (ftnlen)6);
return 0;
}
}
if (ndsclk) {
s_copy(sfstat, "OLD", (ftnlen)3, (ftnlen)3);
fileok = FALSE_;
s_copy(prmpt, " SCLK file : ", (ftnlen)80, (ftnlen)21);
getfnm_1__(prmpt, sfstat, sclfnm, &fileok, (ftnlen)80, (ftnlen)3, (
ftnlen)128);
if (failed_()) {
chkout_("SPASUM", (ftnlen)6);
return 0;
}
}
writln_(" ", &c__6, (ftnlen)1);
if (ndlps) {
s_copy(line, " Loading the Leapseconds kernel file. Please wait ..."
, (ftnlen)255, (ftnlen)55);
writln_(line, &c__6, (ftnlen)255);
furnsh_(lpsfnm, (ftnlen)128);
if (failed_()) {
chkout_("SPASUM", (ftnlen)6);
return 0;
}
lpsldd = TRUE_;
}
if (ndsclk) {
s_copy(line, " Loading the SCLK kernel file. Please wait ...", (
ftnlen)255, (ftnlen)48);
writln_(line, &c__6, (ftnlen)255);
furnsh_(sclfnm, (ftnlen)128);
if (failed_()) {
chkout_("SPASUM", (ftnlen)6);
return 0;
}
sclldd = TRUE_;
}
writln_(" ", &c__6, (ftnlen)1);
if (*logfil) {
writln_(" ", loglun, (ftnlen)1);
}
if (s_cmp(type__, "CK", (ftnlen)4, (ftnlen)2) == 0) {
/* Summarize a binary CK file. */
dafopr_(binfnm, &handle, (ftnlen)128);
if (failed_()) {
chkout_("SPASUM", (ftnlen)6);
return 0;
}
sumck_(&handle, binfnm, lpsfnm, sclfnm, logfil, loglun, (ftnlen)128, (
ftnlen)128, (ftnlen)128);
dafcls_(&handle);
} else if (s_cmp(type__, "SPK", (ftnlen)4, (ftnlen)3) == 0) {
/* Summarize a binary SPK file. */
dafopr_(binfnm, &handle, (ftnlen)128);
if (failed_()) {
chkout_("SPASUM", (ftnlen)6);
return 0;
}
sumspk_(&handle, binfnm, lpsfnm, logfil, loglun, (ftnlen)128, (ftnlen)
128);
dafcls_(&handle);
} else if (s_cmp(type__, "PCK", (ftnlen)4, (ftnlen)3) == 0) {
/* Summarize a binary PCK file. */
dafopr_(binfnm, &handle, (ftnlen)128);
if (failed_()) {
chkout_("SPASUM", (ftnlen)6);
return 0;
}
sumpck_(&handle, binfnm, lpsfnm, logfil, loglun, (ftnlen)128, (ftnlen)
128);
dafcls_(&handle);
} else if (s_cmp(type__, "EK", (ftnlen)4, (ftnlen)2) == 0) {
/* Summarize a binary EK file. */
dasopr_(binfnm, &handle, (ftnlen)128);
sumek_(&handle, binfnm, logfil, loglun, (ftnlen)128);
dascls_(&handle);
} else {
setmsg_("The specified file is not of a \"type\" that can be summari"
"zed. The types of files that can be summarized are: CK, EK, "
"PCK, and SPK. According to the type in the internal id-word"
" of the file, this file has type: '#'. You will need to get"
" an upgrade of SPACIT to summarize this file. ", (ftnlen)283);
errch_("#", type__, (ftnlen)1, (ftnlen)4);
sigerr_("SPICE(UNKNOWNTYPE)", (ftnlen)18);
chkout_("SPASUM", (ftnlen)6);
return 0;
}
chkout_("SPASUM", (ftnlen)6);
return 0;
} /* spasum_ */
/* $Procedure ZZLDKER ( Load a kernel ) */
/* Subroutine */ int zzldker_(char *file, char *nofile, char *filtyp, integer
*handle, ftnlen file_len, ftnlen nofile_len, ftnlen filtyp_len)
{
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char arch[32];
extern /* Subroutine */ int zzbodkik_(void), eklef_(char *, integer *,
ftnlen), chkin_(char *, ftnlen), cklpf_(char *, integer *, ftnlen)
, errch_(char *, char *, ftnlen, ftnlen);
char versn[32];
extern logical failed_(void);
extern /* Subroutine */ int getfat_(char *, char *, char *, ftnlen,
ftnlen, ftnlen), pcklof_(char *, integer *, ftnlen), spklef_(char
*, integer *, ftnlen), ldpool_(char *, ftnlen), sigerr_(char *,
ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen);
extern logical exists_(char *, ftnlen), return_(void);
char mytype[32];
extern /* Subroutine */ int tkvrsn_(char *, char *, ftnlen, ftnlen);
/* $ Abstract */
/* SPICE Private routine intended solely for the support of SPICE */
/* routines. Users should not call this routine directly due */
/* to the volatile nature of this routine. */
/* Determine the architecture and type of a file and load */
/* the file into the appropriate SPICE subsystem */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* PRIVATE */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* FILE I The name of a file to be loaded. */
/* NOFILE I A message to issue if FILE cannot be located */
/* FILTYP O The type of kernel. */
/* HANDLE O The handle associated with the loaded kernel. */
/* $ Detailed_Input */
/* FILE is the name of a file that is anticipated to */
/* be a SPICE kernel. */
/* NOFILE is a template for the message that should be created */
/* with SETMSG if a problem is identified with FILE. The */
/* message should have the form: "[text] '#' [text] #" The */
/* first octothorpe ('#') will be replaced by the name of */
/* the file. The second by a descriptive message. */
/* $ Detailed_Output */
/* FILTYP is the type of the kernel as determined by the */
/* SPICE file record of the file or by various */
/* heuristics. Possible return values are: */
/* TEXT --- if FILE is interpreted as a text kernel */
/* suitable for loading via LDPOOL. No */
/* attempt is made to distinguish between */
/* different types of text kernels. */
/* SPK | */
/* CK | */
/* PCK |--- if FILE is a binary PCK file. */
/* EK | */
/* If a failure occurs during the attempt to load */
/* the FILE, FILTYP will be returned as the blank string. */
/* HANDLE is the DAF or DAS handle that is associated with the */
/* file. If the FILTYP of the file is 'TEXT', HANDLE */
/* will be set to zero. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the specified file does not exist, the error */
/* SPICE(NOSUCHFILE) will be signaled. */
/* 2) If the specified file can be identified as unloadable */
/* because it is a transfer format file, the error */
/* SPICE(TRANSFERFILE) will be signaled. */
/* 3) If the specified file can be identified as unloadable */
/* because it is an obsolete text E-kernel, the error */
/* SPICE(TYPE1TEXTEK) will be signaled. */
/* 4) If the specified file can be recognized as a DAF/DAS file */
/* but is not one of the currently recognized binary kernel */
/* types, the error SPICE(UNKNOWNKERNELTYPE) will be signaled. */
/* 5) FILTYP is not sufficiently long to hold the full text of the */
/* type of the kernel, the value returned will be the truncation */
/* of the value. As currently implemented this truncated type is */
/* sufficient to distinguish between the various types of */
/* kernels. */
/* 6) If the FILE cannot be loaded, HANDLE will be set to zero. */
/* 7) All other problems associated with the loading of FILE */
/* are diagnosed by the routines called by this routine. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine is intended as a supporting routine for the */
/* SPICE routine FURNSH. It handles the task of loading */
/* an arbitrary kernel without the caller having to specify */
/* the type of the kernel. */
/* $ Examples */
/* None. (After all it's a private routine) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* E.D. Wright (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 1.17.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 1.16.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 1.15.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 1.14.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.13.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 1.12.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 1.11.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.10.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 1.9.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.8.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 1.7.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 1.6.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 1.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 1.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 1.3.0, 03-OCT-2005 (EDW) */
/* Source file zzldker.f converted to master file. */
/* Modification occurred to prevent f2c's versions */
/* from making the zzascii test. CSPICE now */
/* includes coed to allow reading of non native text files. */
/* - SPICELIB Version 1.2.0, 17-FEB-2004 (EDW) (BVS) */
/* Added the ZZASCII terminator test for text files. Used a */
/* working line length of 132 characters (maximum text kernel */
/* line size.) */
/* - SPICELIB Version 1.1.0, 24-JUN-2002 (EDW) */
/* Added a call to ZZBODKIK to run the */
/* NAIF_BODY_NAME/CODE read/check routine */
/* whenever a text kernel loads. */
/* - SPICELIB Version 1.0.0, 04-JUN-1999 (WLT) */
/* -& */
/* SPICELIB Functions */
/* Local Variables. */
if (return_()) {
return 0;
}
chkin_("ZZLDKER", (ftnlen)7);
if (! exists_(file, file_len)) {
setmsg_(nofile, nofile_len);
errch_("#", file, (ftnlen)1, file_len);
errch_("#", "could not be located.", (ftnlen)1, (ftnlen)21);
sigerr_("SPICE(NOSUCHFILE)", (ftnlen)17);
chkout_("ZZLDKER", (ftnlen)7);
return 0;
}
getfat_(file, arch, mytype, file_len, (ftnlen)32, (ftnlen)32);
/* Possible values for the architecture are: */
/* DAF -- The file is based on the DAF architecture. */
/* DAS -- The file is based on the DAS architecture. */
/* XFR -- The file is in a SPICE transfer file format. */
/* DEC -- The file is an old SPICE decimal text file. */
/* ASC -- An ASCII text file. */
/* KPL -- Kernel Pool File (i.e., a text kernel) */
/* TXT -- An ASCII text file. */
/* TE1 -- Text E-Kernel type 1. */
/* ? -- The architecture could not be determined. */
/* Some of these are obviously losers. */
if (s_cmp(arch, "XFR", (ftnlen)32, (ftnlen)3) == 0 || s_cmp(arch, "DEC", (
ftnlen)32, (ftnlen)3) == 0) {
setmsg_(nofile, nofile_len);
errch_("#", file, (ftnlen)1, file_len);
errch_("#", "is a transfer format file. Transfer format files cannot"
" be loaded. ", (ftnlen)1, (ftnlen)67);
sigerr_("SPICE(TRANSFERFILE)", (ftnlen)19);
chkout_("ZZLDKER", (ftnlen)7);
return 0;
} else if (s_cmp(arch, "TE1", (ftnlen)32, (ftnlen)3) == 0) {
setmsg_(nofile, nofile_len);
errch_("#", file, (ftnlen)1, file_len);
errch_("#", "is a type 1 text E-kernel. These files are obsolete an"
"d cannot be loaded. ", (ftnlen)1, (ftnlen)75);
sigerr_("SPICE(TYPE1TEXTEK)", (ftnlen)18);
chkout_("ZZLDKER", (ftnlen)7);
return 0;
}
/* That takes care of the obvious errors. Try loading the */
/* kernel. */
*handle = 0;
s_copy(filtyp, " ", filtyp_len, (ftnlen)1);
if (s_cmp(arch, "DAF", (ftnlen)32, (ftnlen)3) == 0) {
if (s_cmp(mytype, "SPK", (ftnlen)32, (ftnlen)3) == 0) {
spklef_(file, handle, file_len);
} else if (s_cmp(mytype, "CK", (ftnlen)32, (ftnlen)2) == 0) {
cklpf_(file, handle, file_len);
} else if (s_cmp(mytype, "PCK", (ftnlen)32, (ftnlen)3) == 0) {
pcklof_(file, handle, file_len);
} else {
tkvrsn_("TOOLKIT", versn, (ftnlen)7, (ftnlen)32);
setmsg_(nofile, nofile_len);
errch_("#", file, (ftnlen)1, file_len);
errch_("#", "is a \"#\" DAF file. This kind of binary file is no"
"t supported in version # of the SPICE toolkit. Check wit"
"h NAIF to see if your toolkit version is up to date. ", (
ftnlen)1, (ftnlen)158);
errch_("#", mytype, (ftnlen)1, (ftnlen)32);
errch_("#", versn, (ftnlen)1, (ftnlen)32);
sigerr_("SPICE(UNKNOWNKERNELTYPE)", (ftnlen)24);
chkout_("ZZLDKER", (ftnlen)7);
return 0;
}
s_copy(filtyp, mytype, filtyp_len, (ftnlen)32);
} else if (s_cmp(arch, "DAS", (ftnlen)32, (ftnlen)3) == 0) {
if (s_cmp(mytype, "EK", (ftnlen)32, (ftnlen)2) == 0) {
eklef_(file, handle, file_len);
} else {
tkvrsn_("TOOLKIT", versn, (ftnlen)7, (ftnlen)32);
setmsg_(nofile, nofile_len);
errch_("#", file, (ftnlen)1, file_len);
errch_("#", "is a \"#\" DAS file. This kind of binary file is n"
"ot supported in version # of the SPICE toolkit. Check wi"
"th NAIF to see if your toolkit version is up to date. ", (
ftnlen)1, (ftnlen)159);
errch_("#", mytype, (ftnlen)1, (ftnlen)32);
errch_("#", versn, (ftnlen)1, (ftnlen)32);
sigerr_("SPICE(UNKNOWNKERNELTYPE)", (ftnlen)24);
chkout_("ZZLDKER", (ftnlen)7);
return 0;
}
s_copy(filtyp, mytype, filtyp_len, (ftnlen)32);
} else {
/* Load the file using the text file loader. */
ldpool_(file, file_len);
if (! failed_()) {
s_copy(filtyp, "TEXT", filtyp_len, (ftnlen)4);
/* Cause the kernel pool mechanism to perform */
/* the standard error checks on the pool */
/* data. */
zzbodkik_();
}
}
chkout_("ZZLDKER", (ftnlen)7);
return 0;
} /* zzldker_ */
/* $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__ */