void SaturationMeasurer::measureIteration()
{
if(n_sum_out != 0)
outputs_sum /= n_sum_out;
if(n_sum_der != 0)
derivatives_sum /= n_sum_der;
if(binary_mode)
{
file->write(&outputs_sum, sizeof(real), 1);
file->write(&derivatives_sum, sizeof(real), 1);
}
else
file->printf("%g %g\n", outputs_sum, derivatives_sum);
file->flush();
reset_();
}
ClassMeasurer::ClassMeasurer(Sequence *inputs_, DataSet *data_, ClassFormat *class_format_, XFile *file_,
bool calc_confusion_at_each_iter_) : Measurer(data_, file_)
{
inputs = inputs_;
class_format = class_format_;
calc_confusion_at_each_iter = calc_confusion_at_each_iter_;
confusion = NULL;
n_classes = class_format->n_classes;
if(calc_confusion_at_each_iter)
{
confusion = (int **)allocator->alloc(sizeof(int*)*n_classes);
for(int i = 0; i < n_classes; i++)
confusion[i] = (int *)allocator->alloc(sizeof(int)*n_classes);
}
reset_();
}
SpatialConvolution::SpatialConvolution(int n_input_planes_, int n_output_planes_, int width_, int height_, int k_w_, int d_x_, int d_y_)
: GradientMachine(0, 0)
{
n_input_planes = n_input_planes_;
n_output_planes = n_output_planes_;
input_width = width_;
input_height = height_;
k_w = k_w_;
d_x = d_x_;
d_y = d_y_;
n_inputs = n_input_planes * input_height * input_width;
output_height = (input_height - k_w) / d_y + 1;
output_width = (input_width - k_w) / d_x + 1;
n_outputs = n_output_planes * output_height * output_width;
if(input_height < k_w)
error("SpatialConvolution: input image height is too small (height = %d < k_w = %d) ", input_height, k_w);
if(input_width < k_w)
error("SpatialConvolution: input image width is too small (width = %d < k_w = %d) ", input_width, k_w);
outputs = new(allocator) Sequence(1, n_outputs);
beta = new(allocator) Sequence(1, n_inputs);
int n_params_ = k_w*k_w*n_input_planes*n_output_planes+n_output_planes;
params = new(allocator) Parameters(n_params_);
der_params = new(allocator) Parameters(n_params_);
weights = (real **)allocator->alloc(sizeof(real *)*n_output_planes);
for(int i = 0; i < n_output_planes; i++)
weights[i] = params->data[0] + i*k_w*k_w*n_input_planes;
biases = params->data[0] + k_w*k_w*n_input_planes*n_output_planes;
der_weights = (real **)allocator->alloc(sizeof(real *)*n_output_planes);
for(int i = 0; i < n_output_planes; i++)
der_weights[i] = der_params->data[0] + i*k_w*k_w*n_input_planes;
der_biases = der_params->data[0] + k_w*k_w*n_input_planes*n_output_planes;
message("SpatialConvolution: output image is <%d x %d>", output_width, output_height);
reset_();
}
void ClassMeasurer::reset()
{
reset_();
}
/* $ Procedure TIMECN (Convert and round times) */
/* Subroutine */ int timecn_(doublereal *tconv, integer *ids, char *tout,
char *linet, ftnlen tout_len, ftnlen linet_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int sct2e_(integer *, doublereal *, doublereal *),
dpfmt_(doublereal *, char *, char *, ftnlen, ftnlen), reset_(
void);
extern logical failed_(void);
extern /* Subroutine */ int scdecd_(integer *, doublereal *, char *,
ftnlen);
integer sc;
logical ok;
extern /* Subroutine */ int ckmeta_(integer *, char *, integer *, ftnlen),
erract_(char *, char *, ftnlen, ftnlen);
doublereal ettime;
extern /* Subroutine */ int fixuni_(void), errprt_(char *, char *, ftnlen,
ftnlen), timout_(doublereal *, char *, char *, ftnlen, ftnlen);
/* $ Abstract */
/* This is internal subroutine for CKBRIEF program. It converts */
/* time between encoded SCLK, SCLK string, ET, UTC or UTC/DOY. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Keywords */
/* SUMMARY */
/* C KERNEL */
/* $ 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. */
/* $ Author_and_Institution */
/* Y.K. Zaiko (BERC) */
/* B.V. Semenov (NAIF) */
/* $ Version */
/* - Toolkit Version 6.1.0, 27-JUN-2014 (BVS) */
/* BUG FIX: changed logic to make a combination of -a and an ID */
/* specified on the command line work in all cases. */
/* - CKBRIEF Version 6.0.0, 2014-04-28 (BVS) (NJB) */
/* Modified to treat all files as a single file (-a). */
/* Changed SCLKD display format to include 6 decimal */
/* places. */
/* Increased MAXBOD to 1,000,000 (from 100,000) and CMDSIZ to */
/* 50,000 (from 25,000). */
/* Added support for CK type 6. */
/* - CKBRIEF Version 5.0.0, 2009-02-11 (BVS) */
/* Updated version. */
/* - CKBRIEF Version 4.0.0, 2008-01-13 (BVS) */
/* Increased MAXBOD to 100,000 (from 10,000). */
/* Increased CMDSIZ to 25,000 (from 4,000). */
/* Updated version string and changed its format to */
/* '#.#.#, Month DD, YYYY' (from '#.#.#, YYYY-MM-DD'). */
/* - CKBRIEF Version 3.2.0, 2006-11-02 (BVS) */
/* Updated version string. */
/* - CKBRIEF Version 3.1.0, 2005-11-08 (BVS) */
/* Updated version string. */
/* - CKBRIEF Version 2.0.0, 2001-05-16 (BVS) */
/* Increased MAXBOD to 10000 (from 4000). Set LRGWIN to be */
/* MAXBOD*2 (was MAXBOD). Changed version string. */
/* - CKBRIEF Version 1.1.2, 2001-04-09 (BVS) */
/* Changed version parameter. */
/* - CKBRIEF Version 1.0.0 beta, 1999-02-17 (YKZ)(BVS) */
/* Initial release. */
/* -& */
/* The Version is stored as a string. */
/* The maximum number of segments or interpolation intervals */
/* that can be summarized is stored in the parameter MAXBOD. */
/* This is THE LIMIT that should be increased if window */
/* routines called by CKBRIEF fail. */
/* The largest expected window -- must be twice the size of */
/* MAXBOD for consistency. */
/* The longest command line that can be accommodated is */
/* given by CMDSIZ. */
/* MAXUSE is the maximum number of objects that can be explicitly */
/* specified on the command line for ckbrief summaries. */
/* Generic line size for all modules. */
/* Time type keys. */
/* Output time format pictures. */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* TCONV I Encoded SCLK time */
/* IDS I NAIF ID code of object */
/* TOUT I Form of time representation on output */
/* LINET O Text presentation of time */
/* $ Detailed Input */
/* TCONV Encoded SCLK time to be converted, rounded */
/* and decoded to character string */
/* IDS Integer NAIF ID code found in summary from which */
/* TCONV was obtained. */
/* TOUT Key specifying time presentation on output: */
/* SCLK string, encoded SCLK, ET, UTC or DOY UTC. */
/* $ Detailed Output */
/* LINET Character string which contains time converted */
/* to requested representation or NOTIME flag if */
/* conversion was not possible. */
/* $ Parameters */
/* None. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* Y.K. Zaiko (BERC) */
/* B.V. Semenov (NAIF) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - CKBRIEF Beta Version 1.0.0, 17-FEB-1999 (YKZ)(BVS) */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Reset output time string. */
s_copy(linet, " ", linet_len, (ftnlen)1);
/* It is necessary to use real spacecraft ID in SCLK<->ET */
/* conversion routines. CKMETA is providing it. */
ckmeta_(ids, "SCLK", &sc, (ftnlen)4);
/* TIMECN is the special routine to be used in CKBRIEF */
/* utility to convert times in accordance to user request. If user */
/* haven't provided ancillary files to perform this conversion, the */
/* program shouldn't stop. To achieve this we'll forbid TIMECN to */
/* be aborted by SPICELIB standard error processing if it can't */
/* convert times. On the exit from TIMECN, SPICE error handling */
/* is restored to its original state. */
erract_("SET", "RETURN", (ftnlen)3, (ftnlen)6);
errprt_("SET", "NONE", (ftnlen)3, (ftnlen)4);
/* We do appropriate conversion depending on the requested output */
/* time representation. If SCLK for the s/c of interest and(!) */
/* LSK file weren't loaded, conversions to string SCLK, ET, UTC */
/* and UTC/DOY are not possible. The output time set to NOTIME */
/* flag. */
if (s_cmp(tout, "TICKS", tout_len, (ftnlen)5) == 0) {
/* DP SLCKs should be simply converted to string. */
dpfmt_(tconv, "xxxxxxxxxxxxxx.xxxxxx", linet, (ftnlen)21, linet_len);
} else if (s_cmp(tout, "SCLK", tout_len, (ftnlen)4) == 0) {
/* SCLK string is computed from DP SCLK if it's possible. */
scdecd_(&sc, tconv, linet, linet_len);
if (failed_()) {
s_copy(linet, "NEED LSK AND SCLK FILES", linet_len, (ftnlen)23);
}
} else if (s_cmp(tout, "ET", tout_len, (ftnlen)2) == 0) {
/* Calendar ET is computed by converting DP SCLK to ET seconds */
/* and converting them further to ET calendar string */
sct2e_(&sc, tconv, &ettime);
if (! failed_()) {
timout_(&ettime, "YYYY-MON-DD HR:MN:SC.### ::TDB", linet, (ftnlen)
30, linet_len);
if (failed_()) {
s_copy(linet, "NEED LSK AND SCLK FILES", linet_len, (ftnlen)
23);
}
} else {
s_copy(linet, "NEED LSK AND SCLK FILES", linet_len, (ftnlen)23);
}
} else if (s_cmp(tout, "UTC", tout_len, (ftnlen)3) == 0) {
/* UTC time is computed by converting DP SCLK to ET seconds, */
/* which after that converted to UTC string. */
sct2e_(&sc, tconv, &ettime);
if (! failed_()) {
timout_(&ettime, "YYYY-MON-DD HR:MN:SC.###", linet, (ftnlen)24,
linet_len);
if (failed_()) {
s_copy(linet, "NEED LSK AND SCLK FILES", linet_len, (ftnlen)
23);
}
} else {
s_copy(linet, "NEED LSK AND SCLK FILES", linet_len, (ftnlen)23);
}
} else if (s_cmp(tout, "UTC/DOY", tout_len, (ftnlen)7) == 0) {
/* UTCDOY time is computed by converting DP SCLK to ET seconds, */
/* which after that converted to UTC string. */
sct2e_(&sc, tconv, &ettime);
if (! failed_()) {
timout_(&ettime, "YYYY-DOY // HR:MN:SC.###", linet, (ftnlen)24,
linet_len);
if (failed_()) {
s_copy(linet, "NEED LSK AND SCLK FILES", linet_len, (ftnlen)
23);
}
} else {
s_copy(linet, "NEED LSK AND SCLK FILES", linet_len, (ftnlen)23);
}
}
ok = ! failed_();
/* Now we can reset SPICE error handling mechanism back to its */
/* original state. */
reset_();
erract_("SET", "ABORT", (ftnlen)3, (ftnlen)5);
errprt_("SET", "DEFAULT", (ftnlen)3, (ftnlen)7);
/* There is a bug in UNITIM (trace: SCT2E --> SCTE01 --> UNITIM) */
/* that has to be temporarily fixed before UNITIM officially fixed */
/* in N0049 delivery. Call to a specially written routine FIXUNI */
/* does that. */
if (! ok) {
fixuni_();
}
return 0;
} /* timecn_ */
void
sig_alrm (int notUsed)
{
alarmed = 1;
alarm (AIL);
check_dbtimers (); /* timers :) */
AIL8 += AIL;
if (quiz_halt == 1)
{
AIL13++;
if (AIL13 >= QUIZ_REPEAT_TIMER)
{
AIL13 = 0;
quiz_halt = 0;
}
}
if (quiz_answer == 1 && quiz_halt == 0)
{
if (quiz_timer >= QUIZ_TIMER)
{
quiz_answer = 0;
quiz_timer = 0;
quiz_halt = 1;
run_quiz_answer ();
}
else
quiz_timer++;
}
if (AIL8 >= SEND_DELAY)
{
AIL8 = 0;
Send ();
}
LastInput += AIL;
if (LastInput >= 500)
{
LastInput = 0;
#if CHECK_STONED == 1
L088 (BS);
#ifdef WIN32
printf ("\nNo response from %s in 5 mins, reconnecting...\n", BS);
#endif
prepare_bot ();
register_bot ();
#endif
}
AIL10 += AIL;
if (AIL10 >= 900)
{ /* 15 mins */
AIL10 = 0;
if (MARK_CHANGE == 1)
{
MARK_CHANGE = 0;
save_setup (); /* save settings */
}
}
AIL666 += AIL;
if (AIL666 >= 60)
{ /* 60 sec timer */
AIL666 = 0;
S ("PING :%s\n", BS);
}
AIL9 += AIL;
if (AIL9 >= 30)
{
AIL9 = 0;
if (stricmp (s_Mynick, Mynick) != 0)
{
S ("NICK %s\n", s_Mynick);
strncpy (Mynick, s_Mynick, sizeof (Mynick));
snprintf (NICK_COMMA, sizeof (NICK_COMMA), "%s,", Mynick);
snprintf (COLON_NICK, sizeof (COLON_NICK), "%s:", Mynick);
snprintf (BCOLON_NICK, sizeof (BCOLON_NICK), "%s\2:\2", Mynick);
}
}
if (Sleep_Toggle == 1)
{
AIL4 += AIL;
if (AIL4 >= Sleep_Time)
{
Sleep_Toggle = 0;
AIL4 = 0;
L089 (sleep_chan);
}
}
AIL2 += AIL;
AIL3 += AIL;
#ifdef RANDOM_STUFF
Rand_Idle++;
if (RAND_IDLE <= Rand_Idle)
{
Rand_Idle = 0;
do_random_stuff ();
get_rand_stuff_time ();
}
Rand_Stuff -= AIL;
if (Rand_Stuff <= 0)
{
if (Sleep_Toggle != 1)
do_random_stuff ();
get_rand_stuff_time ();
}
#endif
if (AIL3 >= AUTOTOPIC_TIME)
{
AIL3 = 0;
do_autotopics ();
}
AIL5 += AIL;
if (AIL5 >= 600)
{
#ifdef ANTI_IDLE
S ("PRIVMSG ! :\2\n");
#endif
AIL5 = 0;
}
if (AIL2 >= 300)
{
AIL2 = 0;
#if STATUS == 1
S ("LUSERS\n");
#endif
S ("MODE %s %s\n", Mynick, DEFAULT_UMODE);
S ("JOIN %s\n", CHAN);
reset_ ();
save_changes ();
#if PERFORM_TIMER == 1
run_perform ();
#endif
}
}
void SaturationMeasurer::reset()
{
reset_();
}
SaturationMeasurer::SaturationMeasurer(GradientMachine *machine_, DataSet *data_, XFile *file_) : Measurer(data_, file_)
{
machine = machine_;
reset_();
}
/* $Procedure SUMCK ( Summarize a CK file ) */
/* Subroutine */ int sumck_(integer *handle, char *binfnm, char *lpsfnm, char
*sclfnm, logical *logfil, integer *loglun, ftnlen binfnm_len, ftnlen
lpsfnm_len, ftnlen sclfnm_len)
{
/* Initialized data */
static char menutl[20] = "CK Summary Options ";
static char menuvl[20*6] = "QUIT " "Skip "
"ENTIRE_FILE " "BY_INSTRUMENT_ID " "BY_UTC_INTERVAL "
" " "BY_SCLK_INTERVAL ";
static char menutx[40*6] = "Quit, returning to main menu. "
"Skip " "Summarize entire fil"
"e. " "Summarize by NAIF instrument ID code. "
"Summarize by UTC time interval. " "Summarize by SCLK ti"
"me interval. ";
static char menunm[1*6] = "Q" "." "F" "I" "U" "S";
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen), s_wsle(cilist *), e_wsle(void), do_lio(integer *,
integer *, char *, ftnlen);
/* Local variables */
static logical done;
static char line[255];
extern /* Subroutine */ int sct2e_(integer *, doublereal *, doublereal *);
extern integer cardd_(doublereal *);
static doublereal beget;
static char segid[40];
extern /* Subroutine */ int chkin_(char *, ftnlen);
static char bsclk[32];
static doublereal endet;
static char esclk[32];
extern /* Subroutine */ int repmc_(char *, char *, char *, char *, ftnlen,
ftnlen, ftnlen, ftnlen);
static char separ[80];
static logical found;
extern /* Subroutine */ int repmi_(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen), ckgss_(char *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, integer *,
integer *, ftnlen), reset_(void);
static logical error;
extern /* Subroutine */ int ckwss_(integer *, char *, integer *, integer *
, integer *, integer *, doublereal *, doublereal *, ftnlen);
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int utc2et_(char *, doublereal *, ftnlen),
et2utc_(doublereal *, char *, integer *, char *, ftnlen, ftnlen),
daffna_(logical *);
extern logical failed_(void);
static integer segbad;
extern /* Subroutine */ int scdecd_(integer *, doublereal *, char *,
ftnlen), dafbfs_(integer *);
static integer segead;
static doublereal begscl;
extern /* Subroutine */ int scardd_(integer *, doublereal *), scencd_(
integer *, char *, doublereal *, ftnlen);
static logical segfnd;
static doublereal endscl;
static char begutc[32];
extern /* Subroutine */ int cnfirm_(char *, logical *, ftnlen), getchr_(
char *, char *, logical *, logical *, char *, ftnlen, ftnlen,
ftnlen);
static logical haveit;
static char endutc[32];
static integer segfrm;
static doublereal segbtm, segetm;
static integer instid, segins;
static doublereal segint[8];
static logical anyseg;
extern /* Subroutine */ int getint_(char *, integer *, logical *, logical
*, char *, ftnlen, ftnlen);
static char errmsg[320], option[20], sumsep[80];
extern logical return_(void);
static char fnmout[255], sclout[255];
static integer missin;
static char lpsout[255];
static integer menuop, segrts;
static char tmpstr[80];
static integer segtyp;
static doublereal intrvl[8], intsct[8];
static logical contnu, tryagn;
extern /* Subroutine */ int ssized_(integer *, doublereal *), writln_(
char *, integer *, ftnlen), getopt_(char *, integer *, char *,
char *, integer *, ftnlen, ftnlen, ftnlen), wninsd_(doublereal *,
doublereal *, doublereal *), wnintd_(doublereal *, doublereal *,
doublereal *);
static char typout[255];
extern /* Subroutine */ int chkout_(char *, ftnlen);
/* Fortran I/O blocks */
static cilist io___23 = { 0, 6, 0, 0, 0 };
static cilist io___24 = { 0, 6, 0, 0, 0 };
static cilist io___25 = { 0, 6, 0, 0, 0 };
static cilist io___26 = { 0, 6, 0, 0, 0 };
static cilist io___27 = { 0, 6, 0, 0, 0 };
static cilist io___28 = { 0, 6, 0, 0, 0 };
static cilist io___29 = { 0, 6, 0, 0, 0 };
static cilist io___30 = { 0, 6, 0, 0, 0 };
static cilist io___32 = { 0, 6, 0, 0, 0 };
static cilist io___33 = { 0, 6, 0, 0, 0 };
static cilist io___34 = { 0, 6, 0, 0, 0 };
static cilist io___36 = { 0, 6, 0, 0, 0 };
static cilist io___37 = { 0, 6, 0, 0, 0 };
static cilist io___38 = { 0, 6, 0, 0, 0 };
static cilist io___39 = { 0, 6, 0, 0, 0 };
static cilist io___41 = { 0, 6, 0, 0, 0 };
static cilist io___42 = { 0, 6, 0, 0, 0 };
static cilist io___43 = { 0, 6, 0, 0, 0 };
static cilist io___44 = { 0, 6, 0, 0, 0 };
static cilist io___46 = { 0, 6, 0, 0, 0 };
static cilist io___47 = { 0, 6, 0, 0, 0 };
static cilist io___48 = { 0, 6, 0, 0, 0 };
static cilist io___49 = { 0, 6, 0, 0, 0 };
static cilist io___51 = { 0, 6, 0, 0, 0 };
static cilist io___52 = { 0, 6, 0, 0, 0 };
static cilist io___53 = { 0, 6, 0, 0, 0 };
static cilist io___54 = { 0, 6, 0, 0, 0 };
static cilist io___56 = { 0, 6, 0, 0, 0 };
static cilist io___57 = { 0, 6, 0, 0, 0 };
static cilist io___58 = { 0, 6, 0, 0, 0 };
static cilist io___59 = { 0, 6, 0, 0, 0 };
static cilist io___60 = { 0, 6, 0, 0, 0 };
static cilist io___61 = { 0, 6, 0, 0, 0 };
static cilist io___62 = { 0, 6, 0, 0, 0 };
static cilist io___63 = { 0, 6, 0, 0, 0 };
static cilist io___65 = { 0, 6, 0, 0, 0 };
static cilist io___66 = { 0, 6, 0, 0, 0 };
static cilist io___67 = { 0, 6, 0, 0, 0 };
static cilist io___68 = { 0, 6, 0, 0, 0 };
static cilist io___70 = { 0, 6, 0, 0, 0 };
static cilist io___71 = { 0, 6, 0, 0, 0 };
static cilist io___72 = { 0, 6, 0, 0, 0 };
static cilist io___73 = { 0, 6, 0, 0, 0 };
static cilist io___75 = { 0, 6, 0, 0, 0 };
static cilist io___76 = { 0, 6, 0, 0, 0 };
static cilist io___77 = { 0, 6, 0, 0, 0 };
static cilist io___78 = { 0, 6, 0, 0, 0 };
static cilist io___80 = { 0, 6, 0, 0, 0 };
/* $ Abstract */
/* Summarize a CK file. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Declarations */
/* Set the number of double precision components in an unpacked CK */
/* descriptor. */
/* Set the number of integer components in an unpacked CK descriptor. */
/* Set the size of a packed CK descriptor. */
/* Set the length of a CK segment identifier. */
/* Set the value for the lower bound of the CELL data type. */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle of the SPK file to be summarized. */
/* LOGFIL I Write the summary to a log file and to screen? */
/* LOGLUN I Logical unit connected to the log file. */
/* NDC P Number of d.p. components in SPK descriptor. */
/* NIC P Number of integer components in SPK descriptor. */
/* NC P Size of packed SPK descriptor. */
/* IDSIZ P Length of SPK segment identifier. */
/* LBCELL P Lower bound for the SPICELIB CELL data structure. */
/* $ Detailed_Input */
/* HANDLE is the integer handle of the CK file to be summarized. */
/* LOGFIL if TRUE means that the summary will be written to */
/* a log file as well as displayed on the terminal */
/* screen. Otherwise, the summary will not be written */
/* to a log file. */
/* LOGLUN is the logical unit connected to a log file to which */
/* the summary is to be written if LOGFIL is TRUE. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* NDC is the number of double precision components in an */
/* unpacked SPK descriptor. */
/* NIC is the number of integer components in an unpacked */
/* SPK descriptor. */
/* NC is the size of a packed SPK descriptor. */
/* IDSIZ is the length of an SPK segment identifier. */
/* LBCELL is the lower bound for the SPICELIB CELL data */
/* structure. */
/* $ Exceptions */
/* None. */
/* $ Files */
/* The CK file to be summarized is referred throughout this routine */
/* by its handle. The file should already be opened for read. */
/* $ Particulars */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* M.J. Spencer (JPL) */
/* J.E. McLean (JPL) */
/* R.E. Thurman (JPL) */
/* $ Version */
/* - Beta Version 5.0.0 21-JUL-1995 (KRG) */
/* Added several arguments to the call of this subroutine and */
/* made other modifications to allow it to perform its own */
/* formatting of the summary, including filenames and separators. */
/* - Beta Version 4.0.0 11-APR-1994 (KRG) */
/* Modified this routine to make use of new routines to get and */
/* format and write CK segment summaries. */
/* Added a missing $ Index_Entries header section. */
/* Fixed a few typos in the header. */
/* The routine DISPC is now obsolete. It is no longer used. */
/* - Beta Version 3.0.0 22-MAR-1993 (KRG) */
/* 1) Changed the names of the variables TOFILE and UNIT to LOGFIL */
/* and LOGLUN, respectively. */
/* 2) Updated the program to use the menuing subroutine GETOPT */
/* which removes the need for the routine QSUMC. Redesigned */
/* the case sructure of the code to facilitate the use of the */
/* menuing routine. */
/* 3) Rearranged some of thee initializations that were performed, */
/* moved several calls to SCARDD outside the main loop, etc. */
/* 5) Performed some general cleanup as deemed necessary. */
/* - Beta Version 2.1.0 20-NOV-1991 (MJS) */
/* Checked FAILED function in main loop. */
/* - Beta Version 2.0.0 17-JUN-1991 (JEM) */
/* 1. Added the arguments TOFILE and UNIT. Previously the */
/* summary was only displayed on the terminal screen. */
/* Now, if requested by TOFILE, the summary is also */
/* written to the file connected to UNIT. */
/* 2. A user may cancel a task selected in QSUMC and */
/* select another. */
/* - SPICELIB Version 1.1.0 31-AUG-1990 (JEM) */
/* This routine was updated due to changes in the CK and */
/* SCLK design. Also, several implementation-specific */
/* parameters were moved from the header to the local */
/* parameters section. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (RET) */
/* -& */
/* $ Index_Entries */
/* summarize the segments in a binary ck file */
/* -& */
/* $ Revisions */
/* - Beta Version 5.0.0 21-JUL-1995 (KRG) */
/* Added several arguments to the call of this subroutine and */
/* made other modifications to allow it to perform its own */
/* formatting of the summary, including filenames and separators. */
/* - Beta Version 4.0.0 11-APR-1994 (KRG) */
/* Modified this routine to make use of new routines to get and */
/* format and write CK segment summaries. */
/* Added a missing $ Index_Entries header section. */
/* Fixed a few typos in the header. */
/* The routine DISPC is now obsolete. It is no longer used. */
/* - Beta Version 3.0.0 22-MAR-1993 (KRG) */
/* 1) Changed the names of the variables TOFILE and UNIT to LOGFIL */
/* and LOGLUN, respectively. */
/* 2) Updated the program to use the menuing subroutine GETOPT */
/* which removes the need for the routine QSUMC. Redesigned */
/* the case sructure of the code to facilitate the use of the */
/* menuing routine. */
/* 3) Rearranged some of thee initializations that were performed, */
/* moved several calls to SCARDD outside the main loop, etc. */
/* 5) Performed some general cleanup as deemed necessary. */
/* - Beta Version 2.1.0 20-NOV-1991 (MJS) */
/* Checked FAILED function in main loop. In the previous version, */
/* if any time conversion produced an error, the summary would go */
/* in an endless loop. */
/* - Beta Version 2.0.0 22-MAY-1991 (JEM) */
/* 1. In addition to adding the arguments TOFILE and UNIT to */
/* the calling sequence, the following code changes were */
/* made. The two new arguments were added to the calling */
/* sequence of DISPC as well. If TOFILE is true, a */
/* description of the type of summary is written to the */
/* output file before calling DISPC to write the summary. */
/* If no segments are found, the message is written to the */
/* output file as well as the terminal screen when */
/* TOFILE is true. */
/* 2. QSUMC was changed. 'NONE' is now a possible task */
/* returned from QSUMC and means a task was selected, */
/* then cancelled. QSUMC is called repeatedly until the */
/* task returned is something other than NONE. In */
/* this way the user is able to select another task. */
/* - SPICELIB Version 1.1.0 31-AUG-1990 (JEM) */
/* This routine was updated to handle these changes to the */
/* C-kernel design: */
/* 1. Ephemeris time is no longer included in CK files. */
/* All data is associated with spacecraft clock time only. */
/* The segment descriptor no longer contains the */
/* start and stop ET. Thus, the number of double */
/* precision components (NDC) is now two instead of four. */
/* 2. Segments may now contain rate information, along with */
/* pointing data. The segment descriptor contains a flag */
/* that indicates whether or not the segment includes */
/* rate information. Thus, the number of integer */
/* components (NIC) is now six instead of five. */
/* This version of SUMCK converts encoded SCLK times to ET for */
/* comparison with input times which are converted from UTC to ET. */
/* This routine was also updated to handle these changes to the */
/* SCLK design: */
/* 1. The name of the routine that encodes spacecraft */
/* clock time was changed from ENSCLK to SCENCD, and */
/* the order of arguments in the calling sequence */
/* was changed. */
/* 2. Instrument ID codes are now negative integers to */
/* avoid conflict with other body id codes. */
/* The parameters that pertain to the CK file architecture, */
/* like the number of double precision components in the */
/* segment descriptor (NDC), were moved from the header */
/* to the local parameter section. These parameters are */
/* implementation specific. Further, the user is not invited */
/* to change them, nor are they needed in any argument */
/* declaration. Thus they do not belong in the header. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Set value for a separator */
/* Set up the instrument ID code prompt. */
/* Set up the spacecraft ID code prompt. */
/* Set up the SCLK time string prompt. */
/* Set up labels for various output things. */
/* Set up the UTC time string prompt. */
/* Set the length for a line of text. */
/* Set the length for an output line. */
/* Set the length for an error message. */
/* Set the length for a UTC time string. */
/* Set the precision for the fractional part of UTC times. */
/* Set a length for the option values. */
/* Set a length for the title of a menu. */
/* Set the length of the text description of an option on a menu. */
/* The number of options available on the main menu. */
/* Parameter for the standard output unit. */
/* Local variables */
/* Save everything to keep control happy. */
/* Initial Values */
/* Define the menu title ... */
/* Define the menu option values ... */
/* Define the menu descriptive text for each option ... */
/* Define the menu option names ... */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SUMCK", (ftnlen)5);
}
/* Initialize the separator. */
s_copy(separ, "*********************************************************"
"***********************", (ftnlen)80, (ftnlen)80);
/* Initialize the segment separator. */
s_copy(sumsep, "--------------------------------------------------------"
"------------------------", (ftnlen)80, (ftnlen)80);
/* Set the sizes of the window cells that we will use if the file */
/* is to be summarized by time. */
ssized_(&c__2, intrvl);
ssized_(&c__2, segint);
ssized_(&c__2, intsct);
/* Initialize a few things before we start. */
instid = 0;
done = FALSE_;
while(! done) {
/* Initialize those things we reuse on every iteration. */
contnu = TRUE_;
writln_(" ", &c__6, (ftnlen)1);
getopt_(menutl, &c__6, menunm, menutx, &menuop, (ftnlen)20, (ftnlen)1,
(ftnlen)40);
if (failed_()) {
contnu = FALSE_;
}
if (contnu) {
/* Perform all of the setup necessary to perform the summary. */
/* This include prompting for input values required, etc. */
repmc_("Summary for CK file: #", "#", binfnm, fnmout, (ftnlen)22,
(ftnlen)1, binfnm_len, (ftnlen)255);
repmc_("Leapseconds File : #", "#", lpsfnm, lpsout, (ftnlen)22,
(ftnlen)1, lpsfnm_len, (ftnlen)255);
repmc_("SCLK File : #", "#", sclfnm, sclout, (ftnlen)22,
(ftnlen)1, sclfnm_len, (ftnlen)255);
s_copy(option, menuvl + ((i__1 = menuop - 1) < 6 && 0 <= i__1 ?
i__1 : s_rnge("menuvl", i__1, "sumck_", (ftnlen)553)) *
20, (ftnlen)20, (ftnlen)20);
if (s_cmp(option, "QUIT", (ftnlen)20, (ftnlen)4) == 0) {
contnu = FALSE_;
done = TRUE_;
} else if (s_cmp(option, "ENTIRE_FILE", (ftnlen)20, (ftnlen)11) ==
0) {
/* Summarize the entire file. */
repmc_("Summary Type : #", "#", "Entire File", typout, (
ftnlen)22, (ftnlen)1, (ftnlen)11, (ftnlen)255);
} else if (s_cmp(option, "BY_INSTRUMENT_ID", (ftnlen)20, (ftnlen)
16) == 0) {
/* Summarize for a specified body. */
/* First, we need to get the instrument ID code. */
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___23);
e_wsle();
s_wsle(&io___24);
do_lio(&c__9, &c__1, "Enter the desired NAIF instrument "
"code.", (ftnlen)39);
e_wsle();
s_wsle(&io___25);
e_wsle();
getint_("Instrument ID code? ", &instid, &haveit, &error,
errmsg, (ftnlen)20, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___26);
e_wsle();
s_wsle(&io___27);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___28);
e_wsle();
s_wsle(&io___29);
do_lio(&c__9, &c__1, "A NAIF instrument ID code "
"must be entered for this option.", (
ftnlen)58);
e_wsle();
}
if (! haveit || error) {
s_wsle(&io___30);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)
20);
if (! tryagn) {
contnu = FALSE_;
}
}
} else {
tryagn = FALSE_;
}
}
/* Write the type of summary to the log file if we need to. */
if (contnu) {
s_copy(tmpstr, "By Instrument ID #", (ftnlen)80, (ftnlen)
18);
repmc_("Summary Type : #", "#", tmpstr, typout, (
ftnlen)22, (ftnlen)1, (ftnlen)80, (ftnlen)255);
repmi_(typout, "#", &instid, typout, (ftnlen)255, (ftnlen)
1, (ftnlen)255);
}
} else if (s_cmp(option, "BY_UTC_INTERVAL", (ftnlen)20, (ftnlen)
15) == 0) {
/* Summarize for given UTC time interval. */
/* First, we need to get the UTC time string for the */
/* begin time. */
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___32);
e_wsle();
s_wsle(&io___33);
do_lio(&c__9, &c__1, "Enter the desired beginning UTC ti"
"me.", (ftnlen)37);
e_wsle();
s_wsle(&io___34);
e_wsle();
getchr_("UTC time? ", begutc, &haveit, &error, errmsg, (
ftnlen)10, (ftnlen)32, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___36);
e_wsle();
s_wsle(&io___37);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___38);
e_wsle();
s_wsle(&io___39);
do_lio(&c__9, &c__1, "A beginning UTC time strin"
"g must be entered for this option.", (
ftnlen)60);
e_wsle();
}
} else {
tryagn = FALSE_;
}
/* We now have the beginning time in UTC, so attempt */
/* to convert it to ET. If the conversion fails, we */
/* need to immediately reset the error handling so that */
/* we can continue processing. Remember, we are in a */
/* menuing subroutine, and we are not allowed to exit */
/* on an error: we must go back to the menu. thus the */
/* need for a resetting of the error handler here. If */
/* we got to here, there were no errors, so as long as */
/* we maintain that status, everything will be hunky */
/* dory. We also convert the ET back into UTC to get */
/* a consistent format for display. */
if (haveit) {
utc2et_(begutc, &beget, (ftnlen)32);
et2utc_(&beget, "C", &c__3, begutc, (ftnlen)1, (
ftnlen)32);
if (failed_()) {
reset_();
error = TRUE_;
}
}
/* Check to see if they want to try and enter the */
/* beginning UTC time string again. */
if (! haveit || error) {
s_wsle(&io___41);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)20);
if (! tryagn) {
contnu = FALSE_;
}
}
}
/* Now, if we can, we need to get the UTC time string for */
/* the end time. */
if (contnu) {
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___42);
e_wsle();
s_wsle(&io___43);
do_lio(&c__9, &c__1, "Enter the desired ending UTC t"
"ime.", (ftnlen)34);
e_wsle();
s_wsle(&io___44);
e_wsle();
getchr_("UTC time? ", endutc, &haveit, &error, errmsg,
(ftnlen)10, (ftnlen)32, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___46);
e_wsle();
s_wsle(&io___47);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___48);
e_wsle();
s_wsle(&io___49);
do_lio(&c__9, &c__1, "An ending UTC time str"
"ing must be entered for this option.",
(ftnlen)58);
e_wsle();
}
} else {
tryagn = FALSE_;
}
/* We now have the ending time in UTC, so attempt */
/* to convert it to ET. If the conversion fails, we */
/* need to immediately reset the error handling so */
/* that we can continue processing. Remember, we are */
/* in a menuing subroutine, and we are not allowed */
/* to exit on an error: we must go back to the menu. */
/* thus the need for a resetting of the error handler */
/* here. If we got to here, there were no errors, so */
/* as long as we maintain that status, everything */
/* will be hunky dory. We also convert the ET back */
/* into UTC to get a consistent format for display. */
if (haveit) {
utc2et_(endutc, &endet, (ftnlen)32);
et2utc_(&endet, "C", &c__3, endutc, (ftnlen)1, (
ftnlen)32);
if (failed_()) {
reset_();
error = TRUE_;
}
}
/* Check to see if they want to try and enter the */
/* beginning UTC time string again. */
if (! haveit || error) {
s_wsle(&io___51);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)
20);
if (! tryagn) {
contnu = FALSE_;
}
} else {
tryagn = FALSE_;
}
}
}
/* Create an interval out of the begin and end ET times, */
/* if we can. */
if (contnu) {
scardd_(&c__0, intrvl);
wninsd_(&beget, &endet, intrvl);
if (failed_()) {
contnu = FALSE_;
}
}
/* Write the type of summary to the output file, if we can. */
if (contnu) {
s_copy(tmpstr, "By # Time Interval #", (ftnlen)80, (
ftnlen)20);
repmc_("Summary Type : #", "#", tmpstr, typout, (
ftnlen)22, (ftnlen)1, (ftnlen)80, (ftnlen)255);
repmc_(typout, "#", "UTC", typout, (ftnlen)255, (ftnlen)1,
(ftnlen)3, (ftnlen)255);
repmc_(typout, "#", "(#, #)", typout, (ftnlen)255, (
ftnlen)1, (ftnlen)6, (ftnlen)255);
repmc_(typout, "#", begutc, typout, (ftnlen)255, (ftnlen)
1, (ftnlen)32, (ftnlen)255);
repmc_(typout, "#", endutc, typout, (ftnlen)255, (ftnlen)
1, (ftnlen)32, (ftnlen)255);
}
} else if (s_cmp(option, "BY_SCLK_INTERVAL", (ftnlen)20, (ftnlen)
16) == 0) {
/* Summarize for given SCLK time interval. */
/* First, we need to get spacecraft ID code. */
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___52);
e_wsle();
s_wsle(&io___53);
do_lio(&c__9, &c__1, "Enter the desired NAIF spacecraft "
"ID code.", (ftnlen)42);
e_wsle();
s_wsle(&io___54);
e_wsle();
getint_("Spacecraft ID code? ", &missin, &haveit, &error,
errmsg, (ftnlen)20, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___56);
e_wsle();
s_wsle(&io___57);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___58);
e_wsle();
s_wsle(&io___59);
do_lio(&c__9, &c__1, "A NAIF spacecraft ID code "
"must be entered for this option.", (
ftnlen)58);
e_wsle();
}
if (! haveit || error) {
s_wsle(&io___60);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)
20);
if (! tryagn) {
contnu = FALSE_;
}
}
} else {
tryagn = FALSE_;
}
}
/* Now, we need to get the SCLK time string for the */
/* begin time. */
if (contnu) {
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___61);
e_wsle();
s_wsle(&io___62);
do_lio(&c__9, &c__1, "Enter the desired beginning SC"
"LK time.", (ftnlen)38);
e_wsle();
s_wsle(&io___63);
e_wsle();
getchr_("SCLK time? ", bsclk, &haveit, &error, errmsg,
(ftnlen)11, (ftnlen)32, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___65);
e_wsle();
s_wsle(&io___66);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___67);
e_wsle();
s_wsle(&io___68);
do_lio(&c__9, &c__1, "A beginning SCLK time "
"string must be entered for this opti"
"on.", (ftnlen)61);
e_wsle();
}
} else {
tryagn = FALSE_;
}
/* We now have the beginning time in SCLK, so attempt */
/* to convert it to ET. If the conversion fails, we */
/* need to immediately reset the error handling so */
/* that we can continue processing. Remember, we are */
/* in a menuing subroutine, and we are not allowed to */
/* exit on an error: we must go back to the menu. thus */
/* the need for a resetting of the error handler here. */
/* If we got to here, there were no errors, so as long */
/* as we maintain that status, everything will be */
/* hunky dory. We also convert the ET back into SCLK, */
/* and UTC to get a consistent format for display. */
if (haveit) {
scencd_(&missin, bsclk, &begscl, (ftnlen)32);
sct2e_(&missin, &begscl, &beget);
et2utc_(&beget, "C", &c__3, begutc, (ftnlen)1, (
ftnlen)32);
scdecd_(&missin, &begscl, bsclk, (ftnlen)32);
if (failed_()) {
reset_();
error = TRUE_;
}
}
/* Check to see if they want to try and enter the */
/* beginning UTC time string again. */
if (! haveit || error) {
s_wsle(&io___70);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)
20);
if (! tryagn) {
contnu = FALSE_;
}
}
}
}
/* Now, if we can, we need to get the UTC time string for */
/* the end time. */
if (contnu) {
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___71);
e_wsle();
s_wsle(&io___72);
do_lio(&c__9, &c__1, "Enter the desired ending SCLK "
"time.", (ftnlen)35);
e_wsle();
s_wsle(&io___73);
e_wsle();
getchr_("SCLK time? ", esclk, &haveit, &error, errmsg,
(ftnlen)11, (ftnlen)32, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___75);
e_wsle();
s_wsle(&io___76);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___77);
e_wsle();
s_wsle(&io___78);
do_lio(&c__9, &c__1, "An ending SCLK time st"
"ring must be entered for this option."
, (ftnlen)59);
e_wsle();
}
} else {
tryagn = FALSE_;
}
/* We now have the ending time in UTC, so attempt */
/* to convert it to ET. If the conversion fails, we */
/* need to immediately reset the error handling so */
/* that we can continue processing. Remember, we are */
/* in a menuing subroutine, and we are not allowed */
/* to exit on an error: we must go back to the menu. */
/* thus the need for a resetting of the error handler */
/* here. If we got to here, there were no errors, so */
/* as long as we maintain that status, everything */
/* will be hunky dory. We also convert the ET back */
/* into UTC to get a consistent format for display. */
if (haveit) {
scencd_(&missin, esclk, &endscl, (ftnlen)32);
sct2e_(&missin, &endscl, &endet);
et2utc_(&endet, "C", &c__3, endutc, (ftnlen)1, (
ftnlen)32);
scdecd_(&missin, &endscl, esclk, (ftnlen)32);
if (failed_()) {
reset_();
error = TRUE_;
}
}
/* Check to see if they want to try and enter the */
/* ending SCLK time string again. */
if (! haveit || error) {
s_wsle(&io___80);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)
20);
if (! tryagn) {
contnu = FALSE_;
}
} else {
tryagn = FALSE_;
}
}
}
/* Create an interval out of the begin and end ET times, */
/* if we can. */
if (contnu) {
scardd_(&c__0, intrvl);
wninsd_(&beget, &endet, intrvl);
if (failed_()) {
contnu = FALSE_;
}
}
/* Write the type of summary to the output file, if we can. */
if (contnu) {
s_copy(tmpstr, "By # Time Interval #", (ftnlen)80, (
ftnlen)20);
repmc_("Summary Type : #", "#", tmpstr, typout, (
ftnlen)22, (ftnlen)1, (ftnlen)80, (ftnlen)255);
repmc_(typout, "#", "SCLK", typout, (ftnlen)255, (ftnlen)
1, (ftnlen)4, (ftnlen)255);
repmc_(typout, "#", "(#, #)", typout, (ftnlen)255, (
ftnlen)1, (ftnlen)6, (ftnlen)255);
repmc_(typout, "#", bsclk, typout, (ftnlen)255, (ftnlen)1,
(ftnlen)32, (ftnlen)255);
repmc_(typout, "#", esclk, typout, (ftnlen)255, (ftnlen)1,
(ftnlen)32, (ftnlen)255);
}
}
/* Now, if we can, search through the file from the beginning. */
/* Keep track of whether or not any segments satisfy the search */
/* criteria. */
if (contnu) {
writln_(" ", &c__6, (ftnlen)1);
writln_(separ, &c__6, (ftnlen)80);
writln_(" ", &c__6, (ftnlen)1);
writln_(fnmout, &c__6, (ftnlen)255);
writln_(lpsout, &c__6, (ftnlen)255);
writln_(sclout, &c__6, (ftnlen)255);
writln_(typout, &c__6, (ftnlen)255);
writln_(" ", &c__6, (ftnlen)1);
if (*logfil) {
writln_(" ", loglun, (ftnlen)1);
writln_(separ, loglun, (ftnlen)80);
writln_(" ", loglun, (ftnlen)1);
writln_(fnmout, loglun, (ftnlen)255);
writln_(lpsout, loglun, (ftnlen)255);
writln_(sclout, loglun, (ftnlen)255);
writln_(typout, loglun, (ftnlen)255);
writln_(" ", loglun, (ftnlen)1);
}
anyseg = FALSE_;
dafbfs_(handle);
daffna_(&found);
while(found && contnu) {
/* On each iteration of the loop, we have not found */
/* anything initially. */
segfnd = FALSE_;
scardd_(&c__0, intsct);
scardd_(&c__0, segint);
/* Get the descriptor of the segment. */
ckgss_(segid, &segins, &segfrm, &segtyp, &segrts, &segbtm,
&segetm, &segbad, &segead, (ftnlen)40);
/* Check to see if the current segment satisfies the */
/* current search criteria. */
if (s_cmp(option, "ENTIRE_FILE", (ftnlen)20, (ftnlen)11)
== 0) {
segfnd = TRUE_;
} else if (s_cmp(option, "BY_INSTRUMENT_ID", (ftnlen)20, (
ftnlen)16) == 0) {
segfnd = instid == segins;
} else if (s_cmp(option, "BY_UTC_INTERVAL", (ftnlen)20, (
ftnlen)15) == 0) {
/* Create an interval out of the epochs in the */
/* segment. */
missin = segins / 1000;
sct2e_(&missin, &segbtm, &beget);
sct2e_(&missin, &segetm, &endet);
wninsd_(&beget, &endet, segint);
/* Intersect it with the input interval. */
wnintd_(segint, intrvl, intsct);
if (failed_()) {
reset_();
contnu = FALSE_;
} else {
segfnd = cardd_(intsct) > 0;
}
} else if (s_cmp(option, "BY_SCLK_INTERVAL", (ftnlen)20, (
ftnlen)16) == 0) {
/* Create an interval out of the epochs in the */
/* segment. */
if (missin == segins / 1000) {
sct2e_(&missin, &segbtm, &beget);
sct2e_(&missin, &segetm, &endet);
wninsd_(&beget, &endet, segint);
/* Intersect it with the input interval. */
wnintd_(segint, intrvl, intsct);
if (failed_()) {
reset_();
contnu = FALSE_;
} else {
segfnd = cardd_(intsct) > 0;
}
} else {
segfnd = FALSE_;
}
}
if (contnu && segfnd) {
anyseg = TRUE_;
/* Display the segment summary. */
writln_(sumsep, &c__6, (ftnlen)80);
if (*logfil) {
writln_(sumsep, loglun, (ftnlen)80);
}
ckwss_(&c__6, segid, &segins, &segfrm, &segtyp, &
segrts, &segbtm, &segetm, (ftnlen)40);
if (*logfil) {
ckwss_(loglun, segid, &segins, &segfrm, &segtyp, &
segrts, &segbtm, &segetm, (ftnlen)40);
}
writln_(sumsep, &c__6, (ftnlen)80);
if (*logfil) {
writln_(sumsep, loglun, (ftnlen)80);
}
}
/* Find that next segment. */
daffna_(&found);
if (failed_()) {
contnu = FALSE_;
}
}
}
/* Better say something if no segments were matching the */
/* search criteria were found. */
if (contnu && ! anyseg) {
s_copy(line, "No matching segments were found.", (ftnlen)255,
(ftnlen)32);
writln_(line, &c__6, (ftnlen)255);
if (*logfil) {
writln_(line, loglun, (ftnlen)255);
}
}
if (contnu) {
writln_(" ", &c__6, (ftnlen)1);
writln_(separ, &c__6, (ftnlen)80);
writln_(" ", &c__6, (ftnlen)1);
if (*logfil) {
writln_(" ", loglun, (ftnlen)1);
writln_(separ, loglun, (ftnlen)80);
writln_(" ", loglun, (ftnlen)1);
}
}
}
/* If anything failed, rset the error handling so that we can */
/* redisplay the menu and keep doing things. */
if (failed_()) {
reset_();
}
}
chkout_("SUMCK", (ftnlen)5);
return 0;
} /* sumck_ */
const boost::dynamic_bitset<>::size_type
) const>(&boost::dynamic_bitset<>::operator>>)
)
.def("set",
static_cast<boost::dynamic_bitset<> &(boost::dynamic_bitset<>::*)(
boost::dynamic_bitset<>::size_type, bool
)>(&boost::dynamic_bitset<>::set),
py::return_internal_reference<>(),
set_()
)
.def("reset",
static_cast<boost::dynamic_bitset<> &(boost::dynamic_bitset<>::*)(
boost::dynamic_bitset<>::size_type
)>(&boost::dynamic_bitset<>::reset),
py::return_internal_reference<>(),
reset_()
)
.def("flip",
static_cast<boost::dynamic_bitset<> &(boost::dynamic_bitset<>::*)(
boost::dynamic_bitset<>::size_type
)>(&boost::dynamic_bitset<>::flip),
py::return_internal_reference<>(),
flip_()
)
.def("test",
static_cast<bool (boost::dynamic_bitset<>::*)(
boost::dynamic_bitset<>::size_type
) const>(&boost::dynamic_bitset<>::test)
)
.def("test_set",
static_cast<bool (boost::dynamic_bitset<>::*)(
/* $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__ */
void SpatialConvolution::reset()
{
reset_();
}
/* $Procedure GETFNM_1 ( Get a filename from standard input ) */
/* Subroutine */ int getfnm_1__(char *prmpt, char *fstat, char *fname,
logical *valid, ftnlen prmpt_len, ftnlen fstat_len, ftnlen fname_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
address a__1[2];
integer i__1, i__2[2];
char ch__1[1], ch__2[81];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
extern integer cpos_(char *, char *, integer *, ftnlen, ftnlen);
integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen), errch_(char *, char *, ftnlen, ftnlen), reset_(
void);
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
static char badchr[162];
extern logical failed_(void);
char oldact[10];
extern /* Subroutine */ int cnfirm_(char *, logical *, ftnlen), erract_(
char *, char *, ftnlen, ftnlen);
integer length;
extern integer lastnb_(char *, ftnlen);
char myfnam[1000];
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen);
logical tryagn, myvlid;
extern logical exists_(char *, ftnlen), return_(void);
extern /* Subroutine */ int prompt_(char *, char *, ftnlen, ftnlen),
writln_(char *, integer *, ftnlen);
char status[3], myprmt[80];
/* $ Abstract */
/* This routine prompts the user for a valid filename. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* PRMPT I The prompt to use when asking for the filename. */
/* FSTAT I Status of the file: 'OLD' or 'NEW'. */
/* FNAME O A valid filename typed in by the user. */
/* VALID O A logical flag indicating a valid filename. */
/* PRMLEN P Maximum length allowed for a prompt before */
/* truncation. */
/* $ Detailed_Input */
/* PRMPT is a character string that will be displayed from the */
/* current cursor position that informs a user that input */
/* is expected. Prompts should be fairly short, since we */
/* need to declare some local storage. The current maximum */
/* length of a prompt is given by the parameter PRMLEN. */
/* FSTAT This is the status of the filename entered. It should */
/* be 'OLD' when prompting for the filename of a file which */
/* already exists, and 'NEW' when prompting for the */
/* filename of a file which does not already exist or is to */
/* be over written. */
/* $ Detailed_Output */
/* FNAME is a character string that contains a valid filename */
/* typed in by the user. A valid filename is defined */
/* simply to be a nonblank character string with no */
/* embedded blanks, nonprinting characters, or characters */
/* having decimal values > 126. */
/* VALID A logical flag which indicates whether or not the */
/* filename entered is valid, i.e., a nonblank character */
/* string with no leading or embedded blanks, which */
/* satisfies the constraints for validity imposed. */
/* $ Parameters */
/* PRMLEN The maximum length for an input prompt string. */
/* $ Exceptions */
/* 1) If the input file status is not equal to 'NEW' or 'OLD' after */
/* being left justified and converted to upper case, the error */
/* SPICE(INVALIDARGUMENT) will be signalled. The error handling */
/* is then reset. */
/* 2) If the filename entered at the prompt is blank, the error */
/* SPICE(BLANKFILENAME) will be signalled. The error handling is */
/* then reset. */
/* 3) If the filename contains an illegal character, a nonprinting */
/* character or embedded blanks, the error */
/* SPICE(ILLEGALCHARACTER) will be signalled. */
/* 4) If the file status is equal to 'OLD' after being left */
/* justified and converted to upper case and the file specified */
/* by the filename entered at the prompt does not exist, the */
/* error SPICE(FILEDOESNOTEXIST) will be signalled. */
/* 5) If the file status is equal to 'NEW' after being left */
/* justified and converted to upper case and the file specified */
/* by the filename entered at the prompt already exists, the */
/* error SPICE(FILEALREADYEXISTS) will be signalled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This is a utility that allows you to "easily" request a valid, */
/* filename from a program user. At a high level, it frees you */
/* from the peculiarities of a particular FORTRAN's implementation */
/* of cursor control. */
/* A valid filename is defined as a nonblank character string with */
/* no embedded blanks, nonprinting characters, or characters with */
/* decimal values > 126. Leading blanks are removed, and trailing */
/* blanks are ignored. */
/* If an invalid filename is entered, this routine provides a */
/* descriptive error message and halts the execution of the */
/* process which called it by using a Fortran STOP. */
/* $ Examples */
/* EXAMPLE 1: */
/* FNAME = ' ' */
/* PRMPT = 'Filename? ' */
/* FSTAT = 'OLD' */
/* CALL GETFNM_1( PRMPT, FSTAT, FNAME, VALID ) */
/* The user sees the following displayed on the screen: */
/* Filename? _ */
/* where the underbar, '_', represents the cursor position. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* $ Version */
/* - SPICELIB Version 6.17.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 6.16.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 6.15.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 6.14.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 6.13.0, 14-DEC-2010 (EDW) */
/* Declared PROMPT as EXTERNAL. */
/* Unfied Version and Revision sections, eliminated Revision */
/* section. Corrected error in 09-DEC-1999 Version entry. */
/* Version ID changed to 6.0.9 from 7.0.0. */
/* - Beta Version 6.12.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - Beta Version 6.11.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - Beta Version 6.10.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - Beta Version 6.9.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - Beta Version 6.8.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - Beta Version 6.7.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - Beta Version 6.6.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - Beta Version 6.5.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - Beta Version 6.4.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - Beta Version 6.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - Beta Version 6.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - Beta Version 6.1.1, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - Beta Version 6.1.0, 16-AUG-2000 (WLT) */
/* Added PC-LINUX environment */
/* - Beta Version 6.0.9, 09-DEC-1999 (WLT) */
/* This routine now calls EXPFNM_2 only UNIX environments */
/* - Beta Version 6.0.0, 20-JAN-1998 (NJB) */
/* Now calls EXPFNM_2 to attempt to expand environment variables. */
/* Fixed a typo or two at various places in the header. */
/* - Beta Version 5.1.0, 31-JAN-1996 (KRG) */
/* Fixed a pedantic Fortran syntax error dealing with input */
/* strings that are dimensioned CHARACTER*(*). */
/* A local character string is now declared, and a parameter, */
/* PRMLEN, has been added to the interface description for this */
/* subroutine. PRMLEN defines the maximum length allowed for a */
/* prompt before it is truncated. */
/* - Beta Version 5.0.0, 05-JUL-1995 (KRG) */
/* Modified the routine to handle all of its own error messages */
/* and error conditions. The routine now signals an error */
/* immediately resetting the error handling when an exceptional */
/* condition is encountered. This is done so that input attempts */
/* may continue until a user decides to stop trying. */
/* Added several exceptions to the $ Exceptions section of the */
/* header. */
/* - Beta Version 4.0.1, 25-APR-1994 (KRG) */
/* Removed some incorrect comments from the $ Particulars section */
/* of the header. Something about a looping structure that is not */
/* a part of the code now, if it ever was. */
/* Fixed a typo or two at various places in the header. */
/* - Beta Version 4.0.0, 29-SEP-1993 (KRG) */
/* Added the character reperesnted by decimal 127 to the BADCHR. */
/* It should have been there, but it wasn't. */
/* - Beta Version 3.0.0, 10-SEP-1993 (KRG) */
/* Made the file status variable FSTAT case insensitive. */
/* Added code to the file status .EQ. 'NEW' case to set the */
/* valid flag to .FALSE. and set an appropriate error message */
/* about the file already existing. */
/* - Beta Version 2.0.0, 02-APR-1993 (KRG) */
/* The variable BADCHR was not saved which caused problems on */
/* some computers. This variable is now saved. */
/* - Beta Version 1.0.0, 01-JUN-1992 (KRG) */
/* -& */
/* $ Index_Entries */
/* prompt for a filename with error handling */
/* -& */
/* SPICELIB Functions */
/* Local Parameters */
/* Maximum length of a filename. */
/* Length of an error action */
/* Local Variables */
/* Saved Variables */
/* Initial Values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("GETFNM_1", (ftnlen)8);
}
/* We are going to be signalling errors and resetting the error */
/* handling, so we need to be in RETURN mode. First we get the */
/* current mode and save it, then we set the mode to return. Upon */
/* leaving the subroutine, we will restore the error handling mode */
/* that was in effect when we entered. */
erract_("GET", oldact, (ftnlen)3, (ftnlen)10);
erract_("SET", "RETURN", (ftnlen)3, (ftnlen)6);
/* If this is the first time this routine has been called, */
/* initialize the ``bad character'' string. */
if (first) {
first = FALSE_;
for (i__ = 0; i__ <= 32; ++i__) {
i__1 = i__;
*(unsigned char *)&ch__1[0] = i__;
s_copy(badchr + i__1, ch__1, i__ + 1 - i__1, (ftnlen)1);
}
for (i__ = 1; i__ <= 129; ++i__) {
i__1 = i__ + 32;
*(unsigned char *)&ch__1[0] = i__ + 126;
s_copy(badchr + i__1, ch__1, i__ + 33 - i__1, (ftnlen)1);
}
}
/* Left justify and convert the file status to upper case for */
/* comparisons. */
ljust_(fstat, status, fstat_len, (ftnlen)3);
ucase_(status, status, (ftnlen)3, (ftnlen)3);
/* Check to see if we have a valid status for the filename. */
if (s_cmp(status, "OLD", (ftnlen)3, (ftnlen)3) != 0 && s_cmp(status,
"NEW", (ftnlen)3, (ftnlen)3) != 0) {
setmsg_("The file status '#' was not valid. The file status must hav"
"e a value of 'NEW' or 'OLD'.", (ftnlen)87);
errch_("#", status, (ftnlen)1, (ftnlen)3);
sigerr_("SPICE(INVALIDARGUMENT)", (ftnlen)22);
chkout_("GETFNM_1", (ftnlen)8);
return 0;
}
/* Store the input value for the prompt into our local value. We do */
/* this for pedantic Fortran compilers that issue warnings for */
/* CHARACTER*(*) variables used with concatenation. */
s_copy(myprmt, prmpt, (ftnlen)80, prmpt_len);
/* Read in a potential filename, and test it for validity. */
tryagn = TRUE_;
while(tryagn) {
/* Set the value of the valid flag to .TRUE.. We assume that the */
/* name entered will be a valid one. */
myvlid = TRUE_;
/* Get the filename. */
if (s_cmp(myprmt, " ", (ftnlen)80, (ftnlen)1) == 0) {
prompt_("Filename? ", myfnam, (ftnlen)10, (ftnlen)1000);
} else {
/* Writing concatenation */
i__2[0] = lastnb_(myprmt, (ftnlen)80), a__1[0] = myprmt;
i__2[1] = 1, a__1[1] = " ";
s_cat(ch__2, a__1, i__2, &c__2, (ftnlen)81);
prompt_(ch__2, myfnam, lastnb_(myprmt, (ftnlen)80) + 1, (ftnlen)
1000);
}
if (failed_()) {
myvlid = FALSE_;
}
if (myvlid) {
if (s_cmp(myfnam, " ", (ftnlen)1000, (ftnlen)1) == 0) {
myvlid = FALSE_;
setmsg_("The filename entered was blank.", (ftnlen)31);
sigerr_("SPICE(BLANKFILENAME)", (ftnlen)20);
}
}
if (myvlid) {
/* Left justify the filename. */
ljust_(myfnam, myfnam, (ftnlen)1000, (ftnlen)1000);
/* Check for bad characters in the filename. */
length = lastnb_(myfnam, (ftnlen)1000);
i__ = cpos_(myfnam, badchr, &c__1, length, (ftnlen)162);
if (i__ > 0) {
myvlid = FALSE_;
setmsg_("The filename entered contains non printing characte"
"rs or embedded blanks.", (ftnlen)73);
sigerr_("SPICE(ILLEGALCHARACTER)", (ftnlen)23);
}
}
if (myvlid) {
/* We know that the filename that was entered was nonblank and */
/* had no bad characters. So, now we take care of the status */
/* question. */
if (s_cmp(status, "OLD", (ftnlen)3, (ftnlen)3) == 0) {
if (! exists_(myfnam, rtrim_(myfnam, (ftnlen)1000))) {
myvlid = FALSE_;
setmsg_("A file with the name '#' does not exist.", (
ftnlen)40);
errch_("#", myfnam, (ftnlen)1, (ftnlen)1000);
sigerr_("SPICE(FILEDOESNOTEXIST)", (ftnlen)23);
}
} else if (s_cmp(status, "NEW", (ftnlen)3, (ftnlen)3) == 0) {
if (exists_(myfnam, rtrim_(myfnam, (ftnlen)1000))) {
myvlid = FALSE_;
setmsg_("A file with the name '#' already exists.", (
ftnlen)40);
errch_("#", myfnam, (ftnlen)1, (ftnlen)1000);
sigerr_("SPICE(FILEALREADYEXISTS)", (ftnlen)24);
}
}
}
if (myvlid) {
tryagn = FALSE_;
} else {
writln_(" ", &c__6, (ftnlen)1);
cnfirm_("Try again? (Yes/No) ", &tryagn, (ftnlen)20);
writln_(" ", &c__6, (ftnlen)1);
if (tryagn) {
reset_();
}
}
}
/* At this point, we have done the best we can. If the status */
/* was new, we might still have an invalid filename, but the */
/* exact reasons for its invalidity are system dependent, and */
/* therefore hard to test. */
*valid = myvlid;
if (*valid) {
s_copy(fname, myfnam, fname_len, rtrim_(myfnam, (ftnlen)1000));
}
/* Restore the error action. */
erract_("SET", oldact, (ftnlen)3, (ftnlen)10);
chkout_("GETFNM_1", (ftnlen)8);
return 0;
} /* getfnm_1__ */