/* $Procedure VERSION ( Print library version information ) */
/* Main program */ MAIN__(void)
{
/* System generated locals */
address a__1[2], a__2[4];
integer i__1[2], i__2, i__3[4], i__4;
doublereal d__1;
char ch__1[25], ch__2[99];
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen),
s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
char line[80], vrsn[6];
extern /* Subroutine */ int zzplatfm_(char *, char *, ftnlen, ftnlen);
integer i__;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
extern doublereal dpmin_(void);
extern /* Subroutine */ int repmd_(char *, char *, doublereal *, integer *
, char *, ftnlen, ftnlen, ftnlen);
extern doublereal dpmax_(void);
char fform[80];
extern /* Subroutine */ int repmi_(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
char cmplr[80];
extern integer wdcnt_(char *, ftnlen);
char tform[80];
extern integer rtrim_(char *, ftnlen);
char os[80];
extern /* Subroutine */ int getcml_(char *, ftnlen), byebye_(char *,
ftnlen);
extern integer intmin_(void), intmax_(void);
char linout[80*6];
extern /* Subroutine */ int tostdo_(char *, ftnlen), tkvrsn_(char *, char
*, ftnlen, ftnlen);
extern integer pos_(char *, char *, integer *, ftnlen, ftnlen);
char sys[80];
/* $ Abstract */
/* This program prints to standard output the current SPICE */
/* distribution version number, hardware system ID, operating */
/* system ID, compiler name, the format of double precision */
/* numbers for the hardware architecture, and the max and min */
/* values for double precision and integer numbers. */
/* $ 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. */
/* $ Keyword */
/* VERSION */
/* UTILITY */
/* $ Parameters */
/* LINELN length of line output string, set to 80. */
/* DATEID update version time string, set to 20. */
/* $ Exceptions */
/* None. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The version utility may use 3 different command line arguments. */
/* The default (no arguments) returns the Toolkit version string. */
/* Usage: $ version [OPTION] */
/* $ Description */
/* None. */
/* $ Examples */
/* Default behavior: */
/* $ version */
/* N0051 */
/* Display all (-a) information: */
/* $version -a */
/* Toolkit version : N0051 */
/* System : PC */
/* Operating System : LINUX */
/* Compiler : LINUX G77 */
/* File Format : LTL-IEEE */
/* MAX DP : 1.7976931348623E+308 */
/* MIN DP : -1.7976931348623E+308 */
/* MAX INT : 2147483647 */
/* MIN INT : -2147483647 */
/* Display version (-v) information: */
/* $version -v */
/* Version Utility for SPICE Toolkit edition N0051, */
/* last update: 1.1.0, 05-OCT-2001 */
/* Display help (-h) information: */
/* $version -h */
/* Usage: version [OPTION] */
/* no arguments output only the SPICE toolkit version string. */
/* -a(ll) output all environment variables; SPICE toolkit */
/* version, system ID, operating system, compiler, */
/* binary file format, max and min values for */
/* double precision and integer numbers. */
/* -v(ersion) output the version of the utility. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* F.S. Turner (JPL) */
/* E.D. Wright (JPL) */
/* $ Version */
/* SPICELIB Version 1.1.0 26-SEP-2001 (FST) (EDW) */
/* Added TEXT_FORMAT output. */
/* Included options for SYSTEM, O/S, COMPILER, FILE_FORMAT, */
/* max/min DPs & integers, outputs, version, and help. */
/* Added proper SPICE header. */
/* SPICELIB Version 1.0.0 13-NOV-2001 (WLT) */
/* First version, Thu NOV 13 10:04:41 PST 1997 W.L. Taber */
/* -& */
/* SPICELIB functions. */
/* Local Parameters. */
/* Local Variables. */
/* Get command line. */
getcml_(line, (ftnlen)80);
ucase_(line, line, (ftnlen)80, (ftnlen)80);
tkvrsn_("TOOLKIT", vrsn, (ftnlen)7, (ftnlen)6);
/* Parse the command line for arguments. Appropriately respond. */
if (wdcnt_(line, (ftnlen)80) == 0) {
/* No arguments, default to the toolkit version string. */
tostdo_(vrsn, rtrim_(vrsn, (ftnlen)6));
} else if (pos_(line, "-A", &c__1, (ftnlen)80, (ftnlen)2) == 1) {
/* All. Output everything. */
tostdo_(" ", (ftnlen)1);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "Toolkit version : ";
i__1[1] = 6, a__1[1] = vrsn;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)25);
tostdo_(ch__1, (ftnlen)25);
zzplatfm_("SYSTEM", sys, (ftnlen)6, (ftnlen)80);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "System : ";
i__1[1] = 80, a__1[1] = sys;
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)99);
tostdo_(ch__2, (ftnlen)99);
zzplatfm_("O/S", os, (ftnlen)3, (ftnlen)80);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "Operating System : ";
i__1[1] = 80, a__1[1] = os;
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)99);
tostdo_(ch__2, (ftnlen)99);
zzplatfm_("COMPILER", cmplr, (ftnlen)8, (ftnlen)80);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "Compiler : ";
i__1[1] = 80, a__1[1] = cmplr;
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)99);
tostdo_(ch__2, (ftnlen)99);
zzplatfm_("FILE_FORMAT", fform, (ftnlen)11, (ftnlen)80);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "File Format : ";
i__1[1] = 80, a__1[1] = fform;
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)99);
tostdo_(ch__2, (ftnlen)99);
zzplatfm_("TEXT_FORMAT", tform, (ftnlen)11, (ftnlen)80);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "Text File Format : ";
i__1[1] = 80, a__1[1] = tform;
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)99);
tostdo_(ch__2, (ftnlen)99);
s_copy(linout, "MAX DP : #", (ftnlen)80, (ftnlen)21);
d__1 = dpmax_();
repmd_(linout, "#", &d__1, &c__23, linout, (ftnlen)80, (ftnlen)1, (
ftnlen)80);
tostdo_(linout, (ftnlen)80);
s_copy(linout + 80, "MIN DP : #", (ftnlen)80, (ftnlen)20);
d__1 = dpmin_();
repmd_(linout + 80, "#", &d__1, &c__23, linout + 80, (ftnlen)80, (
ftnlen)1, (ftnlen)80);
tostdo_(linout + 80, (ftnlen)80);
s_copy(linout + 160, "MAX INT : #", (ftnlen)80, (ftnlen)21);
i__2 = intmax_();
repmi_(linout + 160, "#", &i__2, linout + 160, (ftnlen)80, (ftnlen)1,
(ftnlen)80);
tostdo_(linout + 160, (ftnlen)80);
s_copy(linout + 240, "MIN INT : #", (ftnlen)80, (ftnlen)20);
i__2 = intmin_();
repmi_(linout + 240, "#", &i__2, linout + 240, (ftnlen)80, (ftnlen)1,
(ftnlen)80);
tostdo_(linout + 240, (ftnlen)80);
tostdo_(" ", (ftnlen)1);
} else if (pos_(line, "-V", &c__1, (ftnlen)80, (ftnlen)2) == 1) {
/* Version. Output the utility version string. */
/* Writing concatenation */
i__3[0] = 42, a__2[0] = "Version Utility for SPICE Toolkit edition ";
i__3[1] = rtrim_(vrsn, (ftnlen)6), a__2[1] = vrsn;
i__3[2] = 15, a__2[2] = ", last update: ";
i__3[3] = 18, a__2[3] = "1.1.0, 07-JAN-2002 ";
s_cat(linout, a__2, i__3, &c__4, (ftnlen)80);
tostdo_(" ", (ftnlen)1);
tostdo_(linout, (ftnlen)80);
tostdo_(" ", (ftnlen)1);
} else if (pos_(line, "-H", &c__1, (ftnlen)80, (ftnlen)2) == 1) {
/* Help. How does does one use this perplexing routine? */
s_copy(linout, "Usage: version [OPTION]", (ftnlen)80, (ftnlen)23);
s_copy(linout + 80, " no arguments output only the SPICE toolkit v"
"ersion string.", (ftnlen)80, (ftnlen)61);
s_copy(linout + 160, " -a(ll) output all environment variabl"
"es; SPICE toolkit version, system", (ftnlen)80, (ftnlen)79);
s_copy(linout + 240, " ID, operating system, compiler"
", and binary file format, ", (ftnlen)80, (ftnlen)72);
s_copy(linout + 320, " max and min values for double "
"precision and integer numbers.", (ftnlen)80, (ftnlen)76);
s_copy(linout + 400, " -v(ersion) output the version of the util"
"ity.", (ftnlen)80, (ftnlen)50);
tostdo_(" ", (ftnlen)1);
for (i__ = 1; i__ <= 6; ++i__) {
tostdo_(linout + ((i__2 = i__ - 1) < 6 && 0 <= i__2 ? i__2 :
s_rnge("linout", i__2, "version_", (ftnlen)272)) * 80,
rtrim_(linout + ((i__4 = i__ - 1) < 6 && 0 <= i__4 ? i__4
: s_rnge("linout", i__4, "version_", (ftnlen)272)) * 80, (
ftnlen)80));
}
tostdo_(" ", (ftnlen)1);
} else {
/* The user put something on the command line, but nothing */
/* known. Return the toolkit version string. */
tostdo_(vrsn, rtrim_(vrsn, (ftnlen)6));
}
/* Done. Indicate as much. Say bye. */
byebye_("SUCCESS", (ftnlen)7);
s_stop("", (ftnlen)0);
return 0;
} /* MAIN__ */
/* $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 OUTMSG ( Output Error Messages ) */
/* Subroutine */ int outmsg_(char *list, ftnlen list_len)
{
/* Initialized data */
static char defmsg[80*4] = "Oh, by the way: The SPICELIB error handling"
" actions are USER-TAILORABLE. You " "can choose whether the To"
"olkit aborts or continues when errors occur, which " "error "
"messages to output, and where to send the output. Please read t"
"he ERROR " "\"Required Reading\" file, or see the routines ERRA"
"CT, ERRDEV, and ERRPRT. ";
static logical first = TRUE_;
/* System generated locals */
address a__1[2], a__2[3];
integer i__1, i__2, i__3[2], i__4[3];
char ch__1[38];
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen),
s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char name__[32], line[80];
logical long__;
char lmsg[1840];
logical expl;
char smsg[25], xmsg[80];
integer i__;
logical trace;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
integer depth, index;
extern integer wdcnt_(char *, ftnlen);
extern /* Subroutine */ int expln_(char *, char *, ftnlen, ftnlen);
extern integer rtrim_(char *, ftnlen);
char versn[80], words[9*5];
integer start;
logical short__;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
char device[255];
integer remain;
static char border[80];
extern /* Subroutine */ int getdev_(char *, ftnlen);
logical dfault;
integer length;
extern /* Subroutine */ int trcdep_(integer *);
extern integer lastnb_(char *, ftnlen);
extern /* Subroutine */ int trcnam_(integer *, char *, ftnlen), lparse_(
char *, char *, integer *, integer *, char *, ftnlen, ftnlen,
ftnlen);
extern logical msgsel_(char *, ftnlen);
integer wrdlen;
extern /* Subroutine */ int getlms_(char *, ftnlen), wrline_(char *, char
*, ftnlen, ftnlen), getsms_(char *, ftnlen), suffix_(char *,
integer *, char *, ftnlen, ftnlen);
char tmpmsg[105];
extern /* Subroutine */ int nextwd_(char *, char *, char *, ftnlen,
ftnlen, ftnlen);
integer numwrd;
char upword[9], outwrd[1840];
extern /* Subroutine */ int tkvrsn_(char *, char *, ftnlen, ftnlen);
logical output;
/* $ Abstract */
/* Output error messages. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* ERROR */
/* $ Keywords */
/* ERROR */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include File: SPICELIB Error Handling Parameters */
/* errhnd.inc Version 2 18-JUN-1997 (WLT) */
/* The size of the long error message was */
/* reduced from 25*80 to 23*80 so that it */
/* will be accepted by the Microsoft Power Station */
/* FORTRAN compiler which has an upper bound */
/* of 1900 for the length of a character string. */
/* errhnd.inc Version 1 29-JUL-1997 (NJB) */
/* Maximum length of the long error message: */
/* Maximum length of the short error message: */
/* End Include File: SPICELIB Error Handling Parameters */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* LIST I A list of error message types. */
/* FILEN P Maximum length of file name. */
/* NAMLEN P Maximum length of module name. See TRCPKG. */
/* LL P Output line length. */
/* $ Detailed_Input */
/* LIST is a list of error message types. A list is a */
/* character string containing one or more words */
/* from the following list, separated by commas. */
/* SHORT */
/* EXPLAIN */
/* LONG */
/* TRACEBACK */
/* DEFAULT */
/* Each type of error message specified in LIST will */
/* be output when an error is detected, if it is */
/* enabled for output. Note that DEFAULT does */
/* NOT refer to the "default message selection," */
/* but rather to a special message that is output */
/* when the error action is 'DEFAULT'. This message */
/* is a statement referring the user to the error */
/* handling documentation. */
/* Messages are never duplicated in the output; for */
/* instance, supplying a value of LIST such as */
/* 'SHORT, SHORT' */
/* does NOT result in the output of two short */
/* messages. */
/* The words in LIST may appear in mixed case; */
/* for example, the call */
/* CALL OUTMSG ( 'ShOrT' ) */
/* will work. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* FILEN is the maximum device name length that can be */
/* accommodated by this routine. */
/* NAMELN is the maximum length of an individual module name. */
/* LL is the maximum line length for the output message. */
/* If the output message string is very long, it is */
/* displayed over several lines, each of which has a */
/* maximum length of LL characters. */
/* $ Exceptions */
/* 1) This routine detects invalid message types in the argument, */
/* LIST. The short error message in this case is */
/* 'SPICE(INVALIDLISTITEM)' */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine is part of the SPICELIB error handling */
/* mechanism. */
/* This routine outputs the error messages specified in LIST that */
/* have been enabled for output (use the SPICELIB routine ERRPRT */
/* to enable or disable output of specified types of error */
/* messages). A border is written out preceding and following the */
/* messages. Output is directed to the current error output device. */
/* $ Examples */
/* 1) Output the short and long error messages: */
/* C */
/* C Output short and long messages: */
/* C */
/* CALL OUTMSG ( 'SHORT, LONG' ) */
/* $ Restrictions */
/* 1) This routine is intended for use by the SPICELIB error */
/* handling mechanism. SPICELIB users are not expected to */
/* need to call this routine. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* K.R. Gehringer (JPL) */
/* H.A. Neilan (JPL) */
/* M.J. Spencer (JPL) */
/* $ Version */
/* - SPICELIB Version 5.27.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 5.26.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 5.25.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 5.24.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 5.23.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 5.22.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 5.21.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 5.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 5.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 5.18.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 5.17.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 5.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 5.15.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 5.14.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 5.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 5.12.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 5.11.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 5.10.0, 01-MAR-2009 (NJB) */
/* Bug fix: truncation of long words in */
/* output has been corrected. Local parameter */
/* TMPLEN was added and is used in declaration */
/* of TMPMSG. */
/* - SPICELIB Version 5.9.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 5.8.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 5.7.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 5.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 5.5.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 5.4.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 5.3.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 5.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 5.1.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 5.1.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 5.1.3, 24-SEP-1999 (NJB) */
/* CSPICE environments were added. Some typos were corrected. */
/* - SPICELIB Version 5.1.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 5.1.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 5.1.0, 13-JAN-1999 (BVS) */
/* ``errhnd.inc'' file was included. Long and short error */
/* message lengths parameter declarations were deleted. Long */
/* and short error message string sizes were changed to those */
/* declared in ``errhnd.inc''. */
/* - SPICELIB Version 5.0.0, 08-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 4.0.0, 09-MAY-1996 (KRG) */
/* Added the toolkit version to the output error message. */
/* Updated this routine to be consistent with the trace package */
/* revisions. This primarily affects the creation of the */
/* traceback string. */
/* Long error messages are now wrapped on word boundaries when */
/* they are longer than the output line length. Note that this */
/* only happens for long error messages obtained from GETLMS, */
/* and not for the error messages displayed by this subroutine */
/* and other error handling subroutines that write their own */
/* error messages. */
/* - SPICELIB Version 3.0.0, 09-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* for the Silicon Graphics, DEC Alpha-OSF/1, and */
/* NeXT platforms. Also, the previous value of 256 for */
/* Unix platforms was changed to 255. */
/* - SPICELIB Version 2.2.0, 12-OCT-1992 (HAN) */
/* Updated module for multiple environments. Moved the parameter */
/* LL to the Declarations section of the header since it's */
/* environment dependent. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 2.1.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 2.1.0, 15-MAY-1991 (MJS) */
/* Module was updated to include the value of LL for the */
/* Macintosh. */
/* - SPICELIB Version 2.0.0, 28-MAR-1991 (NJB) */
/* Work-around for MS Fortran compiler error under DOS 3.10 */
/* was made. Some substring bounds were simplified using RTRIM. */
/* Updates were made to the header to clarify the text and */
/* improve the header's appearance. The default error message */
/* was slightly de-uglified. */
/* The IBM PC version of this routine now uses an output line */
/* length of 78 characters rather than 80. This prevents */
/* wrapping of the message borders and default error message. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (NJB) */
/* -& */
/* $ Index_Entries */
/* None. */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 5.1.0, 13-JAN-1999 (BVS) */
/* ``errhnd.inc'' file was included. Long and short error */
/* message lengths parameter declarations were deleted. Long */
/* and short error message string size were changed to those */
/* declared in ``errhnd.inc''. */
/* - SPICELIB Version 5.0.0, 08-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 4.0.0, 09-MAY-1996 (KRG) */
/* Added the toolkit version to the output error message. */
/* Updated this routine to be consistent with the trace package */
/* revisions. This primarily affects the creation of the */
/* traceback string. */
/* Long error messages are now wrapped on word boundaries when */
/* they are longer than the output line length. Note that this */
/* only happens for long error messages obtained from GETLMS, */
/* and not for the error messages displayed by this subroutine */
/* and other error handling subroutines that write their own */
/* error messages. */
/* - SPICELIB Version 3.0.0, 9-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* for the Silicon Graphics, DEC Alpha-OSF/1, and */
/* NeXT platforms. Also, the previous value of 256 for */
/* Unix platforms was changed to 255. */
/* - SPICELIB Version 2.2.0, 12-OCT-1992 (HAN) */
/* Updated module for multiple environments. Moved the */
/* parameter LL to the Declarations section of the header since */
/* it's environment dependent. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 2.1.0, 15-MAY-1991 (MJS) */
/* Module was updated to include the value of LL for the */
/* Macintosh. */
/* - SPICELIB Version 2.0.0, 28-MAR-1991 (NJB) */
/* 1) Work-around for MS Fortran compiler error under DOS 3.10 */
/* was made. The compiler did not correctly handle code that */
/* concatenated strings whose bounds involved the intrinsic */
/* MAX function. */
/* 2) Some substring bounds were simplified using RTRIM. */
/* 3) Updates were made to the header to clarify the text and */
/* improve the header's appearance. */
/* 4) Declarations were re-organized. */
/* 5) The default error message was slightly de-uglified. */
/* 6) The IBM PC version of this routine now uses an output line */
/* length of 78 characters rather than 80. This prevents */
/* wrapping of the message borders and default error message. */
/* - Beta Version 1.3.0, 19-JUL-1989 (NJB) */
/* Calls to REMSUB removed; blanking and left-justifying used */
/* instead. This was done because REMSUB handles substring */
/* bounds differently than in previous versions, and no longer */
/* handles all possible inputs as required by this routine. */
/* LJUST, which is used now, is error free. */
/* Also, an instance of .LT. was changed to .LE. The old code */
/* caused a line break one character too soon. A minor bug, but */
/* a bug nonetheless. */
/* Also, two substring bounds were changed to ensure that they */
/* remain greater than zero. */
/* - Beta Version 1.2.0, 16-FEB-1989 (NJB) */
/* Warnings added to discourage use of this routine in */
/* non-error-handling code. Parameters section updated to */
/* describe FILEN and NAMLEN. */
/* Declaration of unused function FAILED removed. */
/* - Beta Version 1.1.0, 06-OCT-1988 (NJB) */
/* Test added to ensure substring upper bound is greater than 0. */
/* REMAIN must be greater than 0 when used as the upper bound */
/* for a substring of NAME. Also, substring upper bound in */
/* WRLINE call is now forced to be greater than 0. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* These parameters are system-independent. */
/* Local variables */
/* Saved variables */
/* Initial Values: */
/* Executable Code: */
/* The first time through, set up the output borders. */
if (first) {
first = FALSE_;
for (i__ = 1; i__ <= 80; ++i__) {
*(unsigned char *)&border[i__ - 1] = '=';
}
}
/* No messages are to be output which are not specified */
/* in LIST: */
short__ = FALSE_;
expl = FALSE_;
long__ = FALSE_;
trace = FALSE_;
dfault = FALSE_;
/* We parse the list of message types, and set local flags */
/* indicating which ones are to be output. If we find */
/* a word we don't recognize in the list, we signal an error */
/* and continue parsing the list. */
lparse_(list, ",", &c__5, &numwrd, words, list_len, (ftnlen)1, (ftnlen)9);
i__1 = numwrd;
for (i__ = 1; i__ <= i__1; ++i__) {
ucase_(words + ((i__2 = i__ - 1) < 5 && 0 <= i__2 ? i__2 : s_rnge(
"words", i__2, "outmsg_", (ftnlen)613)) * 9, upword, (ftnlen)
9, (ftnlen)9);
if (s_cmp(upword, "SHORT", (ftnlen)9, (ftnlen)5) == 0) {
short__ = TRUE_;
} else if (s_cmp(upword, "EXPLAIN", (ftnlen)9, (ftnlen)7) == 0) {
expl = TRUE_;
} else if (s_cmp(upword, "LONG", (ftnlen)9, (ftnlen)4) == 0) {
long__ = TRUE_;
} else if (s_cmp(upword, "TRACEBACK", (ftnlen)9, (ftnlen)9) == 0) {
trace = TRUE_;
} else if (s_cmp(upword, "DEFAULT", (ftnlen)9, (ftnlen)7) == 0) {
dfault = TRUE_;
} else {
/* Unrecognized word! This is an error... */
/* We have a special case on our hands; this routine */
/* is itself called by SIGERR, so a recursion error will */
/* result if this routine calls SIGERR. So we output */
/* the error message directly: */
getdev_(device, (ftnlen)255);
wrline_(device, "SPICE(INVALIDLISTITEM)", (ftnlen)255, (ftnlen)22)
;
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
wrline_(device, "OUTMSG: An invalid message type was specified "
"in the type list. ", (ftnlen)255, (ftnlen)65);
/* Writing concatenation */
i__3[0] = 29, a__1[0] = "The invalid message type was ";
i__3[1] = 9, a__1[1] = words + ((i__2 = i__ - 1) < 5 && 0 <= i__2
? i__2 : s_rnge("words", i__2, "outmsg_", (ftnlen)650)) *
9;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)38);
wrline_(device, ch__1, (ftnlen)255, (ftnlen)38);
}
}
/* LIST has been parsed. */
/* Now, we output those error messages that were specified by LIST */
/* and which belong to the set of messages selected for output. */
/* We get the default error output device: */
getdev_(device, (ftnlen)255);
output = short__ && msgsel_("SHORT", (ftnlen)5) || expl && msgsel_("EXPL"
"AIN", (ftnlen)7) || long__ && msgsel_("LONG", (ftnlen)4) || trace
&& msgsel_("TRACEBACK", (ftnlen)9) || dfault && msgsel_("DEFAULT",
(ftnlen)7) && s_cmp(device, "NULL", (ftnlen)255, (ftnlen)4) != 0;
/* We go ahead and output those messages that have been specified */
/* in the list and also are enabled for output. The order of the */
/* cases below IS significant; the order in which the messages */
/* appear in the output depends on it. */
/* If there's nothing to output, we can leave now. */
if (! output) {
return 0;
}
/* Write the starting border: skip a line, write the border, */
/* skip a line. */
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
wrline_(device, border, (ftnlen)255, (ftnlen)80);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
/* Output the toolkit version and skip a line. */
tkvrsn_("TOOLKIT", versn, (ftnlen)7, (ftnlen)80);
/* Writing concatenation */
i__3[0] = 17, a__1[0] = "Toolkit version: ";
i__3[1] = 80, a__1[1] = versn;
s_cat(line, a__1, i__3, &c__2, (ftnlen)80);
wrline_(device, line, (ftnlen)255, (ftnlen)80);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
/* Next, we output the messages specified in the list */
/* that have been enabled. */
/* We start with the short message and its accompanying */
/* explanation. If both are to be output, they are */
/* concatenated into a single message. */
if (short__ && msgsel_("SHORT", (ftnlen)5) && (expl && msgsel_("EXPLAIN",
(ftnlen)7))) {
/* Extract the short message from global storage; then get */
/* the corresponding explanation. */
getsms_(smsg, (ftnlen)25);
expln_(smsg, xmsg, (ftnlen)25, (ftnlen)80);
/* Writing concatenation */
i__4[0] = rtrim_(smsg, (ftnlen)25), a__2[0] = smsg;
i__4[1] = 4, a__2[1] = " -- ";
i__4[2] = 80, a__2[2] = xmsg;
s_cat(tmpmsg, a__2, i__4, &c__3, (ftnlen)105);
wrline_(device, tmpmsg, (ftnlen)255, (ftnlen)105);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
} else if (short__ && msgsel_("SHORT", (ftnlen)5)) {
/* Output the short error message without the explanation. */
getsms_(smsg, (ftnlen)25);
wrline_(device, smsg, (ftnlen)255, (ftnlen)25);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
} else if (expl && msgsel_("EXPLAIN", (ftnlen)7)) {
/* Obtain the explanatory text for the short error */
/* message and output it: */
getsms_(smsg, (ftnlen)25);
expln_(smsg, xmsg, (ftnlen)25, (ftnlen)80);
wrline_(device, xmsg, (ftnlen)255, (ftnlen)80);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
if (long__ && msgsel_("LONG", (ftnlen)4)) {
/* Extract the long message from global storage and */
/* output it: */
getlms_(lmsg, (ftnlen)1840);
/* Get the number of words in the error message. */
numwrd = wdcnt_(lmsg, (ftnlen)1840);
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
start = 1;
/* Format the words into output lines and display them as */
/* needed. */
i__1 = numwrd;
for (i__ = 1; i__ <= i__1; ++i__) {
nextwd_(lmsg, outwrd, lmsg, (ftnlen)1840, (ftnlen)1840, (ftnlen)
1840);
wrdlen = rtrim_(outwrd, (ftnlen)1840);
if (start + wrdlen <= 80) {
s_copy(line + (start - 1), outwrd, 80 - (start - 1), (ftnlen)
1840);
start = start + wrdlen + 1;
} else {
if (wrdlen <= 80) {
/* We had a short word, so just write the line and */
/* continue. */
wrline_(device, line, (ftnlen)255, (ftnlen)80);
start = wrdlen + 2;
s_copy(line, outwrd, (ftnlen)80, (ftnlen)1840);
} else {
/* We got a very long word here, so we break it up and */
/* write it out. We fit as much of it as we an into line */
/* as possible before writing it. */
/* Get the remaining space. If START is > 1 we have at */
/* least one word already in the line, including it's */
/* trailing space, otherwise the line is blank. If line */
/* is empty, we have all of the space available. */
if (start > 1) {
remain = 80 - start;
} else {
remain = 80;
}
/* Now we stuff bits of the word into the output line */
/* until we're done, i.e., until we have a word part */
/* that is less than the output length. First, we */
/* check to see if there is a "significant" amount of */
/* room left in the current output line. If not, we */
/* write it and then begin stuffing the long word into */
/* output lines. */
if (remain < 10) {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
remain = 80;
start = 1;
}
/* Stuff the word a chunk at a time into output lines */
/* and write them. After writing a line, we clear the */
/* part of the long word that we just wrote, left */
/* justifying the remaining part before proceeding. */
while(wrdlen > 80) {
s_copy(line + (start - 1), outwrd, 80 - (start - 1),
remain);
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(outwrd, " ", remain, (ftnlen)1);
ljust_(outwrd, outwrd, (ftnlen)1840, (ftnlen)1840);
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
wrdlen -= remain;
remain = 80;
start = 1;
}
/* If we had a part of the long word left, get set up to */
/* append more words from the error message to the output */
/* line. If we finished the word, WRDLEN .EQ. 0, then */
/* START and LINE have already been initialized. */
if (wrdlen > 0) {
start = wrdlen + 2;
s_copy(line, outwrd, (ftnlen)80, (ftnlen)1840);
}
}
}
}
/* We may need to write the remaining part of a line. */
if (s_cmp(line, " ", (ftnlen)80, (ftnlen)1) != 0) {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
}
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
if (trace && msgsel_("TRACEBACK", (ftnlen)9)) {
/* Extract the traceback from global storage and */
/* output it: */
trcdep_(&depth);
if (depth > 0) {
/* We know we'll be outputting some trace information. */
/* So, write a line telling the reader what's coming. */
wrline_(device, "A traceback follows. The name of the highest l"
"evel module is first.", (ftnlen)255, (ftnlen)68);
/* While there are more names in the traceback */
/* representation, we stuff them into output lines and */
/* write the lines out when they are full. */
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
remain = 80;
i__1 = depth;
for (index = 1; index <= i__1; ++index) {
/* For each module name in the traceback representation, */
/* retrieve module name and stuff it into one or more */
/* lines for output. */
/* Get a name and add the call order sign. We */
/* indicate calling order by a ' --> ' delimiter; e.g. */
/* "A calls B" is indicated by 'A --> B'. */
trcnam_(&index, name__, (ftnlen)32);
length = lastnb_(name__, (ftnlen)32);
/* If it's the first name, just put it into the output */
/* line, otherwise, add the call order sign and put the */
/* name into the output line. */
if (index == 1) {
suffix_(name__, &c__0, line, (ftnlen)32, (ftnlen)80);
remain -= length;
} else {
/* Add the calling order indicator, if it will fit. */
/* If not, write the line and put the indicator as */
/* the first thing on the next line. */
if (remain >= 4) {
suffix_("-->", &c__1, line, (ftnlen)3, (ftnlen)80);
remain += -4;
} else {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(line, "-->", (ftnlen)80, (ftnlen)3);
remain = 77;
}
/* The name fits or it doesn't. If it does, just add */
/* it, if it doesn't, write it, then make the name */
/* the first thing on the next line. */
if (remain >= length) {
suffix_(name__, &c__1, line, (ftnlen)32, (ftnlen)80);
remain = remain - length - 1;
} else {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(line, name__, (ftnlen)80, (ftnlen)32);
remain = 80 - length;
}
}
}
/* At this point, no more names are left in the */
/* trace representation. LINE may still contain */
/* names, or part of a long name. If it does, */
/* we now write it out. */
if (s_cmp(line, " ", (ftnlen)80, (ftnlen)1) != 0) {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
}
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
/* At this point, either we have output the trace */
/* representation, or the trace representation was */
/* empty. */
}
if (dfault && msgsel_("DEFAULT", (ftnlen)7)) {
/* Output the default message: */
for (i__ = 1; i__ <= 4; ++i__) {
wrline_(device, defmsg + ((i__1 = i__ - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("defmsg", i__1, "outmsg_", (ftnlen)971)) *
80, (ftnlen)255, (ftnlen)80);
}
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
/* At this point, we've output all of the enabled messages */
/* that were specified in LIST. At least one message that */
/* was specified was enabled. */
/* Write the ending border out: */
wrline_(device, border, (ftnlen)255, (ftnlen)80);
return 0;
} /* outmsg_ */
/* $Procedure 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__ */
