/* $Procedure DISPLY ( BRIEF Display Summary ) */
/* Subroutine */ int disply_(char *fmtpic, logical *tdsp, logical *gdsp,
logical *obnam, integer *objlis, char *winsym, integer *winptr,
doublereal *winval, char *timtyp, char *kertyp, ftnlen fmtpic_len,
ftnlen winsym_len, ftnlen timtyp_len, ftnlen kertyp_len)
{
/* System generated locals */
address a__1[3];
integer i__1, i__2, i__3[3], i__4, i__5;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
static char name__[64];
static logical same;
static char line[132];
static integer nobj, objn[2], sobj, size;
static char rest[132];
static integer b, e, i__, j;
extern integer cardc_(char *, ftnlen);
static integer s;
extern /* Subroutine */ int chkin_(char *, ftnlen);
static char names[64*100006];
static logical found, group;
extern integer rtrim_(char *, ftnlen);
static integer n1, n2;
static char p1[8], p2[8];
static integer start;
static char header[132*2], wd[8];
extern integer objact_(integer *);
extern /* Subroutine */ int maknam_(integer *, integer *, logical *, char
*, char *, ftnlen, ftnlen), appndc_(char *, char *, ftnlen,
ftnlen);
static integer object[3], remain;
extern /* Subroutine */ int objget_(integer *, integer *, integer *),
objrem_(integer *, integer *), rmaini_(integer *, integer *,
integer *, integer *);
static char timlbl[8];
static integer npline;
extern /* Subroutine */ int objnth_(integer *, integer *, integer *,
logical *), prname_(integer *, integer *, char *, char *, char *,
integer *, char *, char *, ftnlen, ftnlen, ftnlen, ftnlen, ftnlen)
;
static doublereal filwin[1006];
static integer nlines, objtmp[2];
extern integer touchi_(integer *);
extern /* Subroutine */ int distim_(char *, doublereal *, char *, char *,
ftnlen, ftnlen, ftnlen);
static integer widest;
extern integer objsiz_(integer *);
extern /* Subroutine */ int chkout_(char *, ftnlen), objnxt_(integer *,
integer *, integer *, logical *), nextwd_(char *, char *, char *,
ftnlen, ftnlen, ftnlen);
static integer ngroup;
extern /* Subroutine */ int sygetd_(char *, char *, integer *, doublereal
*, integer *, doublereal *, logical *, ftnlen, ftnlen), ssizec_(
integer *, char *, ftnlen);
extern logical return_(void);
static doublereal lstwin[1006];
static char timstr[64];
extern /* Subroutine */ int writit_(char *, ftnlen);
static logical fnd;
static integer obj[2];
/* $ Abstract */
/* Display BRIEF summary. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* None. */
/* $ Declarations */
/* $ 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 */
/* W.L. Taber (NAIF) */
/* B.V. Semenov (NAIF) */
/* $ Version */
/* - BRIEF Version 3.0.0, 14-JAN-2008 (BVS) */
/* Increased MAXBOD to 100,000 (from 20,000). */
/* Increased CMDSIZ to 25,000 (from 4,000). */
/* Updated version string and changed its format to */
/* '#.#.#, Month DD, YYYY' (from '#.#.#'). */
/* - BRIEF Version 1.0.0, 14-MAR-1996 (WLT) */
/* Initial release. */
/* -& */
/* The Version is stored as a string. */
/* MAXUSE is the maximum number of bodies that can be explicitly */
/* specified on the command line for brief summaries. */
/* The longest command line that can be accommodated is */
/* given by CMDSIZ */
/* The maximum number of bodies that can be summarized is stored */
/* in the parameter MAXBOD */
/* The average number of intervals per body */
/* The largest expected window */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* FMTPIC I Body name/ID format picture (see BRIEF.PGM) */
/* TDSP I Tabular display flag */
/* GDSP I Grouping display flag */
/* OBNAM I Name ordering flag */
/* OBJLIS I List of object (?) */
/* WINSYM I Symbol table with object attributes (?) */
/* WINPTR I Symbol table with object attributes (?) */
/* WINVAL I Symbol table with object attributes (?) */
/* TIMTYP I Output time type (see DISTIM.FOR) */
/* KERTYP I Kernel type (SPK, PCK) */
/* $ Detailed_Input */
/* See Brief_I/O. */
/* $ Detailed_Output */
/* This routine return no outputs. Instead it prints summary of */
/* provided input information to STDOUT. */
/* $ Parameters */
/* LBCELL. */
/* $ Exceptions */
/* 1) Errors may be signaled by routines in the calling tree of */
/* this routine. */
/* $ Files */
/* TBD. */
/* $ Particulars */
/* TBD. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* This routine must not be called by any routines except BRIEF's */
/* main program. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* B.V. Semenov (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - BRIEF Version 2.0.0, 22-OCT-2007 (BVS) */
/* Added output time type to the argument list. Changed to */
/* call DISTIM to format output time and provide time system */
/* label for the summary table header. */
/* - BRIEF Version 1.0.0, 14-MAR-1996 (WLT) */
/* Bill's initial version. */
/* -& */
/* $ Index_Entries */
/* display summary by BRIEF */
/* -& */
/* SPICELIB functions */
/* Parameters */
/* Local Variables. */
/* SPICELIB Calls */
/* Saved variables */
/* The SAVE statement that appears here causes f2c to create */
/* local variables with static duration. This enables the CSPICE */
/* version of brief to run under cygwin. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("DISPLY", (ftnlen)6);
}
/* Get time system label for the table header. */
distim_(timtyp, &c_b3, timlbl, timstr, timtyp_len, (ftnlen)8, (ftnlen)64);
/* Set local grouping flag. */
group = ! (*tdsp) || *gdsp;
/* First take apart the format picture to see what */
/* the various components are. */
nextwd_(fmtpic, p1, rest, fmtpic_len, (ftnlen)8, (ftnlen)132);
nextwd_(rest, wd, rest, (ftnlen)132, (ftnlen)8, (ftnlen)132);
nextwd_(rest, p2, rest, (ftnlen)132, (ftnlen)8, (ftnlen)132);
size = 1;
if (s_cmp(p2, " ", (ftnlen)8, (ftnlen)1) != 0) {
size = 3;
}
/* Find out the width of the widest name. */
nobj = objact_(objlis);
sobj = objsiz_(objlis);
/* If we don't have any objects to display then */
/* we just return. */
if (nobj == 0) {
chkout_("DISPLY", (ftnlen)6);
return 0;
}
objnth_(objlis, &c__1, obj, &found);
widest = 0;
while(found) {
objget_(obj, objlis, object);
objnxt_(obj, objlis, objn, &found);
prname_(object, &sobj, p1, wd, p2, &size, kertyp, name__, (ftnlen)8, (
ftnlen)8, (ftnlen)8, kertyp_len, (ftnlen)64);
/* Computing MAX */
i__1 = widest, i__2 = rtrim_(name__, (ftnlen)64);
widest = max(i__1,i__2);
obj[0] = objn[0];
obj[1] = objn[1];
}
/* Are we going to group by window? If not, this is pretty */
/* easy. Just display stuff. */
if (*tdsp && ! (*gdsp)) {
s = widest + 3;
e = s + 32;
if (s_cmp(kertyp, "SPK", kertyp_len, (ftnlen)3) == 0) {
s_copy(line, "Bodies", (ftnlen)132, (ftnlen)6);
} else if (s_cmp(kertyp, "PCK", kertyp_len, (ftnlen)3) == 0) {
s_copy(line, "Frames", (ftnlen)132, (ftnlen)6);
} else {
s_copy(line, "IDs", (ftnlen)132, (ftnlen)3);
}
/* Writing concatenation */
i__3[0] = 19, a__1[0] = "Start of Interval (";
i__3[1] = rtrim_(timlbl, (ftnlen)8), a__1[1] = timlbl;
i__3[2] = 1, a__1[2] = ")";
s_cat(line + (s - 1), a__1, i__3, &c__3, 132 - (s - 1));
/* Writing concatenation */
i__3[0] = 17, a__1[0] = "End of Interval (";
i__3[1] = rtrim_(timlbl, (ftnlen)8), a__1[1] = timlbl;
i__3[2] = 1, a__1[2] = ")";
s_cat(line + (e - 1), a__1, i__3, &c__3, 132 - (e - 1));
writit_(line, (ftnlen)132);
s_copy(line, "-------", (ftnlen)132, (ftnlen)7);
s_copy(line + (s - 1), "-----------------------------", 132 - (s - 1),
(ftnlen)29);
s_copy(line + (e - 1), "-----------------------------", 132 - (e - 1),
(ftnlen)29);
writit_(line, (ftnlen)132);
objnth_(objlis, &c__1, obj, &found);
n1 = 0;
while(found) {
s_copy(line, " ", (ftnlen)132, (ftnlen)1);
objget_(obj, objlis, object);
prname_(object, &sobj, p1, wd, p2, &size, kertyp, line, (ftnlen)8,
(ftnlen)8, (ftnlen)8, kertyp_len, (ftnlen)132);
maknam_(object, &sobj, obnam, kertyp, name__, kertyp_len, (ftnlen)
64);
sygetd_(name__, winsym, winptr, winval, &n2, &filwin[6], &found, (
ftnlen)64, winsym_len);
if (n2 == n1) {
same = TRUE_;
i__ = 1;
while(same && i__ <= n1) {
same = filwin[(i__1 = i__ + 5) < 1006 && 0 <= i__1 ? i__1
: s_rnge("filwin", i__1, "disply_", (ftnlen)340)]
== lstwin[(i__2 = i__ + 5) < 1006 && 0 <= i__2 ?
i__2 : s_rnge("lstwin", i__2, "disply_", (ftnlen)
340)];
++i__;
}
} else {
same = FALSE_;
}
if (! same) {
i__1 = n2;
for (i__ = 1; i__ <= i__1; i__ += 2) {
distim_(timtyp, &filwin[(i__2 = i__ + 5) < 1006 && 0 <=
i__2 ? i__2 : s_rnge("filwin", i__2, "disply_", (
ftnlen)352)], timlbl, line + (s - 1), timtyp_len,
(ftnlen)8, 132 - (s - 1));
distim_(timtyp, &filwin[(i__2 = i__ + 6) < 1006 && 0 <=
i__2 ? i__2 : s_rnge("filwin", i__2, "disply_", (
ftnlen)353)], timlbl, line + (e - 1), timtyp_len,
(ftnlen)8, 132 - (e - 1));
writit_(line, (ftnlen)132);
s_copy(line, " ", (ftnlen)132, (ftnlen)1);
lstwin[(i__2 = i__ + 5) < 1006 && 0 <= i__2 ? i__2 :
s_rnge("lstwin", i__2, "disply_", (ftnlen)356)] =
filwin[(i__4 = i__ + 5) < 1006 && 0 <= i__4 ?
i__4 : s_rnge("filwin", i__4, "disply_", (ftnlen)
356)];
lstwin[(i__2 = i__ + 6) < 1006 && 0 <= i__2 ? i__2 :
s_rnge("lstwin", i__2, "disply_", (ftnlen)357)] =
filwin[(i__4 = i__ + 6) < 1006 && 0 <= i__4 ?
i__4 : s_rnge("filwin", i__4, "disply_", (ftnlen)
357)];
n1 = n2;
}
} else {
i__1 = s + 11;
s_copy(line + i__1, "Same coverage as previous object ", 132
- i__1, (ftnlen)33);
writit_(line, (ftnlen)132);
}
objnxt_(obj, objlis, objtmp, &found);
obj[0] = touchi_(objtmp);
obj[1] = touchi_(&objtmp[1]);
}
} else if (*tdsp && *gdsp) {
s = widest + 3;
e = s + 32;
if (s_cmp(kertyp, "SPK", kertyp_len, (ftnlen)3) == 0) {
s_copy(line, "Bodies", (ftnlen)132, (ftnlen)6);
} else if (s_cmp(kertyp, "PCK", kertyp_len, (ftnlen)3) == 0) {
s_copy(line, "Frames", (ftnlen)132, (ftnlen)6);
} else {
s_copy(line, "IDs", (ftnlen)132, (ftnlen)3);
}
/* Writing concatenation */
i__3[0] = 19, a__1[0] = "Start of Interval (";
i__3[1] = rtrim_(timlbl, (ftnlen)8), a__1[1] = timlbl;
i__3[2] = 1, a__1[2] = ")";
s_cat(line + (s - 1), a__1, i__3, &c__3, 132 - (s - 1));
/* Writing concatenation */
i__3[0] = 17, a__1[0] = "End of Interval (";
i__3[1] = rtrim_(timlbl, (ftnlen)8), a__1[1] = timlbl;
i__3[2] = 1, a__1[2] = ")";
s_cat(line + (e - 1), a__1, i__3, &c__3, 132 - (e - 1));
writit_(line, (ftnlen)132);
s_copy(line, "-------", (ftnlen)132, (ftnlen)7);
s_copy(line + (s - 1), "-----------------------------", 132 - (s - 1),
(ftnlen)29);
s_copy(line + (e - 1), "-----------------------------", 132 - (e - 1),
(ftnlen)29);
writit_(line, (ftnlen)132);
objnth_(objlis, &c__1, obj, &found);
while(found) {
s_copy(line, " ", (ftnlen)132, (ftnlen)1);
objget_(obj, objlis, object);
prname_(object, &sobj, p1, wd, p2, &size, kertyp, line, (ftnlen)8,
(ftnlen)8, (ftnlen)8, kertyp_len, (ftnlen)132);
maknam_(object, &sobj, obnam, kertyp, name__, kertyp_len, (ftnlen)
64);
sygetd_(name__, winsym, winptr, winval, &n1, &filwin[6], &found, (
ftnlen)64, winsym_len);
i__1 = n1;
for (i__ = 1; i__ <= i__1; i__ += 2) {
distim_(timtyp, &filwin[(i__2 = i__ + 5) < 1006 && 0 <= i__2 ?
i__2 : s_rnge("filwin", i__2, "disply_", (ftnlen)416)
], timlbl, line + (s - 1), timtyp_len, (ftnlen)8, 132
- (s - 1));
distim_(timtyp, &filwin[(i__2 = i__ + 6) < 1006 && 0 <= i__2 ?
i__2 : s_rnge("filwin", i__2, "disply_", (ftnlen)417)
], timlbl, line + (e - 1), timtyp_len, (ftnlen)8, 132
- (e - 1));
writit_(line, (ftnlen)132);
s_copy(line, " ", (ftnlen)132, (ftnlen)1);
lstwin[(i__2 = i__ + 5) < 1006 && 0 <= i__2 ? i__2 : s_rnge(
"lstwin", i__2, "disply_", (ftnlen)420)] = filwin[(
i__4 = i__ + 5) < 1006 && 0 <= i__4 ? i__4 : s_rnge(
"filwin", i__4, "disply_", (ftnlen)420)];
lstwin[(i__2 = i__ + 6) < 1006 && 0 <= i__2 ? i__2 : s_rnge(
"lstwin", i__2, "disply_", (ftnlen)421)] = filwin[(
i__4 = i__ + 6) < 1006 && 0 <= i__4 ? i__4 : s_rnge(
"filwin", i__4, "disply_", (ftnlen)421)];
}
objnxt_(obj, objlis, objn, &fnd);
objrem_(obj, objlis);
obj[0] = objn[0];
obj[1] = objn[1];
while(fnd) {
s_copy(line, " ", (ftnlen)132, (ftnlen)1);
objget_(obj, objlis, object);
prname_(object, &sobj, p1, wd, p2, &size, kertyp, line, (
ftnlen)8, (ftnlen)8, (ftnlen)8, kertyp_len, (ftnlen)
132);
maknam_(object, &sobj, obnam, kertyp, name__, kertyp_len, (
ftnlen)64);
sygetd_(name__, winsym, winptr, winval, &n2, &filwin[6], &
found, (ftnlen)64, winsym_len);
if (n2 == n1) {
same = TRUE_;
i__ = 1;
while(same && i__ <= n1) {
same = filwin[(i__1 = i__ + 5) < 1006 && 0 <= i__1 ?
i__1 : s_rnge("filwin", i__1, "disply_", (
ftnlen)445)] == lstwin[(i__2 = i__ + 5) <
1006 && 0 <= i__2 ? i__2 : s_rnge("lstwin",
i__2, "disply_", (ftnlen)445)];
++i__;
}
} else {
same = FALSE_;
}
if (same) {
i__1 = s + 11;
s_copy(line + i__1, "Same coverage as previous object ",
132 - i__1, (ftnlen)33);
writit_(line, (ftnlen)132);
}
objnxt_(obj, objlis, objn, &fnd);
if (same) {
objrem_(obj, objlis);
}
obj[0] = objn[0];
obj[1] = objn[1];
}
objnth_(objlis, &c__1, obj, &found);
}
} else {
objnth_(objlis, &c__1, obj, &found);
while(found) {
ssizec_(&c_b78, names, (ftnlen)64);
objget_(obj, objlis, object);
prname_(object, &sobj, p1, wd, p2, &size, kertyp, name__, (ftnlen)
8, (ftnlen)8, (ftnlen)8, kertyp_len, (ftnlen)64);
appndc_(name__, names, (ftnlen)64, (ftnlen)64);
/* Look up the window associated with this object. */
maknam_(object, &sobj, obnam, kertyp, name__, kertyp_len, (ftnlen)
64);
sygetd_(name__, winsym, winptr, winval, &n1, &lstwin[6], &fnd, (
ftnlen)64, winsym_len);
/* Fetch the next object. */
objnxt_(obj, objlis, objn, &fnd);
objrem_(obj, objlis);
obj[0] = objn[0];
obj[1] = objn[1];
while(fnd) {
objget_(obj, objlis, object);
maknam_(object, &sobj, obnam, kertyp, name__, kertyp_len, (
ftnlen)64);
sygetd_(name__, winsym, winptr, winval, &n2, &filwin[6], &fnd,
(ftnlen)64, winsym_len);
/* See if this window is the same as the current */
/* window under considerations. */
if (n1 == n2) {
same = TRUE_;
i__ = 1;
while(same && i__ <= n1) {
same = filwin[(i__1 = i__ + 5) < 1006 && 0 <= i__1 ?
i__1 : s_rnge("filwin", i__1, "disply_", (
ftnlen)520)] == lstwin[(i__2 = i__ + 5) <
1006 && 0 <= i__2 ? i__2 : s_rnge("lstwin",
i__2, "disply_", (ftnlen)520)];
++i__;
}
} else {
same = FALSE_;
}
objnxt_(obj, objlis, objn, &fnd);
if (same) {
objrem_(obj, objlis);
prname_(object, &sobj, p1, wd, p2, &size, kertyp, name__,
(ftnlen)8, (ftnlen)8, (ftnlen)8, kertyp_len, (
ftnlen)64);
appndc_(name__, names, (ftnlen)64, (ftnlen)64);
}
obj[0] = objn[0];
obj[1] = objn[1];
}
ngroup = cardc_(names, (ftnlen)64);
if (ngroup == 1) {
if (s_cmp(kertyp, "SPK", kertyp_len, (ftnlen)3) == 0) {
s_copy(line, "Body: ", (ftnlen)132, (ftnlen)6);
start = 7;
} else if (s_cmp(kertyp, "PCK", kertyp_len, (ftnlen)3) == 0) {
s_copy(line, "Frame: ", (ftnlen)132, (ftnlen)7);
start = 8;
} else {
s_copy(line, "ID: ", (ftnlen)132, (ftnlen)4);
start = 5;
}
} else {
if (s_cmp(kertyp, "SPK", kertyp_len, (ftnlen)3) == 0) {
s_copy(line, "Bodies: ", (ftnlen)132, (ftnlen)8);
start = 9;
} else if (s_cmp(kertyp, "PCK", kertyp_len, (ftnlen)3) == 0) {
s_copy(line, "Frames: ", (ftnlen)132, (ftnlen)8);
start = 9;
} else {
s_copy(line, "IDs: ", (ftnlen)132, (ftnlen)5);
start = 6;
}
}
npline = (80 - widest - start) / (widest + 2) + 1;
rmaini_(&ngroup, &npline, &nlines, &remain);
if (remain != 0) {
++nlines;
}
i__1 = nlines;
for (j = 1; j <= i__1; ++j) {
b = start;
i__2 = ngroup;
i__4 = nlines;
for (i__ = j; i__4 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
i__4) {
s_copy(line + (b - 1), names + (((i__5 = i__ + 5) <
100006 && 0 <= i__5 ? i__5 : s_rnge("names", i__5,
"disply_", (ftnlen)580)) << 6), 132 - (b - 1), (
ftnlen)64);
b = b + widest + 2;
}
writit_(line, (ftnlen)132);
s_copy(line, " ", (ftnlen)132, (ftnlen)1);
}
s = start;
e = start + 36;
s_copy(header, " ", (ftnlen)132, (ftnlen)1);
s_copy(header + 132, " ", (ftnlen)132, (ftnlen)1);
/* Writing concatenation */
i__3[0] = 19, a__1[0] = "Start of Interval (";
i__3[1] = rtrim_(timlbl, (ftnlen)8), a__1[1] = timlbl;
i__3[2] = 1, a__1[2] = ")";
s_cat(header + (s - 1), a__1, i__3, &c__3, 132 - (s - 1));
/* Writing concatenation */
i__3[0] = 17, a__1[0] = "End of Interval (";
i__3[1] = rtrim_(timlbl, (ftnlen)8), a__1[1] = timlbl;
i__3[2] = 1, a__1[2] = ")";
s_cat(header + (e - 1), a__1, i__3, &c__3, 132 - (e - 1));
s_copy(header + (s + 131), "-----------------------------", 132 -
(s - 1), (ftnlen)29);
s_copy(header + (e + 131), "-----------------------------", 132 -
(e - 1), (ftnlen)29);
writit_(header, (ftnlen)132);
writit_(header + 132, (ftnlen)132);
i__1 = n1;
for (i__ = 1; i__ <= i__1; i__ += 2) {
s_copy(line, " ", (ftnlen)132, (ftnlen)1);
distim_(timtyp, &lstwin[(i__4 = i__ + 5) < 1006 && 0 <= i__4 ?
i__4 : s_rnge("lstwin", i__4, "disply_", (ftnlen)608)
], timlbl, line + (s - 1), timtyp_len, (ftnlen)8, 132
- (s - 1));
distim_(timtyp, &lstwin[(i__4 = i__ + 6) < 1006 && 0 <= i__4 ?
i__4 : s_rnge("lstwin", i__4, "disply_", (ftnlen)609)
], timlbl, line + (e - 1), timtyp_len, (ftnlen)8, 132
- (e - 1));
writit_(line, (ftnlen)132);
}
writit_(" ", (ftnlen)1);
objnth_(objlis, &c__1, obj, &found);
}
}
/* All done. */
chkout_("DISPLY", (ftnlen)6);
return 0;
} /* disply_ */
/* $Procedure META_2 ( Percy's interface to META_0 ) */
/* Subroutine */ int meta_2__0_(int n__, char *command, char *temps, integer *
ntemps, char *temp, integer *btemp, char *error, ftnlen command_len,
ftnlen temps_len, ftnlen temp_len, ftnlen error_len)
{
/* Initialized data */
static logical pass1 = TRUE_;
static char margns[128] = "LEFT 1 RIGHT 75 "
" "
" ";
static char keynam[6*10] = "1 " "2 " "3 " "4 " "5 "
"6 " "7 " "8 " "9 " "10 ";
/* System generated locals */
address a__1[5];
integer i__1, i__2[5];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsle(cilist *), e_wsle(
void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer do_lio(integer *, integer *, char *, ftnlen);
/* Local variables */
extern /* Subroutine */ int getopt_1__(char *, integer *, char *, integer
*, char *, integer *, char *, char *, ftnlen, ftnlen, ftnlen,
ftnlen, ftnlen);
static integer sbeg;
static char mode[16], pick[32];
static integer b, e, i__, j;
extern integer cardc_(char *, ftnlen);
extern logical batch_(void);
static integer score;
static logical fixit;
extern integer rtrim_(char *, ftnlen);
static char style[128];
static integer m2code;
static char tryit[600];
extern /* Subroutine */ int m2gmch_(char *, char *, char *, integer *,
logical *, integer *, logical *, integer *, integer *, char *,
ftnlen, ftnlen, ftnlen, ftnlen), m2rcvr_(integer *, integer *,
char *, ftnlen), scardc_(integer *, char *, ftnlen);
static integer bscore, cutoff;
static logical reason;
extern /* Subroutine */ int prefix_(char *, integer *, char *, ftnlen,
ftnlen), ssizec_(integer *, char *, ftnlen), repsub_(char *,
integer *, integer *, char *, char *, ftnlen, ftnlen, ftnlen);
static logical intrct;
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen);
static char thnwds[32*7], kwords[32*16];
extern /* Subroutine */ int cmprss_(char *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen), prepsn_(char *, ftnlen);
static logical pssthn;
static char questn[80];
extern /* Subroutine */ int niceio_3__(char *, integer *, char *, ftnlen,
ftnlen), cnfirm_1__(char *, logical *, ftnlen);
/* Fortran I/O blocks */
static cilist io___19 = { 0, 6, 0, 0, 0 };
static cilist io___20 = { 0, 6, 0, 0, 0 };
static cilist io___21 = { 0, 6, 0, 0, 0 };
static cilist io___22 = { 0, 6, 0, 0, 0 };
static cilist io___23 = { 0, 6, 0, 0, 0 };
static cilist io___27 = { 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___31 = { 0, 6, 0, 0, 0 };
/* $ Abstract */
/* Given a collection of acceptable syntax's and a statement */
/* (COMMAND) this routine determines if the statement is */
/* syntactically correct. */
/* $ 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 */
/* The META/2 Book. */
/* $ Keywords */
/* COMPARE */
/* PARSING */
/* SEARCH */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* COMMAND I A candidate PERCY command. */
/* TEMPS I A collection of language definition statements */
/* NTEMPS I The number of definition statements */
/* TEMP - Work space required for comparison of statements. */
/* BTEMP O The first of the def statements that best matches. */
/* ERROR O Non-blank if none of the def's match. */
/* $ Detailed_Input */
/* COMMAND A candidate PERCY command. */
/* TEMPS A collection of language definition statements */
/* NTEMPS The number of definition statements */
/* TEMP Work space required for comparison of statements. */
/* TEMP should be declared to have the same length */
/* as the character strings that make up TEMPS. */
/* $ Detailed_Output */
/* BTEMP The first of the def statements that best matches. */
/* ERROR Non-blank if none of the def's match. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Particulars */
/* Later. */
/* $ Examples */
/* Later. */
/* $ Restrictions */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - META/2 Configured Version 3.0.0, 11-AUG-1995 (WLT) */
/* The control flow through this routine was modified */
/* so that it will now re-try all templates (starting */
/* with the best previous match) if a spelling error */
/* is encountered. This should fix the confused */
/* responses that META/2 gave occassionally before. */
/* - META/2 Configured Version 2.0.0, 9-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 9, 1994 */
/* - META/2 Configured Version 2.0.0, 9-MAY-1994 */
/* Added a pretty print formatting capability to the */
/* error diagnostics. */
/* - META/2 Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of META/2 */
/* software as of May 3, 1994 */
/* - Beta Version 2.0.0, 14-JAN-1993 (HAN) */
/* Assigned the value 'INTERACTIVE' to the variable MODE, and */
/* replaced calls to VTLIB routines with calls to more */
/* portable routines. */
/* - Beta Version 1.0.0, 13-JUL-1988 (WLT) (IMU) */
/* -& */
/* Spice Functions */
/* Local variables. */
/* Saved variables */
/* Initial values */
/* Parameter adjustments */
if (temps) {
}
if (error) {
}
/* Function Body */
switch(n__) {
case 1: goto L_m2marg;
}
/* %&END_DECLARATIONS */
/* Take care of first pass initializations. */
if (pass1) {
pass1 = FALSE_;
ssizec_(&c__1, thnwds, (ftnlen)32);
scardc_(&c__0, thnwds, (ftnlen)32);
ssizec_(&c__10, kwords, (ftnlen)32);
scardc_(&c__0, kwords, (ftnlen)32);
/* Determine if were in batch or interactive mode. */
if (batch_()) {
s_copy(mode, "BATCH", (ftnlen)16, (ftnlen)5);
} else {
s_copy(mode, "INTERACTIVE", (ftnlen)16, (ftnlen)11);
}
}
intrct = s_cmp(mode, "BATCH", (ftnlen)16, (ftnlen)5) != 0;
s_copy(style, margns, (ftnlen)128, (ftnlen)128);
suffix_("NEWLINE /cr VTAB /vt HARDSPACE , ", &c__1, style, (ftnlen)33, (
ftnlen)128);
i__ = 0;
bscore = -1;
m2code = -1;
cutoff = 72;
reason = TRUE_;
/* Look through the templates until we get a match or we */
/* run out of templates to try. */
i__1 = *ntemps;
for (i__ = 1; i__ <= i__1; ++i__) {
score = 0;
s_copy(temp, temps + (i__ - 1) * temps_len, temp_len, temps_len);
sbeg = 1;
m2code = 0;
m2gmch_(temp, thnwds, command, &sbeg, &reason, &cutoff, &pssthn, &
m2code, &score, error, temp_len, (ftnlen)32, command_len,
error_len);
/* If M2CODE comes back zero, we are done with the work */
/* of this routine. */
if (m2code == 0) {
*btemp = i__;
return 0;
}
if (score > bscore) {
bscore = score;
*btemp = i__;
}
}
/* If we get here, we know we didn't have a match. Examine the */
/* highest scoring template to get available diagnostics */
/* about the mismatch. */
s_copy(temp, temps + (*btemp - 1) * temps_len, temp_len, temps_len);
sbeg = 1;
fixit = TRUE_;
m2code = 0;
m2gmch_(temp, thnwds, command, &sbeg, &c_true, &cutoff, &pssthn, &m2code,
&score, error, temp_len, (ftnlen)32, command_len, error_len);
/* If we are in interactiive mode and we have a spelling error, we */
/* can attempt to fix it. Note this occurs only if the M2CODE */
/* is less than 100 mod 10000. */
while(m2code % 10000 < 100 && intrct && fixit) {
/* Construct a friendly message; display it; and */
/* get the user's response as to whether or not the */
/* command should be modified. */
s_copy(tryit, error, (ftnlen)600, error_len);
prefix_("Hmmmm.,,,", &c__1, tryit, (ftnlen)9, (ftnlen)600);
suffix_("/cr/cr I can repair this if you like.", &c__0, tryit, (
ftnlen)37, (ftnlen)600);
s_wsle(&io___19);
e_wsle();
niceio_3__(tryit, &c__6, style, (ftnlen)600, (ftnlen)128);
s_wsle(&io___20);
e_wsle();
s_wsle(&io___21);
e_wsle();
s_wsle(&io___22);
e_wsle();
s_wsle(&io___23);
e_wsle();
m2rcvr_(&b, &e, kwords, (ftnlen)32);
if (cardc_(kwords, (ftnlen)32) == 1) {
/* Writing concatenation */
i__2[0] = 17, a__1[0] = "Should I change \"";
i__2[1] = e - (b - 1), a__1[1] = command + (b - 1);
i__2[2] = 6, a__1[2] = "\" to \"";
i__2[3] = rtrim_(kwords + 192, (ftnlen)32), a__1[3] = kwords +
192;
i__2[4] = 3, a__1[4] = "\" ?";
s_cat(questn, a__1, i__2, &c__5, (ftnlen)80);
cnfirm_1__(questn, &fixit, rtrim_(questn, (ftnlen)80));
} else {
cnfirm_1__("Should I fix it?", &fixit, (ftnlen)16);
}
/* If the user has elected to have us fix the command */
/* we have a few things to do... */
if (fixit) {
/* Look up the suggested fixes. If there is more than */
/* one possibility, see which one the user thinks is */
/* best. Otherwise, no more questions for now. */
m2rcvr_(&b, &e, kwords, (ftnlen)32);
if (cardc_(kwords, (ftnlen)32) > 1) {
i__1 = cardc_(kwords, (ftnlen)32) - 4;
for (i__ = 1; i__ <= i__1; ++i__) {
s_wsle(&io___27);
e_wsle();
}
i__1 = cardc_(kwords, (ftnlen)32);
getopt_1__("Which word did you mean?", &i__1, keynam, &c__6,
kwords + 192, &c__32, kwords + 192, pick, (ftnlen)24,
(ftnlen)6, (ftnlen)32, (ftnlen)32, (ftnlen)32);
} else {
s_copy(pick, kwords + 192, (ftnlen)32, (ftnlen)32);
}
/* Make the requested repairs on the command, and */
/* redisplay the command. */
repsub_(command, &b, &e, pick, command, command_len, (ftnlen)32,
command_len);
cmprss_(" ", &c__1, command, command, (ftnlen)1, command_len,
command_len);
s_wsle(&io___29);
do_lio(&c__9, &c__1, " ", (ftnlen)1);
e_wsle();
s_wsle(&io___30);
do_lio(&c__9, &c__1, " ", (ftnlen)1);
e_wsle();
niceio_3__(command, &c__6, style, command_len, (ftnlen)128);
s_wsle(&io___31);
e_wsle();
/* Look through the templates again until we get a match or we */
/* run out of templates to try. Note however, that this time */
/* we will start in a different spot. We already have a best */
/* matching template. We'll start our search for a match */
/* there and simulate a circular list of templates so that */
/* we can examine all of them if necessary. */
s_copy(error, " ", error_len, (ftnlen)1);
s_copy(error + error_len, " ", error_len, (ftnlen)1);
bscore = -1;
m2code = -1;
cutoff = 72;
reason = TRUE_;
j = *btemp - 1;
i__1 = *ntemps;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Get the index of the next template to examine. */
++j;
while(j > *ntemps) {
j -= *ntemps;
}
/* Set the template, score for this template, spot to */
/* begin examining it and the M2CODE so far. */
s_copy(temp, temps + (j - 1) * temps_len, temp_len, temps_len)
;
sbeg = 1;
score = 0;
m2code = 0;
m2gmch_(temp, thnwds, command, &sbeg, &reason, &cutoff, &
pssthn, &m2code, &score, error, temp_len, (ftnlen)32,
command_len, error_len);
/* If we get back a zero M2CODE we've got a match */
/* This routine's work is done. */
if (m2code == 0) {
*btemp = i__;
return 0;
}
/* Hmmph. No match. See if we've got a better */
/* matching score so far and then go on to the next */
/* template if any are left. */
if (score > bscore) {
bscore = score;
*btemp = i__;
}
}
/* If we made it to this point the command doesn't properly */
/* match any of the templates. Get the best match and */
/* determine the diagnostics for this template. */
s_copy(temp, temps + (*btemp - 1) * temps_len, temp_len,
temps_len);
sbeg = 1;
m2code = 0;
score = 0;
m2gmch_(temp, thnwds, command, &sbeg, &reason, &cutoff, &pssthn, &
m2code, &score, error, temp_len, (ftnlen)32, command_len,
error_len);
}
}
/* If you get to this point. We didn't have a match set up */
/* the second level of mismatch diagnostics using the best */
/* matching template. (BTEMP already points to it.) */
s_copy(temp, temps + (*btemp - 1) * temps_len, temp_len, temps_len);
cmprss_(" ", &c__1, temp, temp, (ftnlen)1, temp_len, temp_len);
prepsn_(temp, temp_len);
prepsn_(error + error_len, error_len);
prefix_("/cr/cr(-3:-3) ", &c__1, error + error_len, (ftnlen)14, error_len)
;
prefix_(temp, &c__1, error + error_len, temp_len, error_len);
prefix_("/cr/cr(3:3) ", &c__1, error + error_len, (ftnlen)12, error_len);
prefix_("a command with the following syntax:", &c__3, error + error_len,
(ftnlen)36, error_len);
prefix_("I Believe you were trying to enter", &c__1, error + error_len, (
ftnlen)34, error_len);
prefix_("META/2:", &c__1, error + error_len, (ftnlen)7, error_len);
return 0;
/* The following entry point allows user's to adjust the margins */
/* of the META/2 error messages. */
L_m2marg:
s_copy(margns, temp, (ftnlen)128, temp_len);
return 0;
} /* meta_2__ */
/* $Procedure SEPOOL ( String from pool ) */
/* Subroutine */ int sepool_(char *item, integer *fidx, char *contin, char *
string, integer *size, integer *lidx, logical *found, ftnlen item_len,
ftnlen contin_len, ftnlen string_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen), s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer comp;
logical more;
char part[80];
integer room, n;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer clast, csize;
logical gotit;
extern integer rtrim_(char *, ftnlen);
integer putat;
extern /* Subroutine */ int gcpool_(char *, integer *, integer *, integer
*, char *, logical *, ftnlen, ftnlen);
integer cfirst;
extern /* Subroutine */ int chkout_(char *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Retrieve the string starting at the FIDX element of the kernel */
/* pool variable, where the string may be continued across several */
/* components of the kernel pool variable. */
/* $ 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 */
/* POOL */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ITEM I name of the kernel pool variable */
/* FIDX I index of the first component of the string */
/* CONTIN I character sequence used to indicate continuation */
/* STRING O a full string concatenated across continuations */
/* SIZE O the number of character in the full string value */
/* LIDX O index of the last component of the string */
/* FOUND O flag indicating success or failure of request */
/* $ Detailed_Input */
/* ITEM is the name of a kernel pool variable for which */
/* the caller wants to retrieve a full (potentially */
/* continued) string. */
/* FIDX is the index of the first component (the start) of */
/* the string in ITEM. */
/* CONTIN is a sequence of characters which (if they appear as */
/* the last non-blank sequence of characters in a */
/* component of a value of a kernel pool variable) */
/* indicate that the string associated with the */
/* component is continued into the next literal */
/* component of the kernel pool variable. */
/* If CONTIN is blank, all of the components of ITEM */
/* will be retrieved as a single string. */
/* $ Detailed_Output */
/* STRING is the full string starting at the FIDX element of the */
/* kernel pool variable specified by ITEM. */
/* Note that if STRING is not sufficiently long to hold */
/* the fully continued string, the value will be */
/* truncated. You can determine if STRING has been */
/* truncated by examining the variable SIZE. */
/* SIZE is the index of last non-blank character of */
/* continued string as it is represented in the */
/* kernel pool. This is the actual number of characters */
/* needed to hold the requested string. If STRING */
/* contains a truncated portion of the full string, */
/* RTRIM(STRING) will be less than SIZE. */
/* If the value of STRING should be a blank, then */
/* SIZE will be set to 1. */
/* LIDX is the index of the last component (the end) of */
/* the retrieved string in ITEM. */
/* FOUND is a logical variable indicating success of the */
/* request to retrieve the string. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the variable specified by ITEM is not present in the */
/* kernel pool or is present but is not character valued, STRING */
/* will be returned as a blank, SIZE will be returned with the */
/* value 0 and FOUND will be set to .FALSE. In particular if NTH */
/* is less than 1, STRING will be returned as a blank, SIZE will */
/* be zero and FOUND will be FALSE. */
/* 2) If the variable specified has a blank string associated */
/* with its full string starting at FIDX, STRING will be blank, */
/* SIZE will be 1 and FOUND will be set to .TRUE. */
/* 3) If STRING is not long enough to hold all of the characters */
/* associated with the NTH string, it will be truncated on the */
/* right. */
/* 4) If the continuation character is a blank, every component */
/* of the variable specified by ITEM will be inserted into */
/* the output string. */
/* 5) If the continuation character is blank, then a blank component */
/* of a variable is treated as a component with no letters. */
/* For example: */
/* STRINGS = ( 'This is a variable' */
/* 'with a blank' */
/* ' ' */
/* 'component.' ) */
/* Is equivalent to */
/* STRINGS = ( 'This is a variable' */
/* 'with a blank' */
/* 'component.' ) */
/* from the point of view of SEPOOL if CONTIN is set to the */
/* blank character. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The SPICE Kernel Pool provides a very convenient interface */
/* for supplying both numeric and textual data to user application */
/* programs. However, any particular component of a character */
/* valued component of a kernel pool variable is limited to 80 */
/* or fewer characters in length. */
/* This routine allows you to overcome this limitation by */
/* "continuing" a character component of a kernel pool variable. */
/* To do this you need to select a continuation sequence */
/* of characters and then insert this sequence as the last non-blank */
/* set of characters that make up the portion of the component */
/* that should be continued. */
/* For example, you may decide to use the sequence '//' to indicate */
/* that a string should be continued to the next component of */
/* a kernel pool variable. Then set up the */
/* kernel pool variable as shown below */
/* LONG_STRINGS = ( 'This is part of the first component //' */
/* 'that needs more than one line when //' */
/* 'inserting it into the kernel pool.' */
/* 'This is the second string that is split //' */
/* 'up as several components of a kernel pool //' */
/* 'variable.' ) */
/* When loaded into the kernel pool, the variable LONG_STRINGS */
/* will have six literal components: */
/* COMPONENT (1) = 'This is part of the first component //' */
/* COMPONENT (2) = 'that needs more than one line when //' */
/* COMPONENT (3) = 'inserting it into the kernel pool.' */
/* COMPONENT (4) = 'This is the second string that is split //' */
/* COMPONENT (5) = 'up as several components of a kernel pool //' */
/* COMPONENT (6) = 'variable.' */
/* These are the components that would be retrieved by the call */
/* CALL GCPOOL ( 'LONG_STRINGS', 1, 6, N, COMPONENT, FOUND ) */
/* However, using the routine SEPOOL you can view the variable */
/* LONG_STRINGS as having two long components. */
/* STRING (1) = 'This is part of the first component that ' */
/* . // 'needs more than one line when inserting ' */
/* . // 'it into the kernel pool. ' */
/* STRING (2) = 'This is the second string that is split ' */
/* . // 'up as several components of a kernel pool ' */
/* . // 'variable. ' */
/* These string components would be retrieved by the following two */
/* calls. */
/* FIDX = 1 */
/* CALL SEPOOL ( 'LONG_STRINGS', FIDX, '//', */
/* . STRING(1), SIZE, LIDX, FOUND ) */
/* FIDX = LIDX+1 */
/* CALL SEPOOL ( 'LONG_STRINGS', FIDX, '//', */
/* . STRING(2), SIZE, LIDX, FOUND ) */
/* $ Examples */
/* Example 1. Retrieving file names. */
/* Suppose a you have used the kernel pool as a mechanism for */
/* specifying SPK files to load at startup but that the full */
/* names of the files are too long to be contained in a single */
/* text line of a kernel pool assignment. */
/* By selecting an appropriate continuation character ('*' for */
/* example) you can insert the full names of the SPK files */
/* into the kernel pool and then retrieve them using this */
/* routine. */
/* First set up the kernel pool specification of the strings */
/* as shown here: */
/* SPK_FILES = ( 'this_is_the_full_path_specification_*' */
/* 'of_a_file_with_a_long_name' */
/* 'this_is_the_full_path_specification_*' */
/* 'of_a_second_file_with_a_very_long_*' */
/* 'name' ) */
/* Now to retrieve and load the SPK_FILES one at a time, */
/* exercise the following loop. */
/* INTEGER FILSIZ */
/* PARAMETER ( FILSIZ = 255 ) */
/* CHARACTER*(FILSIZ) FILE */
/* INTEGER I */
/* INTEGER LIDX */
/* I = 1 */
/* CALL SEPOOL ( 'SPK_FILES', I, '*', FILE, SIZE, LIDX, FOUND ) */
/* DO WHILE ( FOUND .AND. RTRIM(FILE) .EQ. SIZE ) */
/* CALL SPKLEF ( FILE, HANDLE ) */
/* I = LIDX + 1 */
/* CALL SEPOOL ( 'SPK_FILES', I, '*', FILE, SIZE, LIDX, FOUND ) */
/* END DO */
/* IF ( FOUND .AND. RTRIM(FILE) .NE. SIZE ) THEN */
/* WRITE (*,*) 'The ', I, '''th file name was too long.' */
/* END IF */
/* Example 2. Retrieving all components as a string. */
/* Occasionally, it may be useful to retrieve the entire */
/* contents of a kernel pool variable as a single string. To */
/* do this you can use the blank character as the */
/* continuation character. For example if you place the */
/* following assignment in a text kernel */
/* COMMENT = ( 'This is a long note ' */
/* ' about the intended ' */
/* ' use of this text kernel that ' */
/* ' can be retrieved at run time.' ) */
/* you can retrieve COMMENT as single string via the call below. */
/* CALL SEPOOL ( 'COMMENT', 1, ' ', COMMNT, SIZE, LIDX, FOUND ) */
/* The result will be that COMMNT will have the following value. */
/* COMMNT = 'This is a long note about the intended use of ' */
/* . // 'this text kernel that can be retrieved at run ' */
/* . // 'time. ' */
/* Note that the leading blanks of each component of COMMENT are */
/* significant, trailing blanks are not significant. */
/* If COMMENT had been set as */
/* COMMENT = ( 'This is a long note ' */
/* 'about the intended ' */
/* 'use of this text kernel that ' */
/* 'can be retrieved at run time.' ) */
/* Then the call to SEPOOL above would have resulted in several */
/* words being run together as shown below. */
/* COMMNT = 'This is a long noteabout the intendeduse of ' */
/* . // 'this text kernel thatcan be retrieved at run ' */
/* . // 'time. ' */
/* resulted in several words being run together as shown below. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 12-APR-2012 (WLT)(BVS) */
/* -& */
/* $ Index_Entries */
/* Retrieve a continued string value from the kernel pool */
/* -& */
/* SPICELIB Variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
/* Return empty output if the input index is bad. */
if (*fidx < 1) {
*found = FALSE_;
s_copy(string, " ", string_len, (ftnlen)1);
*size = 0;
*lidx = 0;
return 0;
}
/* Check in. */
chkin_("SEPOOL", (ftnlen)6);
/* Check if the first component exists. Return empty output if not. */
gcpool_(item, fidx, &c__1, &n, part, &gotit, item_len, (ftnlen)80);
gotit = gotit && n > 0;
if (! gotit) {
*found = FALSE_;
s_copy(string, " ", string_len, (ftnlen)1);
*size = 0;
*lidx = 0;
chkout_("SEPOOL", (ftnlen)6);
return 0;
}
/* Fetch the string using Bill's algorithm from STPOOL 'as is'. */
room = i_len(string, string_len);
csize = rtrim_(contin, contin_len);
putat = 1;
comp = *fidx;
more = TRUE_;
s_copy(string, " ", string_len, (ftnlen)1);
n = 0;
while(more) {
gcpool_(item, &comp, &c__1, &n, part, &more, item_len, (ftnlen)80);
more = more && n > 0;
if (more) {
*found = TRUE_;
clast = rtrim_(part, (ftnlen)80);
cfirst = clast - csize + 1;
if (cfirst < 0) {
if (putat <= room) {
s_copy(string + (putat - 1), part, string_len - (putat -
1), clast);
}
putat += clast;
more = FALSE_;
} else if (s_cmp(part + (cfirst - 1), contin, clast - (cfirst - 1)
, contin_len) != 0) {
if (putat <= room) {
s_copy(string + (putat - 1), part, string_len - (putat -
1), clast);
}
putat += clast;
more = FALSE_;
} else if (cfirst > 1) {
if (putat <= room) {
s_copy(string + (putat - 1), part, string_len - (putat -
1), cfirst - 1);
}
putat = putat + cfirst - 1;
}
}
++comp;
}
/* We are done. Get the size of the full string and the index of its */
/* last component and checkout. */
*size = putat - 1;
*lidx = comp - 1;
chkout_("SEPOOL", (ftnlen)6);
return 0;
} /* sepool_ */
/* $Procedure TKFRAM (Text kernel frame transformation ) */
/* Subroutine */ int tkfram_(integer *id, doublereal *rot, integer *frame,
logical *found)
{
/* Initialized data */
static integer at = 0;
static logical first = TRUE_;
/* System generated locals */
address a__1[2];
integer i__1, i__2[2], i__3;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static char name__[32];
static integer tail;
static char spec[32], item[32*14];
static integer idnt[1], axes[3];
static logical full;
static integer pool[52] /* was [2][26] */;
extern doublereal vdot_(doublereal *, doublereal *);
static char type__[1];
static doublereal qtmp[4];
extern /* Subroutine */ int eul2m_(doublereal *, doublereal *, doublereal
*, integer *, integer *, integer *, doublereal *);
static integer i__, n, r__;
static doublereal buffd[180] /* was [9][20] */;
static integer buffi[20] /* was [1][20] */, oldid;
extern /* Subroutine */ int chkin_(char *, ftnlen);
static char agent[32];
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen),
ident_(doublereal *), errch_(char *, char *, ftnlen, ftnlen);
static doublereal tempd;
extern /* Subroutine */ int moved_(doublereal *, integer *, doublereal *),
repmi_(char *, char *, integer *, char *, ftnlen, ftnlen, ftnlen)
, vhatg_(doublereal *, integer *, doublereal *);
extern integer lnktl_(integer *, integer *);
static char idstr[32];
extern integer rtrim_(char *, ftnlen);
static char versn[8], units[32];
static integer ar;
extern logical failed_(void), badkpv_(char *, char *, char *, integer *,
integer *, char *, ftnlen, ftnlen, ftnlen, ftnlen);
static char frname[32];
static doublereal angles[3];
static char oldagt[32];
static logical buffrd;
extern /* Subroutine */ int locati_(integer *, integer *, integer *,
integer *, integer *, logical *), frmnam_(integer *, char *,
ftnlen), namfrm_(char *, integer *, ftnlen);
static logical update;
static char altnat[32];
extern /* Subroutine */ int lnkini_(integer *, integer *);
extern integer lnknfn_(integer *);
static integer idents[20] /* was [1][20] */;
extern /* Subroutine */ int gcpool_(char *, integer *, integer *, integer
*, char *, logical *, ftnlen, ftnlen), gdpool_(char *, integer *,
integer *, integer *, doublereal *, logical *, ftnlen), sigerr_(
char *, ftnlen), gipool_(char *, integer *, integer *, integer *,
integer *, logical *, ftnlen), chkout_(char *, ftnlen), sharpr_(
doublereal *), dtpool_(char *, logical *, integer *, char *,
ftnlen, ftnlen), setmsg_(char *, ftnlen);
static doublereal matrix[9] /* was [3][3] */;
extern /* Subroutine */ int cvpool_(char *, logical *, ftnlen), dwpool_(
char *, ftnlen), errint_(char *, integer *, ftnlen), vsclip_(
doublereal *, doublereal *);
static doublereal quatrn[4];
extern /* Subroutine */ int convrt_(doublereal *, char *, char *,
doublereal *, ftnlen, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int q2m_(doublereal *, doublereal *), intstr_(
integer *, char *, ftnlen), swpool_(char *, integer *, char *,
ftnlen, ftnlen);
static logical fnd;
static char alt[32*14];
/* $ Abstract */
/* This routine returns the rotation from the input frame */
/* specified by ID to the associated frame given by FRAME. */
/* $ 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 */
/* FRAMES */
/* $ Keywords */
/* POINTING */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- ---------------------------------------------- */
/* ID I Class identification code for the instrument */
/* ROT O The rotation from ID to FRAME. */
/* FRAME O The integer code of some reference frame. */
/* FOUND O TRUE if the rotation could be determined. */
/* $ Detailed_Input */
/* ID The identification code used to specify an */
/* instrument in the SPICE system. */
/* $ Detailed_Output */
/* ROT is a rotation matrix that gives the transformation */
/* from the frame specified by ID to the frame */
/* specified by FRAME. */
/* FRAME is the id code of the frame used to define the */
/* orientation of the frame given by ID. ROT gives */
/* the transformation from the IF frame to */
/* the frame specified by FRAME. */
/* FOUND is a logical indicating whether or not a frame */
/* definition for frame ID was constructed from */
/* kernel pool data. If ROT and FRAME were constructed */
/* FOUND will be returned with the value TRUE. */
/* Otherwise it will be returned with the value FALSE. */
/* $ Parameters */
/* BUFSIZ is the number of rotation, frame id pairs that */
/* can have their instance data buffered for the */
/* sake of improving run-time performance. This */
/* value MUST be positive and should probably be */
/* at least 10. */
/* $ Exceptions */
/* 1) If some instance value associated with this frame */
/* cannot be located, or does not have the proper type */
/* or dimension, the error will be diagnosed by the */
/* routine BADKPV. In such a case FOUND will be set to .FALSE. */
/* 2) If the input ID has the value 0, the error */
/* SPICE(ZEROFRAMEID) will be signaled. FOUND will be set */
/* to FALSE. */
/* 3) If the name of the frame corresponding to ID cannot be */
/* determined, the error 'SPICE(INCOMPLETEFRAME)' is signaled. */
/* 4) If the frame given by ID is defined relative to a frame */
/* that is unrecognized, the error SPICE(BADFRAMESPEC) */
/* will be signaled. FOUND will be set to FALSE. */
/* 5) If the kernel pool specification for ID is not one of */
/* MATRIX, ANGLES, or QUATERNION, then the error */
/* SPICE(UNKNOWNFRAMESPEC) will be signaled. FOUND will be */
/* set to FALSE. */
/* $ Files */
/* This routine makes use of the loaded text kernels to */
/* determine the rotation from a constant offset frame */
/* to its defining frame. */
/* $ Particulars */
/* This routine is used to construct the rotation from some frame */
/* that is a constant rotation offset from some other reference */
/* frame. This rotation is derived from data stored in the kernel */
/* pool. */
/* It is considered to be an low level routine that */
/* will need to be called directly only by persons performing */
/* high volume processing. */
/* $ Examples */
/* This is intended to be used as a low level routine by */
/* the frame system software. However, you could use this */
/* routine to directly retrieve the rotation from an offset */
/* frame to its relative frame. One instance in which you */
/* might do this is if you have a properly specified topocentric */
/* frame for some site on earth and you wish to determine */
/* the geodetic latitude and longitude of the site. Here's how. */
/* Suppose the name of the topocentric frame is: 'MYTOPO'. */
/* First we get the id-code of the topocentric frame. */
/* CALL NAMFRM ( 'MYTOPO', FRCODE ) */
/* Next get the rotation from the topocentric frame to */
/* the bodyfixed frame. */
/* CALL TKFRAM ( FRCODE, ROT, FRAME, FOUND ) */
/* Make sure the topoframe is relative to one of the earth */
/* fixed frames. */
/* CALL FRMNAM( FRAME, TEST ) */
/* IF ( TEST .NE. 'IAU_EARTH' */
/* . .AND. TEST .NE. 'EARTH_FIXED' */
/* . .AND. TEST .NE. 'ITRF93' ) THEN */
/* WRITE (*,*) 'The frame MYTOPO does not appear to be ' */
/* WRITE (*,*) 'defined relative to an earth fixed frame.' */
/* STOP */
/* END IF */
/* Things look ok. Get the location of the Z-axis in the */
/* topocentric frame. */
/* Z(1) = ROT(1,3) */
/* Z(2) = ROT(2,3) */
/* Z(3) = ROT(3,3) */
/* Convert the Z vector to latitude longitude and radius. */
/* CALL RECLAT ( Z, LAT, LONG, RAD ) */
/* WRITE (*,*) 'The geodetic coordinates of the center of' */
/* WRITE (*,*) 'the topographic frame are: ' */
/* WRITE (*,*) */
/* WRITE (*,*) 'Latitude (deg): ', LAT *DPR() */
/* WRITE (*,*) 'Longitude (deg): ', LONG*DPR() */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 2.1.0, 23-APR-2009 (NJB) */
/* Bug fix: watch is deleted only for frames */
/* that are deleted from the buffer. */
/* - SPICELIB Version 2.0.0, 19-MAR-2009 (NJB) */
/* Bug fix: this routine now deletes watches set on */
/* kernel variables of frames that are discarded from */
/* the local buffering system. */
/* - SPICELIB Version 1.2.0, 09-SEP-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in CONVRT, UCRSS, VHATG and VSCL calls. */
/* - SPICELIB Version 1.1.0, 21-NOV-2001 (FST) */
/* Updated this routine to dump the buffer of frame ID codes */
/* it saves when it or one of the modules in its call tree signals */
/* an error. This fixes a bug where a frame's ID code is */
/* buffered, but the matrix and kernel pool watcher were not set */
/* properly. */
/* - SPICELIB Version 1.0.0, 18-NOV-1996 (WLT) */
/* -& */
/* $ Index_Entries */
/* Fetch the rotation and frame of a text kernel frame */
/* Fetch the rotation and frame of a constant offset frame */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.2.0, 09-SEP-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in CONVRT, UCRSS, VHATG and VSCL calls. */
/* -& */
/* Spicelib Functions */
/* Local Parameters */
/* Local Variables */
/* Saved variables */
/* Initial values */
/* Programmer's note: this routine makes use of the *implementation* */
/* of LOCATI. If that routine is changed, the logic this routine */
/* uses to locate buffered, old frame IDs may need to change as well. */
/* Before we even check in, if N is less than 1 we can */
/* just return. */
/* Perform any initializations that might be needed for this */
/* routine. */
if (first) {
first = FALSE_;
s_copy(versn, "1.0.0", (ftnlen)8, (ftnlen)5);
lnkini_(&c__20, pool);
}
/* Now do the standard SPICE error handling. Sure this is */
/* a bit unconventional, but nothing will be hurt by doing */
/* the stuff above first. */
if (return_()) {
return 0;
}
chkin_("TKFRAM", (ftnlen)6);
/* So far, we've not FOUND the rotation to the specified frame. */
*found = FALSE_;
/* Check the ID to make sure it is non-zero. */
if (*id == 0) {
lnkini_(&c__20, pool);
setmsg_("Frame identification codes are required to be non-zero. Yo"
"u've specified a frame with ID value zero. ", (ftnlen)102);
sigerr_("SPICE(ZEROFRAMEID)", (ftnlen)18);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* Find out whether our linked list pool is already full. */
/* We'll use this information later to decide whether we're */
/* going to have to delete a watcher. */
full = lnknfn_(pool) == 0;
if (full) {
/* If the input frame ID is not buffered, we'll need to */
/* overwrite an existing buffer entry. In this case */
/* the call to LOCATI we're about to make will overwrite */
/* the ID code in the slot we're about to use. We need */
/* this ID code, so extract it now while we have the */
/* opportunity. The old ID sits at the tail of the list */
/* whose head node is AT. */
tail = lnktl_(&at, pool);
oldid = idents[(i__1 = tail - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge(
"idents", i__1, "tkfram_", (ftnlen)413)];
/* Create the name of the agent associated with the old */
/* frame. */
s_copy(oldagt, "TKFRAME_#", (ftnlen)32, (ftnlen)9);
repmi_(oldagt, "#", &oldid, oldagt, (ftnlen)32, (ftnlen)1, (ftnlen)32)
;
}
/* Look up the address of the instance data. */
idnt[0] = *id;
locati_(idnt, &c__1, idents, pool, &at, &buffrd);
if (full && ! buffrd) {
/* Since the buffer is already full, we'll delete the watcher for */
/* the kernel variables associated with OLDID, since there's no */
/* longer a need for that watcher. */
/* First clear the update status of the old agent; DWPOOL won't */
/* delete an agent with a unchecked update. */
cvpool_(oldagt, &update, (ftnlen)32);
dwpool_(oldagt, (ftnlen)32);
}
/* Until we have better information we put the identity matrix */
/* into the output rotation and set FRAME to zero. */
ident_(rot);
*frame = 0;
/* If we have to look up the data for our frame, we do */
/* it now and perform any conversions and computations that */
/* will be needed when it's time to convert coordinates to */
/* directions. */
/* Construct the name of the agent associated with the */
/* requested frame. (Each frame has its own agent). */
intstr_(id, idstr, (ftnlen)32);
frmnam_(id, frname, (ftnlen)32);
if (s_cmp(frname, " ", (ftnlen)32, (ftnlen)1) == 0) {
lnkini_(&c__20, pool);
setmsg_("The Text Kernel (TK) frame with id-code # does not have a r"
"ecognized name. ", (ftnlen)75);
errint_("#", id, (ftnlen)1);
sigerr_("SPICE(INCOMPLETFRAME)", (ftnlen)21);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* Writing concatenation */
i__2[0] = 8, a__1[0] = "TKFRAME_";
i__2[1] = 32, a__1[1] = idstr;
s_cat(agent, a__1, i__2, &c__2, (ftnlen)32);
r__ = rtrim_(agent, (ftnlen)32);
/* Writing concatenation */
i__2[0] = 8, a__1[0] = "TKFRAME_";
i__2[1] = 32, a__1[1] = frname;
s_cat(altnat, a__1, i__2, &c__2, (ftnlen)32);
ar = rtrim_(altnat, (ftnlen)32);
/* If the frame is buffered, we check the kernel pool to */
/* see if there has been an update to this frame. */
if (buffrd) {
cvpool_(agent, &update, r__);
} else {
/* If the frame is not buffered we definitely need to update */
/* things. */
update = TRUE_;
}
if (! update) {
/* Just look up the rotation matrix and relative-to */
/* information from the local buffer. */
rot[0] = buffd[(i__1 = at * 9 - 9) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)506)];
rot[1] = buffd[(i__1 = at * 9 - 8) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)507)];
rot[2] = buffd[(i__1 = at * 9 - 7) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)508)];
rot[3] = buffd[(i__1 = at * 9 - 6) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)509)];
rot[4] = buffd[(i__1 = at * 9 - 5) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)510)];
rot[5] = buffd[(i__1 = at * 9 - 4) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)511)];
rot[6] = buffd[(i__1 = at * 9 - 3) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)512)];
rot[7] = buffd[(i__1 = at * 9 - 2) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)513)];
rot[8] = buffd[(i__1 = at * 9 - 1) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)514)];
*frame = buffi[(i__1 = at - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge(
"buffi", i__1, "tkfram_", (ftnlen)516)];
} else {
/* Determine how the frame is specified and what it */
/* is relative to. The variables that specify */
/* how the frame is represented and what it is relative to */
/* are TKFRAME_#_SPEC and TKFRAME_#_RELATIVE where # is */
/* replaced by the text value of ID or the frame name. */
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 5, a__1[1] = "_SPEC";
s_cat(item, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 9, a__1[1] = "_RELATIVE";
s_cat(item + 32, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 5, a__1[1] = "_SPEC";
s_cat(alt, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 9, a__1[1] = "_RELATIVE";
s_cat(alt + 32, a__1, i__2, &c__2, (ftnlen)32);
/* See if the friendlier version of the kernel pool variables */
/* are available. */
for (i__ = 1; i__ <= 2; ++i__) {
dtpool_(alt + (((i__1 = i__ - 1) < 14 && 0 <= i__1 ? i__1 :
s_rnge("alt", i__1, "tkfram_", (ftnlen)537)) << 5), found,
&n, type__, (ftnlen)32, (ftnlen)1);
if (*found) {
s_copy(item + (((i__1 = i__ - 1) < 14 && 0 <= i__1 ? i__1 :
s_rnge("item", i__1, "tkfram_", (ftnlen)540)) << 5),
alt + (((i__3 = i__ - 1) < 14 && 0 <= i__3 ? i__3 :
s_rnge("alt", i__3, "tkfram_", (ftnlen)540)) << 5), (
ftnlen)32, (ftnlen)32);
}
}
/* If either the SPEC or RELATIVE frame are missing from */
/* the kernel pool, we simply return. */
if (badkpv_("TKFRAM", item, "=", &c__1, &c__1, "C", (ftnlen)6, (
ftnlen)32, (ftnlen)1, (ftnlen)1) || badkpv_("TKFRAM", item +
32, "=", &c__1, &c__1, "C", (ftnlen)6, (ftnlen)32, (ftnlen)1,
(ftnlen)1)) {
lnkini_(&c__20, pool);
*frame = 0;
ident_(rot);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* If we make it this far, look up the SPEC and RELATIVE frame. */
gcpool_(item, &c__1, &c__1, &n, spec, &fnd, (ftnlen)32, (ftnlen)32);
gcpool_(item + 32, &c__1, &c__1, &n, name__, &fnd, (ftnlen)32, (
ftnlen)32);
/* Look up the id-code for this frame. */
namfrm_(name__, frame, (ftnlen)32);
if (*frame == 0) {
lnkini_(&c__20, pool);
setmsg_("The frame to which frame # is relatively defined is not"
" recognized. The kernel pool specification of the relati"
"ve frame is '#'. This is not a recognized frame. ", (
ftnlen)161);
errint_("#", id, (ftnlen)1);
errch_("#", name__, (ftnlen)1, (ftnlen)32);
sigerr_("SPICE(BADFRAMESPEC)", (ftnlen)19);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* Convert SPEC to upper case so that we can easily check */
/* to see if this is one of the expected specification types. */
ucase_(spec, spec, (ftnlen)32, (ftnlen)32);
if (s_cmp(spec, "MATRIX", (ftnlen)32, (ftnlen)6) == 0) {
/* This is the easiest case. Just grab the matrix */
/* from the kernel pool (and polish it up a bit just */
/* to make sure we have a rotation matrix). */
/* We give preference to the kernel pool variable */
/* TKFRAME_<name>_MATRIX if it is available. */
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 7, a__1[1] = "_MATRIX";
s_cat(item + 64, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 7, a__1[1] = "_MATRIX";
s_cat(alt + 64, a__1, i__2, &c__2, (ftnlen)32);
dtpool_(alt + 64, found, &n, type__, (ftnlen)32, (ftnlen)1);
if (*found) {
s_copy(item + 64, alt + 64, (ftnlen)32, (ftnlen)32);
}
if (badkpv_("TKFRAM", item + 64, "=", &c__9, &c__1, "N", (ftnlen)
6, (ftnlen)32, (ftnlen)1, (ftnlen)1)) {
lnkini_(&c__20, pool);
*frame = 0;
ident_(rot);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* The variable meets current expectations, look it up */
/* from the kernel pool. */
gdpool_(item + 64, &c__1, &c__9, &n, matrix, &fnd, (ftnlen)32);
/* In this case the full transformation matrix has been */
/* specified. We simply polish it up a bit. */
moved_(matrix, &c__9, rot);
sharpr_(rot);
/* The matrix might not be right-handed, so correct */
/* the sense of the second and third columns if necessary. */
if (vdot_(&rot[3], &matrix[3]) < 0.) {
vsclip_(&c_b95, &rot[3]);
}
if (vdot_(&rot[6], &matrix[6]) < 0.) {
vsclip_(&c_b95, &rot[6]);
}
} else if (s_cmp(spec, "ANGLES", (ftnlen)32, (ftnlen)6) == 0) {
/* Look up the angles, their units and axes for the */
/* frame specified by ID. (Note that UNITS are optional). */
/* As in the previous case we give preference to the */
/* form TKFRAME_<name>_<item> over TKFRAME_<id>_<item>. */
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 7, a__1[1] = "_ANGLES";
s_cat(item + 64, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 5, a__1[1] = "_AXES";
s_cat(item + 96, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 6, a__1[1] = "_UNITS";
s_cat(item + 128, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 7, a__1[1] = "_ANGLES";
s_cat(alt + 64, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 5, a__1[1] = "_AXES";
s_cat(alt + 96, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 6, a__1[1] = "_UNITS";
s_cat(alt + 128, a__1, i__2, &c__2, (ftnlen)32);
/* Again, we give preference to the more friendly form */
/* of TKFRAME specification. */
for (i__ = 3; i__ <= 5; ++i__) {
dtpool_(alt + (((i__1 = i__ - 1) < 14 && 0 <= i__1 ? i__1 :
s_rnge("alt", i__1, "tkfram_", (ftnlen)668)) << 5),
found, &n, type__, (ftnlen)32, (ftnlen)1);
if (*found) {
s_copy(item + (((i__1 = i__ - 1) < 14 && 0 <= i__1 ? i__1
: s_rnge("item", i__1, "tkfram_", (ftnlen)671)) <<
5), alt + (((i__3 = i__ - 1) < 14 && 0 <= i__3 ?
i__3 : s_rnge("alt", i__3, "tkfram_", (ftnlen)671)
) << 5), (ftnlen)32, (ftnlen)32);
}
}
if (badkpv_("TKFRAM", item + 64, "=", &c__3, &c__1, "N", (ftnlen)
6, (ftnlen)32, (ftnlen)1, (ftnlen)1) || badkpv_("TKFRAM",
item + 96, "=", &c__3, &c__1, "N", (ftnlen)6, (ftnlen)32,
(ftnlen)1, (ftnlen)1)) {
lnkini_(&c__20, pool);
*frame = 0;
ident_(rot);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
s_copy(units, "RADIANS", (ftnlen)32, (ftnlen)7);
gdpool_(item + 64, &c__1, &c__3, &n, angles, &fnd, (ftnlen)32);
gipool_(item + 96, &c__1, &c__3, &n, axes, &fnd, (ftnlen)32);
gcpool_(item + 128, &c__1, &c__1, &n, units, &fnd, (ftnlen)32, (
ftnlen)32);
/* Convert angles to radians. */
for (i__ = 1; i__ <= 3; ++i__) {
convrt_(&angles[(i__1 = i__ - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("angles", i__1, "tkfram_", (ftnlen)700)],
units, "RADIANS", &tempd, (ftnlen)32, (ftnlen)7);
angles[(i__1 = i__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
"angles", i__1, "tkfram_", (ftnlen)701)] = tempd;
}
if (failed_()) {
lnkini_(&c__20, pool);
*frame = 0;
ident_(rot);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* Compute the rotation from instrument frame to CK frame. */
eul2m_(angles, &angles[1], &angles[2], axes, &axes[1], &axes[2],
rot);
} else if (s_cmp(spec, "QUATERNION", (ftnlen)32, (ftnlen)10) == 0) {
/* Look up the quaternion and convert it to a rotation */
/* matrix. Again there are two possible variables that */
/* may point to the quaternion. We give preference to */
/* the form TKFRAME_<name>_Q over the form TKFRAME_<id>_Q. */
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 2, a__1[1] = "_Q";
s_cat(item + 64, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 2, a__1[1] = "_Q";
s_cat(alt + 64, a__1, i__2, &c__2, (ftnlen)32);
dtpool_(alt + 64, found, &n, type__, (ftnlen)32, (ftnlen)1);
if (*found) {
s_copy(item + 64, alt + 64, (ftnlen)32, (ftnlen)32);
}
if (badkpv_("TKFRAM", item + 64, "=", &c__4, &c__1, "N", (ftnlen)
6, (ftnlen)32, (ftnlen)1, (ftnlen)1)) {
lnkini_(&c__20, pool);
*frame = 0;
ident_(rot);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* In this case we have the quaternion representation. */
/* Again, we do a small amount of polishing of the input. */
gdpool_(item + 64, &c__1, &c__4, &n, quatrn, &fnd, (ftnlen)32);
vhatg_(quatrn, &c__4, qtmp);
q2m_(qtmp, rot);
} else {
/* We don't recognize the SPEC for this frame. Say */
/* so. Also note that perhaps the user needs to upgrade */
/* the toolkit. */
lnkini_(&c__20, pool);
setmsg_("The frame specification \"# = '#'\" is not one of the r"
"econized means of specifying a text-kernel constant offs"
"et frame (as of version # of the routine TKFRAM). This m"
"ay reflect a typographical error or may indicate that yo"
"u need to consider updating your version of the SPICE to"
"olkit. ", (ftnlen)284);
errch_("#", item, (ftnlen)1, (ftnlen)32);
errch_("#", spec, (ftnlen)1, (ftnlen)32);
errch_("#", versn, (ftnlen)1, (ftnlen)8);
sigerr_("SPICE(UNKNOWNFRAMESPEC)", (ftnlen)23);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* Buffer the identifier, relative frame and rotation matrix. */
buffd[(i__1 = at * 9 - 9) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)784)] = rot[0];
buffd[(i__1 = at * 9 - 8) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)785)] = rot[1];
buffd[(i__1 = at * 9 - 7) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)786)] = rot[2];
buffd[(i__1 = at * 9 - 6) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)787)] = rot[3];
buffd[(i__1 = at * 9 - 5) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)788)] = rot[4];
buffd[(i__1 = at * 9 - 4) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)789)] = rot[5];
buffd[(i__1 = at * 9 - 3) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)790)] = rot[6];
buffd[(i__1 = at * 9 - 2) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)791)] = rot[7];
buffd[(i__1 = at * 9 - 1) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)792)] = rot[8];
buffi[(i__1 = at - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge("buffi", i__1,
"tkfram_", (ftnlen)794)] = *frame;
/* If these were not previously buffered, we need to set */
/* a watch on the various items that might be used to define */
/* this frame. */
if (! buffrd) {
/* Immediately check for an update so that we will */
/* not redundantly look for this item the next time this */
/* routine is called. */
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 9, a__1[1] = "_RELATIVE";
s_cat(item, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 5, a__1[1] = "_SPEC";
s_cat(item + 32, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 5, a__1[1] = "_AXES";
s_cat(item + 64, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 7, a__1[1] = "_MATRIX";
s_cat(item + 96, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 2, a__1[1] = "_Q";
s_cat(item + 128, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 7, a__1[1] = "_ANGLES";
s_cat(item + 160, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 6, a__1[1] = "_UNITS";
s_cat(item + 192, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 9, a__1[1] = "_RELATIVE";
s_cat(item + 224, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 5, a__1[1] = "_SPEC";
s_cat(item + 256, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 5, a__1[1] = "_AXES";
s_cat(item + 288, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 7, a__1[1] = "_MATRIX";
s_cat(item + 320, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 2, a__1[1] = "_Q";
s_cat(item + 352, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 7, a__1[1] = "_ANGLES";
s_cat(item + 384, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 6, a__1[1] = "_UNITS";
s_cat(item + 416, a__1, i__2, &c__2, (ftnlen)32);
swpool_(agent, &c__14, item, (ftnlen)32, (ftnlen)32);
cvpool_(agent, &update, (ftnlen)32);
}
}
if (failed_()) {
lnkini_(&c__20, pool);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* All errors cause the routine to exit before we get to this */
/* point. If we reach this point we didn't have an error and */
/* hence did find the rotation from ID to FRAME. */
*found = TRUE_;
/* That's it */
chkout_("TKFRAM", (ftnlen)6);
return 0;
} /* tkfram_ */
/* $Procedure WRLINE ( Write Output Line to a Device ) */
/* Subroutine */ int wrline_0_(int n__, char *device, char *line, ftnlen
device_len, ftnlen line_len)
{
/* System generated locals */
integer i__1;
cilist ci__1;
olist o__1;
cllist cl__1;
inlist ioin__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
integer *, char *, ftnlen), e_wsfe(void), f_inqu(inlist *),
s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void), f_open(olist *);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer f_clos(cllist *);
/* Local variables */
integer unit;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
extern integer ltrim_(char *, ftnlen);
char error[240];
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
logical opened;
extern /* Subroutine */ int fndlun_(integer *);
char tmpnam[128];
integer iostat;
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen);
logical exists;
char errstr[11];
extern /* Subroutine */ int intstr_(integer *, char *, ftnlen);
/* Fortran I/O blocks */
static cilist io___6 = { 0, 6, 0, 0, 0 };
static cilist io___7 = { 0, 6, 0, 0, 0 };
static cilist io___8 = { 0, 6, 0, 0, 0 };
static cilist io___9 = { 0, 6, 0, 0, 0 };
static cilist io___10 = { 0, 6, 0, 0, 0 };
static cilist io___11 = { 0, 6, 0, 0, 0 };
static cilist io___12 = { 0, 6, 0, 0, 0 };
static cilist io___15 = { 0, 6, 0, 0, 0 };
static cilist io___16 = { 0, 6, 0, 0, 0 };
static cilist io___17 = { 0, 6, 0, 0, 0 };
static cilist io___18 = { 0, 6, 0, 0, 0 };
/* $ Abstract */
/* Write a character string to an output device. */
/* $ 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 */
/* TEXT */
/* FILES */
/* ERROR */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* DEVICE I A string specifying an output device. */
/* LINE I A line of text to be output. */
/* FILEN P Maximum length of a file name. */
/* $ Detailed_Input */
/* LINE is a line of text to be written to the output */
/* device specified by DEVICE. */
/* DEVICE is the output device to which the line of text */
/* will be written. */
/* Possible values and meanings of DEVICE are: */
/* a device name This may be the name of a */
/* file, or any other name that */
/* is valid in a FORTRAN OPEN */
/* statement. For example, on a */
/* VAX, a logical name may be */
/* used. */
/* The device name must not */
/* be any of the reserved strings */
/* below. */
/* 'SCREEN' The output will go to the */
/* terminal screen. */
/* 'NULL' The data will not be output. */
/* 'SCREEN' and 'NULL' can be written in mixed */
/* case. For example, the following call will work: */
/* CALL WRLINE ( 'screEn', LINE ) */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* FILEN is the maximum length of a file name. */
/* $ Exceptions */
/* This routine is a special case as far as error handling */
/* is concerned because it is called to output error */
/* messages resulting from errors detected by other routines. */
/* In such a case, calling SIGERR would constitute recursion. */
/* Therefore, this routine prints error messages rather */
/* than signalling errors via SIGERR and setting the long */
/* error message via SETMSG. */
/* The following exceptional cases are treated as errors: */
/* 1) SPICE(NOFREELOGICALUNIT) -- No logical unit number */
/* is available to refer to the device. */
/* 2) SPICE(FILEOPENFAILED) -- General file open error. */
/* 3) SPICE(FILEWRITEFAILED) -- General file write error. */
/* 4) SPICE(INQUIREFAILED) -- INQUIRE statement failed. */
/* 5) Leading blanks in (non-blank) file names are not */
/* significant. The file names */
/* 'MYFILE.DAT' */
/* ' MYFILE.DAT' */
/* are considered to name the same file. */
/* 6) If different names that indicate the same file are supplied */
/* to this routine on different calls, all output associated */
/* with these calls WILL be written to the file. For example, */
/* on a system where logical filenames are supported, if */
/* ALIAS is a logical name pointing to MYFILE, then the calls */
/* CALL WRLINE ( 'MYFILE', 'This is the first line' ) */
/* CALL WRLINE ( 'ALIAS', 'This is the second line' ) */
/* will place the lines of text */
/* 'This is the first line' */
/* 'This is the second line' */
/* in MYFILE. See $Restrictions for more information on use */
/* of logical names on VAX systems. */
/* $ Files */
/* 1) If DEVICE specifies a device other than 'SCREEN' or 'NULL', */
/* that device is opened (if it's not already open) as a NEW, */
/* SEQUENTIAL, FORMATTED file. The logical unit used is */
/* determined at run time. */
/* $ Particulars */
/* If the output device is a file that is not open, the file will */
/* be opened (if possible) as a NEW, sequential, formatted file, */
/* and the line of text will be written to the file. If the file */
/* is already opened as a sequential, formatted file, the line of */
/* text will be written to the file. */
/* Use the entry point CLLINE to close files opened by WRLINE. */
/* $ Examples */
/* 1) Write a message to the screen: */
/* CALL WRLINE ( 'SCREEN', 'Here''s a message.' ) */
/* The text */
/* Here's a message. */
/* will be written to the screen. */
/* 2) Write out all of the elements of a character string array */
/* to a file. */
/* CHARACTER*(80) STRING ( ASIZE ) */
/* . */
/* . */
/* . */
/* DO I = 1, ASIZE */
/* CALL WRLINE ( FILE, STRING(I) ) */
/* END DO */
/* 3) Set DEVICE to NULL to suppress output: */
/* C */
/* C Ask the user whether verbose program output is */
/* C desired. Set the output device accordingly. */
/* C */
/* WRITE (*,*) 'Do you want to see test results ' // */
/* . 'on the screen?' */
/* READ (*,FMT='(A)') VERBOS */
/* CALL LJUST ( VERBOS, VERBOS ) */
/* CALL UCASE ( VERBOS, VERBOS ) */
/* IF ( VERBOS(1:1) .EQ. 'Y' ) THEN */
/* DEVICE = 'SCREEN' */
/* ELSE */
/* DEVICE = 'NULL' */
/* ENDIF */
/* . */
/* . */
/* . */
/* C */
/* C Output test results. */
/* C */
/* CALL WRLINE ( DEVICE, STRING ) */
/* . */
/* . */
/* . */
/* $ Restrictions */
/* 1) File names must not exceed FILEN characters. */
/* 2) On VAX systems, caution should be exercised when using */
/* multiple logical names to point to the same file. Logical */
/* name translation supporting execution of the Fortran */
/* INQUIRE statement does not appear to work reliably in all */
/* cases, which may lead this routine to believe that different */
/* logical names indicate different files. The specific problem */
/* that has been observed is that logical names that include */
/* disk specifications are not always recognized as pointing */
/* to the file they actually name. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* $ Version */
/* - SPICELIB Version 4.25.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 4.24.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 4.23.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 4.22.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.21.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 4.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 4.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 4.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 4.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 4.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 4.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 4.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 4.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 4.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 4.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 4.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 4.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 4.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 4.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 4.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 4.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 4.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 4.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 4.0.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 4.0.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 4.0.3, 16-SEP-1999 (NJB) */
/* CSPICE environments were added. Some typos were corrected. */
/* - SPICELIB Version 4.0.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 4.0.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 4.0.0, 07-APR-1998 (NJB) */
/* References to the PC-LINUX environment were added. The */
/* write format for the case where the output device is the */
/* screen has been made system-dependent; list-directed output */
/* format is now used for systems that require a leading carriage */
/* control character; other systems use character format. The */
/* write format for the case where the output device is a file */
/* has been changed from list-directed to character. */
/* - SPICELIB Version 3.0.0, 11-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* and the appropriate OPEN statement for the Silicon */
/* Graphics, DEC Alpha-OSF/1, and NeXT platforms. The previous */
/* value of 256 for Unix platforms was changed to 255. */
/* - SPICELIB Version 2.1.0, 13-OCT-1992 (HAN) */
/* Module was updated to include the value of FILEN for the */
/* Hewlett Packard UX 9000/750 environment. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 2.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 2.0.0, 26-MAR-1991 (NJB) */
/* This routine now can write to files that have been opened */
/* by other routines. */
/* The limit imposed by this routine on the number of files it */
/* can open has been removed. */
/* The output file is now opened as a normal text file on */
/* VAX systems. */
/* Improper treatment of the case where DEVICE is blank was */
/* remedied. */
/* Unneeded variable declarations and references were removed. */
/* Initialization of SAVED variables was added. */
/* All occurrences of "PRINT *" have been replaced by */
/* "WRITE (*,*)". */
/* Calls to UCASE and LJUST replace in-line code that performed */
/* these operations. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (NJB) */
/* -& */
/* $ Index_Entries */
/* write output line to a device */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 4.0.0, 07-APR-1998 (NJB) */
/* References to the PC-LINUX environment were added. */
/* The write format for the case where the output device is the */
/* screen has been made system-dependent; list-directed output */
/* format is now used for systems that require a leading carriage */
/* control character; other systems use character format. The */
/* write format for the case where the output device is a file */
/* has been changed from list-directed to character. */
/* - SPICELIB Version 3.0.0, 11-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* and the appropriate OPEN statement for the Silicon */
/* Graphics, DEC Alpha-OSF/1, and NeXT platforms. The previous */
/* value of 256 for Unix platforms was changed to 255. */
/* - SPICELIB Version 2.1.0, 13-OCT-1992 (HAN) */
/* Module was updated to include the value of FILEN for the */
/* Hewlett Packard UX 9000/750 environment. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 2.0.0, 25-MAR-1991 (NJB) */
/* 1) This routine now can write to files that have been opened */
/* by other routines. WRLINE uses an INQUIRE statement to */
/* determine whether the file indicated by DEVICE is open, */
/* and if it is, WRLINE does not attempt to open it. This */
/* allows use of WRLINE to feed error output into a log file */
/* opened by another routine. */
/* The header has been updated accordingly. */
/* This fix also fixes a bug wherein this routine would treat */
/* different character strings naming the same file as though */
/* they indicated different files. */
/* 2) The limit imposed by this routine on the number of files it */
/* can open has been removed. The file database used in */
/* previous versions of this routine is no longer used. */
/* 3) On VAX systems, this routine now opens the output file */
/* (when required to do so) as a normal text file. */
/* 4) Improper treatment of the case where DEVICE is blank was */
/* remedied. Any value of DEVICE that is not equal to */
/* 'SCREEN' or 'NULL' after being left-justified and */
/* converted to upper case is considered to be a file name. */
/* 5) Unneeded variable declarations and references were removed. */
/* The arrays called STATUS and FILES are not needed. */
/* 6) All instances if "PRINT *" have been replaced by */
/* "WRITE (*,*)" because Language Systems Fortran on the */
/* Macintosh interprets "PRINT *" in a non-standard manner. */
/* 7) Use of the EXIST specifier was added to the INQUIRE */
/* statement used to determine whether the file named by */
/* DEVICE is open. This is a work-around for a rather */
/* peculiar behavior of at least one version of Sun Fortran: */
/* files that don't exist may be considered to be open, as */
/* indicated by the OPENED specifier of the INQUIRE statement. */
/* 8) One other thing: now that LJUST and UCASE are error-free, */
/* WRLINE uses them; this simplifies the code. */
/* - Beta Version 1.2.0, 27-FEB-1989 (NJB) */
/* Call to GETLUN replaced by call to FNDLUN, which is error-free. */
/* Call to IOERR replaced with in-line code to construct long */
/* error message indicating file open failure. Arrangement of */
/* declarations changed. Keywords added. FILEN declaration */
/* moved to "declarations" section. Parameters section added. */
/* - Beta Version 1.1.0, 06-OCT-1988 (NJB) */
/* Upper bound of written substring changed to prevent use of */
/* invalid substring bound. Specifically, LASTNB ( LINE ) was */
/* replaced by MAX ( 1, LASTNB (LINE) ). This upper bound */
/* now used in the PRINT statement as well. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Executable Code: */
switch(n__) {
case 1: goto L_clline;
}
ljust_(device, tmpnam, device_len, (ftnlen)128);
ucase_(tmpnam, tmpnam, (ftnlen)128, (ftnlen)128);
/* TMPNAM is now left justified and is in upper case. */
if (s_cmp(tmpnam, "NULL", (ftnlen)128, (ftnlen)4) == 0) {
return 0;
} else if (s_cmp(tmpnam, "SCREEN", (ftnlen)128, (ftnlen)6) == 0) {
ci__1.cierr = 1;
ci__1.ciunit = 6;
ci__1.cifmt = "(A)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
iostat = do_fio(&c__1, line, rtrim_(line, line_len));
if (iostat != 0) {
goto L100001;
}
iostat = e_wsfe();
L100001:
return 0;
}
/* Find out whether we'll need to open the file. */
/* We use the EXIST inquiry specifier because files that don't exist */
/* may be (possibly due to a Sun compiler bug) deemed to be OPEN by */
/* Sun Fortran. */
i__1 = ltrim_(device, device_len) - 1;
ioin__1.inerr = 1;
ioin__1.infilen = device_len - i__1;
ioin__1.infile = device + i__1;
ioin__1.inex = &exists;
ioin__1.inopen = &opened;
ioin__1.innum = &unit;
ioin__1.innamed = 0;
ioin__1.inname = 0;
ioin__1.inacc = 0;
ioin__1.inseq = 0;
ioin__1.indir = 0;
ioin__1.infmt = 0;
ioin__1.inform = 0;
ioin__1.inunf = 0;
ioin__1.inrecl = 0;
ioin__1.innrec = 0;
ioin__1.inblank = 0;
iostat = f_inqu(&ioin__1);
if (iostat != 0) {
/* This is weird. How can an INQUIRE statement fail, */
/* if the syntax is correct? But just in case... */
s_wsle(&io___6);
do_lio(&c__9, &c__1, "SPICE(INQUIREFAILED)", (ftnlen)20);
e_wsle();
s_wsle(&io___7);
do_lio(&c__9, &c__1, "WRLINE: File = ", (ftnlen)15);
do_lio(&c__9, &c__1, device, device_len);
do_lio(&c__9, &c__1, "IOSTAT = ", (ftnlen)9);
do_lio(&c__3, &c__1, (char *)&iostat, (ftnlen)sizeof(integer));
e_wsle();
return 0;
}
if (! (opened && exists)) {
/* We will need a free logical unit. There is always the chance */
/* that no units are available. */
fndlun_(&unit);
if (unit < 1) {
s_wsle(&io___8);
do_lio(&c__9, &c__1, "SPICE(NOFREELOGICALUNIT)", (ftnlen)24);
e_wsle();
s_wsle(&io___9);
do_lio(&c__9, &c__1, " ", (ftnlen)1);
e_wsle();
s_wsle(&io___10);
do_lio(&c__9, &c__1, "WRLINE: Maximum number of logical units th"
"at can be allocated by SPICELIB has already been reached",
(ftnlen)98);
e_wsle();
return 0;
}
/* Okay, we have a unit. Open the file, and hope nothing */
/* goes awry. (On the VAX, the qualifier */
/* CARRIAGECONTROL = 'LIST' */
/* may be inserted into the OPEN statement.) */
i__1 = ltrim_(device, device_len) - 1;
o__1.oerr = 1;
o__1.ounit = unit;
o__1.ofnmlen = device_len - i__1;
o__1.ofnm = device + i__1;
o__1.orl = 0;
o__1.osta = "NEW";
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
iostat = f_open(&o__1);
if (iostat != 0) {
s_wsle(&io___11);
do_lio(&c__9, &c__1, "SPICE(FILEOPENFAILED)", (ftnlen)21);
e_wsle();
s_wsle(&io___12);
do_lio(&c__9, &c__1, " ", (ftnlen)1);
e_wsle();
s_copy(error, "WRLINE: An error occurred while attempting to open"
, (ftnlen)240, (ftnlen)50);
suffix_(device, &c__1, error, device_len, (ftnlen)240);
suffix_(".", &c__0, error, (ftnlen)1, (ftnlen)240);
suffix_("The value of IOSTAT returned was", &c__2, error, (ftnlen)
32, (ftnlen)240);
suffix_(":", &c__0, error, (ftnlen)1, (ftnlen)240);
intstr_(&iostat, errstr, (ftnlen)11);
suffix_(errstr, &c__1, error, (ftnlen)11, (ftnlen)240);
suffix_(".", &c__0, error, (ftnlen)1, (ftnlen)240);
s_wsle(&io___15);
do_lio(&c__9, &c__1, error, (ftnlen)240);
e_wsle();
return 0;
}
/* Whew! We're ready to write to this file. */
}
/* At this point, either we opened the file, or it was already */
/* opened by somebody else. */
/* This is the easy part. Write the next line to the file. */
ci__1.cierr = 1;
ci__1.ciunit = unit;
ci__1.cifmt = "(A)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100002;
}
iostat = do_fio(&c__1, line, rtrim_(line, line_len));
if (iostat != 0) {
goto L100002;
}
iostat = e_wsfe();
L100002:
/* Well, what happened? Any non-zero value for IOSTAT indicates */
/* an error. */
if (iostat != 0) {
s_copy(error, "WRLINE: An error occurred while attempting to WRITE t"
"o ", (ftnlen)240, (ftnlen)55);
suffix_(device, &c__1, error, device_len, (ftnlen)240);
suffix_(".", &c__0, error, (ftnlen)1, (ftnlen)240);
suffix_("The value of IOSTAT returned was", &c__2, error, (ftnlen)32,
(ftnlen)240);
suffix_(":", &c__0, error, (ftnlen)1, (ftnlen)240);
intstr_(&iostat, errstr, (ftnlen)11);
suffix_(errstr, &c__1, error, (ftnlen)11, (ftnlen)240);
suffix_(".", &c__0, error, (ftnlen)1, (ftnlen)240);
s_wsle(&io___16);
do_lio(&c__9, &c__1, error, (ftnlen)240);
e_wsle();
return 0;
}
return 0;
/* $Procedure CLLINE ( Close a device ) */
L_clline:
/* $ Abstract */
/* Close a device. */
/* $ 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 */
/* TEXT, FILES, ERROR */
/* $ Declarations */
/* CHARACTER*(*) DEVICE */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* DEVICE I Device to be closed. */
/* $ Detailed_Input */
/* DEVICE is the name of a device which is currently */
/* opened for reading or writing. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* This routine is called by SPICELIB error handling routines, so */
/* it cannot use the normal SPICELIB error signalling mechanism. */
/* Instead, it writes error messages to the screen if necessary. */
/* 1) If the device indicated by DEVICE was not opened by WRLINE, */
/* this routine closes it anyway. */
/* 2) If the INQUIRE performed by this routine fails, an error */
/* diagnosis is printed to the screen. */
/* $ Files */
/* This routin */
/* $ Particulars */
/* CLLINE closes a device that is currently open. */
/* $ Examples */
/* 1) Write two lines to the file, SPUD.DAT (VAX file name */
/* syntax), and then close the file. */
/* CALL WRLINE ( 'SPUD.DAT', ' This is line 1 ' ) */
/* CALL WRLINE ( 'SPUD.DAT', ' This is line 2 ' ) */
/* CALL CLLINE ( 'SPUD.DAT' ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 4.0.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 4.0.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 4.0.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 4.0.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 2.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 2.0.0, 26-MAR-1991 (NJB) */
/* All occurrences of "PRINT *" have been replaced by */
/* "WRITE (*,*)". */
/* Also, this routine now closes the device named by DEVICE */
/* whether or not the device was opened by WRLINE. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (NJB) */
/* -& */
/* $ Index_Entries */
/* None. */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 26-MAR-1991 (NJB) */
/* All instances if "PRINT *" have been replaced by "WRITE (*,*)" */
/* because Language Systems Fortran on the Macintosh interprets */
/* "PRINT *" in a non-standard manner. */
/* This routine no longer has to maintain the file database, since */
/* WRLINE does not use it any more. */
/* Also, this routine now closes the device named by DEVICE, */
/* whether or not the device was opened by WRLINE. */
/* - Beta Version 1.0.1, 08-NOV-1988 (NJB) */
/* Keywords added. */
/* -& */
/* Find the unit connected to DEVICE. */
i__1 = ltrim_(device, device_len) - 1;
ioin__1.inerr = 1;
ioin__1.infilen = device_len - i__1;
ioin__1.infile = device + i__1;
ioin__1.inex = 0;
ioin__1.inopen = 0;
ioin__1.innum = &unit;
ioin__1.innamed = 0;
ioin__1.inname = 0;
ioin__1.inacc = 0;
ioin__1.inseq = 0;
ioin__1.indir = 0;
ioin__1.infmt = 0;
ioin__1.inform = 0;
ioin__1.inunf = 0;
ioin__1.inrecl = 0;
ioin__1.innrec = 0;
ioin__1.inblank = 0;
iostat = f_inqu(&ioin__1);
if (iostat != 0) {
/* This is weird. How can an INQUIRE statement fail, */
/* if the syntax is correct? But just in case... */
s_wsle(&io___17);
do_lio(&c__9, &c__1, "SPICE(INQUIREFAILED)", (ftnlen)20);
e_wsle();
s_wsle(&io___18);
do_lio(&c__9, &c__1, "CLLINE: File = ", (ftnlen)16);
do_lio(&c__9, &c__1, device, device_len);
do_lio(&c__9, &c__1, "IOSTAT = ", (ftnlen)9);
do_lio(&c__3, &c__1, (char *)&iostat, (ftnlen)sizeof(integer));
e_wsle();
return 0;
}
cl__1.cerr = 0;
cl__1.cunit = unit;
cl__1.csta = 0;
f_clos(&cl__1);
return 0;
} /* wrline_ */
/* $Procedure STRAN */
/* Subroutine */ int stran_0_(int n__, char *input, char *output, logical *
tran, ftnlen input_len, ftnlen output_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen), i_indx(char *, char *,
ftnlen, ftnlen), s_rnge(char *, integer, char *, integer), i_len(
char *, ftnlen);
/* Local variables */
static integer ldef, leno, vdim, slot, lout, lsym, ptrs[810], i__, j;
extern integer cardc_(char *, ftnlen);
static integer l, n;
static logical check[200];
extern logical batch_(void);
static integer place;
extern /* Subroutine */ int lcase_(char *, char *, ftnlen, ftnlen);
static char delim[1];
extern /* Subroutine */ int chkin_(char *, ftnlen);
static integer nname;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
static char names[32*206];
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen),
geteq_(char *, ftnlen);
extern integer ncpos_(char *, char *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int nthwd_(char *, integer *, char *, integer *,
ftnlen, ftnlen);
static char symbl[33];
static integer psize;
extern integer rtrim_(char *, ftnlen);
static logical checkd[200];
extern logical failed_(void);
static char alphab[32];
extern /* Subroutine */ int getdel_(char *, ftnlen);
extern logical matchm_(char *, char *, char *, char *, char *, char *,
ftnlen, ftnlen, ftnlen, ftnlen, ftnlen, ftnlen);
static char buffer[256*52];
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen),
lastnb_(char *, ftnlen);
static logical gotone;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), repsub_(char *, integer *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen);
static char equote[1];
extern /* Subroutine */ int setmsg_(char *, ftnlen);
static char resvrd[32*12], symbol[33], pattrn[80];
static integer nxtchr;
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen), rdstmn_(char *, char *, char *, ftnlen, ftnlen, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int sbget_1__(char *, char *, integer *, char *,
char *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), nthuqw_(char *
, integer *, char *, char *, integer *, ftnlen, ftnlen, ftnlen);
static char myprmt[80];
extern /* Subroutine */ int sbrem_1__(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
static integer lsttry;
extern /* Subroutine */ int sbset_1__(char *, char *, char *, integer *,
char *, ftnlen, ftnlen, ftnlen, ftnlen);
static char def[1024];
static integer loc;
static char key[32];
static logical new__;
extern /* Subroutine */ int sbinit_1__(integer *, integer *, integer *,
char *, integer *, char *, ftnlen, ftnlen);
/* $ Abstract */
/* Translate the symbols in an input string. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Keywords */
/* PARSE */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* INPUT I Input string containing symbols to be translated. */
/* OUTPUT O Output string, with all symbols translated. */
/* $ Detailed_Input */
/* INPUT is the input string to be translated. INPUT may contain */
/* any number of known symbols. */
/* $ Detailed_Output */
/* OUTPUT is the translation of the input string. The first */
/* of the symbols in INPUT will have been translated. */
/* When INPUT is either a DEFINE or an UNDEFINE command, */
/* OUTPUT is blank. */
/* OUTPUT may overwrite INPUT. */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* None. */
/* $ Exceptions */
/* The following exceptions are detected by this routine: */
/* 1) Attempt to define or undefine a symbol that does */
/* not begin with a letter. */
/* 2) Attempt to define or undefine a symbol that ends with */
/* a question mark '?' . */
/* 3) Failure to specify a symbol to define or undefine. */
/* 4) Attempting to define a reserved word. The reserved */
/* words are: */
/* 'START' */
/* 'STOP' */
/* 'EXIT' */
/* 'INQUIRE' */
/* 'SHOW' */
/* 'DEFINE' */
/* 'SHOW' */
/* 'UNDEFINE' */
/* 'HELP' */
/* In all of the above cases OUTPUT is set to blank and TRAN to */
/* FALSE. No new symbol is placed in the table of symbol */
/* definitions. */
/* In all of these cases the error BAD_SYMBOL_SPC is signalled. */
/* 5) Recursive symbol definitions are detected and disallowed. */
/* A long error message diagnosing the problem is set and */
/* the error RECURSIVE_SYMBOL is signalled. */
/* 5) Overflow of the input command caused by symbol resolution. */
/* In this case the OUTPUT is left at the state it had reached */
/* prior to the overflow condition and TRAN is returned as */
/* FALSE. The error SYMBOL_OVERFLOW is signalled. */
/* $ Detailed_Description */
/* A new symbol may be defined with the DEFINE command. The */
/* syntax is: */
/* DEFINE <symbol> <definition> */
/* where <symbol> is a valid symbol name and <definition> is any */
/* valid definition. The DEFINE command, the symbol name, and the */
/* definition are delimited by blanks. */
/* When a symbol is defined, the symbol and definition are inserted */
/* into the symbol table. */
/* An existing symbol may be removed from the table with the */
/* UNDEFINE command. The syntax is: */
/* UNDEFINE <symbol> */
/* where <symbol> is the name of an existing symbol. The UNDEFINE */
/* command and the symbol name are delimited by blanks. */
/* If the input string does not contain a definition statement, */
/* STRANS searches the input string for potential symbol names. */
/* When a valid symbol is encountered, it is removed from the */
/* string and replaced by the corresponding definition. This */
/* continues until no untranslated symbols remain. */
/* $ Examples */
/* Suppose that we are given the following definitions: */
/* DEFINE BODIES PLANET AND SATS */
/* DEFINE EUROPA 502 */
/* DEFINE GANYMEDE 503 */
/* DEFINE IO 501 */
/* DEFINE JUPITER 599 */
/* DEFINE PLANET JUPITER */
/* DEFINE CALLISTO 504 */
/* DEFINE SATS IO EUROPA GANYMEDE CALLISTO */
/* Then the string 'BODIES AND SOULS' would translate, */
/* at various stages, to: */
/* 'PLANET AND SATS AND SOULS' */
/* 'JUPITER AND SATS AND SOULS' */
/* '599 AND SATS AND SOULS' */
/* '599 AND IO EUROPA GANYMEDE CALLISTO AND SOULS' */
/* '599 AND 501 EUROPA GANYMEDE CALLISTO AND SOULS' */
/* '599 AND 501 502 GANYMEDE CALLISTO AND SOULS' */
/* '599 AND 501 502 503 CALLISTO AND SOULS' */
/* '599 AND 501 502 503 504 AND SOULS' */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* I. M. Underwood (JPL) */
/* $ Version_and_Date */
/* Version 1.2.0 29-Aug-1996 (WLT) */
/* Fixed the error message for the case in which someone */
/* tries to create a symbol that is more than 32 characters */
/* in length. */
/* Version 1.1, 14-SEP-1995 */
/* Reference to unused variable WORD deleted. */
/* Version 1, 8-SEP-1986 */
/* -& */
/* SPICELIB Functions */
/* Other supporting functions */
/* The following parameters are used to define our table */
/* of symbol translations. */
/* Longest allowed symbol name is given by WDSIZE */
/* Maximum number of allowed symbols is MAXN */
/* The longest we expect any symbol to be is MAXL characters */
/* The average number of characters per symbol is AVGL */
/* Finally, here are the arrays used to hold the symbol translations. */
/* Here's the storage we need for the reserved words. */
switch(n__) {
case 1: goto L_sympat;
case 2: goto L_symget;
}
/* Set up all of the data structures and special strings in */
/* the first pass through the routine. */
if (return_()) {
return 0;
}
chkin_("STRAN", (ftnlen)5);
if (first) {
first = FALSE_;
vdim = 51;
psize = 804;
nname = 200;
sbinit_1__(&nname, &psize, &vdim, names, ptrs, buffer, (ftnlen)32, (
ftnlen)256);
s_copy(resvrd, "START", (ftnlen)32, (ftnlen)5);
s_copy(resvrd + 32, "STOP", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 64, "EXIT", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 96, "INQUIRE", (ftnlen)32, (ftnlen)7);
s_copy(resvrd + 128, "SHOW", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 160, "DEFINE", (ftnlen)32, (ftnlen)6);
s_copy(resvrd + 192, "SHOW", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 224, "UNDEFINE", (ftnlen)32, (ftnlen)8);
s_copy(resvrd + 256, "HELP", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 288, "RECALL", (ftnlen)32, (ftnlen)6);
s_copy(resvrd + 320, "DO", (ftnlen)32, (ftnlen)2);
s_copy(resvrd + 352, "EDIT", (ftnlen)32, (ftnlen)4);
s_copy(alphab, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", (ftnlen)32, (ftnlen)26);
}
/* Find out what the special marker character is for suppressing */
/* symbol evaluation. */
geteq_(equote, (ftnlen)1);
/* Is this a definition statement? The presence of DEFINE, INQUIRE or */
/* UNDEFINE at the beginning of the string will confirm this. */
nthwd_(input, &c__1, key, &loc, input_len, (ftnlen)32);
ucase_(key, key, (ftnlen)32, (ftnlen)32);
/* The keyword must be followed by a valid symbol name. */
if (s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0 || s_cmp(key, "INQU"
"IRE", (ftnlen)32, (ftnlen)7) == 0 || s_cmp(key, "UNDEFINE", (
ftnlen)32, (ftnlen)8) == 0) {
nthwd_(input, &c__2, symbl, &loc, input_len, (ftnlen)33);
ucase_(symbl, symbol, (ftnlen)33, (ftnlen)33);
l = rtrim_(symbol, (ftnlen)33);
if (s_cmp(symbol, " ", (ftnlen)33, (ftnlen)1) == 0) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
setmsg_("The \"#\" command must be followed by the name of the s"
"ymbol that you want to #. ", (ftnlen)79);
errch_("#", key, (ftnlen)1, (ftnlen)32);
lcase_(key, key, (ftnlen)32, (ftnlen)32);
errch_("#", key, (ftnlen)1, (ftnlen)32);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (i_indx(alphab, symbol, (ftnlen)32, (ftnlen)1) == 0) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
lcase_(key, key, (ftnlen)32, (ftnlen)32);
setmsg_("You cannot # \"#\". Symbols must begin with a letter ("
"A-Z) ", (ftnlen)58);
errch_("#", key, (ftnlen)1, (ftnlen)32);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (l > 32) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
lcase_(key, key, (ftnlen)32, (ftnlen)32);
setmsg_("You cannot # \"#...\". Symbols may not be longer than "
"32 characters in length.", (ftnlen)77);
errch_("#", key, (ftnlen)1, (ftnlen)32);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (*(unsigned char *)&symbol[l - 1] == '?') {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
lcase_(key, key, (ftnlen)32, (ftnlen)32);
setmsg_("You cannot # \"#\". Symbols may not end with a questio"
"n mark '?'. ", (ftnlen)65);
errch_("#", key, (ftnlen)1, (ftnlen)32);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if ((s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0 || s_cmp(
key, "INQUIRE", (ftnlen)32, (ftnlen)7) == 0) && isrchc_(
symbol, &c__12, resvrd, (ftnlen)33, (ftnlen)32) > 0) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
setmsg_("The word '#' is a reserved word. You may not redefine i"
"t. ", (ftnlen)58);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
}
}
if (s_cmp(key, "INQUIRE", (ftnlen)32, (ftnlen)7) == 0) {
/* First of all we, can only INQUIRE for symbol definitions */
/* if the program is not running in "batch" mode. */
if (batch_()) {
setmsg_("You've attempted to INQUIRE for the value of a symbol w"
"hile the program is running in \"batch\" mode. You can I"
"NQUIRE for a symbol value only if you are running in INT"
"ERACTIVE mode. ", (ftnlen)180);
sigerr_("WRONG_MODE", (ftnlen)10);
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* See if there is anything following the symbol that is */
/* to be defined. This will be used as our prompt value. */
/* Computing MAX */
i__3 = loc + l;
i__1 = loc + l, i__2 = ncpos_(input, " ", &i__3, input_len, (ftnlen)1)
;
nxtchr = max(i__1,i__2);
if (s_cmp(input + (nxtchr - 1), " ", input_len - (nxtchr - 1), (
ftnlen)1) != 0) {
s_copy(myprmt, input + (nxtchr - 1), (ftnlen)80, input_len - (
nxtchr - 1));
} else {
s_copy(myprmt, "Enter definition for", (ftnlen)80, (ftnlen)20);
suffix_(symbol, &c__1, myprmt, (ftnlen)33, (ftnlen)80);
suffix_(">", &c__1, myprmt, (ftnlen)1, (ftnlen)80);
}
getdel_(delim, (ftnlen)1);
rdstmn_(myprmt, delim, def, (ftnlen)80, (ftnlen)1, (ftnlen)1024);
sbset_1__(symbol, def, names, ptrs, buffer, (ftnlen)33, (ftnlen)1024,
(ftnlen)32, (ftnlen)256);
}
/* If this is a definition, and the symbol already exists in the */
/* symbol table, simply replace the existing definition with the */
/* string following the symbol name. If this is a new symbol, */
/* find the first symbol in the list that should follow the new */
/* one. Move the rest of the symbols back, and insert the new one */
/* at this point. */
if (s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0) {
/* Computing MAX */
i__3 = loc + l;
i__1 = loc + l, i__2 = ncpos_(input, " ", &i__3, input_len, (ftnlen)1)
;
nxtchr = max(i__1,i__2);
sbset_1__(symbol, input + (nxtchr - 1), names, ptrs, buffer, (ftnlen)
33, input_len - (nxtchr - 1), (ftnlen)32, (ftnlen)256);
}
if (s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0 || s_cmp(key, "INQU"
"IRE", (ftnlen)32, (ftnlen)7) == 0) {
if (failed_()) {
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* Now check for a recursive definition. To do this we have */
/* two parallel arrays to the NAMES array of the string */
/* buffer. The first array CHECK is used to indicate that */
/* in the course of the definition resolution of the */
/* new symbol, another symbol shows up. The second array */
/* called CHECKD indicats whether or not we have examined this */
/* existing symbol to see if contains the newly created */
/* symbol as part of its definition. */
/* So far we have nothing to check and haven't checked anything. */
n = cardc_(names, (ftnlen)32);
i__1 = n;
for (j = 1; j <= i__1; ++j) {
check[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge("check",
i__2, "stran_", (ftnlen)545)] = FALSE_;
checkd[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge("checkd",
i__2, "stran_", (ftnlen)546)] = FALSE_;
}
/* Find the location of our new symbol in the NAMES cell. */
place = isrchc_(symbol, &n, names + 192, (ftnlen)33, (ftnlen)32);
new__ = TRUE_;
while(new__) {
/* Look up the definition currently associated with */
/* the symbol we are checking. */
sbget_1__(symbol, names, ptrs, buffer, def, &i__, (ftnlen)33, (
ftnlen)32, (ftnlen)256, (ftnlen)1024);
j = 1;
nthuqw_(def, &j, equote, symbol, &loc, (ftnlen)1024, (ftnlen)1, (
ftnlen)33);
while(loc > 0) {
ucase_(symbol, symbol, (ftnlen)33, (ftnlen)33);
slot = isrchc_(symbol, &n, names + 192, (ftnlen)33, (ftnlen)
32);
/* If the word is located in the same place as the */
/* symbol we've just defined, we've introduced */
/* a recursive symbol definition. Remove this */
/* symbol and diagnose the error. */
if (slot == place) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
s_copy(symbol, names + (((i__1 = place + 5) < 206 && 0 <=
i__1 ? i__1 : s_rnge("names", i__1, "stran_", (
ftnlen)582)) << 5), (ftnlen)33, (ftnlen)32);
sbrem_1__(symbol, names, ptrs, buffer, (ftnlen)33, (
ftnlen)32, (ftnlen)256);
setmsg_("The definition of '#' is recursive. Recursivel"
"y defined symbol definitions are not allowed. ", (
ftnlen)93);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("RECURSIVE_SYMBOL", (ftnlen)16);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (slot > 0) {
/* Otherwise if this word is in the names list */
/* we may need to check this symbol to see if */
/* it lists the just defined symbol in its definition. */
if (checkd[(i__1 = slot - 1) < 200 && 0 <= i__1 ? i__1 :
s_rnge("checkd", i__1, "stran_", (ftnlen)602)]) {
check[(i__1 = slot - 1) < 200 && 0 <= i__1 ? i__1 :
s_rnge("check", i__1, "stran_", (ftnlen)603)]
= FALSE_;
} else {
check[(i__1 = slot - 1) < 200 && 0 <= i__1 ? i__1 :
s_rnge("check", i__1, "stran_", (ftnlen)605)]
= TRUE_;
}
}
/* Locate the next unquoted word in the definition. */
++j;
nthuqw_(def, &j, equote, symbol, &loc, (ftnlen)1024, (ftnlen)
1, (ftnlen)33);
}
/* See if there are any new items to check. If there */
/* are create a new value for symbol, and mark the */
/* new item as being checked. */
new__ = FALSE_;
i__1 = n;
for (j = 1; j <= i__1; ++j) {
if (check[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge(
"check", i__2, "stran_", (ftnlen)625)] && ! new__) {
s_copy(symbol, names + (((i__2 = j + 5) < 206 && 0 <=
i__2 ? i__2 : s_rnge("names", i__2, "stran_", (
ftnlen)626)) << 5), (ftnlen)33, (ftnlen)32);
check[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge(
"check", i__2, "stran_", (ftnlen)627)] = FALSE_;
checkd[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge(
"checkd", i__2, "stran_", (ftnlen)628)] = TRUE_;
new__ = TRUE_;
}
}
}
/* If we get to this point, we have a new non-recursively */
/* defined symbol. */
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* If this is a deletion, and the symbol already exists in the */
/* symbol table, simply move the symbols that follow toward the */
/* front of the table. */
if (s_cmp(key, "UNDEFINE", (ftnlen)32, (ftnlen)8) == 0) {
sbrem_1__(symbol, names, ptrs, buffer, (ftnlen)33, (ftnlen)32, (
ftnlen)256);
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* This is not a definition statement. Look for potential symbols. */
/* Try to resolve the first symbol in the string by substituting the */
/* corresponding definition for the existing symbol. */
s_copy(output, input, output_len, input_len);
*tran = FALSE_;
j = 1;
nthuqw_(output, &j, equote, symbol, &loc, output_len, (ftnlen)1, (ftnlen)
33);
while(! (*tran) && s_cmp(symbol, " ", (ftnlen)33, (ftnlen)1) != 0) {
ucase_(symbol, symbol, (ftnlen)33, (ftnlen)33);
sbget_1__(symbol, names, ptrs, buffer, def, &i__, (ftnlen)33, (ftnlen)
32, (ftnlen)256, (ftnlen)1024);
if (i__ > 0) {
lsym = lastnb_(symbol, (ftnlen)33);
ldef = lastnb_(def, (ftnlen)1024) + 1;
lout = lastnb_(output, output_len);
leno = i_len(output, output_len);
if (lout - lsym + ldef > leno) {
*tran = FALSE_;
setmsg_("As a result of attempting to resolve the symbols in"
" the input command, the command has overflowed the a"
"llocated memory. This is may be due to unintentional"
"ly using symbols that you had not intended to use. "
"You may protect portions of your string from symbol "
"evaluation by enclosing that portion of your string "
"between the character # as in 'DO #THIS PART WITHOUT"
" SYMBOLS#' . ", (ftnlen)376);
errch_("#", equote, (ftnlen)1, (ftnlen)1);
errch_("#", equote, (ftnlen)1, (ftnlen)1);
errch_("#", equote, (ftnlen)1, (ftnlen)1);
sigerr_("SYMBOL_OVERFLOW", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
}
i__1 = loc + lsym - 1;
repsub_(output, &loc, &i__1, def, output, output_len, ldef,
output_len);
*tran = TRUE_;
} else {
++j;
}
nthuqw_(output, &j, equote, symbol, &loc, output_len, (ftnlen)1, (
ftnlen)33);
}
chkout_("STRAN", (ftnlen)5);
return 0;
/* The following entry point allows us to set up a search */
/* of defined symbols that match a wild-card pattern. It must */
/* be called prior to getting any symbol definitions. */
L_sympat:
lsttry = 0;
s_copy(pattrn, input, (ftnlen)80, input_len);
return 0;
/* The following entry point fetches the next symbol and its */
/* definition for the next SYMBOL whose name */
/* matches a previously supplied template via the entry point */
/* above --- SYMPAT. */
/* If there is no matching symbol, we get back blanks. Note */
/* that no translation of the definition is performed. */
L_symget:
s_copy(input, " ", input_len, (ftnlen)1);
s_copy(output, " ", output_len, (ftnlen)1);
n = cardc_(names, (ftnlen)32);
while(lsttry < n) {
++lsttry;
gotone = matchm_(names + (((i__1 = lsttry + 5) < 206 && 0 <= i__1 ?
i__1 : s_rnge("names", i__1, "stran_", (ftnlen)767)) << 5),
pattrn, "*", "%", "~", "|", (ftnlen)32, (ftnlen)80, (ftnlen)1,
(ftnlen)1, (ftnlen)1, (ftnlen)1);
if (gotone) {
s_copy(symbol, names + (((i__1 = lsttry + 5) < 206 && 0 <= i__1 ?
i__1 : s_rnge("names", i__1, "stran_", (ftnlen)771)) << 5)
, (ftnlen)33, (ftnlen)32);
s_copy(input, names + (((i__1 = lsttry + 5) < 206 && 0 <= i__1 ?
i__1 : s_rnge("names", i__1, "stran_", (ftnlen)772)) << 5)
, input_len, (ftnlen)32);
sbget_1__(symbol, names, ptrs, buffer, output, &i__, (ftnlen)33, (
ftnlen)32, (ftnlen)256, output_len);
return 0;
}
}
return 0;
} /* stran_ */
/* $Procedure ZZDYNBID ( Fetch body ID kernel variable ) */
/* Subroutine */ int zzdynbid_(char *frname, integer *frcode, char *item,
integer *idcode, ftnlen frname_len, ftnlen item_len)
{
integer n;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen), repmc_(char *, char *, char *, char *, ftnlen,
ftnlen, ftnlen, ftnlen);
logical found;
extern /* Subroutine */ int repmi_(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
char dtype[1];
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int bods2c_(char *, integer *, logical *, ftnlen);
extern logical failed_(void);
char bodnam[36];
integer codeln, nameln;
char kvname[32], cdestr[32];
integer itemln, reqnam;
extern /* Subroutine */ int chkout_(char *, ftnlen);
extern logical return_(void);
integer reqnum;
extern /* Subroutine */ int intstr_(integer *, char *, ftnlen), dtpool_(
char *, logical *, integer *, char *, ftnlen, ftnlen), setmsg_(
char *, ftnlen), errint_(char *, integer *, ftnlen), sigerr_(char
*, ftnlen), gcpool_(char *, integer *, integer *, integer *, char
*, logical *, ftnlen, ftnlen), gipool_(char *, integer *, integer
*, integer *, integer *, logical *, ftnlen);
/* $ Abstract */
/* SPICE Private routine intended solely for the support of SPICE */
/* routines. Users should not call this routine directly due */
/* to the volatile nature of this routine. */
/* Look up a frame definition kernel variable whose associated value */
/* is a body name or body ID code. The returned value is always an */
/* ID code. The frame name or frame ID may be used as part of the */
/* variable's name. */
/* If the kernel variable is not present, or if the variable */
/* is not a body name or a numeric value, signal an error. */
/* $ 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 */
/* FRAMES */
/* KERNEL */
/* PRIVATE */
/* UTILITY */
/* $ Declarations */
/* $ Abstract */
/* This include file lists the parameter collection */
/* defining the number of SPICE ID -> NAME mappings. */
/* $ 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 */
/* naif_ids.req */
/* $ Keywords */
/* Body mappings. */
/* $ Author_and_Institution */
/* E.D. Wright (JPL) */
/* $ Version */
/* SPICELIB 1.0.0 Thu May 20 07:57:58 2010 (EDW) */
/* A script generates this file. Do not edit by hand. */
/* Edit the creation script to modify the contents of */
/* ZZBODTRN.INC. */
/* Maximum size of a NAME string */
/* Count of default SPICE mapping assignments. */
/* $ Abstract */
/* Include file zzdyn.inc */
/* SPICE private file intended solely for the support of SPICE */
/* routines. Users should not include this file directly due */
/* to the volatile nature of this file */
/* The parameters defined below are used by the SPICELIB dynamic */
/* frame subsystem. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Parameters */
/* This file declares parameters required by the dynamic */
/* frame routines of the SPICELIB frame subsystem. */
/* $ Restrictions */
/* The parameter BDNMLN is this routine must be kept */
/* consistent with the parameter MAXL defined in */
/* zzbodtrn.inc */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.1.0, 12-JAN-2005 (NJB) */
/* Parameters KWX, KWY, KWZ renamed to KVX, KVY, KVZ. */
/* - SPICELIB Version 1.0.0, 22-DEC-2004 (NJB) */
/* -& */
/* String length parameters */
/* ======================== */
/* Kernel variable name length. This parameter must be */
/* kept consistent with the parameter MAXLEN used in the */
/* POOL umbrella routine. */
/* Length of a character kernel pool datum. This parameter must be */
/* kept consistent with the parameter MAXCHR used in the POOL */
/* umbrella routine. */
/* Reference frame name length. This parameter must be */
/* kept consistent with the parameter WDSIZE used in the */
/* FRAMEX umbrella routine. */
/* Body name length. This parameter is used to provide a level */
/* of indirection so the dynamic frame source code doesn't */
/* have to change if the name of this SPICELIB-scope parameter */
/* is changed. The value MAXL used here is defined in the */
/* INCLUDE file */
/* zzbodtrn.inc */
/* Current value of MAXL = 36 */
/* Numeric parameters */
/* =================================== */
/* The parameter MAXCOF is the maximum number of polynomial */
/* coefficients that may be used to define an Euler angle */
/* in an "Euler frame" definition */
/* The parameter LBSEP is the default angular separation limit for */
/* the vectors defining a two-vector frame. The angular separation */
/* of the vectors must differ from Pi and 0 by at least this amount. */
/* The parameter QEXP is used to determine the width of */
/* the interval DELTA used for the discrete differentiation */
/* of velocity in the routines ZZDYNFRM, ZZDYNROT, and their */
/* recursive analogs. This parameter is appropriate for */
/* 64-bit IEEE double precision numbers; when SPICELIB */
/* is hosted on platforms where longer mantissas are supported, */
/* this parameter (and hence this INCLUDE file) will become */
/* platform-dependent. */
/* The choice of QEXP is based on heuristics. It's believed to */
/* be a reasonable choice obtainable without expensive computation. */
/* QEXP is the largest power of 2 such that */
/* 1.D0 + 2**QEXP = 1.D0 */
/* Given an epoch T0 at which a discrete derivative is to be */
/* computed, this choice provides a value of DELTA that usually */
/* contributes no round-off error in the computation of the function */
/* evaluation epochs */
/* T0 +/- DELTA */
/* while providing the largest value of DELTA having this form that */
/* causes the order of the error term O(DELTA**2) in the quadratric */
/* function approximation to round to zero. Note that the error */
/* itself will normally be small but doesn't necessarily round to */
/* zero. Note also that the small function approximation error */
/* is not a measurement of the error in the discrete derivative */
/* itself. */
/* For ET values T0 > 2**27 seconds past J2000, the value of */
/* DELTA will be set to */
/* T0 * 2**QEXP */
/* For smaller values of T0, DELTA should be set to 1.D0. */
/* Frame kernel parameters */
/* ======================= */
/* Parameters relating to kernel variable names (keywords) start */
/* with the letters */
/* KW */
/* Parameters relating to kernel variable values start with the */
/* letters */
/* KV */
/* Generic parameters */
/* --------------------------------- */
/* Token used to build the base frame keyword: */
/* Frame definition style parameters */
/* --------------------------------- */
/* Token used to build the frame definition style keyword: */
/* Token indicating parameterized dynamic frame. */
/* Freeze epoch parameters */
/* --------------------------------- */
/* Token used to build the freeze epoch keyword: */
/* Rotation state parameters */
/* --------------------------------- */
/* Token used to build the rotation state keyword: */
/* Token indicating rotating rotation state: */
/* Token indicating inertial rotation state: */
/* Frame family parameters */
/* --------------------------------- */
/* Token used to build the frame family keyword: */
/* Token indicating mean equator and equinox of date frame. */
/* Token indicating mean ecliptic and equinox of date frame. */
/* Token indicating true equator and equinox of date frame. */
/* Token indicating two-vector frame. */
/* Token indicating Euler frame. */
/* "Of date" frame family parameters */
/* --------------------------------- */
/* Token used to build the precession model keyword: */
/* Token used to build the nutation model keyword: */
/* Token used to build the obliquity model keyword: */
/* Mathematical models used to define "of date" frames will */
/* likely accrue over time. We will simply assign them */
/* numbers. */
/* Token indicating the Lieske earth precession model: */
/* Token indicating the IAU 1980 earth nutation model: */
/* Token indicating the IAU 1980 earth mean obliqity of */
/* date model. Note the name matches that of the preceding */
/* nutation model---this is intentional. The keyword */
/* used in the kernel variable definition indicates what */
/* kind of model is being defined. */
/* Two-vector frame family parameters */
/* --------------------------------- */
/* Token used to build the vector axis keyword: */
/* Tokens indicating axis values: */
/* Prefixes used for primary and secondary vector definition */
/* keywords: */
/* Token used to build the vector definition keyword: */
/* Token indicating observer-target position vector: */
/* Token indicating observer-target velocity vector: */
/* Token indicating observer-target near point vector: */
/* Token indicating constant vector: */
/* Token used to build the vector observer keyword: */
/* Token used to build the vector target keyword: */
/* Token used to build the vector frame keyword: */
/* Token used to build the vector aberration correction keyword: */
/* Token used to build the constant vector specification keyword: */
/* Token indicating rectangular coordinates used to */
/* specify constant vector: */
/* Token indicating latitudinal coordinates used to */
/* specify constant vector: */
/* Token indicating RA/DEC coordinates used to */
/* specify constant vector: */
/* Token used to build the cartesian vector literal keyword: */
/* Token used to build the constant vector latitude keyword: */
/* Token used to build the constant vector longitude keyword: */
/* Token used to build the constant vector right ascension keyword: */
/* Token used to build the constant vector declination keyword: */
/* Token used to build the angular separation tolerance keyword: */
/* See the section "Physical unit parameters" below for additional */
/* parameters applicable to two-vector frames. */
/* Euler frame family parameters */
/* --------------------------------- */
/* Token used to build the epoch keyword: */
/* Token used to build the Euler axis sequence keyword: */
/* Tokens used to build the Euler angle coefficients keywords: */
/* See the section "Physical unit parameters" below for additional */
/* parameters applicable to Euler frames. */
/* Physical unit parameters */
/* --------------------------------- */
/* Token used to build the units keyword: */
/* Token indicating radians: */
/* Token indicating degrees: */
/* End of include file zzdyn.inc */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- ------------------------------------------------- */
/* FRNAME I Frame name. */
/* FRCODE I Frame ID code. */
/* ITEM I Item associated with frame definition. */
/* IDCODE O Body ID code. */
/* $ Detailed_Input */
/* FRNAME is the name of the reference frame with which */
/* the requested variable is associated. */
/* FRCODE is the frame ID code of the reference frame with */
/* which the requested variable is associated. */
/* ITEM is a string identifying the specific datum */
/* to be fetched. The kernel variable name */
/* has the form */
/* FRAME_<frame ID code>_<ITEM> */
/* or */
/* FRAME_<frame name>_<ITEM> */
/* The former of the two names takes precedence: */
/* this routine will look for a numeric variable */
/* of that name first. */
/* The value associated with the kernel variable */
/* must be one of */
/* - a nbody ID code */
/* - a string representation of an integer, */
/* for example '5' */
/* - a body frame name */
/* $ Detailed_Output */
/* IDCODE is the requested body ID code. */
/* The kernel variable name of the form */
/* FRAME_<frame ID code>_<ITEM> */
/* will be looked up first; if this variable */
/* is found and has numeric type, the associated */
/* value will be returned. If this variable is */
/* found and has character type, the value will */
/* be converted to a body ID code, and that */
/* code will be returned. */
/* If this variable is not found, the variable */
/* FRAME_<frame name>_<ITEM> */
/* will be looked up. If this variable is found and */
/* has numeric type, the associated value will be */
/* returned. If this variable is found and has */
/* character type, the value will be converted to a */
/* body ID code, and that code will be returned. */
/* If a numeric value associated with the selected */
/* kernel variable is not integral, it will be */
/* rounded to the closest integer. */
/* $ Parameters */
/* See zzdyn.inc for definition of KVNMLN. */
/* $ Exceptions */
/* 1) If neither the frame-ID-based or frame-name-based form of the */
/* requested kernel variable name matches a kernel variable */
/* present in the kernel pool, the error SPICE(KERNELVARNOTFOUND) */
/* will be signaled. */
/* 2) If either the frame-ID-based or frame-name-based form of the */
/* requested kernel variable name has length greater than KVNMLN, */
/* that variable will not be searched for. */
/* 3) If both the frame-ID-based and frame-name-based forms of the */
/* requested kernel variable name have length greater than KVNMLN, */
/* the error SPICE(VARNAMETOOLONG) will be signaled. */
/* 4) If kernel variable matching one form of the requested kernel */
/* variable names is found, but that variable has more than 1 */
/* associated value, the error SPICE(BADVARIABLESIZE) will be */
/* signaled. */
/* 5) If a name match is found for a character kernel variable, but */
/* the value associated with the variable cannot be mapped to a */
/* body ID code, the error SPICE(NOTRANSLATION) will be */
/* signaled. */
/* 6) If a name match is found for a numeric kernel variable, */
/* but that variable has a value that cannot be rounded to an */
/* integer representable on the host platform, an error will */
/* be signaled by a routine in the call tree of this routine. */
/* $ Files */
/* 1) Kernel variables fetched by this routine are normally */
/* introduced into the kernel pool by loading one or more */
/* frame kernels. See the Frames Required Reading for */
/* details. */
/* $ Particulars */
/* This routine centralizes logic for kernel variable lookups that */
/* must be performed by the SPICELIB frame subsystem. Part of the */
/* functionality of this routine consists of handling error */
/* conditions such as the unavailability of required kernel */
/* variables; hence no "found" flag is returned to the caller. */
/* As indicated above, the requested kernel variable may have a name */
/* of the form */
/* FRAME_<frame ID code>_<ITEM> */
/* or */
/* FRAME_<frame name>_<ITEM> */
/* Because most frame definition keywords have the first form, this */
/* routine looks for a name of that form first. */
/* Note that although this routine considers the two forms of the */
/* names to be synonymous, from the point of view of the kernel pool */
/* access routines, these names are distinct. Hence kernel */
/* variables having names of both forms, but having possibly */
/* different attributes, can be simultaneously present in the kernel */
/* pool. Intentional use of this kernel pool feature is discouraged. */
/* $ Examples */
/* 1) See ZZDYNFRM. */
/* 2) Applications of this routine include finding ID codes of */
/* observer or target bodies serving to define two-vector dynamic */
/* frames. */
/* $ Restrictions */
/* 1) This is a SPICE private routine; the routine is subject */
/* to change without notice. User applications should not */
/* call this routine. */
/* 2) An array-valued kernel variable matching the "ID code form" */
/* of the requested kernel variable name could potentially */
/* mask a scalar-valued kernel variable matching the "name */
/* form" of the requested name. This problem can be prevented */
/* by sensible frame kernel design. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 2.0.0, 05-AUG-2005 (NJB) */
/* References to parameterized dynamic frames in long error */
/* messages were changed to references to "reference frames." */
/* This change was made to enable this utility to support */
/* kernel variable look-ups for non-dynamic frames. */
/* - SPICELIB Version 1.0.0, 18-DEC-2004 (NJB) */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 05-AUG-2005 (NJB) */
/* References to parameterized dynamic frames in long error */
/* messages were changed to references to "reference frames." */
/* This change was made to enable this utility to support */
/* kernel variable look-ups for non-dynamic frames. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* TEMPLN is the length of the keyword template, minus */
/* the sum of the lengths of the two substitution markers ('#'). */
/* Local variables */
if (return_()) {
return 0;
}
chkin_("ZZDYNBID", (ftnlen)8);
/* Prepare to check the name of the kernel variable we're about */
/* to look up. */
/* Convert the frame code to a string. */
intstr_(frcode, cdestr, (ftnlen)32);
if (failed_()) {
chkout_("ZZDYNBID", (ftnlen)8);
return 0;
}
/* Get the lengths of the input frame code, name and item. */
/* Compute the length of the ID-based kernel variable name; */
/* check this length against the maximum allowed value. If */
/* the name is too long, proceed to look up the form of the */
/* kernel variable name based on the frame name. */
codeln = rtrim_(cdestr, (ftnlen)32);
nameln = rtrim_(frname, frname_len);
itemln = rtrim_(item, item_len);
reqnum = codeln + itemln + 7;
if (reqnum <= 32) {
/* First try looking for a kernel variable including the frame ID */
/* code. */
/* Note the template is */
/* 'FRAME_#_#' */
repmi_("FRAME_#_#", "#", frcode, kvname, (ftnlen)9, (ftnlen)1, (
ftnlen)32);
repmc_(kvname, "#", item, kvname, (ftnlen)32, (ftnlen)1, item_len, (
ftnlen)32);
dtpool_(kvname, &found, &n, dtype, (ftnlen)32, (ftnlen)1);
} else {
/* The ID-based name is too long. We can't find the variable if */
/* we can't look it up. */
found = FALSE_;
}
if (! found) {
/* We need to look up the frame name-based kernel variable. */
/* Determine the length of the name of this variable; make */
/* sure it's not too long. */
reqnam = nameln + itemln + 7;
if (reqnam > 32 && reqnum > 32) {
/* Both forms of the name are too long. */
setmsg_("Kernel variable FRAME_#_# has length #; kernel variable"
" FRAME_#_# has length #; maximum allowed length is #. N"
"either variable could be searched for in the kernel pool"
" due to these name length errors.", (ftnlen)200);
errint_("#", frcode, (ftnlen)1);
errch_("#", item, (ftnlen)1, item_len);
errint_("#", &reqnum, (ftnlen)1);
errch_("#", frname, (ftnlen)1, frname_len);
errch_("#", item, (ftnlen)1, item_len);
errint_("#", &reqnam, (ftnlen)1);
errint_("#", &c__32, (ftnlen)1);
sigerr_("SPICE(VARNAMETOOLONG)", (ftnlen)21);
chkout_("ZZDYNBID", (ftnlen)8);
return 0;
} else if (reqnam > 32) {
/* We couldn't find the variable having the ID-based name, */
/* and the frame name-based variable name is too long to */
/* look up. */
/* Note that at this point KVNAME contains the ID-based */
/* kernel variable name. */
setmsg_("Kernel variable # was expected to be present in the ker"
"nel pool but was not found. The alternative form of ker"
"nel variable name FRAME_#_# was not searched for because"
" this name has excessive length (# characters vs allowed"
" maximum of #). One of these variables is needed to def"
"ine the reference frame #. Usually this type of problem"
" is due to a missing keyword assignment in a frame kerne"
"l. Another, less likely, possibility is that other erro"
"rs in a frame kernel have confused the frame subsystem i"
"nto wrongly deciding these variables are needed.", (
ftnlen)551);
errch_("#", kvname, (ftnlen)1, (ftnlen)32);
errch_("#", frname, (ftnlen)1, frname_len);
errch_("#", item, (ftnlen)1, item_len);
errint_("#", &reqnam, (ftnlen)1);
errint_("#", &c__32, (ftnlen)1);
errch_("#", frname, (ftnlen)1, frname_len);
sigerr_("SPICE(KERNELVARNOTFOUND)", (ftnlen)24);
chkout_("ZZDYNBID", (ftnlen)8);
return 0;
}
/* Now try looking for a kernel variable including the frame */
/* name. */
repmc_("FRAME_#_#", "#", frname, kvname, (ftnlen)9, (ftnlen)1,
frname_len, (ftnlen)32);
repmc_(kvname, "#", item, kvname, (ftnlen)32, (ftnlen)1, item_len, (
ftnlen)32);
dtpool_(kvname, &found, &n, dtype, (ftnlen)32, (ftnlen)1);
if (! found && reqnum > 32) {
/* The kernel variable's presence (in one form or the other) */
/* is mandatory: signal an error. The error message */
/* depends on which variables we were able to try to */
/* look up. In this case, we never tried to look up the */
/* frame ID-based name. */
/* Note that at this point KVNAME contains the name-based */
/* kernel variable name. */
setmsg_("Kernel variable # was expected to be present in the ker"
"nel pool but was not found. The alternative form of ker"
"nel variable name FRAME_#_# was not searched for because"
" this name has excessive length (# characters vs allowed"
" maximum of #). One of these variables is needed to def"
"ine the reference frame #. Usually this type of problem"
" is due to a missing keyword assignment in a frame kerne"
"l. Another, less likely, possibility is that other erro"
"rs in a frame kernel have confused the frame subsystem i"
"nto wrongly deciding these variables are needed.", (
ftnlen)551);
errch_("#", kvname, (ftnlen)1, (ftnlen)32);
errint_("#", frcode, (ftnlen)1);
errch_("#", item, (ftnlen)1, item_len);
errint_("#", &reqnum, (ftnlen)1);
errint_("#", &c__32, (ftnlen)1);
errch_("#", frname, (ftnlen)1, frname_len);
sigerr_("SPICE(KERNELVARNOTFOUND)", (ftnlen)24);
chkout_("ZZDYNBID", (ftnlen)8);
return 0;
} else if (! found) {
/* We tried to look up both names and failed. */
setmsg_("At least one of the kernel variables FRAME_#_# or FRAME"
"_#_# was expected to be present in the kernel pool but n"
"either was found. One of these variables is needed to de"
"fine the reference frame #. Usually this type of proble"
"m is due to a missing keyword assignment in a frame kern"
"el. Another, less likely, possibility is that other err"
"ors in a frame kernel have confused the frame subsystem "
"into wrongly deciding these variables are needed.", (
ftnlen)440);
errint_("#", frcode, (ftnlen)1);
errch_("#", item, (ftnlen)1, item_len);
errch_("#", frname, (ftnlen)1, frname_len);
errch_("#", item, (ftnlen)1, item_len);
errch_("#", frname, (ftnlen)1, frname_len);
sigerr_("SPICE(KERNELVARNOTFOUND)", (ftnlen)24);
chkout_("ZZDYNBID", (ftnlen)8);
return 0;
}
}
/* Getting to this point means we found a kernel variable. The name */
/* of the variable is KVNAME. The data type is DTYPE and the */
/* cardinality is N. */
if (*(unsigned char *)dtype == 'C') {
/* Rather than using BADKPV, we check the cardinality of the */
/* kernel variable in-line so we can create a more detailed error */
/* message if need be. */
if (n > 1) {
setmsg_("The kernel variable # has used to define frame # was ex"
"pected to have size not exceeding 1 but in fact has size"
" #. Usually this type of problem is due to an error in a"
" frame definition provided in a frame kernel.", (ftnlen)
212);
errch_("#", kvname, (ftnlen)1, (ftnlen)32);
errch_("#", frname, (ftnlen)1, frname_len);
errint_("#", &n, (ftnlen)1);
sigerr_("SPICE(BADVARIABLESIZE)", (ftnlen)22);
chkout_("ZZDYNBID", (ftnlen)8);
return 0;
}
/* Look up the kernel variable. */
gcpool_(kvname, &c__1, &c__1, &n, bodnam, &found, (ftnlen)32, (ftnlen)
36);
if (! found) {
setmsg_("Variable # not found after DTPOOL indicated it was pres"
"ent in pool.", (ftnlen)67);
errch_("#", kvname, (ftnlen)1, (ftnlen)32);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZDYNBID", (ftnlen)8);
return 0;
}
/* Convert the body name to a body code. */
bods2c_(bodnam, idcode, &found, (ftnlen)36);
if (! found) {
setmsg_("Body name # could not be translated to an ID code.", (
ftnlen)50);
errch_("#", bodnam, (ftnlen)1, (ftnlen)36);
sigerr_("SPICE(NOTRANSLATION)", (ftnlen)20);
chkout_("ZZDYNBID", (ftnlen)8);
return 0;
}
} else {
/* The variable has numeric type. */
if (n > 1) {
setmsg_("The kernel variable # has used to define frame # was ex"
"pected to have size not exceeding 1 but in fact has size"
" #. Usually this type of problem is due to an error in a"
" frame definition provided in a frame kernel.", (ftnlen)
212);
errch_("#", kvname, (ftnlen)1, (ftnlen)32);
errch_("#", frname, (ftnlen)1, frname_len);
errint_("#", &n, (ftnlen)1);
sigerr_("SPICE(BADVARIABLESIZE)", (ftnlen)22);
chkout_("ZZDYNBID", (ftnlen)8);
return 0;
}
/* Look up the kernel variable. */
gipool_(kvname, &c__1, &c__1, &n, idcode, &found, (ftnlen)32);
if (! found) {
setmsg_("Variable # not found after DTPOOL indicated it was pres"
"ent in pool.", (ftnlen)67);
errch_("#", kvname, (ftnlen)1, (ftnlen)32);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZDYNBID", (ftnlen)8);
return 0;
}
}
chkout_("ZZDYNBID", (ftnlen)8);
return 0;
} /* zzdynbid_ */
/* $Procedure DISSM ( Write a summary to standard output ) */
/* Subroutine */ int dispsm_(integer *nobj, integer *ids, doublereal *tstrts,
doublereal *tends, integer *avfs, integer *frames, char *tout,
logical *fdsp, logical *tdsp, logical *gdsp, logical *ndsp, ftnlen
tout_len)
{
/* System generated locals */
integer ids_dim1, frames_dim1, avfs_dim1, tstrts_dim1, tends_dim1, i__1,
i__2, i__3, i__4, i__5, i__6;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
integer i__, k;
extern integer rtrim_(char *, ftnlen);
char tdsph1[256], tdsph2[256];
extern /* Subroutine */ int repmcw_(char *, char *, char *, integer *,
char *, ftnlen, ftnlen, ftnlen, ftnlen), tostdo_(char *, ftnlen),
prinsr_(void), prinst_(integer *, doublereal *, doublereal *,
integer *, integer *, char *, logical *, logical *, logical *,
logical *, ftnlen);
/* $ Abstract */
/* Format and display CK-file data summary on standard output. */
/* $ 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 */
/* CKBRIEF.UG */
/* $ Keywords */
/* SUMMARY */
/* CK */
/* $ 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 */
/* -------- --- -------------------------------------------------- */
/* NOBJ I Number of intervals */
/* IDS I NAIF ID codes of objects */
/* TSTRTS I Begin DP SCLK times of intervals */
/* TENDS I End DP SCLK times of intervals */
/* AVFS I Angular velocity flags */
/* FRAMES I NAIF ID codes of reference frames */
/* TOUT I Key specifying times representation on output */
/* FDSP I Flag defining whether frame's name/id is printed */
/* TDSP I Flag defining tabular/non-tabular summary format */
/* GDSP I Flag requesting object grouping by coverage */
/* NDSP I Flag to display frame assosiated with CK ID */
/* $ Detailed_Input */
/* NOBJ Number of different coverage intervals in a */
/* CK-file. */
/* IDS Integer array of NAIF ID codes corresponding to */
/* the coverage intervals. */
/* TSTRTS Double precision array of begin DP SCLK times for */
/* each interval for a given CK-file. */
/* TENDS Double precision array of end DP SCLK times for */
/* each interval for a given CK-file. */
/* AVFS Integer array of angular velocities flags */
/* corresponding to the coverage intervals. */
/* FRAMES Integer array of reference frame ID codes */
/* corresponding to the coverage intervals. */
/* TOUT Key specifying time representation on output: */
/* SCLK string, encoded SCLK, ET, UTC or DOY */
/* FDSP Flag defining whether name or ID code of the */
/* FRAME should appear on output. */
/* TDSP Flag defining whether summaries have to be written */
/* in tabular or non-tabular format. */
/* GDSP Flag defining whether objects with the same */
/* coverage must be grouped together. */
/* NDSP Flag requesting display of the name of the frame */
/* associated with CK ID. */
/* $ Detailed_Output */
/* No output parameters in this subroutine. It prints summary for */
/* a given CK-file. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* Y.K. Zaiko (BERC) */
/* B.V. Semenov (NAIF) */
/* $ Version */
/* - CKBRIEF Beta Version 2.0.0, 13-OCT-2008 (BVS) */
/* Added NDSP argument. Changed tabular display heading for */
/* frame name display. */
/* - CKBRIEF Beta Version 1.1.0, 28-DEC-2001 (NJB) */
/* Removed extraneous white space at end of file so that */
/* the final character is a newline. This was done */
/* to suppress compiler warnings. */
/* - CKBRIEF Beta Version 1.0.0, 17-FEB-1999 (YKZ)(BVS) */
/* -& */
/* SPICELIB functions. */
/* Local variables */
/* If table output was requested, substitute correct time type in */
/* the table header and print it (header) out. */
/* Parameter adjustments */
frames_dim1 = *nobj;
avfs_dim1 = *nobj;
tends_dim1 = *nobj + 1;
tstrts_dim1 = *nobj + 1;
ids_dim1 = *nobj + 1;
/* Function Body */
if (*tdsp) {
/* Set header template for tabular format of summary display. */
if (*ndsp) {
if (*fdsp) {
s_copy(tdsph1, "Frames Interval Begin ##"
"##### Interval End ####### AV Relative to FRA"
"ME", (ftnlen)256, (ftnlen)98);
s_copy(tdsph2, "-------------------------- -----------------"
"------- ------------------------ --- ---------------"
"--", (ftnlen)256, (ftnlen)98);
} else {
s_copy(tdsph1, "Frames Interval Begin ##"
"##### Interval End ####### AV ", (ftnlen)256, (
ftnlen)81);
s_copy(tdsph2, "-------------------------- -----------------"
"------- ------------------------ --- ", (ftnlen)256, (
ftnlen)81);
}
} else {
if (*fdsp) {
s_copy(tdsph1, "Objects Interval Begin ####### Interval E"
"nd ####### AV Relative to FRAME", (ftnlen)256, (
ftnlen)80);
s_copy(tdsph2, "-------- ------------------------ ----------"
"-------------- --- -----------------", (ftnlen)256, (
ftnlen)80);
} else {
s_copy(tdsph1, "Objects Interval Begin ####### Interval E"
"nd ####### AV ", (ftnlen)256, (ftnlen)63);
s_copy(tdsph2, "-------- ------------------------ ----------"
"-------------- --- ", (ftnlen)256, (ftnlen)63);
}
}
i__1 = rtrim_("#######", (ftnlen)7);
repmcw_(tdsph1, "#######", tout, &i__1, tdsph1, (ftnlen)256, (ftnlen)
7, tout_len, (ftnlen)256);
i__1 = rtrim_("#######", (ftnlen)7);
repmcw_(tdsph1, "#######", tout, &i__1, tdsph1, (ftnlen)256, (ftnlen)
7, tout_len, (ftnlen)256);
tostdo_(" ", (ftnlen)1);
tostdo_(tdsph1, (ftnlen)256);
tostdo_(tdsph2, (ftnlen)256);
}
/* If option "group together objects with the same coverage" was not */
/* specified then objects will be displayed one by one from index */
/* 1 to index NOBJ. */
if (! (*gdsp)) {
i__1 = *nobj;
for (i__ = 1; i__ <= i__1; ++i__) {
prinst_(&ids[(i__2 = i__ - 1) < ids_dim1 && 0 <= i__2 ? i__2 :
s_rnge("ids", i__2, "dispsm_", (ftnlen)254)], &tstrts[(
i__3 = i__ - 1) < tstrts_dim1 && 0 <= i__3 ? i__3 :
s_rnge("tstrts", i__3, "dispsm_", (ftnlen)254)], &tends[(
i__4 = i__ - 1) < tends_dim1 && 0 <= i__4 ? i__4 : s_rnge(
"tends", i__4, "dispsm_", (ftnlen)254)], &avfs[(i__5 =
i__ - 1) < avfs_dim1 && 0 <= i__5 ? i__5 : s_rnge("avfs",
i__5, "dispsm_", (ftnlen)254)], &frames[(i__6 = i__ - 1) <
frames_dim1 && 0 <= i__6 ? i__6 : s_rnge("frames", i__6,
"dispsm_", (ftnlen)254)], tout, fdsp, tdsp, gdsp, ndsp,
tout_len);
}
} else {
/* Grouping option was specified. But, do we have anything to */
/* group together (or in other words do we have more that one */
/* record?) */
if (*nobj == 1) {
/* No, we don't. Then we display this one (and only :) record. */
prinst_(&ids[(i__1 = 0) < ids_dim1 ? i__1 : s_rnge("ids", i__1,
"dispsm_", (ftnlen)271)], &tstrts[(i__2 = 0) <
tstrts_dim1 ? i__2 : s_rnge("tstrts", i__2, "dispsm_", (
ftnlen)271)], &tends[(i__3 = 0) < tends_dim1 ? i__3 :
s_rnge("tends", i__3, "dispsm_", (ftnlen)271)], &avfs[(
i__4 = 0) < avfs_dim1 ? i__4 : s_rnge("avfs", i__4, "dis"
"psm_", (ftnlen)271)], &frames[(i__5 = 0) < frames_dim1 ?
i__5 : s_rnge("frames", i__5, "dispsm_", (ftnlen)271)],
tout, fdsp, tdsp, gdsp, ndsp, tout_len);
} else {
/* We need to group together objects this the same coverage */
/* in summary display. To provide this, there are two */
/* loops. Loop for variable I is to find first record */
/* in source buffer, which was not displayed yet. Loop for */
/* variable K is to find an index of object with the coverage */
/* equal to the coverage of previous displayed object (if */
/* such exists). */
i__ = 1;
while(i__ < *nobj) {
/* Look for the next ID that wasn't displayed yet. */
while(ids[(i__1 = i__ - 1) < ids_dim1 && 0 <= i__1 ? i__1 :
s_rnge("ids", i__1, "dispsm_", (ftnlen)292)] == 0 &&
i__ < *nobj) {
++i__;
}
/* Did we reach the end of the buffer? */
if (i__ == *nobj) {
/* We did. Was the last record in the buffer processed */
/* already? If not, print in out. */
if (ids[(i__1 = i__ - 1) < ids_dim1 && 0 <= i__1 ? i__1 :
s_rnge("ids", i__1, "dispsm_", (ftnlen)305)] != 0)
{
prinst_(&ids[(i__1 = i__ - 1) < ids_dim1 && 0 <= i__1
? i__1 : s_rnge("ids", i__1, "dispsm_", (
ftnlen)307)], &tstrts[(i__2 = i__ - 1) <
tstrts_dim1 && 0 <= i__2 ? i__2 : s_rnge(
"tstrts", i__2, "dispsm_", (ftnlen)307)], &
tends[(i__3 = i__ - 1) < tends_dim1 && 0 <=
i__3 ? i__3 : s_rnge("tends", i__3, "dispsm_",
(ftnlen)307)], &avfs[(i__4 = i__ - 1) <
avfs_dim1 && 0 <= i__4 ? i__4 : s_rnge("avfs",
i__4, "dispsm_", (ftnlen)307)], &frames[(
i__5 = i__ - 1) < frames_dim1 && 0 <= i__5 ?
i__5 : s_rnge("frames", i__5, "dispsm_", (
ftnlen)307)], tout, fdsp, tdsp, gdsp, ndsp,
tout_len);
}
} else {
/* Our record is somewhere in the middle of the buffer. */
/* Print it first and after that loop over the rest of */
/* the buffer to see whether we have more records */
/* with the same coverage. */
prinst_(&ids[(i__1 = i__ - 1) < ids_dim1 && 0 <= i__1 ?
i__1 : s_rnge("ids", i__1, "dispsm_", (ftnlen)320)
], &tstrts[(i__2 = i__ - 1) < tstrts_dim1 && 0 <=
i__2 ? i__2 : s_rnge("tstrts", i__2, "dispsm_", (
ftnlen)320)], &tends[(i__3 = i__ - 1) <
tends_dim1 && 0 <= i__3 ? i__3 : s_rnge("tends",
i__3, "dispsm_", (ftnlen)320)], &avfs[(i__4 = i__
- 1) < avfs_dim1 && 0 <= i__4 ? i__4 : s_rnge(
"avfs", i__4, "dispsm_", (ftnlen)320)], &frames[(
i__5 = i__ - 1) < frames_dim1 && 0 <= i__5 ? i__5
: s_rnge("frames", i__5, "dispsm_", (ftnlen)320)],
tout, fdsp, tdsp, gdsp, ndsp, tout_len);
ids[(i__1 = i__ - 1) < ids_dim1 && 0 <= i__1 ? i__1 :
s_rnge("ids", i__1, "dispsm_", (ftnlen)322)] = 0;
k = i__;
while(k < *nobj) {
++k;
if (tstrts[(i__1 = i__ - 1) < tstrts_dim1 && 0 <=
i__1 ? i__1 : s_rnge("tstrts", i__1, "dispsm_"
, (ftnlen)330)] == tstrts[(i__2 = k - 1) <
tstrts_dim1 && 0 <= i__2 ? i__2 : s_rnge(
"tstrts", i__2, "dispsm_", (ftnlen)330)] &&
tends[(i__3 = i__ - 1) < tends_dim1 && 0 <=
i__3 ? i__3 : s_rnge("tends", i__3, "dispsm_",
(ftnlen)330)] == tends[(i__4 = k - 1) <
tends_dim1 && 0 <= i__4 ? i__4 : s_rnge("ten"
"ds", i__4, "dispsm_", (ftnlen)330)]) {
/* Print this records and set IDS(K) to 0. */
prinst_(&ids[(i__1 = k - 1) < ids_dim1 && 0 <=
i__1 ? i__1 : s_rnge("ids", i__1, "disps"
"m_", (ftnlen)336)], &tstrts[(i__2 = k - 1)
< tstrts_dim1 && 0 <= i__2 ? i__2 :
s_rnge("tstrts", i__2, "dispsm_", (ftnlen)
336)], &tends[(i__3 = k - 1) < tends_dim1
&& 0 <= i__3 ? i__3 : s_rnge("tends",
i__3, "dispsm_", (ftnlen)336)], &avfs[(
i__4 = k - 1) < avfs_dim1 && 0 <= i__4 ?
i__4 : s_rnge("avfs", i__4, "dispsm_", (
ftnlen)336)], &frames[(i__5 = k - 1) <
frames_dim1 && 0 <= i__5 ? i__5 : s_rnge(
"frames", i__5, "dispsm_", (ftnlen)336)],
tout, fdsp, tdsp, gdsp, ndsp, tout_len);
ids[(i__1 = k - 1) < ids_dim1 && 0 <= i__1 ? i__1
: s_rnge("ids", i__1, "dispsm_", (ftnlen)
338)] = 0;
}
}
}
}
}
}
/* Reset variables saved in PRINST to make sure that summary for */
/* the next CK file will be displayed correctly. */
prinsr_();
return 0;
} /* dispsm_ */
/* $Procedure PRTRAP */
/* Subroutine */ int prtrap_(char *command, logical *tran, ftnlen command_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Local variables */
char word[33*3];
integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen), errch_(char *, char *, ftnlen, ftnlen), nthwd_(
char *, integer *, char *, integer *, ftnlen, ftnlen);
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen);
integer loc;
/* $ Abstract */
/* Determine whether the given command should be trapped (left */
/* untranslated). */
/* $ 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 */
/* PERCY */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* COMMND I PERCY command to be evaluated. */
/* TRAN I True if further translation is needed. */
/* $ Detailed_Input */
/* COMMAND is the input PERCY command. The following commands */
/* should not be translated fully. (A moment's thought */
/* will show why.) */
/* - SHOW SYMBOL <symbol> */
/* - INQUIRE <symbol> */
/* If translation has proceeded far enough for either */
/* of these statements to be recognized, then it has */
/* gone far enough. */
/* $ Detailed_Output */
/* TRAN is true if further translation of COMMAND is okay. */
/* If any of the statements mentioned above is recognized, */
/* TRAN is false. (This will prevent PERCY from trying */
/* to resolve any more symbols.) */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* See 'SYMBOLS.INC'. */
/* $ Detailed_Description */
/* Get the first three words of COMMAND. */
/* - If the first two words are SHOW SYMBOL, and the */
/* third word is not blank and does not end with '?', */
/* then this should be trapped. */
/* - If the first word is INQUIRE and the second word */
/* is not blank and does not end with '?', then this */
/* should be trapped. */
/* If the statement should be trapped, set TRAN to false and return. */
/* $ Examples */
/* Command Trap? */
/* ------------------------------------ ----- */
/* 'SHOW SYMBOL CARROT ' Y */
/* 'SHOW SYMBOL ' N */
/* 'SHOW SYMBOL SYMBOL_NAME? ' N */
/* 'INQUIRE PRIMARY_PLANET ' N */
/* 'INQUIRE ' Y */
/* 'INQUIRE QUERY_NAME? ' Y */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* W. L. Taber (JPL) */
/* I. M. Underwood (JPL) */
/* $ Version_and_Date */
/* Version 1, 17-SEP-1986 */
/* -& */
/* Spicelib Functions */
/* Local variables */
/* Get the first three words of COMMAND. */
for (i__ = 1; i__ <= 3; ++i__) {
nthwd_(command, &i__, word + ((i__1 = i__ - 1) < 3 && 0 <= i__1 ?
i__1 : s_rnge("word", i__1, "prtrap_", (ftnlen)144)) * 33, &
loc, command_len, (ftnlen)33);
ucase_(word + ((i__1 = i__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
"word", i__1, "prtrap_", (ftnlen)145)) * 33, word + ((i__2 =
i__ - 1) < 3 && 0 <= i__2 ? i__2 : s_rnge("word", i__2, "prt"
"rap_", (ftnlen)145)) * 33, (ftnlen)33, (ftnlen)33);
}
/* Is this a SHOW SYMBOL command? */
if (s_cmp(word, "SHOW", (ftnlen)33, (ftnlen)4) == 0 && s_cmp(word + 33,
"SYMBOL", (ftnlen)33, (ftnlen)6) == 0) {
/* The third word must not be blank, and must not end with '?'. */
/* (WORD is longer than any allowable symbol or query, so there */
/* should always be a blank at the end.) */
if (s_cmp(word + 66, " ", (ftnlen)33, (ftnlen)1) != 0) {
loc = rtrim_(word + 66, (ftnlen)33);
if (*(unsigned char *)&word[loc + 65] != '?') {
*tran = FALSE_;
return 0;
}
}
/* Is this an INQUIRE command? */
} else if (s_cmp(word, "INQUIRE", (ftnlen)33, (ftnlen)7) == 0) {
/* The second word must not be blank, and must not end with '?'. */
if (s_cmp(word + 33, " ", (ftnlen)33, (ftnlen)1) != 0) {
loc = rtrim_(word + 33, (ftnlen)33);
if (*(unsigned char *)&word[loc + 32] == '?') {
*tran = FALSE_;
chkin_("PRTRAP", (ftnlen)6);
setmsg_("INQUIRE commands must be of the form INQUIRE <symbo"
"l_name>, You have INQUIRE # which is inquiring for "
"the value of a query. This kind of INQUIRE is not su"
"pported. ", (ftnlen)164);
errch_("#", word + 33, (ftnlen)1, (ftnlen)33);
sigerr_("INVALID_INQUIRE", (ftnlen)15);
chkout_("PRTRAP", (ftnlen)6);
return 0;
}
}
}
/* No reason to trap this. */
*tran = TRUE_;
return 0;
} /* prtrap_ */
/* $Procedure OUTMSG ( Output Error Messages ) */
/* Subroutine */ int outmsg_(char *list, ftnlen list_len)
{
/* Initialized data */
static char defmsg[80*4] = "Oh, by the way: The SPICELIB error handling"
" actions are USER-TAILORABLE. You " "can choose whether the To"
"olkit aborts or continues when errors occur, which " "error "
"messages to output, and where to send the output. Please read t"
"he ERROR " "\"Required Reading\" file, or see the routines ERRA"
"CT, ERRDEV, and ERRPRT. ";
static logical first = TRUE_;
/* System generated locals */
address a__1[2], a__2[3];
integer i__1, i__2, i__3[2], i__4[3];
char ch__1[38];
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen),
s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char name__[32], line[80];
logical long__;
char lmsg[1840];
logical expl;
char smsg[25], xmsg[80];
integer i__;
logical trace;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
integer depth, index;
extern integer wdcnt_(char *, ftnlen);
extern /* Subroutine */ int expln_(char *, char *, ftnlen, ftnlen);
extern integer rtrim_(char *, ftnlen);
char versn[80], words[9*5];
integer start;
logical short__;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
char device[255];
integer remain;
static char border[80];
extern /* Subroutine */ int getdev_(char *, ftnlen);
logical dfault;
integer length;
extern /* Subroutine */ int trcdep_(integer *);
extern integer lastnb_(char *, ftnlen);
extern /* Subroutine */ int trcnam_(integer *, char *, ftnlen), lparse_(
char *, char *, integer *, integer *, char *, ftnlen, ftnlen,
ftnlen);
extern logical msgsel_(char *, ftnlen);
integer wrdlen;
extern /* Subroutine */ int getlms_(char *, ftnlen), wrline_(char *, char
*, ftnlen, ftnlen), getsms_(char *, ftnlen), suffix_(char *,
integer *, char *, ftnlen, ftnlen);
char tmpmsg[105];
extern /* Subroutine */ int nextwd_(char *, char *, char *, ftnlen,
ftnlen, ftnlen);
integer numwrd;
char upword[9], outwrd[1840];
extern /* Subroutine */ int tkvrsn_(char *, char *, ftnlen, ftnlen);
logical output;
/* $ Abstract */
/* Output error messages. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* ERROR */
/* $ Keywords */
/* ERROR */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include File: SPICELIB Error Handling Parameters */
/* errhnd.inc Version 2 18-JUN-1997 (WLT) */
/* The size of the long error message was */
/* reduced from 25*80 to 23*80 so that it */
/* will be accepted by the Microsoft Power Station */
/* FORTRAN compiler which has an upper bound */
/* of 1900 for the length of a character string. */
/* errhnd.inc Version 1 29-JUL-1997 (NJB) */
/* Maximum length of the long error message: */
/* Maximum length of the short error message: */
/* End Include File: SPICELIB Error Handling Parameters */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* LIST I A list of error message types. */
/* FILEN P Maximum length of file name. */
/* NAMLEN P Maximum length of module name. See TRCPKG. */
/* LL P Output line length. */
/* $ Detailed_Input */
/* LIST is a list of error message types. A list is a */
/* character string containing one or more words */
/* from the following list, separated by commas. */
/* SHORT */
/* EXPLAIN */
/* LONG */
/* TRACEBACK */
/* DEFAULT */
/* Each type of error message specified in LIST will */
/* be output when an error is detected, if it is */
/* enabled for output. Note that DEFAULT does */
/* NOT refer to the "default message selection," */
/* but rather to a special message that is output */
/* when the error action is 'DEFAULT'. This message */
/* is a statement referring the user to the error */
/* handling documentation. */
/* Messages are never duplicated in the output; for */
/* instance, supplying a value of LIST such as */
/* 'SHORT, SHORT' */
/* does NOT result in the output of two short */
/* messages. */
/* The words in LIST may appear in mixed case; */
/* for example, the call */
/* CALL OUTMSG ( 'ShOrT' ) */
/* will work. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* FILEN is the maximum device name length that can be */
/* accommodated by this routine. */
/* NAMELN is the maximum length of an individual module name. */
/* LL is the maximum line length for the output message. */
/* If the output message string is very long, it is */
/* displayed over several lines, each of which has a */
/* maximum length of LL characters. */
/* $ Exceptions */
/* 1) This routine detects invalid message types in the argument, */
/* LIST. The short error message in this case is */
/* 'SPICE(INVALIDLISTITEM)' */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine is part of the SPICELIB error handling */
/* mechanism. */
/* This routine outputs the error messages specified in LIST that */
/* have been enabled for output (use the SPICELIB routine ERRPRT */
/* to enable or disable output of specified types of error */
/* messages). A border is written out preceding and following the */
/* messages. Output is directed to the current error output device. */
/* $ Examples */
/* 1) Output the short and long error messages: */
/* C */
/* C Output short and long messages: */
/* C */
/* CALL OUTMSG ( 'SHORT, LONG' ) */
/* $ Restrictions */
/* 1) This routine is intended for use by the SPICELIB error */
/* handling mechanism. SPICELIB users are not expected to */
/* need to call this routine. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* K.R. Gehringer (JPL) */
/* H.A. Neilan (JPL) */
/* M.J. Spencer (JPL) */
/* $ Version */
/* - SPICELIB Version 5.27.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 5.26.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 5.25.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 5.24.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 5.23.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 5.22.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 5.21.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 5.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 5.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 5.18.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 5.17.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 5.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 5.15.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 5.14.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 5.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 5.12.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 5.11.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 5.10.0, 01-MAR-2009 (NJB) */
/* Bug fix: truncation of long words in */
/* output has been corrected. Local parameter */
/* TMPLEN was added and is used in declaration */
/* of TMPMSG. */
/* - SPICELIB Version 5.9.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 5.8.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 5.7.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 5.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 5.5.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 5.4.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 5.3.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 5.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 5.1.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 5.1.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 5.1.3, 24-SEP-1999 (NJB) */
/* CSPICE environments were added. Some typos were corrected. */
/* - SPICELIB Version 5.1.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 5.1.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 5.1.0, 13-JAN-1999 (BVS) */
/* ``errhnd.inc'' file was included. Long and short error */
/* message lengths parameter declarations were deleted. Long */
/* and short error message string sizes were changed to those */
/* declared in ``errhnd.inc''. */
/* - SPICELIB Version 5.0.0, 08-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 4.0.0, 09-MAY-1996 (KRG) */
/* Added the toolkit version to the output error message. */
/* Updated this routine to be consistent with the trace package */
/* revisions. This primarily affects the creation of the */
/* traceback string. */
/* Long error messages are now wrapped on word boundaries when */
/* they are longer than the output line length. Note that this */
/* only happens for long error messages obtained from GETLMS, */
/* and not for the error messages displayed by this subroutine */
/* and other error handling subroutines that write their own */
/* error messages. */
/* - SPICELIB Version 3.0.0, 09-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* for the Silicon Graphics, DEC Alpha-OSF/1, and */
/* NeXT platforms. Also, the previous value of 256 for */
/* Unix platforms was changed to 255. */
/* - SPICELIB Version 2.2.0, 12-OCT-1992 (HAN) */
/* Updated module for multiple environments. Moved the parameter */
/* LL to the Declarations section of the header since it's */
/* environment dependent. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 2.1.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 2.1.0, 15-MAY-1991 (MJS) */
/* Module was updated to include the value of LL for the */
/* Macintosh. */
/* - SPICELIB Version 2.0.0, 28-MAR-1991 (NJB) */
/* Work-around for MS Fortran compiler error under DOS 3.10 */
/* was made. Some substring bounds were simplified using RTRIM. */
/* Updates were made to the header to clarify the text and */
/* improve the header's appearance. The default error message */
/* was slightly de-uglified. */
/* The IBM PC version of this routine now uses an output line */
/* length of 78 characters rather than 80. This prevents */
/* wrapping of the message borders and default error message. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (NJB) */
/* -& */
/* $ Index_Entries */
/* None. */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 5.1.0, 13-JAN-1999 (BVS) */
/* ``errhnd.inc'' file was included. Long and short error */
/* message lengths parameter declarations were deleted. Long */
/* and short error message string size were changed to those */
/* declared in ``errhnd.inc''. */
/* - SPICELIB Version 5.0.0, 08-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 4.0.0, 09-MAY-1996 (KRG) */
/* Added the toolkit version to the output error message. */
/* Updated this routine to be consistent with the trace package */
/* revisions. This primarily affects the creation of the */
/* traceback string. */
/* Long error messages are now wrapped on word boundaries when */
/* they are longer than the output line length. Note that this */
/* only happens for long error messages obtained from GETLMS, */
/* and not for the error messages displayed by this subroutine */
/* and other error handling subroutines that write their own */
/* error messages. */
/* - SPICELIB Version 3.0.0, 9-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* for the Silicon Graphics, DEC Alpha-OSF/1, and */
/* NeXT platforms. Also, the previous value of 256 for */
/* Unix platforms was changed to 255. */
/* - SPICELIB Version 2.2.0, 12-OCT-1992 (HAN) */
/* Updated module for multiple environments. Moved the */
/* parameter LL to the Declarations section of the header since */
/* it's environment dependent. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 2.1.0, 15-MAY-1991 (MJS) */
/* Module was updated to include the value of LL for the */
/* Macintosh. */
/* - SPICELIB Version 2.0.0, 28-MAR-1991 (NJB) */
/* 1) Work-around for MS Fortran compiler error under DOS 3.10 */
/* was made. The compiler did not correctly handle code that */
/* concatenated strings whose bounds involved the intrinsic */
/* MAX function. */
/* 2) Some substring bounds were simplified using RTRIM. */
/* 3) Updates were made to the header to clarify the text and */
/* improve the header's appearance. */
/* 4) Declarations were re-organized. */
/* 5) The default error message was slightly de-uglified. */
/* 6) The IBM PC version of this routine now uses an output line */
/* length of 78 characters rather than 80. This prevents */
/* wrapping of the message borders and default error message. */
/* - Beta Version 1.3.0, 19-JUL-1989 (NJB) */
/* Calls to REMSUB removed; blanking and left-justifying used */
/* instead. This was done because REMSUB handles substring */
/* bounds differently than in previous versions, and no longer */
/* handles all possible inputs as required by this routine. */
/* LJUST, which is used now, is error free. */
/* Also, an instance of .LT. was changed to .LE. The old code */
/* caused a line break one character too soon. A minor bug, but */
/* a bug nonetheless. */
/* Also, two substring bounds were changed to ensure that they */
/* remain greater than zero. */
/* - Beta Version 1.2.0, 16-FEB-1989 (NJB) */
/* Warnings added to discourage use of this routine in */
/* non-error-handling code. Parameters section updated to */
/* describe FILEN and NAMLEN. */
/* Declaration of unused function FAILED removed. */
/* - Beta Version 1.1.0, 06-OCT-1988 (NJB) */
/* Test added to ensure substring upper bound is greater than 0. */
/* REMAIN must be greater than 0 when used as the upper bound */
/* for a substring of NAME. Also, substring upper bound in */
/* WRLINE call is now forced to be greater than 0. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* These parameters are system-independent. */
/* Local variables */
/* Saved variables */
/* Initial Values: */
/* Executable Code: */
/* The first time through, set up the output borders. */
if (first) {
first = FALSE_;
for (i__ = 1; i__ <= 80; ++i__) {
*(unsigned char *)&border[i__ - 1] = '=';
}
}
/* No messages are to be output which are not specified */
/* in LIST: */
short__ = FALSE_;
expl = FALSE_;
long__ = FALSE_;
trace = FALSE_;
dfault = FALSE_;
/* We parse the list of message types, and set local flags */
/* indicating which ones are to be output. If we find */
/* a word we don't recognize in the list, we signal an error */
/* and continue parsing the list. */
lparse_(list, ",", &c__5, &numwrd, words, list_len, (ftnlen)1, (ftnlen)9);
i__1 = numwrd;
for (i__ = 1; i__ <= i__1; ++i__) {
ucase_(words + ((i__2 = i__ - 1) < 5 && 0 <= i__2 ? i__2 : s_rnge(
"words", i__2, "outmsg_", (ftnlen)613)) * 9, upword, (ftnlen)
9, (ftnlen)9);
if (s_cmp(upword, "SHORT", (ftnlen)9, (ftnlen)5) == 0) {
short__ = TRUE_;
} else if (s_cmp(upword, "EXPLAIN", (ftnlen)9, (ftnlen)7) == 0) {
expl = TRUE_;
} else if (s_cmp(upword, "LONG", (ftnlen)9, (ftnlen)4) == 0) {
long__ = TRUE_;
} else if (s_cmp(upword, "TRACEBACK", (ftnlen)9, (ftnlen)9) == 0) {
trace = TRUE_;
} else if (s_cmp(upword, "DEFAULT", (ftnlen)9, (ftnlen)7) == 0) {
dfault = TRUE_;
} else {
/* Unrecognized word! This is an error... */
/* We have a special case on our hands; this routine */
/* is itself called by SIGERR, so a recursion error will */
/* result if this routine calls SIGERR. So we output */
/* the error message directly: */
getdev_(device, (ftnlen)255);
wrline_(device, "SPICE(INVALIDLISTITEM)", (ftnlen)255, (ftnlen)22)
;
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
wrline_(device, "OUTMSG: An invalid message type was specified "
"in the type list. ", (ftnlen)255, (ftnlen)65);
/* Writing concatenation */
i__3[0] = 29, a__1[0] = "The invalid message type was ";
i__3[1] = 9, a__1[1] = words + ((i__2 = i__ - 1) < 5 && 0 <= i__2
? i__2 : s_rnge("words", i__2, "outmsg_", (ftnlen)650)) *
9;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)38);
wrline_(device, ch__1, (ftnlen)255, (ftnlen)38);
}
}
/* LIST has been parsed. */
/* Now, we output those error messages that were specified by LIST */
/* and which belong to the set of messages selected for output. */
/* We get the default error output device: */
getdev_(device, (ftnlen)255);
output = short__ && msgsel_("SHORT", (ftnlen)5) || expl && msgsel_("EXPL"
"AIN", (ftnlen)7) || long__ && msgsel_("LONG", (ftnlen)4) || trace
&& msgsel_("TRACEBACK", (ftnlen)9) || dfault && msgsel_("DEFAULT",
(ftnlen)7) && s_cmp(device, "NULL", (ftnlen)255, (ftnlen)4) != 0;
/* We go ahead and output those messages that have been specified */
/* in the list and also are enabled for output. The order of the */
/* cases below IS significant; the order in which the messages */
/* appear in the output depends on it. */
/* If there's nothing to output, we can leave now. */
if (! output) {
return 0;
}
/* Write the starting border: skip a line, write the border, */
/* skip a line. */
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
wrline_(device, border, (ftnlen)255, (ftnlen)80);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
/* Output the toolkit version and skip a line. */
tkvrsn_("TOOLKIT", versn, (ftnlen)7, (ftnlen)80);
/* Writing concatenation */
i__3[0] = 17, a__1[0] = "Toolkit version: ";
i__3[1] = 80, a__1[1] = versn;
s_cat(line, a__1, i__3, &c__2, (ftnlen)80);
wrline_(device, line, (ftnlen)255, (ftnlen)80);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
/* Next, we output the messages specified in the list */
/* that have been enabled. */
/* We start with the short message and its accompanying */
/* explanation. If both are to be output, they are */
/* concatenated into a single message. */
if (short__ && msgsel_("SHORT", (ftnlen)5) && (expl && msgsel_("EXPLAIN",
(ftnlen)7))) {
/* Extract the short message from global storage; then get */
/* the corresponding explanation. */
getsms_(smsg, (ftnlen)25);
expln_(smsg, xmsg, (ftnlen)25, (ftnlen)80);
/* Writing concatenation */
i__4[0] = rtrim_(smsg, (ftnlen)25), a__2[0] = smsg;
i__4[1] = 4, a__2[1] = " -- ";
i__4[2] = 80, a__2[2] = xmsg;
s_cat(tmpmsg, a__2, i__4, &c__3, (ftnlen)105);
wrline_(device, tmpmsg, (ftnlen)255, (ftnlen)105);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
} else if (short__ && msgsel_("SHORT", (ftnlen)5)) {
/* Output the short error message without the explanation. */
getsms_(smsg, (ftnlen)25);
wrline_(device, smsg, (ftnlen)255, (ftnlen)25);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
} else if (expl && msgsel_("EXPLAIN", (ftnlen)7)) {
/* Obtain the explanatory text for the short error */
/* message and output it: */
getsms_(smsg, (ftnlen)25);
expln_(smsg, xmsg, (ftnlen)25, (ftnlen)80);
wrline_(device, xmsg, (ftnlen)255, (ftnlen)80);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
if (long__ && msgsel_("LONG", (ftnlen)4)) {
/* Extract the long message from global storage and */
/* output it: */
getlms_(lmsg, (ftnlen)1840);
/* Get the number of words in the error message. */
numwrd = wdcnt_(lmsg, (ftnlen)1840);
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
start = 1;
/* Format the words into output lines and display them as */
/* needed. */
i__1 = numwrd;
for (i__ = 1; i__ <= i__1; ++i__) {
nextwd_(lmsg, outwrd, lmsg, (ftnlen)1840, (ftnlen)1840, (ftnlen)
1840);
wrdlen = rtrim_(outwrd, (ftnlen)1840);
if (start + wrdlen <= 80) {
s_copy(line + (start - 1), outwrd, 80 - (start - 1), (ftnlen)
1840);
start = start + wrdlen + 1;
} else {
if (wrdlen <= 80) {
/* We had a short word, so just write the line and */
/* continue. */
wrline_(device, line, (ftnlen)255, (ftnlen)80);
start = wrdlen + 2;
s_copy(line, outwrd, (ftnlen)80, (ftnlen)1840);
} else {
/* We got a very long word here, so we break it up and */
/* write it out. We fit as much of it as we an into line */
/* as possible before writing it. */
/* Get the remaining space. If START is > 1 we have at */
/* least one word already in the line, including it's */
/* trailing space, otherwise the line is blank. If line */
/* is empty, we have all of the space available. */
if (start > 1) {
remain = 80 - start;
} else {
remain = 80;
}
/* Now we stuff bits of the word into the output line */
/* until we're done, i.e., until we have a word part */
/* that is less than the output length. First, we */
/* check to see if there is a "significant" amount of */
/* room left in the current output line. If not, we */
/* write it and then begin stuffing the long word into */
/* output lines. */
if (remain < 10) {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
remain = 80;
start = 1;
}
/* Stuff the word a chunk at a time into output lines */
/* and write them. After writing a line, we clear the */
/* part of the long word that we just wrote, left */
/* justifying the remaining part before proceeding. */
while(wrdlen > 80) {
s_copy(line + (start - 1), outwrd, 80 - (start - 1),
remain);
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(outwrd, " ", remain, (ftnlen)1);
ljust_(outwrd, outwrd, (ftnlen)1840, (ftnlen)1840);
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
wrdlen -= remain;
remain = 80;
start = 1;
}
/* If we had a part of the long word left, get set up to */
/* append more words from the error message to the output */
/* line. If we finished the word, WRDLEN .EQ. 0, then */
/* START and LINE have already been initialized. */
if (wrdlen > 0) {
start = wrdlen + 2;
s_copy(line, outwrd, (ftnlen)80, (ftnlen)1840);
}
}
}
}
/* We may need to write the remaining part of a line. */
if (s_cmp(line, " ", (ftnlen)80, (ftnlen)1) != 0) {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
}
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
if (trace && msgsel_("TRACEBACK", (ftnlen)9)) {
/* Extract the traceback from global storage and */
/* output it: */
trcdep_(&depth);
if (depth > 0) {
/* We know we'll be outputting some trace information. */
/* So, write a line telling the reader what's coming. */
wrline_(device, "A traceback follows. The name of the highest l"
"evel module is first.", (ftnlen)255, (ftnlen)68);
/* While there are more names in the traceback */
/* representation, we stuff them into output lines and */
/* write the lines out when they are full. */
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
remain = 80;
i__1 = depth;
for (index = 1; index <= i__1; ++index) {
/* For each module name in the traceback representation, */
/* retrieve module name and stuff it into one or more */
/* lines for output. */
/* Get a name and add the call order sign. We */
/* indicate calling order by a ' --> ' delimiter; e.g. */
/* "A calls B" is indicated by 'A --> B'. */
trcnam_(&index, name__, (ftnlen)32);
length = lastnb_(name__, (ftnlen)32);
/* If it's the first name, just put it into the output */
/* line, otherwise, add the call order sign and put the */
/* name into the output line. */
if (index == 1) {
suffix_(name__, &c__0, line, (ftnlen)32, (ftnlen)80);
remain -= length;
} else {
/* Add the calling order indicator, if it will fit. */
/* If not, write the line and put the indicator as */
/* the first thing on the next line. */
if (remain >= 4) {
suffix_("-->", &c__1, line, (ftnlen)3, (ftnlen)80);
remain += -4;
} else {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(line, "-->", (ftnlen)80, (ftnlen)3);
remain = 77;
}
/* The name fits or it doesn't. If it does, just add */
/* it, if it doesn't, write it, then make the name */
/* the first thing on the next line. */
if (remain >= length) {
suffix_(name__, &c__1, line, (ftnlen)32, (ftnlen)80);
remain = remain - length - 1;
} else {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(line, name__, (ftnlen)80, (ftnlen)32);
remain = 80 - length;
}
}
}
/* At this point, no more names are left in the */
/* trace representation. LINE may still contain */
/* names, or part of a long name. If it does, */
/* we now write it out. */
if (s_cmp(line, " ", (ftnlen)80, (ftnlen)1) != 0) {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
}
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
/* At this point, either we have output the trace */
/* representation, or the trace representation was */
/* empty. */
}
if (dfault && msgsel_("DEFAULT", (ftnlen)7)) {
/* Output the default message: */
for (i__ = 1; i__ <= 4; ++i__) {
wrline_(device, defmsg + ((i__1 = i__ - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("defmsg", i__1, "outmsg_", (ftnlen)971)) *
80, (ftnlen)255, (ftnlen)80);
}
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
/* At this point, we've output all of the enabled messages */
/* that were specified in LIST. At least one message that */
/* was specified was enabled. */
/* Write the ending border out: */
wrline_(device, border, (ftnlen)255, (ftnlen)80);
return 0;
} /* outmsg_ */
/* $Procedure ZZRVAR ( Private --- Pool, read the next kernel variable ) */
/* Subroutine */ int zzrvar_(integer *namlst, integer *nmpool, char *names,
integer *datlst, integer *dppool, doublereal *dpvals, integer *chpool,
char *chvals, char *varnam, logical *eof, ftnlen names_len, ftnlen
chvals_len, ftnlen varnam_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen), s_rnge(char *, integer, char *, integer),
s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer head, code, itab;
static char name__[132], file[255];
static integer free, begs[132], node;
static char line[132];
static integer tail, ends[132];
static logical even, full;
static integer type__[132], b, e, i__, j, badat;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen), lnkan_(integer *, integer *);
static logical found;
static integer ncomp, lstnb, count;
static char error[255];
static integer iplus;
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int zzcln_(integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer r1, r2;
extern logical failed_(void);
static integer at, datahd, iblank, chnode, icomma, nameat, dpnode;
extern /* Subroutine */ int rdkdat_(char *, logical *, ftnlen), lnkila_(
integer *, integer *, integer *);
static integer iequal;
extern integer lastnb_(char *, ftnlen), lastpc_(char *, ftnlen), lnknfn_(
integer *);
static integer ilparn, irparn, itmark;
static doublereal dvalue;
static integer dirctv, lookat, iquote;
extern integer zzhash_(char *, ftnlen);
static integer number, varlen;
static logical intokn, insepf;
extern logical return_(void);
static logical inquot;
static integer status, vartyp;
extern /* Subroutine */ int chkout_(char *, ftnlen);
static integer nxttok;
extern /* Subroutine */ int rdklin_(char *, integer *, ftnlen), setmsg_(
char *, ftnlen), errint_(char *, integer *, ftnlen), sigerr_(char
*, ftnlen), lnkfsl_(integer *, integer *, integer *), tparse_(
char *, doublereal *, char *, ftnlen, ftnlen), nparsd_(char *,
doublereal *, char *, integer *, ftnlen, ftnlen);
/* $ Abstract */
/* SPICE Private routine intended solely for the support of SPICE */
/* routines. Users should not call this routine directly due */
/* to the volatile nature of this routine. */
/* Read the next variable from a SPICE ASCII kernel file into */
/* the kernel pool. */
/* $ 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 */
/* PRIVATE KERNEL */
/* $ Keywords */
/* FILES */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* NAMLST I/O array of collision resolution list heads. */
/* NMPOOL I/O linked list pool of collision resolution lists. */
/* NAMES I/O array of names of kernel pool variables. */
/* DATLST I/O array of heads of lists of variable values. */
/* DPPOOL I/O linked list pool of pointer lists to d.p. values. */
/* DPVALS I/O array of d.p. kernel pool values. */
/* CHPOOL I/O linked list pool of pointer lists to string values. */
/* CHVALS I/O array of string kernel pool values. */
/* VARNAM O name of variable parsed. */
/* EOF O if TRUE end of input file has been reached. */
/* $ Detailed_Input */
/* NAMLST this collection of arrays together with the hash */
/* NMPOOL function ZZHASH provide the mechanism for storing */
/* NAMES and retrieving kernel pool variables. */
/* DATLST */
/* DPPOOL Given a potential variable name NAME the function */
/* DPVALS ZZHASH(NAME) gives the location in the array in */
/* CHPOOL NAMLST where one should begin looking for the */
/* CHVALS kernel pool variable NAME. */
/* If NAMLST( ZZHASH(NAME) ) is zero, there is no kernel */
/* pool variable corresponding to NAME. If it is non-zero */
/* then NAMLST is the head node of a linked list of names */
/* that evaluate to the same integer under the function */
/* ZZHASH. Letting NODE = NAMLST( ZZHASH(NAME) ) check */
/* NAMES(NODE) for equality with NAME. If there is */
/* no match find the next node ( NMPOOL(NEXT,NODE) ) until */
/* a match occurs or all nodes of the list have been */
/* examined. To insert a new NAME allocate a node NEW from */
/* the free list of NMPOOL and append it to the tail of the */
/* list pointed to by NAMLST ( ZZHASH(NAME) ). */
/* Once a node for NAME is located (call it NAMEAT) */
/* the values for NAME can be found by examining */
/* DATLST(NAMEAT). If zero, no values have yet been */
/* given to NAME. If less than zero, -DATLST(NAMEAT) */
/* is the head node of a list in CHPOOL that gives the */
/* indexes of the values of NAME in CHVALS. If greater */
/* than zero, DATLST(NAMEAT) is the head node of a list */
/* in DPPOOL that gives the indexes of the values of NAME */
/* in DPVALS. */
/* $ Detailed_Output */
/* NAMLST is the same structure as input but updated to */
/* NMPOOL include the next variable read from the current */
/* NAMES active text kernel in RDKER. */
/* DATLST */
/* DPPOOL */
/* DPVALS */
/* CHPOOL */
/* CHVALS */
/* VARNAM is the name of the variable. VARNAM is blank if */
/* no variable is read. */
/* EOF is true when the end of the kernel file has been */
/* reached, and is false otherwise. The kernel file */
/* is closed automatically when the end of the file */
/* is reached. */
/* $ Parameters */
/* LINLEN is the maximum length of a line in the kernel file. */
/* MAXLEN is the maximum length of the variable names that */
/* can be stored in the kernel pool (also set in */
/* pool.f). */
/* $ Exceptions */
/* 1) The error 'SPICE(BADTIMESPEC)' is signaled if a value */
/* beginning with '@' cannot be parsed as a time. */
/* 2) The error 'SPICE(BADVARASSIGN)' is signaled if variable */
/* assignment does not have the form NAME = [(] value [ value ) ]. */
/* 3) The error 'SPICE(KERNELPOOLFULL)' is signaled if there is */
/* no room left in the kernel pool to store another variable */
/* or value. */
/* 4) The error 'SPICE(NONPRINTINGCHAR)' is signaled if the name */
/* in a variable assignment contains a non-printing character. */
/* 5) The error 'SPICE(NUMBEREXPECTED)' is signaled if a value */
/* that is unquoted cannot be parsed as time or number. */
/* 6) The error 'SPICE(TYPEMISMATCH)' is signalled if a variable */
/* has a first value of one type (numeric or character) and */
/* a subsequent component has the other type. */
/* 7) The error 'SPICE(BADVARNAME)' signals if a kernel pool */
/* variable name length exceeds MAXLEN. */
/* $ Files */
/* ZZRVAR reads from the file most recently opened by RDKNEW. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* See POOL (entry point LDPOOL). */
/* $ Restrictions */
/* The input file must be opened and initialized by RDKNEW prior */
/* to the first call to ZZRVAR. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 1.7.0, 08-FEB-2010 (EDW) */
/* Added an error check on the length of the kernel pool variable */
/* name read from the kernel file. */
/* - SPICELIB Version 1.6.0, 06-AUG-2002 (BVS) */
/* Modified to make sure that DO WHILE loop that looks for the */
/* end of string variable value always exits. */
/* - SPICELIB Version 1.5.0, 07-APR-2000 (WLT) */
/* Happy Birthday Alex. Added check to the assignment to CHVALS */
/* so that we cannot store data past the end of the string. */
/* - SPICELIB Version 1.4.0, 22-MAR-1999 (WLT) */
/* Added code to detect and signal an error for empty */
/* vector assignment. */
/* - SPICELIB Version 1.3.0, 16-JAN-1997 (WLT) */
/* The error message regarding the directives allowed */
/* in a keyword = value directive was updated. */
/* - SPICELIB Version 1.1.0, 25-JUN-1996 (WLT) */
/* The error message for unparsed numeric components */
/* was corrected so that it now shows the line and */
/* line number on which the error occurred. */
/* - SPICELIB Version 1.0.0, 20-SEP-1995 (WLT) */
/* -& */
/* SPICELIB functions */
/* Local parameters. */
/* Below are a collection of enumerated lists that are used */
/* to discern what part of the processing we are in and what */
/* kind of entity we are dealing with. First the overall */
/* processing flow of a variable assignment. */
/* Next we have the various types of tokens that can be found */
/* in the parsing of an input line */
/* Q --- quoted (or protected tokens) */
/* NQ --- unquoted tokens */
/* BV --- beginning of a vector */
/* EV --- ending of a vector */
/* EQ --- equal sign */
/* EQP --- equal sign plus */
/* A variable can have one of three types as we process */
/* it. It can have an unknown type UNKNWN, STRTYP or NUMTYP. */
/* The next two parameters indicate which component of a linked */
/* list node point to the previous node and the next node. */
/* The next collection of variables are set up in first pass */
/* through this routine. They would be parameters if FORTRAN */
/* allowed us to do this in a standard way. */
/* The logicals below are used to take apart the tokens in an */
/* input line. */
/* The following logicals are in-line functions that are used */
/* when processing the input strings. */
/* Save everything. */
/* Below are a collection of In-line function definitions that are */
/* intended to make the code a bit easier to write and read. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZRVAR", (ftnlen)6);
}
/* Initializations. */
if (first) {
first = FALSE_;
icomma = ',';
iblank = ' ';
iquote = '\'';
ilparn = '(';
irparn = ')';
iequal = '=';
iplus = '+';
itmark = '@';
itab = 9;
}
/* No variable yet and no parsing errors so far. */
s_copy(name__, " ", (ftnlen)132, (ftnlen)1);
s_copy(error, " ", (ftnlen)255, (ftnlen)1);
ncomp = 0;
/* Get the next data line. Unless something is terribly wrong, */
/* this will begin a new variable definition. We have to read */
/* the whole variable, unless we get an error, in which case */
/* we can quit. */
status = 1;
while(status != 2 && ! failed_()) {
rdkdat_(line, eof, (ftnlen)132);
if (*eof) {
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
/* Find the "tokens" in the input line. As you scan from left */
/* to right along the line, exactly one of the following */
/* conditions is true. */
/* 1) You are in a separator field */
/* 4) You are in a quoted substring */
/* 5) You are in a non-quoted substring that isn't a separator */
/* field. */
/* Stuff between separator fields are regarded as tokens. Note */
/* this includes quoted strings. */
/* In addition we keep track of 3 separators: '=', '(', ')' */
/* Finally, whenever we encounters the separator '=', we back */
/* up and see if it is preceded by a '+', if so we attach */
/* it to the '=' and treat the pair of characters as a single */
/* separator. */
even = TRUE_;
intokn = FALSE_;
inquot = FALSE_;
insepf = TRUE_;
count = 0;
i__ = 0;
while(i__ < i_len(line, (ftnlen)132)) {
/* The current character is either a separator, quote or */
/* some other character. */
++i__;
code = *(unsigned char *)&line[i__ - 1];
if (code == iblank || code == icomma || code == ilparn || code ==
irparn || code == iequal || code == itab) {
/* There are 3 possible states we could be in */
/* Separation Field */
/* A quoted substring with the last quote an odd one. */
/* A quoted substring with the last quote an even one. */
/* A non-quoted token. */
/* In the first two cases nothing changes, but in the */
/* next two cases we transition to a separation field. */
if (intokn || inquot && even) {
inquot = FALSE_;
intokn = FALSE_;
insepf = TRUE_;
}
if (insepf) {
/* We need to see if this is one of the special */
/* separators */
if (code == iequal) {
++count;
begs[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("begs", i__1, "zzrvar_", (ftnlen)555)]
= i__;
type__[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("type", i__1, "zzrvar_", (ftnlen)556)]
= 5;
ends[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("ends", i__1, "zzrvar_", (ftnlen)557)]
= i__;
if (i__ > 1) {
/* Look back at the previous character. */
/* See if it is a plus character. */
i__1 = i__ - 2;
code = *(unsigned char *)&line[i__1];
if (code == iplus) {
/* This is the directive '+=' we need */
/* to set the beginning of this token */
/* to the one before this and adjust */
/* the end of the last token. */
type__[(i__1 = count - 1) < 132 && 0 <= i__1 ?
i__1 : s_rnge("type", i__1, "zzrvar_"
, (ftnlen)573)] = 6;
begs[(i__1 = count - 1) < 132 && 0 <= i__1 ?
i__1 : s_rnge("begs", i__1, "zzrvar_",
(ftnlen)574)] = i__ - 1;
if (begs[(i__1 = count - 2) < 132 && 0 <=
i__1 ? i__1 : s_rnge("begs", i__1,
"zzrvar_", (ftnlen)576)] == ends[(
i__2 = count - 2) < 132 && 0 <= i__2 ?
i__2 : s_rnge("ends", i__2, "zzrvar_"
, (ftnlen)576)]) {
--count;
begs[(i__1 = count - 1) < 132 && 0 <=
i__1 ? i__1 : s_rnge("begs", i__1,
"zzrvar_", (ftnlen)580)] = i__ -
1;
ends[(i__1 = count - 1) < 132 && 0 <=
i__1 ? i__1 : s_rnge("ends", i__1,
"zzrvar_", (ftnlen)581)] = i__;
type__[(i__1 = count - 1) < 132 && 0 <=
i__1 ? i__1 : s_rnge("type", i__1,
"zzrvar_", (ftnlen)582)] = 6;
} else {
ends[(i__1 = count - 2) < 132 && 0 <=
i__1 ? i__1 : s_rnge("ends", i__1,
"zzrvar_", (ftnlen)586)] = ends[(
i__2 = count - 2) < 132 && 0 <=
i__2 ? i__2 : s_rnge("ends", i__2,
"zzrvar_", (ftnlen)586)] - 1;
}
}
}
} else if (code == irparn) {
++count;
begs[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("begs", i__1, "zzrvar_", (ftnlen)597)]
= i__;
ends[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("ends", i__1, "zzrvar_", (ftnlen)598)]
= i__;
type__[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("type", i__1, "zzrvar_", (ftnlen)599)]
= 4;
} else if (code == ilparn) {
++count;
begs[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("begs", i__1, "zzrvar_", (ftnlen)604)]
= i__;
ends[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("ends", i__1, "zzrvar_", (ftnlen)605)]
= i__;
type__[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("type", i__1, "zzrvar_", (ftnlen)606)]
= 3;
}
}
} else if (code == iquote) {
/* There are 3 cases of interest. */
/* We are in a quoted substring already */
/* We are in a separator field */
/* We are in a non-quoted token. */
/* In the first case nothing changes. In the second */
/* two cases we change to being in a quoted substring. */
even = ! even;
if (! inquot) {
insepf = FALSE_;
intokn = FALSE_;
inquot = TRUE_;
++count;
begs[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("begs", i__1, "zzrvar_", (ftnlen)629)] =
i__;
type__[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("type", i__1, "zzrvar_", (ftnlen)630)] = 1;
}
ends[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 : s_rnge(
"ends", i__1, "zzrvar_", (ftnlen)634)] = i__;
} else {
/* This is some character other than a quote, or */
/* separator character. */
/* We are in one of four situations. */
/* 1) We are in a quoted substring with an odd number of */
/* quotes. */
/* 2) We are in a quoted substring with an even number of */
/* quotes. */
/* 2) We are in a separator field */
/* 3) We are in a non-quoted token. */
/* In cases 1 and 3 nothing changes. So we won't check */
/* those cases. */
if (insepf || inquot && even) {
inquot = FALSE_;
insepf = FALSE_;
intokn = TRUE_;
++count;
begs[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("begs", i__1, "zzrvar_", (ftnlen)659)] =
i__;
type__[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("type", i__1, "zzrvar_", (ftnlen)660)] = 2;
}
ends[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 : s_rnge(
"ends", i__1, "zzrvar_", (ftnlen)663)] = i__;
}
}
/* The first word on the first line should be the name of a */
/* variable. The second word should be a directive: = or +=. */
if (status == 1) {
/* There must be at least 3 contributing tokens on this line. */
if (count < 3) {
rdklin_(file, &number, (ftnlen)255);
setmsg_("A kernel variable was not properly formed on line #"
" of the file #. Such an assignment should have the f"
"orm: '<variable name> [+]= <values>'. This line was "
"'#'. ", (ftnlen)160);
r1 = rtrim_(file, (ftnlen)255);
r2 = rtrim_(line, (ftnlen)132);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r1);
errch_("#", line, (ftnlen)1, r2);
sigerr_("SPICE(BADVARASSIGN)", (ftnlen)19);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
/* See if the variable name is legitimate: */
i__1 = begs[0] - 1;
badat = lastpc_(line + i__1, ends[0] - i__1);
if (badat <= ends[0] - begs[0]) {
/* There is a non-printing character in the variable */
/* name. This isn't allowed. */
at = begs[0] + badat;
rdklin_(file, &number, (ftnlen)255);
r1 = rtrim_(file, (ftnlen)255);
setmsg_("There is a non-printing character embedded in line "
"# of the text kernel file #. Non-printing character"
"s are not allowed in kernel variable assignments. T"
"he non-printing character has ASCII code #. ", (
ftnlen)199);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r1);
i__1 = *(unsigned char *)&line[at - 1];
errint_("#", &i__1, (ftnlen)1);
sigerr_("SPICE(NONPRINTINGCHAR)", (ftnlen)22);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
/* Check the variable name length; signal an error */
/* if longer than MAXLEN. */
i__1 = begs[0] - 1;
varlen = i_len(line + i__1, ends[0] - i__1);
if (varlen > 32) {
setmsg_("A kernel pool variable name read from a kernel file"
" exceeds the maximum allowed length #1. The actual l"
"ength of the variable name is #2, the offending vari"
"able name to #3 characters: '#4'.", (ftnlen)188);
errint_("#1", &c__32, (ftnlen)2);
errint_("#2", &varlen, (ftnlen)2);
errint_("#3", &c__132, (ftnlen)2);
i__1 = begs[0] - 1;
errch_("#4", line + i__1, (ftnlen)2, ends[0] - i__1);
sigerr_("SPICE(BADVARNAME)", (ftnlen)17);
}
/* The variable name is ok. How about the directive. */
i__1 = begs[0] - 1;
s_copy(varnam, line + i__1, varnam_len, ends[0] - i__1);
dirctv = type__[1];
/* If this is replacement (=) and not an addition (+=), */
/* delete the values currently associated with the variable. */
/* They will be replaced later. */
if (dirctv != 5 && dirctv != 6) {
rdklin_(file, &number, (ftnlen)255);
setmsg_("A kernel variable was not properly formed on line #"
" of the file #. Such an assignment should have the f"
"orm: '<variable name> [+]= <values>'. More specific"
"ally, the assignment operator did not have one of th"
"e expected forms: '=' or '+='. The line was '#'. ", (
ftnlen)256);
r1 = rtrim_(file, (ftnlen)255);
r2 = rtrim_(line, (ftnlen)132);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r1);
errch_("#", line, (ftnlen)1, r2);
sigerr_("SPICE(BADVARASSIGN)", (ftnlen)19);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
/* Locate this variable name in the name pool or insert it */
/* if it isn't there. The location will be NAMEAT and */
/* we will use the variable FOUND to indicate whether or */
/* not it was already present. */
lookat = zzhash_(varnam, varnam_len);
node = namlst[lookat - 1];
full = lnknfn_(nmpool) <= 0;
found = FALSE_;
/* See if this name (or one colliding with it in the */
/* hash scheme) has already been stored in the name list. */
if (node > 0) {
head = node;
tail = -nmpool[(head << 1) + 11];
while(node > 0 && ! found) {
found = s_cmp(names + (node - 1) * names_len, varnam,
names_len, varnam_len) == 0;
nameat = node;
node = nmpool[(node << 1) + 10];
}
if (! found && ! full) {
/* We didn't find this name on the conflict resolution */
/* list. Allocate a new slot for it. */
lnkan_(nmpool, &node);
lnkila_(&tail, &node, nmpool);
s_copy(names + (node - 1) * names_len, varnam, names_len,
varnam_len);
nameat = node;
}
} else if (! full) {
/* Nothing like this variable name (in the hashing sense) */
/* has been loaded so far. We need to allocate */
/* a name slot for this variable. */
lnkan_(nmpool, &node);
namlst[lookat - 1] = node;
s_copy(names + (node - 1) * names_len, varnam, names_len,
varnam_len);
nameat = node;
}
/* If the name pool was full and we didn't find this name */
/* we've got an error. Diagnose it and return. */
if (full && ! found) {
rdklin_(file, &number, (ftnlen)255);
r1 = rtrim_(file, (ftnlen)255);
setmsg_("The kernel pool does not have room for any more var"
"iables. It filled up at line # of the kernel file #"
". ", (ftnlen)105);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r1);
sigerr_("SPICE(KERNELPOOLFULL)", (ftnlen)21);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
/* Now depending upon the kind of directive, we will need */
/* to remove data and allocate a new list or simply append */
/* data to the existing list. */
if (dirctv == 5) {
/* We are going to dump whatever is associated with */
/* this name and then we will need to allocate a new */
/* linked list for the data. */
vartyp = 3;
if (found) {
/* We need to free the data associated with this */
/* variable. */
datahd = datlst[nameat - 1];
datlst[nameat - 1] = 0;
if (datahd < 0) {
/* This variable was character type we need to */
/* free a linked list from the character data */
/* pool. */
head = -datahd;
tail = -chpool[(head << 1) + 11];
lnkfsl_(&head, &tail, chpool);
} else {
/* This variable was numeric type. We need to */
/* free a linked list from the numeric pool. */
head = datahd;
tail = -dppool[(head << 1) + 11];
lnkfsl_(&head, &tail, dppool);
}
}
} else if (dirctv == 6) {
/* We need to append to the current variable. */
if (found) {
if (datlst[nameat - 1] > 0) {
vartyp = 2;
} else if (datlst[nameat - 1] < 0) {
vartyp = 1;
} else {
vartyp = 3;
}
} else {
vartyp = 3;
}
}
/* If this is a vector, the next thing on the line will be a */
/* left parenthesis. Otherwise, assume that this is a scalar. */
/* If it's a vector, get the first value. If it's a scalar, */
/* plant a bogus right parenthesis, to make the following loop */
/* terminate after one iteration. */
if (type__[2] == 3) {
nxttok = 4;
} else {
nxttok = 3;
++count;
type__[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 : s_rnge(
"type", i__1, "zzrvar_", (ftnlen)950)] = 4;
}
/* For subsequent lines, treat everything as a new value. */
} else {
nxttok = 1;
}
/* We have a value anyway. Store it in the table. */
/* Keep going until the other shoe (the right parenthesis) */
/* drops, or until the end of the line is reached. */
/* Dates begin with @; anything else is presumed to be a number. */
while(type__[(i__1 = nxttok - 1) < 132 && 0 <= i__1 ? i__1 : s_rnge(
"type", i__1, "zzrvar_", (ftnlen)971)] != 4 && nxttok <=
count) {
/* Get the begin and end of this token. */
b = begs[(i__1 = nxttok - 1) < 132 && 0 <= i__1 ? i__1 : s_rnge(
"begs", i__1, "zzrvar_", (ftnlen)975)];
e = ends[(i__1 = nxttok - 1) < 132 && 0 <= i__1 ? i__1 : s_rnge(
"ends", i__1, "zzrvar_", (ftnlen)976)];
if (vartyp == 3) {
/* We need to determine which category of variable we */
/* have by looking at this token and deducing the */
/* type. */
if (type__[(i__1 = nxttok - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("type", i__1, "zzrvar_", (ftnlen)984)] == 1) {
vartyp = 1;
} else if (type__[(i__1 = nxttok - 1) < 132 && 0 <= i__1 ?
i__1 : s_rnge("type", i__1, "zzrvar_", (ftnlen)988)]
== 2) {
vartyp = 2;
} else {
/* This is an error. We should have had one of the */
/* two previous types. */
/* First perform the clean up function. */
zzcln_(&lookat, &nameat, namlst, datlst, nmpool, chpool,
dppool);
rdklin_(file, &number, (ftnlen)255);
r1 = rtrim_(file, (ftnlen)255);
setmsg_("The first item following the assignment operato"
"r should be the value of a variable or a left pa"
"renthesis '(' followed by a value for a variable"
". This is not true on line # of the text kernel "
"file '#'. ", (ftnlen)201);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r1);
sigerr_("SPICE(BADVARASSIGN)", (ftnlen)19);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
}
if (vartyp == 1) {
/* First make sure that this token represents a string. */
if (type__[(i__1 = nxttok - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("type", i__1, "zzrvar_", (ftnlen)1029)] != 1) {
/* First perform the clean up function. */
zzcln_(&lookat, &nameat, namlst, datlst, nmpool, chpool,
dppool);
rdklin_(file, &number, (ftnlen)255);
r1 = rtrim_(varnam, varnam_len);
r2 = rtrim_(file, (ftnlen)255);
setmsg_("The kernel variable # has been set up as a stri"
"ng variable. However, the value that you are at"
"tempting to assign to this variable on line # of"
" the kernel file '#' is not a string value. ", (
ftnlen)187);
errch_("#", varnam, (ftnlen)1, r1);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r2);
sigerr_("SPICE(TYPEMISMATCH)", (ftnlen)19);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
/* Still going? Make sure there is something between */
/* the quotes. */
if (b + 1 >= e) {
/* First perform the clean up function. */
zzcln_(&lookat, &nameat, namlst, datlst, nmpool, chpool,
dppool);
rdklin_(file, &number, (ftnlen)255);
r1 = rtrim_(file, (ftnlen)255);
setmsg_("There is a quoted string with no characters on "
"line # of the text kernel file '#'. ", (ftnlen)83)
;
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r1);
sigerr_("SPICE(TYPEMISMATCH)", (ftnlen)19);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
/* We are ready to go. Allocate a node for this data */
/* item. First make sure there is room to do so. */
free = lnknfn_(chpool);
if (free <= 0) {
rdklin_(file, &number, (ftnlen)255);
r1 = rtrim_(file, (ftnlen)255);
setmsg_("There is no room available for adding another c"
"haracter value to the kernel pool. The characte"
"r values buffer became full at line # of the tex"
"t kernel file '#'. ", (ftnlen)162);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r1);
sigerr_("SPICE(KERNELPOOLFULL)", (ftnlen)21);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
/* Allocate a node for storing this string value: */
lnkan_(chpool, &chnode);
if (datlst[nameat - 1] == 0) {
/* There was no data for this name yet. We make */
/* CHNODE be the head of the data list for this name. */
datlst[nameat - 1] = -chnode;
} else {
/* Put this node after the tail of the current list. */
head = -datlst[nameat - 1];
tail = -chpool[(head << 1) + 11];
lnkila_(&tail, &chnode, chpool);
}
/* Finally insert this data item in the data buffer */
/* at CHNODE. Note any quotes will be doubled so we */
/* have to undo this affect when we store the data. */
s_copy(chvals + (chnode - 1) * chvals_len, " ", chvals_len, (
ftnlen)1);
++ncomp;
/* Adjust end-of-token position (E) if it happens to the */
/* last, non-quote character of the truncated input line. */
/* This has to be done to make sure that all meaningful */
/* characters get moved to the value. */
code = *(unsigned char *)&line[e - 1];
if (! (code == iquote)) {
++e;
}
i__ = 1;
j = b + 1;
while(j < e) {
code = *(unsigned char *)&line[j - 1];
if (code == iquote) {
++j;
}
if (i__ <= i_len(chvals + (chnode - 1) * chvals_len,
chvals_len)) {
*(unsigned char *)&chvals[(chnode - 1) * chvals_len +
(i__ - 1)] = *(unsigned char *)&line[j - 1];
++i__;
++j;
} else {
++j;
}
}
/* That's all for this value. It's now time to loop */
/* back through and get the next value. */
} else {
if (type__[(i__1 = nxttok - 1) < 132 && 0 <= i__1 ? i__1 :
s_rnge("type", i__1, "zzrvar_", (ftnlen)1175)] != 2) {
/* First perform the clean up function. */
zzcln_(&lookat, &nameat, namlst, datlst, nmpool, chpool,
dppool);
rdklin_(file, &number, (ftnlen)255);
r1 = rtrim_(varnam, varnam_len);
r2 = rtrim_(file, (ftnlen)255);
setmsg_("The kernel variable # has been set up as a nume"
"ric or time variable. However, the value that y"
"ou are attempting to assign to this variable on "
"line # of the kernel file '#' is not a numeric o"
"r time value. ", (ftnlen)205);
errch_("#", varnam, (ftnlen)1, r1);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r2);
sigerr_("SPICE(TYPEMISMATCH)", (ftnlen)19);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
/* Look at the first character to see if we have a time */
/* or a number. */
code = *(unsigned char *)&line[b - 1];
if (code == itmark) {
/* We need to have more than a single character. */
if (e == b) {
/* First perform the clean up function. */
zzcln_(&lookat, &nameat, namlst, datlst, nmpool,
chpool, dppool);
rdklin_(file, &number, (ftnlen)255);
r1 = rtrim_(varnam, varnam_len);
r2 = rtrim_(file, (ftnlen)255);
setmsg_("At character # of line # in the text kerne"
"l file '#' the character '@' appears. This "
"character is reserved for identifying time v"
"alues in assignments to kernel pool variable"
"s. However it is not being used in this fas"
"hion for the variable '#'. ", (ftnlen)246);
errint_("#", &b, (ftnlen)1);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r2);
errch_("#", varnam, (ftnlen)1, r1);
sigerr_("SPICE(BADTIMESPEC)", (ftnlen)18);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
i__1 = b;
tparse_(line + i__1, &dvalue, error, e - i__1, (ftnlen)
255);
if (s_cmp(error, " ", (ftnlen)255, (ftnlen)1) != 0) {
/* First perform the clean up function. */
zzcln_(&lookat, &nameat, namlst, datlst, nmpool,
chpool, dppool);
rdklin_(file, &number, (ftnlen)255);
r1 = rtrim_(file, (ftnlen)255);
lstnb = lastnb_(error, (ftnlen)255);
setmsg_("Encountered '#' while attempting to parse a"
" time on line # of the text kernel file '#'."
" Error message: '#'", (ftnlen)107);
i__1 = b;
errch_("#", line + i__1, (ftnlen)1, e - i__1);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, (ftnlen)255);
errch_("#", error, (ftnlen)1, lstnb);
sigerr_("SPICE(BADTIMESPEC)", (ftnlen)18);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
} else {
nparsd_(line + (b - 1), &dvalue, error, &i__, e - (b - 1),
(ftnlen)255);
if (s_cmp(error, " ", (ftnlen)255, (ftnlen)1) != 0) {
zzcln_(&lookat, &nameat, namlst, datlst, nmpool,
chpool, dppool);
rdklin_(file, &number, (ftnlen)255);
lstnb = lastnb_(error, (ftnlen)255);
setmsg_("Encountered '#' while attempting to parse a"
" number on line # of the text kernel file '#"
"'. Error message: '#'", (ftnlen)109);
errch_("#", line + (b - 1), (ftnlen)1, e - (b - 1));
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, (ftnlen)255);
errch_("#", error, (ftnlen)1, lstnb);
sigerr_("SPICE(NUMBEREXPECTED)", (ftnlen)21);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
}
/* OK. We have a parsed value. See if there is room in */
/* the numeric portion of the pool to store this value. */
free = lnknfn_(dppool);
if (free <= 0) {
rdklin_(file, &number, (ftnlen)255);
r1 = rtrim_(file, (ftnlen)255);
setmsg_("There is no room available for adding another n"
"umeric value to the kernel pool. The numeric va"
"lues buffer became full at line # of the text ke"
"rnel file '#'. ", (ftnlen)158);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r1);
sigerr_("SPICE(KERNELPOOLFULL)", (ftnlen)21);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
/* Allocate a node for storing this numeric value: */
lnkan_(dppool, &dpnode);
if (datlst[nameat - 1] == 0) {
/* There was no data for this name yet. We make */
/* DPNODE be the head of the data list for this name. */
datlst[nameat - 1] = dpnode;
} else {
/* Put this node after the tail of the current list. */
head = datlst[nameat - 1];
tail = -dppool[(head << 1) + 11];
lnkila_(&tail, &dpnode, dppool);
}
/* Finally insert this data item into the numeric buffer. */
dpvals[dpnode - 1] = dvalue;
++ncomp;
}
/* Now process the next token in the list of tokens. */
++nxttok;
}
/* We could have ended the above loop in one of two ways. */
/* 1) NXTTOK now exceeds count. This means we did not reach */
/* an end of vector marker. */
/* 2) We hit an end of vector marker. */
if (nxttok > count) {
status = 3;
} else {
status = 2;
}
}
/* It is possible that we reached this point without actually */
/* assigning a value to the kernel pool variable. This can */
/* happen if there is a vector input of the form NAME = ( ) */
if (ncomp < 1) {
zzcln_(&lookat, &nameat, namlst, datlst, nmpool, chpool, dppool);
rdklin_(file, &number, (ftnlen)255);
r1 = rtrim_(file, (ftnlen)255);
setmsg_("The first item following the assignment operator should be "
"the value of a variable or a left parenthesis '(' followed b"
"y a value for a variable. This is not true on line # of the "
"text kernel file '#'. ", (ftnlen)201);
errint_("#", &number, (ftnlen)1);
errch_("#", file, (ftnlen)1, r1);
sigerr_("SPICE(BADVARASSIGN)", (ftnlen)19);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
}
/* Return the name of the variable. */
s_copy(name__, varnam, (ftnlen)132, varnam_len);
chkout_("ZZRVAR", (ftnlen)6);
return 0;
} /* zzrvar_ */
/* $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_ */
/* $Procedure EDTCMD ( Edit a file using a specified text editor ) */
/* Subroutine */ int edtcmd_(char *cmd, char *file, ftnlen cmd_len, ftnlen
file_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern integer rtrim_(char *, ftnlen);
char loccmd[255];
extern /* Subroutine */ int chkout_(char *, ftnlen), suffix_(char *,
integer *, char *, ftnlen, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int exesys_(char *, ftnlen);
/* $ Abstract */
/* Edit a file using a specified editor. */
/* $ 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 */
/* SYSTEM */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* CMD I Command string used to invoke editor. */
/* FILE I Name of file to edit. */
/* $ Detailed_Input */
/* CMD is a character string containing the command */
/* used to invoke a text editor available on the */
/* system under which the calling program is running. */
/* This routine will invoke the specified editor */
/* using FILE as the target file to edit. The name */
/* of the file to be edited is not included in the */
/* command; this name is input as a separate argument. */
/* Case sensitivity of CMD varies with the system on */
/* which the calling program is run. */
/* Trailing white space in CMD is not significant. */
/* FILE is the name of a file that is to be edited. FILE */
/* need not exist at the time this routine is called. */
/* Case sensitivity of FILE varies with the system on */
/* which the calling program is run. */
/* Trailing white space in FILE is not significant. */
/* $ Detailed_Output */
/* None. See $Particulars for further information on the action of */
/* this routine. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the specified edit command fails, the error will be */
/* diagnosed by routines called by this routine. */
/* 2) If the editing session started by this routine is terminated */
/* abnormally, the effect on the operation of the calling program */
/* is unspecified. */
/* $ Files */
/* See $Particulars. */
/* $ Particulars */
/* This routine should be used with caution; calls to this routine */
/* may have unintended side effects on the operation of the calling */
/* program. A solid understanding of the global operation of the */
/* calling program is a prerequisite for programmers wishing to */
/* use this routine. */
/* The input argument FILE should unambiguously designate a file */
/* that can be edited by the specified editor on the system under */
/* which the calling program is being run. The calling program */
/* should have read or write privileges consistent with the intended */
/* mode of access to FILE. */
/* This routine may fail to recover in a predictable fashion from */
/* abnormal termination of an editing session. */
/* $ Examples */
/* 1) On a VAX/VMS system, the EDT editor could be invoked by */
/* the calls */
/* CALL EDTCMD ( 'EDIT/EDT', FILE ) */
/* or */
/* CALL EDTCMD ( 'EDIT/EDT/COMMAND = <command file>', FILE ) */
/* 2) On a Unix system, the emacs editor could be invoked */
/* (normally) by the calls */
/* CALL EDTCMD ( 'emacs', FILE ) */
/* or */
/* CALL EDTCMD ( '/usr/bin/emacs', FILE ) */
/* $ Restrictions */
/* 1) The means by which this routine invokes an editor are system- */
/* dependent; invoking the editor may have side effects that */
/* affect the operation of the calling program. For example, */
/* on Unix systems, this routine may start a new shell in which */
/* to run the editor; starting a new shell may interfere with */
/* any sequential file I/O in progress at the time the shell is */
/* started. */
/* See the code for implementation details. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - Beta Version 2.22.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - Beta Version 2.21.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - Beta Version 2.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - Beta Version 2.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - Beta Version 2.18.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - Beta Version 2.17.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - Beta Version 2.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - Beta Version 2.15.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - Beta Version 2.14.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - Beta Version 2.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - Beta Version 2.12.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - Beta Version 2.11.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - Beta Version 2.10.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - Beta Version 2.9.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - Beta Version 2.8.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - Beta Version 2.7.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - Beta Version 2.6.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - Beta Version 2.5.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - Beta Version 2.4.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - Beta Version 2.3.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - Beta Version 2.2.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - Beta Version 2.2.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - Beta Version 2.2.3, 20-SEP-1999 (NJB) */
/* CSPICE and PC-LINUX environment lines were added. Some */
/* typos were corrected. */
/* - Beta Version 2.2.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - Beta Version 2.2.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - Beta Version 2.2.0, 12-AUG-1996 (WLT) */
/* Added DEC-OSF1 to the list of supported environments */
/* - Beta Version 2.1.0, 10-JAN-1996 (WLT) */
/* Added PC-LAHEY to the list of supported environments. */
/* - Beta Version 2.0.0, 16-JUN-1995 (WLT)(HAN) */
/* Created master file from collection of machine dependent */
/* routines. Copyright notice added. */
/* - Beta Version 1.0.0, 16-AUG-1994 (NJB) */
/* -& */
/* $ Index_Entries */
/* invoke a text editor within a program */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("EDTCMD", (ftnlen)6);
}
/* VAX: */
/* Computer: VAX 11/780 */
/* Operating System: VAX VMS 5.3 */
/* Fortran: VAX FORTRAN 5.5 */
/* PC-MS: */
/* Computer: PC */
/* Operating System: Microsoft DOS 5.00 */
/* Fortran: Microsoft Powerstation Fortran V1.0 */
/* Build the edit command to be passed to the system. */
s_copy(loccmd, cmd, (ftnlen)255, cmd_len);
suffix_(file, &c__1, loccmd, file_len, (ftnlen)255);
/* Invoke the editor. */
exesys_(loccmd, rtrim_(loccmd, (ftnlen)255));
chkout_("EDTCMD", (ftnlen)6);
return 0;
} /* edtcmd_ */
/* $Procedure PARCML ( Parse command line) */
/* Subroutine */ int parcml_(char *line, integer *maxkey, char *clkeys,
logical *clflag, char *clvals, logical *found, ftnlen line_len,
ftnlen clkeys_len, ftnlen clvals_len)
{
/* System generated locals */
address a__1[2];
integer i__1, i__2[2];
/* 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 */
static char hkey[1024];
static integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen);
static char hline[1024];
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
static integer clidx;
static char uline[1024], lngwd[1024];
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
static integer begpos, pclidx;
static char hlngwd[1024];
static integer endpos;
extern /* Subroutine */ int chkout_(char *, ftnlen), nextwd_(char *, char
*, char *, ftnlen, ftnlen, ftnlen);
extern logical return_(void);
extern integer pos_(char *, char *, integer *, ftnlen, ftnlen);
/* $ Abstract */
/* This routine parses "command-line" looking line and returns */
/* values of requested keys. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* None. */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* LINE I Input line. */
/* MAXKEY I Number of keys. */
/* CLKEYS I Keys. */
/* CLFLAG O "Key-found" flags. */
/* CLVALS O Key values. */
/* FOUND O Flag indicating that at least one key was found. */
/* $ Detailed_Input */
/* LINE Input line in a format "-key value -key value ..." */
/* MAXKEY Total number of keys to look for. */
/* CLKEYS Keys to look for; uppercased. */
/* $ Detailed_Output */
/* CLFLAG Flags set TRUE if corresponding key was found. */
/* CLVALS Values key; if key wasn't found, value set to */
/* blank string. */
/* FOUND .TRUE. if at least one key was found. */
/* Otherwise -- .FALSE. */
/* $ Parameters */
/* TBD. */
/* $ Exceptions */
/* TBD */
/* $ Files */
/* None. */
/* $ Particulars */
/* TBD */
/* $ Examples */
/* Let CLKEYS be */
/* CLKEYS(1) = '-SETUP' */
/* CLKEYS(2) = '-TO' */
/* CLKEYS(3) = '-FROM' */
/* CLKEYS(4) = '-HELP' */
/* then: */
/* line '-setup my.file -from utc -to sclk' */
/* will be parsed as */
/* CLFLAG(1) = .TRUE. CLVALS(1) = 'my.file' */
/* CLFLAG(2) = .TRUE. CLVALS(2) = 'utc' */
/* CLFLAG(3) = .TRUE. CLVALS(3) = 'sclk' */
/* CLFLAG(4) = .FALSE. CLVALS(4) = ' ' */
/* FOUND = .TRUE. */
/* line '-setup my.file -setup your.file' */
/* will be parsed as */
/* CLFLAG(1) = .TRUE. CLVALS(1) = 'your.file' */
/* CLFLAG(2) = .FALSE. CLVALS(2) = ' ' */
/* CLFLAG(3) = .FALSE. CLVALS(3) = ' ' */
/* CLFLAG(4) = .FALSE. CLVALS(4) = ' ' */
/* FOUND = .TRUE. */
/* line '-setup my.file -SeTuP your.file' */
/* will be parsed as */
/* CLFLAG(1) = .TRUE. CLVALS(1) = 'your.file' */
/* CLFLAG(2) = .FALSE. CLVALS(2) = ' ' */
/* CLFLAG(3) = .FALSE. CLVALS(3) = ' ' */
/* CLFLAG(4) = .FALSE. CLVALS(4) = ' ' */
/* FOUND = .TRUE. */
/* line '-help' */
/* will be parsed as */
/* CLFLAG(1) = .FALSE. CLVALS(1) = ' ' */
/* CLFLAG(2) = .FALSE. CLVALS(2) = ' ' */
/* CLFLAG(3) = .FALSE. CLVALS(3) = ' ' */
/* CLFLAG(4) = .TRUE. CLVALS(4) = ' ' */
/* FOUND = .TRUE. */
/* and so on. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - Alpha Version 1.0.0, 12-SEP-2008 (BVS) */
/* -& */
/* Save everything to prevent potential memory problems in f2c'ed */
/* version. */
/* SPICELIB functions. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("PARCML", (ftnlen)6);
}
/* Command line parse loop. Set initial values to blanks. */
i__1 = *maxkey;
for (i__ = 1; i__ <= i__1; ++i__) {
clflag[i__ - 1] = FALSE_;
s_copy(clvals + (i__ - 1) * clvals_len, " ", clvals_len, (ftnlen)1);
}
*found = FALSE_;
s_copy(hline, line, (ftnlen)1024, line_len);
pclidx = 0;
clidx = 0;
while(s_cmp(hline, " ", (ftnlen)1024, (ftnlen)1) != 0) {
/* Get next word, uppercase it. */
nextwd_(hline, lngwd, hline, (ftnlen)1024, (ftnlen)1024, (ftnlen)1024)
;
ucase_(lngwd, hlngwd, (ftnlen)1024, (ftnlen)1024);
clidx = isrchc_(hlngwd, maxkey, clkeys, (ftnlen)1024, clkeys_len);
/* Is the token that we found a command line key? */
if (clidx != 0) {
/* Is it the first key that we have found? */
if (pclidx != 0) {
/* It's not. Save value of the previous key. Compute begin */
/* and end position of substring that contains this */
/* value. */
ucase_(line, uline, line_len, (ftnlen)1024);
begpos = pos_(uline, clkeys + (pclidx - 1) * clkeys_len, &
c__1, (ftnlen)1024, rtrim_(clkeys + (pclidx - 1) *
clkeys_len, clkeys_len)) + rtrim_(clkeys + (pclidx -
1) * clkeys_len, clkeys_len);
/* Writing concatenation */
i__2[0] = 1, a__1[0] = " ";
i__2[1] = rtrim_(clkeys + (clidx - 1) * clkeys_len,
clkeys_len), a__1[1] = clkeys + (clidx - 1) *
clkeys_len;
s_cat(hkey, a__1, i__2, &c__2, (ftnlen)1024);
endpos = pos_(uline, hkey, &begpos, (ftnlen)1024, rtrim_(hkey,
(ftnlen)1024) + 1);
/* Extract the value, left-justify and RTRIM it. Set */
/* "value present" flag to .TRUE. */
s_copy(clvals + (pclidx - 1) * clvals_len, line + (begpos - 1)
, clvals_len, endpos - (begpos - 1));
ljust_(clvals + (pclidx - 1) * clvals_len, clvals + (pclidx -
1) * clvals_len, clvals_len, clvals_len);
s_copy(clvals + (pclidx - 1) * clvals_len, clvals + (pclidx -
1) * clvals_len, clvals_len, rtrim_(clvals + (pclidx
- 1) * clvals_len, clvals_len));
clflag[pclidx - 1] = TRUE_;
/* Check whether we already parsed the whole line. */
if (s_cmp(hline, " ", (ftnlen)1024, (ftnlen)1) != 0) {
/* We are not at the end of the command line. There is */
/* more stuff to parse and we put this stuff to */
/* the HLINE. */
i__1 = endpos + 1 + rtrim_(clkeys + (clidx - 1) *
clkeys_len, clkeys_len) - 1;
s_copy(hline, line + i__1, (ftnlen)1024, line_len - i__1);
}
/* Now reset our line and previous index. */
i__1 = endpos;
s_copy(line, line + i__1, line_len, line_len - i__1);
}
/* Save current key index in as previous. */
pclidx = clidx;
}
}
/* We need to save the last value. */
if (pclidx != 0) {
*found = TRUE_;
/* Save the last value. */
clflag[pclidx - 1] = TRUE_;
if (rtrim_(line, line_len) > rtrim_(clkeys + (pclidx - 1) *
clkeys_len, clkeys_len)) {
/* Compute begin position of, extract, left justify and */
/* RTRIM the last value. */
ucase_(line, uline, line_len, (ftnlen)1024);
begpos = pos_(uline, clkeys + (pclidx - 1) * clkeys_len, &c__1, (
ftnlen)1024, rtrim_(clkeys + (pclidx - 1) * clkeys_len,
clkeys_len)) + rtrim_(clkeys + (pclidx - 1) * clkeys_len,
clkeys_len);
s_copy(clvals + (pclidx - 1) * clvals_len, line + (begpos - 1),
clvals_len, line_len - (begpos - 1));
ljust_(clvals + (pclidx - 1) * clvals_len, clvals + (pclidx - 1) *
clvals_len, clvals_len, clvals_len);
s_copy(clvals + (pclidx - 1) * clvals_len, clvals + (pclidx - 1) *
clvals_len, clvals_len, rtrim_(clvals + (pclidx - 1) *
clvals_len, clvals_len));
} else {
/* The key is the last thing on the line. So, it's value */
/* is blank. */
s_copy(clvals + (pclidx - 1) * clvals_len, " ", clvals_len, (
ftnlen)1);
}
}
chkout_("PARCML", (ftnlen)6);
return 0;
} /* parcml_ */
/* Subroutine */ int kerman_0_(int n__, char *commnd, char *infile__, char *
error, ftnlen commnd_len, ftnlen infile_len, ftnlen error_len)
{
/* Initialized data */
static integer nfiles = 0;
static logical first = TRUE_;
static char synval[80*9] = " "
" " " "
" " " "
" "
" " " "
" " " "
" " " "
" "
" " "EK #word[ekfile] "
" " "LEAPSECONDS #word[leapfile] "
" " "SCLK KERNEL #word[sc"
"lkfile] ";
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Local variables */
static integer need;
static char file[127], name__[32];
static integer clen;
extern logical have_(char *, ftnlen);
static integer left, reqd, nseg;
static char indx[4], pval[32*4];
static integer hits;
static char size[32], type__[32];
static logical quit;
extern /* Subroutine */ int zzeksinf_(integer *, integer *, char *,
integer *, char *, integer *, ftnlen, ftnlen);
static integer i__, j, k;
extern integer cardc_(char *, ftnlen);
static integer l, n;
extern /* Subroutine */ int clgai_(integer *, char *, integer *, integer *
, ftnlen), clgac_(integer *, char *, char *, ftnlen, ftnlen);
static integer r__;
static char cname[80], break__[80];
static integer headr[5];
extern /* Subroutine */ int eklef_(char *, integer *, ftnlen), clnid_(
integer *, integer *, logical *);
static integer space;
extern logical match_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int chkin_(char *, ftnlen);
static integer tcode, ncomc;
extern /* Subroutine */ int ekuef_(integer *);
static char rname[6], tname[32];
extern /* Subroutine */ int repmc_(char *, char *, char *, char *, ftnlen,
ftnlen, ftnlen, ftnlen), clnew_(char *, integer *, integer *,
integer *, integer *, integer *, logical *, logical *, integer *,
ftnlen);
static logical found;
static integer csize, ncols, ncomr;
static logical cnull;
static integer right, width[5], ctype;
extern integer ltrim_(char *, ftnlen);
static integer count;
extern integer rtrim_(char *, ftnlen);
static integer sizes[5];
static char style[80];
extern /* Subroutine */ int clnum_(integer *);
static logical justr[5];
extern /* Subroutine */ int m2chck_(char *, char *, integer *, char *,
char *, ftnlen, ftnlen, ftnlen, ftnlen), m2getc_(char *, char *,
logical *, char *, ftnlen, ftnlen, ftnlen), m2ints_(integer *,
char *, integer *, char *, ftnlen, ftnlen);
static integer id, nb;
static char bs[1];
extern logical m2xist_(char *, ftnlen);
static integer nh, sb, handle;
static char ifname[60], tabnam[64], tabcol[80*506], rnamec[7], cnames[64*
100];
static integer handls[20], segdsc[24];
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen),
eknseg_(integer *);
extern /* Subroutine */ int gcolmn_();
extern integer isrchi_(integer *, integer *, integer *);
extern /* Subroutine */ int pagput_(char *, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int nspwln_(char *, ftnlen);
static char synkey[32*9];
static integer synptr[9];
static char ekfils[127*20], thisfl[127], messge[300], idword[8];
static integer cdscrs[1100] /* was [11][100] */, widest, totalc, nresvr,
nresvc;
static logical cindxd;
static char spcial[4*5], lsttab[32];
static integer colids[506], lmarge, ordvec[500];
static logical presrv[5];
extern /* Subroutine */ int replch_(char *, char *, char *, char *,
ftnlen, ftnlen, ftnlen, ftnlen), prefix_(char *, integer *, char *
, ftnlen, ftnlen), chkout_(char *, ftnlen), expool_(char *,
logical *, ftnlen), repmct_(char *, char *, integer *, char *,
char *, ftnlen, ftnlen, ftnlen, ftnlen), clunld_(integer *),
ldpool_(char *, ftnlen);
static integer nid;
extern /* Subroutine */ int dasfnh_(char *, integer *, ftnlen);
static integer col, seg, ids[5];
extern /* Subroutine */ int remlac_(integer *, integer *, char *, integer
*, ftnlen), nspglr_(integer *, integer *), nspmrg_(char *, ftnlen)
, suffix_(char *, integer *, char *, ftnlen, ftnlen), pagrst_(
void), pagset_(char *, integer *, ftnlen), ssizec_(integer *,
char *, ftnlen), ssizei_(integer *, integer *), appndc_(char *,
char *, ftnlen, ftnlen), appndi_(integer *, integer *), pagscn_(
char *, ftnlen), scolmn_(integer *, integer *, char *, ftnlen),
tabrpt_(integer *, integer *, integer *, integer *, logical *,
logical *, char *, integer *, integer *, U_fp, ftnlen), orderc_(
char *, integer *, integer *, ftnlen);
extern integer pos_(char *, char *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int pagsft_(void), dasrfr_(integer *, char *,
char *, integer *, integer *, integer *, integer *, ftnlen,
ftnlen), nspshc_(integer *, logical *), bbputc_1__(char *, char *,
integer *, char *, ftnlen, ftnlen, ftnlen), nicepr_1__(char *,
char *, S_fp, ftnlen, ftnlen);
/* Version 2.4.0, 26-SEP-2005 */
/* Minor bug fix: replaced FILE with INFILE in the RTRIM call */
/* constructing "The file # is not listed ..." error message. */
/* Version 2.3.0, 21-JUN-1999 */
/* Added RETURN before first entry points. */
/* Version 2.2.0, 22-APR-1997 */
/* Declared PAGPUT external */
/* Version 2.1.0 14-SEP-1995 */
/* Variable INDEX removed. */
/* Version 2.0.0 23-AUG-1995 */
/* The widest string in a string column is no longer supplied */
/* by the EK summary stuff. We just set the value WIDEST */
/* to 24. */
/* This routine handles the loading of E-kernels, leapsecond and */
/* SCLK kernels. */
/* Passable routines */
/* Parameters that contain the routine name for use in check-in, */
/* check-out, and error messages. */
/* SPICELIB functions */
/* E-kernel functions */
/* Meta/2 Functions */
/* Interface to the SPICELIB error handling. */
/* Ek include files. */
/* +============================================================== */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Column Descriptor Parameters */
/* ekcoldsc.inc Version 6 23-AUG-1995 (NJB) */
/* Note: The column descriptor size parameter CDSCSZ is */
/* declared separately in the include section CDSIZE$INC.FOR. */
/* Offset of column descriptors, relative to start of segment */
/* integer address range. This number, when added to the last */
/* integer address preceding the segment, yields the DAS integer */
/* base address of the first column descriptor. Currently, this */
/* offset is exactly the size of a segment descriptor. The */
/* parameter SDSCSZ, which defines the size of a segment descriptor, */
/* is declared in the include file eksegdsc.inc. */
/* Size of column descriptor */
/* Indices of various pieces of column descriptors: */
/* CLSIDX is the index of the column's class code. (We use the */
/* word `class' to distinguish this item from the column's data */
/* type.) */
/* TYPIDX is the index of the column's data type code (CHR, INT, DP, */
/* or TIME). The type is actually implied by the class, but it */
/* will frequently be convenient to look up the type directly. */
/* LENIDX is the index of the column's string length value, if the */
/* column has character type. A value of IFALSE in this element of */
/* the descriptor indicates that the strings have variable length. */
/* SIZIDX is the index of the column's element size value. This */
/* descriptor element is meaningful for columns with fixed-size */
/* entries. For variable-sized columns, this value is IFALSE. */
/* NAMIDX is the index of the base address of the column's name. */
/* IXTIDX is the data type of the column's index. IXTIDX */
/* contains a type value only if the column is indexed. For columns */
/* that are not indexed, the location IXTIDX contains the boolean */
/* value IFALSE. */
/* IXPIDX is a pointer to the column's index. IXTPDX contains a */
/* meaningful value only if the column is indexed. The */
/* interpretation of the pointer depends on the data type of the */
/* index. */
/* NFLIDX is the index of a flag indicating whether nulls are */
/* permitted in the column. The value at location NFLIDX is */
/* ITRUE if nulls are permitted and IFALSE otherwise. */
/* ORDIDX is the index of the column's ordinal position in the */
/* list of columns belonging to the column's parent segment. */
/* METIDX is the index of the column's integer metadata pointer. */
/* This pointer is a DAS integer address. */
/* The last position in the column descriptor is reserved. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Column Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Segment Descriptor Parameters */
/* eksegdsc.inc Version 8 06-NOV-1995 (NJB) */
/* All `base addresses' referred to below are the addresses */
/* *preceding* the item the base applies to. This convention */
/* enables simplied address calculations in many cases. */
/* Size of segment descriptor. Note: the include file ekcoldsc.inc */
/* must be updated if this parameter is changed. The parameter */
/* CDOFF in that file should be kept equal to SDSCSZ. */
/* Index of the segment type code: */
/* Index of the segment's number. This number is the segment's */
/* index in the list of segments contained in the EK to which */
/* the segment belongs. */
/* Index of the DAS integer base address of the segment's integer */
/* meta-data: */
/* Index of the DAS character base address of the table name: */
/* Index of the segment's column count: */
/* Index of the segment's record count: */
/* Index of the root page number of the record tree: */
/* Index of the root page number of the character data page tree: */
/* Index of the root page number of the double precision data page */
/* tree: */
/* Index of the root page number of the integer data page tree: */
/* Index of the `modified' flag: */
/* Index of the `initialized' flag: */
/* Index of the shadowing flag: */
/* Index of the companion file handle: */
/* Index of the companion segment number: */
/* The next three items are, respectively, the page numbers of the */
/* last character, d.p., and integer data pages allocated by the */
/* segment: */
/* The next three items are, respectively, the page-relative */
/* indices of the last DAS word in use in the segment's */
/* last character, d.p., and integer data pages: */
/* Index of the DAS character base address of the column name list: */
/* The last descriptor element is reserved for future use. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Segment Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Boolean Enumerated Type */
/* ekbool.inc Version 1 21-DEC-1994 (NJB) */
/* Within the EK system, boolean values sometimes must be */
/* represented by integer or character codes. The codes and their */
/* meanings are listed below. */
/* Integer code indicating `true': */
/* Integer code indicating `false': */
/* Character code indicating `true': */
/* Character code indicating `false': */
/* End Include Section: EK Boolean Enumerated Type */
/* +============================================================== */
/* Meta/2 syntax definition variables. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Data Types */
/* ektype.inc Version 1 27-DEC-1994 (NJB) */
/* Within the EK system, data types of EK column contents are */
/* represented by integer codes. The codes and their meanings */
/* are listed below. */
/* Integer codes are also used within the DAS system to indicate */
/* data types; the EK system makes no assumptions about compatibility */
/* between the codes used here and those used in the DAS system. */
/* Character type: */
/* Double precision type: */
/* Integer type: */
/* `Time' type: */
/* Within the EK system, time values are represented as ephemeris */
/* seconds past J2000 (TDB), and double precision numbers are used */
/* to store these values. However, since time values require special */
/* treatment both on input and output, and since the `TIME' column */
/* has a special role in the EK specification and code, time values */
/* are identified as a type distinct from double precision numbers. */
/* End Include Section: EK Data Types */
/* E-kernel column type definitions */
/* INTEGER CH */
/* PARAMETER ( CH = 1 ) */
/* INTEGER DP */
/* PARAMETER ( DP = 2 ) */
/* INTEGER INT */
/* PARAMETER ( INT = 3 ) */
/* INTEGER TIME */
/* PARAMETER ( TIME = 4 ) */
/* Local Parameters */
/* FILSIZ is the maximum number of characters allowed for a */
/* filename */
/* LNGSIZ is the maximum number of characters allowed for */
/* use in reporting the columns associated with a given */
/* file. */
/* MAXFIL is the maximum number of E-kernels that can be loaded */
/* at any one time. */
/* NNAMES is the maximum number of names/headings that can appear */
/* in a report of loaded files and columns. */
/* MAXCOL is the maximum number of columns that may be present */
/* in any segment of an E-kernel */
/* LNSIZE is the standard text line length. */
/* Initialization logical */
/* Loaded file database (shared between entry points) */
/* Local Variables */
/* INTEGER IFALSE */
/* PARAMETER ( IFALSE = -1 ) */
/* Variables needed by NSPEKS */
/* Save everything. */
/* Initial Values */
/* Parameter adjustments */
if (error) {
}
/* Function Body */
switch(n__) {
case 1: goto L_nspld;
case 2: goto L_nspuld;
case 3: goto L_nspeks;
case 4: goto L_nspekc;
}
return 0;
/* Load an E-, leapsecond, or sclk kernel. */
L_nspld:
/* Standard Spicelib error handling. */
s_copy(rname, "NSPLD", (ftnlen)6, (ftnlen)5);
s_copy(rnamec, "NSPLD:", (ftnlen)7, (ftnlen)6);
if (return_()) {
return 0;
}
chkin_(rname, (ftnlen)6);
/* On the first pass establish the syntax that this routine */
/* is responsible for recognizing. */
if (first) {
first = FALSE_;
*(unsigned char *)bs = '@';
for (i__ = 1; i__ <= 100; ++i__) {
s_copy(cnames + (((i__1 = i__ - 1) < 100 && 0 <= i__1 ? i__1 :
s_rnge("cnames", i__1, "kerman_", (ftnlen)361)) << 6),
" ", (ftnlen)64, (ftnlen)1);
}
for (i__ = 1; i__ <= 3; ++i__) {
replch_(synval + ((i__1 = i__ + 5) < 9 && 0 <= i__1 ? i__1 :
s_rnge("synval", i__1, "kerman_", (ftnlen)366)) * 80,
"#", bs, synval + ((i__2 = i__ + 5) < 9 && 0 <= i__2 ?
i__2 : s_rnge("synval", i__2, "kerman_", (ftnlen)366)) *
80, (ftnlen)80, (ftnlen)1, (ftnlen)1, (ftnlen)80);
}
m2ints_(&c__3, synkey, synptr, synval, (ftnlen)32, (ftnlen)80);
}
/* See if this command matches a known syntax. If it doesn't */
/* there is no point in hanging around. */
m2chck_(commnd, synkey, synptr, synval, error, commnd_len, (ftnlen)32, (
ftnlen)80, error_len);
if (have_(error, error_len)) {
prefix_(rnamec, &c__1, error, (ftnlen)7, error_len);
chkout_(rname, (ftnlen)6);
return 0;
}
if (m2xist_("ekfile", (ftnlen)6)) {
/* We need to have a leapseconds kernel loaded before */
/* we can load an E-kernel. */
expool_("DELTET/DELTA_AT", &found, (ftnlen)15);
if (! found) {
s_copy(error, "Before an E-kernel can be loaded, you must load a"
" leapseconds kernel. ", error_len, (ftnlen)71);
chkout_(rname, (ftnlen)6);
return 0;
}
m2getc_("ekfile", commnd, &found, file, (ftnlen)6, commnd_len, (
ftnlen)127);
/* See if we already have this file. */
if (isrchc_(file, &nfiles, ekfils, (ftnlen)127, (ftnlen)127) > 0) {
chkout_(rname, (ftnlen)6);
return 0;
}
/* Make sure there is room for this file. */
if (nfiles == 20) {
s_copy(error, "The maximum number of E-kernels that can loaded a"
"t open by INSPEKT at one time is #. That number has alr"
"eady been reached. You will need to unload one of the fi"
"les that have already been loaded before you will be abl"
"e to load any other files. ", error_len, (ftnlen)244);
repmct_(error, "#", &c__20, "L", error, error_len, (ftnlen)1, (
ftnlen)1, error_len);
prefix_(rnamec, &c__1, error, (ftnlen)7, error_len);
chkout_(rname, (ftnlen)6);
return 0;
}
/* Load the file as an e-kernel. */
eklef_(file, &handle, rtrim_(file, (ftnlen)127));
if (have_(error, error_len)) {
prefix_(rnamec, &c__1, error, (ftnlen)7, error_len);
chkout_(rname, (ftnlen)6);
return 0;
}
/* Store the name of this file. */
++nfiles;
s_copy(ekfils + ((i__1 = nfiles - 1) < 20 && 0 <= i__1 ? i__1 :
s_rnge("ekfils", i__1, "kerman_", (ftnlen)442)) * 127, file, (
ftnlen)127, (ftnlen)127);
/* Determine how many segments are in the file we just loaded. */
nseg = eknseg_(&handle);
/* For each segment in the newly loaded file ... */
i__1 = nseg;
for (seg = 1; seg <= i__1; ++seg) {
s_copy(tabnam, " ", (ftnlen)64, (ftnlen)1);
for (i__ = 1; i__ <= 100; ++i__) {
s_copy(cnames + (((i__2 = i__ - 1) < 100 && 0 <= i__2 ? i__2 :
s_rnge("cnames", i__2, "kerman_", (ftnlen)457)) << 6)
, " ", (ftnlen)64, (ftnlen)1);
}
zzeksinf_(&handle, &seg, tabnam, segdsc, cnames, cdscrs, (ftnlen)
64, (ftnlen)64);
/* Add each column name to the list of columns held by the */
/* column manager. */
ncols = segdsc[4];
i__2 = ncols;
for (col = 1; col <= i__2; ++col) {
/* We need to make the column name include table it */
/* belongs to (a fully qualified column name). */
prefix_(".", &c__0, cnames + (((i__3 = col - 1) < 100 && 0 <=
i__3 ? i__3 : s_rnge("cnames", i__3, "kerman_", (
ftnlen)475)) << 6), (ftnlen)1, (ftnlen)64);
prefix_(tabnam, &c__0, cnames + (((i__3 = col - 1) < 100 && 0
<= i__3 ? i__3 : s_rnge("cnames", i__3, "kerman_", (
ftnlen)476)) << 6), (ftnlen)64, (ftnlen)64);
cindxd = cdscrs[(i__3 = col * 11 - 6) < 1100 && 0 <= i__3 ?
i__3 : s_rnge("cdscrs", i__3, "kerman_", (ftnlen)478)]
!= -1;
cnull = cdscrs[(i__3 = col * 11 - 4) < 1100 && 0 <= i__3 ?
i__3 : s_rnge("cdscrs", i__3, "kerman_", (ftnlen)479)]
!= -1;
ctype = cdscrs[(i__3 = col * 11 - 10) < 1100 && 0 <= i__3 ?
i__3 : s_rnge("cdscrs", i__3, "kerman_", (ftnlen)481)]
;
clen = cdscrs[(i__3 = col * 11 - 9) < 1100 && 0 <= i__3 ?
i__3 : s_rnge("cdscrs", i__3, "kerman_", (ftnlen)482)]
;
csize = cdscrs[(i__3 = col * 11 - 8) < 1100 && 0 <= i__3 ?
i__3 : s_rnge("cdscrs", i__3, "kerman_", (ftnlen)483)]
;
/* This is what used to be here, but the item NBLIDX */
/* vanished by design. We now just set this so something */
/* reasonable. 24 seemed like the reasonable thing at */
/* the time. (See the column manager and do a bit of */
/* code diving to see what this is used for.) */
/* WIDEST = CDSCRS ( NBLIDX, COL ) */
widest = 24;
clnew_(cnames + (((i__3 = col - 1) < 100 && 0 <= i__3 ? i__3 :
s_rnge("cnames", i__3, "kerman_", (ftnlen)496)) << 6)
, &handle, &ctype, &clen, &widest, &csize, &cindxd, &
cnull, &id, (ftnlen)64);
}
}
/* If anything went wrong, unload the file. */
if (have_(error, error_len)) {
prefix_(rnamec, &c__1, error, (ftnlen)7, error_len);
ekuef_(&handle);
clunld_(&handle);
--nfiles;
chkout_(rname, (ftnlen)6);
return 0;
}
} else if (m2xist_("leapfile", (ftnlen)8)) {
m2getc_("leapfile", commnd, &found, file, (ftnlen)8, commnd_len, (
ftnlen)127);
ldpool_(file, (ftnlen)127);
bbputc_1__("POST", "LEAPSECONDS", &c__1, file, (ftnlen)4, (ftnlen)11,
(ftnlen)127);
} else if (m2xist_("sclkfile", (ftnlen)8)) {
m2getc_("sclkfile", commnd, &found, file, (ftnlen)8, commnd_len, (
ftnlen)127);
ldpool_(file, (ftnlen)127);
bbputc_1__("APPEND", "SCLK", &c__1, file, (ftnlen)6, (ftnlen)4, (
ftnlen)127);
} else {
s_copy(error, "The input command was unrecognized and somehow got to"
" an \"impossible\" place in KERMAN.FOR", error_len, (ftnlen)
89);
}
if (have_(error, error_len)) {
prefix_(rnamec, &c__1, error, (ftnlen)7, error_len);
chkout_(rname, (ftnlen)6);
return 0;
}
chkout_(rname, (ftnlen)6);
return 0;
/* Unload an E-kernel from the list of known files. */
L_nspuld:
s_copy(rname, "NSPULD", (ftnlen)6, (ftnlen)6);
s_copy(rnamec, "NSPULD:", (ftnlen)7, (ftnlen)7);
if (return_()) {
return 0;
}
chkin_(rname, (ftnlen)6);
j = isrchc_(infile__, &nfiles, ekfils, infile_len, (ftnlen)127);
if (j == 0) {
s_copy(error, "The file # is not listed among those files that have "
"been loaded. ", error_len, (ftnlen)66);
repmc_(error, "#", infile__, error, error_len, (ftnlen)1, rtrim_(
infile__, infile_len), error_len);
chkout_(rname, (ftnlen)6);
return 0;
}
/* Get the handle associated with this file. */
dasfnh_(infile__, &handle, rtrim_(infile__, infile_len));
if (have_(error, error_len)) {
chkout_(rname, (ftnlen)6);
return 0;
}
/* Now unload the file, and detach its handle from any columns to */
/* which it might be attached. */
ekuef_(&handle);
clunld_(&handle);
/* Finally remove this file from our internal list of files. */
remlac_(&c__1, &j, ekfils, &nfiles, (ftnlen)127);
chkout_(rname, (ftnlen)6);
return 0;
/* Create a report regarding currently loaded kernels/columns. */
L_nspeks:
/* Version 2.0 Aug 3, 1995 */
/* This routine was rewritten to provide a more friendly */
/* kernel summary. */
/* ---B. Taber */
/* This routine displays the currently loaded E-kernels. */
s_copy(rname, "NSPEKS", (ftnlen)6, (ftnlen)6);
s_copy(rnamec, "NSPEKS:", (ftnlen)7, (ftnlen)7);
if (return_()) {
return 0;
}
/* write (*,*) 'Checking in:' */
chkin_(rname, (ftnlen)6);
if (nfiles <= 0) {
nspwln_(" ", (ftnlen)1);
nspwln_("There are no E-kernels loaded now.", (ftnlen)34);
nspwln_(" ", (ftnlen)1);
chkout_(rname, (ftnlen)6);
return 0;
}
/* First thing we do is set up the NICEPR_1 style string */
/* to be used in creation of summary headers. */
/* write (*,*) 'Fetching margins: ' */
nspglr_(&left, &right);
nspmrg_(style, (ftnlen)80);
suffix_("FLAG", &c__1, style, (ftnlen)4, (ftnlen)80);
suffix_("E-kernel:", &c__1, style, (ftnlen)9, (ftnlen)80);
/* Reset the output page, title frequency and header frequency */
/* values. */
/* write (*,*) 'Resetting page and setting up page attributes:' */
pagrst_();
pagset_("TITLEFREQUENCY", &c__0, (ftnlen)14);
pagset_("HEADERFREQUENCY", &c__0, (ftnlen)15);
pagset_("NOSPACEFOOTER", &c__1, (ftnlen)13);
pagset_("FOOTERFREQUENCY", &c_n1, (ftnlen)15);
s_copy(pval, "CH", (ftnlen)32, (ftnlen)2);
s_copy(pval + 32, "D.P.", (ftnlen)32, (ftnlen)4);
s_copy(pval + 64, "INTEGER", (ftnlen)32, (ftnlen)7);
s_copy(pval + 96, "TIME", (ftnlen)32, (ftnlen)4);
lmarge = 1;
space = 1;
/* Next we set up the the column id codes, sizes, */
/* default widths, justifications, component preservation, */
/* and special marker attributes for each column. */
headr[0] = 1;
headr[1] = 2;
headr[2] = 3;
headr[3] = 4;
headr[4] = 5;
sizes[0] = 1;
sizes[1] = 1;
sizes[2] = 1;
sizes[3] = 1;
sizes[4] = 1;
width[0] = 16;
width[1] = 16;
width[2] = 8;
width[3] = 8;
width[4] = 6;
need = width[0] + width[1] + width[2] + width[3] + width[4] + 4;
right = min(right,need);
pagset_("PAGEWIDTH", &right, (ftnlen)9);
reqd = width[2] + width[3] + width[4] + 4;
/* If the page width is less than default needed, we reset the */
/* widths of the first two columns so they will fit in available */
/* space. */
if (right < need) {
width[0] = (right - reqd) / 2;
width[1] = width[0];
}
justr[0] = FALSE_;
justr[1] = FALSE_;
justr[2] = FALSE_;
justr[3] = TRUE_;
justr[4] = TRUE_;
presrv[0] = TRUE_;
presrv[1] = TRUE_;
presrv[2] = TRUE_;
presrv[3] = TRUE_;
presrv[4] = TRUE_;
s_copy(spcial, " ", (ftnlen)4, (ftnlen)1);
s_copy(spcial + 4, " ", (ftnlen)4, (ftnlen)1);
s_copy(spcial + 8, " ", (ftnlen)4, (ftnlen)1);
s_copy(spcial + 12, " ", (ftnlen)4, (ftnlen)1);
s_copy(spcial + 16, " ", (ftnlen)4, (ftnlen)1);
/* write (*,*) 'Starting file loop:' */
i__1 = nfiles;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Get the handle associated with this file, and get the */
/* number of ID's currently known. */
dasfnh_(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 : s_rnge(
"ekfils", i__2, "kerman_", (ftnlen)738)) * 127, &handle, (
ftnlen)127);
clnum_(&nid);
/* write (*,*) 'File: ', I, 'Handle: ', HANDLE */
/* Now empty out the table/column data for this file. */
/* write (*,*) 'Empty out the column collector.' */
ssizec_(&c__500, tabcol, (ftnlen)80);
ssizei_(&c__500, colids);
/* Cycle over all column id's to determine if they */
/* are attached to this particular file. */
/* write (*,*) 'Beginning Column search: ', NID, ' Columns' */
i__2 = nid;
for (j = 1; j <= i__2; ++j) {
clnid_(&j, &id, &found);
clgai_(&id, "HANDLES", &nh, handls, (ftnlen)7);
if (isrchi_(&handle, &nh, handls) > 0) {
/* This column is associated with this file. Store */
/* its name and id-code for the next section of code. */
/* write (*,*) 'Column id and associated handle match.' */
clgac_(&id, "NAME", cname, (ftnlen)4, (ftnlen)80);
appndc_(cname, tabcol, (ftnlen)80, (ftnlen)80);
appndi_(&id, colids);
}
}
/* Layout the pages. We perform a soft page reset */
/* so that the various sections will be empty. */
/* Note this doesn't affect frequency parameter */
/* or other geometry attributes of pages. */
/* write (*,*) 'Creating page: Title:' */
pagscn_("TITLE", (ftnlen)5);
pagput_(" ", (ftnlen)1);
pagput_("Summary of Loaded E-kernels", (ftnlen)27);
pagput_(" ", (ftnlen)1);
/* write (*,*) 'Creating page: Header' */
/* Set up the various items needed for the report header. */
pagscn_("HEADER", (ftnlen)6);
pagput_(" ", (ftnlen)1);
nicepr_1__(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("ekfils", i__2, "kerman_", (ftnlen)791)) * 127, style,
(S_fp)pagput_, (ftnlen)127, (ftnlen)80);
pagput_(" ", (ftnlen)1);
scolmn_(&c__1, &c__1, "Table Name", (ftnlen)10);
scolmn_(&c__2, &c__1, "Column Name", (ftnlen)11);
scolmn_(&c__3, &c__1, "Type", (ftnlen)4);
scolmn_(&c__4, &c__1, "Size", (ftnlen)4);
scolmn_(&c__5, &c__1, "Index", (ftnlen)5);
/* write (*,*) 'Creating page: Column headings' */
tabrpt_(&c__5, headr, sizes, width, justr, presrv, spcial, &lmarge, &
space, (U_fp)gcolmn_, (ftnlen)4);
s_copy(break__, "==================================================="
"=============================", (ftnlen)80, (ftnlen)80);
pagput_(break__, right);
/* Now set the page section to the body portion for */
/* preparing to fill in the e-kernel summary. */
/* write (*,*) 'Creating page: Body of report:' */
pagscn_("BODY", (ftnlen)4);
n = cardc_(tabcol, (ftnlen)80);
orderc_(tabcol + 480, &n, ordvec, (ftnlen)80);
s_copy(lsttab, " ", (ftnlen)32, (ftnlen)1);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
k = ordvec[(i__3 = j - 1) < 500 && 0 <= i__3 ? i__3 : s_rnge(
"ordvec", i__3, "kerman_", (ftnlen)826)];
clgac_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 : s_rnge(
"colids", i__3, "kerman_", (ftnlen)828)], "TABLE", tname,
(ftnlen)5, (ftnlen)32);
clgac_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 : s_rnge(
"colids", i__3, "kerman_", (ftnlen)829)], "NAME", cname, (
ftnlen)4, (ftnlen)80);
clgac_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 : s_rnge(
"colids", i__3, "kerman_", (ftnlen)830)], "SIZE", size, (
ftnlen)4, (ftnlen)32);
clgac_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 : s_rnge(
"colids", i__3, "kerman_", (ftnlen)831)], "INDEXED", indx,
(ftnlen)7, (ftnlen)4);
/* Note: There is only one type associated with each */
/* handle. Thus TCODE does not need to be an array. */
clgai_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 : s_rnge(
"colids", i__3, "kerman_", (ftnlen)836)], "TYPE", &count,
&tcode, (ftnlen)4);
if (s_cmp(tname, lsttab, (ftnlen)32, (ftnlen)32) == 0) {
s_copy(tname, " ", (ftnlen)32, (ftnlen)1);
} else if (s_cmp(lsttab, " ", (ftnlen)32, (ftnlen)1) != 0) {
pagput_(" ", (ftnlen)1);
s_copy(lsttab, tname, (ftnlen)32, (ftnlen)32);
} else {
s_copy(lsttab, tname, (ftnlen)32, (ftnlen)32);
}
nb = pos_(cname, ".", &c__1, (ftnlen)80, (ftnlen)1) + 1;
s_copy(name__, cname + (nb - 1), (ftnlen)32, 80 - (nb - 1));
if (tcode == 1) {
clgac_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 :
s_rnge("colids", i__3, "kerman_", (ftnlen)852)],
"TYPE", type__, (ftnlen)4, (ftnlen)32);
sb = pos_(type__, "*", &c__1, (ftnlen)32, (ftnlen)1);
s_copy(pval, "CH", (ftnlen)32, (ftnlen)2);
suffix_(type__ + (sb - 1), &c__0, pval, 32 - (sb - 1), (
ftnlen)32);
}
scolmn_(&c__6, &c__1, tname, (ftnlen)32);
scolmn_(&c__7, &c__1, name__, (ftnlen)32);
scolmn_(&c__8, &c__1, pval + (((i__3 = tcode - 1) < 4 && 0 <=
i__3 ? i__3 : s_rnge("pval", i__3, "kerman_", (ftnlen)860)
) << 5), (ftnlen)32);
scolmn_(&c__9, &c__1, size, (ftnlen)32);
scolmn_(&c__10, &c__1, indx, (ftnlen)4);
ids[0] = 6;
ids[1] = 7;
ids[2] = 8;
ids[3] = 9;
ids[4] = 10;
/* write (*,*) 'Creating next row:' */
/* write (*,*) TNAME */
/* write (*,*) NAME */
/* write (*,*) PVAL(TCODE) */
/* write (*,*) SIZE */
/* write (*,*) INDX */
tabrpt_(&c__5, ids, sizes, width, justr, presrv, spcial, &lmarge,
&space, (U_fp)gcolmn_, (ftnlen)4);
/* write (*,*) 'Row created.' */
}
/* Do a soft page reset so for the next file to be displayed */
/* write (*,*) 'Performing soft page reset.' */
pagsft_();
pagrst_();
pagset_("TITLEFREQUENCY", &c_n1, (ftnlen)14);
pagset_("HEADERFREQUENCY", &c__0, (ftnlen)15);
pagset_("NOSPACEFOOTER", &c__1, (ftnlen)13);
pagset_("FOOTERFREQUENCY", &c_n1, (ftnlen)15);
}
chkout_(rname, (ftnlen)6);
return 0;
/* $Procedure NSPEKC ( Inspekt the comments from EK files ) */
L_nspekc:
/* This entry point examines each file that matches the */
/* template given by INFILE and if comments exist for the */
/* file, they are displayed. */
/* Version 1.0.0 25-AUG-1995 (WLT) */
chkin_("NSPEKC", (ftnlen)6);
totalc = 0;
s_copy(thisfl, " ", (ftnlen)127, (ftnlen)1);
/* We might not need the style string, but it doesn't hurt to */
/* get it. */
nspmrg_(style, (ftnlen)80);
/* If there are no loaded E-kernels say so and return. */
if (nfiles == 0) {
s_copy(messge, "There are no E-kernels loaded now. ", (ftnlen)300, (
ftnlen)35);
nicepr_1__(messge, style, (S_fp)nspwln_, (ftnlen)300, (ftnlen)80);
chkout_("NSPEKC", (ftnlen)6);
return 0;
}
/* Count the number of characters present in the files */
/* that match the template. */
r__ = rtrim_(infile__, infile_len);
l = ltrim_(infile__, infile_len);
i__1 = nfiles;
for (i__ = 1; i__ <= i__1; ++i__) {
if (match_(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("ekfils", i__2, "kerman_", (ftnlen)945)) * 127,
infile__ + (l - 1), (ftnlen)127, r__ - (l - 1))) {
dasfnh_(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("ekfils", i__2, "kerman_", (ftnlen)947)) * 127, &
handle, (ftnlen)127);
dasrfr_(&handle, idword, ifname, &nresvr, &nresvc, &ncomr, &ncomc,
(ftnlen)8, (ftnlen)60);
totalc += ncomc;
++hits;
s_copy(thisfl, ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ?
i__2 : s_rnge("ekfils", i__2, "kerman_", (ftnlen)955)) *
127, (ftnlen)127, (ftnlen)127);
}
}
/* If we didn't get any characters there several possible */
/* reasons. We can look at HITS to see why and form a */
/* grammatically reasonable message. */
if (totalc == 0) {
if (hits == 0) {
s_copy(messge, "There are no E-kernels loaded whose file name ma"
"tches the supplied template '#'.", (ftnlen)300, (ftnlen)
80);
repmc_(messge, "#", infile__ + (l - 1), messge, (ftnlen)300, (
ftnlen)1, r__ - (l - 1), (ftnlen)300);
} else if (hits == 1) {
s_copy(messge, "There are no comments present in the file '#'. ",
(ftnlen)300, (ftnlen)47);
repmc_(messge, "#", thisfl, messge, (ftnlen)300, (ftnlen)1, (
ftnlen)127, (ftnlen)300);
} else if (hits == 2) {
s_copy(messge, "There are no comments present in either of the #"
" files that match the supplied template. ", (ftnlen)300, (
ftnlen)89);
repmct_(messge, "#", &hits, "L", messge, (ftnlen)300, (ftnlen)1, (
ftnlen)1, (ftnlen)300);
} else {
s_copy(messge, "There are no comments present in any of the # fi"
"les that match the supplied template. ", (ftnlen)300, (
ftnlen)86);
repmct_(messge, "#", &hits, "L", messge, (ftnlen)300, (ftnlen)1, (
ftnlen)1, (ftnlen)300);
}
nicepr_1__(messge, style, (S_fp)nspwln_, (ftnlen)300, (ftnlen)80);
chkout_("NSPEKC", (ftnlen)6);
return 0;
}
/* Ok. We've got something. Set up the output page to receive */
/* the comments a file at a time. */
suffix_("FLAG E-kernel:", &c__1, style, (ftnlen)14, (ftnlen)80);
i__1 = nfiles;
for (i__ = 1; i__ <= i__1; ++i__) {
if (match_(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("ekfils", i__2, "kerman_", (ftnlen)1012)) * 127,
infile__ + (l - 1), (ftnlen)127, r__ - (l - 1))) {
dasfnh_(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("ekfils", i__2, "kerman_", (ftnlen)1014)) * 127, &
handle, (ftnlen)127);
dasrfr_(&handle, idword, ifname, &nresvr, &nresvc, &ncomr, &ncomc,
(ftnlen)8, (ftnlen)60);
if (ncomc == 0) {
s_copy(messge, "# contains no comments.", (ftnlen)300, (
ftnlen)23);
repmc_(messge, "#", ekfils + ((i__2 = i__ - 1) < 20 && 0 <=
i__2 ? i__2 : s_rnge("ekfils", i__2, "kerman_", (
ftnlen)1023)) * 127, messge, (ftnlen)300, (ftnlen)1, (
ftnlen)127, (ftnlen)300);
nspwln_(" ", (ftnlen)1);
nicepr_1__(messge, style, (S_fp)nspwln_, (ftnlen)300, (ftnlen)
80);
} else {
pagrst_();
pagscn_("HEADER", (ftnlen)6);
pagset_("TITLEFREQUENCY", &c__0, (ftnlen)14);
pagset_("HEADERFREQUENCY", &c__0, (ftnlen)15);
pagset_("NOSPACEFOOTER", &c__1, (ftnlen)13);
pagset_("FOOTERFREQUENCY", &c_n1, (ftnlen)15);
pagput_(" ", (ftnlen)1);
nicepr_1__(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ?
i__2 : s_rnge("ekfils", i__2, "kerman_", (ftnlen)1038)
) * 127, style, (S_fp)pagput_, (ftnlen)127, (ftnlen)
80);
pagput_(" ", (ftnlen)1);
nspshc_(&handle, &quit);
if (quit) {
nspwln_(" ", (ftnlen)1);
chkout_("NSPEKC", (ftnlen)6);
return 0;
}
}
}
}
nspwln_(" ", (ftnlen)1);
chkout_("NSPEKC", (ftnlen)6);
return 0;
} /* kerman_ */
/* $ Procedure ZZCONVTB ( Convert kernel file from text to binary ) */
/* Subroutine */ int zzconvtb_(char *txtfil, char *arch, char *type__, char *
binfil, integer *number, ftnlen txtfil_len, ftnlen arch_len, ftnlen
type_len, ftnlen binfil_len)
{
/* System generated locals */
integer i__1;
cilist ci__1;
olist o__1;
cllist cl__1;
alist al__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), f_clos(cllist *), f_back(
alist *), s_rsfe(cilist *), do_fio(integer *, char *, ftnlen),
e_rsfe(void), f_open(olist *), s_wsfe(cilist *), e_wsfe(void);
/* Local variables */
char line[255];
extern /* Subroutine */ int daftb_(integer *, char *, ftnlen), spcac_(
integer *, integer *, char *, char *, ftnlen, ftnlen), chkin_(
char *, ftnlen), dastb_(integer *, char *, ftnlen), errch_(char *,
char *, ftnlen, ftnlen);
extern integer ltrim_(char *, ftnlen), rtrim_(char *, ftnlen);
extern /* Subroutine */ int daft2b_(integer *, char *, integer *, ftnlen);
extern logical failed_(void);
integer handle;
extern /* Subroutine */ int dafcls_(integer *);
logical havcom;
extern /* Subroutine */ int dafopw_(char *, integer *, ftnlen), sigerr_(
char *, ftnlen), chkout_(char *, ftnlen), getlun_(integer *),
setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
integer scrlun;
extern logical return_(void);
logical eoc;
/* $ Abstract */
/* Convert a SPICE text file into its equivalent binary format. */
/* NOTE: This routine is currently for use ONLY with the SPACIT */
/* utility program. Use it at your own risk. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* FILES */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* TXTFIL I Name of text file to be converted. */
/* BINARY I Name of a binary file to be created. */
/* $ Detailed_Input */
/* None. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Files */
/* 1) This routine uses a Fortran scratch file to temporarily */
/* store any lines of comments. */
/* $ Exceptions */
/* 1) If there is a problem opening or writing to the binary */
/* file, a routine that ZZCONVTB calls diagnoses and signals */
/* an error. */
/* 2) If there is a problem reading from the text file, the */
/* error SPICE(FILEREADFAILED) is signalled. */
/* 3) If there is a problem opening the scratch file, the error */
/* SPICE(FILEOPENERROR) is signalled. */
/* 4) If there is a problem writing to the scratch file, the */
/* error SPICE(FILEWRITEFAILED) is signalled. */
/* 5) If the binary file archictecture is not recognized, the error */
/* SPICE(UNSUPPBINARYARCH) will be signalled. */
/* 7) If the transfer file format is not recognized, the error */
/* SPICE(NOTATRANSFERFILE) will be signalled. */
/* 8) If the input file format cannot be identified, the error */
/* SPICE(UNRECOGNIZABLEFILE) will be signalled.. */
/* $ Particulars */
/* This routine is currently only for use with the SPACIT program. */
/* $ Examples */
/* $ Restrictions */
/* 1) This routine assumes that the data and comments in the */
/* text format SPK, PCK or CK file come from a binary file */
/* and were written by one of the SPICELIB binary to text */
/* conversion routines. Data and/or comments written any */
/* other way may not be in the correct format and, therefore, */
/* may not be handled properly. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* E.D. Wright (JPL) */
/* $ Version */
/* - Beta Version 1.0.0, 20-MAR-1999 (EDW) */
/* This routine is a modification of the CONVTB routine. */
/* Both have the same basic functionality, but this routine */
/* takes the unit number of the text file opened by ZZGETFAT, */
/* the architecture, and file type as input. ZZCONVTB does */
/* not open the file, ZZGETFAT performs that function. */
/* -& */
/* $ Index_Entries */
/* convert text SPICE files to binary */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Begin and end markers in the file for the comment area. */
/* Maximum length of an input text line. */
/* Maximum length of a file architecture. */
/* Maximum length of a file type. */
/* Number of reserved records to use when creating a binar DAF file. */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZCONVTB", (ftnlen)8);
}
/* Process the file based on the derived architecture and type. */
if (s_cmp(arch, "XFR", arch_len, (ftnlen)3) == 0 && s_cmp(type__, "DAF",
type_len, (ftnlen)3) == 0) {
/* We got a DAF file. */
/* Convert the data portion of the text file to binary. At this */
/* point, we know that we have a current DAF text file format. */
/* We expect to have comments. */
havcom = TRUE_;
/* Convert it. */
daftb_(number, binfil, binfil_len);
if (failed_()) {
/* If there was an error then we need to close the */
/* text file, and then check out and return to the */
/* caller. */
cl__1.cerr = 0;
cl__1.cunit = *number;
cl__1.csta = 0;
f_clos(&cl__1);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
} else if (s_cmp(arch, "XFR", arch_len, (ftnlen)3) == 0 && s_cmp(type__,
"DAS", type_len, (ftnlen)3) == 0) {
/* We got a DAS file. So we should begin converting it to binary. */
/* DAS files are easier: all we do is call one routine. */
/* We do not have comments. Actually, we might but they are */
/* included as part of the DAS file conversion process. */
havcom = FALSE_;
/* Convert it. */
dastb_(number, binfil, binfil_len);
if (failed_()) {
/* If there was an error then we need to close the */
/* text file, and then check out and return to the */
/* caller. */
cl__1.cerr = 0;
cl__1.cunit = *number;
cl__1.csta = 0;
f_clos(&cl__1);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
} else if (s_cmp(arch, "DAS", arch_len, (ftnlen)3) == 0) {
/* This is an error case, most likely caused by reading a binary */
/* DAS file by accident. So signal an appropriate error. */
setmsg_("The file '#' appears to be a binary DAS file and not a tran"
"sfer file.", (ftnlen)69);
errch_("#", txtfil, (ftnlen)1, txtfil_len);
sigerr_("SPICE(NOTATRANSFERFILE)", (ftnlen)23);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
} else if (s_cmp(arch, "DAS", arch_len, (ftnlen)3) == 0 && s_cmp(type__,
"PRE", type_len, (ftnlen)3) == 0) {
/* This is an error case, most likely caused by reading a binary */
/* DAS file by accident. So signal an appropriate error. */
cl__1.cerr = 0;
cl__1.cunit = *number;
cl__1.csta = 0;
f_clos(&cl__1);
setmsg_("The file '#' appears to be a pre-release binary DAS file an"
"d not a transfer file.", (ftnlen)81);
errch_("#", txtfil, (ftnlen)1, txtfil_len);
sigerr_("SPICE(NOTATRANSFERFILE)", (ftnlen)23);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
} else if (s_cmp(arch, "DAF", arch_len, (ftnlen)3) == 0) {
/* This is an error case, most likely caused by reading a binary */
/* DAF file by accident. So signal an appropriate error. */
setmsg_("The file '#' appears to be a binary DAF file and not a tran"
"sfer file.", (ftnlen)69);
errch_("#", txtfil, (ftnlen)1, txtfil_len);
sigerr_("SPICE(NOTATRANSFERFILE)", (ftnlen)23);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
} else if (s_cmp(arch, "DEC", arch_len, (ftnlen)3) == 0 && s_cmp(type__,
"DAF", type_len, (ftnlen)3) == 0) {
/* This is the case for the old text file format. It has no */
/* identifying marks whatsoever, so we simply have to try and */
/* convert it. */
/* We expect to have comments. */
havcom = TRUE_;
/* Back up one record so that we are positioned in the file where */
/* we were when this routine was entered. */
al__1.aerr = 0;
al__1.aunit = *number;
f_back(&al__1);
/* Convert it. */
daft2b_(number, binfil, &c__0, binfil_len);
if (failed_()) {
/* If there was an error then we need to close the text */
/* file, and then check out and return to the caller. */
cl__1.cerr = 0;
cl__1.cunit = *number;
cl__1.csta = 0;
f_clos(&cl__1);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
} else {
/* This is the catch all error case. At this point, we didn't */
/* match any of the files whose architecture and types are */
/* recognized. So, we toss our hands in the air and signal an */
/* error. */
setmsg_("The architecture and type of the file '#'could not be deter"
"mined.", (ftnlen)65);
errch_("#", txtfil, (ftnlen)1, txtfil_len);
sigerr_("SPICE(UNRECOGNIZABLEFILE)", (ftnlen)25);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
/* If we have comments to process, then process them. */
if (havcom) {
/* There are three situations that we need to consider here: */
/* 1) We have a SPICE text file with comments. This implies */
/* that we have a bunch of comments to be put into the */
/* comment area that are surrounded by the begin comments */
/* marker, BCMARK, and the end comemnts marker, ECMARK. */
/* 2) We are at the end of the file. This means that we have */
/* an old SPICE kernel file, from the good old days before */
/* the comment area was implemented, or we ahve a plain old */
/* ordinary DAF file. */
/* 3) We are not at the end of the file, but there are no */
/* comments. This means a text DAF file may be embedded */
/* in a larger text file or something. PDS does things like */
/* this: SFDUs and such. */
/* So, we need to look out for and deal with each of these */
/* possibilities. */
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = *number;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
iostat = do_fio(&c__1, line, (ftnlen)255);
if (iostat != 0) {
goto L100001;
}
iostat = e_rsfe();
L100001:
if (iostat > 0) {
/* If there was an error then we need to close the text */
/* file, and then check out and return to the caller. */
cl__1.cerr = 0;
cl__1.cunit = *number;
cl__1.csta = 0;
f_clos(&cl__1);
setmsg_("Error reading the text file: #. IOSTAT = #.", (ftnlen)43)
;
errch_("#", txtfil, (ftnlen)1, txtfil_len);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
/* If we encountered the end of the file, just check out and */
/* return. This is not an error. */
if (iostat < 0) {
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
/* We got a line, so left justify it and see if it matches the */
/* begin comments marker. If not, then use the Fortran BACKSPACE */
/* command to reposition the file pointer to be ready to read the */
/* line we just read. */
i__1 = ltrim_(line, (ftnlen)255) - 1;
if (s_cmp(line + i__1, "~NAIF/SPC BEGIN COMMENTS~", 255 - i__1, (
ftnlen)25) != 0) {
al__1.aerr = 0;
al__1.aunit = *number;
f_back(&al__1);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
/* We're not at the end of the file, and the line we read */
/* is BCMARK, so we write the comments to a scratch file. */
/* We do this because we have to use SPCAC to add the comments */
/* to the comment area of the binary file, and SPCAC rewinds */
/* the file. It's okay for SPCAC to rewind a scratch file, since */
/* it will probably not be very big, but it's not okay to rewind */
/* the file connected to NUMBER -- we don't know the initial */
/* location of the file pointer or how big the file is. */
getlun_(&scrlun);
o__1.oerr = 1;
o__1.ounit = scrlun;
o__1.ofnm = 0;
o__1.orl = 0;
o__1.osta = "SCRATCH";
o__1.oacc = "SEQUENTIAL";
o__1.ofm = "FORMATTED";
o__1.oblnk = 0;
iostat = f_open(&o__1);
if (iostat != 0) {
/* If there was an error then we need to close the text */
/* file, and then check out and return to the caller. */
cl__1.cerr = 0;
cl__1.cunit = scrlun;
cl__1.csta = 0;
f_clos(&cl__1);
cl__1.cerr = 0;
cl__1.cunit = *number;
cl__1.csta = 0;
f_clos(&cl__1);
setmsg_("Error opening temporary file. IOSTAT = #.", (ftnlen)41);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEOPENERROR)", (ftnlen)20);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
/* Continue reading lines from the text file and storing them */
/* in the scratch file until we get to the end marker. We do not */
/* write the begin and end markers to the scratch file. We do not */
/* need them. */
eoc = FALSE_;
while(! eoc) {
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = *number;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100002;
}
iostat = do_fio(&c__1, line, (ftnlen)255);
if (iostat != 0) {
goto L100002;
}
iostat = e_rsfe();
L100002:
if (iostat != 0) {
/* If there was an error then we need to close the */
/* scratch file, the text file, and then check out */
/* and return to the caller. */
cl__1.cerr = 0;
cl__1.cunit = scrlun;
cl__1.csta = 0;
f_clos(&cl__1);
cl__1.cerr = 0;
cl__1.cunit = *number;
cl__1.csta = 0;
f_clos(&cl__1);
setmsg_("Error reading the text file: #. IOSTAT = #.", (
ftnlen)43);
errch_("#", txtfil, (ftnlen)1, txtfil_len);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
/* If we are not at the end of the comments, then write the */
/* line ot the scratch file. Otherwise set the end of comments */
/* flag to .TRUE.. */
i__1 = ltrim_(line, (ftnlen)255) - 1;
if (s_cmp(line + i__1, "~NAIF/SPC END COMMENTS~", 255 - i__1, (
ftnlen)23) != 0) {
ci__1.cierr = 1;
ci__1.ciunit = scrlun;
ci__1.cifmt = "(A)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100003;
}
iostat = do_fio(&c__1, line, rtrim_(line, (ftnlen)255));
if (iostat != 0) {
goto L100003;
}
iostat = e_wsfe();
L100003:
if (iostat != 0) {
/* If there was an error then we need to close the */
/* scratch file, the text file, and then check out */
/* and return to the caller. */
cl__1.cerr = 0;
cl__1.cunit = scrlun;
cl__1.csta = 0;
f_clos(&cl__1);
cl__1.cerr = 0;
cl__1.cunit = *number;
cl__1.csta = 0;
f_clos(&cl__1);
setmsg_("Error writing to temporary file. IOSTAT = #.", (
ftnlen)44);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEWRITEFAILED)", (ftnlen)22);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
} else {
eoc = TRUE_;
}
}
/* Open the new binary file and add the comments that have been */
/* stored temporarily in a scratch file. */
dafopw_(binfil, &handle, binfil_len);
if (failed_()) {
/* If there was an error then we need to close the scratch */
/* file and the text file, and then check out and return to */
/* the caller. */
cl__1.cerr = 0;
cl__1.cunit = scrlun;
cl__1.csta = 0;
f_clos(&cl__1);
cl__1.cerr = 0;
cl__1.cunit = *number;
cl__1.csta = 0;
f_clos(&cl__1);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
spcac_(&handle, &scrlun, " ", " ", (ftnlen)1, (ftnlen)1);
if (failed_()) {
/* If there was an error then we need to close the scratch */
/* file and the text file, and then check out and return to */
/* the caller. */
cl__1.cerr = 0;
cl__1.cunit = scrlun;
cl__1.csta = 0;
f_clos(&cl__1);
cl__1.cerr = 0;
cl__1.cunit = *number;
cl__1.csta = 0;
f_clos(&cl__1);
dafcls_(&handle);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
/* We succeeded, so close the files we opened to deal with the */
/* comments. The scratch file is automatically deleted. */
cl__1.cerr = 0;
cl__1.cunit = scrlun;
cl__1.csta = 0;
f_clos(&cl__1);
dafcls_(&handle);
}
/* Close the transfer file. We know it is open, because we got here. */
cl__1.cerr = 0;
cl__1.cunit = *number;
cl__1.csta = 0;
f_clos(&cl__1);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
} /* zzconvtb_ */
/* $Procedure EXPFNM_1 ( Expand a filename ) */
/* Subroutine */ int expfnm_1__(char *infil, char *outfil, ftnlen infil_len,
ftnlen outfil_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen);
/* Local variables */
integer need, keep;
char word[255];
integer blank;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
integer inlen, slash;
extern integer rtrim_(char *, ftnlen);
integer dirlen;
extern /* Subroutine */ int getenv_(char *, char *, ftnlen, ftnlen);
integer wrdlen;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), repsub_(char *, integer *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen), setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen);
integer outlen;
extern logical return_(void);
char dir[255];
extern integer pos_(char *, char *, integer *, ftnlen, ftnlen);
/* $ Abstract */
/* Given a filename, expand it to be a full 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 */
/* FILES */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* INFIL I The filename to be expanded. */
/* OUTFIL O The expanded filename. */
/* $ Detailed_Input */
/* INFIL is the filename to be expanded. */
/* $ Detailed_Output */
/* OUTFIL is the expanded filename. If no expansion could be */
/* done, the value of OUTFIL is equal to the value of */
/* INFIL. OUTFIL may not overwrite INFIL. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the input filename is blank, begins with blank characters, */
/* or has embedded blanks in it, the error SPICE(BADFILENAME) */
/* is signalled. */
/* 2) If the expanded filename is too long to fit into the */
/* output string, the error SPICE(STRINGTOOSMALL) is signalled. */
/* 3) The output string may not overwrite the input string. */
/* 4) If no expansion of the input filename can be done, the */
/* output filename is assigned the value of the input filename. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The input filename may not be blank, begin with blank characters, */
/* nor may it it contain embedded blanks. As a general rule, */
/* SPICELIB routines do not allow blank characters as part of a */
/* filename. */
/* Unix platforms: */
/* On the Unix platforms, a filename containing an environment */
/* variable must be expanded completely before FORTRAN can do */
/* anything with it. FORTRAN interacts directly with the kernel, and */
/* as a result does not pass input filenames through the shell */
/* for expansion of environment variables. */
/* VAX/VMS, Alpha/OpenVMS platforms: */
/* The operating system does filname expansion itself, so this */
/* routine currently does not expand the name. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* Unix platforms: */
/* This routine cannot be used to expand a file name whose form */
/* is '~xxx', where xxx is an account name. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* $ Version */
/* - Beta Version 3.25.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - Beta Version 3.24.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - Beta Version 3.23.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - Beta Version 3.22.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - Beta Version 3.21.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - Beta Version 3.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - Beta Version 3.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - Beta Version 3.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - Beta Version 3.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - Beta Version 3.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - Beta Version 3.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - Beta Version 3.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - Beta Version 3.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - Beta Version 3.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - Beta Version 3.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - Beta Version 3.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - Beta Version 3.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - Beta Version 3.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - Beta Version 3.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - Beta Version 3.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - Beta Version 3.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - Beta Version 3.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - Beta Version 3.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - Beta Version 3.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - Beta Version 3.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - Beta Version 3.0.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - Beta Version 3.0.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are WIN-NT */
/* - Beta Version 3.0.3, 21-SEP-1999 (NJB) */
/* CSPICE environments were added. Some typos were corrected. */
/* - Beta Version 3.0.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - Beta Version 3.0.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - Beta Version 3.0.0, 05-APR-1998 (NJB) */
/* Added references to the PC-LINUX environment. */
/* - Beta Version 2.1.0, 5-JAN-1995 (HAN) */
/* Removed Sun Solaris environment since it is now the same */
/* as the Sun OS 4.1.x environment. */
/* Removed DEC Alpha/OpenVMS environment since it is now the */
/* same as the VAX environment. */
/* - Beta Version 2.0.0, 08-JUL-1994 (HAN) */
/* The capability of resolving a Unix filename that contains */
/* an environment variable directory specificiation plus a */
/* filename has been added. */
/* - Beta Version 1.0.0, 06-APR-1992 (HAN) */
/* -& */
/* $ Index_Entries */
/* expand a filename */
/* -& */
/* SPICELIB functions */
/* Parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("EXPFNM_1", (ftnlen)8);
}
/* If the input filename is blank, that's an error. */
if (s_cmp(infil, " ", infil_len, (ftnlen)1) == 0) {
setmsg_("The input filename '#' was blank.", (ftnlen)33);
errch_("#", infil, (ftnlen)1, infil_len);
sigerr_("SPICE(BADFILENAME)", (ftnlen)18);
chkout_("EXPFNM_1", (ftnlen)8);
return 0;
}
/* If there are blanks anywhere in the filename, SPICELIB */
/* considers the filename to be invalid. */
blank = pos_(infil, " ", &c__1, rtrim_(infil, infil_len), (ftnlen)1);
if (blank != 0) {
setmsg_("The input filename '#' had blank characters in it.", (ftnlen)
50);
errch_("#", infil, (ftnlen)1, infil_len);
sigerr_("SPICE(BADFILENAME)", (ftnlen)18);
chkout_("EXPFNM_1", (ftnlen)8);
return 0;
}
/* Look for a slash in the filename. */
slash = pos_(infil, "/", &c__1, infil_len, (ftnlen)1);
/* If we found a slash in a position other than the first */
/* character position, we want to examine the word that */
/* comes before it just in case it is an environment */
/* variable. */
if (slash > 1) {
s_copy(word, infil, (ftnlen)255, slash - 1);
getenv_(word, dir, (ftnlen)255, (ftnlen)255);
/* If the word was an environment variable, then construct */
/* the expanded filename. If it wasn't, just return the original */
/* input filename. */
if (s_cmp(dir, " ", (ftnlen)255, (ftnlen)1) != 0) {
s_copy(outfil, infil, outfil_len, infil_len);
inlen = rtrim_(infil, infil_len);
wrdlen = rtrim_(word, (ftnlen)255);
dirlen = rtrim_(dir, (ftnlen)255);
outlen = i_len(outfil, outfil_len);
keep = inlen - wrdlen;
need = keep + dirlen;
/* If the output filename length is not long enough for */
/* the substitution, signal an error. Otherwise, substitute */
/* in the new value. */
if (need > outlen) {
setmsg_("The expanded filename for the input filename '#' ex"
"ceeded the length of the output filename. The expand"
"ed name was # characters too long.", (ftnlen)137);
errch_("#", infil, (ftnlen)1, infil_len);
i__1 = need - outlen;
errint_("#", &i__1, (ftnlen)1);
sigerr_("SPICE(STRINGTOOSMALL)", (ftnlen)21);
chkout_("EXPFNM_1", (ftnlen)8);
return 0;
} else {
i__1 = slash - 1;
repsub_(infil, &c__1, &i__1, dir, outfil, infil_len, rtrim_(
dir, (ftnlen)255), outfil_len);
}
} else {
s_copy(outfil, infil, outfil_len, infil_len);
}
} else {
/* No slashes are in the filename, so it's just an easy case. */
/* It's possible that the entire filename is an environment */
/* variable. If it's not, then just return the input filename. */
getenv_(infil, outfil, infil_len, outfil_len);
if (s_cmp(outfil, " ", outfil_len, (ftnlen)1) == 0) {
s_copy(outfil, infil, outfil_len, infil_len);
}
}
chkout_("EXPFNM_1", (ftnlen)8);
return 0;
} /* expfnm_1__ */
/* $Procedure ZZGFRPWK ( Geometry finder report work done on a task ) */
/* Subroutine */ int zzgfrpwk_0_(int n__, integer *unit, doublereal *total,
doublereal *freq, integer *tcheck, char *begin, char *end, doublereal
*incr, ftnlen begin_len, ftnlen end_len)
{
/* Initialized data */
static integer calls = 0;
static integer stdout = 6;
static doublereal step = 0.;
static doublereal svincr = 0.;
static integer svunit = 6;
static integer check = 1;
static doublereal done = 0.;
static doublereal entire = 0.;
static char finish[13] = " ";
static logical first = TRUE_;
static integer ls = 1;
static doublereal lstsec = 0.;
static char start[55] = " "
" ";
/* System generated locals */
address a__1[5];
integer i__1[5];
doublereal d__1, d__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
/* Local variables */
doublereal tvec[6];
extern /* Subroutine */ int zzgfdsps_(integer *, char *, char *, integer *
, ftnlen, ftnlen), zzcputim_(doublereal *), chkin_(char *, ftnlen)
, dpfmt_(doublereal *, char *, char *, ftnlen, ftnlen), stdio_(
char *, integer *, ftnlen);
extern integer rtrim_(char *, ftnlen);
extern doublereal brcktd_(doublereal *, doublereal *, doublereal *);
doublereal fractn;
char messge[78];
doublereal cursec;
char prcent[10];
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen);
extern logical return_(void);
extern /* Subroutine */ int writln_(char *, integer *, ftnlen);
/* $ Abstract */
/* The entry points under this routine allows one to easily monitor */
/* the status of job in progress. */
/* $ 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 */
/* GF */
/* $ Keywords */
/* UTILITY */
/* REPORT */
/* WORK */
/* $ Declarations */
/* $ Abstract */
/* SPICE private include file intended solely for the support of */
/* SPICE routines. Users should not include this routine in their */
/* source code due to the volatile nature of this file. */
/* This file contains private, global parameter declarations */
/* for the SPICELIB Geometry Finder (GF) subsystem. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* GF */
/* $ Keywords */
/* GEOMETRY */
/* ROOT */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* E.D. Wright (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 17-FEB-2009 (NJB) (EDW) */
/* -& */
/* The set of supported coordinate systems */
/* System Coordinates */
/* ---------- ----------- */
/* Rectangular X, Y, Z */
/* Latitudinal Radius, Longitude, Latitude */
/* Spherical Radius, Colatitude, Longitude */
/* RA/Dec Range, Right Ascension, Declination */
/* Cylindrical Radius, Longitude, Z */
/* Geodetic Longitude, Latitude, Altitude */
/* Planetographic Longitude, Latitude, Altitude */
/* Below we declare parameters for naming coordinate systems. */
/* User inputs naming coordinate systems must match these */
/* when compared using EQSTR. That is, user inputs must */
/* match after being left justified, converted to upper case, */
/* and having all embedded blanks removed. */
/* Below we declare names for coordinates. Again, user */
/* inputs naming coordinates must match these when */
/* compared using EQSTR. */
/* Note that the RA parameter value below matches */
/* 'RIGHT ASCENSION' */
/* when extra blanks are compressed out of the above value. */
/* Parameters specifying types of vector definitions */
/* used for GF coordinate searches: */
/* All string parameter values are left justified, upper */
/* case, with extra blanks compressed out. */
/* POSDEF indicates the vector is defined by the */
/* position of a target relative to an observer. */
/* SOBDEF indicates the vector points from the center */
/* of a target body to the sub-observer point on */
/* that body, for a given observer and target. */
/* SOBDEF indicates the vector points from the center */
/* of a target body to the surface intercept point on */
/* that body, for a given observer, ray, and target. */
/* Number of workspace windows used by ZZGFREL: */
/* Number of additional workspace windows used by ZZGFLONG: */
/* Index of "existence window" used by ZZGFCSLV: */
/* Progress report parameters: */
/* MXBEGM, */
/* MXENDM are, respectively, the maximum lengths of the progress */
/* report message prefix and suffix. */
/* Note: the sum of these lengths, plus the length of the */
/* "percent complete" substring, should not be long enough */
/* to cause wrap-around on any platform's terminal window. */
/* Total progress report message length upper bound: */
/* End of file zzgf.inc. */
/* $ Brief_I/O */
/* VARIABLE I/O Entry points */
/* -------- --- -------------------------------------------------- */
/* UNIT I-O ZZGFWKUN, ZZGFWKMO */
/* TOTAL I-O ZZGFTSWK, ZZGFWKAD, ZZGFWKMO */
/* FREQ I-O ZZGFTSWK, ZZGFWKAD, ZZGFWKMO */
/* TCHECK I-O ZZGFTSWK, ZZGFWKAD, ZZGFWKMO */
/* BEGIN I-O ZZGFTSWK, ZZGFWKAD, ZZGFWKMO */
/* END I-O ZZGFTSWK, ZZGFWKAD, ZZGFWKMO */
/* INCR I-O ZZGFWKIN, ZZGFWKMO */
/* $ Detailed_Input */
/* See the headers of the entry points. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* MXBEGM, */
/* MXENDM, */
/* MXMSG are, respectively, the maximum lengths of the progress */
/* message prefix, progress message suffix, and the */
/* complete message. */
/* $ Exceptions */
/* If this routine is called directly, the error SPICE(BOGUSENTRY) */
/* is signaled. */
/* See the entry points for descriptions of exceptions they detect. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The entry points under this routine are designed to allow one to */
/* easily build into his/her application a monitoring facility */
/* that reports how work on a particular task is proceeding. */
/* There are five entry points: ZZGFTSWK, ZZGFWKIN, ZZGFWKAD, */
/* ZZGFWKUN, and ZZGFWKMO. */
/* The first entry point ZZGFTSWK is used to initialize the reporter. */
/* It is used to tell the reporter "I have some work to do. This is */
/* how much, and this is how often I want you to report on the */
/* progress of the task." */
/* The second entry point ZZGFWKIN is used to tell the reporter "I've */
/* just finished some of the task I told you about with ZZGFTSWK. */
/* This is how much I've just done." (As in real life, the amount */
/* of work you've just done can be negative.) The reporter uses */
/* this information together with the information input in ZZGFTSWK */
/* to decide whether and how much work to report as finished. The */
/* reports will be sent to the current output device. */
/* The third entry point, ZZGFWKAD, adjusts the frequency with which */
/* work progress is reported. */
/* The fourth entry point ZZGFWKUN also is used for testing. It is */
/* used to send the output to the file connected to a specified */
/* logical unit. */
/* The fifth entry point ZZGFWKMO is used for testing. It returns */
/* the saved search parameters. */
/* A more detailed description of each entry point is provided in its */
/* associated header. */
/* $ Examples */
/* A typical use of ZZGFRPWK might be as follows. */
/* C */
/* C Compute how much work is to be done and put it in TOTAL */
/* C */
/* code */
/* computing */
/* how */
/* much */
/* work */
/* to */
/* do */
/* . */
/* . */
/* . */
/* TOTAL = <the amount of work to do> */
/* C */
/* C Tell the work reporter to report work completed every */
/* C 3 seconds. (The third argument in ZZGFTSWK is explained */
/* C in the header for ZZGFTSWK.) */
/* C */
/* FREQUENCY = 3.0D0 */
/* BEGIN = 'Current work status: ' */
/* END = 'completed. ' */
/* CALL ZZGFTSWK ( TOTAL, FREQUENCY, 1, BEGIN, END ) */
/* DO WHILE ( THERE_IS_MORE_WORK_TO_DO ) */
/* code that */
/* performs */
/* the work to */
/* be done */
/* AMOUNT = amount of work done in this loop pass */
/* CALL ZZGFWKIN ( AMOUNT ) */
/* END DO */
/* $ Restrictions */
/* You can use this routine to report progress on only one task at */
/* a time. The work reporter must be initialized using ZZGFTSWK */
/* before calling ZZGFWKIN. Failure to do this may lead to */
/* unexpected results. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* L.S. Elson (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0 17-FEB-2009 (NJB) (LSE) (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* GF low-level progress report umbrella */
/* -& */
/* SPICELIB Functions */
/* Local variables */
/* Saved variables */
/* Initial values */
switch(n__) {
case 1: goto L_zzgftswk;
case 2: goto L_zzgfwkin;
case 3: goto L_zzgfwkad;
case 4: goto L_zzgfwkun;
case 5: goto L_zzgfwkmo;
}
chkin_("ZZGFRPWK", (ftnlen)8);
sigerr_("SPICE(BOGUSENTRY)", (ftnlen)17);
chkout_("ZZGFRPWK", (ftnlen)8);
return 0;
/* $Procedure ZZGFTSWK ( Geometry finder total sum of work to be done. ) */
L_zzgftswk:
/* $ Abstract */
/* Initialize the work progress utility. This is required prior to */
/* use of the routine that performs the actual reporting. */
/* $ 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 */
/* GF */
/* $ Keywords */
/* UTILITY */
/* REPORT */
/* WORK */
/* $ Declarations */
/* DOUBLE PRECISION TOTAL */
/* DOUBLE PRECISION FREQ */
/* INTEGER TCHECK */
/* CHARACTER*(*) BEGIN */
/* CHARACTER*(*) END */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* TOTAL I A measure of the total amount of work to be done. */
/* FREQ I How often the work progress should be reported. */
/* TCHECK I How often to sample the system clock. */
/* BEGIN I First part of the output message. */
/* END I Last part of the output message. */
/* $ Detailed_Input */
/* UNIT is a logical unit connected to the output stream */
/* to which the progress report should be sent. */
/* Normally UNIT is set to the standard output unit, */
/* which can be obtained by calling the SPICELIB */
/* routine STDIO. Unit can be a logical unit connected */
/* to a file; this feature supports testing. */
/* TOTAL is a measure of the total amount of work to be done */
/* by the routine(s) that will be using this facility. */
/* It is expected (but not required) that TOTAL is a */
/* positive number. */
/* FREQ is the how often the work progress should be reported */
/* in seconds. If FREQ = 5 then a work progress report */
/* will be sent to the output device approximately every */
/* 5 seconds. Since writing to the output device takes */
/* time, the smaller FREQ is set, the greater the overhead */
/* taken up by the work reporter will be. ( A value of 2 */
/* or greater should not burden your application */
/* appreciably ) */
/* TCHECK is an integer used to the tell the reporter how often */
/* to sample the system clock. If TCHECK = 7, then on */
/* every seventh call to ZZGFWKIN, the system clock will */
/* be sampled to determine if FREQ seconds have elapsed */
/* since the last report time. Sampling the system clock */
/* takes time. Not a lot of time, but it does take time. */
/* If ZZGFWKIN is being called from a loop that does not */
/* take a lot of time for each pass, the sampling of */
/* the system clock can become a significant overhead */
/* cost in itself. On the VAX the sampling of the */
/* system clock used here takes about 37 double precision */
/* multiplies. If thousands of multiplies take place */
/* between calls to ZZGFWKIN, the sampling time is */
/* insignificant. On the other hand, if only a hundred or */
/* so multiplies occur between calls to ZZGFWKIN, the */
/* sampling of the system clock can become a significant */
/* fraction of your overhead. TCHECK allows you to */
/* tailor the work reporter to your application. */
/* If a non-positive value for TCHECK is entered, a value */
/* of 1 will be used instead of the input value. */
/* BEGIN Is the first part of the output message that will be */
/* constructed for shipment to the output device. This */
/* message will have the form: */
/* BEGIN // xx.x% // END */
/* where xx.x is the percentage of the job completed when */
/* the output message is sent to the output device. */
/* END is the second part of the output message that will be */
/* constructed and sent to the output device (see above). */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Standard SPICE error handling. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This entry point is used to initialize parameters that will */
/* be used by ZZGFWKIN. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* See the header for this module */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* L.S. Elson (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0 17-FEB-2009 (NJB) (LSE) (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* GF low-level initialize progress report */
/* -& */
if (return_()) {
return 0;
}
chkin_("ZZGFTSWK", (ftnlen)8);
/* On the first pass, obtain the logical unit for */
/* standard output. */
if (first) {
stdio_("STDOUT", &stdout, (ftnlen)6);
/* The output unit is STDOUT unless the caller */
/* sets it to something else. */
svunit = stdout;
first = FALSE_;
}
/* Save the inputs and set the amount of work done to 0 */
entire = *total;
/* Computing MIN */
d__1 = 3600., d__2 = max(0.,*freq);
step = min(d__1,d__2);
check = max(1,*tcheck);
s_copy(start, begin, (ftnlen)55, begin_len);
s_copy(finish, end, (ftnlen)13, end_len);
done = 0.;
/* Set the timer. */
zzcputim_(tvec);
lstsec = tvec[3] * 3600. + tvec[4] * 60. + tvec[5];
/* Set the increment counter */
calls = 0;
/* Compose the output message. */
ls = rtrim_(start, (ftnlen)55);
/* Writing concatenation */
i__1[0] = ls, a__1[0] = start;
i__1[1] = 1, a__1[1] = " ";
i__1[2] = 7, a__1[2] = " 0.00%";
i__1[3] = 1, a__1[3] = " ";
i__1[4] = 13, a__1[4] = finish;
s_cat(messge, a__1, i__1, &c__5, (ftnlen)78);
/* Display a blank line, make sure we don't overwrite anything */
/* at the bottom of the screen. The display the message. */
if (svunit == stdout) {
zzgfdsps_(&c__1, messge, "A", &c__0, (ftnlen)78, (ftnlen)1);
} else {
/* Write the message without special carriage control. */
writln_(" ", &svunit, (ftnlen)1);
writln_(" ", &svunit, (ftnlen)1);
writln_(messge, &svunit, (ftnlen)78);
}
chkout_("ZZGFTSWK", (ftnlen)8);
return 0;
/* $Procedure ZZGFWKIN ( Geometry finder work finished increment ) */
L_zzgfwkin:
/* $ Abstract */
/* Let the work reporter know that an increment of work has just */
/* been completed. */
/* $ 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 */
/* GF */
/* $ Keywords */
/* UTILITY */
/* REPORT */
/* WORK */
/* $ Declarations */
/* DOUBLE PRECISION INCR */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* INCR I An amount of work just completed. */
/* $ Detailed_Input */
/* INCR is some amount of work that has been completed since */
/* the last call to ZZGFWKIN. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Standard SPICE error handling. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This entry point is used to report work that has been done since */
/* initialization was performed using ZZGFTSWK or since the last */
/* call to ZZGFWKIN. The work reporter uses this information */
/* together with samples of the system clock to report how much of */
/* the total job has been completed. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* See the header for this module */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* L.S. Elson (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0 17-FEB-2009 (NJB) (LSE) (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* ZZGF low-level progress report increment */
/* -& */
if (return_()) {
return 0;
}
chkin_("ZZGFWKIN", (ftnlen)8);
svincr = *incr;
done += *incr;
++calls;
if (entire == 0.) {
chkout_("ZZGFWKIN", (ftnlen)8);
return 0;
}
if (calls >= check) {
calls = 0;
zzcputim_(tvec);
cursec = tvec[3] * 3600. + tvec[4] * 60. + tvec[5];
if ((d__1 = cursec - lstsec, abs(d__1)) >= step) {
lstsec = cursec;
/* Report how much work has been done. */
d__1 = done / entire * 100.;
fractn = brcktd_(&d__1, &c_b19, &c_b20);
dpfmt_(&fractn, "xxx.xx", prcent, (ftnlen)6, (ftnlen)10);
*(unsigned char *)&prcent[6] = '%';
/* Writing concatenation */
i__1[0] = ls, a__1[0] = start;
i__1[1] = 1, a__1[1] = " ";
i__1[2] = 7, a__1[2] = prcent;
i__1[3] = 1, a__1[3] = " ";
i__1[4] = rtrim_(finish, (ftnlen)13), a__1[4] = finish;
s_cat(messge, a__1, i__1, &c__5, (ftnlen)78);
if (svunit == stdout) {
zzgfdsps_(&c__0, messge, "A", &c__0, (ftnlen)78, (ftnlen)1);
} else {
/* Write the message without special carriage control. */
writln_(messge, &svunit, (ftnlen)78);
}
}
}
chkout_("ZZGFWKIN", (ftnlen)8);
return 0;
/* $Procedure ZZGFWKAD ( Geometry finder work reporting adjustment ) */
L_zzgfwkad:
/* $ Abstract */
/* Adjust the frequency with which work progress is reported. */
/* $ 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 */
/* GF */
/* $ Keywords */
/* UTILITY */
/* REPORT */
/* WORK */
/* $ Declarations */
/* DOUBLE PRECISION FREQ */
/* INTEGER TCHECK */
/* CHARACTER*(*) BEGIN */
/* CHARACTER*(*) END */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* TOTAL I A measure of the total amount of work to be done. */
/* FREQ I How often the work progress should be reported. */
/* BEGIN I First part of the output message. */
/* END I Last part of the output message. */
/* $ Detailed_Input */
/* FREQ is the how often the work progress should be reported */
/* in seconds. If FREQ = 5 then a work progress report */
/* will be sent to the output device approximately every */
/* 5 seconds. Since writing to the output device takes */
/* time, the smaller FREQ is set, the greater the overhead */
/* taken up by the work reporter will be. ( A value of 2 */
/* or greater should not burden your application */
/* appreciably ) */
/* TCHECK is an integer used to the tell the reporter how often */
/* to sample the system clock. If TCHECK = 7, then on */
/* every seventh call to ZZGFWKIN, the system clock will */
/* be sampled to determine if FREQ seconds have elapsed */
/* since the last report time. Sampling the system clock */
/* takes time. Not a lot of time, but it does take time. */
/* If ZZGFWKIN is being called from a loop that does not */
/* take a lot of time for each pass, the sampling of */
/* the system clock can become a significant overhead */
/* cost in itself. On the VAX the sampling of the */
/* system clock used here takes about 37 double precision */
/* multiplies. If thousands of multiplies take place */
/* between calls to ZZGFWKIN, the sampling time is */
/* insignificant. On the other hand, if only a hundred or */
/* so multiplies occur between calls to ZZGFWKIN, the */
/* sampling of the system clock can become a significant */
/* fraction of your overhead. TCHECK allows you to */
/* tailor the work reporter to your application. */
/* If a non-positive value for TCHECK is entered, a value */
/* of 1 will be used instead of the input value. */
/* BEGIN Is the first part of the output message that will be */
/* constructed for shipment to the output device. This */
/* message will have the form: */
/* BEGIN // xx.x% // END */
/* where xx.x is the percentage of the job completed when */
/* the output message is sent to the output device. */
/* END is the second part of the output message that will be */
/* constructed and sent to the output device (see above). */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* 1) If TCHECK is less than 1, the value 1 is stored. */
/* 2) If FREQ is less than 0.1, the value 0.1 is stored. */
/* If FREQ is greater than 3600, the value 3600 is stored. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This entry point exists to modify the reporting frequency set */
/* up by an initial call to ZZGFTSWK. In this way one can override */
/* how often reporting of work increments is performed, without */
/* causing the screen to be modified (which happens if a new */
/* call to ZZGFTSWK is made.) */
/* It exists primarily as a back door to existing code */
/* that calls ZZGFTSWK in a rigid way. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* See the header for this module. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* L.S. Elson (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0 17-FEB-2009 (NJB) (LSE) (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* GF low-level progress report adjust frequency */
/* -& */
/* Computing MIN */
d__1 = 3600., d__2 = max(0.,*freq);
step = min(d__1,d__2);
check = max(1,*tcheck);
s_copy(start, begin, (ftnlen)55, begin_len);
s_copy(finish, end, (ftnlen)13, end_len);
return 0;
/* $Procedure ZZGFWUN ( Geometry finder set work report output unit ) */
L_zzgfwkun:
/* $ Abstract */
/* Set the output unit for the progress report. */
/* $ 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 */
/* GF */
/* $ Keywords */
/* UTILITY */
/* REPORT */
/* WORK */
/* $ Declarations */
/* INTEGER UNIT */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* UNIT I Output logical unit. */
/* $ Detailed_Input */
/* UNIT Logical unit of a text file open for write access. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* The file designated by UNIT should be a text file opened by the */
/* calling application. */
/* $ Particulars */
/* This routine can be called before ZZGFTSWK to set the output */
/* logical unit to that of a text file. */
/* This entry point exists to support testing of the higher-level */
/* GF progress reporting routines */
/* GFREPI */
/* GFREPU */
/* GFREPF */
/* This routine enables TSPICE to send the output report to */
/* a specified file. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0 17-FEB-2009 (NJB) */
/* -& */
/* $ Index_Entries */
/* GF low-level progress report output select unit */
/* -& */
/* On the first pass, obtain the logical unit for */
/* standard output. */
if (first) {
stdio_("STDOUT", &stdout, (ftnlen)6);
first = FALSE_;
}
svunit = *unit;
return 0;
/* $Procedure ZZGFWKMO ( Geometry finder work reporting monitor ) */
L_zzgfwkmo:
/* $ Abstract */
/* Return saved progress report parameters. */
/* $ 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 */
/* GF */
/* $ Keywords */
/* UTILITY */
/* REPORT */
/* WORK */
/* $ Declarations */
/* INTEGER UNIT */
/* DOUBLE PRECISION TOTAL */
/* DOUBLE PRECISION FREQ */
/* INTEGER TCHECK */
/* CHARACTER*(*) BEGIN */
/* CHARACTER*(*) END */
/* DOUBLE PRECISION INCR */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* UNIT O Output logical unit. */
/* TOTAL O A measure of the total amount of work to be done. */
/* FREQ O How often the work progress should be reported. */
/* TCHECK O Number of calls between system time check. */
/* BEGIN O First part of the output message. */
/* END O Last part of the output message. */
/* INCR O Last progress increment. */
/* $ Detailed_Input */
/* None. */
/* $ Detailed_Output */
/* UNIT, */
/* TOTAL, */
/* FREQ, */
/* TCHECK, */
/* BEGIN, */
/* END, */
/* INCR are the most recent values of these */
/* variables passed in via calls to ZZGFTSWK, */
/* ZZGFWKIN, or ZZGFWKAD. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This entry point exists to support testing of the higher-level */
/* GF progress reporting routines */
/* GFREPI */
/* GFREPU */
/* GFREPF */
/* This routine enables TSPICE to determine the values passed */
/* in to entry points of this package by those routines. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0 17-FEB-2009 (NJB) */
/* -& */
/* $ Index_Entries */
/* GF low-level progress report monitor */
/* -& */
*unit = svunit;
*total = entire;
*freq = step;
*tcheck = check;
s_copy(begin, start, begin_len, (ftnlen)55);
s_copy(end, finish, end_len, (ftnlen)13);
*incr = svincr;
return 0;
} /* zzgfrpwk_ */
/* $Procedure VERSION ( Print library version information ) */
/* Main program */ MAIN__(void)
{
/* System generated locals */
address a__1[2], a__2[4];
integer i__1[2], i__2, i__3[4], i__4;
doublereal d__1;
char ch__1[25], ch__2[99];
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen),
s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
char line[80], vrsn[6];
extern /* Subroutine */ int zzplatfm_(char *, char *, ftnlen, ftnlen);
integer i__;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
extern doublereal dpmin_(void);
extern /* Subroutine */ int repmd_(char *, char *, doublereal *, integer *
, char *, ftnlen, ftnlen, ftnlen);
extern doublereal dpmax_(void);
char fform[80];
extern /* Subroutine */ int repmi_(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
char cmplr[80];
extern integer wdcnt_(char *, ftnlen);
char tform[80];
extern integer rtrim_(char *, ftnlen);
char os[80];
extern /* Subroutine */ int getcml_(char *, ftnlen), byebye_(char *,
ftnlen);
extern integer intmin_(void), intmax_(void);
char linout[80*6];
extern /* Subroutine */ int tostdo_(char *, ftnlen), tkvrsn_(char *, char
*, ftnlen, ftnlen);
extern integer pos_(char *, char *, integer *, ftnlen, ftnlen);
char sys[80];
/* $ Abstract */
/* This program prints to standard output the current SPICE */
/* distribution version number, hardware system ID, operating */
/* system ID, compiler name, the format of double precision */
/* numbers for the hardware architecture, and the max and min */
/* values for double precision and integer numbers. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keyword */
/* VERSION */
/* UTILITY */
/* $ Parameters */
/* LINELN length of line output string, set to 80. */
/* DATEID update version time string, set to 20. */
/* $ Exceptions */
/* None. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The version utility may use 3 different command line arguments. */
/* The default (no arguments) returns the Toolkit version string. */
/* Usage: $ version [OPTION] */
/* $ Description */
/* None. */
/* $ Examples */
/* Default behavior: */
/* $ version */
/* N0051 */
/* Display all (-a) information: */
/* $version -a */
/* Toolkit version : N0051 */
/* System : PC */
/* Operating System : LINUX */
/* Compiler : LINUX G77 */
/* File Format : LTL-IEEE */
/* MAX DP : 1.7976931348623E+308 */
/* MIN DP : -1.7976931348623E+308 */
/* MAX INT : 2147483647 */
/* MIN INT : -2147483647 */
/* Display version (-v) information: */
/* $version -v */
/* Version Utility for SPICE Toolkit edition N0051, */
/* last update: 1.1.0, 05-OCT-2001 */
/* Display help (-h) information: */
/* $version -h */
/* Usage: version [OPTION] */
/* no arguments output only the SPICE toolkit version string. */
/* -a(ll) output all environment variables; SPICE toolkit */
/* version, system ID, operating system, compiler, */
/* binary file format, max and min values for */
/* double precision and integer numbers. */
/* -v(ersion) output the version of the utility. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* F.S. Turner (JPL) */
/* E.D. Wright (JPL) */
/* $ Version */
/* SPICELIB Version 1.1.0 26-SEP-2001 (FST) (EDW) */
/* Added TEXT_FORMAT output. */
/* Included options for SYSTEM, O/S, COMPILER, FILE_FORMAT, */
/* max/min DPs & integers, outputs, version, and help. */
/* Added proper SPICE header. */
/* SPICELIB Version 1.0.0 13-NOV-2001 (WLT) */
/* First version, Thu NOV 13 10:04:41 PST 1997 W.L. Taber */
/* -& */
/* SPICELIB functions. */
/* Local Parameters. */
/* Local Variables. */
/* Get command line. */
getcml_(line, (ftnlen)80);
ucase_(line, line, (ftnlen)80, (ftnlen)80);
tkvrsn_("TOOLKIT", vrsn, (ftnlen)7, (ftnlen)6);
/* Parse the command line for arguments. Appropriately respond. */
if (wdcnt_(line, (ftnlen)80) == 0) {
/* No arguments, default to the toolkit version string. */
tostdo_(vrsn, rtrim_(vrsn, (ftnlen)6));
} else if (pos_(line, "-A", &c__1, (ftnlen)80, (ftnlen)2) == 1) {
/* All. Output everything. */
tostdo_(" ", (ftnlen)1);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "Toolkit version : ";
i__1[1] = 6, a__1[1] = vrsn;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)25);
tostdo_(ch__1, (ftnlen)25);
zzplatfm_("SYSTEM", sys, (ftnlen)6, (ftnlen)80);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "System : ";
i__1[1] = 80, a__1[1] = sys;
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)99);
tostdo_(ch__2, (ftnlen)99);
zzplatfm_("O/S", os, (ftnlen)3, (ftnlen)80);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "Operating System : ";
i__1[1] = 80, a__1[1] = os;
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)99);
tostdo_(ch__2, (ftnlen)99);
zzplatfm_("COMPILER", cmplr, (ftnlen)8, (ftnlen)80);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "Compiler : ";
i__1[1] = 80, a__1[1] = cmplr;
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)99);
tostdo_(ch__2, (ftnlen)99);
zzplatfm_("FILE_FORMAT", fform, (ftnlen)11, (ftnlen)80);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "File Format : ";
i__1[1] = 80, a__1[1] = fform;
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)99);
tostdo_(ch__2, (ftnlen)99);
zzplatfm_("TEXT_FORMAT", tform, (ftnlen)11, (ftnlen)80);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "Text File Format : ";
i__1[1] = 80, a__1[1] = tform;
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)99);
tostdo_(ch__2, (ftnlen)99);
s_copy(linout, "MAX DP : #", (ftnlen)80, (ftnlen)21);
d__1 = dpmax_();
repmd_(linout, "#", &d__1, &c__23, linout, (ftnlen)80, (ftnlen)1, (
ftnlen)80);
tostdo_(linout, (ftnlen)80);
s_copy(linout + 80, "MIN DP : #", (ftnlen)80, (ftnlen)20);
d__1 = dpmin_();
repmd_(linout + 80, "#", &d__1, &c__23, linout + 80, (ftnlen)80, (
ftnlen)1, (ftnlen)80);
tostdo_(linout + 80, (ftnlen)80);
s_copy(linout + 160, "MAX INT : #", (ftnlen)80, (ftnlen)21);
i__2 = intmax_();
repmi_(linout + 160, "#", &i__2, linout + 160, (ftnlen)80, (ftnlen)1,
(ftnlen)80);
tostdo_(linout + 160, (ftnlen)80);
s_copy(linout + 240, "MIN INT : #", (ftnlen)80, (ftnlen)20);
i__2 = intmin_();
repmi_(linout + 240, "#", &i__2, linout + 240, (ftnlen)80, (ftnlen)1,
(ftnlen)80);
tostdo_(linout + 240, (ftnlen)80);
tostdo_(" ", (ftnlen)1);
} else if (pos_(line, "-V", &c__1, (ftnlen)80, (ftnlen)2) == 1) {
/* Version. Output the utility version string. */
/* Writing concatenation */
i__3[0] = 42, a__2[0] = "Version Utility for SPICE Toolkit edition ";
i__3[1] = rtrim_(vrsn, (ftnlen)6), a__2[1] = vrsn;
i__3[2] = 15, a__2[2] = ", last update: ";
i__3[3] = 18, a__2[3] = "1.1.0, 07-JAN-2002 ";
s_cat(linout, a__2, i__3, &c__4, (ftnlen)80);
tostdo_(" ", (ftnlen)1);
tostdo_(linout, (ftnlen)80);
tostdo_(" ", (ftnlen)1);
} else if (pos_(line, "-H", &c__1, (ftnlen)80, (ftnlen)2) == 1) {
/* Help. How does does one use this perplexing routine? */
s_copy(linout, "Usage: version [OPTION]", (ftnlen)80, (ftnlen)23);
s_copy(linout + 80, " no arguments output only the SPICE toolkit v"
"ersion string.", (ftnlen)80, (ftnlen)61);
s_copy(linout + 160, " -a(ll) output all environment variabl"
"es; SPICE toolkit version, system", (ftnlen)80, (ftnlen)79);
s_copy(linout + 240, " ID, operating system, compiler"
", and binary file format, ", (ftnlen)80, (ftnlen)72);
s_copy(linout + 320, " max and min values for double "
"precision and integer numbers.", (ftnlen)80, (ftnlen)76);
s_copy(linout + 400, " -v(ersion) output the version of the util"
"ity.", (ftnlen)80, (ftnlen)50);
tostdo_(" ", (ftnlen)1);
for (i__ = 1; i__ <= 6; ++i__) {
tostdo_(linout + ((i__2 = i__ - 1) < 6 && 0 <= i__2 ? i__2 :
s_rnge("linout", i__2, "version_", (ftnlen)272)) * 80,
rtrim_(linout + ((i__4 = i__ - 1) < 6 && 0 <= i__4 ? i__4
: s_rnge("linout", i__4, "version_", (ftnlen)272)) * 80, (
ftnlen)80));
}
tostdo_(" ", (ftnlen)1);
} else {
/* The user put something on the command line, but nothing */
/* known. Return the toolkit version string. */
tostdo_(vrsn, rtrim_(vrsn, (ftnlen)6));
}
/* Done. Indicate as much. Say bye. */
byebye_("SUCCESS", (ftnlen)7);
s_stop("", (ftnlen)0);
return 0;
} /* MAIN__ */
/* $Procedure ZZDDHF2H ( Private --- DDH Filename to Handle ) */
/* Subroutine */ int zzddhf2h_(char *fname, integer *ftabs, integer *ftamh,
integer *ftarc, integer *ftbff, integer *fthan, char *ftnam, integer *
ftrtm, doublereal *ftmnm, integer *nft, integer *utcst, integer *
uthan, logical *utlck, integer *utlun, integer *nut, logical *exists,
logical *opened, integer *handle, logical *found, doublereal *mnm,
ftnlen fname_len, ftnlen ftnam_len)
{
/* System generated locals */
olist o__1;
cllist cl__1;
inlist ioin__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), f_inqu(inlist *), f_open(
olist *), f_clos(cllist *);
/* Local variables */
integer unit;
extern doublereal zzddhmnm_(integer *);
extern /* Subroutine */ int zzddhgtu_(integer *, integer *, logical *,
integer *, integer *, integer *), zzddhrmu_(integer *, integer *,
integer *, integer *, logical *, integer *, integer *);
integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer rchar;
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen);
extern integer rtrim_(char *, ftnlen);
extern logical failed_(void);
extern integer isrchi_(integer *, integer *, integer *);
logical locopn;
extern /* Subroutine */ int sigerr_(char *, ftnlen);
integer uindex;
logical locexs;
extern /* Subroutine */ int chkout_(char *, ftnlen), setmsg_(char *,
ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* SPICE Private routine intended solely for the support of SPICE */
/* routines. Users should not call this routine directly due */
/* to the volatile nature of this routine. */
/* Convert filename to a handle. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* PRIVATE */
/* $ Declarations */
/* $ Abstract */
/* Parameter declarations for the DAF/DAS handle manager. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* DAF, DAS */
/* $ Keywords */
/* PRIVATE */
/* $ Particulars */
/* This include file contains parameters defining limits and */
/* integer codes that are utilized in the DAF/DAS handle manager */
/* routines. */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 2.5.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 2.4.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 2.3.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 2.2.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 2.1.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 2.0.0, 12-APR-2012 (BVS) */
/* Increased FTSIZE (from 1000 to 5000). */
/* - SPICELIB Version 1.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 1.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 1.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 1.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 1.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 1.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 1.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 1.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 1.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 1.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 1.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 1.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 1.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 1.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 1.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 1.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 1.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 1.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 1.0.1, 17-JUL-2002 */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 1.0.0, 07-NOV-2001 */
/* -& */
/* Unit and file table size parameters. */
/* FTSIZE is the maximum number of files (DAS and DAF) that a */
/* user may have open simultaneously. */
/* RSVUNT is the number of units protected from being locked */
/* to a particular handle by ZZDDHHLU. */
/* SCRUNT is the number of units protected for use by scratch */
/* files. */
/* UTSIZE is the maximum number of logical units this manager */
/* will utilize at one time. */
/* Access method enumeration. These parameters are used to */
/* identify which access method is associated with a particular */
/* handle. They need to be synchronized with the STRAMH array */
/* defined in ZZDDHGSD in the following fashion: */
/* STRAMH ( READ ) = 'READ' */
/* STRAMH ( WRITE ) = 'WRITE' */
/* STRAMH ( SCRTCH ) = 'SCRATCH' */
/* STRAMH ( NEW ) = 'NEW' */
/* These values are used in the file table variable FTAMH. */
/* Binary file format enumeration. These parameters are used to */
/* identify which binary file format is associated with a */
/* particular handle. They need to be synchronized with the STRBFF */
/* array defined in ZZDDHGSD in the following fashion: */
/* STRBFF ( BIGI3E ) = 'BIG-IEEE' */
/* STRBFF ( LTLI3E ) = 'LTL-IEEE' */
/* STRBFF ( VAXGFL ) = 'VAX-GFLT' */
/* STRBFF ( VAXDFL ) = 'VAX-DFLT' */
/* These values are used in the file table variable FTBFF. */
/* Some random string lengths... more documentation required. */
/* For now this will have to suffice. */
/* Architecture enumeration. These parameters are used to identify */
/* which file architecture is associated with a particular handle. */
/* They need to be synchronized with the STRARC array defined in */
/* ZZDDHGSD in the following fashion: */
/* STRARC ( DAF ) = 'DAF' */
/* STRARC ( DAS ) = 'DAS' */
/* These values will be used in the file table variable FTARC. */
/* For the following environments, record length is measured in */
/* characters (bytes) with eight characters per double precision */
/* number. */
/* Environment: Sun, Sun FORTRAN */
/* Source: Sun Fortran Programmer's Guide */
/* Environment: PC, MS FORTRAN */
/* Source: Microsoft Fortran Optimizing Compiler User's Guide */
/* Environment: Macintosh, Language Systems FORTRAN */
/* Source: Language Systems FORTRAN Reference Manual, */
/* Version 1.2, page 12-7 */
/* Environment: PC/Linux, g77 */
/* Source: Determined by experiment. */
/* Environment: PC, Lahey F77 EM/32 Version 4.0 */
/* Source: Lahey F77 EM/32 Language Reference Manual, */
/* page 144 */
/* Environment: HP-UX 9000/750, FORTRAN/9000 Series 700 computers */
/* Source: FORTRAN/9000 Reference-Series 700 Computers, */
/* page 5-110 */
/* Environment: NeXT Mach OS (Black Hardware), */
/* Absoft Fortran Version 3.2 */
/* Source: NAIF Program */
/* The following parameter defines the size of a string used */
/* to store a filenames on this target platform. */
/* The following parameter controls the size of the character record */
/* buffer used to read data from non-native files. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* FNAME I Name of the file to convert to a handle. */
/* FTABS, */
/* FTAMH, */
/* FTARC, */
/* FTBFF, */
/* FTHAN, */
/* FTNAM, */
/* FTRTM, */
/* FTMNM I File table. */
/* NFT I Number of entries in the file table. */
/* UTCST, */
/* UTHAN, */
/* UTLCK, */
/* UTLUN I/O Unit table. */
/* NUT I/O Number of entries in the unit table. */
/* EXISTS O Logical indicating if FNAME exists. */
/* OPENED O Logical indicating if FNAME is opened. */
/* HANDLE O Handle associated with FNAME. */
/* FOUND O Logical indicating if FNAME's HANDLE was found. */
/* MNM O Unique DP (Magic NuMber) associated with FNAME. */
/* $ Detailed_Input */
/* FNAME is the name of the file to locate in the file table. */
/* FTABS, */
/* FTAMH, */
/* FTARC, */
/* FTBFF, */
/* FTHAN, */
/* FTNAM, */
/* FTRTM, */
/* FTMNM are the arrays respectively containing the absolute */
/* value of the handle, access method, architecture, */
/* binary file format, handle, name, RTRIM and */
/* magic number columns of the file table. */
/* NFT is the number of entries in the file table. */
/* UTCST, */
/* UTHAN, */
/* UTLCK, */
/* UTLUN are the arrays respectively containing the cost, */
/* handle, locked, and logical unit columns of the unit */
/* table. */
/* NUT is the number of entries in the unit table. */
/* $ Detailed_Output */
/* UTCST, */
/* UTHAN, */
/* UTLCK, */
/* UTLUN are the arrays respectively containing the cost, */
/* handle, locked, and logical unit columns of the unit */
/* table. If ZZDDHF2H requires a logical unit, then */
/* it will borrow one from the unit table. Depending */
/* on the state of the table passed in from the caller */
/* one of three possible scenarios may occur (Recall */
/* that 'zero-cost' rows are ones whose units are */
/* reserved with RESLUN and not currently connected */
/* to any file.) */
/* A 'zero-cost' row exists in the table, in */
/* which case the row is used temporarily and */
/* may be removed depending on the number of entries */
/* in the file table (NFT). */
/* The unit table is full (NUT=UTSIZE), in which */
/* case the unit with the lowest cost that is not */
/* locked to its handle will be disconnected, used, */
/* and then returned to the table as a 'zero-cost' */
/* row before returning to the caller. */
/* The unit table is not full (NUT<UTSIZE) and there */
/* are no 'zero-cost' rows. In this case NUT is */
/* temporarily increased by one, and the new row */
/* is used. After this routine no longer requires */
/* the unit, depending on the number of entries in */
/* the file table (NFT) the row may be left in the */
/* table as a 'zero-handle' row or removed entirely. */
/* In the event an error is signaled, the contents of the */
/* unit table are placed into a usable state before */
/* returning to the caller. */
/* NUT is the number of entries in the unit table. Since */
/* this routine borrows a unit from the unit table, which */
/* may involve allocation of a new unit, this value may */
/* change. */
/* EXISTS is a logical if set to TRUE, indicates that FNAME */
/* exists. If FALSE, FNAME does not exist. In the event */
/* an exception is signaled the value is undefined. */
/* OPENED is a logical if set to TRUE, indicates that FNAME */
/* is opened and attached to a logical unit. If FALSE, */
/* FNAME is not attached to a unit. In the event an */
/* exception is signaled the value is undefined. */
/* HANDLE is the handle in the file table associated with */
/* FNAME. If FOUND is FALSE, then HANDLE is returned as */
/* 0. */
/* FOUND is a logical if TRUE indicates that FNAME was found */
/* in the file table. If FALSE indicates that it was not */
/* located. */
/* MNM is a unique (enough) DP number -- the Magic NuMber -- */
/* associated with FNAME computed by this examining the */
/* file contents. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If any of the INQUIRE statments this routine performs fail, */
/* the error SPICE(INQUIREFAILED) is signaled. FOUND is set to */
/* FALSE and HANDLE to 0. */
/* 2) If the attempt to open FNAME fails, then SPICE(FILEOPENFAILED) */
/* is signaled. FOUND is set to FALSE, and HANDLE to 0. */
/* 3) If FNAME is determined not to be loaded into the file table */
/* then FOUND is set to FALSE and HANDLE is set to 0. */
/* $ Files */
/* If the file named by FNAME is not connected to a logical unit, */
/* this routine will open it for direct access to complete its */
/* examination. */
/* $ Particulars */
/* This routine encapsulates the logic necessary to determine if */
/* a particular filename names a file already loaded into the */
/* DAF/DAS handle manager. If it discovers the file is loaded, */
/* the routine returns the handle to the caller. */
/* $ Examples */
/* See ZZDDHFNH for sample usage. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* E.D. Wright (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 3.0.0, 26-APR-2012 (BVS) */
/* Changed calling sequence to include FTMNM and MNM. Change */
/* algorithm to compute MNM and use it to bypass n^2 INQUIREs */
/* for files opened for READ access, if possible. */
/* - SPICELIB Version 2.0.1, 24-APR-2003 (EDW) */
/* Added MAC-OSX-F77 to the list of platforms */
/* that require READONLY to read write protected */
/* kernels. */
/* - SPICELIB Version 2.0.0, 05-AUG-2002 (FST) */
/* Bug fix: this module was updated to allow proper loading */
/* of read-only files on VAX environments. */
/* - SPICELIB Version 1.0.0, 04-OCT-2001 (FST) */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 05-AUG-2002 (FST) */
/* An OPEN statement that is exercised by this module under */
/* certain circumstances, failed to pass the non-standard */
/* READONLY option for the VAX environments. This had the */
/* undesirable side-effect of not permitting files available */
/* only for READ access to be opened. */
/* This file was promoted from a standard portable module */
/* to a master file. */
/* -& */
/* SPICELIB Functions */
/* Local Variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZDDHF2H", (ftnlen)8);
}
/* First check to see if FNAME is blank. If so, set FOUND to .FALSE. */
/* and return. ZZDDHOPN prevents any blank filenames from being */
/* loaded into the file table. */
if (s_cmp(fname, " ", fname_len, (ftnlen)1) == 0) {
*found = FALSE_;
*handle = 0;
*opened = FALSE_;
*exists = FALSE_;
chkout_("ZZDDHF2H", (ftnlen)8);
return 0;
}
/* Start by trimming the file name in preparation for the INQUIRE. */
rchar = rtrim_(fname, fname_len);
/* Now INQUIRE on the input file FNAME. */
ioin__1.inerr = 1;
ioin__1.infilen = rchar;
ioin__1.infile = fname;
ioin__1.inex = &locexs;
ioin__1.inopen = &locopn;
ioin__1.innum = &unit;
ioin__1.innamed = 0;
ioin__1.inname = 0;
ioin__1.inacc = 0;
ioin__1.inseq = 0;
ioin__1.indir = 0;
ioin__1.infmt = 0;
ioin__1.inform = 0;
ioin__1.inunf = 0;
ioin__1.inrecl = 0;
ioin__1.innrec = 0;
ioin__1.inblank = 0;
iostat = f_inqu(&ioin__1);
/* Check IOSTAT for failure. */
if (iostat != 0) {
*found = FALSE_;
*handle = 0;
setmsg_("INQUIRE failed. Value of IOSTAT was #.", (ftnlen)38);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(INQUIREFAILED)", (ftnlen)20);
chkout_("ZZDDHF2H", (ftnlen)8);
return 0;
}
/* First, set some of the output arguments. Remember, some */
/* systems consider non-existant files as open. Compensate for */
/* this unusual behavior. */
*exists = locexs;
*opened = locopn && *exists;
/* Now check to see if the file exists. If it does not, then */
/* set FOUND to false and HANDLE to 0 as non-existant files */
/* can not possibly be present in the file table. */
if (! (*exists)) {
*found = FALSE_;
*handle = 0;
chkout_("ZZDDHF2H", (ftnlen)8);
return 0;
}
/* Now check to see if the file is opened. If it is, we need to */
/* determine whether or not the logical unit to which it is */
/* attached is present in the unit table. */
if (*opened) {
/* Since the file is opened, see if we can find its unit */
/* in the unit table. */
uindex = isrchi_(&unit, nut, utlun);
/* When UINDEX is 0, the file is opened, but not by */
/* the DAF/DAS handle manager. Set FOUND to FALSE, HANDLE */
/* to 0, and return to the caller. */
if (uindex == 0) {
*handle = 0;
*found = FALSE_;
chkout_("ZZDDHF2H", (ftnlen)8);
return 0;
}
/* If we end up here, then we found UNIT in the unit table. */
/* Set FOUND to TRUE if the handle associated with UNIT is */
/* non-zero. */
*handle = uthan[uindex - 1];
*found = *handle != 0;
chkout_("ZZDDHF2H", (ftnlen)8);
return 0;
}
/* At this point, we took action for all simple cases. Now */
/* we need to find out if FNAME is one of the files in the */
/* file table that isn't open. To determine this, we open FNAME, */
/* and then INQUIRE on every file in the table. To do this, we */
/* need a unit. Get one. */
zzddhgtu_(utcst, uthan, utlck, utlun, nut, &uindex);
if (failed_()) {
*handle = 0;
*found = FALSE_;
chkout_("ZZDDHF2H", (ftnlen)8);
return 0;
}
/* Now open the file (which we know exists and isn't open). Since */
/* we effectively are just borrowing this unit, we are not going to */
/* set UTHAN or UTCST from the defaults that ZZDDHGTU sets up. */
o__1.oerr = 1;
o__1.ounit = utlun[uindex - 1];
o__1.ofnmlen = rchar;
o__1.ofnm = fname;
o__1.orl = 1024;
o__1.osta = "OLD";
o__1.oacc = "DIRECT";
o__1.ofm = 0;
o__1.oblnk = 0;
iostat = f_open(&o__1);
/* Check IOSTAT. */
if (iostat != 0) {
/* Since an error has occurred, set FOUND to false and HANDLE */
/* to 0. */
*found = FALSE_;
*handle = 0;
/* Close the unit and remove it from the unit table. */
cl__1.cerr = 0;
cl__1.cunit = utlun[uindex - 1];
cl__1.csta = 0;
f_clos(&cl__1);
zzddhrmu_(&uindex, nft, utcst, uthan, utlck, utlun, nut);
/* Signal the error and return. */
setmsg_("Attempt to open file '#' failed. Value of IOSTAT was #.", (
ftnlen)55);
errch_("#", fname, (ftnlen)1, fname_len);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEOPENFAILED)", (ftnlen)21);
chkout_("ZZDDHF2H", (ftnlen)8);
return 0;
}
/* Get a unique enough DP number -- the Magic NuMber (MNM) ;) -- for */
/* this file. */
*mnm = zzddhmnm_(&utlun[uindex - 1]);
/* Now loop through all the files in the file table. Unfortunately */
/* we have no other choice. */
i__ = 1;
*found = FALSE_;
while(i__ <= *nft && ! (*found)) {
/* If this file's magic number is non-zero and is different from */
/* the magic number of the currently checked, opened-for-READ */
/* file, we will declare that these files are not the same file */
/* and will skip INQUIRE. In all other cases we will do INQUIRE */
/* and check UNITs. */
if (*mnm != 0. && (*mnm != ftmnm[i__ - 1] && ftamh[i__ - 1] == 1)) {
/* These files are not the same file. Clear IOSTAT and set */
/* UNIT to not match the UNIT of the input file. */
iostat = 0;
unit = utlun[uindex - 1] + 1;
} else {
/* Do the INQUIRE. ;( */
ioin__1.inerr = 1;
ioin__1.infilen = ftrtm[i__ - 1];
ioin__1.infile = ftnam + (i__ - 1) * ftnam_len;
ioin__1.inex = &locexs;
ioin__1.inopen = &locopn;
ioin__1.innum = &unit;
ioin__1.innamed = 0;
ioin__1.inname = 0;
ioin__1.inacc = 0;
ioin__1.inseq = 0;
ioin__1.indir = 0;
ioin__1.infmt = 0;
ioin__1.inform = 0;
ioin__1.inunf = 0;
ioin__1.inrecl = 0;
ioin__1.innrec = 0;
ioin__1.inblank = 0;
iostat = f_inqu(&ioin__1);
}
/* Check IOSTAT. */
if (iostat != 0) {
/* Since we have an error condition, set FOUND to FALSE */
/* and HANDLE to 0. */
*found = FALSE_;
*handle = 0;
/* Close the unit and clean up the unit table. */
cl__1.cerr = 0;
cl__1.cunit = utlun[uindex - 1];
cl__1.csta = 0;
f_clos(&cl__1);
zzddhrmu_(&uindex, nft, utcst, uthan, utlck, utlun, nut);
/* Signal the error and return. */
setmsg_("INQUIRE failed. Value of IOSTAT was #.", (ftnlen)38);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(INQUIREFAILED)", (ftnlen)20);
chkout_("ZZDDHF2H", (ftnlen)8);
return 0;
}
/* Now check to see if FILE exists, is currently open. and */
/* its UNIT matches UTLUN(UINDEX). */
if (locexs && locopn && unit == utlun[uindex - 1]) {
*handle = fthan[i__ - 1];
*found = TRUE_;
/* Otherwise, continue searching. */
} else {
++i__;
}
}
/* Check to see if we found the file in the file table. */
if (! (*found)) {
*handle = 0;
}
/* Close the unit and clean up the unit table. */
cl__1.cerr = 0;
cl__1.cunit = utlun[uindex - 1];
cl__1.csta = 0;
f_clos(&cl__1);
zzddhrmu_(&uindex, nft, utcst, uthan, utlck, utlun, nut);
chkout_("ZZDDHF2H", (ftnlen)8);
return 0;
} /* zzddhf2h_ */
/* Subroutine */ int flgrpt_(integer *nitems, char *names, char *values, U_fp
myio, ftnlen names_len, ftnlen values_len)
{
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), i_len(char *, ftnlen),
s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char hard[1];
logical free[129];
integer i__, j, k, l;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer width;
extern integer rtrim_(char *, ftnlen);
char style[200];
extern /* Subroutine */ int chkout_(char *, ftnlen);
char letter[1];
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen), nspmrg_(char *, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int nicepr_1__(char *, char *, U_fp, ftnlen,
ftnlen);
/* This routine takes an array of names and an array of associated */
/* value strings and produces a flagged set of outputs. This */
/* routine signals no errors. */
/* The routine MYIO is a routine that is supplied by the user */
/* that can handle io of text lines without any action by the */
/* routine that calls it. */
/* $ Version */
/* Inspekt Routine version 2.0.0, 7-APR-1995 (WLT) */
/* Unused variables LEFT and RIGHT were removed. */
/* Spicelib functions */
if (return_()) {
return 0;
}
chkin_("FLGRPT", (ftnlen)6);
/* First find the widest of the names: */
width = 0;
i__1 = *nitems;
for (i__ = 1; i__ <= i__1; ++i__) {
if (rtrim_(names + (i__ - 1) * names_len, names_len) > width) {
width = rtrim_(names + (i__ - 1) * names_len, names_len);
}
}
/* Now for each of the NAME/VALUE pairs construct a style */
/* string using NAMES and run the VALUES through NICEPR_1. */
i__1 = *nitems;
for (i__ = 1; i__ <= i__1; ++i__) {
/* First we need to find a character that is not used */
/* in the NAMES(I)/VALUES(I) pair. We will use this as */
/* a hardspace in our style string. */
for (j = 33; j <= 127; ++j) {
free[(i__2 = j) < 129 && 0 <= i__2 ? i__2 : s_rnge("free", i__2,
"flgrpt_", (ftnlen)102)] = TRUE_;
}
i__2 = width;
for (j = 1; j <= i__2; ++j) {
free[(i__3 = *(unsigned char *)&names[(i__ - 1) * names_len + (j
- 1)]) < 129 && 0 <= i__3 ? i__3 : s_rnge("free", i__3,
"flgrpt_", (ftnlen)106)] = FALSE_;
}
i__2 = i_len(values, values_len);
for (j = 1; j <= i__2; ++j) {
free[(i__3 = *(unsigned char *)&values[(i__ - 1) * values_len + (
j - 1)]) < 129 && 0 <= i__3 ? i__3 : s_rnge("free", i__3,
"flgrpt_", (ftnlen)110)] = FALSE_;
}
j = 33;
while(! free[(i__2 = j) < 129 && 0 <= i__2 ? i__2 : s_rnge("free",
i__2, "flgrpt_", (ftnlen)114)] && j < 127) {
++j;
}
*(unsigned char *)hard = (char) j;
/* Set up the style we are going to use for this */
/* value */
nspmrg_(style, (ftnlen)200);
suffix_("HARDSPACE", &c__1, style, (ftnlen)9, (ftnlen)200);
suffix_(hard, &c__1, style, (ftnlen)1, (ftnlen)200);
suffix_("FLAG", &c__1, style, (ftnlen)4, (ftnlen)200);
l = rtrim_(style, (ftnlen)200) + 2;
i__2 = width;
for (k = 1; k <= i__2; ++k) {
*(unsigned char *)letter = *(unsigned char *)&names[(i__ - 1) *
names_len + (k - 1)];
if (*(unsigned char *)letter == ' ') {
*(unsigned char *)&style[l - 1] = *(unsigned char *)hard;
} else {
*(unsigned char *)&style[l - 1] = *(unsigned char *)letter;
}
++l;
}
*(unsigned char *)&style[l - 1] = ':';
++l;
*(unsigned char *)&style[l - 1] = *(unsigned char *)hard;
/* Ok. Now just ship the stuff to the output routines. */
if (s_cmp(names + (i__ - 1) * names_len, " ", names_len, (ftnlen)1) ==
0 && s_cmp(values + (i__ - 1) * values_len, " ", values_len,
(ftnlen)1) == 0) {
i__2 = l - 2;
s_copy(style + i__2, hard, l - 1 - i__2, (ftnlen)1);
nicepr_1__(hard, style, (U_fp)myio, (ftnlen)1, l);
} else if (s_cmp(values + (i__ - 1) * values_len, " ", values_len, (
ftnlen)1) == 0) {
i__2 = l - 2;
s_copy(style + i__2, hard, l - 1 - i__2, (ftnlen)1);
nicepr_1__(hard, style, (U_fp)myio, (ftnlen)1, l);
} else {
nicepr_1__(values + (i__ - 1) * values_len, style, (U_fp)myio,
values_len, l);
}
}
chkout_("FLGRPT", (ftnlen)6);
return 0;
} /* flgrpt_ */
/* Subroutine */ int rptsym_0_(int n__, integer *id, integer *comp, char *
string, integer *wdth, char *name__, char *def, char *value, ftnlen
string_len, ftnlen name_len, ftnlen def_len, ftnlen value_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern integer rtrim_(char *, ftnlen);
static char symdef[1000], symnam[32], symval[1000];
/* This routine is a utility for setting and retrieving symbol */
/* names, definitions and expanded values. It is intended that */
/* this be used by a higher level routine that fetches symbol */
/* definitions one at a time, puts the definition here and */
/* passes the routine RETSYM to a formatting routine. */
/* The ENTRY point SETSYM allows you to set the symbol and its */
/* values. */
/* The ENTRY point RETSYM returns the last set values. To */
/* request a portion of a symbol you supply the following */
/* values for ID and COMP */
/* 1,1 for the symbol name */
/* 2,1 for the symbol definition */
/* 2,2 or 3,1 for the symbol expanded value. */
/* If used with the routine TABRPT you can then easily display */
/* symbols as: */
/* name definition fully_expanded_value */
/* or */
/* name definition */
/* fully_expanded_value. */
switch(n__) {
case 1: goto L_setsym;
case 2: goto L_retsym;
}
return 0;
L_setsym:
s_copy(symnam, name__, (ftnlen)32, name_len);
s_copy(symdef, def, (ftnlen)1000, def_len);
s_copy(symval, value, (ftnlen)1000, value_len);
return 0;
L_retsym:
if (*id == 1) {
if (*comp != 1) {
s_copy(string, " ", string_len, (ftnlen)1);
} else {
s_copy(string, symnam, string_len, (ftnlen)32);
}
} else if (*id == 2) {
if (*comp == 1) {
s_copy(string, symdef, string_len, (ftnlen)1000);
} else if (*comp == 2) {
s_copy(string, symval, string_len, (ftnlen)1000);
} else {
s_copy(string, " ", string_len, (ftnlen)1);
}
} else if (*id == 3) {
if (*comp == 1) {
s_copy(string, symval, string_len, (ftnlen)1000);
} else {
s_copy(string, " ", string_len, (ftnlen)1);
}
}
*wdth = rtrim_(string, string_len);
return 0;
} /* rptsym_ */
/* $Procedure ZZASCII ( determine/verify EOL terminators in a text file ) */
/* Subroutine */ int zzascii_(char *file, char *line, logical *check, char *
termin, ftnlen file_len, ftnlen line_len, ftnlen termin_len)
{
/* System generated locals */
olist o__1;
cllist cl__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen), f_open(olist *), f_clos(cllist *), s_rdue(
cilist *), do_uio(integer *, char *, ftnlen), e_rdue(void);
/* Local variables */
extern /* Subroutine */ int zzplatfm_(char *, char *, ftnlen, ftnlen);
integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
extern integer rtrim_(char *, ftnlen);
extern logical eqstr_(char *, char *, ftnlen, ftnlen);
integer maccnt, reclen;
char native[5];
integer number, doscnt;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), getlun_(integer *), setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
extern logical return_(void);
integer unxcnt;
/* Fortran I/O blocks */
static cilist io___5 = { 1, 0, 1, 0, 1 };
/* $ Abstract */
/* Returns a string indicating the line terminators of an ASCII file */
/* and, if requested, stops execution if the terminator does match */
/* the one that is native to the platform on which the toolkit was */
/* compiled. */
/* $ 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 */
/* FILE TYPE */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* FILE I Name of the text file to scan. */
/* LINE I The work string for file reads. */
/* CHECK I Flag directing to check for mismatched EOL. */
/* TERMIN 0 The deduced terminator ID. */
/* $ Detailed_Input */
/* FILE the name of the ASCII file to scan for a line */
/* terminator */
/* LINE a character string of sufficient length to perform the */
/* line reads from FILE. */
/* CHECK a logical flag that, if set to .TRUE., instructs this */
/* routine to check terminator that has been determined */
/* against the one that is native to the platform, on */
/* which the toolkit was compiled, and to generate error */
/* if it was not the case. If set to .FALSE., instructs */
/* the routine to bypass the check. */
/* $ Detailed_Output */
/* TERMIN the terminator ID extracted from FILE. The possible */
/* values: */
/* 'CR' - carriage return (Mac classic) */
/* 'LF' - line feed (Unix) */
/* 'CR-LF' - carriage return and line feed (DOS) */
/* '?' - unable to determine, possibly */
/* due to an error event */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) A SPICE(STRINGTOOSHORT) error signals if LINE has length less */
/* than 3. */
/* 2) A SPICE(FILEOPENFAILED) error signals if the file of interest */
/* fails to open, i.e. IOSTAT < 0. */
/* 3) A text kernel found to contain non-native line terminators */
/* and abort of the run was requested by causes this routine to */
/* signal the error SPICE(INCOMPATIBLEEOL). */
/* $ Files */
/* None. */
/* $ Particulars */
/* The function scans a string read from a text file to determine */
/* the native platform of the file. The functions response is */
/* unpredictable if it scans a binary file. */
/* $ Examples */
/* To return EOL terminator for a given file: */
/* CHARACTER*(5) TERMIN */
/* CHARACTER*(64) LINE */
/* ... given a file name */
/* ... and a line long enough to hold a text string */
/* from FILE */
/* CALL ZZASCII( FILE, LINE, .FALSE., TERMIN ) */
/* CALL TOSTDO( 'FOUND FILE TERMINATOR '//TERMIN ) */
/* To stop if EOL terminator for a given file, if detected */
/* successfully, is not native to this platform: */
/* CHARACTER*(5) TERMIN */
/* CHARACTER*(64) LINE */
/* ... given a file name */
/* ... and a line long enough to hold a text string */
/* from FILE */
/* CALL ZZASCII( FILE, LINE, .TRUE., TERMIN ) */
/* If the EOL terminator was not native, the call will generate */
/* SPICE(INCOMPATIBLEEOL) error. */
/* $ Restrictions */
/* 1) The terminator detection is not performed if the read from */
/* the file fails because the file is smaller than the allocated */
/* LINE size or for any other reason. */
/* 2) The terminator detection is not possible if the length of the */
/* first text line in the file exceeds the length of the LINE */
/* work space. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* E.D. Wright (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 1.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 1.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 1.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 1.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 1.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 1.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 1.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 1.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 1.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 1.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 1.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 1.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 1.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 1.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 1.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 1.3.1, 26-OCT-2006 (EDW) */
/* Expanded error message explanation the */
/* routine outputs when the file-of-interest */
/* includes non-native text line terminators. */
/* - SPICELIB Version 1.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 1.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 1.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 1.0.0, 17-FEB-2004 (EDW) (BVS) */
/* -& */
/* $ Index_Entries */
/* determine ascii text file end-of-line type */
/* -& */
/* SPICELIB functions. */
/* Local parameters. */
/* Local variables. */
/* Discovery check-in. Can't determine the terminator in RETURN */
/* mode. */
if (return_()) {
s_copy(termin, "?", termin_len, (ftnlen)1);
return 0;
}
/* Check-in to the error system. */
chkin_("ZZASCII", (ftnlen)7);
/* Retrieve the native line terminator. */
zzplatfm_("TEXT_FORMAT", native, (ftnlen)11, (ftnlen)5);
/* If it is VAX, return immediately with undefined terminator. */
if (eqstr_(native, "VAX", (ftnlen)5, (ftnlen)3)) {
s_copy(termin, "?", termin_len, (ftnlen)1);
chkout_("ZZASCII", (ftnlen)7);
return 0;
}
/* Set the record lenght that will be used to read data from */
/* the file. */
reclen = i_len(line, line_len);
/* Check the length of the work string is sufficient to perform the */
/* operations. Less than 3 is a no-op. */
if (i_len(line, line_len) < 3) {
s_copy(termin, "?", termin_len, (ftnlen)1);
setmsg_("Work string lacks sufficient length to perform operation.", (
ftnlen)57);
sigerr_("SPICE(STRINGTOOSHORT)", (ftnlen)21);
chkout_("ZZASCII", (ftnlen)7);
return 0;
}
/* Find a free logical unit for file access. */
getlun_(&number);
/* Open the file for DIRECT access. */
o__1.oerr = 1;
o__1.ounit = number;
o__1.ofnmlen = rtrim_(file, file_len);
o__1.ofnm = file;
o__1.orl = reclen;
o__1.osta = "OLD";
o__1.oacc = "DIRECT";
o__1.ofm = 0;
o__1.oblnk = 0;
iostat = f_open(&o__1);
if (iostat != 0) {
/* The open failed, can't determine the terminator if the routine */
/* can't open the file. */
s_copy(termin, "?", termin_len, (ftnlen)1);
/* Execute a close, J.I.C. */
cl__1.cerr = 0;
cl__1.cunit = number;
cl__1.csta = 0;
f_clos(&cl__1);
setmsg_("File open failed for file '$1'. IOSTAT value $2.", (ftnlen)
49);
errch_("$1", file, (ftnlen)2, file_len);
errint_("$2", &iostat, (ftnlen)2);
sigerr_("SPICE(FILEOPENFAIL)", (ftnlen)19);
chkout_("ZZASCII", (ftnlen)7);
return 0;
}
/* Read a line into the LINE variable assigned by the user. */
s_copy(line, " ", line_len, (ftnlen)1);
io___5.ciunit = number;
iostat = s_rdue(&io___5);
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, line, line_len);
if (iostat != 0) {
goto L100001;
}
iostat = e_rdue();
L100001:
if (iostat != 0) {
/* If something went wrong during this read, a part or the whole */
/* returned line may contain garbage. Instead of examining it and */
/* making wrong determination based on it, set terminator to */
/* undefined and return. */
s_copy(termin, "?", termin_len, (ftnlen)1);
/* Execute a close, J.I.C. */
cl__1.cerr = 0;
cl__1.cunit = number;
cl__1.csta = 0;
f_clos(&cl__1);
chkout_("ZZASCII", (ftnlen)7);
return 0;
}
/* We have a line of text data. Use ICHAR to scan for carriage */
/* returns and line feeds and count how may of various recognized */
/* line termination sequences are in this line. */
doscnt = 0;
unxcnt = 0;
maccnt = 0;
i__ = 1;
while(i__ < i_len(line, line_len)) {
/* Check for ICHAR values of 10 (LF) and 13 (CR). */
if (*(unsigned char *)&line[i__ - 1] == 10) {
/* Found a UNIX line terminator LF. */
++unxcnt;
} else if (*(unsigned char *)&line[i__ - 1] == 13) {
/* Found CR, increment character counter and check */
/* the next character. */
++i__;
if (*(unsigned char *)&line[i__ - 1] == 10) {
/* Found a DOS line terminator CR+LF. */
++doscnt;
} else {
/* Found a Classic Mac line terminator CR. */
++maccnt;
}
}
++i__;
}
/* Examine the counters. */
if (doscnt > 0 && unxcnt == 0 && maccnt == 0) {
/* Only DOS terminator counter is non-zero. ID the file as DOS. */
s_copy(termin, "CR-LF", termin_len, (ftnlen)5);
} else if (doscnt == 0 && unxcnt > 0 && maccnt == 0) {
/* Only Unix terminator counter is non-zero. ID the file as UNIX. */
s_copy(termin, "LF", termin_len, (ftnlen)2);
} else if (doscnt == 0 && unxcnt == 0 && maccnt > 0) {
/* Only Mac terminator counter is non-zero. ID the file as Mac */
/* Classic. */
s_copy(termin, "CR", termin_len, (ftnlen)2);
} else {
/* We can get here in two cases. First if the line did not */
/* contain any CRs or LFs. Second if the line contained more than */
/* one kind of terminators. In either case the format of the file */
/* is unclear. */
s_copy(termin, "?", termin_len, (ftnlen)1);
}
/* Close the file. */
cl__1.cerr = 0;
cl__1.cunit = number;
cl__1.csta = 0;
f_clos(&cl__1);
/* If we were told check the terminator against the native one, do */
/* it. */
if (*check) {
/* If the terminator was identified and does not match the native */
/* one, error out. */
if (! eqstr_(termin, native, termin_len, (ftnlen)5) && ! eqstr_(
termin, "?", termin_len, (ftnlen)1)) {
setmsg_("Text file '$1' contains lines terminated with '$2' whil"
"e the expected terminator for this platform is '$3'. SPI"
"CE cannot process the file in the current form. This pro"
"blem likely occurred because the file was copied in bina"
"ry mode between operating systems where the operating sy"
"stems use different text line terminators. Try convertin"
"g the file to native text form using a utility such as d"
"os2unix or unix2dos.", (ftnlen)411);
errch_("$1", file, (ftnlen)2, file_len);
errch_("$2", termin, (ftnlen)2, termin_len);
errch_("$3", native, (ftnlen)2, (ftnlen)5);
sigerr_("SPICE(INCOMPATIBLEEOL)", (ftnlen)22);
chkout_("ZZASCII", (ftnlen)7);
return 0;
}
}
chkout_("ZZASCII", (ftnlen)7);
return 0;
} /* zzascii_ */
/* $Procedure PARCML ( Parse command line ) */
/* Subroutine */ int parcml_(char *line, integer *nkeys, char *clkeys,
logical *clflag, char *clvals, logical *found, char *unprsd, ftnlen
line_len, ftnlen clkeys_len, ftnlen clvals_len, ftnlen unprsd_len)
{
/* System generated locals */
address a__1[2];
integer i__1, i__2[2];
char ch__1[2049];
/* 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 */
static char hkey[2048];
static integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen);
static char hline[2048];
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
static integer clidx;
static char lngwd[2048], uline[2048];
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
static integer begpos;
static char hlngwd[2048];
static integer pclidx, endpos;
extern /* Subroutine */ int chkout_(char *, ftnlen), nextwd_(char *, char
*, char *, ftnlen, ftnlen, ftnlen);
extern logical return_(void);
extern integer pos_(char *, char *, integer *, ftnlen, ftnlen);
/* $ Abstract */
/* Parse a command-line like string in the "key value key value ..." */
/* format with keys provided in any order and any letter case */
/* (lower, upper, mixed) and return values of requested keys. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* PARSING */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* LINE I/O Input command-line like string. */
/* NKEYS I Number of keys to look for. */
/* CLKEYS I Keys to look for. */
/* CLFLAG O "A particular key found" flags. */
/* CLVALS O Key values. */
/* FOUND O "At least one key found" flag. */
/* UNPRSD O Beginning part of the LINE that was not parsed */
/* LLNSIZ P Size of longest sub-string that can be processed. */
/* $ Detailed_Input */
/* LINE is the input command-line like string in the "key */
/* value key value ..." format. The line should start */
/* with one of the keys provided in CLKEYS as the */
/* routine ignores any words before the first recognized */
/* key. */
/* To avoid limiting the size of the input string that */
/* can be processed, this routine uses LINE as the work */
/* buffer; it modifies LINE in the process of execution, */
/* and sets it to blank before return. */
/* NKEYS is the number of keys to look for provided in the */
/* CLKEYS array. */
/* CLKEYS is an array of keys to look for. Individual keys */
/* must be left-justified string consisting of any */
/* printable the characters except lower-case letters */
/* and blanks. */
/* $ Detailed_Output */
/* LINE is set to blank on the output. */
/* CLFLAG are the "key found" flags; set to TRUE if */
/* corresponding key was found. */
/* CLVALS are the key values; if a key wasn't found, its value */
/* set to a blank string. */
/* FOUND is set to .TRUE. if at least one key was found. */
/* Otherwise it is set to .FALSE. */
/* UNPRSD is the beginning part of the LINE, preceeding the */
/* first recognized key, that was ignored by this */
/* routine. */
/* $ Parameters */
/* LLNSIZ is the size of the internal buffer that holds a */
/* portion of the input string that is being examined. */
/* It limits the maximum total length of a front and */
/* back blank-padded, blank-separated sub-string */
/* containing a key, the value that follows it, and the */
/* next key (e.g. ' key value key ') that this routine */
/* can correctly process. */
/* $ Exceptions */
/* None. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine modifies the input string. It returns it set to */
/* blank. */
/* The case of the keys in the input string is not significant. */
/* The order of keys in the input string is not significant. */
/* If any key appears in the string more than once, only the */
/* last value of that key is returned. */
/* The part of the line from the start up to the first recognized */
/* key is returned in the UNPRSD argument. */
/* $ Examples */
/* If CLKEYS are */
/* CLKEYS(1) = '-SETUP' */
/* CLKEYS(2) = '-TO' */
/* CLKEYS(3) = '-FROM' */
/* CLKEYS(4) = '-HELP' */
/* then: */
/* line '-setup my.file -FROM utc -TO sclk' */
/* will be parsed as */
/* CLFLAG(1) = .TRUE. CLVALS(1) = 'my.file' */
/* CLFLAG(2) = .TRUE. CLVALS(2) = 'utc' */
/* CLFLAG(3) = .TRUE. CLVALS(3) = 'sclk' */
/* CLFLAG(4) = .FALSE. CLVALS(4) = ' ' */
/* UNPRSD = ' ' */
/* FOUND = .TRUE. */
/* line '-bogus -setup my.file -FROM utc -TO sclk' */
/* will be parsed as */
/* CLFLAG(1) = .TRUE. CLVALS(1) = 'my.file' */
/* CLFLAG(2) = .TRUE. CLVALS(2) = 'utc' */
/* CLFLAG(3) = .TRUE. CLVALS(3) = 'sclk' */
/* CLFLAG(4) = .FALSE. CLVALS(4) = ' ' */
/* UNPRSD = '-bogus' */
/* FOUND = .TRUE. */
/* line 'why not -setup my.file -FROM utc -TO sclk' */
/* will be parsed as */
/* CLFLAG(1) = .TRUE. CLVALS(1) = 'my.file' */
/* CLFLAG(2) = .TRUE. CLVALS(2) = 'utc' */
/* CLFLAG(3) = .TRUE. CLVALS(3) = 'sclk' */
/* CLFLAG(4) = .FALSE. CLVALS(4) = ' ' */
/* UNPRSD = 'why not' */
/* FOUND = .TRUE. */
/* line '-SETUP my.file -setup your.file' */
/* will be parsed as */
/* CLFLAG(1) = .TRUE. CLVALS(1) = 'your.file' */
/* CLFLAG(2) = .FALSE. CLVALS(2) = ' ' */
/* CLFLAG(3) = .FALSE. CLVALS(3) = ' ' */
/* CLFLAG(4) = .FALSE. CLVALS(4) = ' ' */
/* UNPRSD = ' ' */
/* FOUND = .TRUE. */
/* line '-setup my.file -SeTuP your.file' */
/* will be parsed as */
/* CLFLAG(1) = .TRUE. CLVALS(1) = 'your.file' */
/* CLFLAG(2) = .FALSE. CLVALS(2) = ' ' */
/* CLFLAG(3) = .FALSE. CLVALS(3) = ' ' */
/* CLFLAG(4) = .FALSE. CLVALS(4) = ' ' */
/* UNPRSD = ' ' */
/* FOUND = .TRUE. */
/* line '-help' */
/* will be parsed as */
/* CLFLAG(1) = .FALSE. CLVALS(1) = ' ' */
/* CLFLAG(2) = .FALSE. CLVALS(2) = ' ' */
/* CLFLAG(3) = .FALSE. CLVALS(3) = ' ' */
/* CLFLAG(4) = .TRUE. CLVALS(4) = ' ' */
/* UNPRSD = ' ' */
/* FOUND = .TRUE. */
/* and so on. */
/* $ Restrictions */
/* This routine cannot process input lines with any ' -key value */
/* -key ' sub-string that is longer than LLNSIZ. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SUPPORT Version 1.0.0, 15-FEB-2012 (BVS) */
/* -& */
/* Local variables. */
/* Save everything to prevent potential memory problems in f2c'ed */
/* version. */
/* SPICELIB functions. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("PARCML", (ftnlen)6);
}
/* Set initial values of keys to blanks and flags to .FALSE. */
i__1 = *nkeys;
for (i__ = 1; i__ <= i__1; ++i__) {
clflag[i__ - 1] = FALSE_;
s_copy(clvals + (i__ - 1) * clvals_len, " ", clvals_len, (ftnlen)1);
}
*found = FALSE_;
/* Parsing loop. We will set the sub-string buffer HLINE to as many */
/* characters from the input line as it will fit, starting with the */
/* initial part of the line on the first iteration and resetting to */
/* sub-strings starting at the first character of each value after */
/* the previous key-value pair was processed, and will pick at HLINE */
/* word by word looking for recognized keys. The loop will */
/* continue until we reach the end of the string -- all key-value */
/* pairs were processed and the sub-string buffer HLINE was set to */
/* blank. */
s_copy(hline, line, (ftnlen)2048, line_len);
pclidx = 0;
clidx = 0;
s_copy(unprsd, line, unprsd_len, line_len);
while(s_cmp(hline, " ", (ftnlen)2048, (ftnlen)1) != 0) {
/* Get next word; uppercase it; look for it in the input keys */
/* array. */
nextwd_(hline, lngwd, hline, (ftnlen)2048, (ftnlen)2048, (ftnlen)2048)
;
ucase_(lngwd, hlngwd, (ftnlen)2048, (ftnlen)2048);
clidx = isrchc_(hlngwd, nkeys, clkeys, (ftnlen)2048, clkeys_len);
/* Is the token that we found a recognized key? */
if (clidx != 0) {
/* Yes, it is. Is it the first key that we have found? */
if (pclidx != 0) {
/* No it is not. We need to save the value of the previous */
/* key. */
/* Compute the begin and end positions of the sub-string */
/* that contains the previous value by looking for the */
/* previous and current keys in the upper-cased remainder of */
/* the input line. */
/* The begin position is the position of the previous key */
/* plus its length. The end position is the position of the */
/* front-n-back blank-padded current key. */
ucase_(line, uline, line_len, (ftnlen)2048);
begpos = pos_(uline, clkeys + (pclidx - 1) * clkeys_len, &
c__1, (ftnlen)2048, rtrim_(clkeys + (pclidx - 1) *
clkeys_len, clkeys_len)) + rtrim_(clkeys + (pclidx -
1) * clkeys_len, clkeys_len);
/* Writing concatenation */
i__2[0] = 1, a__1[0] = " ";
i__2[1] = rtrim_(clkeys + (clidx - 1) * clkeys_len,
clkeys_len), a__1[1] = clkeys + (clidx - 1) *
clkeys_len;
s_cat(hkey, a__1, i__2, &c__2, (ftnlen)2048);
/* Writing concatenation */
i__2[0] = 2048, a__1[0] = uline;
i__2[1] = 1, a__1[1] = " ";
s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2049);
endpos = pos_(ch__1, hkey, &begpos, (ftnlen)2049, rtrim_(hkey,
(ftnlen)2048) + 1);
/* Extract the value, left-justify it, and RTRIM it. Set */
/* "value found" flag to .TRUE. */
s_copy(clvals + (pclidx - 1) * clvals_len, line + (begpos - 1)
, clvals_len, endpos - (begpos - 1));
ljust_(clvals + (pclidx - 1) * clvals_len, clvals + (pclidx -
1) * clvals_len, clvals_len, clvals_len);
s_copy(clvals + (pclidx - 1) * clvals_len, clvals + (pclidx -
1) * clvals_len, clvals_len, rtrim_(clvals + (pclidx
- 1) * clvals_len, clvals_len));
clflag[pclidx - 1] = TRUE_;
/* Check whether we already parsed the whole line. It will */
/* be so if the remainder of the buffer holding the */
/* sub-string that we examine word-by-word is a blank */
/* string. */
if (s_cmp(hline, " ", (ftnlen)2048, (ftnlen)1) != 0) {
/* No, we did not parse the whole line yet. There is */
/* more stuff to parse and we reset the temporary */
/* sub-string buffer to hold the part of the input string */
/* starting with the first character after the current */
/* key -- the end position plus the length of the */
/* current key. */
i__1 = endpos + 1 + rtrim_(clkeys + (clidx - 1) *
clkeys_len, clkeys_len) - 1;
s_copy(hline, line + i__1, (ftnlen)2048, line_len - i__1);
}
/* Now reset the line to its portion starting with the */
/* first character of the current key. */
i__1 = endpos;
s_copy(line, line + i__1, line_len, line_len - i__1);
} else {
/* This is the first key that we have found. Set UNPRSD */
/* to the part of the line from the start to this key. */
ucase_(line, uline, line_len, (ftnlen)2048);
/* Writing concatenation */
i__2[0] = 1, a__1[0] = " ";
i__2[1] = rtrim_(clkeys + (clidx - 1) * clkeys_len,
clkeys_len), a__1[1] = clkeys + (clidx - 1) *
clkeys_len;
s_cat(hkey, a__1, i__2, &c__2, (ftnlen)2048);
/* Writing concatenation */
i__2[0] = 1, a__1[0] = " ";
i__2[1] = 2048, a__1[1] = uline;
s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2049);
begpos = pos_(ch__1, hkey, &c__1, (ftnlen)2049, rtrim_(hkey, (
ftnlen)2048) + 1);
if (begpos <= 1) {
s_copy(unprsd, " ", unprsd_len, (ftnlen)1);
} else {
s_copy(unprsd, line, unprsd_len, begpos - 1);
}
}
/* Save the current key index in as previous. */
pclidx = clidx;
}
}
/* If we found at least one recognized key, we need to save the last */
/* value. */
if (pclidx != 0) {
/* Set "found any" output flag and "found previous key" flags to */
/* .TRUE. */
*found = TRUE_;
clflag[pclidx - 1] = TRUE_;
/* Check if there was any value following the last key (there was */
/* if the non-blank length of what's left in the line starting */
/* with the last key if greater than the non-blank length of the */
/* last key). */
if (rtrim_(line, line_len) > rtrim_(clkeys + (pclidx - 1) *
clkeys_len, clkeys_len)) {
/* Compute begin position of, extract, left justify and */
/* RTRIM the last value. */
ucase_(line, uline, line_len, (ftnlen)2048);
begpos = pos_(uline, clkeys + (pclidx - 1) * clkeys_len, &c__1, (
ftnlen)2048, rtrim_(clkeys + (pclidx - 1) * clkeys_len,
clkeys_len)) + rtrim_(clkeys + (pclidx - 1) * clkeys_len,
clkeys_len);
s_copy(clvals + (pclidx - 1) * clvals_len, line + (begpos - 1),
clvals_len, line_len - (begpos - 1));
ljust_(clvals + (pclidx - 1) * clvals_len, clvals + (pclidx - 1) *
clvals_len, clvals_len, clvals_len);
s_copy(clvals + (pclidx - 1) * clvals_len, clvals + (pclidx - 1) *
clvals_len, clvals_len, rtrim_(clvals + (pclidx - 1) *
clvals_len, clvals_len));
} else {
/* The key was the last thing on the line. So, it's value is */
/* blank. */
s_copy(clvals + (pclidx - 1) * clvals_len, " ", clvals_len, (
ftnlen)1);
}
}
chkout_("PARCML", (ftnlen)6);
return 0;
} /* parcml_ */
/* $Procedure CHCKDO ( Check presence of required input parameters ) */
/* Subroutine */ int chckdo_(char *indtvl, integer *outtvl, integer *param,
integer *nparam, char *doval, ftnlen indtvl_len, ftnlen doval_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer l;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen), repmc_(char *, char *, char *, char *, ftnlen,
ftnlen, ftnlen, ftnlen);
logical found;
extern integer rtrim_(char *, ftnlen), isrchi_(integer *, integer *,
integer *);
extern logical return_(void);
char errlin[512];
extern /* Subroutine */ int setmsg_(char *, ftnlen), sigerr_(char *,
ftnlen), inssub_(char *, char *, integer *, char *, ftnlen,
ftnlen, ftnlen), chkout_(char *, ftnlen);
/* $ Abstract */
/* This routine is a module of the MKSPK program. It checks whether */
/* set of input parameters specified in the DATA_ORDER value */
/* contains all parameters required for a given input data type and */
/* output SPK type. */
/* $ 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 */
/* MKSPK User's Guide */
/* $ Keywords */
/* None. */
/* $ Declarations */
/* $ Abstract */
/* MKSPK Include 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. */
/* $ Author_and_Institution */
/* N.G. Khavenson (IKI RAS, Russia) */
/* B.V. Semenov (NAIF, JPL) */
/* $ Version */
/* - Version 1.3.0, 08-FEB-2012 (BVS). */
/* Added TLE coverage and ID keywords. Added default TLE pad */
/* parameter. */
/* - Version 1.2.0, 16-JAN-2008 (BVS). */
/* Added ETTMWR parameter */
/* - Version 1.1.0, 05-JUN-2001 (BVS). */
/* Added MAXDEG parameter. */
/* - Version 1.0.4, 21-MAR-2001 (BVS). */
/* Added parameter for command line flag '-append' indicating */
/* that appending to an existing output file was requested. */
/* Added corresponding setup file keyword ('APPEND_TO_OUTPUT'.) */
/* Added parameters for yes and no values of this keyword. */
/* - Version 1.0.3, 28-JAN-2000 (BVS). */
/* Added parameter specifying number of supported input data */
/* types and parameter specifying number of supported output SPK */
/* types */
/* - Version 1.0.2, 22-NOV-1999 (NGK). */
/* Added parameters for two-line elements processing. */
/* - Version 1.0.1, 18-MAR-1999 (BVS). */
/* Added usage, help and template displays. Corrected comments. */
/* - Version 1.0.0, 8-SEP-1998 (NGK). */
/* -& */
/* Begin Include Section: MKSPK generic parameters. */
/* Maximum number of states allowed per one segment. */
/* String size allocation parameters */
/* Length of buffer for input text processing */
/* Length of a input text line */
/* Length of file name and comment line */
/* Length of string for keyword value processing */
/* Length of string for word processing */
/* Length of data order parameters string */
/* Length of string reserved as delimiter */
/* Numbers of different parameters */
/* Maximum number of allowed comment lines. */
/* Reserved number of input parameters */
/* Full number of delimiters */
/* Number of delimiters that may appear in time string */
/* Command line flags */
/* Setup file keywords reserved values */
/* Standard YES and NO values for setup file keywords. */
/* Number of supported input data types and input DATA TYPE */
/* reserved values. */
/* Number of supported output SPK data types -- this version */
/* supports SPK types 5, 8, 9, 10, 12, 13, 15 and 17. */
/* End of input record marker */
/* Maximum allowed polynomial degree. The value of this parameter */
/* is consistent with the ones in SPKW* routines. */
/* Special time wrapper tag for input times given as ET seconds past */
/* J2000 */
/* Default TLE pad, 1/2 day in seconds. */
/* End Include Section: MKSPK generic parameters. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* INDTVL I Input data type. */
/* OUTTVL I Output spk type. */
/* PARAM I Array of DATA_ORDER parameter IDs */
/* NPARAM I Number of not zero parameter IDs in PARAM */
/* DOVAL I Array of parameter values acceptable in DATA_ORDER */
/* $ Detailed_Input */
/* INDTVL is the input data type. See MKSPK.INC for the */
/* current list of supported input data types. */
/* OUTTVL is the output SPK type. Currently supported output */
/* SPK types are 5, 8, 9, 12, 13, 15 and 17. */
/* PARAM is an integer array containing indexes of the */
/* recognizable input parameters present in the */
/* DATA_ORDER keyword value in the order in which they */
/* were provided in that value. */
/* NPARAM is the number of elements in PARAM. */
/* DOVAL is an array containing complete set recognizable */
/* input parameters. (see main module for the current */
/* list) */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* If the set of input parameters does not contain some of the */
/* required tokens, then the error 'SPICE(MISSINGDATAORDERTK)' */
/* will be signalled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.G. Khavenson (IKI RAS, Russia) */
/* B.V. Semenov (NAIF, JPL) */
/* $ Version */
/* - Version 1.0.3, 29-MAR-1999 (NGK). */
/* Added comments. */
/* - Version 1.0.2, 18-MAR-1999 (BVS). */
/* Corrected comments. */
/* - Version 1.0.1, 13-JAN-1999 (BVS). */
/* Modified error messages. */
/* - Version 1.0.0, 08-SEP-1998 (NGK). */
/* -& */
/* $ Index_Entries */
/* Check adequacy of the DATA_ORDER defined in MKSPK setup */
/* -& */
/* SPICELIB functions */
/* Parameters INELTP, INSTTP, INEQTP containing supported */
/* input data type names and keyword parameter KDATOR are declared */
/* in the include file. */
/* Local variables */
/* Error line variable. Size LINLEN declared in the include file. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("CHCKDO", (ftnlen)6);
}
/* Check if EPOCH is present among specified input parameters. */
if (isrchi_(&c__1, nparam, param) == 0) {
setmsg_("Set of input data parameters specified in the setup file ke"
"yword '#' must contain token '#' designating epoch position "
"in the input data records.", (ftnlen)145);
errch_("#", "DATA_ORDER", (ftnlen)1, (ftnlen)10);
errch_("#", doval, (ftnlen)1, doval_len);
sigerr_("SPICE(MISSINGEPOCHTOKEN)", (ftnlen)24);
}
/* Check whether all necessary input parameters are present */
/* according to the input data type. */
found = TRUE_;
s_copy(errlin, "The following token(s) designating input parameter(s) re"
"quired when input data type is '#' is(are) missing in the value "
"of the setup file keyword '#':", (ftnlen)512, (ftnlen)150);
if (s_cmp(indtvl, "ELEMENTS", rtrim_(indtvl, indtvl_len), (ftnlen)8) == 0)
{
/* Input type is ELEMENTS. Check whether eccentricity, */
/* inclination, argument of periapsis and longitude of ascending */
/* node are present in the input data. */
repmc_(errlin, "#", "ELEMENTS", errlin, (ftnlen)512, (ftnlen)1, (
ftnlen)8, (ftnlen)512);
repmc_(errlin, "#", "DATA_ORDER", errlin, (ftnlen)512, (ftnlen)1, (
ftnlen)10, (ftnlen)512);
if (isrchi_(&c__9, nparam, param) == 0) {
i__1 = rtrim_(errlin, (ftnlen)512) + 1;
inssub_(errlin, " '#',", &i__1, errlin, (ftnlen)512, (ftnlen)5, (
ftnlen)512);
repmc_(errlin, "#", doval + (doval_len << 3), errlin, (ftnlen)512,
(ftnlen)1, doval_len, (ftnlen)512);
found = FALSE_;
}
for (l = 13; l <= 15; ++l) {
if (isrchi_(&l, nparam, param) == 0) {
i__1 = rtrim_(errlin, (ftnlen)512) + 1;
inssub_(errlin, " '#',", &i__1, errlin, (ftnlen)512, (ftnlen)
5, (ftnlen)512);
repmc_(errlin, "#", doval + (l - 1) * doval_len, errlin, (
ftnlen)512, (ftnlen)1, doval_len, (ftnlen)512);
found = FALSE_;
}
}
} else if (s_cmp(indtvl, "STATES", rtrim_(indtvl, indtvl_len), (ftnlen)6)
== 0) {
/* Input type is STATES. Check whether all state vector */
/* components are present in the input data. */
repmc_(errlin, "#", "STATES", errlin, (ftnlen)512, (ftnlen)1, (ftnlen)
6, (ftnlen)512);
repmc_(errlin, "#", "DATA_ORDER", errlin, (ftnlen)512, (ftnlen)1, (
ftnlen)10, (ftnlen)512);
for (l = 2; l <= 7; ++l) {
if (isrchi_(&l, nparam, param) == 0) {
i__1 = rtrim_(errlin, (ftnlen)512) + 1;
inssub_(errlin, " '#',", &i__1, errlin, (ftnlen)512, (ftnlen)
5, (ftnlen)512);
repmc_(errlin, "#", doval + (l - 1) * doval_len, errlin, (
ftnlen)512, (ftnlen)1, doval_len, (ftnlen)512);
found = FALSE_;
}
}
} else if (s_cmp(indtvl, "EQ_ELEMENTS", rtrim_(indtvl, indtvl_len), (
ftnlen)11) == 0) {
/* Input type is EQ_ELEMENTS. Check whether all equinoctial */
/* elements are present in the input data. */
repmc_(errlin, "#", "EQ_ELEMENTS", errlin, (ftnlen)512, (ftnlen)1, (
ftnlen)11, (ftnlen)512);
repmc_(errlin, "#", "DATA_ORDER", errlin, (ftnlen)512, (ftnlen)1, (
ftnlen)10, (ftnlen)512);
for (l = 21; l <= 29; ++l) {
if (isrchi_(&l, nparam, param) == 0) {
i__1 = rtrim_(errlin, (ftnlen)512) + 1;
inssub_(errlin, " '#',", &i__1, errlin, (ftnlen)512, (ftnlen)
5, (ftnlen)512);
repmc_(errlin, "#", doval + (l - 1) * doval_len, errlin, (
ftnlen)512, (ftnlen)1, doval_len, (ftnlen)512);
found = FALSE_;
}
}
}
/* Signal the error if any of the required parameters wasn't found. */
if (! found) {
i__1 = rtrim_(errlin, (ftnlen)512) - 1;
s_copy(errlin + i__1, ".", rtrim_(errlin, (ftnlen)512) - i__1, (
ftnlen)1);
setmsg_(errlin, (ftnlen)512);
sigerr_("SPICE(MISSINGDATAORDERTK)", (ftnlen)25);
}
/* Check whether all necessary input parameters are present */
/* according to the output SPK type. */
found = TRUE_;
if (*outtvl == 17) {
/* Output type is 17. Verify if dM/dt, dNOD/dt, dPER/dt */
/* exist in input data. */
s_copy(errlin, "The following token(s) designating input parameter(s"
") required when output SPK type is 17 is(are) missing in the"
" value of the setup file keyword '#':", (ftnlen)512, (ftnlen)
149);
for (l = 27; l <= 29; ++l) {
if (isrchi_(&l, nparam, param) == 0) {
i__1 = rtrim_(errlin, (ftnlen)512) + 1;
inssub_(errlin, " '#',", &i__1, errlin, (ftnlen)512, (ftnlen)
5, (ftnlen)512);
repmc_(errlin, "#", doval + (l - 1) * doval_len, errlin, (
ftnlen)512, (ftnlen)1, doval_len, (ftnlen)512);
found = FALSE_;
}
}
}
/* Signal the error if any of the required parameters wasn't found. */
if (! found) {
i__1 = rtrim_(errlin, (ftnlen)512) - 1;
s_copy(errlin + i__1, ".", rtrim_(errlin, (ftnlen)512) - i__1, (
ftnlen)1);
setmsg_(errlin, (ftnlen)512);
sigerr_("SPICE(MISSINGDATAORDERTK)", (ftnlen)25);
}
chkout_("CHCKDO", (ftnlen)6);
return 0;
} /* chckdo_ */
/* $Procedure GETOPT ( Get an option from a menu ) */
/* Subroutine */ int getopt_(char *title, integer *nopt, char *optnam, char *
opttxt, integer *option, ftnlen title_len, ftnlen optnam_len, ftnlen
opttxt_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
logical done;
char line[80];
integer iopt, i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen), repmc_(char *, char *, char *, char *, ftnlen,
ftnlen, ftnlen, ftnlen);
logical okequ;
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
char prmpt[80];
extern logical failed_(void);
logical ok, okdigi;
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
logical okalph;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
extern logical return_(void);
extern /* Subroutine */ int writln_(char *, integer *, ftnlen), prompt_(
char *, char *, ftnlen, ftnlen);
char msg[80];
/* $ Abstract */
/* Display a list of options in a standard menu format and get */
/* an option from a user returning the corresponding index of */
/* the option selected. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* None. */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* TITLE I Title for the menu. */
/* NOPT I Number of options available. */
/* OPTNAM I Names for the options. */
/* OPTTXT I Brief text describing an option. */
/* OPTVAL I The value returned when its option is selected. */
/* OPTION O The number of the option selected. */
/* $ Detailed_Input */
/* TITLE Title for the option menu. */
/* NOPT The number of menu options to be displayed. */
/* OPTNAM A list of single character names for the menu options. */
/* These are the names used to select an option. The names */
/* must each be a single alphanumeric character. All names */
/* must be upper case if they are characters. */
/* If the option names is a period, '.', then a blank line */
/* is to be displayed at that position in the menu list. */
/* OPTTXT A list of character strings which contain brief */
/* descriptions for each of the menu options. These */
/* character strings should be kept relatively short. */
/* Please note that the lengths of the option names, OPTNAM, and */
/* the descriptive text for each option, OPTTXT, should be kept */
/* reasonable, they both need to fit on the same output line with */
/* a width of 80 characters. 13 characters out of the 80 available */
/* are used for spacing and menu presentation, so there are 67 */
/* characters available for the option name and the descriptive text */
/* combined. */
/* $ Detailed_Output */
/* OPTION The index of the option selected from the menu. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the number of options, NOPT, is not > 0, the error */
/* SPICE(INVALIDARGUMENT) will be signalled. */
/* 2) If the option names are not all upper case alphanumeric */
/* characters, the error SPICE(BADOPTIONNAME) will be signalled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine will display a menu of options in a standardized */
/* format, promting for the selection of one of the listed options. */
/* This routine will not return to the caller until one of the */
/* supplied options has been selected or an error occurs. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* This routine makes explicit use fo the ASCII character sequence. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* $ Version */
/* - Beta Version 4.2.0, 18-DEC-2010 (EDW) */
/* Declared PROMPT as EXTERNAL. Eliminated unneeded Revisions */
/* section. */
/* - Beta Version 4.1.0, 05-JUL-1995 (KRG) */
/* Removed the initial blank line that was printed before the */
/* title of the menu. The calling program should determine the */
/* whitespace requirements for the appearance of the menu */
/* displayed by this routine. */
/* - Beta Version 4.0.0, 25-APR-1994 (KRG) */
/* Modified the routine to output the index into the list of menu */
/* options rather than a character string representing the option */
/* selected. Also removed several calling arguments that were not */
/* needed anymore. */
/* Added the capability of inserting a blank line into the menu. */
/* This is done by placing a period, '.', into the option name */
/* location where the blank line lshould occur. */
/* Added the missing $ Index_Entries section to the header. */
/* Clarified a few of the comments in the header. */
/* - Beta Version 3.0.0, 03-SEP-1992 (KRG) */
/* -& */
/* $ Index_Entries */
/* display a menu and get a user's selection */
/* -& */
/* SPICELIB functions */
/* Local Parameters */
/* Mnemonic for the standard output. */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("GETOPT", (ftnlen)6);
}
/* Check to make sure that the number of menu options is positive. */
/* if it is not, then signal an error with an appropriate error */
/* message. */
if (*nopt < 1) {
setmsg_("The number of options was not positive: #.", (ftnlen)42);
errint_("#", nopt, (ftnlen)1);
sigerr_("SPICE(INVALIDARGUMENT)", (ftnlen)22);
chkout_("GETOPT", (ftnlen)6);
return 0;
}
/* Initialize the option prompt. */
s_copy(prmpt, " ", (ftnlen)80, (ftnlen)1);
s_copy(prmpt + 3, "Option: ", (ftnlen)77, (ftnlen)8);
/* Check to make sure that all of the option names are alphanumeric */
/* and uppercase. The only exception is the period, which signals a */
/* blank line. */
ok = TRUE_;
i__1 = *nopt;
for (i__ = 1; i__ <= i__1; ++i__) {
okdigi = *(unsigned char *)&optnam[(i__ - 1) * optnam_len] >= '0' && *
(unsigned char *)&optnam[(i__ - 1) * optnam_len] <= '9';
okalph = *(unsigned char *)&optnam[(i__ - 1) * optnam_len] >= 'A' && *
(unsigned char *)&optnam[(i__ - 1) * optnam_len] <= 'Z';
okequ = *(unsigned char *)&optnam[(i__ - 1) * optnam_len] == '.';
ok = ok && (okdigi || okalph || okequ);
if (! ok) {
setmsg_("An illegal option name was found: option #, name '#'. ",
(ftnlen)54);
errint_("#", &i__, (ftnlen)1);
sigerr_("SPICE(ILLEGALOPTIONNAME)", (ftnlen)24);
chkout_("GETOPT", (ftnlen)6);
return 0;
}
}
/* Do until we get a valid option. */
done = FALSE_;
while(! done) {
/* Display the menu title if it is non blank */
if (s_cmp(title, " ", title_len, (ftnlen)1) != 0) {
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
s_copy(line + 9, "#", (ftnlen)71, (ftnlen)1);
repmc_(line, "#", title, line, (ftnlen)80, (ftnlen)1, title_len, (
ftnlen)80);
writln_(line, &c__6, (ftnlen)80);
}
/* Display the menu and read in an option. */
writln_(" ", &c__6, (ftnlen)1);
i__1 = *nopt;
for (i__ = 1; i__ <= i__1; ++i__) {
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
if (s_cmp(optnam + (i__ - 1) * optnam_len, ".", optnam_len, (
ftnlen)1) != 0) {
s_copy(line + 3, "( # ) #", (ftnlen)77, (ftnlen)7);
repmc_(line, "#", optnam + (i__ - 1) * optnam_len, line, (
ftnlen)80, (ftnlen)1, optnam_len, (ftnlen)80);
repmc_(line, "#", opttxt + (i__ - 1) * opttxt_len, line, (
ftnlen)80, (ftnlen)1, opttxt_len, (ftnlen)80);
}
writln_(line, &c__6, (ftnlen)80);
}
writln_(" ", &c__6, (ftnlen)1);
i__ = rtrim_(prmpt, (ftnlen)80) + 1;
prompt_(prmpt, line, i__, (ftnlen)80);
if (failed_()) {
chkout_("GETOPT", (ftnlen)6);
return 0;
}
/* Initialize the option value to zero, invalid option. */
iopt = 0;
if (s_cmp(line, " ", (ftnlen)80, (ftnlen)1) == 0) {
writln_(" ", &c__6, (ftnlen)1);
} else {
ljust_(line, line, (ftnlen)80, (ftnlen)80);
ucase_(line, line, (ftnlen)80, (ftnlen)80);
/* Check to make sure that the option we got is a valid */
/* candidate: It must be alpha numeric. */
okdigi = *(unsigned char *)line >= '0' && *(unsigned char *)line
<= '9';
okalph = *(unsigned char *)line >= 'A' && *(unsigned char *)line
<= 'Z';
ok = okdigi || okalph;
/* If we got a valid candidate for an option, see if it is one */
/* of the options that we are supplying. */
if (ok) {
iopt = isrchc_(line, nopt, optnam, (ftnlen)1, optnam_len);
ok = iopt != 0;
}
if (! ok) {
s_copy(msg, "'#' was not a valid option. Please try again.", (
ftnlen)80, (ftnlen)45);
repmc_(msg, "#", line, msg, (ftnlen)80, (ftnlen)1, (ftnlen)1,
(ftnlen)80);
writln_(" ", &c__6, (ftnlen)1);
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
s_copy(line + 3, "***", (ftnlen)77, (ftnlen)3);
writln_(line, &c__6, (ftnlen)80);
s_copy(line + 3, "*** #", (ftnlen)77, (ftnlen)5);
repmc_(line, "#", msg, line, (ftnlen)80, (ftnlen)1, (ftnlen)
80, (ftnlen)80);
writln_(line, &c__6, (ftnlen)80);
s_copy(line + 3, "***", (ftnlen)77, (ftnlen)3);
writln_(line, &c__6, (ftnlen)80);
writln_(" ", &c__6, (ftnlen)1);
} else {
*option = iopt;
done = TRUE_;
}
}
}
chkout_("GETOPT", (ftnlen)6);
return 0;
} /* getopt_ */
/* $Procedure SPCT2B ( SPK and CK, text to binary ) */
/* Subroutine */ int spct2b_(integer *unit, char *binary, ftnlen binary_len)
{
/* System generated locals */
integer i__1;
cilist ci__1;
olist o__1;
cllist cl__1;
/* Builtin functions */
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
s_cmp(char *, char *, ftnlen, ftnlen), f_open(olist *), s_wsfe(
cilist *), e_wsfe(void), f_clos(cllist *);
/* Local variables */
char line[1000];
extern /* Subroutine */ int spcac_(integer *, integer *, char *, char *,
ftnlen, ftnlen), chkin_(char *, ftnlen);
extern integer ltrim_(char *, ftnlen), rtrim_(char *, ftnlen);
extern /* Subroutine */ int daft2b_(integer *, char *, integer *, ftnlen);
integer handle;
extern /* Subroutine */ int dafcls_(integer *), dafopw_(char *, integer *,
ftnlen);
integer scrtch;
extern /* Subroutine */ int errfnm_(char *, integer *, ftnlen), sigerr_(
char *, ftnlen), chkout_(char *, ftnlen), getlun_(integer *),
setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Reconstruct a binary SPK or CK file including comments */
/* from a text file opened by the calling program. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* SPC */
/* $ Keywords */
/* FILES */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* UNIT I Logical unit connected to the text format file. */
/* BINARY I Name of a binary SPK or CK file to be created. */
/* $ Detailed_Input */
/* UNIT is the logical unit connected to an existing text */
/* format SPK or CK file that may contain comments in */
/* the appropriate SPC format, as written by SPCB2A or */
/* SPCB2T. This file must be opened for read access */
/* using the routine TXTOPR. */
/* This file may contain text that precedes and */
/* follows the SPK or CK data and comments, however, */
/* when calling this routine, the file pointer must be */
/* in a position in the file such that the next line */
/* returned by a READ statement is */
/* ''NAIF/DAF'' */
/* which marks the beginning of the data. */
/* BINARY is the name of a binary SPK or CK file to be created. */
/* The binary file contains the same data and comments */
/* as the text file, but in the binary format required */
/* for use with the SPICELIB reader subroutines. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Files */
/* 1) See arguments UNIT and BINARY above. */
/* 2) This routine uses a Fortran scratch file to temporarily */
/* store the lines of comments if there are any. */
/* $ Exceptions */
/* 1) If there is a problem opening or writing to the binary */
/* file, a routine that SPCT2B calls diagnoses and signals */
/* an error. */
/* 2) If there is a problem reading from the text file, the */
/* error SPICE(FILEREADFAILED) is signalled. */
/* 3) If there is a problem opening a scratch file, the error */
/* SPICE(FILEOPENERROR) is signalled. */
/* 4) If there is a problem writing to the scratch file, the */
/* error SPICE(FILEWRITEFAILED) is signalled. */
/* $ Particulars */
/* The SPICELIB SPK and CK reader subroutines read binary files. */
/* However, because different computing environments have different */
/* binary representations of numbers, you must convert SPK and CK */
/* files to text format when porting from one system to another. */
/* After converting the file to text, you can transfer it using */
/* a transfer protocol program like Kermit or FTP. Then, convert */
/* the text file back to binary format. */
/* The following is a list of the SPICELIB routines that convert */
/* SPK and CK files between binary and text format: */
/* SPCA2B converts text to binary. It opens the text file, */
/* creates a new binary file, and closes both files. */
/* SPCB2A converts binary to text. It opens the binary file, */
/* creates a new text file, and closes both files. */
/* SPCT2B converts text to binary. It creates a new binary */
/* file and closes it. The text file is open on */
/* entrance and exit. */
/* SPCB2T converts binary to text. It opens the binary */
/* file and closes it. The text file is open on */
/* entrance and exit */
/* See the SPC required reading for more information */
/* about SPC routines and the SPK and CK file formats. */
/* $ Examples */
/* 1) The following code fragment creates a text file containing */
/* text format SPK data and comments preceded and followed */
/* by a standard label. */
/* The SPICELIB routine TXTOPN opens a new text file and TXTOPR */
/* opens an existing text file for read access. TEXT and */
/* BINARY are character strings that contain the names of the */
/* text and binary files. */
/* CALL TXTOPN ( TEXT, UNIT ) */
/* (Write header label to UNIT) */
/* CALL SPCB2T ( BINARY, UNIT ) */
/* (Write trailing label to UNIT) */
/* CLOSE ( UNIT ) */
/* The following code fragment reconverts the text format */
/* SPK data and comments back into binary format. */
/* CALL TXTOPR ( TEXT, UNIT ) */
/* (Read, or just read past, header label from UNIT) */
/* CALL SPCT2B ( UNIT, BINARY ) */
/* (Read trailing label from UNIT, if desired ) */
/* CLOSE ( UNIT ) */
/* 2) Suppose three text format SPK files have been appended */
/* together into one text file called THREE.TSP. The following */
/* code fragment converts each set of data and comments into */
/* its own binary file. */
/* CALL TXTOPR ( 'THREE.TSP', UNIT ) */
/* CALL SPCT2B ( UNIT, 'FIRST.BSP' ) */
/* CALL SPCT2B ( UNIT, 'SECOND.BSP' ) */
/* CALL SPCT2B ( UNIT, 'THIRD.BSP' ) */
/* CLOSE ( UNIT ) */
/* $ Restrictions */
/* 1) This routine assumes that the data and comments in the */
/* text format SPK or CK file come from a binary file */
/* and were written by one of the routines SPCB2A or SPCB2T. */
/* Data and/or comments written any other way may not be */
/* in the correct format and, therefore, may not be handled */
/* properly. */
/* 2) Older versions of SPK and CK files did not have a comment */
/* area. These files, in text format, may still be converted */
/* to binary using SPCT2B. However, upon exit, the file pointer */
/* will not be in position ready to read the first line of text */
/* after the data. Instead, the next READ statement after */
/* calling SPCT2B will return the second line of text after */
/* the data. Therefore, example 1 may not work as desired */
/* if the trailing label begins on the first line after the */
/* data. To solve this problem, use DAFT2B instead of SPCT2B. */
/* 3) UNIT must be obtained via TXTOPR. Use TXTOPR to open text */
/* files for read access and get the logical unit. System */
/* dependencies regarding opening text files have been isolated */
/* in the routines TXTOPN and TXTOPR. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* J.E. McLean (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 05-APR-1991 (JEM) */
/* -& */
/* $ Index_Entries */
/* text spk or ck to binary */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SPCT2B", (ftnlen)6);
}
/* DAFT2B creates the new binary file and writes the data to */
/* it. If the 'NAIF/DAF' keyword is not the first line that */
/* it reads from the text file, it will signal an error. */
/* Initially, no records are reserved. */
daft2b_(unit, binary, &c__0, binary_len);
/* The comments follow the data and are surrounded by markers. */
/* BMARK should be the next line that we read. If it isn't, */
/* then this is an old file, created before the comment area */
/* existed. In this case, we've read one line too far, but */
/* we can't backspace because the file was written using list- */
/* directed formatting (See the ANSI standard). All we can do */
/* is check out, leaving the file pointer where it is, but */
/* that's better than signalling an error. */
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = *unit;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
iostat = do_fio(&c__1, line, (ftnlen)1000);
if (iostat != 0) {
goto L100001;
}
iostat = e_rsfe();
L100001:
if (iostat > 0) {
setmsg_("Error reading the text file named FNM. Value of IOSTAT is "
"#.", (ftnlen)61);
errint_("#", &iostat, (ftnlen)1);
errfnm_("FNM", unit, (ftnlen)3);
sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
i__1 = ltrim_(line, (ftnlen)1000) - 1;
if (s_cmp(line + i__1, "~NAIF/SPC BEGIN COMMENTS~", 1000 - i__1, (ftnlen)
25) != 0 || iostat < 0) {
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
/* We're not at the end of the file, and the line we read */
/* is BMARK, so we write the comments to a scratch file. */
/* We do this because we have to use SPCAC to add the comments */
/* to the comment area of the binary file, and SPCAC rewinds */
/* the file. It's okay for SPCAC to rewind a scratch file, */
/* but it's not okay to rewind the file connected to UNIT -- */
/* we don't know the initial location of the file pointer. */
getlun_(&scrtch);
o__1.oerr = 1;
o__1.ounit = scrtch;
o__1.ofnm = 0;
o__1.orl = 0;
o__1.osta = "SCRATCH";
o__1.oacc = "SEQUENTIAL";
o__1.ofm = "FORMATTED";
o__1.oblnk = 0;
iostat = f_open(&o__1);
if (iostat != 0) {
setmsg_("Error opening a scratch file. File name was FNM. Value of"
" IOSTAT is #.", (ftnlen)72);
errint_("#", &iostat, (ftnlen)1);
errfnm_("FNM", &scrtch, (ftnlen)3);
sigerr_("SPICE(FILEOPENERROR)", (ftnlen)20);
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
ci__1.cierr = 1;
ci__1.ciunit = scrtch;
ci__1.cifmt = "(A)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100002;
}
iostat = do_fio(&c__1, line, rtrim_(line, (ftnlen)1000));
if (iostat != 0) {
goto L100002;
}
iostat = e_wsfe();
L100002:
if (iostat != 0) {
setmsg_("Error writing to scratch file. File name is FNM. Value of "
"IOSTAT is #.", (ftnlen)71);
errint_("#", &iostat, (ftnlen)1);
errfnm_("FNM", &scrtch, (ftnlen)3);
sigerr_("SPICE(FILEWRITEFAILED)", (ftnlen)22);
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
/* Continue reading lines from the text file and storing them */
/* in the scratch file until we get to the end marker. */
for(;;) { /* while(complicated condition) */
i__1 = ltrim_(line, (ftnlen)1000) - 1;
if (!(s_cmp(line + i__1, "~NAIF/SPC END COMMENTS~", 1000 - i__1, (
ftnlen)23) != 0))
break;
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = *unit;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100003;
}
iostat = do_fio(&c__1, line, (ftnlen)1000);
if (iostat != 0) {
goto L100003;
}
iostat = e_rsfe();
L100003:
if (iostat != 0) {
setmsg_("Error reading the text file named FNM. Value of IOSTAT"
" is #.", (ftnlen)61);
errint_("#", &iostat, (ftnlen)1);
errfnm_("FNM", unit, (ftnlen)3);
sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
ci__1.cierr = 1;
ci__1.ciunit = scrtch;
ci__1.cifmt = "(A)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100004;
}
iostat = do_fio(&c__1, line, rtrim_(line, (ftnlen)1000));
if (iostat != 0) {
goto L100004;
}
iostat = e_wsfe();
L100004:
if (iostat != 0) {
setmsg_("Error writing to scratch file. File name is FNM. Valu"
"e of IOSTAT is #.", (ftnlen)72);
errint_("#", &iostat, (ftnlen)1);
errfnm_("FNM", &scrtch, (ftnlen)3);
sigerr_("SPICE(FILEWRITEFAILED)", (ftnlen)22);
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
}
/* Open the new binary file and add the comments that have been */
/* stored temporarily in a scratch file. */
dafopw_(binary, &handle, binary_len);
spcac_(&handle, &scrtch, "~NAIF/SPC BEGIN COMMENTS~", "~NAIF/SPC END COM"
"MENTS~", (ftnlen)25, (ftnlen)23);
/* Close the files. The scratch file is automatically deleted. */
dafcls_(&handle);
cl__1.cerr = 0;
cl__1.cunit = scrtch;
cl__1.csta = 0;
f_clos(&cl__1);
chkout_("SPCT2B", (ftnlen)6);
return 0;
} /* spct2b_ */
/* $Procedure LTIME ( Light Time ) */
/* Subroutine */ int ltime_(doublereal *etobs, integer *obs, char *dir,
integer *targ, doublereal *ettarg, doublereal *elapsd, ftnlen dir_len)
{
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
doublereal sobs[6], myet, c__;
integer r__;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
doublereal starg[6];
extern doublereal vdist_(doublereal *, doublereal *);
extern integer rtrim_(char *, ftnlen);
extern logical failed_(void);
doublereal lt;
extern doublereal clight_(void);
integer bcentr;
extern /* Subroutine */ int spkgeo_(integer *, doublereal *, char *,
integer *, doublereal *, doublereal *, ftnlen), sigerr_(char *,
ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* This routine computes the transmit (or receive) time */
/* of a signal at a specified target, given the receive */
/* (or transmit) time at a specified observer. The elapsed */
/* time between transmit and receive is also returned. */
/* $ 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 */
/* SPK */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ETOBS I Epoch of a signal at some observer */
/* OBS I NAIF-id of some observer */
/* DIR I Direction the signal travels ( '->' or '<-' ) */
/* TARG I NAIF-id of the target object */
/* ETTARG O Epoch of the signal at the target */
/* ELAPSD O Time between transmit and receipt of the signal */
/* $ Detailed_Input */
/* ETOBS is an epoch expressed in ephemeris second (TDB) */
/* past the epoch of the J2000 reference system. */
/* This is the time at which an electromagnetic */
/* signal is "at" the observer. */
/* OBS is the NAIF-id of some observer. */
/* DIR is the direction the signal travels. The */
/* acceptable values are '->' and '<-'. When */
/* you read the calling sequence from left to */
/* right, the "arrow" given by DIR indicates */
/* which way the electromagnetic signal is travelling. */
/* If the argument list reads as below, */
/* ..., OBS, '->', TARG, ... */
/* the signal is travelling from the observer to the */
/* target. */
/* If the argument reads as */
/* ..., OBS, '<-', TARG */
/* the signal is travelling from the target to */
/* the observer. */
/* TARG is the NAIF-id of the target. */
/* $ Detailed_Output */
/* ETTARG is the epoch expressed in ephemeris seconds (TDB) */
/* past the epoch of the J2000 reference system */
/* at which the electromagnetic signal is "at" the */
/* target body. */
/* Note ETTARG is computed using only Newtonian */
/* assumptions about the propagation of light. */
/* ELAPSD is the number of ephemeris seconds (TDB) between */
/* transmission and receipt of the signal. */
/* ELAPSD = DABS( ETOBS - ETTARG ) */
/* $ Parameters */
/* None. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* 1) If DIR is not one of '->' or '<-' the error */
/* 'SPICE(BADDIRECTION)' will be signalled. In this case */
/* ETTARG and ELAPSD will not be altered from their */
/* input values. */
/* 2) If insufficient ephemeris information is available to */
/* compute the outputs ETTARG and ELAPSD, or if observer */
/* or target is not recognized, the problems is diagnosed */
/* by a routine in the call tree of this routine. */
/* In this case, the value of ETTARG will be set to ETOBS */
/* and ELAPSD will be set to zero. */
/* $ Particulars */
/* Suppose a radio signal travels between two solar system */
/* objects. Given an ephemeris for the two objects, which way */
/* the signal is travelling, and the time when the signal is */
/* "at" at one of the objects (the observer OBS), this routine */
/* determines when the signal is "at" the other object (the */
/* target TARG). It also returns the elapsed time between */
/* transmission and receipt of the signal. */
/* $ Examples */
/* Example 1. */
/* ---------- */
/* Suppose a signal is transmitted at time ET from the Goldstone */
/* tracking site (id-code 399001) to a spacecraft whose id-code */
/* is -77. */
/* signal travelling to spacecraft */
/* * -._.-._.-._.-._.-._.-._.-._.-._.-> * */
/* Goldstone (OBS=399001) Spacecraft (TARG = -77) */
/* at epoch ETOBS(given) at epoch ETTARG(unknown) */
/* Assuming that all of the required SPICE kernels have been */
/* loaded, the code fragment below shows how to compute the */
/* time (ARRIVE) at which the signal arrives at the spacecraft */
/* and how long (HOWLNG) it took the signal to reach the spacecraft. */
/* (Note that we display the arrival time as the number of seconds */
/* past J2000.) */
/* OBS = 399001 */
/* TARG = -77 */
/* ETOBS = ET */
/* CALL LTIME ( ETOBS, OBS, '->', TARG, ARRIVE, HOWLNG ) */
/* CALL ETCAL */
/* WRITE (*,*) 'The signal arrived at time: ', ARRIVE */
/* WRITE (*,*) 'It took ', HOWLNG, ' seconds to get there.' */
/* Example 2. */
/* ---------- */
/* Suppose a signal is received at the Goldstone tracking sight */
/* at epoch ET from the spacecraft of the previous example. */
/* signal sent from spacecraft */
/* * <-._.-._.-._.-._.-._.-._.-._.-._.- * */
/* Goldstone (OBS=399001) Spacecraft (TARG = -77) */
/* at epoch ETOBS(given) at epoch ETTARG(unknown) */
/* Again assuming that all the required kernels have been loaded */
/* the code fragment below computes the epoch at which the */
/* signal was transmitted from the spacecraft. */
/* OBS = 399001 */
/* TARG = -77 */
/* ETOBS = ET */
/* CALL LTIME ( ETOBS, OBS, '<-', TARG, SENT, HOWLNG ) */
/* CALL ETCAL */
/* WRITE (*,*) 'The signal was transmitted at: ', SENT */
/* WRITE (*,*) 'It took ', HOWLNG, ' seconds to get here.' */
/* EXAMPLE 3 */
/* --------- */
/* Suppose there is a transponder on board the spacecraft of */
/* the previous examples that transmits a signal back to the */
/* sender exactly 1 microsecond after a signal arrives at */
/* the spacecraft. If we send a signal from Goldstone */
/* to the spacecraft and wait to receive it at Canberra. */
/* What will be the epoch at which the return signal arrives */
/* in Canberra? ( The id-code for Canberra is 399002 ). */
/* Again, assuming we've loaded all the necessary kernels, */
/* the fragment below will give us the answer. */
/* GSTONE = 399001 */
/* SC = -77 */
/* CANBER = 399002 */
/* ETGOLD = ET */
/* CALL LTIME ( ETGOLD, GSTONE, '->', SC, SCGET, LT1 ) */
/* Account for the microsecond delay between receipt and transmit */
/* SCSEND = SCGET + 0.000001 */
/* CALL LTIME ( SCSEND, SC, '->', CANBER, ETCANB, LT2 ) */
/* RNDTRP = ETCANB - ETGOLD */
/* WRITE (*,*) 'The signal arrives in Canberra at: ', ETCANB */
/* WRITE (*,*) 'Round trip time for the signal was: ', RNDTRP */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.1.2, 22-SEP-2004 (EDW) */
/* Placed Copyright after Abstract. */
/* - SPICELIB Version 1.1.1, 18-NOV-1996 (WLT) */
/* Errors in the examples section were corrected. */
/* - SPICELIB Version 1.1.0, 10-JUL-1996 (WLT) */
/* Added Copyright Notice to the header. */
/* - SPICELIB Version 1.0.0, 10-NOV-1995 (WLT) */
/* -& */
/* $ Index_Entries */
/* Compute uplink and downlink light time */
/* -& */
/* SPICELIB Functions */
/* Local Variables */
if (return_()) {
return 0;
}
chkin_("LTIME", (ftnlen)5);
/* First perform the obvious error check. */
if (s_cmp(dir, "->", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(dir, "<-", (
ftnlen)2, (ftnlen)2) != 0) {
setmsg_("The direction specifier for the signal was '#' it must be "
"either '->' or '<-'. ", (ftnlen)80);
r__ = rtrim_(dir, (ftnlen)2);
errch_("#", dir, (ftnlen)1, r__);
sigerr_("SPICE(BADDIRECTION)", (ftnlen)19);
chkout_("LTIME", (ftnlen)5);
return 0;
}
/* We need two constants, the speed of light and the id-code */
/* for the solar system barycenter. */
c__ = clight_();
bcentr = 0;
myet = *etobs;
/* First get the barycenter relative states of the observer */
/* and target. */
spkgeo_(obs, &myet, "J2000", &bcentr, sobs, <, (ftnlen)5);
spkgeo_(targ, &myet, "J2000", &bcentr, starg, <, (ftnlen)5);
*elapsd = vdist_(sobs, starg) / c__;
/* The rest is straight forward. We either add the elapsed */
/* time to get the next state or subtract the elapsed time. */
/* This depends on whether we are receiving or transmitting */
/* at the observer. */
/* Note that 3 iterations as performed here gives us */
/* Newtonian accuracy to the nanosecond level for all */
/* known objects in the solar system. The ephemeris */
/* is certain to be much worse than this. */
if (s_cmp(dir, "->", (ftnlen)2, (ftnlen)2) == 0) {
*ettarg = myet + *elapsd;
spkgeo_(targ, ettarg, "J2000", &bcentr, starg, <, (ftnlen)5);
*elapsd = vdist_(sobs, starg) / c__;
*ettarg = myet + *elapsd;
spkgeo_(targ, ettarg, "J2000", &bcentr, starg, <, (ftnlen)5);
*elapsd = vdist_(sobs, starg) / c__;
*ettarg = myet + *elapsd;
spkgeo_(targ, ettarg, "J2000", &bcentr, starg, <, (ftnlen)5);
*elapsd = vdist_(sobs, starg) / c__;
*ettarg = myet + *elapsd;
} else {
*ettarg = myet - *elapsd;
spkgeo_(targ, ettarg, "J2000", &bcentr, starg, <, (ftnlen)5);
*elapsd = vdist_(sobs, starg) / c__;
*ettarg = myet - *elapsd;
spkgeo_(targ, ettarg, "J2000", &bcentr, starg, <, (ftnlen)5);
*elapsd = vdist_(sobs, starg) / c__;
*ettarg = myet - *elapsd;
spkgeo_(targ, ettarg, "J2000", &bcentr, starg, <, (ftnlen)5);
*elapsd = vdist_(sobs, starg) / c__;
*ettarg = myet - *elapsd;
}
if (failed_()) {
*ettarg = myet;
*elapsd = 0.;
}
chkout_("LTIME", (ftnlen)5);
return 0;
} /* ltime_ */
/* $Procedure PRINST (Display string of CK-file summary) */
/* Subroutine */ int prinst_0_(int n__, integer *id, doublereal *tbegin,
doublereal *tend, integer *avflag, integer *frame, char *tout,
logical *fdsp, logical *tdsp, logical *gdsp, logical *ndsp, ftnlen
tout_len)
{
/* Initialized data */
static doublereal tbprev = 0.;
static doublereal teprev = 0.;
static integer idprev = 0;
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer hint;
extern /* Subroutine */ int repmc_(char *, char *, char *, char *, ftnlen,
ftnlen, ftnlen, ftnlen);
integer scidw;
logical found;
extern /* Subroutine */ int repmi_(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
extern integer rtrim_(char *, ftnlen);
integer frcode;
extern /* Subroutine */ int ccifrm_(integer *, integer *, integer *, char
*, integer *, logical *, ftnlen);
char idline[256], fnline[256], tbline[256], avline[256], teline[256];
extern /* Subroutine */ int timecn_(doublereal *, integer *, char *, char
*, ftnlen, ftnlen), frmnam_(integer *, char *, ftnlen), repmcw_(
char *, char *, char *, integer *, char *, ftnlen, ftnlen, ftnlen,
ftnlen);
char outlin[256];
extern /* Subroutine */ int tostdo_(char *, ftnlen), intstr_(integer *,
char *, ftnlen);
/* $ Abstract */
/* Write a single CK-file summary record string to standard */
/* output in requested format. */
/* $ 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 */
/* CKBRIEF.UG */
/* $ Keywords */
/* SUMMARY */
/* CK */
/* $ 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 */
/* -------- --- -------------------------------------------------- */
/* ID I NAIF ID code of object */
/* TBEGIN I Start time of object coverage interval, SCLK ticks */
/* TEND I End time of object coverage interval, SCLK ticks */
/* AVFLAG I Angular velocity flag */
/* FRAME I NAIF ID code of reference frame */
/* TOUT I Key specifying times representation on output */
/* FDSP I Flag defining whether frames name/id is printed */
/* TDSP I Flag defining tabular/non-tabular summary format */
/* GDSP I Flag requesting object grouping by coverage */
/* NDSP I Flag to display frame assosiated with CK ID */
/* $ Detailed_Input */
/* ID Integer NAIF ID code found in summaries */
/* of CK-file and to be written to standard output. */
/* TBEGIN Begin time for object coverage given as DP */
/* SCLK ticks. */
/* TEND End time for object coverage given as DP */
/* SCLK ticks. */
/* AVFLAG Angular velocities presence flag: 0 - not present, */
/* 1 - present, 2 - mixed. */
/* FRAME Integer NAIF ID code of reference frame relative */
/* to which orientation of the ID was given. */
/* TOUT Key specifying time representation on output: */
/* SCLK string, encoded SCLK, ET, UTC or DOY */
/* FDSP Flag defining whether name or ID code of the */
/* FRAME should appear on output. */
/* TDSP Flag defining whether summaries have to be written */
/* in tabular or non-tabular format. */
/* GDSP Flag defining whether objects with the same */
/* coverage must be grouped together. */
/* NDSP Flag requesting display of the name of the frame */
/* associated with CK ID. */
/* $ Detailed_Output */
/* None. This subroutine displays summary line for a CK-file/segment */
/* for subroutine DISPSM. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* Y.K. Zaiko (BERC) */
/* B.V. Semenov (NAIF) */
/* $ Version */
/* - CKBRIEF Beta Version 2.0.0, 13-OCT-2008 (BVS) */
/* Added NDSP argument. Changed to display frame names associated */
/* with CK IDs when NDSP is .TRUE.. */
/* - CKBRIEF Beta Version 1.0.0, 17-FEB-1999 (YKZ)(BVS) */
/* -& */
/* SPICELIB functions */
/* Local parameters. */
/* Output fields widths. */
/* Preset output values. */
/* Local variables */
/* Save previous time boundaries and ID code. */
/* Set initial value to zeros. */
switch(n__) {
case 1: goto L_prinsr;
}
/* Convert all inputs to strings that will appear on output. */
if (*ndsp) {
scidw = 26;
ccifrm_(&c__3, id, &frcode, idline, &hint, &found, (ftnlen)256);
if (! found) {
s_copy(idline, "NO FRAME FOR #", (ftnlen)256, (ftnlen)14);
repmi_(idline, "#", id, idline, (ftnlen)256, (ftnlen)1, (ftnlen)
256);
}
} else {
scidw = 8;
intstr_(id, idline, (ftnlen)256);
}
timecn_(tbegin, id, tout, tbline, tout_len, (ftnlen)256);
timecn_(tend, id, tout, teline, tout_len, (ftnlen)256);
if (*avflag == 2) {
s_copy(avline, "*", (ftnlen)256, (ftnlen)1);
} else if (*avflag == 1) {
s_copy(avline, "Y", (ftnlen)256, (ftnlen)1);
} else {
s_copy(avline, "N", (ftnlen)256, (ftnlen)1);
}
frmnam_(frame, fnline, (ftnlen)256);
if (s_cmp(fnline, " ", (ftnlen)256, (ftnlen)1) == 0) {
if (*frame == 0) {
s_copy(fnline, "MIXED", (ftnlen)256, (ftnlen)5);
} else {
intstr_(frame, fnline, (ftnlen)256);
}
}
/* Make up output string and print them depending on what kind of */
/* output format was requested. */
if (*tdsp) {
/* For table output, set output line template depending on */
/* whether FRAME display was requested. */
if (*fdsp) {
s_copy(outlin, "# # # # #", (ftnlen)256, (ftnlen)11);
} else {
s_copy(outlin, "# # # #", (ftnlen)256, (ftnlen)7);
}
/* Check whether coverage is the same as previous one and */
/* reassign begin and end time to 'same' flag if so. */
if (*tbegin == tbprev && *tend == teprev && s_cmp(tbline, "NEED LSK "
"AND SCLK FILES", (ftnlen)256, (ftnlen)23) != 0 && s_cmp(
teline, "NEED LSK AND SCLK FILES", (ftnlen)256, (ftnlen)23) !=
0) {
s_copy(tbline, " -- same --", (ftnlen)256, (ftnlen)13);
s_copy(teline, " -- same --", (ftnlen)256, (ftnlen)13);
}
/* Substitute string and print out the line. */
repmcw_(outlin, "#", idline, &scidw, outlin, (ftnlen)256, (ftnlen)1, (
ftnlen)256, (ftnlen)256);
repmcw_(outlin, "#", tbline, &c__24, outlin, (ftnlen)256, (ftnlen)1, (
ftnlen)256, (ftnlen)256);
repmcw_(outlin, "#", teline, &c__24, outlin, (ftnlen)256, (ftnlen)1, (
ftnlen)256, (ftnlen)256);
repmcw_(outlin, "#", avline, &c__1, outlin, (ftnlen)256, (ftnlen)1, (
ftnlen)256, (ftnlen)256);
repmcw_(outlin, "#", fnline, &c__32, outlin, (ftnlen)256, (ftnlen)1, (
ftnlen)256, (ftnlen)256);
/* Display the line. */
tostdo_(outlin, rtrim_(outlin, (ftnlen)256));
} else {
/* If grouping flag is set, we display single coverage line for */
/* multiple objects. If it's not set, we display multiple */
/* coverage lines for a single object. Also when GDSP set we do */
/* NOT display angular velocity flags or FRAME names/ids. */
if (*gdsp) {
if (*tbegin == tbprev && *tend == teprev) {
/* This is another object in a group with the same */
/* coverage. Display just the object ID. */
s_copy(outlin, " #", (ftnlen)256, (ftnlen)10);
} else {
/* This is the first object in a group with a different */
/* coverage. Display blank line, coverage and ID of the */
/* first object. */
tostdo_(" ", (ftnlen)1);
s_copy(outlin, "Begin #: # End #: # ", (ftnlen)256, (ftnlen)
21);
repmc_(outlin, "#", tout, outlin, (ftnlen)256, (ftnlen)1,
tout_len, (ftnlen)256);
repmcw_(outlin, "#", tbline, &c__24, outlin, (ftnlen)256, (
ftnlen)1, (ftnlen)256, (ftnlen)256);
repmc_(outlin, "#", tout, outlin, (ftnlen)256, (ftnlen)1,
tout_len, (ftnlen)256);
repmcw_(outlin, "#", teline, &c__24, outlin, (ftnlen)256, (
ftnlen)1, (ftnlen)256, (ftnlen)256);
tostdo_(outlin, rtrim_(outlin, (ftnlen)256));
if (*ndsp) {
s_copy(outlin, "Frames: #", (ftnlen)256, (ftnlen)10);
} else {
s_copy(outlin, "Objects: #", (ftnlen)256, (ftnlen)10);
}
}
repmcw_(outlin, "#", idline, &scidw, outlin, (ftnlen)256, (ftnlen)
1, (ftnlen)256, (ftnlen)256);
tostdo_(outlin, rtrim_(outlin, (ftnlen)256));
} else {
/* No grouping by time was requested. So, display contains */
/* sets of coverage intervals for a particular object. */
if (*id == idprev) {
/* It's the same object. Print out only interval. */
if (*fdsp) {
s_copy(outlin, " # # # #", (ftnlen)256, (ftnlen)11);
} else {
s_copy(outlin, " # # #", (ftnlen)256, (ftnlen)7);
}
} else {
/* It's another object. Print object ID, header and */
/* the first interval. */
tostdo_(" ", (ftnlen)1);
if (*ndsp) {
s_copy(outlin, "Frame: #", (ftnlen)256, (ftnlen)10);
} else {
s_copy(outlin, "Object: #", (ftnlen)256, (ftnlen)10);
}
repmcw_(outlin, "#", idline, &scidw, outlin, (ftnlen)256, (
ftnlen)1, (ftnlen)256, (ftnlen)256);
tostdo_(outlin, rtrim_(outlin, (ftnlen)256));
if (*fdsp) {
s_copy(outlin, " Interval Begin ####### Interval End "
"####### AV Relative to FRAME", (ftnlen)256, (
ftnlen)73);
i__1 = rtrim_("#######", (ftnlen)7);
repmcw_(outlin, "#######", tout, &i__1, outlin, (ftnlen)
256, (ftnlen)7, tout_len, (ftnlen)256);
i__1 = rtrim_("#######", (ftnlen)7);
repmcw_(outlin, "#######", tout, &i__1, outlin, (ftnlen)
256, (ftnlen)7, tout_len, (ftnlen)256);
tostdo_(outlin, rtrim_(outlin, (ftnlen)256));
s_copy(outlin, " ------------------------ -------------"
"----------- --- ----------------- ", (ftnlen)256,
(ftnlen)74);
tostdo_(outlin, rtrim_(outlin, (ftnlen)256));
s_copy(outlin, " # # # #", (ftnlen)256, (ftnlen)11);
} else {
s_copy(outlin, " Interval Begin ####### Interval End "
"####### AV ", (ftnlen)256, (ftnlen)56);
i__1 = rtrim_("#######", (ftnlen)7);
repmcw_(outlin, "#######", tout, &i__1, outlin, (ftnlen)
256, (ftnlen)7, tout_len, (ftnlen)256);
i__1 = rtrim_("#######", (ftnlen)7);
repmcw_(outlin, "#######", tout, &i__1, outlin, (ftnlen)
256, (ftnlen)7, tout_len, (ftnlen)256);
tostdo_(outlin, rtrim_(outlin, (ftnlen)256));
s_copy(outlin, " ------------------------ -------------"
"----------- --- ", (ftnlen)256, (ftnlen)56);
tostdo_(outlin, rtrim_(outlin, (ftnlen)256));
s_copy(outlin, " # # #", (ftnlen)256, (ftnlen)7);
}
}
repmcw_(outlin, "#", tbline, &c__24, outlin, (ftnlen)256, (ftnlen)
1, (ftnlen)256, (ftnlen)256);
repmcw_(outlin, "#", teline, &c__24, outlin, (ftnlen)256, (ftnlen)
1, (ftnlen)256, (ftnlen)256);
repmcw_(outlin, "#", avline, &c__1, outlin, (ftnlen)256, (ftnlen)
1, (ftnlen)256, (ftnlen)256);
repmcw_(outlin, "#", fnline, &c__32, outlin, (ftnlen)256, (ftnlen)
1, (ftnlen)256, (ftnlen)256);
tostdo_(outlin, rtrim_(outlin, (ftnlen)256));
}
}
/* Reassign saved variables. */
tbprev = *tbegin;
teprev = *tend;
idprev = *id;
return 0;
/* $Procedure PRINSR (Reset saved variables) */
L_prinsr:
/* $ Abstract */
/* This entry point resets saved ID and start and stop time) */
/* to make sure that CKBRIEF generates table headers correctly. */
/* $ 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 */
/* CKBRIEF.UG */
/* $ Keywords */
/* SUMMARY */
/* CK */
/* $ Declarations */
/* None. */
/* $ Brief_I/O */
/* None. */
/* $ Detailed_Input */
/* None. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* Y.K. Zaiko (BERC) */
/* B.V. Semenov (NAIF) */
/* $ Version */
/* - CKBRIEF Beta Version 2.0.0, 13-OCT-2008 (BVS) */
/* -& */
tbprev = 0.;
teprev = 0.;
idprev = 0;
return 0;
} /* prinst_ */
/* Subroutine */ int shosym_(char *templt, ftnlen templt_len)
{
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
char name__[32], line[132];
integer ncol, item[3];
logical tran;
integer size[3];
char rest[132];
integer i__, n, r__, space[3];
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen),
repmc_(char *, char *, char *, char *, ftnlen, ftnlen, ftnlen,
ftnlen);
char value[2000];
integer width[3];
extern /* Subroutine */ int stran_(char *, char *, logical *, ftnlen,
ftnlen);
extern integer rtrim_(char *, ftnlen);
logical justr[3];
integer lmarge, pagewd;
char spcial[1*3];
extern /* Subroutine */ int pagscn_(char *, ftnlen);
char margin[32], messge[132];
extern /* Subroutine */ int pagset_(char *, integer *, ftnlen), tabrpt_(
integer *, integer *, integer *, integer *, logical *, logical *,
char *, integer *, integer *, U_fp, ftnlen);
char myline[132];
extern /* Subroutine */ int pagrst_(void), nspmrg_(char *, ftnlen),
symget_(char *, char *, ftnlen, ftnlen);
char frstwd[32];
extern /* Subroutine */ int nspglr_(integer *, integer *), nextwd_(char *,
char *, char *, ftnlen, ftnlen, ftnlen), sympat_(char *, ftnlen),
nspwln_(char *, ftnlen);
extern /* Subroutine */ int retsym_();
logical presrv[3];
extern /* Subroutine */ int setsym_(char *, char *, char *, ftnlen,
ftnlen, ftnlen);
char def[2000];
extern /* Subroutine */ int nicepr_1__(char *, char *, S_fp, ftnlen,
ftnlen);
r__ = rtrim_(templt, templt_len);
sympat_(templt, r__);
symget_(name__, def, (ftnlen)32, (ftnlen)2000);
nspmrg_(margin, (ftnlen)32);
if (s_cmp(name__, " ", (ftnlen)32, (ftnlen)1) == 0) {
s_copy(messge, "There are no symbols that match the template \"#\".",
(ftnlen)132, (ftnlen)49);
repmc_(messge, "#", templt, messge, (ftnlen)132, (ftnlen)1, r__, (
ftnlen)132);
nicepr_1__(messge, margin, (S_fp)nspwln_, (ftnlen)132, (ftnlen)32);
return 0;
}
/* If still here there are some matching symbols. Set up the */
/* standard defaults. */
s_copy(line, "=========================================================="
"================================================================"
"==============================================", (ftnlen)132, (
ftnlen)168);
presrv[0] = TRUE_;
presrv[1] = TRUE_;
presrv[2] = TRUE_;
lmarge = 1;
space[0] = 2;
space[1] = 2;
space[2] = 2;
*(unsigned char *)&spcial[0] = ' ';
*(unsigned char *)&spcial[1] = ' ';
*(unsigned char *)&spcial[2] = ' ';
justr[0] = FALSE_;
justr[1] = FALSE_;
justr[2] = FALSE_;
/* Get the width of the page and based upon that determine */
/* the basic table style that will be used to display the */
/* symbol definition. */
nspglr_(&n, &pagewd);
width[0] = 14;
width[1] = 30;
width[2] = 30;
size[0] = 1;
size[1] = 1;
size[2] = 1;
item[0] = 1;
item[1] = 2;
item[2] = 3;
ncol = 3;
/* Adjust all of the columns */
i__1 = ncol;
for (i__ = 1; i__ <= i__1; ++i__) {
width[(i__2 = i__ - 1) < 3 && 0 <= i__2 ? i__2 : s_rnge("width", i__2,
"shosym_", (ftnlen)156)] = width[(i__3 = i__ - 1) < 3 && 0 <=
i__3 ? i__3 : s_rnge("width", i__3, "shosym_", (ftnlen)156)]
* pagewd / 80;
}
pagewd = 0;
i__1 = ncol;
for (i__ = 1; i__ <= i__1; ++i__) {
pagewd = width[(i__2 = i__ - 1) < 3 && 0 <= i__2 ? i__2 : s_rnge(
"width", i__2, "shosym_", (ftnlen)162)] + space[(i__3 = i__ -
1) < 3 && 0 <= i__3 ? i__3 : s_rnge("space", i__3, "shosym_",
(ftnlen)162)] + pagewd;
}
pagewd -= space[(i__1 = ncol - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge("space"
, i__1, "shosym_", (ftnlen)165)];
nspwln_(" ", (ftnlen)1);
nspwln_("Symbols Matching Request: ", (ftnlen)26);
nspwln_(" ", (ftnlen)1);
pagrst_();
pagset_("PAGEWIDTH", &pagewd, (ftnlen)9);
pagscn_("BODY", (ftnlen)4);
setsym_("Symbol Name", "Definition", "Expanded Value", (ftnlen)11, (
ftnlen)10, (ftnlen)14);
tabrpt_(&ncol, item, size, width, justr, presrv, spcial, &lmarge, space, (
U_fp)retsym_, (ftnlen)1);
s_copy(myline, line, (ftnlen)132, pagewd);
nspwln_(myline, (ftnlen)132);
while(s_cmp(name__, " ", (ftnlen)32, (ftnlen)1) != 0) {
/* Expand this symbol until there's nothing left to do. */
s_copy(value, def, (ftnlen)2000, (ftnlen)2000);
tran = TRUE_;
while(tran) {
nextwd_(def, frstwd, rest, (ftnlen)2000, (ftnlen)32, (ftnlen)132);
ucase_(frstwd, frstwd, (ftnlen)32, (ftnlen)32);
if (s_cmp(frstwd, "DEFINE", (ftnlen)32, (ftnlen)6) != 0 && s_cmp(
frstwd, "UNDEFINE", (ftnlen)32, (ftnlen)8) != 0) {
stran_(value, value, &tran, (ftnlen)2000, (ftnlen)2000);
} else {
tran = FALSE_;
}
}
setsym_(name__, def, value, (ftnlen)32, (ftnlen)2000, (ftnlen)2000);
tabrpt_(&ncol, item, size, width, justr, presrv, spcial, &lmarge,
space, (U_fp)retsym_, (ftnlen)1);
symget_(name__, def, (ftnlen)32, (ftnlen)2000);
}
nspwln_(" ", (ftnlen)1);
return 0;
} /* shosym_ */