void cpy_reverse_sprite(t_bunny_pixelarray *out,
t_sprite_sheet *sp,
int col, int row)
{
t_bunny_position copying_pos;
t_bunny_position actual_pos;
t_bunny_position max;
actual_pos = pos_(col * sp->size.x, row * sp->size.y);
max = pos_(actual_pos.x + sp->size.x, actual_pos.y + sp->size.y);
copying_pos.y = 0;
while (actual_pos.y < max.y)
{
copying_pos.x = sp->size.x;
while (actual_pos.x < max.x)
{
cpy_color(out, sp->pix, copying_pos, actual_pos);
actual_pos.x += 1;
copying_pos.x -= 1;
}
actual_pos.x = col * sp->size.x;
actual_pos.y += 1;
copying_pos.y += 1;
}
}
void option_menu(t_data *data, int selected_index)
{
t_bunny_position pos;
t_bunny_position size;
int margin;
margin = 20;
size = pos_(WIDTH / 2 - 60, 50);
size.y = (data->config->height - margin - (margin * 10)) / 10;
pos.x = WIDTH / 2 - size.x / 2 - 30;
pos.y = margin;
(selected_index == 0) ? (data->rect_opt[0] = label(data, true, size, pos)) :
(data->rect_opt[0] = label(data, false, size, pos));
check_box(data, data->config->fullscreen, data->rect_opt[0].pos);
size = pos_(WIDTH / 2, 50);
size.y = (data->config->height - margin - (margin * 10)) / 10;
pos.x = data->config->width / 2 - data->rect_opt[0].size.x / 2 - 30;
pos.y = data->rect_opt[0].pos.y + data->rect_opt[0].size.y + margin;
data->rect_opt[1] = label(data, false, size, pos);
pos.x = data->config->width / 2 - data->rect_opt[1].size.x / 2;
pos.y = data->rect_opt[1].pos.y + data->rect_opt[1].size.y + margin;
(selected_index == 1) ? (data->rect_opt[2] = label(data, true, size, pos)) :
(data->rect_opt[2] = label(data, false, size, pos));
option_menu_2(data, selected_index, pos, size);
}
void
WagonSimple::setRearBolsterConnectionPosition(double x_, double y_, double z_)
{
fmatvec::Vec3 pos_(fmatvec::INIT, 0.0);
pos_(0) = x_;
pos_(1) = y_;
pos_(2) = z_;
this->setRearBolsterConnectionPosition(pos_);
}
void
WagonSimple::setGeometryReferenceFramePosition(double x_, double y_, double z_)
{
fmatvec::Vec3 pos_(fmatvec::INIT, 0.0);
pos_(0) = x_;
pos_(1) = y_;
pos_(2) = z_;
this->setGeometryReferenceFramePosition(pos_);
}
void input_menu_next(t_data *data, t_mrect *ref)
{
t_mrect box;
box.size = pos_(60, ref->size.y);
box.pos = pos_(ref->pos.x + 20, ref->pos.y);
box.color[0] = WHITE;
box.color[1] = WHITE;
box.contour = 0;
box.selected = false;
draw_square(data->pix_ar, &box);
}
//--------------------------------------------------------------
void ofApp::mousePressed(int x, int y, int button){
Donuts *donuts = new Donuts;
ofPoint pos_(x,y);
donuts->setup(pos_,0,0,50,40);
donuties.push_back(donuts);
}
void cpy_sprite(t_bunny_pixelarray *out, t_sprite_sheet *sp,
int col, int row)
{
t_bunny_position o_pos;
t_bunny_position pos;
t_bunny_position limit;
pos = pos_(col * sp->size.x, row * sp->size.y);
limit = pos_(pos.x + sp->size.x, pos.y + sp->size.y);
o_pos.y = 0;
while (pos.y < limit.y)
{
o_pos.x = 0;
while (pos.x < limit.x)
{
cpy_color(out, sp->pix, o_pos, pos);
pos.x += 1;
o_pos.x++;
}
pos.x = col * sp->size.x;
pos.y += 1;
o_pos.y++;
}
}
/* $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 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__ */
/* 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_ */
int main(){
scatter();
cout << "Gaussian " << gauss_rand() << endl;
ALMcl core;
core.init(10,"landmarks.dat");
drovector pos_(4);
pos_.zero();
cout << "landmark 0 " << core.vision_simulator(pos_,rovec_read(core.landmarks,0)) <<endl;
cout << "landmark 1 " << core.vision_simulator(pos_,rovec_read(core.landmarks,1)) <<endl;
cout << "landmark 2 " << core.vision_simulator(pos_,rovec_read(core.landmarks,2)) <<endl;
cout << "landmark 3 " << core.vision_simulator(pos_,rovec_read(core.landmarks,3)) <<endl;
//ここまでdebug
ALMcl engine, sim, pure;//engine = localization engine, sim = real world simulator
//pure is for simulation excluding noise term
// pure.forward_noise = 0;
//pure.theta_noise = 0;
drovector pos(4),purepos(4);
pos.zero();purepos.zero();
engine.init(100,"landmarks.dat");
dgematrix senario;
senario.read("senario.txt");
dgematrix logPos(T,4),logPure(T,4),logEst(T,4);
sim.forward_noise = 1.0;
sim.theta_noise = 0.1;
sim.vision_noise = 1.0;
pure.forward_noise = 0;
pure.theta_noise = 0;
pure.vision_noise = 1.0;
engine.forward_noise = 1.0;
engine.theta_noise = 0.1;
engine.vision_noise = 1.0;
cout <<"sim fn " << sim.forward_noise << endl;
cout <<"sim tn " << sim.theta_noise << endl;
cout <<"pure fn " << pure.forward_noise << endl;
cout <<"pure tn " << pure.theta_noise << endl;
for(int t=0;t<T;t++){
//command and move
pos = sim.move(pos,senario(t,0),senario(t,1),1);
cout << "pos " << pos << endl;
//pure movement
purepos = pure.move(purepos,senario(t,0),senario(t,1),1);
cout << "purepos " << purepos << endl;
// getchar();
//obtaining view
drovector vision = engine.vision_simulator(pos,rovec_read(engine.landmarks,t%4)); //each time t%4 landmark is observed
cout << "landmark " << vision << endl;
dgematrix view(0,2);// vec_set(view,0,vision);
//updating localization engine
engine.update(senario(t,0),senario(t,1),1,view);
cout << "updated particles "<< endl << engine.X << endl;
cout << "updated weight " << endl << engine.w << endl;
getchar();//estimated self position
engine.get_pos();
//loginmg
vec_set(logPos,t,pos);
vec_set(logPure,t,purepos);
vec_set(logEst,t,engine.get_pos());
}
logPos.write("logPos.txt");
logPure.write("logPure.txt");
logEst.write("logEst.txt");
return 0;
}
/* $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 DPFMT ( Format a double precision number ) */
/* Subroutine */ int dpfmt_(doublereal *x, char *pictur, char *str, ftnlen
pictur_len, ftnlen str_len)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Builtin functions */
integer i_len(char *, ftnlen), s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char fill[1];
integer dpat;
char sign[1];
integer i__;
extern /* Subroutine */ int zzvsbstr_(integer *, integer *, logical *,
char *, logical *, ftnlen);
doublereal y;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen), zzvststr_(doublereal *, char *, integer *,
ftnlen);
logical shift;
extern integer ncpos_(char *, char *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int dpstr_(doublereal *, integer *, char *,
ftnlen);
integer start;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen),
rjust_(char *, char *, ftnlen, ftnlen);
char mystr[32];
integer declen, sigdig;
logical needsn;
integer lastch, sgnlen, frstch, intlen, firstb;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
logical ovflow;
integer expsiz, sprsiz, exp__;
extern integer pos_(char *, char *, integer *, ftnlen, ftnlen);
/* $ Abstract */
/* Using a picture, create a formatted string that represents a */
/* double precision number. */
/* $ 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 */
/* ALPHANUMERIC */
/* CONVERSION */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* X I a double precision number. */
/* PICTUR I a string describing the appearance of the output */
/* STR O a string representing X as prescribed by PICTUR */
/* $ Detailed_Input */
/* X is any double precision number. */
/* PICTUR is a string used to describe the format of the */
/* output string. There are four special characters */
/* recognized by DPFMT --- a leading + or -, a leading */
/* zero ( '0' ) or a zero that follows a leading + or -, */
/* and the first decimal point of the string. */
/* All other non-blank characters are regarded as */
/* equivalent. The picture ends at the first blank */
/* character. The effects associated with the various */
/* characters in a picture are spelled out in the */
/* description of the output STRING. */
/* The following pictures are treated as errors. */
/* ' ', '+', '-', '.', '+.', '-.' */
/* $ Detailed_Output */
/* STRING is a string representing X that matches the input */
/* picture. The format of STRING is governed by PICTUR. */
/* It will represent X rounded to the level of precision */
/* specified by PICTUR. */
/* If the first character of the picture is a minus sign, */
/* the first character in the output string will be */
/* a blank if the number is non-negative, a minus sign */
/* if the number is negative. */
/* If the first character of the picture is a plus sign, */
/* the first character of the output string will be a */
/* plus if the number is positive, a blank if the number */
/* is zero, and a minus sign if the number is negative. */
/* If the first character of the string is NOT a sign */
/* (plus or minus) the first character of the output */
/* string will be a minus sign if the number is negative */
/* and will be the first character of the integer part */
/* of the number otherwise. */
/* The integer portion of STRING will contain the same */
/* number of characters as appear before the decimal */
/* point (or last character if there is no decimal */
/* point) but after a leading + or -. */
/* If the picture begins with any of the following */
/* '+0', '-0', or '0' */
/* it is said to have a leading zero. If a picture has */
/* a leading zero and the integer portion is not large */
/* enough to fill up the integer space specified by */
/* PICTUR, STRING will be zero padded from the sign (if */
/* one is required) up to the first character of the */
/* integer part of the number. */
/* If picture does NOT have a leading zero and the */
/* integer portion is not large enough to fill up the */
/* space specified by PICTUR, STRING will be blank */
/* padded on the left between the sign (if one is */
/* required) and the first character of the integer part */
/* of the number. */
/* If a decimal point ( '.' ) is present in PICTUR it */
/* will be present following the integer portion of */
/* STRING. Moreover, the decimal portion of STRING will */
/* contain the same number of digits as there are */
/* non-blank characters following the decimal point in */
/* PICTUR. However, only the first 14 digits starting */
/* with the first non-zero digit are meaningful. */
/* If the format specified by PICTUR does not provide */
/* enough room for the integer portion of X, the routine */
/* determines whether or not the number of characters */
/* present in the picture is sufficient to create a */
/* representation for X using scientific notation. If */
/* so, the output is displayed using scientific notation */
/* (leading signs, if they are present in PICTUR, will */
/* also appear in STRING). If the format specified by */
/* PICTUR is too short to accommodate scientific */
/* notation, the output string is filled with '*' to the */
/* same length as the length of PICTUR. Leading signs */
/* are not preserved in this overflow case. */
/* STRING may overwrite PICTUR. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) A picture that begins with a blank will cause the error */
/* 'SPICE(NOPICTURE)' to be signalled. */
/* 2) A picture that consists only of '+', '-', '.', '+.' or '-.' */
/* are regarded are regarded as errors (there's no significant */
/* component to the picture.) These pictures cause the error */
/* 'SPICE(BADPICTURE)' to be signalled. */
/* 3) If the length of STR is less than the length of the first */
/* non-blank portion of PICTUR, the error 'SPICE(OUTPUTTOOSHORT)' */
/* will be signalled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine provides a mechanism for producing numeric strings */
/* formatted according to a user supplied picture. We expect that */
/* the string produced by this routine will be used to assist in */
/* the construction of a string that can be read by people. */
/* Note that the process of converting a double precision number */
/* to a string, in not precisely invertible even if the string */
/* contains all of the significant figures allowed by this */
/* routine. You should not anticipate that the string produced */
/* by this routine can be "read" into a double precision number */
/* to reproduce the double precision number X. To the level of */
/* accuracy implied by the string representation, they will be */
/* the same. But, they are unlikely to have the same internal */
/* binary representation. */
/* $ Examples */
/* Suppose that X has the binary representation of PI. Then the */
/* table below illustrates the strings that would be produced */
/* by a variety of different pictures. */
/* PICTUR | STRING */
/* ------------------------------- */
/* '0x.xxx' | '03.142' */
/* 'xx.xxx' | ' 3.142' */
/* '+xxx.yyyy' | '+ 3.1416' */
/* '-.yyyy' | '******' */
/* 'xxxxxxxx' | ' 3' */
/* '00xx' | '0003' */
/* '-00.0000000' | ' 03.1415927' */
/* '00' | '03' */
/* 'x.' | '3.' */
/* '.mynumber' | '3.142E+00' */
/* 'my dog spot' | ' 3' */
/* 'my.dog spot' | ' 3.142' */
/* '+my.dog,spot' | '+ 3.14159265' */
/* Suppose that X has the binary representation of 2/3. Then the */
/* table below illustrates the strings that would be produced */
/* by a variety of different pictures. */
/* PICTUR | STRING */
/* ------------------------------- */
/* '+x.xxx' | '+0.667' */
/* '+xx.xxx' | '+ 0.667' */
/* 'xxx.yyyy' | ' 0.6667' */
/* '.yyyy' | '.6667' */
/* 'xxxxxxxx' | ' 1' */
/* '00xx' | '0001' */
/* '-0.0000000' | ' 0.6666667' */
/* '00' | '01' */
/* 'x.' | '1.' */
/* 'mynumber' | ' 1' */
/* 'my dog spot' | ' 1' */
/* 'my.dog spot' | ' 0.667' */
/* 'my.dog,spot' | ' 0.66666667' */
/* Suppose that X has the binary representation of -8/9. Then the */
/* table below illustrates the strings that would be produced */
/* by a variety of different pictures. */
/* PICTUR | STRING */
/* ------------------------------- */
/* '+x.xxx' | '-0.889' */
/* '-00.xxxx' | '-00.8889' */
/* 'xxx.xxx' | ' -0.889' */
/* '000.000' | '-00.889' */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.2, 31-JAN-2008 (BVS) */
/* Removed non-standard end-of-declarations marker */
/* 'C%&END_DECLARATIONS' from comments. */
/* - Spicelib Version 1.0.1, 22-JUN-1998 (WLT) */
/* A number of typographical and grammatical errors */
/* were corrected in the header. */
/* - Spicelib Version 1.0.0, 17-SEP-1996 (WLT) */
/* -& */
/* $ Index_Entries */
/* format a string representing a d.p. number */
/* string from a d.p. number and format picture */
/* -& */
/* $ Revisions */
/* None. */
/* -& */
/* SPICELIB functions */
/* Initial values */
/* Determine where the picture ends. */
firstb = pos_(pictur, " ", &c__1, pictur_len, (ftnlen)1);
if (firstb == 0) {
lastch = i_len(pictur, pictur_len);
} else {
lastch = firstb - 1;
}
/* Make sure there is a picture to worry about. */
if (lastch == 0) {
chkin_("DPFMT", (ftnlen)5);
setmsg_("The format picture must begin with a non-blank character. "
"The picture supplied was began with a blank.", (ftnlen)103);
sigerr_("SPICE(NOPICTURE)", (ftnlen)16);
chkout_("DPFMT", (ftnlen)5);
return 0;
} else if (lastch == 1) {
if (s_cmp(pictur, "+", pictur_len, (ftnlen)1) == 0 || s_cmp(pictur,
"-", pictur_len, (ftnlen)1) == 0 || s_cmp(pictur, ".",
pictur_len, (ftnlen)1) == 0) {
chkin_("DPFMT", (ftnlen)5);
setmsg_("Format pictures must have at least one significant char"
"acter. The picture provided '#' does not. ", (ftnlen)97);
errch_("#", pictur, (ftnlen)1, (ftnlen)1);
sigerr_("SPICE(BADPICTURE)", (ftnlen)17);
chkout_("DPFMT", (ftnlen)5);
return 0;
}
} else if (lastch == 2) {
if (s_cmp(pictur, "+.", pictur_len, (ftnlen)2) == 0 || s_cmp(pictur,
"-.", pictur_len, (ftnlen)2) == 0) {
chkin_("DPFMT", (ftnlen)5);
setmsg_("Format pictures must have at least one significant char"
"acter. The picture provided '#' does not. ", (ftnlen)97);
errch_("#", pictur, (ftnlen)1, (ftnlen)2);
sigerr_("SPICE(BADPICTURE)", (ftnlen)17);
chkout_("DPFMT", (ftnlen)5);
return 0;
}
} else if (lastch > i_len(str, str_len)) {
chkin_("DPFMT", (ftnlen)5);
setmsg_("The output string is not long enough to accommodate a numbe"
"r formatted according the the supplied format picture. The "
"output string has length #. The output picture '#' requires"
" # characters. ", (ftnlen)194);
i__1 = i_len(str, str_len);
errint_("#", &i__1, (ftnlen)1);
errch_("#", pictur, (ftnlen)1, lastch);
errint_("#", &lastch, (ftnlen)1);
sigerr_("SPICE(OUTPUTTOOSHORT)", (ftnlen)21);
chkout_("DPFMT", (ftnlen)5);
return 0;
}
/* If we get this far, the routine can go ahead and do its business. */
/* Determine the sign of X. Also, determine how many characters */
/* are needed to represent the sign if leading sign is suppressed for */
/* positive numbers. */
if (*x > 0.) {
*(unsigned char *)sign = '+';
sprsiz = 0;
} else if (*x < 0.) {
*(unsigned char *)sign = '-';
sprsiz = 1;
} else {
*(unsigned char *)sign = ' ';
sprsiz = 0;
}
/* Look at the picture and see if a leading sign is required and */
/* if so whether the sign just determined should use a different */
/* character and how many characters are needed for the sign. */
if (*(unsigned char *)pictur == '+') {
needsn = TRUE_;
sgnlen = 1;
} else if (*(unsigned char *)pictur == '-') {
needsn = TRUE_;
sgnlen = 1;
if (*x > 0.) {
*(unsigned char *)sign = ' ';
}
} else {
if (*x > 0.) {
*(unsigned char *)sign = ' ';
}
needsn = FALSE_;
sgnlen = sprsiz;
}
/* If we need a leading sign. The numeric part of the string */
/* will start at character 2. Otherwise it starts at character 1. */
if (needsn) {
start = 2;
} else {
start = 1;
}
/* We can set the sign portion of the string now. */
s_copy(str, sign, str_len, (ftnlen)1);
/* Determine what character should be use for leading characters */
/* before the first significant character of the output string. */
if (*(unsigned char *)&pictur[start - 1] == '0') {
*(unsigned char *)fill = '0';
} else {
*(unsigned char *)fill = ' ';
}
/* See if there is a decimal point. */
dpat = pos_(pictur, ".", &c__1, pictur_len, (ftnlen)1);
/* The integer part is the stuff to the left of the first */
/* decimal point and that follows the sign (if there is one */
/* that is explicitly required. The length of the decimal */
/* portion is the stuff to the right of the decimal point. */
if (dpat > 0) {
intlen = dpat - start;
declen = lastch - dpat;
} else {
intlen = lastch - start + 1;
declen = -1;
}
/* If a sign was not explicitly requested by placing it in */
/* the first digit of the picture START will be 1. If in */
/* addition X is less than zero ( SGNLEN will be 1 in this */
/* case) we have one fewer digits available for the integer */
/* portion of the string than is currently set in INTLEN. */
/* Adjust INTLEN to reflect the actual number of digits */
/* available. */
/* Also set the SHIFT flag to .TRUE. so that we know to swap */
/* the sign and any blanks that might lie between the sign */
/* and the first significant character of the output string. */
if (start == 1 && sgnlen == 1) {
--intlen;
shift = TRUE_;
/* If INTLEN has become negative (i.e. -1) the picture */
/* must be of the form .xxxxx and the input number must */
/* be negative. Add 1 back onto the INTLEN but take one */
/* away from the decimal length DECLEN. */
if (intlen == -1) {
intlen = 0;
--declen;
if (declen == 0 && intlen == 0) {
/* There is no room for anything other than a */
/* decimal point. We simply fill the output */
/* string with the '*' character. */
i__1 = lastch;
for (i__ = 1; i__ <= i__1; ++i__) {
*(unsigned char *)&str[i__ - 1] = '*';
}
return 0;
}
}
} else {
shift = FALSE_;
}
/* Create the "virtual decimal string" associated with the */
/* unsigned part of X. */
y = abs(*x);
zzvststr_(&y, fill, &exp__, (ftnlen)1);
/* The actual number of digits required to print the unsigned integer */
/* portion X is EXP + 1 (provided EXP is at least 0.) We have */
/* INTLEN slots available. So if EXP + 1 is more than INTLEN */
/* ( which is equivalent to EXP being at least INTLEN) we don't */
/* have enough room to print the unsigned integer portion of the */
/* number. */
if (exp__ >= intlen && y != 0.) {
/* See if we have room to print an exponential form. */
/* First we need the number of characters for the */
/* exponent which is always of the form 'E+dd...' */
/* Computing MIN */
i__1 = 1, i__2 = exp__ / 1000;
/* Computing MIN */
i__3 = 1, i__4 = exp__ / 100;
expsiz = min(i__1,i__2) + 4 + min(i__3,i__4);
/* The number of significant digits that can be printed is the */
/* size of the picture minus: the size of the sign */
/* the size of the exponent */
/* the size of the decimal point. */
sigdig = lastch - sgnlen - expsiz - 1;
/* If we don't have room for at least one significant digit, */
/* there's not much we can do. Fill the string with '*'. */
if (sigdig < 1) {
i__1 = lastch;
for (i__ = 1; i__ <= i__1; ++i__) {
*(unsigned char *)&str[i__ - 1] = '*';
}
} else {
dpstr_(x, &sigdig, mystr, (ftnlen)32);
*(unsigned char *)mystr = *(unsigned char *)sign;
ljust_(mystr, str, (ftnlen)32, str_len);
rjust_(str, str, lastch, lastch);
}
return 0;
}
/* One more check. If -INTLEN is greater than DECLEN, or if */
/* both are zero, we don't have room to create an output string. */
if (intlen == 0 && declen == 0 || -intlen > declen) {
i__1 = lastch;
for (i__ = 1; i__ <= i__1; ++i__) {
*(unsigned char *)&str[i__ - 1] = '*';
}
return 0;
}
/* We have a reasonable chance of successfully constructing */
/* the string without overflow. */
start = sgnlen + 1;
i__1 = -intlen;
zzvsbstr_(&i__1, &declen, &c_true, str + (start - 1), &ovflow, str_len - (
start - 1));
/* We might be done at this point. The IF-THEN block below */
/* handles the one snag that could arise. */
/* If the first digit is a zero as a result of rounding it up */
/* OVFLOW will be true. This means we don't have enough room */
/* in the picture for the integer portion of the string. We try */
/* to make an exponential picture. */
if (ovflow) {
/* See if we have room to print an exponential form. */
/* Computing MIN */
i__1 = 1, i__2 = exp__ / 1000;
/* Computing MIN */
i__3 = 1, i__4 = exp__ / 100;
expsiz = min(i__1,i__2) + 4 + min(i__3,i__4);
/* The number of significant digits that can be printed is the */
/* size of the picture minus: the size of the sign */
/* the size of the exponent */
/* the size of the decimal point. */
sigdig = lastch - sgnlen - expsiz - 1;
if (sigdig < 1) {
i__1 = lastch;
for (i__ = 1; i__ <= i__1; ++i__) {
*(unsigned char *)&str[i__ - 1] = '*';
}
} else {
dpstr_(x, &sigdig, mystr, (ftnlen)32);
*(unsigned char *)mystr = *(unsigned char *)sign;
ljust_(mystr, str, (ftnlen)32, str_len);
rjust_(str, str, lastch, lastch);
return 0;
}
} else if (shift) {
/* We need to move the sign right until, there are no */
/* blanks between it and the next character. */
frstch = ncpos_(str, " -", &c__1, str_len, (ftnlen)2);
if (frstch > 2) {
i__1 = frstch - 2;
s_copy(str + i__1, str, frstch - 1 - i__1, (ftnlen)1);
*(unsigned char *)str = ' ';
}
}
return 0;
} /* dpfmt_ */
/* $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_ */
/* $Procedure BEDEC ( Be a decimal number? ) */
logical bedec_(char *string, ftnlen string_len)
{
/* System generated locals */
logical ret_val;
/* Builtin functions */
integer i_len(char *, ftnlen), s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer c__, d__, e, l;
extern logical beint_(char *, ftnlen), beuns_(char *, ftnlen);
extern integer pos_(char *, char *, integer *, ftnlen, ftnlen);
/* $ Abstract */
/* Determine whether a string represents a decimal number. */
/* $ 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 */
/* WORDS */
/* $ Keywords */
/* ALPHANUMERIC */
/* NUMBERS */
/* SCANNING */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* STRING I Character string. */
/* The function returns TRUE if the string represents a decimal */
/* number. Otherwise, it returns FALSE. */
/* $ Detailed_Input */
/* STRING is any string. */
/* $ Detailed_Output */
/* If the input string contains a decimal number (as defined */
/* in $Particulars below), the function returns TRUE. Otherwise, */
/* the functions returns FALSE. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Particulars */
/* A decimal number may be constructed by concatenating */
/* the following components in the order shown. */
/* 1) A sign ('+' or '-'), or the null string. */
/* 2) An unsigned integer (as defined by function BEUNS), */
/* or the null string. */
/* 3) A decimal point, or the null string. */
/* 4) An unsigned integer, or the null string. */
/* $ Examples */
/* Four classes of numbers recognized by the various BE functions. */
/* UNS unsigned integer */
/* INT integer (includes INT) */
/* DEC decimal number (includes UNS, INT) */
/* NUM number (includes UNS, INT, NUM) */
/* The following table illustrates the differences between */
/* the classes. (Any number of leading and trailing blanks */
/* are acceptable.) */
/* String Accepted by */
/* ------------------ ------------------ */
/* 0 UNS, INT, DEC, NUM */
/* 21 */
/* 21994217453648 */
/* +0 INT, DEC, NUM */
/* -13 */
/* +21946 */
/* 1.23 DEC, NUM */
/* 12. */
/* .17 */
/* +4.1 */
/* -.25 */
/* 2.3e17 NUM */
/* 17.D-13275849 */
/* -.194265E+0004 */
/* Note that the functions don't take the magnitudes of the numbers */
/* into account. They may accept numbers that cannot be represented */
/* in Fortran variables. (For example, '2.19E999999999999' probably */
/* exceeds the maximum floating point number on any machine, but */
/* is perfectly acceptable to BENUM.) */
/* The following strings are not accepted by any of the functions. */
/* String Reason */
/* --------------- ---------------------------------------- */
/* 3/4 No implied operations (rational numbers) */
/* 37+14 No explicit operations */
/* E12 Must have mantissa */
/* 217,346.91 No commas */
/* 3.14 159 264 No embedded spaces */
/* PI No special numbers */
/* FIVE No textual numbers */
/* CXIV No roman numerals */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 01-DEC-1995 (WLT) */
/* -& */
/* $ Index_Entries */
/* determine if a string is a decimal number */
/* -& */
/* SPICELIB functions */
/* Local Variables */
/* First determine whether or not a decimal point is present. */
d__ = pos_(string, ".", &c__1, string_len, (ftnlen)1);
c__ = d__ - 1;
e = d__ + 1;
if (d__ == 0) {
/* If there is no decimal point just apply the integer test. */
ret_val = beint_(string, string_len);
} else {
/* A decimal point is present, get the length of the string */
/* and see where the decimal point is relative to the last */
/* character. */
l = i_len(string, string_len);
if (l == 1) {
/* The string is one character long and a decimal point. */
/* Sorry, this is not a decimal number. */
ret_val = FALSE_;
} else if (d__ == 1) {
/* The decimal point occurs as the first character of the */
/* string. The string following it must begin with */
/* a non-blank character and be an unsigned integer. */
ret_val = *(unsigned char *)&string[e - 1] != ' ' && beuns_(
string + (e - 1), string_len - (e - 1));
} else if (d__ == l) {
/* The decimal point is the last character of the string. */
/* The character that precedes it must be non-blank and */
/* the substring to the left must be an integer. */
ret_val = *(unsigned char *)&string[c__ - 1] != ' ' && beint_(
string, c__);
} else if (*(unsigned char *)&string[c__ - 1] == ' ') {
/* The decimal point occurs somewhere in the middle of the */
/* string and the character preceding it is blank. */
ret_val = *(unsigned char *)&string[e - 1] != ' ' && s_cmp(string,
" ", c__, (ftnlen)1) == 0 && beuns_(string + (e - 1),
string_len - (e - 1));
} else if (*(unsigned char *)&string[e - 1] == ' ') {
/* Again the decimal point occurs somewhere in the middle of */
/* the string and the character following it is blank. */
ret_val = s_cmp(string + (e - 1), " ", l - (e - 1), (ftnlen)1) ==
0 && *(unsigned char *)&string[c__ - 1] != ' ' && beint_(
string, c__);
} else if (*(unsigned char *)&string[c__ - 1] == '-' || *(unsigned
char *)&string[c__ - 1] == '+') {
/* The decimal point is in the middle of the string and */
/* is preceded by a '+' or '-'. There should be nothing */
/* preceeding the sign and what follows the decimal point */
/* should be an unsigned integer. (we already know that the */
/* character following the decimal point is not a blank) */
if (c__ == 1) {
ret_val = beuns_(string + (e - 1), l - (e - 1));
} else {
ret_val = beuns_(string + (e - 1), l - (e - 1)) && s_cmp(
string, " ", c__ - 1, (ftnlen)1) == 0;
}
} else {
/* Last chance, the decimal point is in the middle of the */
/* string. The characters to the right and left of the */
/* point are non-blank and we know the character to the */
/* left of the point is not a sign. The string left must */
/* be an integer, the string to the right must be an */
/* unsigned integer. */
ret_val = beint_(string, c__) && beuns_(string + (e - 1), l - (e
- 1));
}
}
return ret_val;
} /* bedec_ */
