/* $Procedure PARSDO ( Parsing of DATA_ORDER string ) */
/* Subroutine */ int parsdo_(char *line, char *doval, integer *nval, integer *
param, integer *nparam, ftnlen line_len, ftnlen doval_len)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer i__, l;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
char value[12];
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen),
lastnb_(char *, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int nextwd_(char *, char *, char *, ftnlen,
ftnlen, ftnlen), setmsg_(char *, ftnlen), sigerr_(char *, ftnlen),
chkout_(char *, ftnlen);
/* $ Abstract */
/* This routine is a module of the MKSPK program. It parses the */
/* DATA_ORDER value provided in a setup file and forms an array */
/* of indexes of recognizable input parameters contaned in it. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* MKSPK User's Guide */
/* $ Keywords */
/* PARSING */
/* $ Declarations */
/* $ Abstract */
/* MKSPK Include File. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Author_and_Institution */
/* N.G. Khavenson (IKI RAS, Russia) */
/* B.V. Semenov (NAIF, JPL) */
/* $ Version */
/* - Version 1.2.0, 16-JAN-2008 (BVS). */
/* Added ETTMWR parameter */
/* - Version 1.1.0, 05-JUN-2001 (BVS). */
/* Added MAXDEG parameter. */
/* - Version 1.0.4, 21-MAR-2001 (BVS). */
/* Added parameter for command line flag '-append' indicating */
/* that appending to an existing output file was requested. */
/* Added corresponding setup file keyword ('APPEND_TO_OUTPUT'.) */
/* Added parameters for yes and no values of this keyword. */
/* - Version 1.0.3, 28-JAN-2000 (BVS). */
/* Added parameter specifying number of supported input data */
/* types and parameter specifying number of supported output SPK */
/* types */
/* - Version 1.0.2, 22-NOV-1999 (NGK). */
/* Added parameters for two-line elements processing. */
/* - Version 1.0.1, 18-MAR-1999 (BVS). */
/* Added usage, help and template displays. Corrected comments. */
/* - Version 1.0.0, 8-SEP-1998 (NGK). */
/* -& */
/* Begin Include Section: MKSPK generic parameters. */
/* Maximum number of states allowed per one segment. */
/* String size allocation parameters */
/* Length of buffer for input text processing */
/* Length of a input text line */
/* Length of file name and comment line */
/* Length of string for keyword value processing */
/* Length of string for word processing */
/* Length of data order parameters string */
/* Length of string reserved as delimiter */
/* Numbers of different parameters */
/* Maximum number of allowed comment lines. */
/* Reserved number of input parameters */
/* Full number of delimiters */
/* Number of delimiters that may appear in time string */
/* Command line flags */
/* Setup file keywords reserved values */
/* Standard YES and NO values for setup file keywords. */
/* Number of supported input data types and input DATA TYPE */
/* reserved values. */
/* Number of supported output SPK data types -- this version */
/* supports SPK types 5, 8, 9, 10, 12, 13, 15 and 17. */
/* End of input record marker */
/* Maximum allowed polynomial degree. The value of this parameter */
/* is consistent with the ones in SPKW* routines. */
/* Special time wrapper tag for input times given as ET seconds past */
/* J2000 */
/* End Include Section: MKSPK generic parameters. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- ---------------------------------------------- */
/* LINE I DATA_ORDER string */
/* DOVAL I Array of recognizable input parameter names */
/* NVAL I Number of recognizable input parameters */
/* PARAM O Array of parameter IDs present in DATA_ORDER */
/* NPARAM O Number of elements in PARAM */
/* $ Detailed_Input */
/* LINE is the DATA_ORDER value that will be parsed. */
/* DOVAL is an array containing complete set recognizable */
/* input parameters (see main module for the current */
/* list). */
/* NVAL is the total number of recognizable input parameters */
/* (number of elements in DOVAL). */
/* $ Detailed_Output */
/* PARAM is an integer array containing indexes of the */
/* recognizable input parameters present in the input */
/* DATA_ORDER value in the order in which they are */
/* provided in that value. */
/* NPARAM is the number of elements in PARAM. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If token in the data order is not recognized, then the */
/* error 'SPICE(BADDATAORDERTOKEN)' will be signalled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This subroutine parses DATA_ORDER string containing names of */
/* input data record parameters in the order in which they appear */
/* in the input records and returns an integer array of the indexes */
/* of the parameters that were found in the string. */
/* $ Examples */
/* Let DATA_ORDER has following value: */
/* LINE = 'EPOCH X Y Z SKIP VX VY VZ' */
/* and DOVAL array contains the following values: */
/* DOVAL(1) = 'EPOCH' */
/* DOVAL(2) = 'X' */
/* DOVAL(3) = 'Y' */
/* DOVAL(4) = 'Z' */
/* DOVAL(5) = 'VX' */
/* DOVAL(6) = 'VY' */
/* DOVAL(7) = 'VZ' */
/* ... */
/* DOVAL(30) = 'SKIP' */
/* Then after parsing we will have on the output: */
/* NPARAM = 8 */
/* PARAM = 1, 2, 3, 4, 30, 5, 6, 7 */
/* $ Restrictions */
/* Because search for a parameter in the DATA_ORDER value is case */
/* sensitive, the DATA_ORDER value and parameter names must be */
/* in the same case (nominally uppercase). */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.G. Khavenson (IKI RAS, Russia) */
/* B.V. Semenov (NAIF, JPL) */
/* $ Version */
/* - Version 1.0.3, 29-MAR-1999 (NGK). */
/* Corrected examples section. */
/* - Version 1.0.2, 18-MAR-1999 (BVS). */
/* Corrected comments. */
/* - Version 1.0.1, 13-JAN-1999 (BVS). */
/* Modified error messages. */
/* - Version 1.0.0, 08-SEP-1998 (NGK). */
/* -& */
/* $ Index_Entries */
/* Parse MKSPK setup DATA_ORDER string. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Size VALUEL declared in the include file. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("PARSDO", (ftnlen)6);
}
/* Assign zero to PARAM array. */
i__1 = *nval;
for (l = 1; l <= i__1; ++l) {
param[l - 1] = 0;
}
/* Reset counter of words on line. */
*nparam = 0;
while(lastnb_(line, line_len) != 0) {
/* Get next word from the line. Value is already uppercase. */
nextwd_(line, value, line, line_len, (ftnlen)12, line_len);
i__ = isrchc_(value, nval, doval, (ftnlen)12, doval_len);
/* Look whether this value is one of the reserved values. */
if (i__ != 0) {
/* This value is OK. Memorize it. */
++(*nparam);
param[*nparam - 1] = i__;
} else {
/* We can not recognize this value. */
setmsg_("Can not recognize token '#' in the value of the setup f"
"ile keyword '#'. Refer to the User's Guide for the progr"
"am for complete list of allowed tokens.", (ftnlen)150);
errch_("#", value, (ftnlen)1, (ftnlen)12);
errch_("#", "DATA_ORDER", (ftnlen)1, (ftnlen)10);
sigerr_("SPICE(BADDATAORDERTOKEN)", (ftnlen)24);
}
}
chkout_("PARSDO", (ftnlen)6);
return 0;
} /* parsdo_ */
/* $Procedure XFMSTA ( Transform state between coordinate systems) */
/* Subroutine */ int xfmsta_(doublereal *istate, char *icosys, char *ocosys,
char *body, doublereal *ostate, ftnlen icosys_len, ftnlen ocosys_len,
ftnlen body_len)
{
/* Initialized data */
static char cosys[40*6] = "RECTANGULAR "
"CYLINDRICAL " "LATITUDINAL "
" " "SPHERICAL "
"GEODETIC " "PLANETOGRAPHIC "
" ";
static logical first = TRUE_;
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
extern /* Subroutine */ int zzbods2c_(integer *, char *, integer *,
logical *, char *, integer *, logical *, ftnlen, ftnlen);
doublereal ivel[3], ipos[3];
extern /* Subroutine */ int vequ_(doublereal *, doublereal *);
integer isys, osys;
doublereal f;
extern /* Subroutine */ int zzctruin_(integer *);
integer i__, j;
doublereal radii[3];
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen), vpack_(doublereal *, doublereal *, doublereal *,
doublereal *);
extern doublereal dpmax_(void);
logical found;
extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen), vequg_(
doublereal *, integer *, doublereal *);
doublereal sqtmp;
char isysu[40], osysu[40];
static logical svfnd1;
static integer svctr1[2];
extern logical failed_(void);
doublereal jacobi[9] /* was [3][3] */;
extern /* Subroutine */ int bodvcd_(integer *, char *, integer *, integer
*, doublereal *, ftnlen), georec_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), drdgeo_(
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *), recgeo_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), dgeodr_(
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *);
integer bodyid;
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
static integer svbdid;
extern /* Subroutine */ int latrec_(doublereal *, doublereal *,
doublereal *, doublereal *), drdlat_(doublereal *, doublereal *,
doublereal *, doublereal *), cylrec_(doublereal *, doublereal *,
doublereal *, doublereal *), drdcyl_(doublereal *, doublereal *,
doublereal *, doublereal *);
doublereal toobig;
extern /* Subroutine */ int sphrec_(doublereal *, doublereal *,
doublereal *, doublereal *), drdsph_(doublereal *, doublereal *,
doublereal *, doublereal *), pgrrec_(char *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, ftnlen), drdpgr_(char *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, ftnlen),
reccyl_(doublereal *, doublereal *, doublereal *, doublereal *),
reclat_(doublereal *, doublereal *, doublereal *, doublereal *),
sigerr_(char *, ftnlen), recsph_(doublereal *, doublereal *,
doublereal *, doublereal *), chkout_(char *, ftnlen), recpgr_(
char *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, ftnlen), dcyldr_(doublereal *,
doublereal *, doublereal *, doublereal *), dlatdr_(doublereal *,
doublereal *, doublereal *, doublereal *), ljucrs_(integer *,
char *, char *, ftnlen, ftnlen), setmsg_(char *, ftnlen), dsphdr_(
doublereal *, doublereal *, doublereal *, doublereal *);
static char svbody[36];
extern /* Subroutine */ int dpgrdr_(char *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, ftnlen);
extern logical return_(void);
integer dim;
extern /* Subroutine */ int mxv_(doublereal *, doublereal *, doublereal *)
;
/* $ Abstract */
/* Transform a state between coordinate systems. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* CONVERSION */
/* COORDINATE */
/* EPHEMERIS */
/* STATE */
/* $ Declarations */
/* $ Abstract */
/* This include file defines the dimension of the counter */
/* array used by various SPICE subsystems to uniquely identify */
/* changes in their states. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Parameters */
/* CTRSIZ is the dimension of the counter array used by */
/* various SPICE subsystems to uniquely identify */
/* changes in their states. */
/* $ Author_and_Institution */
/* B.V. Semenov (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 29-JUL-2013 (BVS) */
/* -& */
/* End of include file. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- ------------------------------------------------- */
/* ISTATE I Input state. */
/* ICOSYS I Current (input) coordinate system. */
/* OCOSYS I Desired (output) coordinate system. */
/* BODY I Name or NAIF ID of body with which */
/* coordinates are associated (if applicable). */
/* OSTATE O Converted output state. */
/* $ Detailed_Input */
/* ISTATE is a state vector in the input (ICOSYS) coordinate */
/* system representing position and velocity. */
/* All angular measurements must be in radians. */
/* Note: body radii values taken from the kernel */
/* pool are used when converting to or from geodetic or */
/* planetographic coordinates. It is the user's */
/* responsibility to verify the distance inputs are in */
/* the same units as the radii in the kernel pool, */
/* typically kilometers. */
/* ICOSYS is the name of the coordinate system that the input */
/* state vector (ISTATE) is currently in. */
/* ICOSYS may be any of the following: */
/* 'RECTANGULAR' */
/* 'CYLINDRICAL' */
/* 'LATITUDINAL' */
/* 'SPHERICAL' */
/* 'GEODETIC' */
/* 'PLANETOGRAPHIC' */
/* Leading spaces, trailing spaces, and letter case */
/* are ignored. For example, ' cyLindRical ' would be */
/* accepted. */
/* OCOSYS is the name of the coordinate system that the state */
/* should be converted to. */
/* Please see the description of ICOSYS for details. */
/* BODY is the name or NAIF ID of the body associated with the */
/* planetographic or geodetic coordinate system. */
/* If neither of the coordinate system choices are */
/* geodetic or planetographic, BODY may be an empty */
/* string (' '). */
/* Examples of accepted body names or IDs are: */
/* 'Earth' */
/* '399' */
/* Leading spaces, trailing spaces, and letter case are */
/* ignored. */
/* $ Detailed_Output */
/* OSTATE is the state vector that has been converted to the */
/* output coordinate system (OCOSYS). */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If either the input or output coordinate system is not */
/* recognized, the error SPICE(COORDSYSNOTREC) is signaled. */
/* 2) If the input body name cannot be converted to a NAIF ID */
/* (applies to geodetic and planetographic coordinate */
/* systems), the error 'SPICE(IDCODENOTFOUND)' is signaled. */
/* 3) If the input state ISTATE is not valid, meaning the position */
/* but not the velocity is along the z-axis, the error */
/* 'SPICE(INVALIDSTATE)' is signaled. */
/* Note: If both the input position and velocity are along */
/* the z-axis and the output coordinate system is not */
/* rectangular, the velocity can still be calculated even */
/* though the Jacobian is undefined. This case will not */
/* signal an error. An example of the input position and */
/* velocity along the z-axis is below. */
/* Term Value */
/* ----- ------ */
/* x 0 */
/* y 0 */
/* z z */
/* dx/dt 0 */
/* dy/dt 0 */
/* dz/dt dz_dt */
/* 4) If either the input or output coordinate system is */
/* geodetic or planetographic and at least one of the body's */
/* radii is less than or equal to zero, the error */
/* SPICE(INVALIDRADIUS) will be signaled. */
/* 5) If either the input or output coordinate system is */
/* geodetic or planetographic and the difference of the */
/* equatorial and polar radii divided by the equatorial radius */
/* would produce numeric overflow, the error */
/* 'SPICE(INVALIDRADIUS)' will be signaled. */
/* 6) If the product of the Jacobian and velocity components */
/* may lead to numeric overflow, the error */
/* 'SPICE(NUMERICOVERFLOW)' is signaled. */
/* $ Files */
/* SPK, PCK, CK, and FK kernels may be required. */
/* If the input or output coordinate systems are either geodetic or */
/* planetographic, a PCK providing the radii of the body */
/* name BODY must be loaded via FURNSH. */
/* Kernel data are normally loaded once per program run, NOT every */
/* time this routine is called. */
/* $ Particulars */
/* Input Order */
/* ------------------------------------------- */
/* The input and output states will be structured by the */
/* following descriptions. */
/* For rectangular coordinates, the state vector is the following */
/* in which X, Y, and Z are the rectangular position components and */
/* DX, DY, and DZ are the time derivatives of each position */
/* component. */
/* ISTATE = ( X, Y, Z, DX, DY, DZ ) */
/* For cylindrical coordinates, the state vector is the following */
/* in which R is the radius, LONG is the longitudes, Z is the */
/* height, and DR, DLONG, and DZ are the time derivatives of each */
/* position component. */
/* ISTATE = ( R, LONG, Z, DR, DLONG, DZ ) */
/* For latitudinal coordinates, the state vector is the following */
/* in which R is the radius, LONG is the longitude, LAT is the */
/* latitude, and DR, DLONG, and DLAT are the time derivatives of */
/* each position component. */
/* ISTATE = ( R, LONG, LAT, DR, DLONG, DLAT ) */
/* For spherical coordinates, the state vector is the following in */
/* which R is the radius, COLAT is the colatitude, LONG is the */
/* longitude, and DR, DCOLAT, and DLONG are the time derivatives of */
/* each position component. */
/* ISTATE = ( R, COLAT, LONG, DR, DCOLAT, DLONG ) */
/* For geodetic coordinates, the state vector is the following in */
/* which LONG is the longitude, LAT is the latitude, ALT is the */
/* altitude, and DLONG, DLAT, and DALT are the time derivatives of */
/* each position component. */
/* ISTATE = ( LONG, LAT, ALT, DLONG, DLAT, DALT ) */
/* For planetographic coordinates, the state vector is the */
/* following in which LONG is the longitude, LAT is the latitude, */
/* ALT is the altitude, and DLONG, DLAT, and DALT are the time */
/* derivatives of each position component. */
/* ISTATE = ( LONG, LAT, ALT, DLONG, DLAT, DALT ) */
/* Input Boundaries */
/* ------------------------------------------- */
/* There are intervals the input angles must fall within if */
/* the input coordinate system is not rectangular. These */
/* intervals are provided below. */
/* Input variable Input meaning Input interval [rad] */
/* -------------- ------------- ------------------------ */
/* LONG Longitude 0 <= LONG < 2*pi */
/* LAT Latitude -pi/2 <= LAT <= pi/2 */
/* COLAT Colatitude 0 <= COLAT <= pi */
/* $ Examples */
/* The numerical results shown for these examples may differ across */
/* platforms. The results depend on the SPICE kernels used as */
/* input, the compiler and supporting libraries, and the machine */
/* specific arithmetic implementation. */
/* 1) Find the apparent state of Phoebe as seen by CASSINI in the */
/* J2000 frame at 2004 Jun 11 19:32:00. Transform the state */
/* from rectangular to latitudinal coordinates. For verification, */
/* transform the state back from latitudinal to rectangular */
/* coordinates. */
/* Use the meta-kernel shown below to load the required SPICE */
/* kernels. */
/* KPL/MK */
/* File name: xfmsta_ex1.tm */
/* This meta-kernel is intended to support operation of SPICE */
/* example programs. The kernels shown here should not be */
/* assumed to contain adequate or correct versions of data */
/* required by SPICE-based user applications. */
/* In order for an application to use this meta-kernel, the */
/* kernels referenced here must be present in the user's */
/* current working directory. */
/* The names and contents of the kernels referenced */
/* by this meta-kernel are as follows: */
/* File name Contents */
/* --------- -------- */
/* cpck05Mar2004.tpc Planet orientation and */
/* radii */
/* naif0009.tls Leapseconds */
/* 020514_SE_SAT105.bsp Satellite ephemeris for */
/* Saturn */
/* 030201AP_SK_SM546_T45.bsp CASSINI ephemeris */
/* 981005_PLTEPH-DE405S.bsp Planetary ephemeris */
/* \begindata */
/* KERNELS_TO_LOAD = ( 'naif0009.tls' , */
/* '020514_SE_SAT105.bsp' , */
/* '030201AP_SK_SM546_T45.bsp' , */
/* '981005_PLTEPH-DE405S.bsp', */
/* 'cpck05Mar2004.tpc' ) */
/* End of meta-kernel */
/* Example code begins here. */
/* PROGRAM EX1_XFMSTA */
/* IMPLICIT NONE */
/* C */
/* C Local parameters */
/* C */
/* C METAKR is the meta-kernel's filename. */
/* C */
/* CHARACTER*(*) METAKR */
/* PARAMETER ( METAKR = 'xfmsta_ex1.tm' ) */
/* CHARACTER*(*) FORM */
/* PARAMETER ( FORM = '(F16.6, F16.6, F16.6)' ) */
/* C */
/* C Local variables */
/* C */
/* C STAREC is the state of Phoebe with respect to CASSINI in */
/* C rectangular coordinates. STALAT is the state rotated into */
/* C latitudinal coordinates. STREC2 is the state transformed */
/* C back into rectangular coordinates from latitudinal. */
/* C */
/* DOUBLE PRECISION STAREC (6) */
/* DOUBLE PRECISION STALAT (6) */
/* DOUBLE PRECISION STREC2 (6) */
/* C */
/* C ET is the ephemeris time (TDB) corresponding to the */
/* C observation. */
/* C */
/* DOUBLE PRECISION ET */
/* DOUBLE PRECISION LT */
/* INTEGER I */
/* C */
/* C The required kernels must be loaded. */
/* C */
/* CALL FURNSH ( METAKR ) */
/* C */
/* C Calculate the state at 2004 Jun 11 19:32:00 UTC. */
/* C */
/* CALL STR2ET ( '2004-JUN-11-19:32:00', ET ) */
/* C */
/* C Calculate the apparent state of Phoebe as seen by */
/* C CASSINI in the J2000 frame. */
/* C */
/* CALL SPKEZR ( 'PHOEBE', ET, 'IAU_PHOEBE', 'LT+S', */
/* . 'CASSINI', STAREC, LT ) */
/* C */
/* C Transform the state from rectangular to latitudinal. */
/* C Notice that since neither the input nor output */
/* C coordinate frames are 'geodetic' or 'planetographic', */
/* C the input for the body name is a blank string. */
/* C */
/* CALL XFMSTA ( STAREC, 'RECTANGULAR', 'LATITUDINAL', ' ', */
/* . STALAT ) */
/* C */
/* C Transform the state back to rectangular from latitudinal */
/* C for verification. This result should be very similar to */
/* C STAREC. */
/* C */
/* CALL XFMSTA ( STALAT, 'LATITUDINAL', 'RECTANGULAR',' ', */
/* . STREC2 ) */
/* C */
/* C Report the results. */
/* C */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Phoebe as seen by CASSINI - rectangular' */
/* WRITE (*,*) ' Position [km]:' */
/* WRITE (*,FORM) (STAREC(I), I = 1, 3) */
/* WRITE (*,*) ' Velocity [km/s]:' */
/* WRITE (*,FORM) (STAREC(I), I = 4, 6) */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Phoebe as seen by CASSINI - latitudinal' */
/* WRITE (*,*) ' Position [km, rad, rad]:' */
/* WRITE (*,FORM) (STALAT(I), I = 1, 3) */
/* WRITE (*,*) ' Velocity [km/s, rad/s, rad/s]:' */
/* WRITE (*,FORM) (STALAT(I), I = 4, 6) */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Verification: ' */
/* WRITE (*,*) 'Phoebe as seen by CASSINI - rectangular' */
/* WRITE (*,*) ' Position [km]:' */
/* WRITE (*,FORM) (STREC2(I), I = 1, 3) */
/* WRITE (*,*) ' Velocity [km/s]:' */
/* WRITE (*,FORM) (STREC2(I), I = 4, 6) */
/* END */
/* When this program was executed using gfortran on a PC Linux */
/* 64 bit environment, the output was: */
/* Phoebe as seen by CASSINI - rectangular */
/* Position [km]: */
/* -1982.639762 -934.530471 -166.562595 */
/* Velocity [km/s]: */
/* 3.970832 -3.812496 -2.371663 */
/* Phoebe as seen by CASSINI - latitudinal */
/* Position [km, rad, rad]: */
/* 2198.169858 -2.701121 -0.075846 */
/* Velocity [km/s, rad/s, rad/s]: */
/* -1.780939 0.002346 -0.001144 */
/* Verification: */
/* Phoebe as seen by CASSINI - rectangular */
/* Position [km]: */
/* -1982.639762 -934.530471 -166.562595 */
/* Velocity [km/s]: */
/* 3.970832 -3.812496 -2.371663 */
/* 2) Transform a given state from cylindrical to planetographic */
/* coordinates with respect to Earth. */
/* Use the meta-kernel shown below to load the required SPICE */
/* kernels. */
/* KPL/MK */
/* File name: xfmsta_ex2.tm */
/* This meta-kernel is intended to support operation of SPICE */
/* example programs. The kernels shown here should not be */
/* assumed to contain adequate or correct versions of data */
/* required by SPICE-based user applications. */
/* In order for an application to use this meta-kernel, the */
/* kernels referenced here must be present in the user's */
/* current working directory. */
/* The names and contents of the kernels referenced */
/* by this meta-kernel are as follows: */
/* File name Contents */
/* --------- -------- */
/* cpck05Mar2004.tpc Planet orientation and */
/* radii */
/* \begindata */
/* KERNELS_TO_LOAD = ( 'cpck05Mar2004.tpc' ) */
/* \begintext */
/* End of meta-kernel */
/* Example code begins here. */
/* PROGRAM EX2_XFMSTA */
/* IMPLICIT NONE */
/* C */
/* C Local parameters */
/* C */
/* C METAKR is the meta-kernel's filename. */
/* C */
/* CHARACTER*(*) METAKR */
/* PARAMETER ( METAKR = 'xfmsta_ex2.tm' ) */
/* CHARACTER*(*) FORM */
/* PARAMETER ( FORM = '(F16.6, F16.6, F16.6)' ) */
/* C */
/* C Local variables */
/* C */
/* C STACYL is the state in cylindrical coordinates. */
/* C */
/* DOUBLE PRECISION STACYL (6) */
/* C */
/* C STAPLN is the state transformed into planetographic */
/* C coordinates. */
/* C */
/* DOUBLE PRECISION STAPLN (6) */
/* C */
/* C STCYL2 is the state transformed back into */
/* C cylindrical coordinates from planetographic. */
/* C */
/* DOUBLE PRECISION STCYL2 (6) */
/* INTEGER I */
/* DATA STACYL / 1.0D0, 0.5D0, 0.5D0, 0.2D0, 0.1D0, -0.2D0 / */
/* C */
/* C The required kernels must be loaded. */
/* C */
/* CALL FURNSH ( METAKR ) */
/* C */
/* C Transform the state from cylindrical to planetographic. */
/* C Note that since one of the coordinate systems is */
/* C planetographic, the body name must be input. */
/* C */
/* CALL XFMSTA ( STACYL, 'CYLINDRICAL', 'PLANETOGRAPHIC', */
/* . 'EARTH', STAPLN ) */
/* C */
/* C Transform the state back to cylindrical from */
/* C planetographic for verification. The result should be very */
/* C close to STACYL. */
/* C */
/* CALL XFMSTA ( STAPLN, 'PLANETOGRAPHIC', 'CYLINDRICAL', */
/* . 'EARTH', STCYL2 ) */
/* C */
/* C Report the results. */
/* C */
/* WRITE (*,*) 'Cylindrical state' */
/* WRITE (*,*) ' Position [km, rad, km]:' */
/* WRITE (*,FORM) (STACYL(I), I = 1, 3) */
/* WRITE (*,*) ' Velocity [km/s, rad/s, km/s]:' */
/* WRITE (*,FORM) (STACYL(I), I = 4, 6) */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Planetographic state' */
/* WRITE (*,*) ' Position [rad, rad, km]:' */
/* WRITE (*,FORM) (STAPLN(I), I = 1, 3) */
/* WRITE (*,*) ' Velocity [rad/s, rad/s, km/s]:' */
/* WRITE (*,FORM) (STAPLN(I), I = 4, 6) */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Verification: Cylindrical state' */
/* WRITE (*,*) ' Position [km, rad, km]:' */
/* WRITE (*,FORM) (STCYL2(I), I = 1, 3) */
/* WRITE (*,*) ' Velocity [km/s, rad/s, km/s]:' */
/* WRITE (*,FORM) (STCYL2(I), I = 4, 6) */
/* END */
/* When this program was executed using gfortran on a PC Linux */
/* 64 bit environment, the output was: */
/* Cylindrical state */
/* Position [km, rad, km]: */
/* 1.000000 0.500000 0.500000 */
/* Velocity [km/s, rad/s, km/s]: */
/* 0.200000 0.100000 -0.200000 */
/* Planetographic state */
/* Position [rad, rad, km]: */
/* 0.500000 1.547727 -6356.238467 */
/* Velocity [rad/s, rad/s, km/s]: */
/* 0.100000 -0.004721 -0.195333 */
/* Verification: Cylindrical state */
/* Position [km, rad, km]: */
/* 1.000000 0.500000 0.500000 */
/* Velocity [km/s, rad/s, km/s]: */
/* 0.200000 0.100000 -0.200000 */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* S.C. Krening (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0 22-APR-2014 (SCK)(BVS) */
/* -& */
/* $ Index_Entries */
/* state transformation between coordinate systems */
/* convert state */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Potentially large numbers produced by transforming the */
/* velocity using the Jacobian must not exceed DPMAX()/MARGIN: */
/* The size of each coordinate system name must not exceed */
/* CHSIZ characters. */
/* NCOSYS is the number of coordinate systems supported by */
/* this routine. */
/* The following integer parameters represent the coordinate */
/* systems supported by this routine. */
/* Saved body name length. */
/* Local variables */
/* COSYS is the array of supported coordinate system names. */
/* ISYSU and OSYSU are the input and output coordinate systems */
/* from the user that are made insensitive to case or leading and */
/* trailing spaces. */
/* IPOS and IVEL are the input position and velocity translated */
/* into rectangular. */
/* For transformations including either geodetic or planetographic */
/* coordinate systems, RADII is an array of the radii values */
/* associated with the input body. These values will be loaded */
/* from the kernel pool. */
/* JACOBI is the Jacobian matrix that converts the velocity */
/* coordinates between systems. */
/* The flattening coefficient, F, is calculated when either */
/* geodetic or planetographic coordinate systems are included */
/* in the transformation. */
/* SQTMP and TOOBIG are used to check for possible numeric */
/* overflow situations. */
/* BODYID and DIM are only used when the input or output coordinate */
/* systems are geodetic or planetographic. The BODYID is the NAID ID */
/* associated with the input body name. DIM is used while retrieving */
/* the radii from the kernel pool. */
/* ISYS and OSYS are the integer codes corresponding to the */
/* input and output coordinate systems. I and J are iterators. */
/* Saved name/ID item declarations. */
/* Saved variables */
/* Saved name/ID items. */
/* Assign the names of the coordinate systems to a character */
/* array in which each coordinate system name is located at */
/* the index of the integer ID of the coordinate system. */
/* Initial values. */
/* There are three main sections of this routine: */
/* 1) Error handling and initialization. */
/* 2) Conversion of the input to rectangular coordinates. */
/* 3) Conversion from rectangular to the output coordinates. */
/* Error handling and initialization */
/* ---------------------------------------------------------------- */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
chkin_("XFMSTA", (ftnlen)6);
/* Initialization. */
if (first) {
/* Initialize counter. */
zzctruin_(svctr1);
first = FALSE_;
}
/* Remove initial and trailing spaces. */
/* Convert the input coordinate systems to upper case. */
ljucrs_(&c__0, icosys, isysu, icosys_len, (ftnlen)40);
ljucrs_(&c__0, ocosys, osysu, ocosys_len, (ftnlen)40);
/* Check to see if the input and output coordinate systems */
/* provided by the user are acceptable. Store the integer */
/* code of the input and output coordinate systems into */
/* ISYS and OSYS. */
isys = isrchc_(isysu, &c__6, cosys, (ftnlen)40, (ftnlen)40);
osys = isrchc_(osysu, &c__6, cosys, (ftnlen)40, (ftnlen)40);
/* If the coordinate systems are not acceptable, an error is */
/* signaled. */
if (isys == 0 || osys == 0) {
if (isys == 0 && osys == 0) {
/* Both the input and the output coordinate systems were not */
/* recognized. */
setmsg_("Input coordinate system # and output coordinate system "
"# are not recognized.", (ftnlen)76);
errch_("#", icosys, (ftnlen)1, icosys_len);
errch_("#", ocosys, (ftnlen)1, ocosys_len);
sigerr_("SPICE(COORDSYSNOTREC)", (ftnlen)21);
chkout_("XFMSTA", (ftnlen)6);
return 0;
} else if (isys == 0) {
/* The input coordinate system was not recognized. */
setmsg_("Input coordinate system # was not recognized", (ftnlen)
44);
errch_("#", icosys, (ftnlen)1, icosys_len);
sigerr_("SPICE(COORDSYSNOTREC)", (ftnlen)21);
chkout_("XFMSTA", (ftnlen)6);
return 0;
} else {
/* The output coordinate system was not recognized. */
setmsg_("Output coordinate system # was not recognized", (ftnlen)
45);
errch_("#", ocosys, (ftnlen)1, ocosys_len);
sigerr_("SPICE(COORDSYSNOTREC)", (ftnlen)21);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
}
/* If the input and output coordinate systems are equal, set the */
/* output equal to the input since no conversion needs to take */
/* place. */
if (isys == osys) {
vequg_(istate, &c__6, ostate);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* If converting to or from either geodetic or planetographic, the */
/* NAIF ID must be found from the input body name BODY. If the */
/* body name does not have a valid NAIF ID code, an error is */
/* signaled. If the NAIF ID is valid, the radii of the body are */
/* located and the flattening coefficient is calculated. */
if (osys == 5 || osys == 6 || isys == 5 || isys == 6) {
/* Find the NAIF ID code */
zzbods2c_(svctr1, svbody, &svbdid, &svfnd1, body, &bodyid, &found, (
ftnlen)36, body_len);
/* If the body's name was found, find the body's radii and */
/* compute flattening coefficient. Otherwise, signal an error. */
if (found) {
bodvcd_(&bodyid, "RADII", &c__3, &dim, radii, (ftnlen)5);
if (failed_()) {
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* If either radius is less than or equal to zero, an error is */
/* signaled. */
if (radii[2] <= 0. || radii[0] <= 0.) {
setmsg_("At least one radii is less than or equal to zero. T"
"he equatorial radius has a value of # and the polar "
"radius has has a value of #.", (ftnlen)131);
errdp_("#", radii, (ftnlen)1);
errdp_("#", &radii[2], (ftnlen)1);
sigerr_("SPICE(INVALIDRADIUS)", (ftnlen)20);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* If the difference of the equatorial and polar radii */
/* divided by the equatorial radius is greater than DPMAX, */
/* a numeric overflow may occur, so an error is signaled. */
if (sqrt((d__1 = radii[0] - radii[2], abs(d__1))) / sqrt((abs(
radii[0]))) >= sqrt(dpmax_())) {
setmsg_("The equatorial radius for # has a value of # and a "
"polar radius of #. The flattening coefficient cannot"
" be calculated due to numeric overflow.", (ftnlen)142)
;
errch_("#", body, (ftnlen)1, body_len);
errdp_("#", radii, (ftnlen)1);
errdp_("#", &radii[2], (ftnlen)1);
sigerr_("SPICE(INVALIDRADIUS)", (ftnlen)20);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
f = (radii[0] - radii[2]) / radii[0];
} else {
setmsg_("The input body name # does not have a valid NAIF ID cod"
"e.", (ftnlen)57);
errch_("#", body, (ftnlen)1, body_len);
sigerr_("SPICE(IDCODENOTFOUND)", (ftnlen)21);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
}
/* Conversion of the input to rectangular coordinates */
/* ---------------------------------------------------------------- */
/* First, the position and velocity coordinates will be converted */
/* into rectangular coordinates. If the input system is not */
/* rectangular, then the velocity coordinates must be translated */
/* into rectangular using the Jacobian. If the input system is */
/* rectangular, then the input state must simply be saved into IPOS */
/* and IVEL. */
/* TOOBIG is used for preventing numerical overflow. The square */
/* roots of values are used to safely check if overflow will occur. */
toobig = sqrt(dpmax_() / 100.);
if (isys != 1) {
/* To rectangular... */
if (isys == 2) {
/* ... from cylindrical */
cylrec_(istate, &istate[1], &istate[2], ipos);
drdcyl_(istate, &istate[1], &istate[2], jacobi);
} else if (isys == 3) {
/* ... from latitudinal */
latrec_(istate, &istate[1], &istate[2], ipos);
drdlat_(istate, &istate[1], &istate[2], jacobi);
} else if (isys == 4) {
/* ... from spherical */
sphrec_(istate, &istate[1], &istate[2], ipos);
drdsph_(istate, &istate[1], &istate[2], jacobi);
} else if (isys == 5) {
/* ... from geodetic */
georec_(istate, &istate[1], &istate[2], radii, &f, ipos);
if (failed_()) {
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
drdgeo_(istate, &istate[1], &istate[2], radii, &f, jacobi);
} else if (isys == 6) {
/* ... from planetographic */
pgrrec_(body, istate, &istate[1], &istate[2], radii, &f, ipos,
body_len);
if (failed_()) {
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
drdpgr_(body, istate, &istate[1], &istate[2], radii, &f, jacobi,
body_len);
} else {
setmsg_("This error should never occur. This is an intermediate "
"step in which a non-rectangular input state should be tr"
"ansferred to rectangular. The input coordinate system i"
"s not recognized, yet was not caught by an earlier check."
, (ftnlen)224);
sigerr_("SPICE(BUG1)", (ftnlen)11);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* Some DRD* routines are not error free. Be safe and check */
/* FAILED to not use un-initialized JACOBI. */
if (failed_()) {
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* If the multiplication of the Jacobian and velocity can cause */
/* overflow, signal an error. */
for (i__ = 1; i__ <= 3; ++i__) {
for (j = 1; j <= 3; ++j) {
sqtmp = sqrt((d__1 = jacobi[(i__1 = i__ + j * 3 - 4) < 9 && 0
<= i__1 ? i__1 : s_rnge("jacobi", i__1, "xfmsta_", (
ftnlen)1054)], abs(d__1))) * sqrt((d__2 = istate[(
i__2 = j + 2) < 6 && 0 <= i__2 ? i__2 : s_rnge("ista"
"te", i__2, "xfmsta_", (ftnlen)1054)], abs(d__2)));
if (sqtmp > toobig) {
setmsg_("The product of the Jacobian and velocity may ca"
"use numeric overflow.", (ftnlen)68);
sigerr_("SPICE(NUMERICOVERFLOW)", (ftnlen)22);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
}
}
/* Transform the velocity into rectangular coordinates. */
mxv_(jacobi, &istate[3], ivel);
} else if (isys == 1) {
/* If the input coordinate system is rectangular, the input */
/* position does not need to be translated into rectangular. */
vequ_(istate, ipos);
vequ_(&istate[3], ivel);
} else {
setmsg_("This error should never occur. This is an ELSE statement. I"
"f the input coordinate system is not rectangular, the IF sho"
"uld be executed. If the input coordinate system is rectangul"
"ar, the ELSE IF should be executed.", (ftnlen)214);
sigerr_("SPICE(BUG2)", (ftnlen)11);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* Conversion from rectangular into the output coordinates */
/* ---------------------------------------------------------------- */
/* Convert to the output coordinate system. If the output */
/* coordinate system is not rectangular, four calculations must */
/* be made: */
/* 1) Verify the position and velocity are not along the z-axis. */
/* If the position and velocity are along the z-axis, the */
/* velocity can still be converted even though the */
/* Jacobian is not defined. If the position is along the */
/* z-axis but the velocity is not, the velocity cannot be */
/* converted to the output coordinate system. */
/* 2) Calculate the Jacobian from rectangular to the output */
/* coordinate system and verify the product of the Jacobian */
/* and velocity will not cause numeric overflow. */
/* 3) Transform the position to the output coordinate system. */
/* 4) Transform the velocity to the output coordinates using */
/* the Jacobian and the rectangular velocity IVEL. */
if (osys != 1) {
/* From rectangular for the case when the input position is along */
/* the z-axis ... */
if (abs(ipos[0]) + abs(ipos[1]) == 0.) {
if (abs(ivel[0]) + abs(ivel[1]) == 0.) {
/* If the velocity is along the z-axis, then the velocity */
/* can be computed in the output coordinate frame even */
/* though the Jacobian is not defined. */
if (osys == 2) {
/* ... to cylindrical */
vpack_(&c_b56, &c_b56, &ivel[2], &ostate[3]);
reccyl_(ipos, ostate, &ostate[1], &ostate[2]);
} else if (osys == 3) {
/* ... to latitudinal */
vpack_(&ivel[2], &c_b56, &c_b56, &ostate[3]);
reclat_(ipos, ostate, &ostate[1], &ostate[2]);
} else if (osys == 4) {
/* ... to spherical */
vpack_(&ivel[2], &c_b56, &c_b56, &ostate[3]);
recsph_(ipos, ostate, &ostate[1], &ostate[2]);
} else if (osys == 5) {
/* ... to geodetic */
vpack_(&c_b56, &c_b56, &ivel[2], &ostate[3]);
recgeo_(ipos, radii, &f, ostate, &ostate[1], &ostate[2]);
} else if (osys == 6) {
/* ... to planetographic */
vpack_(&c_b56, &c_b56, &ivel[2], &ostate[3]);
recpgr_(body, ipos, radii, &f, ostate, &ostate[1], &
ostate[2], body_len);
} else {
setmsg_("This error should never occur. This is an inter"
"mediate step in which a position and velocity al"
"ong the z-axis are converted to a non-rectangula"
"r coordinate system from rectangular. The output"
" coordinate system is not recognized, yet was no"
"t caught by an earlier check.", (ftnlen)268);
sigerr_("SPICE(BUG3)", (ftnlen)11);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* The output state has been calculated for the special */
/* case of the position and velocity existing along the */
/* z-axis. */
chkout_("XFMSTA", (ftnlen)6);
return 0;
} else {
/* The Jacobian is undefined and the velocity cannot be */
/* converted since it is not along the z-axis. */
/* Signal an error. */
setmsg_("Invalid input state: z axis.", (ftnlen)28);
sigerr_("SPICE(INVALIDSTATE)", (ftnlen)19);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
}
/* From rectangular for cases when the input position is not along */
/* the z-axis ... */
if (osys == 2) {
/* ... to cylindrical */
dcyldr_(ipos, &ipos[1], &ipos[2], jacobi);
reccyl_(ipos, ostate, &ostate[1], &ostate[2]);
} else if (osys == 3) {
/* ... to latitudinal */
dlatdr_(ipos, &ipos[1], &ipos[2], jacobi);
reclat_(ipos, ostate, &ostate[1], &ostate[2]);
} else if (osys == 4) {
/* ... to spherical */
dsphdr_(ipos, &ipos[1], &ipos[2], jacobi);
recsph_(ipos, ostate, &ostate[1], &ostate[2]);
} else if (osys == 5) {
/* ... to geodetic */
dgeodr_(ipos, &ipos[1], &ipos[2], radii, &f, jacobi);
recgeo_(ipos, radii, &f, ostate, &ostate[1], &ostate[2]);
} else if (osys == 6) {
/* ... to planetographic */
dpgrdr_(body, ipos, &ipos[1], &ipos[2], radii, &f, jacobi,
body_len);
recpgr_(body, ipos, radii, &f, ostate, &ostate[1], &ostate[2],
body_len);
} else {
setmsg_("This error should never occur. This is an intermediate "
"step in which a state is converted to a non-rectangular "
"coordinate system from rectangular. The output coordinat"
"e system is not recognized, yet was not caught by an ear"
"lier check.", (ftnlen)234);
sigerr_("SPICE(BUG4)", (ftnlen)11);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* Many D*DR and REC* routines are not error free. Be safe and */
/* check FAILED to not use un-initialized JACOBI. */
if (failed_()) {
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* If the multiplication of the Jacobian and velocity can cause */
/* overflow, signal an error. */
for (i__ = 1; i__ <= 3; ++i__) {
for (j = 1; j <= 3; ++j) {
sqtmp = sqrt((d__1 = jacobi[(i__1 = i__ + j * 3 - 4) < 9 && 0
<= i__1 ? i__1 : s_rnge("jacobi", i__1, "xfmsta_", (
ftnlen)1314)], abs(d__1))) * sqrt((d__2 = ivel[(i__2 =
j - 1) < 3 && 0 <= i__2 ? i__2 : s_rnge("ivel", i__2,
"xfmsta_", (ftnlen)1314)], abs(d__2)));
if (sqtmp > toobig) {
setmsg_("The product of the Jacobian and velocity may ca"
"use numeric overflow.", (ftnlen)68);
sigerr_("SPICE(NUMERICOVERFLOW)", (ftnlen)22);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
}
}
/* Calculate the velocity in the output coordinate system. */
mxv_(jacobi, ivel, &ostate[3]);
} else if (osys == 1) {
/* If the output coordinate system is rectangular, the position */
/* and velocity components of the output state are set equal to */
/* the rectangular IPOS and IVEL, respectively, because the */
/* components have already been converted to rectangular. */
vequ_(ipos, ostate);
vequ_(ivel, &ostate[3]);
} else {
setmsg_("This error should never occur. This is an ELSE statement. I"
"f the output coordinate system is not rectangular, the IF sh"
"ould be executed. If the output coordinate system is rectang"
"ular, the ELSE IF should be executed.", (ftnlen)216);
sigerr_("SPICE(BUG5)", (ftnlen)11);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
chkout_("XFMSTA", (ftnlen)6);
return 0;
} /* xfmsta_ */
/* $Procedure ZZEKREQI ( Private: EK, read from encoded query, integer ) */
/* Subroutine */ int zzekreqi_(integer *eqryi, char *name__, integer *value,
ftnlen name_len)
{
/* Initialized data */
static char namlst[32*15] = "ARCHITECTURE " "INITIALI"
"ZED " "PARSED "
"NAMES_RESOLVED " "TIMES_RESOLVED "
" " "SEM_CHECKED " "NUM_TABLES "
" " "NUM_CONJUNCTIONS " "NUM_CONSTRAINTS "
" " "NUM_SELECT_COLS " "NUM_ORDERB"
"Y_COLS " "NUM_BUF_SIZE " "FREE"
"_NUM " "CHR_BUF_SIZE "
"FREE_CHR ";
static integer namidx[15] = { 2,3,4,5,6,7,8,10,9,12,11,13,14,15,16 };
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
static integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen), errch_(char *, char *, ftnlen, ftnlen), ljust_(
char *, char *, ftnlen, ftnlen);
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
static char tmpnam[32];
extern /* Subroutine */ int setmsg_(char *, ftnlen), sigerr_(char *,
ftnlen), chkout_(char *, ftnlen);
/* $ Abstract */
/* SPICE Private routine intended solely for the support of SPICE */
/* routines. Users should not call this routine directly due */
/* to the volatile nature of this routine. */
/* Read scalar integer value from encoded EK query. */
/* $ 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 */
/* EK */
/* $ Keywords */
/* EK */
/* PRIVATE */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Encoded Query Internal Parameters */
/* ekquery.inc Version 3 16-NOV-1995 (NJB) */
/* Updated to reflect increased value of MAXCON in */
/* ekqlimit.inc. */
/* ekquery.inc Version 2 03-AUG-1995 (NJB) */
/* Updated to support representation of the SELECT clause. */
/* ekquery.inc Version 1 12-JAN-1995 (NJB) */
/* An encoded EK query is an abstract data type implemented */
/* as an integer cell, along with a double precision cell and */
/* a character string. The d.p. cell and string contain numeric */
/* and string values from the query string represented by the */
/* encoded query. */
/* The parameters in this file are intended for use only by the */
/* EK encoded query access routines. Callers of EK routines should */
/* not use these parameters. */
/* The following parameters are indices of specified elements */
/* in the integer portion of the encoded query. */
/* Encoded query architecture type: */
/* `Name resolution' consists of: */
/* - Verifying existence of tables: any table names listed */
/* in the FROM clause of a query must be loaded. */
/* - Validating table aliases used to qualify column names. */
/* - Verifying existence of columns and obtaining data types */
/* for columns. */
/* - Setting data type codes for literal values in the encoded */
/* query. */
/* - Checking consistency of operators and operand data types. */
/* - Making sure unqualified column names are unambiguous. */
/* - For constraints, mapping the table names used to qualify */
/* column names to the ordinal position in the FROM clause */
/* of the corresponding table. */
/* Initialization status---this flag indicates whether the encoded */
/* query has been initialized. Values are ITRUE or IFALSE. See the */
/* include file ekbool.inc for parameter values. */
/* Parse status---this flag indicates whether the parsing operation */
/* that produced an encoded query has been completed. Values are */
/* ITRUE or IFALSE. */
/* Name resolution status---this flag indicates whether names */
/* have been resolved in an encoded query. Values are ITRUE or */
/* IFALSE. */
/* Time resolution status---this flag indicates whether time values */
/* have been resolved in an encoded query. Time resolution */
/* consists of converting strings representing time values to ET. */
/* Values of the status are ITRUE or IFALSE. */
/* Semantic check status---this flag indicates whether semantic */
/* checking of constraints has been performed. */
/* Number of tables specified in FROM clause: */
/* Number of constraints in query: */
/* A special value is used to indicate the `maximal' constraint--- */
/* one that logically cannot be satisfied. If the constraints */
/* are equivalent to the maximal constraint, the location EQNCNS */
/* is assigned the value EQMXML */
/* Number of constraint conjunctions: */
/* Number of order-by columns: */
/* Number of SELECT columns: */
/* Size of double precision buffer: */
/* `Free' pointer into double precision buffer: */
/* Size of character string buffer: */
/* `Free' pointer into character string buffer: */
/* The following four base pointers will be valid after a query */
/* has been parsed: */
/* Base pointer for SELECT column descriptors: */
/* Base pointer for constraint descriptors: */
/* Base pointer for conjunction sizes: */
/* Base pointer for order-by column descriptors: */
/* After the quantities named above, the integer array contains */
/* series of descriptors for tables, constraints, and order-by */
/* columns, as well as a list of `conjunction sizes'---that is, */
/* the sizes of the groups of constraints that form conjunctions, */
/* after the input query has been re-arranged as a disjunction of */
/* conjunctions of constraints. */
/* The offsets of specific elements within descriptors are */
/* parameterized. The base addresses of the descriptors themselves */
/* must be calculated using the counts and sizes of the items */
/* preceding them. */
/* A diagram of the structure of the variable-size portion of the */
/* integer array is shown below: */
/* +-------------------------------------+ */
/* | Fixed-size portion of encoded query | */
/* +-------------------------------------+ */
/* | Encoded FROM clause | */
/* +-------------------------------------+ */
/* | Encoded constraint clause | */
/* +-------------------------------------+ */
/* | Conjunction sizes | */
/* +-------------------------------------+ */
/* | Encoded ORDER BY clause | */
/* +-------------------------------------+ */
/* | Encoded SELECT clause | */
/* +-------------------------------------+ */
/* Value Descriptors */
/* ---------------- */
/* In order to discuss the various descriptors below, we'll make use */
/* of sub-structures called `value descriptors'. These descriptors */
/* come in two flavors: character and double precision. For */
/* strings, a descriptor is a set of begin and end pointers that */
/* indicate the location of the string in the character portion of an */
/* encoded query, along with the begin and end pointers for the */
/* corresponding lexeme in the original query. The pointers are set */
/* to zero when they are not in use, for example if they refer to an */
/* optional lexeme that did not appear in the input query. */
/* All value descriptors start with a data type indicator; values */
/* are from ektype.inc. Integer and time values are referred to */
/* by double precision descriptors. */
/* Parameters for string value descriptor elements: */
/* Numeric value descriptors are similar to those for string values, */
/* the difference being that they have only one pointer to the value */
/* they represent. This pointer is the index of the value in the */
/* encoded query's numeric buffer. */
/* All value descriptors have the same size. In order to allow */
/* table descriptors to have the same size as value descriptors, */
/* we include an extra element in the descriptor. */
/* Column Descriptors */
/* ----------------- */
/* Each column descriptor consists of a character descriptor for the */
/* name of the column, followed by an index, which gives the ordinal */
/* position of the column in the logical table to which the column */
/* belongs. The index element is filled in during name resolution. */
/* Table Descriptors */
/* ----------------- */
/* Each table descriptor consists of a character descriptor for the */
/* name of the table, followed by an index, which gives the ordinal */
/* position of the table in the FROM clause in the original query. */
/* The index element is filled in during name resolution. Aliases */
/* and table names have identical descriptor structures. */
/* Constraint descriptors */
/* ------------------ */
/* Each constraint is characterized by: */
/* - A code indicating whether the constraint compares values */
/* in two columns or the value in a column and a literal */
/* value. The values of this element are EQCOL and EQVAL. */
/* - A descriptor for the table used to qualify the */
/* column name on the left side of the constraint. */
/* - A character value descriptor for the column name on the left */
/* side of the query. */
/* - An operator code indicating the relational operator used */
/* in the constraint. */
/* If the constraint compares values from two columns, the */
/* next items are table and column name descriptors that apply to */
/* the column named on the right side of the relational operator. */
/* If the constraint has a literal value on the right side, the */
/* operator code is followed by... */
/* - a value descriptor. */
/* - Size of a constraint descriptor: */
/* Conjunction sizes */
/* ----------------- */
/* The size of each conjunction of constraints occupies a single */
/* integer. */
/* Order-by Column Descriptors */
/* --------------------------- */
/* Each order-by column descriptor contains descriptors for */
/* the table containing the column and for the name of the column */
/* itself; one additional element is used to indicate the direction */
/* of the ordering (ascending vs descending). */
/* - The last integer in the descriptor indicates whether the */
/* order direction is ascending or descending. */
/* - Size of an order-by column descriptor: */
/* Codes indicating sense of ordering (ascending vs descending): */
/* SELECT Column Descriptors */
/* --------------------------- */
/* Each SELECT column descriptor contains descriptors for */
/* the table containing the column and for the name of the column */
/* itself. */
/* - Size of a SELECT column descriptor: */
/* Miscellaneous parameters: */
/* EQIMIN is the minimum size of the integer portion of */
/* an encoded query. EQIMIN depends on the parameters */
/* MAXTAB */
/* MAXCON */
/* MAXORD */
/* MAXSEL */
/* all of which are declared in the include file ekqlimit.inc. */
/* The functional definition of EQIMIN is: */
/* INTEGER EQIMIN */
/* PARAMETER ( EQIMIN = EQVBAS */
/* . + MAXTAB * EQVDSZ * 2 */
/* . + MAXCON * EQCDSZ */
/* . + MAXCON */
/* . + MAXORD * EQODSZ */
/* . + MAXSEL * EQSDSZ ) */
/* End Include Section: EK Encoded Query Internal Parameters */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* EQRYI I Integer component of query. */
/* NAME I Name of scalar item to read. */
/* VALUE O Value of item. */
/* $ Detailed_Input */
/* EQRYI is the integer portion of an encoded EK query. */
/* NAME is the name of the item whose value is to be read. */
/* This item is some element of the integer portion */
/* of an encoded query. */
/* $ Detailed_Output */
/* VALUE is the integer value designated by NAME. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the input name is not recognized, the error */
/* SPICE(INVALIDNAME) is signalled. The encoded query is not */
/* modified. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine is the inverse of ZZEKWEQI. */
/* $ Examples */
/* See EKSRCH. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - Beta Version 1.0.0, 17-OCT-1995 (NJB) */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Saved variables */
/* Initial values */
/* Use discovery check-in. */
/* Find the location of the named item. */
ljust_(name__, tmpnam, name_len, (ftnlen)32);
ucase_(tmpnam, tmpnam, (ftnlen)32, (ftnlen)32);
i__ = isrchc_(tmpnam, &c__15, namlst, (ftnlen)32, (ftnlen)32);
if (i__ == 0) {
chkin_("ZZEKREQI", (ftnlen)8);
setmsg_("Item # not found.", (ftnlen)17);
errch_("#", name__, (ftnlen)1, name_len);
sigerr_("SPICE(INVALIDNAME)", (ftnlen)18);
chkout_("ZZEKREQI", (ftnlen)8);
return 0;
}
/* Do the deed. */
*value = eqryi[namidx[(i__1 = i__ - 1) < 15 && 0 <= i__1 ? i__1 : s_rnge(
"namidx", i__1, "zzekreqi_", (ftnlen)191)] + 5];
return 0;
} /* zzekreqi_ */
/* $Procedure KXTRCT ( Extract a substring starting with a keyword ) */
/* Subroutine */ int kxtrct_(char *keywd, char *terms, integer *nterms, char *
string, logical *found, char *substr, ftnlen keywd_len, ftnlen
terms_len, ftnlen string_len, ftnlen substr_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer b, e;
extern integer nblen_(char *, ftnlen);
integer start, berase, eerase;
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
integer delims;
extern /* Subroutine */ int fndnwd_(char *, integer *, integer *, integer
*, ftnlen);
integer begstr;
extern /* Subroutine */ int shiftl_(char *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen);
extern integer wdindx_(char *, char *, ftnlen, ftnlen);
integer endstr, positn;
/* $ Abstract */
/* Locate a keyword in a string and extract the substring from */
/* the beginning of the first word following the keyword to the */
/* beginning of the first subsequent recognized terminator of a list. */
/* $ 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 */
/* SEARCH, PARSING, PARSING */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* KEYWD I Word that marks the beginning of text of interest. */
/* TERMS I Set of words, any of which marks the end of text. */
/* NTERMS I Number of TERMS. */
/* STRING I/O String containing a sequence of words. */
/* FOUND O TRUE if the keyword is found in the string. */
/* SUBSTR O String from end of KEYWD to beginning of first */
/* TERMS item found. */
/* $ Detailed_Input */
/* KEYWD is a word used to mark the start of text of interest. */
/* TERMS is a set of words, any one of which may signal the */
/* end of text of interest. */
/* NTERMS is the number of TERMS. */
/* STRING is a character string made up of words, that may */
/* contain the keyword in KEYWD. */
/* $ Detailed_Output */
/* STRING is the input string stripped of all words from */
/* the beginning of the keyword KEYWD to the end of */
/* the last word preceding one of the words in TERMS */
/* (or the end of the string if none of the TERMS follows */
/* KEYWD in the string). */
/* FOUND is .TRUE. if KEYWD is present in the input STRING. */
/* SUBSTR is the substring that begins with the first word */
/* following KEYWD up to the beginning of any of the */
/* words in TERM or the end of the string. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* Definitions: */
/* A WORD is a set of consecutive non-blank characters */
/* delimited by blanks or either end of the string */
/* that contains them. */
/* Given a string and a keyword this routine locates the first */
/* occurrence of the keyword in the string and returns the */
/* substring between the end of the keyword and the first occurrence */
/* of any of the words in a list of terminating words. If none */
/* of the terminating words follows the keyword in the string, */
/* the routine returns all of the string following the keyword. */
/* If the next word following the keyword is a terminating word, */
/* the substring returned will be a blank. */
/* If the keyword can not be located in the string, the variable */
/* FOUND will be returned as .FALSE. and the input string will be */
/* unchanged. The substring will be returned as a blank. */
/* In all other cases, the part of the input string from the */
/* beginning of the keyword to the start of the first terminating */
/* word will be removed. If no terminating word follows the keyword */
/* the portion of the string from the keyword to the last non-blank */
/* character of the string will be removed. */
/* $ Examples */
/* Example 1. */
/* ---------- */
/* Input: STRING 'FROM 1 October 1984 12:00:00 TO 1 January 1987' */
/* KEYWD 'TO' */
/* TERMS 'FROM' */
/* 'TO' */
/* 'BEGINNING' */
/* 'ENDING' */
/* Output: STRING 'FROM 1 October 1984 12:00:00 ' */
/* FOUND .TRUE. */
/* SUBSTR '1 January 1987' */
/* Example 2. */
/* ---------- */
/* Input: STRING 'FROM 1 October 1984 12:00:00 TO 1 January 1987' */
/* KEYWD 'FROM' */
/* TERMS 'FROM' */
/* 'TO' */
/* 'BEGINNING' */
/* 'ENDING' */
/* Output: STRING ' TO 1 January 1987' */
/* FOUND .TRUE. */
/* SUBSTR '1 October 1984 12:00:00' */
/* Example 3. */
/* ---------- */
/* Input: STRING 'ADDRESS: 4800 OAK GROVE DRIVE PHONE: 354-4321 ' */
/* KEYWD 'ADDRESS:' */
/* TERMS 'ADDRESS:' */
/* 'PHONE:' */
/* 'NAME:' */
/* Output: STRING ' PHONE: 354-4321 ' */
/* FOUND .TRUE. */
/* SUBSTR '4800 OAK GROVE DRIVE' */
/* Example 4. */
/* ---------- */
/* Input: STRING 'ADDRESS: 4800 OAK GROVE DRIVE PHONE: 354-4321 ' */
/* KEYWD 'NAME:' */
/* TERMS 'ADDRESS:' */
/* 'PHONE:' */
/* 'NAME:' */
/* Output: STRING 'ADDRESS: 4800 OAK GROVE DRIVE PHONE: 354-4321 ' */
/* FOUND .FALSE. */
/* SUBSTR ' ' */
/* $ Restrictions */
/* It is the user's responsibility to make sure there is adequate */
/* room in SUBSTR to contain the substring. */
/* SUBSTR cannot overwrite STRING. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (WLT) */
/* -& */
/* $ Index_Entries */
/* extract a substring starting with a keyword */
/* -& */
/* $ Revisions */
/* - Beta Version 1.1.0, 28-FEB-1989 (WLT) */
/* Reference to REMSUB replaced by SHIFTL. */
/* - Beta Version 1.0.1, 10-FEB-1989 (HAN) */
/* Contents of the Exceptions section was changed */
/* to "error free" to reflect the decision that the */
/* module will never participate in error handling. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Locate the keyword within the string. */
positn = wdindx_(string, keywd, string_len, keywd_len);
/* If the keyword wasn't found, set the outputs and head for home. */
if (positn == 0) {
*found = FALSE_;
s_copy(substr, " ", substr_len, (ftnlen)1);
return 0;
} else {
*found = TRUE_;
}
/* Set the begin erase marker to the start of the current word */
/* Set the end erase marker to the end of the current word */
berase = positn;
eerase = positn + nblen_(keywd, keywd_len) - 1;
start = eerase + 1;
/* Find the begin and end of the next word. */
fndnwd_(string, &start, &b, &e, string_len);
/* If there is a next word ( E came back non-zero ) see if its a */
/* terminator. */
if (e != 0) {
delims = isrchc_(string + (b - 1), nterms, terms, e - (b - 1),
terms_len);
}
/* If we found a terminator, or were already at the end of the */
/* string, we are done. Remove the keyword and put a blank in */
/* SUBSTR */
if (e == 0 || delims != 0) {
i__1 = eerase - berase + 1;
shiftl_(string + (berase - 1), &i__1, " ", string + (berase - 1),
string_len - (berase - 1), (ftnlen)1, string_len - (berase -
1));
s_copy(substr, " ", substr_len, (ftnlen)1);
return 0;
}
/* Ok. If we made it this far, we have at least one legitimate word */
/* following the keyword, set the pointer for the start of the */
/* substring (to return) to the beginning of this word. */
begstr = b;
/* Now we just examine each word until we run out of string or we */
/* run into a terminator. */
while(e != 0 && delims == 0) {
endstr = e;
eerase = e;
start = e + 1;
fndnwd_(string, &start, &b, &e, string_len);
if (e != 0) {
delims = isrchc_(string + (b - 1), nterms, terms, e - (b - 1),
terms_len);
}
}
/* That's it, load the substring variable and remove the keyword */
/* and words up to the terminator or end of the string --- whichever */
/* came first. */
s_copy(substr, string + (begstr - 1), substr_len, endstr - (begstr - 1));
i__1 = eerase - berase + 1;
shiftl_(string + (berase - 1), &i__1, " ", string + (berase - 1),
string_len - (berase - 1), (ftnlen)1, string_len - (berase - 1));
return 0;
} /* kxtrct_ */
/* $Procedure ZZPLATFM ( Private --- Get platform attributes ) */
/* Subroutine */ int zzplatfm_(char *key, char *value, ftnlen key_len, ftnlen
value_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
integer index;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
static char keyval[64*6];
char keycpy[64];
static char attcpy[32*7];
/* $ Abstract */
/* Return platform ID and various attributes of the intended */
/* environment */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* KEY I String indicating what information to return. */
/* VALUE O String containing the requested information. */
/* $ Detailed_Input */
/* KEY is a string value that indicates which platform */
/* specific information is desired. Acceptable inputs */
/* are: */
/* 'SYSTEM' - System Identification String */
/* 'O/S' - Operating System or Environment */
/* 'COMPILER' - NAIF Supported Compiler */
/* 'FILE_FORMAT' - Native Binary File Format */
/* 'TEXT_FORMAT' - Native Text File Format */
/* 'READS_BFF' - List of supported binary file */
/* formats. */
/* Note: The comparison is case-insensitive, and the */
/* supplied value must fit into a string buffer */
/* KYSIZE characters in length. */
/* $ Detailed_Output */
/* VALUE is the string that holds the information requested */
/* by the input string KEY. VALUE must be able to */
/* contain the maximum number of characters returned */
/* by this routine, WDSIZE, or truncation will occur. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the KEY is invalid, then VALUE is set to the value */
/* stored in the character string parameter DEFRPY defined */
/* below. */
/* 2) If VALUE is not large enough to contain the requested */
/* KEY's value, then truncation will occur. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine serves to identify the platform and compiler */
/* used in creating SPICELIB. It is provided so that routines */
/* and programs can make run-time decisions based upon the */
/* ambient Fortran environment. */
/* Operating Systems: */
/* This routine is now aware of the operating systems for which */
/* the code is intended for compilation. In some cases this may */
/* be more than one operating system, particularly in the case */
/* of the PC. */
/* Binary File Format: */
/* This routine now adds the capability to return at run time */
/* the binary file architecture that is native to the system. */
/* Text File Format: */
/* This routine now has the capability to return at run time */
/* the mechanism (or line terminator) used to delimit lines */
/* in text files. In most cases it will return common labels */
/* for the special characters FORTRAN considers line break */
/* indicators. */
/* Binary File Formats Read: */
/* This returns a space delimited list of all the binary file */
/* formats this environment can read for DAF/DAS based files. */
/* $ Examples */
/* This routine could be used so that a single routine */
/* could be written that translates the meaning of IOSTAT values */
/* that depend upon the machine and compiler. At run time */
/* the routine could look up the appropriate message to associate */
/* with an IOSTAT value. */
/* $ Restrictions */
/* 1) VALUE must be large enough to contain the requested */
/* information, otherwise truncation will occur. */
/* 2) The string passed in via the KEY input must be capable */
/* of being properly copied into the KEYCPY buffer internal */
/* to this routine. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* F.S. Turner (JPL) */
/* E.D. Wright (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 2.9.0, 16-MAR-2010 (EDW) */
/* Updated for: */
/* - MAC-OSX-64BIT-INTEL_C */
/* - PC-64BIT-MS_C */
/* - SUN-SOLARIS-64BIT-NATIVE_C */
/* MAC-OSX-64BIT-GFORTRAN */
/* MAC-OSX-64BIT-IFORT */
/* PC-LINUX-64BIT-GFORTRAN */
/* PC-WINDOWS-64BIT-IFORT */
/* SUN-SOLARIS-INTEL-64BIT-CC_C */
/* SUN-SOLARIS-INTEL-CC_C */
/* SUN-SOLARIS-INTEL */
/* environments. */
/* - SPICELIB Version 2.8.0, 12-JAN-2009 (EDW) */
/* Added MAC-OSX-GFORTRAN PC-LINUX-GFORTRAN environments. */
/* - SPICELIB Version 2.7.0, 19-FEB-2008 (BVS) */
/* Added PC-LINUX-IFORT environment. */
/* - SPICELIB Version 2.6.0, 15-NOV-2006 (NJB) */
/* Added PC-WINDOWS-IFORT, MAC-OSX-IFORT, and MAC-OSX-INTEL_C */
/* environments. */
/* - SPICELIB Version 2.5.0, 21-FEB-2006 (NJB) */
/* Added PC-LINUX-64BIT-GCC_C environment. */
/* Corrected error in in-line comments: changed keyword */
/* from FILE_ARCH to FILE_FORMAT. */
/* - SPICELIB Version 2.4.0, 14-MAR-2005 (BVS) */
/* Added SUN-SOLARIS-64BIT-GCC_C environment. */
/* - SPICELIB Version 2.3.0, 31-DEC-2004 (BVS) */
/* Added PC CYGWIN environments. Changed OS for PC-LAHEY, */
/* PC-DIGITAL, and PC-MS_C to 'MICROSOFT WINDOWS'. */
/* - SPICELIB Version 2.2.0, 07-JUL-2002 (EDW) */
/* Added Mac OS X Unix environment. */
/* - SPICELIB Version 2.1.0, 06-FEB-2002 (FST) */
/* Updated the 'TEXT_FORMAT' key value for the PC-LINUX_C */
/* environment. Previous versions incorrectly indicated */
/* 'CR-LF' as line terminators. */
/* - SPICELIB Version 2.0.0, 05-JUN-2001 (FST) */
/* Added TEXT_FORMAT and READS_BFF key/value pairs. */
/* Modified the header slightly to improve word choice; */
/* specifically binary file format replaces file */
/* architecture. */
/* Updated the compiler entry for the PC-LINUX */
/* environment to refer to g77 as opposed to f2c. */
/* Updated the compiler entry for the MACPPC environment. */
/* This environment is now officially tied to Absoft */
/* Fortran. */
/* Updated the compiler entry for the PC-LAHEY environment. */
/* The compiler for this environment is LF95, the latest */
/* offering from Lahey. */
/* - SPICELIB Version 1.0.0, 22-FEB-1999 (FST) */
/* -& */
/* $ Index_Entries */
/* fetch platform dependent information */
/* -& */
/* SPICELIB Functions */
/* Local Parameters */
/* Array index parameters for each of the key/value pairs. */
/* SYSTEM Index. */
/* O/S Index. */
/* Compiler Index. */
/* Binary File Format Index. */
/* Text File Format Index */
/* Reads Binary File Format Index. */
/* Size of the buffer in which KEY is placed. */
/* Maximum Size of local string returned in VALUE */
/* Number of Platform Dependent values stored here. */
/* Default Reply in the event of an invalid KEY. */
/* Local Variables */
/* Saved Variables */
/* Data Statements */
/* Make the initial assignments to the saved character array. */
if (first) {
/* Store the keys in the KEYVAL array. */
s_copy(keyval, "SYSTEM", (ftnlen)64, (ftnlen)6);
s_copy(keyval + 64, "O/S", (ftnlen)64, (ftnlen)3);
s_copy(keyval + 128, "COMPILER", (ftnlen)64, (ftnlen)8);
s_copy(keyval + 192, "FILE_FORMAT", (ftnlen)64, (ftnlen)11);
s_copy(keyval + 256, "TEXT_FORMAT", (ftnlen)64, (ftnlen)11);
s_copy(keyval + 320, "READS_BFF", (ftnlen)64, (ftnlen)9);
/* Set the default reply to be the zero'th component of ATTCPY. */
/* This obviates IF-THEN-ELSE branching all together. */
s_copy(attcpy, "<UNAVAILABLE> ", (ftnlen)32, (
ftnlen)32);
/* Platform/Environment specific assignments follow. */
s_copy(attcpy + 32, "PC", (ftnlen)32, (ftnlen)2);
s_copy(attcpy + 64, "LINUX", (ftnlen)32, (ftnlen)5);
s_copy(attcpy + 96, "GCC/64BIT", (ftnlen)32, (ftnlen)9);
s_copy(attcpy + 128, "LTL-IEEE", (ftnlen)32, (ftnlen)8);
s_copy(attcpy + 160, "LF", (ftnlen)32, (ftnlen)2);
s_copy(attcpy + 192, "BIG-IEEE LTL-IEEE", (ftnlen)32, (ftnlen)17);
/* Don't execute these assignments again. */
first = FALSE_;
}
/* Determine which KEY was passed in; do this by converting KEY */
/* to the known member of the equivalence class of possible */
/* values. */
ucase_(key, keycpy, key_len, (ftnlen)64);
ljust_(keycpy, keycpy, (ftnlen)64, (ftnlen)64);
/* Find out which key we were given. In the event that one of the */
/* KEYVALs (or some equivalent string) was not passed in, ISRCHC */
/* returns a value of zero. */
index = isrchc_(keycpy, &c__6, keyval, (ftnlen)64, (ftnlen)64);
s_copy(value, attcpy + (((i__1 = index) < 7 && 0 <= i__1 ? i__1 : s_rnge(
"attcpy", i__1, "zzplatfm_", (ftnlen)413)) << 5), value_len, (
ftnlen)32);
return 0;
} /* zzplatfm_ */
/* $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 ZZEKNRES ( Private: EK, resolve names in encoded query ) */
/* Subroutine */ int zzeknres_(char *query, integer *eqryi, char *eqryc,
logical *error, char *errmsg, integer *errptr, ftnlen query_len,
ftnlen eqryc_len, ftnlen errmsg_len)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
/* 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 */
integer base, ntab, ncnj, ncns, nord, nsel;
extern /* Subroutine */ int zzekcchk_(char *, integer *, char *, integer *
, char *, char *, integer *, logical *, char *, integer *, ftnlen,
ftnlen, ftnlen, ftnlen, ftnlen), zzekqtab_(integer *, char *,
integer *, char *, char *, ftnlen, ftnlen, ftnlen), zzekreqi_(
integer *, char *, integer *, ftnlen), zzekweqi_(char *, integer *
, integer *, ftnlen);
integer i__, j;
char table[64*10], alias[64*10];
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer nload;
extern /* Subroutine */ int repmc_(char *, char *, char *, char *, ftnlen,
ftnlen, ftnlen, ftnlen);
integer cc[10];
extern logical failed_(void);
char ltable[64];
extern /* Subroutine */ int ekntab_(integer *);
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
integer cnstyp, iparse;
extern /* Subroutine */ int setmsg_(char *, ftnlen), sigerr_(char *,
ftnlen), chkout_(char *, ftnlen), ektnam_(integer *, char *,
ftnlen), ekccnt_(char *, integer *, ftnlen);
logical fnd;
integer lxb, lxe;
/* $ Abstract */
/* SPICE Private routine intended solely for the support of SPICE */
/* routines. Users should not call this routine directly due */
/* to the volatile nature of this routine. */
/* Resolve and semantically check table names, aliases, and column */
/* names in an encoded EK query. */
/* $ 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 */
/* EK */
/* $ Keywords */
/* EK */
/* PRIVATE */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include 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 */
/* $ 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 Query Limit Parameters */
/* ekqlimit.inc Version 3 16-NOV-1995 (NJB) */
/* Parameter MAXCON increased to 1000. */
/* ekqlimit.inc Version 2 01-AUG-1995 (NJB) */
/* Updated to support SELECT clause. */
/* ekqlimit.inc Version 1 07-FEB-1995 (NJB) */
/* These limits apply to character string queries input to the */
/* EK scanner. This limits are part of the EK system's user */
/* interface: the values should be advertised in the EK required */
/* reading document. */
/* Maximum length of an input query: MAXQRY. This value is */
/* currently set to twenty-five 80-character lines. */
/* Maximum number of columns that may be listed in the */
/* `order-by clause' of a query: MAXSEL. MAXSEL = 50. */
/* Maximum number of tables that may be listed in the `FROM */
/* clause' of a query: MAXTAB. */
/* Maximum number of relational expressions that may be listed */
/* in the `constraint clause' of a query: MAXCON. */
/* This limit applies to a query when it is represented in */
/* `normalized form': that is, the constraints have been */
/* expressed as a disjunction of conjunctions of relational */
/* expressions. The number of relational expressions in a query */
/* that has been expanded in this fashion may be greater than */
/* the number of relations in the query as orginally written. */
/* For example, the expression */
/* ( ( A LT 1 ) OR ( B GT 2 ) ) */
/* AND */
/* ( ( C NE 3 ) OR ( D EQ 4 ) ) */
/* which contains 4 relational expressions, expands to the */
/* equivalent normalized constraint */
/* ( ( A LT 1 ) AND ( C NE 3 ) ) */
/* OR */
/* ( ( A LT 1 ) AND ( D EQ 4 ) ) */
/* OR */
/* ( ( B GT 2 ) AND ( C NE 3 ) ) */
/* OR */
/* ( ( B GT 2 ) AND ( D EQ 4 ) ) */
/* which contains eight relational expressions. */
/* MXJOIN is the maximum number of tables that can be joined. */
/* MXJCON is the maximum number of join constraints allowed. */
/* Maximum number of order-by columns that may be used in the */
/* `order-by clause' of a query: MAXORD. MAXORD = 10. */
/* Maximum number of tokens in a query: 500. Tokens are reserved */
/* words, column names, parentheses, and values. Literal strings */
/* and time values count as single tokens. */
/* Maximum number of numeric tokens in a query: */
/* Maximum total length of character tokens in a query: */
/* Maximum length of literal string values allowed in queries: */
/* MAXSTR. */
/* End Include Section: EK Query Limit 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 Encoded Query Internal Parameters */
/* ekquery.inc Version 3 16-NOV-1995 (NJB) */
/* Updated to reflect increased value of MAXCON in */
/* ekqlimit.inc. */
/* ekquery.inc Version 2 03-AUG-1995 (NJB) */
/* Updated to support representation of the SELECT clause. */
/* ekquery.inc Version 1 12-JAN-1995 (NJB) */
/* An encoded EK query is an abstract data type implemented */
/* as an integer cell, along with a double precision cell and */
/* a character string. The d.p. cell and string contain numeric */
/* and string values from the query string represented by the */
/* encoded query. */
/* The parameters in this file are intended for use only by the */
/* EK encoded query access routines. Callers of EK routines should */
/* not use these parameters. */
/* The following parameters are indices of specified elements */
/* in the integer portion of the encoded query. */
/* Encoded query architecture type: */
/* `Name resolution' consists of: */
/* - Verifying existence of tables: any table names listed */
/* in the FROM clause of a query must be loaded. */
/* - Validating table aliases used to qualify column names. */
/* - Verifying existence of columns and obtaining data types */
/* for columns. */
/* - Setting data type codes for literal values in the encoded */
/* query. */
/* - Checking consistency of operators and operand data types. */
/* - Making sure unqualified column names are unambiguous. */
/* - For constraints, mapping the table names used to qualify */
/* column names to the ordinal position in the FROM clause */
/* of the corresponding table. */
/* Initialization status---this flag indicates whether the encoded */
/* query has been initialized. Values are ITRUE or IFALSE. See the */
/* include file ekbool.inc for parameter values. */
/* Parse status---this flag indicates whether the parsing operation */
/* that produced an encoded query has been completed. Values are */
/* ITRUE or IFALSE. */
/* Name resolution status---this flag indicates whether names */
/* have been resolved in an encoded query. Values are ITRUE or */
/* IFALSE. */
/* Time resolution status---this flag indicates whether time values */
/* have been resolved in an encoded query. Time resolution */
/* consists of converting strings representing time values to ET. */
/* Values of the status are ITRUE or IFALSE. */
/* Semantic check status---this flag indicates whether semantic */
/* checking of constraints has been performed. */
/* Number of tables specified in FROM clause: */
/* Number of constraints in query: */
/* A special value is used to indicate the `maximal' constraint--- */
/* one that logically cannot be satisfied. If the constraints */
/* are equivalent to the maximal constraint, the location EQNCNS */
/* is assigned the value EQMXML */
/* Number of constraint conjunctions: */
/* Number of order-by columns: */
/* Number of SELECT columns: */
/* Size of double precision buffer: */
/* `Free' pointer into double precision buffer: */
/* Size of character string buffer: */
/* `Free' pointer into character string buffer: */
/* The following four base pointers will be valid after a query */
/* has been parsed: */
/* Base pointer for SELECT column descriptors: */
/* Base pointer for constraint descriptors: */
/* Base pointer for conjunction sizes: */
/* Base pointer for order-by column descriptors: */
/* After the quantities named above, the integer array contains */
/* series of descriptors for tables, constraints, and order-by */
/* columns, as well as a list of `conjunction sizes'---that is, */
/* the sizes of the groups of constraints that form conjunctions, */
/* after the input query has been re-arranged as a disjunction of */
/* conjunctions of constraints. */
/* The offsets of specific elements within descriptors are */
/* parameterized. The base addresses of the descriptors themselves */
/* must be calculated using the counts and sizes of the items */
/* preceding them. */
/* A diagram of the structure of the variable-size portion of the */
/* integer array is shown below: */
/* +-------------------------------------+ */
/* | Fixed-size portion of encoded query | */
/* +-------------------------------------+ */
/* | Encoded FROM clause | */
/* +-------------------------------------+ */
/* | Encoded constraint clause | */
/* +-------------------------------------+ */
/* | Conjunction sizes | */
/* +-------------------------------------+ */
/* | Encoded ORDER BY clause | */
/* +-------------------------------------+ */
/* | Encoded SELECT clause | */
/* +-------------------------------------+ */
/* Value Descriptors */
/* ---------------- */
/* In order to discuss the various descriptors below, we'll make use */
/* of sub-structures called `value descriptors'. These descriptors */
/* come in two flavors: character and double precision. For */
/* strings, a descriptor is a set of begin and end pointers that */
/* indicate the location of the string in the character portion of an */
/* encoded query, along with the begin and end pointers for the */
/* corresponding lexeme in the original query. The pointers are set */
/* to zero when they are not in use, for example if they refer to an */
/* optional lexeme that did not appear in the input query. */
/* All value descriptors start with a data type indicator; values */
/* are from ektype.inc. Integer and time values are referred to */
/* by double precision descriptors. */
/* Parameters for string value descriptor elements: */
/* Numeric value descriptors are similar to those for string values, */
/* the difference being that they have only one pointer to the value */
/* they represent. This pointer is the index of the value in the */
/* encoded query's numeric buffer. */
/* All value descriptors have the same size. In order to allow */
/* table descriptors to have the same size as value descriptors, */
/* we include an extra element in the descriptor. */
/* Column Descriptors */
/* ----------------- */
/* Each column descriptor consists of a character descriptor for the */
/* name of the column, followed by an index, which gives the ordinal */
/* position of the column in the logical table to which the column */
/* belongs. The index element is filled in during name resolution. */
/* Table Descriptors */
/* ----------------- */
/* Each table descriptor consists of a character descriptor for the */
/* name of the table, followed by an index, which gives the ordinal */
/* position of the table in the FROM clause in the original query. */
/* The index element is filled in during name resolution. Aliases */
/* and table names have identical descriptor structures. */
/* Constraint descriptors */
/* ------------------ */
/* Each constraint is characterized by: */
/* - A code indicating whether the constraint compares values */
/* in two columns or the value in a column and a literal */
/* value. The values of this element are EQCOL and EQVAL. */
/* - A descriptor for the table used to qualify the */
/* column name on the left side of the constraint. */
/* - A character value descriptor for the column name on the left */
/* side of the query. */
/* - An operator code indicating the relational operator used */
/* in the constraint. */
/* If the constraint compares values from two columns, the */
/* next items are table and column name descriptors that apply to */
/* the column named on the right side of the relational operator. */
/* If the constraint has a literal value on the right side, the */
/* operator code is followed by... */
/* - a value descriptor. */
/* - Size of a constraint descriptor: */
/* Conjunction sizes */
/* ----------------- */
/* The size of each conjunction of constraints occupies a single */
/* integer. */
/* Order-by Column Descriptors */
/* --------------------------- */
/* Each order-by column descriptor contains descriptors for */
/* the table containing the column and for the name of the column */
/* itself; one additional element is used to indicate the direction */
/* of the ordering (ascending vs descending). */
/* - The last integer in the descriptor indicates whether the */
/* order direction is ascending or descending. */
/* - Size of an order-by column descriptor: */
/* Codes indicating sense of ordering (ascending vs descending): */
/* SELECT Column Descriptors */
/* --------------------------- */
/* Each SELECT column descriptor contains descriptors for */
/* the table containing the column and for the name of the column */
/* itself. */
/* - Size of a SELECT column descriptor: */
/* Miscellaneous parameters: */
/* EQIMIN is the minimum size of the integer portion of */
/* an encoded query. EQIMIN depends on the parameters */
/* MAXTAB */
/* MAXCON */
/* MAXORD */
/* MAXSEL */
/* all of which are declared in the include file ekqlimit.inc. */
/* The functional definition of EQIMIN is: */
/* INTEGER EQIMIN */
/* PARAMETER ( EQIMIN = EQVBAS */
/* . + MAXTAB * EQVDSZ * 2 */
/* . + MAXCON * EQCDSZ */
/* . + MAXCON */
/* . + MAXORD * EQODSZ */
/* . + MAXSEL * EQSDSZ ) */
/* End Include Section: EK Encoded Query Internal 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 Table Name Size */
/* ektnamsz.inc Version 1 17-JAN-1995 (NJB) */
/* Size of table name, in characters. */
/* End Include Section: EK Table Name Size */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* EQRYI I-O Integer component of query. */
/* EQRYC I-O Character component of query. */
/* ERROR O Error flag. */
/* ERRMSG O Error message. */
/* ERRPTR O Position in query where error was detected. */
/* $ Detailed_Input */
/* QUERY is the original query from which EQRYI and EQRYC */
/* were obtained. QUERY is used only for */
/* construction of error messages. */
/* EQRYI is the integer portion of an encoded EK query. */
/* The query must have been parsed. */
/* EQRYC is the character portion of an encoded EK query. */
/* $ Detailed_Output */
/* EQRYI is the integer portion of an encoded EK query. */
/* On output, all names have been resolved, and */
/* table names, aliases, and column names have */
/* been semantically checked. */
/* EQRYC is the character portion of an encoded EK query. */
/* ERROR is a logical flag indicating whether an error was */
/* detected. The error could be a name resolution */
/* error or a semantic error. */
/* ERRMSG is an error message describing an error in the */
/* input query, if one was detected. If ERROR is */
/* returned .FALSE., then ERRPTR is undefined. */
/* ERRPTR is the character position in the original query */
/* at which an error was detected, if an error was */
/* found. This index refers to the offending lexeme's */
/* position in the original query represented by the */
/* input encoded query. If ERROR is returned .FALSE., */
/* ERRPTR is undefined. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the input query is not initialized, the error will be */
/* diagnosed by routines called by this routine. The outputs */
/* will not be modified. */
/* 2) If the input query has not been parsed, the error */
/* SPICE(QUERYNOTPARSED) will be signalled. The outputs */
/* will not be modified. */
/* 3) If any sort of name resolution error or semantic error is */
/* detected in the input query, the output flag ERROR is set, */
/* and an error message is returned. The checks performed by */
/* this routine are listed below: */
/* - All tables named in the FROM clause must be loaded */
/* in the EK system. */
/* - All aliases in the FROM clause must be distinct. */
/* - No alias may be the name of a table in the FROM clause, */
/* unless it is identical to the name of the table it is */
/* associated with. */
/* - No column name may be qualified with a name that is not */
/* the name or alias of a table in the FROM clause. */
/* - Each qualified column must be present in the table */
/* indicated by its qualifying name. */
/* - Each unqualified column name must be the name of a */
/* column present in exactly one of the tables listed in the */
/* FROM clause. */
/* $ Files */
/* None. */
/* $ Particulars */
/* Resolution of table names involves finding each table's ordinal */
/* position in the FROM clause, and setting the table's descriptor */
/* to record that position. The same is done for column descriptors. */
/* $ Examples */
/* See EKFIND. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - Beta Version 1.0.0, 17-OCT-1995 (NJB) */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* No error to start with. */
*error = FALSE_;
s_copy(errmsg, " ", errmsg_len, (ftnlen)1);
*errptr = 0;
/* The query must have been parsed at this point, or it's no go. */
zzekreqi_(eqryi, "PARSED", &iparse, (ftnlen)6);
if (failed_()) {
return 0;
}
if (iparse == -1) {
chkin_("ZZEKNRES", (ftnlen)8);
setmsg_("Encoded query has not been parsed.", (ftnlen)34);
sigerr_("SPICE(QUERYNOTPARSED)", (ftnlen)21);
chkout_("ZZEKNRES", (ftnlen)8);
return 0;
}
/* Get the important counts from the query. */
zzekreqi_(eqryi, "NUM_TABLES", &ntab, (ftnlen)10);
zzekreqi_(eqryi, "NUM_CONSTRAINTS", &ncns, (ftnlen)15);
zzekreqi_(eqryi, "NUM_CONJUNCTIONS", &ncnj, (ftnlen)16);
zzekreqi_(eqryi, "NUM_ORDERBY_COLS", &nord, (ftnlen)16);
zzekreqi_(eqryi, "NUM_SELECT_COLS", &nsel, (ftnlen)15);
/* Start out by fetching the table names and their aliases. */
i__1 = ntab;
for (i__ = 1; i__ <= i__1; ++i__) {
zzekqtab_(eqryi, eqryc, &i__, table + (((i__2 = i__ - 1) < 10 && 0 <=
i__2 ? i__2 : s_rnge("table", i__2, "zzeknres_", (ftnlen)254))
<< 6), alias + (((i__3 = i__ - 1) < 10 && 0 <= i__3 ? i__3 :
s_rnge("alias", i__3, "zzeknres_", (ftnlen)254)) << 6),
eqryc_len, (ftnlen)64, (ftnlen)64);
}
/* Make sure that the aliases are distinct. Rather than sorting */
/* them, we'll check them in left-to-right order. */
i__1 = ntab - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = ntab;
for (j = i__ + 1; j <= i__2; ++j) {
if (s_cmp(alias + (((i__3 = i__ - 1) < 10 && 0 <= i__3 ? i__3 :
s_rnge("alias", i__3, "zzeknres_", (ftnlen)265)) << 6),
alias + (((i__4 = j - 1) < 10 && 0 <= i__4 ? i__4 :
s_rnge("alias", i__4, "zzeknres_", (ftnlen)265)) << 6), (
ftnlen)64, (ftnlen)64) == 0 && s_cmp(alias + (((i__5 =
i__ - 1) < 10 && 0 <= i__5 ? i__5 : s_rnge("alias", i__5,
"zzeknres_", (ftnlen)265)) << 6), " ", (ftnlen)64, (
ftnlen)1) != 0) {
*error = TRUE_;
s_copy(errmsg, "Non-distinct alias <#> was found.",
errmsg_len, (ftnlen)33);
base = ((j - 1 << 1) + 1) * 6 + 19;
lxb = eqryi[base + 7];
lxe = eqryi[base + 8];
repmc_(errmsg, "#", query + (lxb - 1), errmsg, errmsg_len, (
ftnlen)1, lxe - (lxb - 1), errmsg_len);
*errptr = lxb;
return 0;
}
/* We've checked the Jth alias for a match. */
}
}
/* Make sure that no alias matches a table name other than that of */
/* the table it corresponds to. */
i__1 = ntab;
for (i__ = 1; i__ <= i__1; ++i__) {
j = isrchc_(alias + (((i__2 = i__ - 1) < 10 && 0 <= i__2 ? i__2 :
s_rnge("alias", i__2, "zzeknres_", (ftnlen)295)) << 6), &ntab,
table, (ftnlen)64, (ftnlen)64);
if (j != 0) {
if (j != i__) {
*error = TRUE_;
s_copy(errmsg, "Alias <#> conflicts with table name.",
errmsg_len, (ftnlen)36);
base = ((i__ - 1 << 1) + 1) * 6 + 19;
lxb = eqryi[base + 7];
lxe = eqryi[base + 8];
repmc_(errmsg, "#", query + (lxb - 1), errmsg, errmsg_len, (
ftnlen)1, lxe - (lxb - 1), errmsg_len);
*errptr = lxb;
return 0;
}
}
}
/* Make sure that all of the tables are loaded in the EK system. */
ekntab_(&nload);
i__1 = ntab;
for (i__ = 1; i__ <= i__1; ++i__) {
fnd = FALSE_;
j = 1;
while(j <= nload && ! fnd) {
ektnam_(&j, ltable, (ftnlen)64);
if (s_cmp(table + (((i__2 = i__ - 1) < 10 && 0 <= i__2 ? i__2 :
s_rnge("table", i__2, "zzeknres_", (ftnlen)336)) << 6),
ltable, (ftnlen)64, (ftnlen)64) == 0) {
/* When we find a loaded table, save the column count for */
/* that table. */
fnd = TRUE_;
ekccnt_(table, &cc[(i__2 = i__ - 1) < 10 && 0 <= i__2 ? i__2 :
s_rnge("cc", i__2, "zzeknres_", (ftnlen)342)], (
ftnlen)64);
} else {
++j;
}
}
if (! fnd) {
*error = TRUE_;
s_copy(errmsg, "Table <#> is not currently loaded.", errmsg_len, (
ftnlen)34);
/* In order to set the error pointer, we'll need the */
/* lexeme begin value for the offending table. */
base = (i__ - 1) * 12 + 19;
lxb = eqryi[base + 7];
lxe = eqryi[base + 8];
repmc_(errmsg, "#", query + (lxb - 1), errmsg, errmsg_len, (
ftnlen)1, lxe - (lxb - 1), errmsg_len);
*errptr = lxb;
return 0;
}
}
/* At this point, the tables and aliases are deemed correct. For */
/* safety, fill in each table and alias descriptor with its */
/* ordinal position. */
i__1 = ntab;
for (i__ = 1; i__ <= i__1; ++i__) {
base = (i__ - 1) * 12 + 19;
eqryi[base + 11] = i__;
eqryi[base + 17] = i__;
}
/* Check the column names used in the constraints. */
i__1 = ncns;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Calculate the base address of the constraint. */
base = ntab * 12 + 19 + (i__ - 1) * 26;
/* Obtain the constraint type. */
cnstyp = eqryi[base + 6];
/* Check the column and table on the LHS of the constraint. */
i__2 = base + 1;
zzekcchk_(query, eqryi, eqryc, &ntab, table, alias, &i__2, error,
errmsg, errptr, query_len, eqryc_len, (ftnlen)64, (ftnlen)64,
errmsg_len);
if (*error) {
return 0;
}
if (cnstyp == 1) {
/* Check the column and table on the RHS of the constraint. */
i__2 = base + 14;
zzekcchk_(query, eqryi, eqryc, &ntab, table, alias, &i__2, error,
errmsg, errptr, query_len, eqryc_len, (ftnlen)64, (ftnlen)
64, errmsg_len);
if (*error) {
return 0;
}
}
}
/* Do the same checks and assignments for the SELECT columns. */
i__1 = nsel;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Calculate the base address of the SELECT column descriptor. */
base = ntab * 12 + 19 + ncnj + ncns * 26 + nord * 13 + (i__ - 1) * 12;
zzekcchk_(query, eqryi, eqryc, &ntab, table, alias, &base, error,
errmsg, errptr, query_len, eqryc_len, (ftnlen)64, (ftnlen)64,
errmsg_len);
if (*error) {
return 0;
}
}
/* Do the same checks and assignments for the order-by columns. */
i__1 = nord;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Calculate the base address of the order-by column descriptor. */
base = ntab * 12 + 19 + ncnj + ncns * 26 + (i__ - 1) * 13;
zzekcchk_(query, eqryi, eqryc, &ntab, table, alias, &base, error,
errmsg, errptr, query_len, eqryc_len, (ftnlen)64, (ftnlen)64,
errmsg_len);
if (*error) {
return 0;
}
}
/* Indicate completion of name resolution. */
zzekweqi_("NAMES_RESOLVED", &c__1, eqryi, (ftnlen)14);
return 0;
} /* zzeknres_ */
/* Subroutine */ int kerman_0_(int n__, char *commnd, char *infile__, char *
error, ftnlen commnd_len, ftnlen infile_len, ftnlen error_len)
{
/* Initialized data */
static integer nfiles = 0;
static logical first = TRUE_;
static char synval[80*9] = " "
" " " "
" " " "
" "
" " " "
" " " "
" " " "
" "
" " "EK #word[ekfile] "
" " "LEAPSECONDS #word[leapfile] "
" " "SCLK KERNEL #word[sc"
"lkfile] ";
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Local variables */
static integer need;
static char file[127], name__[32];
static integer clen;
extern logical have_(char *, ftnlen);
static integer left, reqd, nseg;
static char indx[4], pval[32*4];
static integer hits;
static char size[32], type__[32];
static logical quit;
extern /* Subroutine */ int zzeksinf_(integer *, integer *, char *,
integer *, char *, integer *, ftnlen, ftnlen);
static integer i__, j, k;
extern integer cardc_(char *, ftnlen);
static integer l, n;
extern /* Subroutine */ int clgai_(integer *, char *, integer *, integer *
, ftnlen), clgac_(integer *, char *, char *, ftnlen, ftnlen);
static integer r__;
static char cname[80], break__[80];
static integer headr[5];
extern /* Subroutine */ int eklef_(char *, integer *, ftnlen), clnid_(
integer *, integer *, logical *);
static integer space;
extern logical match_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int chkin_(char *, ftnlen);
static integer tcode, ncomc;
extern /* Subroutine */ int ekuef_(integer *);
static char rname[6], tname[32];
extern /* Subroutine */ int repmc_(char *, char *, char *, char *, ftnlen,
ftnlen, ftnlen, ftnlen), clnew_(char *, integer *, integer *,
integer *, integer *, integer *, logical *, logical *, integer *,
ftnlen);
static logical found;
static integer csize, ncols, ncomr;
static logical cnull;
static integer right, width[5], ctype;
extern integer ltrim_(char *, ftnlen);
static integer count;
extern integer rtrim_(char *, ftnlen);
static integer sizes[5];
static char style[80];
extern /* Subroutine */ int clnum_(integer *);
static logical justr[5];
extern /* Subroutine */ int m2chck_(char *, char *, integer *, char *,
char *, ftnlen, ftnlen, ftnlen, ftnlen), m2getc_(char *, char *,
logical *, char *, ftnlen, ftnlen, ftnlen), m2ints_(integer *,
char *, integer *, char *, ftnlen, ftnlen);
static integer id, nb;
static char bs[1];
extern logical m2xist_(char *, ftnlen);
static integer nh, sb, handle;
static char ifname[60], tabnam[64], tabcol[80*506], rnamec[7], cnames[64*
100];
static integer handls[20], segdsc[24];
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen),
eknseg_(integer *);
extern /* Subroutine */ int gcolmn_();
extern integer isrchi_(integer *, integer *, integer *);
extern /* Subroutine */ int pagput_(char *, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int nspwln_(char *, ftnlen);
static char synkey[32*9];
static integer synptr[9];
static char ekfils[127*20], thisfl[127], messge[300], idword[8];
static integer cdscrs[1100] /* was [11][100] */, widest, totalc, nresvr,
nresvc;
static logical cindxd;
static char spcial[4*5], lsttab[32];
static integer colids[506], lmarge, ordvec[500];
static logical presrv[5];
extern /* Subroutine */ int replch_(char *, char *, char *, char *,
ftnlen, ftnlen, ftnlen, ftnlen), prefix_(char *, integer *, char *
, ftnlen, ftnlen), chkout_(char *, ftnlen), expool_(char *,
logical *, ftnlen), repmct_(char *, char *, integer *, char *,
char *, ftnlen, ftnlen, ftnlen, ftnlen), clunld_(integer *),
ldpool_(char *, ftnlen);
static integer nid;
extern /* Subroutine */ int dasfnh_(char *, integer *, ftnlen);
static integer col, seg, ids[5];
extern /* Subroutine */ int remlac_(integer *, integer *, char *, integer
*, ftnlen), nspglr_(integer *, integer *), nspmrg_(char *, ftnlen)
, suffix_(char *, integer *, char *, ftnlen, ftnlen), pagrst_(
void), pagset_(char *, integer *, ftnlen), ssizec_(integer *,
char *, ftnlen), ssizei_(integer *, integer *), appndc_(char *,
char *, ftnlen, ftnlen), appndi_(integer *, integer *), pagscn_(
char *, ftnlen), scolmn_(integer *, integer *, char *, ftnlen),
tabrpt_(integer *, integer *, integer *, integer *, logical *,
logical *, char *, integer *, integer *, U_fp, ftnlen), orderc_(
char *, integer *, integer *, ftnlen);
extern integer pos_(char *, char *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int pagsft_(void), dasrfr_(integer *, char *,
char *, integer *, integer *, integer *, integer *, ftnlen,
ftnlen), nspshc_(integer *, logical *), bbputc_1__(char *, char *,
integer *, char *, ftnlen, ftnlen, ftnlen), nicepr_1__(char *,
char *, S_fp, ftnlen, ftnlen);
/* Version 2.4.0, 26-SEP-2005 */
/* Minor bug fix: replaced FILE with INFILE in the RTRIM call */
/* constructing "The file # is not listed ..." error message. */
/* Version 2.3.0, 21-JUN-1999 */
/* Added RETURN before first entry points. */
/* Version 2.2.0, 22-APR-1997 */
/* Declared PAGPUT external */
/* Version 2.1.0 14-SEP-1995 */
/* Variable INDEX removed. */
/* Version 2.0.0 23-AUG-1995 */
/* The widest string in a string column is no longer supplied */
/* by the EK summary stuff. We just set the value WIDEST */
/* to 24. */
/* This routine handles the loading of E-kernels, leapsecond and */
/* SCLK kernels. */
/* Passable routines */
/* Parameters that contain the routine name for use in check-in, */
/* check-out, and error messages. */
/* SPICELIB functions */
/* E-kernel functions */
/* Meta/2 Functions */
/* Interface to the SPICELIB error handling. */
/* Ek include files. */
/* +============================================================== */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Column Descriptor Parameters */
/* ekcoldsc.inc Version 6 23-AUG-1995 (NJB) */
/* Note: The column descriptor size parameter CDSCSZ is */
/* declared separately in the include section CDSIZE$INC.FOR. */
/* Offset of column descriptors, relative to start of segment */
/* integer address range. This number, when added to the last */
/* integer address preceding the segment, yields the DAS integer */
/* base address of the first column descriptor. Currently, this */
/* offset is exactly the size of a segment descriptor. The */
/* parameter SDSCSZ, which defines the size of a segment descriptor, */
/* is declared in the include file eksegdsc.inc. */
/* Size of column descriptor */
/* Indices of various pieces of column descriptors: */
/* CLSIDX is the index of the column's class code. (We use the */
/* word `class' to distinguish this item from the column's data */
/* type.) */
/* TYPIDX is the index of the column's data type code (CHR, INT, DP, */
/* or TIME). The type is actually implied by the class, but it */
/* will frequently be convenient to look up the type directly. */
/* LENIDX is the index of the column's string length value, if the */
/* column has character type. A value of IFALSE in this element of */
/* the descriptor indicates that the strings have variable length. */
/* SIZIDX is the index of the column's element size value. This */
/* descriptor element is meaningful for columns with fixed-size */
/* entries. For variable-sized columns, this value is IFALSE. */
/* NAMIDX is the index of the base address of the column's name. */
/* IXTIDX is the data type of the column's index. IXTIDX */
/* contains a type value only if the column is indexed. For columns */
/* that are not indexed, the location IXTIDX contains the boolean */
/* value IFALSE. */
/* IXPIDX is a pointer to the column's index. IXTPDX contains a */
/* meaningful value only if the column is indexed. The */
/* interpretation of the pointer depends on the data type of the */
/* index. */
/* NFLIDX is the index of a flag indicating whether nulls are */
/* permitted in the column. The value at location NFLIDX is */
/* ITRUE if nulls are permitted and IFALSE otherwise. */
/* ORDIDX is the index of the column's ordinal position in the */
/* list of columns belonging to the column's parent segment. */
/* METIDX is the index of the column's integer metadata pointer. */
/* This pointer is a DAS integer address. */
/* The last position in the column descriptor is reserved. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Column Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Segment Descriptor Parameters */
/* eksegdsc.inc Version 8 06-NOV-1995 (NJB) */
/* All `base addresses' referred to below are the addresses */
/* *preceding* the item the base applies to. This convention */
/* enables simplied address calculations in many cases. */
/* Size of segment descriptor. Note: the include file ekcoldsc.inc */
/* must be updated if this parameter is changed. The parameter */
/* CDOFF in that file should be kept equal to SDSCSZ. */
/* Index of the segment type code: */
/* Index of the segment's number. This number is the segment's */
/* index in the list of segments contained in the EK to which */
/* the segment belongs. */
/* Index of the DAS integer base address of the segment's integer */
/* meta-data: */
/* Index of the DAS character base address of the table name: */
/* Index of the segment's column count: */
/* Index of the segment's record count: */
/* Index of the root page number of the record tree: */
/* Index of the root page number of the character data page tree: */
/* Index of the root page number of the double precision data page */
/* tree: */
/* Index of the root page number of the integer data page tree: */
/* Index of the `modified' flag: */
/* Index of the `initialized' flag: */
/* Index of the shadowing flag: */
/* Index of the companion file handle: */
/* Index of the companion segment number: */
/* The next three items are, respectively, the page numbers of the */
/* last character, d.p., and integer data pages allocated by the */
/* segment: */
/* The next three items are, respectively, the page-relative */
/* indices of the last DAS word in use in the segment's */
/* last character, d.p., and integer data pages: */
/* Index of the DAS character base address of the column name list: */
/* The last descriptor element is reserved for future use. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Segment Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Boolean Enumerated Type */
/* ekbool.inc Version 1 21-DEC-1994 (NJB) */
/* Within the EK system, boolean values sometimes must be */
/* represented by integer or character codes. The codes and their */
/* meanings are listed below. */
/* Integer code indicating `true': */
/* Integer code indicating `false': */
/* Character code indicating `true': */
/* Character code indicating `false': */
/* End Include Section: EK Boolean Enumerated Type */
/* +============================================================== */
/* Meta/2 syntax definition variables. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Data Types */
/* ektype.inc Version 1 27-DEC-1994 (NJB) */
/* Within the EK system, data types of EK column contents are */
/* represented by integer codes. The codes and their meanings */
/* are listed below. */
/* Integer codes are also used within the DAS system to indicate */
/* data types; the EK system makes no assumptions about compatibility */
/* between the codes used here and those used in the DAS system. */
/* Character type: */
/* Double precision type: */
/* Integer type: */
/* `Time' type: */
/* Within the EK system, time values are represented as ephemeris */
/* seconds past J2000 (TDB), and double precision numbers are used */
/* to store these values. However, since time values require special */
/* treatment both on input and output, and since the `TIME' column */
/* has a special role in the EK specification and code, time values */
/* are identified as a type distinct from double precision numbers. */
/* End Include Section: EK Data Types */
/* E-kernel column type definitions */
/* INTEGER CH */
/* PARAMETER ( CH = 1 ) */
/* INTEGER DP */
/* PARAMETER ( DP = 2 ) */
/* INTEGER INT */
/* PARAMETER ( INT = 3 ) */
/* INTEGER TIME */
/* PARAMETER ( TIME = 4 ) */
/* Local Parameters */
/* FILSIZ is the maximum number of characters allowed for a */
/* filename */
/* LNGSIZ is the maximum number of characters allowed for */
/* use in reporting the columns associated with a given */
/* file. */
/* MAXFIL is the maximum number of E-kernels that can be loaded */
/* at any one time. */
/* NNAMES is the maximum number of names/headings that can appear */
/* in a report of loaded files and columns. */
/* MAXCOL is the maximum number of columns that may be present */
/* in any segment of an E-kernel */
/* LNSIZE is the standard text line length. */
/* Initialization logical */
/* Loaded file database (shared between entry points) */
/* Local Variables */
/* INTEGER IFALSE */
/* PARAMETER ( IFALSE = -1 ) */
/* Variables needed by NSPEKS */
/* Save everything. */
/* Initial Values */
/* Parameter adjustments */
if (error) {
}
/* Function Body */
switch(n__) {
case 1: goto L_nspld;
case 2: goto L_nspuld;
case 3: goto L_nspeks;
case 4: goto L_nspekc;
}
return 0;
/* Load an E-, leapsecond, or sclk kernel. */
L_nspld:
/* Standard Spicelib error handling. */
s_copy(rname, "NSPLD", (ftnlen)6, (ftnlen)5);
s_copy(rnamec, "NSPLD:", (ftnlen)7, (ftnlen)6);
if (return_()) {
return 0;
}
chkin_(rname, (ftnlen)6);
/* On the first pass establish the syntax that this routine */
/* is responsible for recognizing. */
if (first) {
first = FALSE_;
*(unsigned char *)bs = '@';
for (i__ = 1; i__ <= 100; ++i__) {
s_copy(cnames + (((i__1 = i__ - 1) < 100 && 0 <= i__1 ? i__1 :
s_rnge("cnames", i__1, "kerman_", (ftnlen)361)) << 6),
" ", (ftnlen)64, (ftnlen)1);
}
for (i__ = 1; i__ <= 3; ++i__) {
replch_(synval + ((i__1 = i__ + 5) < 9 && 0 <= i__1 ? i__1 :
s_rnge("synval", i__1, "kerman_", (ftnlen)366)) * 80,
"#", bs, synval + ((i__2 = i__ + 5) < 9 && 0 <= i__2 ?
i__2 : s_rnge("synval", i__2, "kerman_", (ftnlen)366)) *
80, (ftnlen)80, (ftnlen)1, (ftnlen)1, (ftnlen)80);
}
m2ints_(&c__3, synkey, synptr, synval, (ftnlen)32, (ftnlen)80);
}
/* See if this command matches a known syntax. If it doesn't */
/* there is no point in hanging around. */
m2chck_(commnd, synkey, synptr, synval, error, commnd_len, (ftnlen)32, (
ftnlen)80, error_len);
if (have_(error, error_len)) {
prefix_(rnamec, &c__1, error, (ftnlen)7, error_len);
chkout_(rname, (ftnlen)6);
return 0;
}
if (m2xist_("ekfile", (ftnlen)6)) {
/* We need to have a leapseconds kernel loaded before */
/* we can load an E-kernel. */
expool_("DELTET/DELTA_AT", &found, (ftnlen)15);
if (! found) {
s_copy(error, "Before an E-kernel can be loaded, you must load a"
" leapseconds kernel. ", error_len, (ftnlen)71);
chkout_(rname, (ftnlen)6);
return 0;
}
m2getc_("ekfile", commnd, &found, file, (ftnlen)6, commnd_len, (
ftnlen)127);
/* See if we already have this file. */
if (isrchc_(file, &nfiles, ekfils, (ftnlen)127, (ftnlen)127) > 0) {
chkout_(rname, (ftnlen)6);
return 0;
}
/* Make sure there is room for this file. */
if (nfiles == 20) {
s_copy(error, "The maximum number of E-kernels that can loaded a"
"t open by INSPEKT at one time is #. That number has alr"
"eady been reached. You will need to unload one of the fi"
"les that have already been loaded before you will be abl"
"e to load any other files. ", error_len, (ftnlen)244);
repmct_(error, "#", &c__20, "L", error, error_len, (ftnlen)1, (
ftnlen)1, error_len);
prefix_(rnamec, &c__1, error, (ftnlen)7, error_len);
chkout_(rname, (ftnlen)6);
return 0;
}
/* Load the file as an e-kernel. */
eklef_(file, &handle, rtrim_(file, (ftnlen)127));
if (have_(error, error_len)) {
prefix_(rnamec, &c__1, error, (ftnlen)7, error_len);
chkout_(rname, (ftnlen)6);
return 0;
}
/* Store the name of this file. */
++nfiles;
s_copy(ekfils + ((i__1 = nfiles - 1) < 20 && 0 <= i__1 ? i__1 :
s_rnge("ekfils", i__1, "kerman_", (ftnlen)442)) * 127, file, (
ftnlen)127, (ftnlen)127);
/* Determine how many segments are in the file we just loaded. */
nseg = eknseg_(&handle);
/* For each segment in the newly loaded file ... */
i__1 = nseg;
for (seg = 1; seg <= i__1; ++seg) {
s_copy(tabnam, " ", (ftnlen)64, (ftnlen)1);
for (i__ = 1; i__ <= 100; ++i__) {
s_copy(cnames + (((i__2 = i__ - 1) < 100 && 0 <= i__2 ? i__2 :
s_rnge("cnames", i__2, "kerman_", (ftnlen)457)) << 6)
, " ", (ftnlen)64, (ftnlen)1);
}
zzeksinf_(&handle, &seg, tabnam, segdsc, cnames, cdscrs, (ftnlen)
64, (ftnlen)64);
/* Add each column name to the list of columns held by the */
/* column manager. */
ncols = segdsc[4];
i__2 = ncols;
for (col = 1; col <= i__2; ++col) {
/* We need to make the column name include table it */
/* belongs to (a fully qualified column name). */
prefix_(".", &c__0, cnames + (((i__3 = col - 1) < 100 && 0 <=
i__3 ? i__3 : s_rnge("cnames", i__3, "kerman_", (
ftnlen)475)) << 6), (ftnlen)1, (ftnlen)64);
prefix_(tabnam, &c__0, cnames + (((i__3 = col - 1) < 100 && 0
<= i__3 ? i__3 : s_rnge("cnames", i__3, "kerman_", (
ftnlen)476)) << 6), (ftnlen)64, (ftnlen)64);
cindxd = cdscrs[(i__3 = col * 11 - 6) < 1100 && 0 <= i__3 ?
i__3 : s_rnge("cdscrs", i__3, "kerman_", (ftnlen)478)]
!= -1;
cnull = cdscrs[(i__3 = col * 11 - 4) < 1100 && 0 <= i__3 ?
i__3 : s_rnge("cdscrs", i__3, "kerman_", (ftnlen)479)]
!= -1;
ctype = cdscrs[(i__3 = col * 11 - 10) < 1100 && 0 <= i__3 ?
i__3 : s_rnge("cdscrs", i__3, "kerman_", (ftnlen)481)]
;
clen = cdscrs[(i__3 = col * 11 - 9) < 1100 && 0 <= i__3 ?
i__3 : s_rnge("cdscrs", i__3, "kerman_", (ftnlen)482)]
;
csize = cdscrs[(i__3 = col * 11 - 8) < 1100 && 0 <= i__3 ?
i__3 : s_rnge("cdscrs", i__3, "kerman_", (ftnlen)483)]
;
/* This is what used to be here, but the item NBLIDX */
/* vanished by design. We now just set this so something */
/* reasonable. 24 seemed like the reasonable thing at */
/* the time. (See the column manager and do a bit of */
/* code diving to see what this is used for.) */
/* WIDEST = CDSCRS ( NBLIDX, COL ) */
widest = 24;
clnew_(cnames + (((i__3 = col - 1) < 100 && 0 <= i__3 ? i__3 :
s_rnge("cnames", i__3, "kerman_", (ftnlen)496)) << 6)
, &handle, &ctype, &clen, &widest, &csize, &cindxd, &
cnull, &id, (ftnlen)64);
}
}
/* If anything went wrong, unload the file. */
if (have_(error, error_len)) {
prefix_(rnamec, &c__1, error, (ftnlen)7, error_len);
ekuef_(&handle);
clunld_(&handle);
--nfiles;
chkout_(rname, (ftnlen)6);
return 0;
}
} else if (m2xist_("leapfile", (ftnlen)8)) {
m2getc_("leapfile", commnd, &found, file, (ftnlen)8, commnd_len, (
ftnlen)127);
ldpool_(file, (ftnlen)127);
bbputc_1__("POST", "LEAPSECONDS", &c__1, file, (ftnlen)4, (ftnlen)11,
(ftnlen)127);
} else if (m2xist_("sclkfile", (ftnlen)8)) {
m2getc_("sclkfile", commnd, &found, file, (ftnlen)8, commnd_len, (
ftnlen)127);
ldpool_(file, (ftnlen)127);
bbputc_1__("APPEND", "SCLK", &c__1, file, (ftnlen)6, (ftnlen)4, (
ftnlen)127);
} else {
s_copy(error, "The input command was unrecognized and somehow got to"
" an \"impossible\" place in KERMAN.FOR", error_len, (ftnlen)
89);
}
if (have_(error, error_len)) {
prefix_(rnamec, &c__1, error, (ftnlen)7, error_len);
chkout_(rname, (ftnlen)6);
return 0;
}
chkout_(rname, (ftnlen)6);
return 0;
/* Unload an E-kernel from the list of known files. */
L_nspuld:
s_copy(rname, "NSPULD", (ftnlen)6, (ftnlen)6);
s_copy(rnamec, "NSPULD:", (ftnlen)7, (ftnlen)7);
if (return_()) {
return 0;
}
chkin_(rname, (ftnlen)6);
j = isrchc_(infile__, &nfiles, ekfils, infile_len, (ftnlen)127);
if (j == 0) {
s_copy(error, "The file # is not listed among those files that have "
"been loaded. ", error_len, (ftnlen)66);
repmc_(error, "#", infile__, error, error_len, (ftnlen)1, rtrim_(
infile__, infile_len), error_len);
chkout_(rname, (ftnlen)6);
return 0;
}
/* Get the handle associated with this file. */
dasfnh_(infile__, &handle, rtrim_(infile__, infile_len));
if (have_(error, error_len)) {
chkout_(rname, (ftnlen)6);
return 0;
}
/* Now unload the file, and detach its handle from any columns to */
/* which it might be attached. */
ekuef_(&handle);
clunld_(&handle);
/* Finally remove this file from our internal list of files. */
remlac_(&c__1, &j, ekfils, &nfiles, (ftnlen)127);
chkout_(rname, (ftnlen)6);
return 0;
/* Create a report regarding currently loaded kernels/columns. */
L_nspeks:
/* Version 2.0 Aug 3, 1995 */
/* This routine was rewritten to provide a more friendly */
/* kernel summary. */
/* ---B. Taber */
/* This routine displays the currently loaded E-kernels. */
s_copy(rname, "NSPEKS", (ftnlen)6, (ftnlen)6);
s_copy(rnamec, "NSPEKS:", (ftnlen)7, (ftnlen)7);
if (return_()) {
return 0;
}
/* write (*,*) 'Checking in:' */
chkin_(rname, (ftnlen)6);
if (nfiles <= 0) {
nspwln_(" ", (ftnlen)1);
nspwln_("There are no E-kernels loaded now.", (ftnlen)34);
nspwln_(" ", (ftnlen)1);
chkout_(rname, (ftnlen)6);
return 0;
}
/* First thing we do is set up the NICEPR_1 style string */
/* to be used in creation of summary headers. */
/* write (*,*) 'Fetching margins: ' */
nspglr_(&left, &right);
nspmrg_(style, (ftnlen)80);
suffix_("FLAG", &c__1, style, (ftnlen)4, (ftnlen)80);
suffix_("E-kernel:", &c__1, style, (ftnlen)9, (ftnlen)80);
/* Reset the output page, title frequency and header frequency */
/* values. */
/* write (*,*) 'Resetting page and setting up page attributes:' */
pagrst_();
pagset_("TITLEFREQUENCY", &c__0, (ftnlen)14);
pagset_("HEADERFREQUENCY", &c__0, (ftnlen)15);
pagset_("NOSPACEFOOTER", &c__1, (ftnlen)13);
pagset_("FOOTERFREQUENCY", &c_n1, (ftnlen)15);
s_copy(pval, "CH", (ftnlen)32, (ftnlen)2);
s_copy(pval + 32, "D.P.", (ftnlen)32, (ftnlen)4);
s_copy(pval + 64, "INTEGER", (ftnlen)32, (ftnlen)7);
s_copy(pval + 96, "TIME", (ftnlen)32, (ftnlen)4);
lmarge = 1;
space = 1;
/* Next we set up the the column id codes, sizes, */
/* default widths, justifications, component preservation, */
/* and special marker attributes for each column. */
headr[0] = 1;
headr[1] = 2;
headr[2] = 3;
headr[3] = 4;
headr[4] = 5;
sizes[0] = 1;
sizes[1] = 1;
sizes[2] = 1;
sizes[3] = 1;
sizes[4] = 1;
width[0] = 16;
width[1] = 16;
width[2] = 8;
width[3] = 8;
width[4] = 6;
need = width[0] + width[1] + width[2] + width[3] + width[4] + 4;
right = min(right,need);
pagset_("PAGEWIDTH", &right, (ftnlen)9);
reqd = width[2] + width[3] + width[4] + 4;
/* If the page width is less than default needed, we reset the */
/* widths of the first two columns so they will fit in available */
/* space. */
if (right < need) {
width[0] = (right - reqd) / 2;
width[1] = width[0];
}
justr[0] = FALSE_;
justr[1] = FALSE_;
justr[2] = FALSE_;
justr[3] = TRUE_;
justr[4] = TRUE_;
presrv[0] = TRUE_;
presrv[1] = TRUE_;
presrv[2] = TRUE_;
presrv[3] = TRUE_;
presrv[4] = TRUE_;
s_copy(spcial, " ", (ftnlen)4, (ftnlen)1);
s_copy(spcial + 4, " ", (ftnlen)4, (ftnlen)1);
s_copy(spcial + 8, " ", (ftnlen)4, (ftnlen)1);
s_copy(spcial + 12, " ", (ftnlen)4, (ftnlen)1);
s_copy(spcial + 16, " ", (ftnlen)4, (ftnlen)1);
/* write (*,*) 'Starting file loop:' */
i__1 = nfiles;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Get the handle associated with this file, and get the */
/* number of ID's currently known. */
dasfnh_(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 : s_rnge(
"ekfils", i__2, "kerman_", (ftnlen)738)) * 127, &handle, (
ftnlen)127);
clnum_(&nid);
/* write (*,*) 'File: ', I, 'Handle: ', HANDLE */
/* Now empty out the table/column data for this file. */
/* write (*,*) 'Empty out the column collector.' */
ssizec_(&c__500, tabcol, (ftnlen)80);
ssizei_(&c__500, colids);
/* Cycle over all column id's to determine if they */
/* are attached to this particular file. */
/* write (*,*) 'Beginning Column search: ', NID, ' Columns' */
i__2 = nid;
for (j = 1; j <= i__2; ++j) {
clnid_(&j, &id, &found);
clgai_(&id, "HANDLES", &nh, handls, (ftnlen)7);
if (isrchi_(&handle, &nh, handls) > 0) {
/* This column is associated with this file. Store */
/* its name and id-code for the next section of code. */
/* write (*,*) 'Column id and associated handle match.' */
clgac_(&id, "NAME", cname, (ftnlen)4, (ftnlen)80);
appndc_(cname, tabcol, (ftnlen)80, (ftnlen)80);
appndi_(&id, colids);
}
}
/* Layout the pages. We perform a soft page reset */
/* so that the various sections will be empty. */
/* Note this doesn't affect frequency parameter */
/* or other geometry attributes of pages. */
/* write (*,*) 'Creating page: Title:' */
pagscn_("TITLE", (ftnlen)5);
pagput_(" ", (ftnlen)1);
pagput_("Summary of Loaded E-kernels", (ftnlen)27);
pagput_(" ", (ftnlen)1);
/* write (*,*) 'Creating page: Header' */
/* Set up the various items needed for the report header. */
pagscn_("HEADER", (ftnlen)6);
pagput_(" ", (ftnlen)1);
nicepr_1__(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("ekfils", i__2, "kerman_", (ftnlen)791)) * 127, style,
(S_fp)pagput_, (ftnlen)127, (ftnlen)80);
pagput_(" ", (ftnlen)1);
scolmn_(&c__1, &c__1, "Table Name", (ftnlen)10);
scolmn_(&c__2, &c__1, "Column Name", (ftnlen)11);
scolmn_(&c__3, &c__1, "Type", (ftnlen)4);
scolmn_(&c__4, &c__1, "Size", (ftnlen)4);
scolmn_(&c__5, &c__1, "Index", (ftnlen)5);
/* write (*,*) 'Creating page: Column headings' */
tabrpt_(&c__5, headr, sizes, width, justr, presrv, spcial, &lmarge, &
space, (U_fp)gcolmn_, (ftnlen)4);
s_copy(break__, "==================================================="
"=============================", (ftnlen)80, (ftnlen)80);
pagput_(break__, right);
/* Now set the page section to the body portion for */
/* preparing to fill in the e-kernel summary. */
/* write (*,*) 'Creating page: Body of report:' */
pagscn_("BODY", (ftnlen)4);
n = cardc_(tabcol, (ftnlen)80);
orderc_(tabcol + 480, &n, ordvec, (ftnlen)80);
s_copy(lsttab, " ", (ftnlen)32, (ftnlen)1);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
k = ordvec[(i__3 = j - 1) < 500 && 0 <= i__3 ? i__3 : s_rnge(
"ordvec", i__3, "kerman_", (ftnlen)826)];
clgac_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 : s_rnge(
"colids", i__3, "kerman_", (ftnlen)828)], "TABLE", tname,
(ftnlen)5, (ftnlen)32);
clgac_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 : s_rnge(
"colids", i__3, "kerman_", (ftnlen)829)], "NAME", cname, (
ftnlen)4, (ftnlen)80);
clgac_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 : s_rnge(
"colids", i__3, "kerman_", (ftnlen)830)], "SIZE", size, (
ftnlen)4, (ftnlen)32);
clgac_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 : s_rnge(
"colids", i__3, "kerman_", (ftnlen)831)], "INDEXED", indx,
(ftnlen)7, (ftnlen)4);
/* Note: There is only one type associated with each */
/* handle. Thus TCODE does not need to be an array. */
clgai_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 : s_rnge(
"colids", i__3, "kerman_", (ftnlen)836)], "TYPE", &count,
&tcode, (ftnlen)4);
if (s_cmp(tname, lsttab, (ftnlen)32, (ftnlen)32) == 0) {
s_copy(tname, " ", (ftnlen)32, (ftnlen)1);
} else if (s_cmp(lsttab, " ", (ftnlen)32, (ftnlen)1) != 0) {
pagput_(" ", (ftnlen)1);
s_copy(lsttab, tname, (ftnlen)32, (ftnlen)32);
} else {
s_copy(lsttab, tname, (ftnlen)32, (ftnlen)32);
}
nb = pos_(cname, ".", &c__1, (ftnlen)80, (ftnlen)1) + 1;
s_copy(name__, cname + (nb - 1), (ftnlen)32, 80 - (nb - 1));
if (tcode == 1) {
clgac_(&colids[(i__3 = k + 5) < 506 && 0 <= i__3 ? i__3 :
s_rnge("colids", i__3, "kerman_", (ftnlen)852)],
"TYPE", type__, (ftnlen)4, (ftnlen)32);
sb = pos_(type__, "*", &c__1, (ftnlen)32, (ftnlen)1);
s_copy(pval, "CH", (ftnlen)32, (ftnlen)2);
suffix_(type__ + (sb - 1), &c__0, pval, 32 - (sb - 1), (
ftnlen)32);
}
scolmn_(&c__6, &c__1, tname, (ftnlen)32);
scolmn_(&c__7, &c__1, name__, (ftnlen)32);
scolmn_(&c__8, &c__1, pval + (((i__3 = tcode - 1) < 4 && 0 <=
i__3 ? i__3 : s_rnge("pval", i__3, "kerman_", (ftnlen)860)
) << 5), (ftnlen)32);
scolmn_(&c__9, &c__1, size, (ftnlen)32);
scolmn_(&c__10, &c__1, indx, (ftnlen)4);
ids[0] = 6;
ids[1] = 7;
ids[2] = 8;
ids[3] = 9;
ids[4] = 10;
/* write (*,*) 'Creating next row:' */
/* write (*,*) TNAME */
/* write (*,*) NAME */
/* write (*,*) PVAL(TCODE) */
/* write (*,*) SIZE */
/* write (*,*) INDX */
tabrpt_(&c__5, ids, sizes, width, justr, presrv, spcial, &lmarge,
&space, (U_fp)gcolmn_, (ftnlen)4);
/* write (*,*) 'Row created.' */
}
/* Do a soft page reset so for the next file to be displayed */
/* write (*,*) 'Performing soft page reset.' */
pagsft_();
pagrst_();
pagset_("TITLEFREQUENCY", &c_n1, (ftnlen)14);
pagset_("HEADERFREQUENCY", &c__0, (ftnlen)15);
pagset_("NOSPACEFOOTER", &c__1, (ftnlen)13);
pagset_("FOOTERFREQUENCY", &c_n1, (ftnlen)15);
}
chkout_(rname, (ftnlen)6);
return 0;
/* $Procedure NSPEKC ( Inspekt the comments from EK files ) */
L_nspekc:
/* This entry point examines each file that matches the */
/* template given by INFILE and if comments exist for the */
/* file, they are displayed. */
/* Version 1.0.0 25-AUG-1995 (WLT) */
chkin_("NSPEKC", (ftnlen)6);
totalc = 0;
s_copy(thisfl, " ", (ftnlen)127, (ftnlen)1);
/* We might not need the style string, but it doesn't hurt to */
/* get it. */
nspmrg_(style, (ftnlen)80);
/* If there are no loaded E-kernels say so and return. */
if (nfiles == 0) {
s_copy(messge, "There are no E-kernels loaded now. ", (ftnlen)300, (
ftnlen)35);
nicepr_1__(messge, style, (S_fp)nspwln_, (ftnlen)300, (ftnlen)80);
chkout_("NSPEKC", (ftnlen)6);
return 0;
}
/* Count the number of characters present in the files */
/* that match the template. */
r__ = rtrim_(infile__, infile_len);
l = ltrim_(infile__, infile_len);
i__1 = nfiles;
for (i__ = 1; i__ <= i__1; ++i__) {
if (match_(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("ekfils", i__2, "kerman_", (ftnlen)945)) * 127,
infile__ + (l - 1), (ftnlen)127, r__ - (l - 1))) {
dasfnh_(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("ekfils", i__2, "kerman_", (ftnlen)947)) * 127, &
handle, (ftnlen)127);
dasrfr_(&handle, idword, ifname, &nresvr, &nresvc, &ncomr, &ncomc,
(ftnlen)8, (ftnlen)60);
totalc += ncomc;
++hits;
s_copy(thisfl, ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ?
i__2 : s_rnge("ekfils", i__2, "kerman_", (ftnlen)955)) *
127, (ftnlen)127, (ftnlen)127);
}
}
/* If we didn't get any characters there several possible */
/* reasons. We can look at HITS to see why and form a */
/* grammatically reasonable message. */
if (totalc == 0) {
if (hits == 0) {
s_copy(messge, "There are no E-kernels loaded whose file name ma"
"tches the supplied template '#'.", (ftnlen)300, (ftnlen)
80);
repmc_(messge, "#", infile__ + (l - 1), messge, (ftnlen)300, (
ftnlen)1, r__ - (l - 1), (ftnlen)300);
} else if (hits == 1) {
s_copy(messge, "There are no comments present in the file '#'. ",
(ftnlen)300, (ftnlen)47);
repmc_(messge, "#", thisfl, messge, (ftnlen)300, (ftnlen)1, (
ftnlen)127, (ftnlen)300);
} else if (hits == 2) {
s_copy(messge, "There are no comments present in either of the #"
" files that match the supplied template. ", (ftnlen)300, (
ftnlen)89);
repmct_(messge, "#", &hits, "L", messge, (ftnlen)300, (ftnlen)1, (
ftnlen)1, (ftnlen)300);
} else {
s_copy(messge, "There are no comments present in any of the # fi"
"les that match the supplied template. ", (ftnlen)300, (
ftnlen)86);
repmct_(messge, "#", &hits, "L", messge, (ftnlen)300, (ftnlen)1, (
ftnlen)1, (ftnlen)300);
}
nicepr_1__(messge, style, (S_fp)nspwln_, (ftnlen)300, (ftnlen)80);
chkout_("NSPEKC", (ftnlen)6);
return 0;
}
/* Ok. We've got something. Set up the output page to receive */
/* the comments a file at a time. */
suffix_("FLAG E-kernel:", &c__1, style, (ftnlen)14, (ftnlen)80);
i__1 = nfiles;
for (i__ = 1; i__ <= i__1; ++i__) {
if (match_(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("ekfils", i__2, "kerman_", (ftnlen)1012)) * 127,
infile__ + (l - 1), (ftnlen)127, r__ - (l - 1))) {
dasfnh_(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ? i__2 :
s_rnge("ekfils", i__2, "kerman_", (ftnlen)1014)) * 127, &
handle, (ftnlen)127);
dasrfr_(&handle, idword, ifname, &nresvr, &nresvc, &ncomr, &ncomc,
(ftnlen)8, (ftnlen)60);
if (ncomc == 0) {
s_copy(messge, "# contains no comments.", (ftnlen)300, (
ftnlen)23);
repmc_(messge, "#", ekfils + ((i__2 = i__ - 1) < 20 && 0 <=
i__2 ? i__2 : s_rnge("ekfils", i__2, "kerman_", (
ftnlen)1023)) * 127, messge, (ftnlen)300, (ftnlen)1, (
ftnlen)127, (ftnlen)300);
nspwln_(" ", (ftnlen)1);
nicepr_1__(messge, style, (S_fp)nspwln_, (ftnlen)300, (ftnlen)
80);
} else {
pagrst_();
pagscn_("HEADER", (ftnlen)6);
pagset_("TITLEFREQUENCY", &c__0, (ftnlen)14);
pagset_("HEADERFREQUENCY", &c__0, (ftnlen)15);
pagset_("NOSPACEFOOTER", &c__1, (ftnlen)13);
pagset_("FOOTERFREQUENCY", &c_n1, (ftnlen)15);
pagput_(" ", (ftnlen)1);
nicepr_1__(ekfils + ((i__2 = i__ - 1) < 20 && 0 <= i__2 ?
i__2 : s_rnge("ekfils", i__2, "kerman_", (ftnlen)1038)
) * 127, style, (S_fp)pagput_, (ftnlen)127, (ftnlen)
80);
pagput_(" ", (ftnlen)1);
nspshc_(&handle, &quit);
if (quit) {
nspwln_(" ", (ftnlen)1);
chkout_("NSPEKC", (ftnlen)6);
return 0;
}
}
}
}
nspwln_(" ", (ftnlen)1);
chkout_("NSPEKC", (ftnlen)6);
return 0;
} /* kerman_ */
/* $Procedure STRAN */
/* Subroutine */ int stran_0_(int n__, char *input, char *output, logical *
tran, ftnlen input_len, ftnlen output_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen), i_indx(char *, char *,
ftnlen, ftnlen), s_rnge(char *, integer, char *, integer), i_len(
char *, ftnlen);
/* Local variables */
static integer ldef, leno, vdim, slot, lout, lsym, ptrs[810], i__, j;
extern integer cardc_(char *, ftnlen);
static integer l, n;
static logical check[200];
extern logical batch_(void);
static integer place;
extern /* Subroutine */ int lcase_(char *, char *, ftnlen, ftnlen);
static char delim[1];
extern /* Subroutine */ int chkin_(char *, ftnlen);
static integer nname;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
static char names[32*206];
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen),
geteq_(char *, ftnlen);
extern integer ncpos_(char *, char *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int nthwd_(char *, integer *, char *, integer *,
ftnlen, ftnlen);
static char symbl[33];
static integer psize;
extern integer rtrim_(char *, ftnlen);
static logical checkd[200];
extern logical failed_(void);
static char alphab[32];
extern /* Subroutine */ int getdel_(char *, ftnlen);
extern logical matchm_(char *, char *, char *, char *, char *, char *,
ftnlen, ftnlen, ftnlen, ftnlen, ftnlen, ftnlen);
static char buffer[256*52];
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen),
lastnb_(char *, ftnlen);
static logical gotone;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), repsub_(char *, integer *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen);
static char equote[1];
extern /* Subroutine */ int setmsg_(char *, ftnlen);
static char resvrd[32*12], symbol[33], pattrn[80];
static integer nxtchr;
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen), rdstmn_(char *, char *, char *, ftnlen, ftnlen, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int sbget_1__(char *, char *, integer *, char *,
char *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), nthuqw_(char *
, integer *, char *, char *, integer *, ftnlen, ftnlen, ftnlen);
static char myprmt[80];
extern /* Subroutine */ int sbrem_1__(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
static integer lsttry;
extern /* Subroutine */ int sbset_1__(char *, char *, char *, integer *,
char *, ftnlen, ftnlen, ftnlen, ftnlen);
static char def[1024];
static integer loc;
static char key[32];
static logical new__;
extern /* Subroutine */ int sbinit_1__(integer *, integer *, integer *,
char *, integer *, char *, ftnlen, ftnlen);
/* $ Abstract */
/* Translate the symbols in an input string. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Keywords */
/* PARSE */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* INPUT I Input string containing symbols to be translated. */
/* OUTPUT O Output string, with all symbols translated. */
/* $ Detailed_Input */
/* INPUT is the input string to be translated. INPUT may contain */
/* any number of known symbols. */
/* $ Detailed_Output */
/* OUTPUT is the translation of the input string. The first */
/* of the symbols in INPUT will have been translated. */
/* When INPUT is either a DEFINE or an UNDEFINE command, */
/* OUTPUT is blank. */
/* OUTPUT may overwrite INPUT. */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* None. */
/* $ Exceptions */
/* The following exceptions are detected by this routine: */
/* 1) Attempt to define or undefine a symbol that does */
/* not begin with a letter. */
/* 2) Attempt to define or undefine a symbol that ends with */
/* a question mark '?' . */
/* 3) Failure to specify a symbol to define or undefine. */
/* 4) Attempting to define a reserved word. The reserved */
/* words are: */
/* 'START' */
/* 'STOP' */
/* 'EXIT' */
/* 'INQUIRE' */
/* 'SHOW' */
/* 'DEFINE' */
/* 'SHOW' */
/* 'UNDEFINE' */
/* 'HELP' */
/* In all of the above cases OUTPUT is set to blank and TRAN to */
/* FALSE. No new symbol is placed in the table of symbol */
/* definitions. */
/* In all of these cases the error BAD_SYMBOL_SPC is signalled. */
/* 5) Recursive symbol definitions are detected and disallowed. */
/* A long error message diagnosing the problem is set and */
/* the error RECURSIVE_SYMBOL is signalled. */
/* 5) Overflow of the input command caused by symbol resolution. */
/* In this case the OUTPUT is left at the state it had reached */
/* prior to the overflow condition and TRAN is returned as */
/* FALSE. The error SYMBOL_OVERFLOW is signalled. */
/* $ Detailed_Description */
/* A new symbol may be defined with the DEFINE command. The */
/* syntax is: */
/* DEFINE <symbol> <definition> */
/* where <symbol> is a valid symbol name and <definition> is any */
/* valid definition. The DEFINE command, the symbol name, and the */
/* definition are delimited by blanks. */
/* When a symbol is defined, the symbol and definition are inserted */
/* into the symbol table. */
/* An existing symbol may be removed from the table with the */
/* UNDEFINE command. The syntax is: */
/* UNDEFINE <symbol> */
/* where <symbol> is the name of an existing symbol. The UNDEFINE */
/* command and the symbol name are delimited by blanks. */
/* If the input string does not contain a definition statement, */
/* STRANS searches the input string for potential symbol names. */
/* When a valid symbol is encountered, it is removed from the */
/* string and replaced by the corresponding definition. This */
/* continues until no untranslated symbols remain. */
/* $ Examples */
/* Suppose that we are given the following definitions: */
/* DEFINE BODIES PLANET AND SATS */
/* DEFINE EUROPA 502 */
/* DEFINE GANYMEDE 503 */
/* DEFINE IO 501 */
/* DEFINE JUPITER 599 */
/* DEFINE PLANET JUPITER */
/* DEFINE CALLISTO 504 */
/* DEFINE SATS IO EUROPA GANYMEDE CALLISTO */
/* Then the string 'BODIES AND SOULS' would translate, */
/* at various stages, to: */
/* 'PLANET AND SATS AND SOULS' */
/* 'JUPITER AND SATS AND SOULS' */
/* '599 AND SATS AND SOULS' */
/* '599 AND IO EUROPA GANYMEDE CALLISTO AND SOULS' */
/* '599 AND 501 EUROPA GANYMEDE CALLISTO AND SOULS' */
/* '599 AND 501 502 GANYMEDE CALLISTO AND SOULS' */
/* '599 AND 501 502 503 CALLISTO AND SOULS' */
/* '599 AND 501 502 503 504 AND SOULS' */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* I. M. Underwood (JPL) */
/* $ Version_and_Date */
/* Version 1.2.0 29-Aug-1996 (WLT) */
/* Fixed the error message for the case in which someone */
/* tries to create a symbol that is more than 32 characters */
/* in length. */
/* Version 1.1, 14-SEP-1995 */
/* Reference to unused variable WORD deleted. */
/* Version 1, 8-SEP-1986 */
/* -& */
/* SPICELIB Functions */
/* Other supporting functions */
/* The following parameters are used to define our table */
/* of symbol translations. */
/* Longest allowed symbol name is given by WDSIZE */
/* Maximum number of allowed symbols is MAXN */
/* The longest we expect any symbol to be is MAXL characters */
/* The average number of characters per symbol is AVGL */
/* Finally, here are the arrays used to hold the symbol translations. */
/* Here's the storage we need for the reserved words. */
switch(n__) {
case 1: goto L_sympat;
case 2: goto L_symget;
}
/* Set up all of the data structures and special strings in */
/* the first pass through the routine. */
if (return_()) {
return 0;
}
chkin_("STRAN", (ftnlen)5);
if (first) {
first = FALSE_;
vdim = 51;
psize = 804;
nname = 200;
sbinit_1__(&nname, &psize, &vdim, names, ptrs, buffer, (ftnlen)32, (
ftnlen)256);
s_copy(resvrd, "START", (ftnlen)32, (ftnlen)5);
s_copy(resvrd + 32, "STOP", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 64, "EXIT", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 96, "INQUIRE", (ftnlen)32, (ftnlen)7);
s_copy(resvrd + 128, "SHOW", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 160, "DEFINE", (ftnlen)32, (ftnlen)6);
s_copy(resvrd + 192, "SHOW", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 224, "UNDEFINE", (ftnlen)32, (ftnlen)8);
s_copy(resvrd + 256, "HELP", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 288, "RECALL", (ftnlen)32, (ftnlen)6);
s_copy(resvrd + 320, "DO", (ftnlen)32, (ftnlen)2);
s_copy(resvrd + 352, "EDIT", (ftnlen)32, (ftnlen)4);
s_copy(alphab, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", (ftnlen)32, (ftnlen)26);
}
/* Find out what the special marker character is for suppressing */
/* symbol evaluation. */
geteq_(equote, (ftnlen)1);
/* Is this a definition statement? The presence of DEFINE, INQUIRE or */
/* UNDEFINE at the beginning of the string will confirm this. */
nthwd_(input, &c__1, key, &loc, input_len, (ftnlen)32);
ucase_(key, key, (ftnlen)32, (ftnlen)32);
/* The keyword must be followed by a valid symbol name. */
if (s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0 || s_cmp(key, "INQU"
"IRE", (ftnlen)32, (ftnlen)7) == 0 || s_cmp(key, "UNDEFINE", (
ftnlen)32, (ftnlen)8) == 0) {
nthwd_(input, &c__2, symbl, &loc, input_len, (ftnlen)33);
ucase_(symbl, symbol, (ftnlen)33, (ftnlen)33);
l = rtrim_(symbol, (ftnlen)33);
if (s_cmp(symbol, " ", (ftnlen)33, (ftnlen)1) == 0) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
setmsg_("The \"#\" command must be followed by the name of the s"
"ymbol that you want to #. ", (ftnlen)79);
errch_("#", key, (ftnlen)1, (ftnlen)32);
lcase_(key, key, (ftnlen)32, (ftnlen)32);
errch_("#", key, (ftnlen)1, (ftnlen)32);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (i_indx(alphab, symbol, (ftnlen)32, (ftnlen)1) == 0) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
lcase_(key, key, (ftnlen)32, (ftnlen)32);
setmsg_("You cannot # \"#\". Symbols must begin with a letter ("
"A-Z) ", (ftnlen)58);
errch_("#", key, (ftnlen)1, (ftnlen)32);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (l > 32) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
lcase_(key, key, (ftnlen)32, (ftnlen)32);
setmsg_("You cannot # \"#...\". Symbols may not be longer than "
"32 characters in length.", (ftnlen)77);
errch_("#", key, (ftnlen)1, (ftnlen)32);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (*(unsigned char *)&symbol[l - 1] == '?') {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
lcase_(key, key, (ftnlen)32, (ftnlen)32);
setmsg_("You cannot # \"#\". Symbols may not end with a questio"
"n mark '?'. ", (ftnlen)65);
errch_("#", key, (ftnlen)1, (ftnlen)32);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if ((s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0 || s_cmp(
key, "INQUIRE", (ftnlen)32, (ftnlen)7) == 0) && isrchc_(
symbol, &c__12, resvrd, (ftnlen)33, (ftnlen)32) > 0) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
setmsg_("The word '#' is a reserved word. You may not redefine i"
"t. ", (ftnlen)58);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
}
}
if (s_cmp(key, "INQUIRE", (ftnlen)32, (ftnlen)7) == 0) {
/* First of all we, can only INQUIRE for symbol definitions */
/* if the program is not running in "batch" mode. */
if (batch_()) {
setmsg_("You've attempted to INQUIRE for the value of a symbol w"
"hile the program is running in \"batch\" mode. You can I"
"NQUIRE for a symbol value only if you are running in INT"
"ERACTIVE mode. ", (ftnlen)180);
sigerr_("WRONG_MODE", (ftnlen)10);
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* See if there is anything following the symbol that is */
/* to be defined. This will be used as our prompt value. */
/* Computing MAX */
i__3 = loc + l;
i__1 = loc + l, i__2 = ncpos_(input, " ", &i__3, input_len, (ftnlen)1)
;
nxtchr = max(i__1,i__2);
if (s_cmp(input + (nxtchr - 1), " ", input_len - (nxtchr - 1), (
ftnlen)1) != 0) {
s_copy(myprmt, input + (nxtchr - 1), (ftnlen)80, input_len - (
nxtchr - 1));
} else {
s_copy(myprmt, "Enter definition for", (ftnlen)80, (ftnlen)20);
suffix_(symbol, &c__1, myprmt, (ftnlen)33, (ftnlen)80);
suffix_(">", &c__1, myprmt, (ftnlen)1, (ftnlen)80);
}
getdel_(delim, (ftnlen)1);
rdstmn_(myprmt, delim, def, (ftnlen)80, (ftnlen)1, (ftnlen)1024);
sbset_1__(symbol, def, names, ptrs, buffer, (ftnlen)33, (ftnlen)1024,
(ftnlen)32, (ftnlen)256);
}
/* If this is a definition, and the symbol already exists in the */
/* symbol table, simply replace the existing definition with the */
/* string following the symbol name. If this is a new symbol, */
/* find the first symbol in the list that should follow the new */
/* one. Move the rest of the symbols back, and insert the new one */
/* at this point. */
if (s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0) {
/* Computing MAX */
i__3 = loc + l;
i__1 = loc + l, i__2 = ncpos_(input, " ", &i__3, input_len, (ftnlen)1)
;
nxtchr = max(i__1,i__2);
sbset_1__(symbol, input + (nxtchr - 1), names, ptrs, buffer, (ftnlen)
33, input_len - (nxtchr - 1), (ftnlen)32, (ftnlen)256);
}
if (s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0 || s_cmp(key, "INQU"
"IRE", (ftnlen)32, (ftnlen)7) == 0) {
if (failed_()) {
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* Now check for a recursive definition. To do this we have */
/* two parallel arrays to the NAMES array of the string */
/* buffer. The first array CHECK is used to indicate that */
/* in the course of the definition resolution of the */
/* new symbol, another symbol shows up. The second array */
/* called CHECKD indicats whether or not we have examined this */
/* existing symbol to see if contains the newly created */
/* symbol as part of its definition. */
/* So far we have nothing to check and haven't checked anything. */
n = cardc_(names, (ftnlen)32);
i__1 = n;
for (j = 1; j <= i__1; ++j) {
check[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge("check",
i__2, "stran_", (ftnlen)545)] = FALSE_;
checkd[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge("checkd",
i__2, "stran_", (ftnlen)546)] = FALSE_;
}
/* Find the location of our new symbol in the NAMES cell. */
place = isrchc_(symbol, &n, names + 192, (ftnlen)33, (ftnlen)32);
new__ = TRUE_;
while(new__) {
/* Look up the definition currently associated with */
/* the symbol we are checking. */
sbget_1__(symbol, names, ptrs, buffer, def, &i__, (ftnlen)33, (
ftnlen)32, (ftnlen)256, (ftnlen)1024);
j = 1;
nthuqw_(def, &j, equote, symbol, &loc, (ftnlen)1024, (ftnlen)1, (
ftnlen)33);
while(loc > 0) {
ucase_(symbol, symbol, (ftnlen)33, (ftnlen)33);
slot = isrchc_(symbol, &n, names + 192, (ftnlen)33, (ftnlen)
32);
/* If the word is located in the same place as the */
/* symbol we've just defined, we've introduced */
/* a recursive symbol definition. Remove this */
/* symbol and diagnose the error. */
if (slot == place) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
s_copy(symbol, names + (((i__1 = place + 5) < 206 && 0 <=
i__1 ? i__1 : s_rnge("names", i__1, "stran_", (
ftnlen)582)) << 5), (ftnlen)33, (ftnlen)32);
sbrem_1__(symbol, names, ptrs, buffer, (ftnlen)33, (
ftnlen)32, (ftnlen)256);
setmsg_("The definition of '#' is recursive. Recursivel"
"y defined symbol definitions are not allowed. ", (
ftnlen)93);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("RECURSIVE_SYMBOL", (ftnlen)16);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (slot > 0) {
/* Otherwise if this word is in the names list */
/* we may need to check this symbol to see if */
/* it lists the just defined symbol in its definition. */
if (checkd[(i__1 = slot - 1) < 200 && 0 <= i__1 ? i__1 :
s_rnge("checkd", i__1, "stran_", (ftnlen)602)]) {
check[(i__1 = slot - 1) < 200 && 0 <= i__1 ? i__1 :
s_rnge("check", i__1, "stran_", (ftnlen)603)]
= FALSE_;
} else {
check[(i__1 = slot - 1) < 200 && 0 <= i__1 ? i__1 :
s_rnge("check", i__1, "stran_", (ftnlen)605)]
= TRUE_;
}
}
/* Locate the next unquoted word in the definition. */
++j;
nthuqw_(def, &j, equote, symbol, &loc, (ftnlen)1024, (ftnlen)
1, (ftnlen)33);
}
/* See if there are any new items to check. If there */
/* are create a new value for symbol, and mark the */
/* new item as being checked. */
new__ = FALSE_;
i__1 = n;
for (j = 1; j <= i__1; ++j) {
if (check[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge(
"check", i__2, "stran_", (ftnlen)625)] && ! new__) {
s_copy(symbol, names + (((i__2 = j + 5) < 206 && 0 <=
i__2 ? i__2 : s_rnge("names", i__2, "stran_", (
ftnlen)626)) << 5), (ftnlen)33, (ftnlen)32);
check[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge(
"check", i__2, "stran_", (ftnlen)627)] = FALSE_;
checkd[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge(
"checkd", i__2, "stran_", (ftnlen)628)] = TRUE_;
new__ = TRUE_;
}
}
}
/* If we get to this point, we have a new non-recursively */
/* defined symbol. */
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* If this is a deletion, and the symbol already exists in the */
/* symbol table, simply move the symbols that follow toward the */
/* front of the table. */
if (s_cmp(key, "UNDEFINE", (ftnlen)32, (ftnlen)8) == 0) {
sbrem_1__(symbol, names, ptrs, buffer, (ftnlen)33, (ftnlen)32, (
ftnlen)256);
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* This is not a definition statement. Look for potential symbols. */
/* Try to resolve the first symbol in the string by substituting the */
/* corresponding definition for the existing symbol. */
s_copy(output, input, output_len, input_len);
*tran = FALSE_;
j = 1;
nthuqw_(output, &j, equote, symbol, &loc, output_len, (ftnlen)1, (ftnlen)
33);
while(! (*tran) && s_cmp(symbol, " ", (ftnlen)33, (ftnlen)1) != 0) {
ucase_(symbol, symbol, (ftnlen)33, (ftnlen)33);
sbget_1__(symbol, names, ptrs, buffer, def, &i__, (ftnlen)33, (ftnlen)
32, (ftnlen)256, (ftnlen)1024);
if (i__ > 0) {
lsym = lastnb_(symbol, (ftnlen)33);
ldef = lastnb_(def, (ftnlen)1024) + 1;
lout = lastnb_(output, output_len);
leno = i_len(output, output_len);
if (lout - lsym + ldef > leno) {
*tran = FALSE_;
setmsg_("As a result of attempting to resolve the symbols in"
" the input command, the command has overflowed the a"
"llocated memory. This is may be due to unintentional"
"ly using symbols that you had not intended to use. "
"You may protect portions of your string from symbol "
"evaluation by enclosing that portion of your string "
"between the character # as in 'DO #THIS PART WITHOUT"
" SYMBOLS#' . ", (ftnlen)376);
errch_("#", equote, (ftnlen)1, (ftnlen)1);
errch_("#", equote, (ftnlen)1, (ftnlen)1);
errch_("#", equote, (ftnlen)1, (ftnlen)1);
sigerr_("SYMBOL_OVERFLOW", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
}
i__1 = loc + lsym - 1;
repsub_(output, &loc, &i__1, def, output, output_len, ldef,
output_len);
*tran = TRUE_;
} else {
++j;
}
nthuqw_(output, &j, equote, symbol, &loc, output_len, (ftnlen)1, (
ftnlen)33);
}
chkout_("STRAN", (ftnlen)5);
return 0;
/* The following entry point allows us to set up a search */
/* of defined symbols that match a wild-card pattern. It must */
/* be called prior to getting any symbol definitions. */
L_sympat:
lsttry = 0;
s_copy(pattrn, input, (ftnlen)80, input_len);
return 0;
/* The following entry point fetches the next symbol and its */
/* definition for the next SYMBOL whose name */
/* matches a previously supplied template via the entry point */
/* above --- SYMPAT. */
/* If there is no matching symbol, we get back blanks. Note */
/* that no translation of the definition is performed. */
L_symget:
s_copy(input, " ", input_len, (ftnlen)1);
s_copy(output, " ", output_len, (ftnlen)1);
n = cardc_(names, (ftnlen)32);
while(lsttry < n) {
++lsttry;
gotone = matchm_(names + (((i__1 = lsttry + 5) < 206 && 0 <= i__1 ?
i__1 : s_rnge("names", i__1, "stran_", (ftnlen)767)) << 5),
pattrn, "*", "%", "~", "|", (ftnlen)32, (ftnlen)80, (ftnlen)1,
(ftnlen)1, (ftnlen)1, (ftnlen)1);
if (gotone) {
s_copy(symbol, names + (((i__1 = lsttry + 5) < 206 && 0 <= i__1 ?
i__1 : s_rnge("names", i__1, "stran_", (ftnlen)771)) << 5)
, (ftnlen)33, (ftnlen)32);
s_copy(input, names + (((i__1 = lsttry + 5) < 206 && 0 <= i__1 ?
i__1 : s_rnge("names", i__1, "stran_", (ftnlen)772)) << 5)
, input_len, (ftnlen)32);
sbget_1__(symbol, names, ptrs, buffer, output, &i__, (ftnlen)33, (
ftnlen)32, (ftnlen)256, output_len);
return 0;
}
}
return 0;
} /* stran_ */
/* Subroutine */ int chunk_(char *buffer, integer *first, integer *last,
ftnlen buffer_len)
{
/* Initialized data */
static char terms[32*24] = "|endliteral " "!endliter"
"al " "@chapter " "@se"
"ction " "@setvarsize "
"@var " "@setparamsize "
" " "@param " "@literal "
" " "@literalitem " "@literalparam "
" " "@literalvar " "@exliteral"
" " "@exliteralitem " "@exl"
"iteralparam " "@exliteralvar "
"@newlist " "@newpage "
" " "@numitem " "@paritem "
" " "@symitem " "@moreparam "
" " "@morevar " " "
" ";
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
char cseq[32];
extern integer cpos_(char *, char *, integer *, ftnlen, ftnlen);
integer term, i__, j;
extern integer cardc_(char *, ftnlen);
integer begin;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer index;
extern integer ncpos_(char *, char *, integer *, ftnlen, ftnlen);
integer nterm;
extern integer ltrim_(char *, ftnlen);
integer endbuf;
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen),
touchi_(integer *);
extern /* Subroutine */ int chkout_(char *, ftnlen);
extern logical return_(void);
integer end;
/* Find the next `chunk' of a FORTeX source buffer. The chunk begins */
/* sometime after BUFFER(FIRST), and ends at BUFFER(LAST). */
/* $ Revisions */
/* - Faketex version 1.3.0 5-DEC-1995 WLT */
/* Set I = TOUCHI( I ) in the IF ( RETURN() ) block so that buggy */
/* compilers won't complain that it isn't used. */
/* - Faketex version 1.2.0 17-NOV-1995 NJB */
/* Data statement for TERMS broken up into multiple statements */
/* to avoid violation of continuation limit on Sun. */
/* - Faketex version 1.1.0 16-MAY-1994 NJB */
/* Substring bounds on line 106 safeguarded to stay in range. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling */
if (return_()) {
i__ = 0;
i__ = touchi_(&i__);
return 0;
} else {
chkin_("CHUNK", (ftnlen)5);
}
/* Because we can safely assume that the first line of the chunk */
/* is not inside a literal section, we can skip blank lines and */
/* @newpage directives with impunity to find the beginning of the */
/* chunk. */
endbuf = cardc_(buffer, buffer_len);
j = ltrim_(buffer + (*first + 5) * buffer_len, buffer_len);
while(*first < endbuf && (s_cmp(buffer + (*first + 5) * buffer_len, " ",
buffer_len, (ftnlen)1) == 0 || s_cmp(buffer + ((*first + 5) *
buffer_len + (j - 1)), "@newpage", buffer_len - (j - 1), (ftnlen)
8) == 0)) {
++(*first);
}
*last = *first;
/* A literal chunk may be terminated only by an explicit end marker */
/* (|endliteral or !endliteral) or the end of the buffer. A normal */
/* chunk is terminated by the beginning of another chunk, a */
/* blank line, or a @newpage. */
/* Computing MAX */
i__1 = 1, i__2 = ncpos_(buffer + (*first + 5) * buffer_len, " ", &c__1,
buffer_len, (ftnlen)2);
begin = max(i__1,i__2);
/* Computing MAX */
i__1 = begin, i__2 = cpos_(buffer + (*first + 5) * buffer_len, " {", &
begin, buffer_len, (ftnlen)2) - 1;
end = max(i__1,i__2);
s_copy(cseq, buffer + ((*first + 5) * buffer_len + (begin - 1)), (ftnlen)
32, end - (begin - 1));
if (s_cmp(cseq, "@literal", (ftnlen)8, (ftnlen)8) == 0) {
term = 1;
nterm = 1;
} else if (s_cmp(cseq, "@exliteral", (ftnlen)10, (ftnlen)10) == 0) {
term = 2;
nterm = 1;
} else {
term = 3;
nterm = 22;
}
/* Check subsequent lines until the proper terminator or the end */
/* of the buffer is reached. */
index = 0;
while(index == 0 && *last < endbuf) {
++(*last);
if (s_cmp(buffer + (*last + 5) * buffer_len, " ", buffer_len, (ftnlen)
1) == 0) {
s_copy(cseq, " ", (ftnlen)32, (ftnlen)1);
} else {
begin = ncpos_(buffer + (*last + 5) * buffer_len, " ", &c__1,
buffer_len, (ftnlen)2);
/* Computing MAX */
i__1 = begin, i__2 = cpos_(buffer + (*last + 5) * buffer_len,
" {", &begin, buffer_len, (ftnlen)2) - 1;
end = max(i__1,i__2);
s_copy(cseq, buffer + ((*last + 5) * buffer_len + (begin - 1)), (
ftnlen)32, end - (begin - 1));
}
index = isrchc_(cseq, &nterm, terms + (((i__1 = term - 1) < 24 && 0 <=
i__1 ? i__1 : s_rnge("terms", i__1, "chunk_", (ftnlen)193))
<< 5), (ftnlen)32, (ftnlen)32);
}
/* Only a literal section retains the line that terminates it. */
if (term > 2 && *last != endbuf) {
--(*last);
}
chkout_("CHUNK", (ftnlen)5);
return 0;
} /* chunk_ */
/* $Procedure GETOPT ( Get an option from a menu ) */
/* Subroutine */ int getopt_(char *title, integer *nopt, char *optnam, char *
opttxt, integer *option, ftnlen title_len, ftnlen optnam_len, ftnlen
opttxt_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
logical done;
char line[80];
integer iopt, i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen), repmc_(char *, char *, char *, char *, ftnlen,
ftnlen, ftnlen, ftnlen);
logical okequ;
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
char prmpt[80];
extern logical failed_(void);
logical ok, okdigi;
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
logical okalph;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
extern logical return_(void);
extern /* Subroutine */ int writln_(char *, integer *, ftnlen), prompt_(
char *, char *, ftnlen, ftnlen);
char msg[80];
/* $ Abstract */
/* Display a list of options in a standard menu format and get */
/* an option from a user returning the corresponding index of */
/* the option selected. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* None. */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* TITLE I Title for the menu. */
/* NOPT I Number of options available. */
/* OPTNAM I Names for the options. */
/* OPTTXT I Brief text describing an option. */
/* OPTVAL I The value returned when its option is selected. */
/* OPTION O The number of the option selected. */
/* $ Detailed_Input */
/* TITLE Title for the option menu. */
/* NOPT The number of menu options to be displayed. */
/* OPTNAM A list of single character names for the menu options. */
/* These are the names used to select an option. The names */
/* must each be a single alphanumeric character. All names */
/* must be upper case if they are characters. */
/* If the option names is a period, '.', then a blank line */
/* is to be displayed at that position in the menu list. */
/* OPTTXT A list of character strings which contain brief */
/* descriptions for each of the menu options. These */
/* character strings should be kept relatively short. */
/* Please note that the lengths of the option names, OPTNAM, and */
/* the descriptive text for each option, OPTTXT, should be kept */
/* reasonable, they both need to fit on the same output line with */
/* a width of 80 characters. 13 characters out of the 80 available */
/* are used for spacing and menu presentation, so there are 67 */
/* characters available for the option name and the descriptive text */
/* combined. */
/* $ Detailed_Output */
/* OPTION The index of the option selected from the menu. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the number of options, NOPT, is not > 0, the error */
/* SPICE(INVALIDARGUMENT) will be signalled. */
/* 2) If the option names are not all upper case alphanumeric */
/* characters, the error SPICE(BADOPTIONNAME) will be signalled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine will display a menu of options in a standardized */
/* format, promting for the selection of one of the listed options. */
/* This routine will not return to the caller until one of the */
/* supplied options has been selected or an error occurs. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* This routine makes explicit use fo the ASCII character sequence. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* $ Version */
/* - Beta Version 4.2.0, 18-DEC-2010 (EDW) */
/* Declared PROMPT as EXTERNAL. Eliminated unneeded Revisions */
/* section. */
/* - Beta Version 4.1.0, 05-JUL-1995 (KRG) */
/* Removed the initial blank line that was printed before the */
/* title of the menu. The calling program should determine the */
/* whitespace requirements for the appearance of the menu */
/* displayed by this routine. */
/* - Beta Version 4.0.0, 25-APR-1994 (KRG) */
/* Modified the routine to output the index into the list of menu */
/* options rather than a character string representing the option */
/* selected. Also removed several calling arguments that were not */
/* needed anymore. */
/* Added the capability of inserting a blank line into the menu. */
/* This is done by placing a period, '.', into the option name */
/* location where the blank line lshould occur. */
/* Added the missing $ Index_Entries section to the header. */
/* Clarified a few of the comments in the header. */
/* - Beta Version 3.0.0, 03-SEP-1992 (KRG) */
/* -& */
/* $ Index_Entries */
/* display a menu and get a user's selection */
/* -& */
/* SPICELIB functions */
/* Local Parameters */
/* Mnemonic for the standard output. */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("GETOPT", (ftnlen)6);
}
/* Check to make sure that the number of menu options is positive. */
/* if it is not, then signal an error with an appropriate error */
/* message. */
if (*nopt < 1) {
setmsg_("The number of options was not positive: #.", (ftnlen)42);
errint_("#", nopt, (ftnlen)1);
sigerr_("SPICE(INVALIDARGUMENT)", (ftnlen)22);
chkout_("GETOPT", (ftnlen)6);
return 0;
}
/* Initialize the option prompt. */
s_copy(prmpt, " ", (ftnlen)80, (ftnlen)1);
s_copy(prmpt + 3, "Option: ", (ftnlen)77, (ftnlen)8);
/* Check to make sure that all of the option names are alphanumeric */
/* and uppercase. The only exception is the period, which signals a */
/* blank line. */
ok = TRUE_;
i__1 = *nopt;
for (i__ = 1; i__ <= i__1; ++i__) {
okdigi = *(unsigned char *)&optnam[(i__ - 1) * optnam_len] >= '0' && *
(unsigned char *)&optnam[(i__ - 1) * optnam_len] <= '9';
okalph = *(unsigned char *)&optnam[(i__ - 1) * optnam_len] >= 'A' && *
(unsigned char *)&optnam[(i__ - 1) * optnam_len] <= 'Z';
okequ = *(unsigned char *)&optnam[(i__ - 1) * optnam_len] == '.';
ok = ok && (okdigi || okalph || okequ);
if (! ok) {
setmsg_("An illegal option name was found: option #, name '#'. ",
(ftnlen)54);
errint_("#", &i__, (ftnlen)1);
sigerr_("SPICE(ILLEGALOPTIONNAME)", (ftnlen)24);
chkout_("GETOPT", (ftnlen)6);
return 0;
}
}
/* Do until we get a valid option. */
done = FALSE_;
while(! done) {
/* Display the menu title if it is non blank */
if (s_cmp(title, " ", title_len, (ftnlen)1) != 0) {
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
s_copy(line + 9, "#", (ftnlen)71, (ftnlen)1);
repmc_(line, "#", title, line, (ftnlen)80, (ftnlen)1, title_len, (
ftnlen)80);
writln_(line, &c__6, (ftnlen)80);
}
/* Display the menu and read in an option. */
writln_(" ", &c__6, (ftnlen)1);
i__1 = *nopt;
for (i__ = 1; i__ <= i__1; ++i__) {
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
if (s_cmp(optnam + (i__ - 1) * optnam_len, ".", optnam_len, (
ftnlen)1) != 0) {
s_copy(line + 3, "( # ) #", (ftnlen)77, (ftnlen)7);
repmc_(line, "#", optnam + (i__ - 1) * optnam_len, line, (
ftnlen)80, (ftnlen)1, optnam_len, (ftnlen)80);
repmc_(line, "#", opttxt + (i__ - 1) * opttxt_len, line, (
ftnlen)80, (ftnlen)1, opttxt_len, (ftnlen)80);
}
writln_(line, &c__6, (ftnlen)80);
}
writln_(" ", &c__6, (ftnlen)1);
i__ = rtrim_(prmpt, (ftnlen)80) + 1;
prompt_(prmpt, line, i__, (ftnlen)80);
if (failed_()) {
chkout_("GETOPT", (ftnlen)6);
return 0;
}
/* Initialize the option value to zero, invalid option. */
iopt = 0;
if (s_cmp(line, " ", (ftnlen)80, (ftnlen)1) == 0) {
writln_(" ", &c__6, (ftnlen)1);
} else {
ljust_(line, line, (ftnlen)80, (ftnlen)80);
ucase_(line, line, (ftnlen)80, (ftnlen)80);
/* Check to make sure that the option we got is a valid */
/* candidate: It must be alpha numeric. */
okdigi = *(unsigned char *)line >= '0' && *(unsigned char *)line
<= '9';
okalph = *(unsigned char *)line >= 'A' && *(unsigned char *)line
<= 'Z';
ok = okdigi || okalph;
/* If we got a valid candidate for an option, see if it is one */
/* of the options that we are supplying. */
if (ok) {
iopt = isrchc_(line, nopt, optnam, (ftnlen)1, optnam_len);
ok = iopt != 0;
}
if (! ok) {
s_copy(msg, "'#' was not a valid option. Please try again.", (
ftnlen)80, (ftnlen)45);
repmc_(msg, "#", line, msg, (ftnlen)80, (ftnlen)1, (ftnlen)1,
(ftnlen)80);
writln_(" ", &c__6, (ftnlen)1);
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
s_copy(line + 3, "***", (ftnlen)77, (ftnlen)3);
writln_(line, &c__6, (ftnlen)80);
s_copy(line + 3, "*** #", (ftnlen)77, (ftnlen)5);
repmc_(line, "#", msg, line, (ftnlen)80, (ftnlen)1, (ftnlen)
80, (ftnlen)80);
writln_(line, &c__6, (ftnlen)80);
s_copy(line + 3, "***", (ftnlen)77, (ftnlen)3);
writln_(line, &c__6, (ftnlen)80);
writln_(" ", &c__6, (ftnlen)1);
} else {
*option = iopt;
done = TRUE_;
}
}
}
chkout_("GETOPT", (ftnlen)6);
return 0;
} /* getopt_ */
/* $Procedure 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 STCC01 ( STAR catalog type 1, check whether type 1 ) */
/* Subroutine */ int stcc01_(char *catfnm, char *tabnam, logical *istyp1,
char *errmsg, ftnlen catfnm_len, ftnlen tabnam_len, ftnlen errmsg_len)
{
/* Initialized data */
static char cat1nm[32*7] = "CATALOG_NUMBER " "RA "
" " "DEC " "RA_"
"SIGMA " "DEC_SIGMA "
"VISUAL_MAGNITUDE " "SPECTRAL_TYPE "
" ";
static char cat1dt[4*7] = "INT " "DP " "DP " "DP " "DP " "DP " "CHR "
;
/* System generated locals */
address a__1[4];
integer i__1, i__2, i__3, i__4[4];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen), s_rnge(char *, integer,
char *, integer);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer i__, j;
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern integer nblen_(char *, ftnlen);
extern /* Subroutine */ int ekcls_(integer *);
static logical found;
static integer ncols;
extern /* Subroutine */ int ekopr_(char *, integer *, ftnlen);
static integer sizes[100], nrows;
static char cnames[32*100];
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen),
eknseg_(integer *);
static logical indexd[100];
static integer tmphnd, numseg;
extern /* Subroutine */ int chkout_(char *, ftnlen);
static logical nullok[100];
extern /* Subroutine */ int ekssum_(integer *, integer *, char *, integer
*, integer *, char *, char *, integer *, integer *, logical *,
logical *, ftnlen, ftnlen, ftnlen);
static char dtypes[4*100];
extern logical return_(void);
static char tmptnm[64];
static integer strlns[100];
static char tnmprv[64];
/* $ Abstract */
/* Check whether a file is a type 1 star catalog and return the */
/* catalog's table name if it is. */
/* $ 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 */
/* EK */
/* $ Keywords */
/* None. */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Column Name Size */
/* ekcnamsz.inc Version 1 17-JAN-1995 (NJB) */
/* Size of column name, in characters. */
/* End Include Section: EK Column Name Size */
/* $ 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 Table Name Size */
/* ektnamsz.inc Version 1 17-JAN-1995 (NJB) */
/* Size of table name, in characters. */
/* End Include Section: EK Table Name Size */
/* $ 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 General Limit Parameters */
/* ekglimit.inc Version 1 21-MAY-1995 (NJB) */
/* This file contains general limits for the EK system. */
/* MXCLSG is the maximum number of columns allowed in a segment. */
/* This limit applies to logical tables as well, since all segments */
/* in a logical table must have the same column definitions. */
/* End Include Section: EK General Limit Parameters */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* CATFNM I Catalog file name. */
/* TABNAM O Catalog table name. */
/* ISTYP1 O True when file is type 1 star catalog. */
/* ERRMSG O Error message. */
/* $ Detailed_Input */
/* CATFNM is the name of the catalog file. */
/* $ Detailed_Output */
/* TABNAM is the name of the data table contained in the */
/* catalog. Set to blank if file is not a type 1 star */
/* catalog. */
/* ISTYP1 is TRUE when the file is a type 1 star catalog. FALSE */
/* otherwise. */
/* ERRMSG is a diagnostic message indicating why the file is */
/* not a type 1 star catalog. Set to blank if the file */
/* is a type 1 star catalog. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the indicated file cannot be opened, the error will be */
/* diagnosed by routines called by this routine. */
/* 2) If the indicated file has the wrong architecture version, the */
/* error will be diagnosed by routines called by this routine. */
/* 3) If an I/O error occurs while reading the indicated file, the */
/* error will be diagnosed by routines called by this routine. */
/* $ Files */
/* This routine checks whether file is really SPICE type 1 star */
/* catalog file. */
/* SPICE type 1 star catalog files MUST contain a single data table. */
/* It can occupy a single segment or it can spread across multiple */
/* segments. This table MUST include the following columns: */
/* column name data type units */
/* ------------------------------------------------------- */
/* RA DOUBLE PRECISION DEGREES */
/* DEC DOUBLE PRECISION DEGREES */
/* RA_SIGMA DOUBLE PRECISION DEGREES */
/* DEC_SIGMA DOUBLE PRECISION DEGREES */
/* CATALOG_NUMBER INTEGER */
/* SPECTRAL_TYPE CHARACTER*(4) */
/* VISUAL_MAGNITUDE DOUBLE PRECISION */
/* Nulls are not allowed in any of the columns. */
/* Other columns can also be present in the table but their data */
/* will NOT be accessible through type 1 star catalog access */
/* routines. Note that the names and attributes of these additional */
/* columns must be identical for all segments containing this table. */
/* $ Particulars */
/* This routine does not need to be called by the user's program. */
/* It is used by star catalog loader routines to check */
/* whether a particular file is a type 1 star catalog before loading */
/* the file. */
/* $ Examples */
/* In the following code fragment, STCC01 is used to determine */
/* whether a file is a SPICE type 1 star catalog. */
/* C */
/* C Call STCC01 to determine whether the file is type 1 star */
/* C catalog file. */
/* C */
/* CALL STCC01 ( CATFNM, TABNAM, ISTYP1, ERRMSG ) */
/* C */
/* C Check ISTYP1 flag and stop execution and report an */
/* C error if file is not type 1 star catalog file. */
/* C */
/* IF ( .NOT. ISTYP1 ) THEN */
/* . WRITE (*,*) 'The file:' */
/* . WRITE (*,*) ' ',CATFNM(1:RTRIM(CATFNM)) */
/* . WRITE (*,*) 'is not a type 1 star catalog.' */
/* . WRITE (*,*) ERRMSG */
/* STOP */
/* END IF */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 15-MAY-1996 (BVS) */
/* -& */
/* $ Index_Entries */
/* check whether a file is a type 1 star catalog */
/* -& */
/* SPICELIB functions */
/* Local parameters. */
/* Local variables */
/* Initial values. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("STCC01", (ftnlen)6);
}
/* More initial values. */
s_copy(tabnam, " ", tabnam_len, (ftnlen)1);
s_copy(errmsg, " ", errmsg_len, (ftnlen)1);
*istyp1 = TRUE_;
/* Open star catalog file with low level "open for read access" */
/* EK routine. */
ekopr_(catfnm, &tmphnd, catfnm_len);
/* Get the number of segments in the file and check whether it is */
/* greater than 0 (i.e. some data are is present in the file). If */
/* not then set an error message and return to the calling routine. */
numseg = eknseg_(&tmphnd);
if (numseg <= 0) {
s_copy(errmsg, "File contains no data.", errmsg_len, (ftnlen)22);
*istyp1 = FALSE_;
chkout_("STCC01", (ftnlen)6);
return 0;
}
/* Loop through the segments to find out whether all of them */
/* contain pieces of the same table. If not then set */
/* an error message and return to the calling routine. */
i__1 = numseg;
for (i__ = 1; i__ <= i__1; ++i__) {
ekssum_(&tmphnd, &i__, tmptnm, &nrows, &ncols, cnames, dtypes, sizes,
strlns, indexd, nullok, (ftnlen)64, (ftnlen)32, (ftnlen)4);
if (i__ > 1) {
if (s_cmp(tmptnm, tnmprv, (ftnlen)64, (ftnlen)64) != 0) {
s_copy(errmsg, "File contains more than one data table.",
errmsg_len, (ftnlen)39);
*istyp1 = FALSE_;
chkout_("STCC01", (ftnlen)6);
return 0;
}
}
s_copy(tnmprv, tmptnm, (ftnlen)64, (ftnlen)64);
}
/* Check whether the number of columns is less than it */
/* is supposed to be in type 1 star catalogs. If so then set */
/* an error message and return to a calling routine. */
if (ncols < 7) {
s_copy(errmsg, "File contains too few data columns.", errmsg_len, (
ftnlen)35);
*istyp1 = FALSE_;
chkout_("STCC01", (ftnlen)6);
return 0;
}
/* Check whether all columns that will be used in catalog search and */
/* star data fetching are present in the data table. If not */
/* then set an error message and return to a calling routine. */
for (i__ = 1; i__ <= 7; ++i__) {
found = FALSE_;
j = isrchc_(cat1nm + (((i__1 = i__ - 1) < 7 && 0 <= i__1 ? i__1 :
s_rnge("cat1nm", i__1, "stcc01_", (ftnlen)319)) << 5), &ncols,
cnames, (ftnlen)32, (ftnlen)32);
if (j > 0) {
found = s_cmp(cat1dt + (((i__1 = i__ - 1) < 7 && 0 <= i__1 ? i__1
: s_rnge("cat1dt", i__1, "stcc01_", (ftnlen)322)) << 2),
dtypes + (((i__2 = j - 1) < 100 && 0 <= i__2 ? i__2 :
s_rnge("dtypes", i__2, "stcc01_", (ftnlen)322)) << 2), (
ftnlen)4, (ftnlen)4) == 0 && ! nullok[(i__3 = j - 1) <
100 && 0 <= i__3 ? i__3 : s_rnge("nullok", i__3, "stcc01_"
, (ftnlen)322)];
}
if (! found) {
/* Writing concatenation */
i__4[0] = 8, a__1[0] = " Column ";
i__4[1] = nblen_(cat1nm + (((i__2 = i__ - 1) < 7 && 0 <= i__2 ?
i__2 : s_rnge("cat1nm", i__2, "stcc01_", (ftnlen)326)) <<
5), (ftnlen)32), a__1[1] = cat1nm + (((i__1 = i__ - 1) <
7 && 0 <= i__1 ? i__1 : s_rnge("cat1nm", i__1, "stcc01_",
(ftnlen)326)) << 5);
i__4[2] = 16, a__1[2] = " is not found or";
i__4[3] = 33, a__1[3] = " improperly declared in the file.";
s_cat(errmsg, a__1, i__4, &c__4, errmsg_len);
*istyp1 = FALSE_;
chkout_("STCC01", (ftnlen)6);
return 0;
}
}
/* If we got to this point then all checks were passed successfully */
/* and the file can be processed as a type 1 star catalog. We */
/* "return" the table name and close the file with the EK close */
/* routine. */
s_copy(tabnam, tmptnm, tabnam_len, (ftnlen)64);
ekcls_(&tmphnd);
chkout_("STCC01", (ftnlen)6);
return 0;
} /* stcc01_ */
/* $Procedure ZZXLATED ( Private --- Translate Double Precision Numbers ) */
/* Subroutine */ int zzxlated_(integer *inbff, char *input, integer *space,
doublereal *output, ftnlen input_len)
{
/* Initialized data */
static logical first = TRUE_;
static integer natbff = 0;
/* System generated locals */
integer i__1, i__2, i__3;
char ch__1[1];
static doublereal equiv_0[128];
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), i_len(char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int zzddhgsd_(char *, integer *, char *, ftnlen,
ftnlen), zzplatfm_(char *, char *, ftnlen, ftnlen);
integer i__, j, k;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen), errch_(char *, char *, ftnlen, ftnlen);
integer value;
extern /* Subroutine */ int moved_(doublereal *, integer *, doublereal *);
integer numdp;
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
static integer bigint;
#define dpbufr (equiv_0)
static char strbff[8*4];
#define inbufr ((integer *)equiv_0)
integer lenipt;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen);
extern integer intmin_(void);
extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen);
static integer smlint;
extern logical return_(void);
char tmpstr[8];
integer outpos;
/* $ Abstract */
/* SPICE Private routine intended solely for the support of SPICE */
/* routines. Users should not call this routine directly due */
/* to the volatile nature of this routine. */
/* Convert double precision values from one binary file format */
/* to another. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* PRIVATE */
/* $ Declarations */
/* $ Abstract */
/* Parameter declarations for the DAF/DAS handle manager. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* DAF, DAS */
/* $ Keywords */
/* PRIVATE */
/* $ Particulars */
/* This include file contains parameters defining limits and */
/* integer codes that are utilized in the DAF/DAS handle manager */
/* routines. */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 1.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 1.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 1.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 1.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 1.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 1.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 1.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 1.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 1.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 1.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 1.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 1.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 1.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 1.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 1.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 1.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 1.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 1.0.1, 17-JUL-2002 */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 1.0.0, 07-NOV-2001 */
/* -& */
/* Unit and file table size parameters. */
/* FTSIZE is the maximum number of files (DAS and DAF) that a */
/* user may have open simultaneously. */
/* RSVUNT is the number of units protected from being locked */
/* to a particular handle by ZZDDHHLU. */
/* SCRUNT is the number of units protected for use by scratch */
/* files. */
/* UTSIZE is the maximum number of logical units this manager */
/* will utilize at one time. */
/* Access method enumeration. These parameters are used to */
/* identify which access method is associated with a particular */
/* handle. They need to be synchronized with the STRAMH array */
/* defined in ZZDDHGSD in the following fashion: */
/* STRAMH ( READ ) = 'READ' */
/* STRAMH ( WRITE ) = 'WRITE' */
/* STRAMH ( SCRTCH ) = 'SCRATCH' */
/* STRAMH ( NEW ) = 'NEW' */
/* These values are used in the file table variable FTAMH. */
/* Binary file format enumeration. These parameters are used to */
/* identify which binary file format is associated with a */
/* particular handle. They need to be synchronized with the STRBFF */
/* array defined in ZZDDHGSD in the following fashion: */
/* STRBFF ( BIGI3E ) = 'BIG-IEEE' */
/* STRBFF ( LTLI3E ) = 'LTL-IEEE' */
/* STRBFF ( VAXGFL ) = 'VAX-GFLT' */
/* STRBFF ( VAXDFL ) = 'VAX-DFLT' */
/* These values are used in the file table variable FTBFF. */
/* Some random string lengths... more documentation required. */
/* For now this will have to suffice. */
/* Architecture enumeration. These parameters are used to identify */
/* which file architecture is associated with a particular handle. */
/* They need to be synchronized with the STRARC array defined in */
/* ZZDDHGSD in the following fashion: */
/* STRARC ( DAF ) = 'DAF' */
/* STRARC ( DAS ) = 'DAS' */
/* These values will be used in the file table variable FTARC. */
/* For the following environments, record length is measured in */
/* characters (bytes) with eight characters per double precision */
/* number. */
/* Environment: Sun, Sun FORTRAN */
/* Source: Sun Fortran Programmer's Guide */
/* Environment: PC, MS FORTRAN */
/* Source: Microsoft Fortran Optimizing Compiler User's Guide */
/* Environment: Macintosh, Language Systems FORTRAN */
/* Source: Language Systems FORTRAN Reference Manual, */
/* Version 1.2, page 12-7 */
/* Environment: PC/Linux, g77 */
/* Source: Determined by experiment. */
/* Environment: PC, Lahey F77 EM/32 Version 4.0 */
/* Source: Lahey F77 EM/32 Language Reference Manual, */
/* page 144 */
/* Environment: HP-UX 9000/750, FORTRAN/9000 Series 700 computers */
/* Source: FORTRAN/9000 Reference-Series 700 Computers, */
/* page 5-110 */
/* Environment: NeXT Mach OS (Black Hardware), */
/* Absoft Fortran Version 3.2 */
/* Source: NAIF Program */
/* The following parameter defines the size of a string used */
/* to store a filenames on this target platform. */
/* The following parameter controls the size of the character record */
/* buffer used to read data from non-native files. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* INBFF I Binary file format of d.p. values in INPUT. */
/* INPUT I String containing d.p. values read as characters. */
/* SPACE I Number of d.p. values that can be placed in OUTPUT. */
/* OUTPUT O Translated d.p. values. */
/* $ Detailed_Input */
/* INBFF is an integer code that indicates the binary file */
/* format of INPUT. Acceptable values are the */
/* parameters: */
/* BIGI3E */
/* LTLI3E */
/* VAXGFL */
/* VAXDFL */
/* as defined in the include file 'zzddhman.inc'. */
/* INPUT is a string containing a group of d.p. values read */
/* from a file as a character string. The length of */
/* this string must be a multiple of the number of */
/* bytes used to store a d.p. value in a file utilizing */
/* INBFF. */
/* SPACE is the number of d.p. values that OUTPUT has room to */
/* store. */
/* $ Detailed_Output */
/* OUTPUT is an array of double precision values containing */
/* the translated values from INPUT into the native */
/* binary format. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* This routine signals several SPICE(BUG) exceptions. They are */
/* signaled when improperly specified inputs are passed into the */
/* routine or if the module or modules in its calling tree are */
/* improperly configured to run on this platform. Callers that */
/* prevent invalid inputs from being passed into this routine */
/* need not check in. See the $Restrictions section for a */
/* discussion of input argument restrictions. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine translates double precision values from a non-native */
/* binary format read from a file as a sequence of characters to the */
/* native format. */
/* $ Examples */
/* See ZZDAFGSR or ZZDAFGDR. */
/* $ Restrictions */
/* 1) Numeric data when read as characters from a file preserves */
/* the bit patterns present in the file in memory. */
/* 2) The intrinsic ICHAR preserves the bit pattern of the character */
/* byte read from a file. Namely if one examines the integer */
/* created the 8 least significant bits will be precisely those */
/* found in the character. */
/* 3) The size of double precision values on the target environment */
/* are a multiple of some number of bytes. */
/* 4) The length of the INPUT string is a multiple of the number */
/* of bytes for a double precision value in the INBFF format. */
/* 5) INBFF is supported for reading on this platform, and not */
/* equivalent to NATBFF on this platform. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* $ Version */
/* - SPICELIB Version 1.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 1.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 1.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 1.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 1.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 1.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 1.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 1.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 1.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 1.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 1.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 1.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 1.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 1.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 1.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 1.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 1.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 1.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 1.0.1, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 1.0.0, 12-NOV-2001 (FST) */
/* -& */
/* SPICELIB Functions */
/* Local Parameters */
/* Length of the double precision and integer buffers that */
/* are equivalenced. */
/* These parameters are used for arithmetic shifting. */
/* Local Variables */
/* Equivalence DPBUFR to INBUFR. */
/* Statement Functions */
/* Saved Variables */
/* Data Statements */
/* Statement Function Definitions */
/* This function controls the conversion of characters to integers. */
/* On some supported environments, ICHAR is not sufficient to */
/* produce the desired results. This, however, is not the case */
/* with this particular environment. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZXLATED", (ftnlen)8);
}
/* Perform some initialization tasks. */
if (first) {
/* Populate STRBFF. */
for (i__ = 1; i__ <= 4; ++i__) {
zzddhgsd_("BFF", &i__, strbff + (((i__1 = i__ - 1) < 4 && 0 <=
i__1 ? i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)
354)) << 3), (ftnlen)3, (ftnlen)8);
}
/* Fetch the native binary file format. */
zzplatfm_("FILE_FORMAT", tmpstr, (ftnlen)11, (ftnlen)8);
ucase_(tmpstr, tmpstr, (ftnlen)8, (ftnlen)8);
natbff = isrchc_(tmpstr, &c__4, strbff, (ftnlen)8, (ftnlen)8);
if (natbff == 0) {
setmsg_("The binary file format, '#', is not supported by this v"
"ersion of the toolkit. This is a serious problem, contac"
"t NAIF.", (ftnlen)118);
errch_("#", tmpstr, (ftnlen)1, (ftnlen)8);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZXLATED", (ftnlen)8);
return 0;
}
/* Store the largest value a 32-bit integer can actually */
/* hold. */
bigint = 2147483647;
/* Prepare the smallest value a 32-bit integer can actually */
/* store, regardless of what INTMIN returns. */
smlint = intmin_();
/* Set SMLINT to the appropriate value if INTMIN is too large. */
if (smlint == -2147483647) {
--smlint;
}
/* Do not perform initialization tasks again. */
first = FALSE_;
}
/* Check to see if INBFF makes sense. */
if (*inbff < 1 || *inbff > 4) {
setmsg_("The integer code used to indicate the binary file format of"
" the input integers, #, is out of range. This error should "
"never occur.", (ftnlen)131);
errint_("#", inbff, (ftnlen)1);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZXLATED", (ftnlen)8);
return 0;
}
/* Retrieve the length of the input string, and set the position */
/* into the output buffer to the beginning. */
lenipt = i_len(input, input_len);
outpos = 1;
/* Now branch based on NATBFF. */
if (natbff == 1) {
if (*inbff == 2) {
/* Check to see that the length of the input string is */
/* appropriate. Since this is a string containing LTL-IEEE */
/* d.p. values, and this is a BIG-IEEE machine characters */
/* are 1-byte and d.p. values are 8-bytes. So the length */
/* of INPUT must be a multiple of 8. */
numdp = lenipt / 8;
if (lenipt - (numdp << 3) != 0) {
setmsg_("The input string that is to be translated from the "
"binary format # to format # has a length that is not"
" a multiple of 4 bytes. This error should never occ"
"ur.", (ftnlen)158);
errch_("#", strbff + (((i__1 = *inbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)
450)) << 3), (ftnlen)1, (ftnlen)8);
errch_("#", strbff + (((i__1 = natbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)
451)) << 3), (ftnlen)1, (ftnlen)8);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZXLATED", (ftnlen)8);
return 0;
}
/* Verify there is enough room to store the results of */
/* the translation. */
if (numdp > *space) {
setmsg_("The caller specified that # double precision number"
"s are to be translated from binary format # to #. H"
"owever there is only room to hold # integers in the "
"output array. This error should never occur.", (
ftnlen)200);
errint_("#", &numdp, (ftnlen)1);
errch_("#", strbff + (((i__1 = *inbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)
471)) << 3), (ftnlen)1, (ftnlen)8);
errch_("#", strbff + (((i__1 = natbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)
472)) << 3), (ftnlen)1, (ftnlen)8);
errint_("#", space, (ftnlen)1);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZXLATED", (ftnlen)8);
return 0;
}
/* The remainder of this branch is devoted to translating */
/* and copying blocks of DPBLEN double precision numbers */
/* into OUTPUT. Initialize K, the integer index into the */
/* buffer equivalenced to DPBUFR. */
k = 1;
/* Start looping over each 8 character package in INPUT and */
/* converting it to double precision numbers. */
i__1 = numdp;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Compute the substring index of the first character */
/* in INPUT for this integer. */
j = (i__ - 1 << 3) + 1;
/* Now arrange the bytes properly. Since these characters */
/* were read from a file utilizing LTL-IEEE: */
/* . */
/* . */
/* . */
/* ------- */
/* | J | - Least Significant Byte of Mantissa */
/* ------- */
/* | J+1 | - Sixth Most Significant Mantissa Byte */
/* ------- */
/* | J+2 | - Fifth Most Significant Mantissa Byte */
/* ------- */
/* | J+3 | - Fourth Most Significant Mantissa Byte */
/* ------- */
/* | J+4 | - Third Most Significant Mantissa Byte */
/* ------- */
/* | J+5 | - Second Most Significant Mantissa Byte */
/* ------- */
/* | J+6 | - Tail of Exponent, Most Significant */
/* ------- Bits of the Mantissa */
/* | J+7 | - Sign Bit, Head of Exponent */
/* ------- */
/* . */
/* . */
/* . */
/* Now rearrange the bytes to place them in the */
/* proper order for d.p. values on BIG-IEEE machines. */
/* This is accomplished in the following manner: */
/* INPUT(J+4:J+4) */
/* INPUT(J+5:J+5)*SHFT8 */
/* INPUT(J+6:J+6)*SHFT16 */
/* + INPUT(J+7:J+7)*SHFT24 */
/* ------------------------- */
/* INBUFR(K) */
/* INPUT(J:J) */
/* INPUT(J+1:J+1)*SHFT8 */
/* INPUT(J+2:J+2)*SHFT16 */
/* + INPUT(J+3:J+3)*SHFT24 */
/* ------------------------- */
/* INBUFR(K+1) */
/* Utilize the military extension bit manipulation */
/* intrinsics to perform the necessary computations. */
/* It has been determined empirically that on these */
/* environments this is faster than arithmetic. */
i__2 = j + 3;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 4 - i__2);
value = *(unsigned char *)&ch__1[0];
inbufr[(i__2 = k - 1) < 256 && 0 <= i__2 ? i__2 : s_rnge(
"inbufr", i__2, "zzxlated_", (ftnlen)553)] = value;
i__2 = j + 4;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 5 - i__2);
value = *(unsigned char *)&ch__1[0];
value <<= 8;
inbufr[(i__2 = k - 1) < 256 && 0 <= i__2 ? i__2 : s_rnge(
"inbufr", i__2, "zzxlated_", (ftnlen)557)] = inbufr[(
i__3 = k - 1) < 256 && 0 <= i__3 ? i__3 : s_rnge(
"inbufr", i__3, "zzxlated_", (ftnlen)557)] | value;
i__2 = j + 5;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 6 - i__2);
value = *(unsigned char *)&ch__1[0];
value <<= 16;
inbufr[(i__2 = k - 1) < 256 && 0 <= i__2 ? i__2 : s_rnge(
"inbufr", i__2, "zzxlated_", (ftnlen)561)] = inbufr[(
i__3 = k - 1) < 256 && 0 <= i__3 ? i__3 : s_rnge(
"inbufr", i__3, "zzxlated_", (ftnlen)561)] | value;
i__2 = j + 6;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 7 - i__2);
value = *(unsigned char *)&ch__1[0];
value <<= 24;
inbufr[(i__2 = k - 1) < 256 && 0 <= i__2 ? i__2 : s_rnge(
"inbufr", i__2, "zzxlated_", (ftnlen)565)] = inbufr[(
i__3 = k - 1) < 256 && 0 <= i__3 ? i__3 : s_rnge(
"inbufr", i__3, "zzxlated_", (ftnlen)565)] | value;
*(unsigned char *)&ch__1[0] = *(unsigned char *)&input[j - 1];
value = *(unsigned char *)&ch__1[0];
inbufr[(i__2 = k) < 256 && 0 <= i__2 ? i__2 : s_rnge("inbufr",
i__2, "zzxlated_", (ftnlen)569)] = value;
i__2 = j;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 1 - i__2);
value = *(unsigned char *)&ch__1[0];
value <<= 8;
inbufr[(i__2 = k) < 256 && 0 <= i__2 ? i__2 : s_rnge("inbufr",
i__2, "zzxlated_", (ftnlen)573)] = inbufr[(i__3 = k)
< 256 && 0 <= i__3 ? i__3 : s_rnge("inbufr", i__3,
"zzxlated_", (ftnlen)573)] | value;
i__2 = j + 1;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 2 - i__2);
value = *(unsigned char *)&ch__1[0];
value <<= 16;
inbufr[(i__2 = k) < 256 && 0 <= i__2 ? i__2 : s_rnge("inbufr",
i__2, "zzxlated_", (ftnlen)577)] = inbufr[(i__3 = k)
< 256 && 0 <= i__3 ? i__3 : s_rnge("inbufr", i__3,
"zzxlated_", (ftnlen)577)] | value;
i__2 = j + 2;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 3 - i__2);
value = *(unsigned char *)&ch__1[0];
value <<= 24;
inbufr[(i__2 = k) < 256 && 0 <= i__2 ? i__2 : s_rnge("inbufr",
i__2, "zzxlated_", (ftnlen)581)] = inbufr[(i__3 = k)
< 256 && 0 <= i__3 ? i__3 : s_rnge("inbufr", i__3,
"zzxlated_", (ftnlen)581)] | value;
/* Check to see if the local buffer is full and the */
/* double precision numbers need to be moved into the */
/* next block of OUTPUT. */
if (k == 255) {
moved_(dpbufr, &c__128, &output[outpos - 1]);
outpos += 128;
k = 1;
/* Otherwise, increment K. */
} else {
k += 2;
}
}
/* Copy any remaining double precision numbers from DPBUFR */
/* into OUTPUT. */
if (k != 1) {
i__1 = k / 2;
moved_(dpbufr, &i__1, &output[outpos - 1]);
}
} else {
setmsg_("Unable to translate double precision values from binary"
" file format # to #. This error should never occur and i"
"s indicative of a bug. Contact NAIF.", (ftnlen)148);
errch_("#", strbff + (((i__1 = *inbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)618))
<< 3), (ftnlen)1, (ftnlen)8);
errch_("#", strbff + (((i__1 = natbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)619))
<< 3), (ftnlen)1, (ftnlen)8);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZXLATED", (ftnlen)8);
return 0;
}
} else if (natbff == 2) {
if (*inbff == 1) {
/* Check to see that the length of the input string is */
/* appropriate. Since this is a string containing BIG-IEEE */
/* d.p. values, and this is a LTL-IEEE machine characters */
/* are 1-byte and d.p. values are 8-bytes. So the length */
/* of INPUT must be a multiple of 8. */
numdp = lenipt / 8;
if (lenipt - (numdp << 3) != 0) {
setmsg_("The input string that is to be translated from the "
"binary format # to format # has a length that is not"
" a multiple of 4 bytes. This error should never occ"
"ur.", (ftnlen)158);
errch_("#", strbff + (((i__1 = *inbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)
646)) << 3), (ftnlen)1, (ftnlen)8);
errch_("#", strbff + (((i__1 = natbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)
647)) << 3), (ftnlen)1, (ftnlen)8);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZXLATED", (ftnlen)8);
return 0;
}
/* Verify there is enough room to store the results of */
/* the translation. */
if (numdp > *space) {
setmsg_("The caller specified that # double precision number"
"s are to be translated from binary format # to #. H"
"owever there is only room to hold # integers in the "
"output array. This error should never occur.", (
ftnlen)200);
errint_("#", &numdp, (ftnlen)1);
errch_("#", strbff + (((i__1 = *inbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)
667)) << 3), (ftnlen)1, (ftnlen)8);
errch_("#", strbff + (((i__1 = natbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)
668)) << 3), (ftnlen)1, (ftnlen)8);
errint_("#", space, (ftnlen)1);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZXLATED", (ftnlen)8);
return 0;
}
/* The remainder of this branch is devoted to translating */
/* and copying blocks of DPBLEN double precision numbers */
/* into OUTPUT. Initialize K, the integer index into the */
/* buffer equivalenced to DPBUFR. */
k = 1;
/* Start looping over each 8 character package in INPUT and */
/* converting them to double precision numbers. */
i__1 = numdp;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Compute the substring index of the first character */
/* in INPUT for this integer. */
j = (i__ - 1 << 3) + 1;
/* Now arrange the bytes properly. Since these characters */
/* were read from a file utilizing BIG-IEEE: */
/* . */
/* . */
/* . */
/* ------- */
/* | J | - Sign Bit, Head of Exponent */
/* ------- */
/* | J+1 | - Tail of Exponent, Most Significant */
/* ------- Bits of the Mantissa */
/* | J+2 | - Second Most Significant Mantissa Byte */
/* ------- */
/* | J+3 | - Third Most Significant Mantissa Byte */
/* ------- */
/* | J+4 | - Fourth Most Significant Mantissa Byte */
/* ------- */
/* | J+5 | - Fifth Most Significant Mantissa Byte */
/* ------- */
/* | J+6 | - Sixth Most Significant Mantissa Byte */
/* ------- */
/* | J+7 | - Least Significant Byte of Mantissa */
/* ------- */
/* . */
/* . */
/* . */
/* Now rearrange the bytes to place them in the */
/* proper order for d.p. values on LTL-IEEE machines. */
/* This is accomplished in the following manner: */
/* INPUT(J+7:J+7) */
/* INPUT(J+6:J+6)*SHFT8 */
/* INPUT(J+5:J+5)*SHFT16 */
/* + INPUT(J+4:J+4)*SHFT24 */
/* ------------------------- */
/* INBUFR(K) */
/* INPUT(J+3:J+3) */
/* INPUT(J+2:J+2)*SHFT8 */
/* INPUT(J+1:J+1)*SHFT16 */
/* + INPUT(J:J)*SHFT24 */
/* ------------------------- */
/* INBUFR(K+1) */
/* Utilize the military extension bit manipulation */
/* intrinsics to perform the necessary computations. */
/* It has been determined empirically that on these */
/* environments this is faster than arithmetic. */
i__2 = j + 6;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 7 - i__2);
value = *(unsigned char *)&ch__1[0];
inbufr[(i__2 = k - 1) < 256 && 0 <= i__2 ? i__2 : s_rnge(
"inbufr", i__2, "zzxlated_", (ftnlen)749)] = value;
i__2 = j + 5;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 6 - i__2);
value = *(unsigned char *)&ch__1[0];
value <<= 8;
inbufr[(i__2 = k - 1) < 256 && 0 <= i__2 ? i__2 : s_rnge(
"inbufr", i__2, "zzxlated_", (ftnlen)753)] = inbufr[(
i__3 = k - 1) < 256 && 0 <= i__3 ? i__3 : s_rnge(
"inbufr", i__3, "zzxlated_", (ftnlen)753)] | value;
i__2 = j + 4;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 5 - i__2);
value = *(unsigned char *)&ch__1[0];
value <<= 16;
inbufr[(i__2 = k - 1) < 256 && 0 <= i__2 ? i__2 : s_rnge(
"inbufr", i__2, "zzxlated_", (ftnlen)757)] = inbufr[(
i__3 = k - 1) < 256 && 0 <= i__3 ? i__3 : s_rnge(
"inbufr", i__3, "zzxlated_", (ftnlen)757)] | value;
i__2 = j + 3;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 4 - i__2);
value = *(unsigned char *)&ch__1[0];
value <<= 24;
inbufr[(i__2 = k - 1) < 256 && 0 <= i__2 ? i__2 : s_rnge(
"inbufr", i__2, "zzxlated_", (ftnlen)761)] = inbufr[(
i__3 = k - 1) < 256 && 0 <= i__3 ? i__3 : s_rnge(
"inbufr", i__3, "zzxlated_", (ftnlen)761)] | value;
i__2 = j + 2;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 3 - i__2);
value = *(unsigned char *)&ch__1[0];
inbufr[(i__2 = k) < 256 && 0 <= i__2 ? i__2 : s_rnge("inbufr",
i__2, "zzxlated_", (ftnlen)765)] = value;
i__2 = j + 1;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 2 - i__2);
value = *(unsigned char *)&ch__1[0];
value <<= 8;
inbufr[(i__2 = k) < 256 && 0 <= i__2 ? i__2 : s_rnge("inbufr",
i__2, "zzxlated_", (ftnlen)769)] = inbufr[(i__3 = k)
< 256 && 0 <= i__3 ? i__3 : s_rnge("inbufr", i__3,
"zzxlated_", (ftnlen)769)] | value;
i__2 = j;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 1 - i__2);
value = *(unsigned char *)&ch__1[0];
value <<= 16;
inbufr[(i__2 = k) < 256 && 0 <= i__2 ? i__2 : s_rnge("inbufr",
i__2, "zzxlated_", (ftnlen)773)] = inbufr[(i__3 = k)
< 256 && 0 <= i__3 ? i__3 : s_rnge("inbufr", i__3,
"zzxlated_", (ftnlen)773)] | value;
*(unsigned char *)&ch__1[0] = *(unsigned char *)&input[j - 1];
value = *(unsigned char *)&ch__1[0];
value <<= 24;
inbufr[(i__2 = k) < 256 && 0 <= i__2 ? i__2 : s_rnge("inbufr",
i__2, "zzxlated_", (ftnlen)777)] = inbufr[(i__3 = k)
< 256 && 0 <= i__3 ? i__3 : s_rnge("inbufr", i__3,
"zzxlated_", (ftnlen)777)] | value;
/* Check to see if the local buffer is full and the */
/* double precision numbers need to be moved into the */
/* next block of OUTPUT. */
if (k == 255) {
moved_(dpbufr, &c__128, &output[outpos - 1]);
outpos += 128;
k = 1;
/* Otherwise, increment K. */
} else {
k += 2;
}
}
/* Copy any remaining double precision numbers from DPBUFR */
/* into OUTPUT. */
if (k != 1) {
i__1 = k / 2;
moved_(dpbufr, &i__1, &output[outpos - 1]);
}
} else {
setmsg_("Unable to translate double precision values from binary"
" file format # to #. This error should never occur and i"
"s indicative of a bug. Contact NAIF.", (ftnlen)148);
errch_("#", strbff + (((i__1 = *inbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)814))
<< 3), (ftnlen)1, (ftnlen)8);
errch_("#", strbff + (((i__1 = natbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)815))
<< 3), (ftnlen)1, (ftnlen)8);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZXLATED", (ftnlen)8);
return 0;
}
/* The native binary file format on this platform is not supported */
/* for the conversion of integers. This is a bug, as this branch */
/* of code should never be reached in normal operation. */
} else {
setmsg_("The native binary file format of this toolkit build, #, is "
"not currently supported for translation of double precision "
"numbers from non-native formats.", (ftnlen)151);
errch_("#", strbff + (((i__1 = natbff - 1) < 4 && 0 <= i__1 ? i__1 :
s_rnge("strbff", i__1, "zzxlated_", (ftnlen)833)) << 3), (
ftnlen)1, (ftnlen)8);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZXLATED", (ftnlen)8);
return 0;
}
chkout_("ZZXLATED", (ftnlen)8);
return 0;
} /* zzxlated_ */
/* $Procedure ZZDAFGFR ( Private --- DAF Get Data Record ) */
/* Subroutine */ int zzdafgfr_(integer *handle, char *idword, integer *nd,
integer *ni, char *ifname, integer *fward, integer *bward, integer *
free, logical *found, ftnlen idword_len, ftnlen ifname_len)
{
/* Initialized data */
static logical first = TRUE_;
static integer natbff = 0;
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), s_rdue(cilist *),
do_uio(integer *, char *, ftnlen), e_rdue(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer ibff, iamh;
extern /* Subroutine */ int zzddhgsd_(char *, integer *, char *, ftnlen,
ftnlen), zzddhnfo_(integer *, char *, integer *, integer *,
integer *, logical *, ftnlen), zzddhhlu_(integer *, char *,
logical *, integer *, ftnlen), zzplatfm_(char *, char *, ftnlen,
ftnlen), zzxlatei_(integer *, char *, integer *, integer *,
ftnlen);
integer i__;
char fname[255];
integer iarch;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer locnd;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
integer locni;
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen);
extern logical failed_(void);
logical locfnd;
char chrbuf[1024], locifn[60];
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
integer cindex, locbwd;
char locidw[8];
integer locfre;
static char strbff[8*4];
integer locfwd;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
extern logical return_(void);
char tmpstr[8];
integer lun;
/* Fortran I/O blocks */
static cilist io___13 = { 1, 0, 1, 0, 1 };
static cilist io___21 = { 1, 0, 1, 0, 1 };
/* $ Abstract */
/* SPICE Private routine intended solely for the support of SPICE */
/* routines. Users should not call this routine directly due */
/* to the volatile nature of this routine. */
/* Read the contents of the file record of a DAF. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* PRIVATE */
/* $ Declarations */
/* $ Abstract */
/* Parameter declarations for the DAF/DAS handle manager. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* DAF, DAS */
/* $ Keywords */
/* PRIVATE */
/* $ Particulars */
/* This include file contains parameters defining limits and */
/* integer codes that are utilized in the DAF/DAS handle manager */
/* routines. */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 2.5.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 2.4.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 2.3.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 2.2.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 2.1.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 2.0.0, 12-APR-2012 (BVS) */
/* Increased FTSIZE (from 1000 to 5000). */
/* - SPICELIB Version 1.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 1.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 1.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 1.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 1.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 1.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 1.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 1.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 1.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 1.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 1.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 1.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 1.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 1.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 1.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 1.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 1.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 1.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 1.0.1, 17-JUL-2002 */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 1.0.0, 07-NOV-2001 */
/* -& */
/* Unit and file table size parameters. */
/* FTSIZE is the maximum number of files (DAS and DAF) that a */
/* user may have open simultaneously. */
/* RSVUNT is the number of units protected from being locked */
/* to a particular handle by ZZDDHHLU. */
/* SCRUNT is the number of units protected for use by scratch */
/* files. */
/* UTSIZE is the maximum number of logical units this manager */
/* will utilize at one time. */
/* Access method enumeration. These parameters are used to */
/* identify which access method is associated with a particular */
/* handle. They need to be synchronized with the STRAMH array */
/* defined in ZZDDHGSD in the following fashion: */
/* STRAMH ( READ ) = 'READ' */
/* STRAMH ( WRITE ) = 'WRITE' */
/* STRAMH ( SCRTCH ) = 'SCRATCH' */
/* STRAMH ( NEW ) = 'NEW' */
/* These values are used in the file table variable FTAMH. */
/* Binary file format enumeration. These parameters are used to */
/* identify which binary file format is associated with a */
/* particular handle. They need to be synchronized with the STRBFF */
/* array defined in ZZDDHGSD in the following fashion: */
/* STRBFF ( BIGI3E ) = 'BIG-IEEE' */
/* STRBFF ( LTLI3E ) = 'LTL-IEEE' */
/* STRBFF ( VAXGFL ) = 'VAX-GFLT' */
/* STRBFF ( VAXDFL ) = 'VAX-DFLT' */
/* These values are used in the file table variable FTBFF. */
/* Some random string lengths... more documentation required. */
/* For now this will have to suffice. */
/* Architecture enumeration. These parameters are used to identify */
/* which file architecture is associated with a particular handle. */
/* They need to be synchronized with the STRARC array defined in */
/* ZZDDHGSD in the following fashion: */
/* STRARC ( DAF ) = 'DAF' */
/* STRARC ( DAS ) = 'DAS' */
/* These values will be used in the file table variable FTARC. */
/* For the following environments, record length is measured in */
/* characters (bytes) with eight characters per double precision */
/* number. */
/* Environment: Sun, Sun FORTRAN */
/* Source: Sun Fortran Programmer's Guide */
/* Environment: PC, MS FORTRAN */
/* Source: Microsoft Fortran Optimizing Compiler User's Guide */
/* Environment: Macintosh, Language Systems FORTRAN */
/* Source: Language Systems FORTRAN Reference Manual, */
/* Version 1.2, page 12-7 */
/* Environment: PC/Linux, g77 */
/* Source: Determined by experiment. */
/* Environment: PC, Lahey F77 EM/32 Version 4.0 */
/* Source: Lahey F77 EM/32 Language Reference Manual, */
/* page 144 */
/* Environment: HP-UX 9000/750, FORTRAN/9000 Series 700 computers */
/* Source: FORTRAN/9000 Reference-Series 700 Computers, */
/* page 5-110 */
/* Environment: NeXT Mach OS (Black Hardware), */
/* Absoft Fortran Version 3.2 */
/* Source: NAIF Program */
/* The following parameter defines the size of a string used */
/* to store a filenames on this target platform. */
/* The following parameter controls the size of the character record */
/* buffer used to read data from non-native files. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle of the DAF. */
/* IDWORD O DAF ID Word that indicates file type. */
/* ND O Number of double precision components in summaries. */
/* NI O Number of integer components in summaries. */
/* IFNAME O Internal file name. */
/* FWARD O Forward list pointer. */
/* BWARD O Backward list pointer. */
/* FREE O Free address pointer. */
/* FOUND O Logical indicating whether the record was found. */
/* $ Detailed_Input */
/* HANDLE is the handle associated with the DAF. */
/* $ Detailed_Output */
/* IDWORD is a character string identifying the architecture */
/* and type of a SPICE binary kernel. In this case */
/* it will be a string identifying the type of DAF. */
/* ND, */
/* NI are the number of double precision and integer */
/* components, respectively, in each array summary in */
/* the specified file. */
/* IFNAME is the internal file name stored in the first */
/* (or file) record of the specified file. */
/* FWARD is the forward list pointer. This points to the */
/* first summary record in the file. (Records between */
/* the first record and the first summary record are */
/* reserved when the file is created, and are invisible */
/* to DAF routines.) */
/* BWARD is the backward list pointer. This points */
/* to the final summary record in the file. */
/* FREE is the free address pointer. This contains the */
/* first free address in the file. (That is, the */
/* initial address of the next array to be added */
/* to the file.) */
/* FOUND is TRUE when the file record is found, and is */
/* FALSE otherwise. */
/* $ Parameters */
/* None. */
/* $ Files */
/* This routine reads data from the DAF associated with HANDLE. */
/* This action may result in connecting a logical unit to the */
/* file, if the handle manager has rotated the file out of the */
/* unit table. */
/* $ Exceptions */
/* 1) SPICE(HANDLENOTFOUND) is signaled if HANDLE can not be */
/* found in the set of loaded handles. The output arguments */
/* are unmodified when this error occurs. */
/* 2) Routines in the call tree of this routine may trap and */
/* signal errors. The output arguments are unmodified in */
/* these cases. */
/* $ Particulars */
/* This routine reads the publically available components of */
/* file records from native and supported non-native DAFs. */
/* The size of the character buffer and the number of records */
/* read may have to change to support new environments. As of */
/* the original release of this routine, all systems currently */
/* supported have a 1 kilobyte record length. */
/* $ Examples */
/* See DAFRFR for sample usage. */
/* $ Restrictions */
/* 1) Numeric data when read as characters from a file preserves */
/* the bit patterns present in the file in memory. */
/* 2) A record of double precision data is at most 1024 characters */
/* in length. */
/* 3) Future updates to this module must preserve the fact that */
/* FOUND is returned as FALSE whenever an error occurs. An */
/* incompletely translated or extracted file record is NOT */
/* FOUND. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 12-NOV-2001 (FST) */
/* -& */
/* SPICELIB Functions */
/* Local Parameters */
/* Record Number of the file record in a DAF. */
/* Length of the IDWORD string. */
/* Length of the internal filename string. */
/* Starting location in bytes of the internal filename in the */
/* file record. */
/* Size of an integer in bytes. */
/* Local Variables */
/* Saved Variables */
/* Data Statements */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZDAFGFR", (ftnlen)8);
}
/* Perform some initialization tasks. */
if (first) {
/* Populate STRBFF, the buffer that contains the labels */
/* for each binary file format. */
for (i__ = 1; i__ <= 4; ++i__) {
zzddhgsd_("BFF", &i__, strbff + (((i__1 = i__ - 1) < 4 && 0 <=
i__1 ? i__1 : s_rnge("strbff", i__1, "zzdafgfr_", (ftnlen)
275)) << 3), (ftnlen)3, (ftnlen)8);
}
/* Fetch the native binary file format and determine its */
/* integer code. */
zzplatfm_("FILE_FORMAT", tmpstr, (ftnlen)11, (ftnlen)8);
ucase_(tmpstr, tmpstr, (ftnlen)8, (ftnlen)8);
natbff = isrchc_(tmpstr, &c__4, strbff, (ftnlen)8, (ftnlen)8);
if (natbff == 0) {
setmsg_("The binary file format, '#', is not supported by this v"
"ersion of the toolkit. This is a serious problem, contac"
"t NAIF.", (ftnlen)118);
errch_("#", tmpstr, (ftnlen)1, (ftnlen)8);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZDAFGFR", (ftnlen)8);
return 0;
}
/* Do not perform initialization tasks again. */
first = FALSE_;
}
/* Assume the data record will not be found, until it has been read */
/* from the file, and if necessary, successfully translated. */
*found = FALSE_;
/* Retrieve information regarding the file from the handle manager. */
/* The value of IARCH is not a concern, since this is a DAF routine */
/* all values passed into handle manager entry points will have */
/* 'DAF' as their architecture arguments. */
zzddhnfo_(handle, fname, &iarch, &ibff, &iamh, &locfnd, (ftnlen)255);
if (! locfnd) {
setmsg_("Unable to locate file associated with HANDLE, #. The most "
"likely cause of this is the file that you are trying to read"
" has been closed.", (ftnlen)136);
errint_("#", handle, (ftnlen)1);
sigerr_("SPICE(HANDLENOTFOUND)", (ftnlen)21);
chkout_("ZZDAFGFR", (ftnlen)8);
return 0;
}
/* Now get a logical unit for the handle. Check FAILED() in */
/* case an error occurs. */
zzddhhlu_(handle, "DAF", &c_false, &lun, (ftnlen)3);
if (failed_()) {
chkout_("ZZDAFGFR", (ftnlen)8);
return 0;
}
/* Branch based on whether the binary file format is native */
/* or not. Only supported formats can be opened by ZZDDHOPN, */
/* so no check of IBFF is required. */
if (ibff == natbff) {
/* In the native case, just read the components of the file */
/* record from the file. */
io___13.ciunit = lun;
iostat = s_rdue(&io___13);
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, locidw, (ftnlen)8);
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, (char *)&locnd, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, (char *)&locni, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, locifn, (ftnlen)60);
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, (char *)&locfwd, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, (char *)&locbwd, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, (char *)&locfre, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100001;
}
iostat = e_rdue();
L100001:
/* Since this routine does not signal any IOSTAT based */
/* errors, return if a non-zero value is assigned to IOSTAT. */
if (iostat != 0) {
chkout_("ZZDAFGFR", (ftnlen)8);
return 0;
}
/* Process the non-native binary file format case. */
} else {
/* Read the data record as characters. */
io___21.ciunit = lun;
iostat = s_rdue(&io___21);
if (iostat != 0) {
goto L100002;
}
iostat = do_uio(&c__1, chrbuf, (ftnlen)1024);
if (iostat != 0) {
goto L100002;
}
iostat = e_rdue();
L100002:
/* Again, since this routine does not signal any IOSTAT */
/* based errors, return if one occurs. */
if (iostat != 0) {
chkout_("ZZDAFGFR", (ftnlen)8);
return 0;
}
/* Assign the character components of the file record. */
s_copy(locidw, chrbuf, (ftnlen)8, (ftnlen)8);
s_copy(locifn, chrbuf + 16, (ftnlen)60, (ftnlen)60);
/* Convert the integer components. */
cindex = 9;
zzxlatei_(&ibff, chrbuf + (cindex - 1), &c__1, &locnd, (ftnlen)4);
cindex += 4;
zzxlatei_(&ibff, chrbuf + (cindex - 1), &c__1, &locni, (ftnlen)4);
cindex = 77;
zzxlatei_(&ibff, chrbuf + (cindex - 1), &c__1, &locfwd, (ftnlen)4);
cindex += 4;
zzxlatei_(&ibff, chrbuf + (cindex - 1), &c__1, &locbwd, (ftnlen)4);
cindex += 4;
zzxlatei_(&ibff, chrbuf + (cindex - 1), &c__1, &locfre, (ftnlen)4);
if (failed_()) {
chkout_("ZZDAFGFR", (ftnlen)8);
return 0;
}
}
/* Transfer the contents of the record to the output arguments */
/* and return to the caller. */
*found = TRUE_;
s_copy(idword, locidw, idword_len, (ftnlen)8);
*nd = locnd;
*ni = locni;
s_copy(ifname, locifn, ifname_len, (ftnlen)60);
*fward = locfwd;
*bward = locbwd;
*free = locfre;
chkout_("ZZDAFGFR", (ftnlen)8);
return 0;
} /* zzdafgfr_ */
/* $Procedure ANA ( AN or A ? ) */
/* Character */ VOID ana_(char *ret_val, ftnlen ret_val_len, char *word, char
*case__, ftnlen word_len, ftnlen case_len)
{
/* Initialized data */
static char a[2*3] = "A " "A " "a ";
static char an[2*3] = "AN" "An" "an";
static char anword[8*22] = "HEIR " "HONEST " "HONOR " "H "
"HOUR " "HORS " "HOMBRE " "F " "L " "M "
"N " "R " "S " "X " "UNIN " "UNIM "
"ONEI " "ONER " "SPK " "EK " "IK " "SCLK ";
static char aword[8*33] = "HORSE " "ONE " "ONE- " "ONCE "
"ONENESS " "UIG " "UIN " "UKA " "UKE " "UKO "
"UKI " "UKU " "ULOT " "UNANI " "UNI " "UNINU "
"UPA " "URA " "URE " "URO " "USA " "USE "
"USU " "UTE " "UTI " "UTO " "UVA " "UVE "
"UVU " "EU " "EWE " "UTRI " "U ";
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_indx(char *, char *, ftnlen, ftnlen), s_rnge(char *, integer,
char *, integer);
/* Local variables */
static integer caps, i__;
static char begin[1];
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
static char start[32*7];
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int replch_(char *, char *, char *, char *,
ftnlen, ftnlen, ftnlen, ftnlen);
static char mycase[1], myword[32];
/* $ Abstract */
/* Return the correct article "a" or "an" used to modify a word */
/* and return it capitalized, lower case, or upper case. */
/* $ 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 */
/* WORD */
/* $ Keywords */
/* UTILITY */
/* WORD */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* WORD I is a word that should be modified by "a" or "an" */
/* CASE I 'U', 'L', or 'C' to specify capitalization of ANA. */
/* ANA O 'A' or 'AN' appropriately capitalized. */
/* $ Detailed_Input */
/* WORD is any english word for which you want to write the */
/* correct phrase "a(an) response(answer)". The case */
/* of the letters of word do not matter. */
/* Leading white space in word is ignored. The characters */
/* " and ' are ignored. Thus ''' apple '' ' and */
/* '"apple"' and ' apple' and 'apple' are all treated as */
/* the same word. */
/* CASE is a character that describes how the value returned */
/* in ANA should be capitalized. The rules are: */
/* 'U' --- ANA is returned in all caps ( A, AN ) */
/* 'C' --- ANA is returned capitalized ( A, An ) */
/* 'L' --- ANA is returned lower case ( a, an ) */
/* The case of CASE does not matter. Any value other */
/* than those specified result in ANA being returned */
/* in all lower case. */
/* $ Detailed_Output */
/* ANA is a character function an will return the correct */
/* indefinite article needed to modify the word contained */
/* in WORD. ANA should be declared to be CHARACTER*(2) */
/* (or CHARACTER*(N) where N > 1) in the calling */
/* program. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error Free */
/* 1) If the uppercase value of CASE is not 'U', 'C' or 'L', it shall */
/* be treated as 'L'. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine allows you to construct grammatically correct phrases */
/* when you need to modify a word by an indefinite article. Using */
/* the pronunciations contained in the Webster's Ninth Collegiate */
/* Dictionary, the phrase */
/* ANA(WORD, CASE) // ' ' // WORD */
/* will be grammatically correct. */
/* $ Examples */
/* Suppose you wished to construct one of the messages */
/* 'a new file' */
/* 'an existing file' */
/* and that the NEW/EXISTING word was in the variable WORD. Then */
/* you could write */
/* MESSAGE = ANA( WORD, 'L' ) // ' ' // WORD // ' file ' */
/* CALL CMPRSS ( ' ', 1, MESSAGE, MESSAGE ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* Webster's Ninth Collegiate Dictionary. */
/* $ Author_and_Institution */
/* B.V. Semenov (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.2, 28-FEB-2008 (BVS) */
/* Corrected the contents of the Required_Reading section. */
/* - SPICELIB Version 1.1.1, 22-SEP-2004 (EDW) */
/* Added Copyright section. */
/* - SPICELIB Version 1.1.0, 18-JAN-2001 (WLT) */
/* Made SCLK and "an" word. */
/* - SPICELIB Version 1.0.0, 29-NOV-1995 (WLT) */
/* -& */
/* $ Index_Entries */
/* GET THE CORRECT INDEFINITE ARTICLE */
/* -& */
ucase_(word, myword, word_len, (ftnlen)32);
replch_(myword, "'", " ", myword, (ftnlen)32, (ftnlen)1, (ftnlen)1, (
ftnlen)32);
replch_(myword, "\"", " ", myword, (ftnlen)32, (ftnlen)1, (ftnlen)1, (
ftnlen)32);
ljust_(myword, myword, (ftnlen)32, (ftnlen)32);
ucase_(case__, mycase, case_len, (ftnlen)1);
s_copy(ret_val, " ", ret_val_len, (ftnlen)1);
if (*(unsigned char *)mycase == 'U') {
caps = 1;
} else if (*(unsigned char *)mycase == 'C') {
caps = 2;
} else {
caps = 3;
}
/* Handle the obvious things first. */
*(unsigned char *)begin = *(unsigned char *)myword;
if (i_indx("AI", begin, (ftnlen)2, (ftnlen)1) > 0) {
s_copy(ret_val, an + (((i__1 = caps - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("an", i__1, "ana_", (ftnlen)235)) << 1), ret_val_len, (
ftnlen)2);
return ;
} else if (i_indx("BCDGJKPQTVWYZ", begin, (ftnlen)13, (ftnlen)1) > 0) {
s_copy(ret_val, a + (((i__1 = caps - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("a", i__1, "ana_", (ftnlen)240)) << 1), ret_val_len, (
ftnlen)2);
return ;
}
/* If we are still here, we need to be a bit more careful */
/* in our determination of ANA. */
/* Get the beginnings of the input word. */
for (i__ = 1; i__ <= 7; ++i__) {
s_copy(start + (((i__1 = i__ - 1) < 7 && 0 <= i__1 ? i__1 : s_rnge(
"start", i__1, "ana_", (ftnlen)252)) << 5), myword, (ftnlen)
32, i__);
}
/* Now see if the start of the input word belongs to */
/* one of the special collections. */
for (i__ = 7; i__ >= 2; --i__) {
if (isrchc_(start + (((i__1 = i__ - 1) < 7 && 0 <= i__1 ? i__1 :
s_rnge("start", i__1, "ana_", (ftnlen)261)) << 5), &c__33,
aword, (ftnlen)32, (ftnlen)8) != 0) {
s_copy(ret_val, a + (((i__1 = caps - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("a", i__1, "ana_", (ftnlen)263)) << 1),
ret_val_len, (ftnlen)2);
return ;
}
if (isrchc_(start + (((i__1 = i__ - 1) < 7 && 0 <= i__1 ? i__1 :
s_rnge("start", i__1, "ana_", (ftnlen)268)) << 5), &c__22,
anword, (ftnlen)32, (ftnlen)8) != 0) {
s_copy(ret_val, an + (((i__1 = caps - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("an", i__1, "ana_", (ftnlen)270)) << 1),
ret_val_len, (ftnlen)2);
return ;
}
}
/* If we got this far we can determine the ANAe by */
/* just looking at the beginning of the string. */
if (i_indx("AEIOU", myword, (ftnlen)5, (ftnlen)1) > 0) {
s_copy(ret_val, an + (((i__1 = caps - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("an", i__1, "ana_", (ftnlen)282)) << 1), ret_val_len, (
ftnlen)2);
} else {
s_copy(ret_val, a + (((i__1 = caps - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("a", i__1, "ana_", (ftnlen)286)) << 1), ret_val_len, (
ftnlen)2);
}
return ;
} /* ana_ */
/* $Procedure ZZSPKAP1 ( S/P Kernel, apparent state ) */
/* Subroutine */ int zzspkap1_(integer *targ, doublereal *et, char *ref,
doublereal *sobs, char *abcorr, doublereal *starg, doublereal *lt,
ftnlen ref_len, ftnlen abcorr_len)
{
/* Initialized data */
static logical first = TRUE_;
static char flags[5*9] = "NONE " "LT " "LT+S " "CN " "CN+S " "XLT "
"XLT+S" "XCN " "XCN+S";
static char prvcor[5] = " ";
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char corr[5];
extern /* Subroutine */ int zzspksb1_(integer *, doublereal *, char *,
doublereal *, ftnlen);
static logical xmit;
extern /* Subroutine */ int vequ_(doublereal *, doublereal *);
integer i__, refid;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen), moved_(doublereal *, integer *, doublereal *);
static logical usecn;
doublereal sapos[3];
extern /* Subroutine */ int vsubg_(doublereal *, doublereal *, integer *,
doublereal *);
static logical uselt;
extern doublereal vnorm_(doublereal *), clight_(void);
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int stelab_(doublereal *, doublereal *,
doublereal *), sigerr_(char *, ftnlen), chkout_(char *, ftnlen),
stlabx_(doublereal *, doublereal *, doublereal *);
integer ltsign;
extern /* Subroutine */ int ljucrs_(integer *, char *, char *, ftnlen,
ftnlen), setmsg_(char *, ftnlen);
doublereal tstate[6];
integer maxitr;
extern /* Subroutine */ int irfnum_(char *, integer *, ftnlen);
extern logical return_(void);
static logical usestl;
extern logical odd_(integer *);
/* $ Abstract */
/* Deprecated: This routine has been superseded by SPKAPS. This */
/* routine is supported for purposes of backward compatibility only. */
/* Return the state (position and velocity) of a target body */
/* relative to an observer, optionally corrected for light time and */
/* stellar aberration. */
/* $ 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 */
/* SPK */
/* $ Keywords */
/* EPHEMERIS */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* TARG I Target body. */
/* ET I Observer epoch. */
/* REF I Inertial reference frame of observer's state. */
/* SOBS I State of observer wrt. solar system barycenter. */
/* ABCORR I Aberration correction flag. */
/* STARG O State of target. */
/* LT O One way light time between observer and target. */
/* $ Detailed_Input */
/* TARG is the NAIF ID code for a target body. The target */
/* and observer define a state vector whose position */
/* component points from the observer to the target. */
/* ET is the ephemeris time, expressed as seconds past J2000 */
/* TDB, at which the state of the target body relative to */
/* the observer is to be computed. ET refers to time at */
/* the observer's location. */
/* REF is the inertial reference frame with respect to which */
/* the observer's state SOBS is expressed. REF must be */
/* recognized by the SPICE Toolkit. The acceptable */
/* frames are listed in the Frames Required Reading, as */
/* well as in the SPICELIB routine CHGIRF. */
/* Case and blanks are not significant in the string REF. */
/* SOBS is the geometric (uncorrected) state of the observer */
/* relative to the solar system barycenter at epoch ET. */
/* SOBS is a 6-vector: the first three components of */
/* SOBS represent a Cartesian position vector; the last */
/* three components represent the corresponding velocity */
/* vector. SOBS is expressed relative to the inertial */
/* reference frame designated by REF. */
/* Units are always km and km/sec. */
/* ABCORR indicates the aberration corrections to be applied */
/* to the state of the target body to account for one-way */
/* light time and stellar aberration. See the discussion */
/* in the Particulars section for recommendations on */
/* how to choose aberration corrections. */
/* ABCORR may be any of the following: */
/* 'NONE' Apply no correction. Return the */
/* geometric state of the target body */
/* relative to the observer. */
/* The following values of ABCORR apply to the */
/* "reception" case in which photons depart from the */
/* target's location at the light-time corrected epoch */
/* ET-LT and *arrive* at the observer's location at ET: */
/* 'LT' Correct for one-way light time (also */
/* called "planetary aberration") using a */
/* Newtonian formulation. This correction */
/* yields the state of the target at the */
/* moment it emitted photons arriving at */
/* the observer at ET. */
/* The light time correction involves */
/* iterative solution of the light time */
/* equation (see Particulars for details). */
/* The solution invoked by the 'LT' option */
/* uses one iteration. */
/* 'LT+S' Correct for one-way light time and */
/* stellar aberration using a Newtonian */
/* formulation. This option modifies the */
/* state obtained with the 'LT' option to */
/* account for the observer's velocity */
/* relative to the solar system */
/* barycenter. The result is the apparent */
/* state of the target---the position and */
/* velocity of the target as seen by the */
/* observer. */
/* 'CN' Converged Newtonian light time */
/* correction. In solving the light time */
/* equation, the 'CN' correction iterates */
/* until the solution converges (three */
/* iterations on all supported platforms). */
/* Whether the 'CN+S' solution is */
/* substantially more accurate than the */
/* 'LT' solution depends on the geometry */
/* of the participating objects and on the */
/* accuracy of the input data. In all */
/* cases this routine will execute more */
/* slowly when a converged solution is */
/* computed. See the Particulars section */
/* of SPKEZR for a discussion of precision */
/* of light time corrections. */
/* 'CN+S' Converged Newtonian light time */
/* correction and stellar aberration */
/* correction. */
/* The following values of ABCORR apply to the */
/* "transmission" case in which photons *depart* from */
/* the observer's location at ET and arrive at the */
/* target's location at the light-time corrected epoch */
/* ET+LT: */
/* 'XLT' "Transmission" case: correct for */
/* one-way light time using a Newtonian */
/* formulation. This correction yields the */
/* state of the target at the moment it */
/* receives photons emitted from the */
/* observer's location at ET. */
/* 'XLT+S' "Transmission" case: correct for */
/* one-way light time and stellar */
/* aberration using a Newtonian */
/* formulation This option modifies the */
/* state obtained with the 'XLT' option to */
/* account for the observer's velocity */
/* relative to the solar system */
/* barycenter. The position component of */
/* the computed target state indicates the */
/* direction that photons emitted from the */
/* observer's location must be "aimed" to */
/* hit the target. */
/* 'XCN' "Transmission" case: converged */
/* Newtonian light time correction. */
/* 'XCN+S' "Transmission" case: converged */
/* Newtonian light time correction and */
/* stellar aberration correction. */
/* Neither special nor general relativistic effects are */
/* accounted for in the aberration corrections applied */
/* by this routine. */
/* Case and blanks are not significant in the string */
/* ABCORR. */
/* $ Detailed_Output */
/* STARG is a Cartesian state vector representing the position */
/* and velocity of the target body relative to the */
/* specified observer. STARG is corrected for the */
/* specified aberrations, and is expressed with respect */
/* to the specified inertial reference frame. The first */
/* three components of STARG represent the x-, y- and */
/* z-components of the target's position; last three */
/* components form the corresponding velocity vector. */
/* The position component of STARG points from the */
/* observer's location at ET to the aberration-corrected */
/* location of the target. Note that the sense of the */
/* position vector is independent of the direction of */
/* radiation travel implied by the aberration */
/* correction. */
/* The velocity component of STARG is obtained by */
/* evaluating the target's geometric state at the light */
/* time corrected epoch, so for aberration-corrected */
/* states, the velocity is not precisely equal to the */
/* time derivative of the position. */
/* Units are always km and km/sec. */
/* LT is the one-way light time between the observer and */
/* target in seconds. If the target state is corrected */
/* for aberrations, then LT is the one-way light time */
/* between the observer and the light time corrected */
/* target location. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the value of ABCORR is not recognized, the error */
/* 'SPICE(SPKINVALIDOPTION)' is signaled. */
/* 2) If the reference frame requested is not a recognized */
/* inertial reference frame, the error 'SPICE(BADFRAME)' */
/* is signaled. */
/* 3) If the state of the target relative to the solar system */
/* barycenter cannot be computed, the error will be diagnosed */
/* by routines in the call tree of this routine. */
/* $ Files */
/* This routine computes states using SPK files that have been */
/* loaded into the SPICE system, normally via the kernel loading */
/* interface routine FURNSH. Application programs typically load */
/* kernels once before this routine is called, for example during */
/* program initialization; kernels need not be loaded repeatedly. */
/* See the routine FURNSH and the SPK and KERNEL Required Reading */
/* for further information on loading (and unloading) kernels. */
/* If any of the ephemeris data used to compute STARG are expressed */
/* relative to a non-inertial frame in the SPK files providing those */
/* data, additional kernels may be needed to enable the reference */
/* frame transformations required to compute the state. Normally */
/* these additional kernels are PCK files or frame kernels. Any */
/* such kernels must already be loaded at the time this routine is */
/* called. */
/* $ Particulars */
/* In space science or engineering applications one frequently */
/* wishes to know where to point a remote sensing instrument, such */
/* as an optical camera or radio antenna, in order to observe or */
/* otherwise receive radiation from a target. This pointing problem */
/* is complicated by the finite speed of light: one needs to point */
/* to where the target appears to be as opposed to where it actually */
/* is at the epoch of observation. We use the adjectives */
/* "geometric," "uncorrected," or "true" to refer to an actual */
/* position or state of a target at a specified epoch. When a */
/* geometric position or state vector is modified to reflect how it */
/* appears to an observer, we describe that vector by any of the */
/* terms "apparent," "corrected," "aberration corrected," or "light */
/* time and stellar aberration corrected." */
/* The SPICE Toolkit can correct for two phenomena affecting the */
/* apparent location of an object: one-way light time (also called */
/* "planetary aberration") and stellar aberration. Correcting for */
/* one-way light time is done by computing, given an observer and */
/* observation epoch, where a target was when the observed photons */
/* departed the target's location. The vector from the observer to */
/* this computed target location is called a "light time corrected" */
/* vector. The light time correction depends on the motion of the */
/* target, but it is independent of the velocity of the observer */
/* relative to the solar system barycenter. Relativistic effects */
/* such as light bending and gravitational delay are not accounted */
/* for in the light time correction performed by this routine. */
/* The velocity of the observer also affects the apparent location */
/* of a target: photons arriving at the observer are subject to a */
/* "raindrop effect" whereby their velocity relative to the observer */
/* is, using a Newtonian approximation, the photons' velocity */
/* relative to the solar system barycenter minus the velocity of the */
/* observer relative to the solar system barycenter. This effect is */
/* called "stellar aberration." Stellar aberration is independent */
/* of the velocity of the target. The stellar aberration formula */
/* used by this routine is non-relativistic. */
/* Stellar aberration corrections are applied after light time */
/* corrections: the light time corrected target position vector is */
/* used as an input to the stellar aberration correction. */
/* When light time and stellar aberration corrections are both */
/* applied to a geometric position vector, the resulting position */
/* vector indicates where the target "appears to be" from the */
/* observer's location. */
/* As opposed to computing the apparent position of a target, one */
/* may wish to compute the pointing direction required for */
/* transmission of photons to the target. This requires correction */
/* of the geometric target position for the effects of light time and */
/* stellar aberration, but in this case the corrections are computed */
/* for radiation traveling from the observer to the target. */
/* The "transmission" light time correction yields the target's */
/* location as it will be when photons emitted from the observer's */
/* location at ET arrive at the target. The transmission stellar */
/* aberration correction is the inverse of the traditional stellar */
/* aberration correction: it indicates the direction in which */
/* radiation should be emitted so that, using a Newtonian */
/* approximation, the sum of the velocity of the radiation relative */
/* to the observer and of the observer's velocity, relative to the */
/* solar system barycenter, yields a velocity vector that points in */
/* the direction of the light time corrected position of the target. */
/* The traditional aberration corrections applicable to observation */
/* and those applicable to transmission are related in a simple way: */
/* one may picture the geometry of the "transmission" case by */
/* imagining the "observation" case running in reverse time order, */
/* and vice versa. */
/* One may reasonably object to using the term "observer" in the */
/* transmission case, in which radiation is emitted from the */
/* observer's location. The terminology was retained for */
/* consistency with earlier documentation. */
/* Below, we indicate the aberration corrections to use for some */
/* common applications: */
/* 1) Find the apparent direction of a target for a remote-sensing */
/* observation. */
/* Use 'LT+S' or 'CN+S: apply both light time and stellar */
/* aberration corrections. */
/* Note that using light time corrections alone ('LT' or 'CN') */
/* is generally not a good way to obtain an approximation to */
/* an apparent target vector: since light time and stellar */
/* aberration corrections often partially cancel each other, */
/* it may be more accurate to use no correction at all than to */
/* use light time alone. */
/* 2) Find the corrected pointing direction to radiate a signal */
/* to a target. This computation is often applicable for */
/* implementing communications sessions. */
/* Use 'XLT+S' or 'XCN+S: apply both light time and stellar */
/* aberration corrections for transmission. */
/* 3) Compute the apparent position of a target body relative */
/* to a star or other distant object. */
/* Use 'LT', 'CN', 'LT+S', or 'CN+S' as needed to match the */
/* correction applied to the position of the distant */
/* object. For example, if a star position is obtained from */
/* a catalog, the position vector may not be corrected for */
/* stellar aberration. In this case, to find the angular */
/* separation of the star and the limb of a planet, the */
/* vector from the observer to the planet should be */
/* corrected for light time but not stellar aberration. */
/* 4) Obtain an uncorrected state vector derived directly from */
/* data in an SPK file. */
/* Use 'NONE'. */
/* C */
/* 5) Use a geometric state vector as a low-accuracy estimate */
/* of the apparent state for an application where execution */
/* speed is critical: */
/* Use 'NONE'. */
/* 6) While this routine cannot perform the relativistic */
/* aberration corrections required to compute states */
/* with the highest possible accuracy, it can supply the */
/* geometric states required as inputs to these computations: */
/* Use 'NONE', then apply high-accuracy aberration */
/* corrections (not available in the SPICE Toolkit). */
/* Below, we discuss in more detail how the aberration corrections */
/* applied by this routine are computed. */
/* Geometric case */
/* ============== */
/* SPKAPP begins by computing the geometric position T(ET) of the */
/* target body relative to the solar system barycenter (SSB). */
/* Subtracting the geometric position of the observer O(ET) gives */
/* the geometric position of the target body relative to the */
/* observer. The one-way light time, LT, is given by */
/* | T(ET) - O(ET) | */
/* LT = ------------------- */
/* c */
/* The geometric relationship between the observer, target, and */
/* solar system barycenter is as shown: */
/* SSB ---> O(ET) */
/* | / */
/* | / */
/* | / */
/* | / T(ET) - O(ET) */
/* V V */
/* T(ET) */
/* The returned state consists of the position vector */
/* T(ET) - O(ET) */
/* and a velocity obtained by taking the difference of the */
/* corresponding velocities. In the geometric case, the */
/* returned velocity is actually the time derivative of the */
/* position. */
/* Reception case */
/* ============== */
/* When any of the options 'LT', 'CN', 'LT+S', 'CN+S' is */
/* selected, SPKAPP computes the position of the target body at */
/* epoch ET-LT, where LT is the one-way light time. Let T(t) and */
/* O(t) represent the positions of the target and observer */
/* relative to the solar system barycenter at time t; then LT is */
/* the solution of the light-time equation */
/* | T(ET-LT) - O(ET) | */
/* LT = ------------------------ (1) */
/* c */
/* The ratio */
/* | T(ET) - O(ET) | */
/* --------------------- (2) */
/* c */
/* is used as a first approximation to LT; inserting (2) into the */
/* RHS of the light-time equation (1) yields the "one-iteration" */
/* estimate of the one-way light time. Repeating the process */
/* until the estimates of LT converge yields the "converged */
/* Newtonian" light time estimate. */
/* Subtracting the geometric position of the observer O(ET) gives */
/* the position of the target body relative to the observer: */
/* T(ET-LT) - O(ET). */
/* SSB ---> O(ET) */
/* | \ | */
/* | \ | */
/* | \ | T(ET-LT) - O(ET) */
/* | \ | */
/* V V V */
/* T(ET) T(ET-LT) */
/* The position component of the light-time corrected state */
/* is the vector */
/* T(ET-LT) - O(ET) */
/* The velocity component of the light-time corrected state */
/* is the difference */
/* T_vel(ET-LT) - O_vel(ET) */
/* where T_vel and O_vel are, respectively, the velocities of */
/* the target and observer relative to the solar system */
/* barycenter at the epochs ET-LT and ET. */
/* If correction for stellar aberration is requested, the target */
/* position is rotated toward the solar system barycenter- */
/* relative velocity vector of the observer. The rotation is */
/* computed as follows: */
/* Let r be the light time corrected vector from the observer */
/* to the object, and v be the velocity of the observer with */
/* respect to the solar system barycenter. Let w be the angle */
/* between them. The aberration angle phi is given by */
/* sin(phi) = v sin(w) / c */
/* Let h be the vector given by the cross product */
/* h = r X v */
/* Rotate r by phi radians about h to obtain the apparent */
/* position of the object. */
/* The velocity component of the output state STARG is */
/* not corrected for stellar aberration. */
/* Transmission case */
/* ================== */
/* When any of the options 'XLT', 'XCN', 'XLT+S', 'XCN+S' are */
/* selected, SPKAPP computes the position of the target body T at */
/* epoch ET+LT, where LT is the one-way light time. LT is the */
/* solution of the light-time equation */
/* | T(ET+LT) - O(ET) | */
/* LT = ------------------------ (3) */
/* c */
/* Subtracting the geometric position of the observer, O(ET), */
/* gives the position of the target body relative to the */
/* observer: T(ET-LT) - O(ET). */
/* SSB --> O(ET) */
/* / | * */
/* / | * T(ET+LT) - O(ET) */
/* / |* */
/* / *| */
/* V V V */
/* T(ET+LT) T(ET) */
/* The position component of the light-time corrected state */
/* is the vector */
/* T(ET+LT) - O(ET) */
/* The velocity component of the light-time corrected state */
/* is the difference */
/* T_vel(ET+LT) - O_vel(ET) */
/* where T_vel and O_vel are, respectively, the velocities of */
/* the target and observer relative to the solar system */
/* barycenter at the epochs ET+LT and ET. */
/* If correction for stellar aberration is requested, the target */
/* position is rotated away from the solar system barycenter- */
/* relative velocity vector of the observer. The rotation is */
/* computed as in the reception case, but the sign of the */
/* rotation angle is negated. */
/* The velocity component of the output state STARG is */
/* not corrected for stellar aberration. */
/* Neither special nor general relativistic effects are accounted */
/* for in the aberration corrections performed by this routine. */
/* $ Examples */
/* In the following code fragment, SPKSSB and SPKAPP are used */
/* to display the position of Io (body 501) as seen from the */
/* Voyager 2 spacecraft (Body -32) at a series of epochs. */
/* Normally, one would call the high-level reader SPKEZR to obtain */
/* state vectors. The example below illustrates the interface */
/* of this routine but is not intended as a recommendation on */
/* how to use the SPICE SPK subsystem. */
/* The use of integer ID codes is necessitated by the low-level */
/* interface of this routine. */
/* IO = 501 */
/* VGR2 = -32 */
/* DO WHILE ( EPOCH .LE. END ) */
/* CALL SPKSSB ( VGR2, EPOCH, 'J2000', STVGR2 ) */
/* CALL SPKAPP ( IO, EPOCH, 'J2000', STVGR2, */
/* . 'LT+S', STIO, LT ) */
/* CALL RECRAD ( STIO, RANGE, RA, DEC ) */
/* WRITE (*,*) RA * DPR(), DEC * DPR() */
/* EPOCH = EPOCH + DELTA */
/* END DO */
/* $ Restrictions */
/* 1) The kernel files to be used by SPKAPP must be loaded */
/* (normally by the SPICELIB kernel loader FURNSH) before */
/* this routine is called. */
/* 2) Unlike most other SPK state computation routines, this */
/* routine requires that the input state be relative to an */
/* inertial reference frame. Non-inertial frames are not */
/* supported by this routine. */
/* 3) In a future version of this routine, the implementation */
/* of the aberration corrections may be enhanced to improve */
/* accuracy. */
/* $ Literature_References */
/* SPK Required Reading. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* B.V. Semenov (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 3.1.0, 04-JUL-2014 (NJB) (BVS) */
/* Discussion of light time corrections was updated. Assertions */
/* that converged light time corrections are unlikely to be */
/* useful were removed. */
/* Last update was 21-SEP-2013 (BVS) */
/* Updated to call LJUCRS instead of CMPRSS/UCASE. */
/* - SPICELIB Version 3.0.3, 18-MAY-2010 (BVS) */
/* Index lines now state that this routine is deprecated. */
/* - SPICELIB Version 3.0.2, 08-JAN-2008 (NJB) */
/* The Abstract section of the header was updated to */
/* indicate that this routine has been deprecated. */
/* - SPICELIB Version 3.0.1, 20-OCT-2003 (EDW) */
/* Added mention that LT returns in seconds. */
/* Corrected spelling errors. */
/* - SPICELIB Version 3.0.0, 18-DEC-2001 (NJB) */
/* Updated to handle aberration corrections for transmission */
/* of radiation. Formerly, only the reception case was */
/* supported. The header was revised and expanded to explain */
/* the functionality of this routine in more detail. */
/* - SPICELIB Version 2.1.0, 09-JUL-1996 (WLT) */
/* Corrected the description of LT in the Detailed Output */
/* section of the header. */
/* - SPICELIB Version 2.0.0, 22-MAY-1995 (WLT) */
/* The routine was modified to support the options 'CN' and */
/* 'CN+S' aberration corrections. Moreover, diagnostics were */
/* added to check for reference frames that are not recognized */
/* inertial frames. */
/* - SPICELIB Version 1.1.2, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.1.1, 06-MAR-1991 (JML) */
/* In the example program, the calling sequence of SPKAPP */
/* was corrected. */
/* - SPICELIB Version 1.1.0, 25-MAY-1990 (HAN) */
/* The local variable CORR was added to eliminate a */
/* run-time error that occurred when SPKAPP was determining */
/* what corrections to apply to the state. */
/* - SPICELIB Version 1.0.1, 22-MAR-1990 (HAN) */
/* Literature references added to the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) */
/* -& */
/* $ Index_Entries */
/* DEPRECATED low-level aberration correction */
/* DEPRECATED apparent state from spk file */
/* DEPRECATED get apparent state */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 22-MAY-1995 (WLT) */
/* The routine was modified to support the options 'CN' and */
/* 'CN+S' aberration corrections. Moreover, diagnostics were */
/* added to check for reference frames that are not recognized */
/* inertial frames. */
/* - SPICELIB Version 1.1.1, 06-MAR-1991 (JML) */
/* In the example program, the calling sequence of SPKAPP */
/* was corrected. */
/* - SPICELIB Version 1.1.0, 25-MAY-1990 (HAN) */
/* The local variable CORR was added to eliminate a run-time */
/* error that occurred when SPKAPP was determining what */
/* corrections to apply to the state. If the literal string */
/* 'LT' was assigned to ABCORR, SPKAPP attempted to look at */
/* ABCORR(3:4). Because ABCORR is a passed length argument, its */
/* length is not guaranteed, and those positions may not exist. */
/* Searching beyond the bounds of a string resulted in a */
/* run-time error at NAIF because NAIF compiles SPICELIB using the */
/* CHECK=BOUNDS option for the DEC VAX/VMX DCL FORTRAN command. */
/* Also, without the local variable CORR, SPKAPP would have to */
/* modify the value of a passed argument, ABCORR. That's a no no. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Indices of flags in the FLAGS array: */
/* Local variables */
/* Saved variables */
/* Initial values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZSPKAP1", (ftnlen)8);
}
if (first || s_cmp(abcorr, prvcor, abcorr_len, (ftnlen)5) != 0) {
/* The aberration correction flag differs from the value it */
/* had on the previous call, if any. Analyze the new flag. */
/* Remove leading and embedded white space from the aberration */
/* correction flag and convert to upper case. */
ljucrs_(&c__0, abcorr, corr, abcorr_len, (ftnlen)5);
/* Locate the flag in our list of flags. */
i__ = isrchc_(corr, &c__9, flags, (ftnlen)5, (ftnlen)5);
if (i__ == 0) {
setmsg_("Requested aberration correction # is not supported.", (
ftnlen)51);
errch_("#", abcorr, (ftnlen)1, abcorr_len);
sigerr_("SPICE(SPKINVALIDOPTION)", (ftnlen)23);
chkout_("ZZSPKAP1", (ftnlen)8);
return 0;
}
/* The aberration correction flag is recognized; save it. */
s_copy(prvcor, abcorr, (ftnlen)5, abcorr_len);
/* Set logical flags indicating the attributes of the requested */
/* correction. */
xmit = i__ > 5;
uselt = i__ == 2 || i__ == 3 || i__ == 6 || i__ == 7;
usestl = i__ > 1 && odd_(&i__);
usecn = i__ == 4 || i__ == 5 || i__ == 8 || i__ == 9;
first = FALSE_;
}
/* See if the reference frame is a recognized inertial frame. */
irfnum_(ref, &refid, ref_len);
if (refid == 0) {
setmsg_("The requested frame '#' is not a recognized inertial frame. "
, (ftnlen)60);
errch_("#", ref, (ftnlen)1, ref_len);
sigerr_("SPICE(BADFRAME)", (ftnlen)15);
chkout_("ZZSPKAP1", (ftnlen)8);
return 0;
}
/* Determine the sign of the light time offset. */
if (xmit) {
ltsign = 1;
} else {
ltsign = -1;
}
/* Find the geometric state of the target body with respect to the */
/* solar system barycenter. Subtract the state of the observer */
/* to get the relative state. Use this to compute the one-way */
/* light time. */
zzspksb1_(targ, et, ref, starg, ref_len);
vsubg_(starg, sobs, &c__6, tstate);
moved_(tstate, &c__6, starg);
*lt = vnorm_(starg) / clight_();
/* To correct for light time, find the state of the target body */
/* at the current epoch minus the one-way light time. Note that */
/* the observer remains where he is. */
if (uselt) {
maxitr = 1;
} else if (usecn) {
maxitr = 3;
} else {
maxitr = 0;
}
i__1 = maxitr;
for (i__ = 1; i__ <= i__1; ++i__) {
d__1 = *et + ltsign * *lt;
zzspksb1_(targ, &d__1, ref, starg, ref_len);
vsubg_(starg, sobs, &c__6, tstate);
moved_(tstate, &c__6, starg);
*lt = vnorm_(starg) / clight_();
}
/* At this point, STARG contains the light time corrected */
/* state of the target relative to the observer. */
/* If stellar aberration correction is requested, perform it now. */
/* Stellar aberration corrections are not applied to the target's */
/* velocity. */
if (usestl) {
if (xmit) {
/* This is the transmission case. */
/* Compute the position vector obtained by applying */
/* "reception" stellar aberration to STARG. */
stlabx_(starg, &sobs[3], sapos);
vequ_(sapos, starg);
} else {
/* This is the reception case. */
/* Compute the position vector obtained by applying */
/* "reception" stellar aberration to STARG. */
stelab_(starg, &sobs[3], sapos);
vequ_(sapos, starg);
}
}
chkout_("ZZSPKAP1", (ftnlen)8);
return 0;
} /* zzspkap1_ */
/* Subroutine */ int cmloop_(char *delim, char *prompt, char *lognam, char *
versn, S_fp greet, S_fp preprc, S_fp action, ftnlen delim_len, ftnlen
prompt_len, ftnlen lognam_len, ftnlen versn_len)
{
/* Initialized data */
static char spcial[8*2] = " " "? ";
/* System generated locals */
address a__1[2], a__2[7], a__3[3];
integer i__1[2], i__2[7], i__3[3], i__4;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
extern /* Subroutine */ int echo_(char *, char *, ftnlen, ftnlen);
extern logical have_(char *, ftnlen);
static integer from;
static logical trap;
static integer rest, l;
static logical dolog;
extern integer ltrim_(char *, ftnlen);
static char error[1760*2], com2do[1024];
extern logical no_(char *, ftnlen);
extern /* Subroutine */ int logchk_(char *, char *, logical *, ftnlen,
ftnlen), cmredo_(char *, integer *, logical *, ftnlen);
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
static char commnd[1024], errflg[32];
extern logical cmmore_(char *, ftnlen);
extern /* Subroutine */ int setdel_(char *, ftnlen), erract_(char *, char
*, ftnlen, ftnlen);
static char usenam[255];
extern /* Subroutine */ int errdev_(char *, char *, ftnlen, ftnlen);
static logical problm;
extern /* Subroutine */ int setdap_(char *, char *, ftnlen, ftnlen),
getcom_(char *, integer *, ftnlen), edtcom_(char *, char *, char *
, integer *, ftnlen, ftnlen, ftnlen), builtn_(char *, logical *,
char *, ftnlen, ftnlen), nsplog_(char *, logical *, ftnlen),
nspend_(void), trnlat_(char *, char *, ftnlen, ftnlen), nsplgs_(
char *, char *, char *, ftnlen, ftnlen, ftnlen);
static char hstyle[120];
extern /* Subroutine */ int nsperr_(char *, char *, ftnlen, ftnlen),
nspopl_(char *, char *, ftnlen, ftnlen);
static char lstyle[120];
extern /* Subroutine */ int cmstup_(void);
extern integer qrtrim_(char *, ftnlen);
extern /* Subroutine */ int nspslr_(integer *, integer *);
static char sstyle[120];
extern /* Subroutine */ int ressym_(char *, char *, ftnlen, ftnlen);
static char vstyle[120];
extern /* Subroutine */ int nspsty_(char *, char *, ftnlen, ftnlen);
static logical log__[4], hit;
/* $ Abstract */
/* This routine handles the main processing loop of a */
/* command driven program. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* INTERFACE */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* DELIM I Non-blank character used to delimit commands */
/* PROMPT I Prompt to let the user know input is expected */
/* LOGNAM I Name pattern of file where commands will be logged */
/* VERSN I Program name and version */
/* INTIZE S Subroutine that initializes I/O facilities */
/* GREET S Displays a banner at program startup */
/* ACTION S The command parser and processor. */
/* $ Detailed_Input */
/* DELIM is a character that will be used to tell the */
/* program that a command has ended. Commands may */
/* extend over as many lines as allowed by the */
/* configuration include file. They end on the */
/* first line on which the delimiter character is */
/* encountered. THIS CHARACTER MUST NOT BE "?" */
/* PROMPT is a string used to prompt the user for commands. */
/* Typically, this is the name of the program that */
/* calles CMLOOP. */
/* LOGNAM is a pattern to use when creating the name of */
/* a file to which all commands will be written. */
/* This can be hard coded in the calling */
/* program, or may be determined by a file naming */
/* convention such as is provided by Christen */
/* and NOMEN. */
/* VERSN is a string that may contain anything you would */
/* like to appear as descriptive text in the first */
/* line of the log file (and possibly in the greeting */
/* presented by the program) Something like */
/* '<program name> --- Version X.Y' would be appropriate. */
/* For example if your programs name is KINDLE and you */
/* are at version 4.2.3 of your program a good value for */
/* VERSN would be */
/* 'KINDLE --- Version 4.2.3' */
/* Your greeting routine can make use of this when */
/* displaying your program's greeting. In this way */
/* you can centralize the name and version number of */
/* your program at a high level or in a subroutine and */
/* simply make the information available to CMLOOP so */
/* that the automatic aspects of presenting this */
/* information can be handled for you. */
/* GREET is a routine that displays a message at program */
/* startup. This should contain the version number */
/* of the program, any general instructions such */
/* as how to get help and who the author or organization */
/* is that is responsible for this program. GREET */
/* takes a single argument VERSN which you supply in */
/* your call to CMLOOP. It may also have */
/* initializations that override various items set */
/* up prior to the call to GREET such as the style */
/* used for displaying error messages. GREET */
/* is the action taken by CMLOOP before commencing the */
/* loop of fetching and processing commands. */
/* PREPRC is a command preprocessor. It might remove */
/* non-printing characters such as TABS, resolve */
/* symbols and convert units to expected ranges. */
/* ACTION is a routine responsible for action upon the commands */
/* entered by a user at the keyboard. ACTION has two */
/* arguments COMMAND a string input and ERROR a two */
/* dimensional array for error and diagnostic output. */
/* The first message should point to the the problem */
/* assuming the user is aware of the context in which */
/* the problem occurred. The second message will */
/* have more detailed information including trace */
/* and other technical information. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* The parameters COMSIZ and ERRSIZ are given in the include */
/* file commdpar.inc. */
/* COMSIZ is maximum number of characters that can be present */
/* in a command. */
/* ERRSIZ is the maximum number of characters that can be used */
/* when creating a diagnostic message. */
/* $ Exceptions */
/* None. This routine cannot detect any errors in its inputs */
/* and all commands are regarded as legal input at this level. */
/* Some can be acted on while others cannot. Commands that */
/* can not be exercised are expected to return diagnostics */
/* in the array ERROR. These are then reported by the */
/* program to the user via his/her terminal. */
/* $ Files */
/* The file specified by LOGFIL will be opened if possible */
/* and all user commands and messages will be written to this */
/* file. */
/* Other files may be used a run time by "STARTing" a command */
/* sequence file. Or by some result of the activity of the */
/* user supplied routines ACTION, GREET, PREPRC. */
/* $ Particulars */
/* This routine organizes the main loop of a command line */
/* program so that the calling program can automatically */
/* log files that a user enters, report errors in a uniform */
/* manner and make use of sequences of commands stored in */
/* files. The calling program supplies routines that handle */
/* the chores of greeting the user and performing special */
/* program initializations and performing actions based upon */
/* the commands supplied by the user. By making use of this */
/* routine and its subordinates, the user inherits a flexible */
/* I/O system and command interface freeing him/her to concentrate */
/* on the actions of the program. */
/* However, there is a minor price incurred by making use of */
/* this routine. Several commands have specific meanings that */
/* the user cannot override. They are commands that start with: */
/* start */
/* exit */
/* stop */
/* quit */
/* echo */
/* no echo */
/* demo on */
/* demo off */
/* wait on */
/* wait off */
/* pause */
/* ? */
/* These commands are case insensitive with respect to the */
/* words presented above. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* $ Version */
/* - Command Loop Configured Version 6.0.0, 20-JUN-2000 (WLT) */
/* Added the ability to run the loop without logging */
/* of inputs. */
/* - Command Loop Configured Version 5.0.0, 23-MAR-2000 (WLT) */
/* Modified the routine to call NSPEND instead of FINISH */
/* now that NSPIO has been redone. */
/* - Command Loop Configured Version 4.0.0, 20-NOV-1995 (WLT) */
/* Added ability to run programs in batch mode and to */
/* start procedures at program startup. */
/* - Command Loop Configured Version 3.0.0, 1-AUG-1995 (WLT) */
/* The routine was modified to better support command */
/* pre-processing. In particular symbol definition */
/* and resolution is now supported. */
/* - Command Loop Configured Version 2.0.0, 19-JUL-1995 (WLT) */
/* A slight change was made so that the command delimiter */
/* is now stored in the routine GETDEL. Also errors */
/* are now checked after command pre-processing has */
/* been performed. */
/* - Command Loop Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 4, 1994 */
/* - Beta Version 1.0.0, 8-OCT-1993 (WLT) */
/* -& */
/* Language Sensitive Strings */
/* $ 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. */
/* $ Version */
/* - Command Loop Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 4, 1994 */
/* The following parameters are the system parameters required */
/* by PERCY. Be sure to read any notes before adjusting these */
/* The maximum number of commands that can be buffered is */
/* determined by the value of MAXCOM. This parameter is */
/* used primarily by NXTCOM. */
/* The parameter FILEN is the maximum length of a file name */
/* on a particular system. */
/* The parameter COMSIZ is the maximum length allowed for a */
/* command. */
/* The parameter ERRSIZ is the maximum length allowed for */
/* error messages. */
/* The parameter STYSIZ is the maximum length expected for */
/* a NICEPR style string. */
/* The following are for special commands that will not be */
/* processed by ACTION. */
/* Store the delimiter used by the program incase someone */
/* else needs to know later on. */
setdel_(delim, delim_len);
/* First, set up the SPICELIB error handling. */
s_copy(error, " ", (ftnlen)1760, (ftnlen)1);
s_copy(error + 1760, " ", (ftnlen)1760, (ftnlen)1);
s_copy(commnd, " ", (ftnlen)1024, (ftnlen)1);
log__[0] = FALSE_;
log__[1] = FALSE_;
log__[2] = TRUE_;
log__[3] = TRUE_;
erract_("SET", "RETURN", (ftnlen)3, (ftnlen)6);
errdev_("SET", "NULL", (ftnlen)3, (ftnlen)4);
/* Set the prompt for the program. */
setdap_(delim, prompt, delim_len, prompt_len);
/* The following styles are for reporting errors to the */
/* screen and log file respectively. */
trnlat_("ERRFLAG", errflg, (ftnlen)7, (ftnlen)32);
/* Writing concatenation */
i__1[0] = 38, a__1[0] = "HARDSPACE ^ NEWLINE /cr VTAB /vt FLAG ";
i__1[1] = 32, a__1[1] = errflg;
s_cat(sstyle, a__1, i__1, &c__2, (ftnlen)120);
/* Writing concatenation */
i__2[0] = 38, a__2[0] = "HARDSPACE ^ NEWLINE /cr VTAB /vt FLAG ";
i__2[1] = 1, a__2[1] = delim;
i__2[2] = qrtrim_(errflg, (ftnlen)32), a__2[2] = errflg;
i__2[3] = 8, a__2[3] = " LEADER ";
i__2[4] = 1, a__2[4] = delim;
i__2[5] = 3, a__2[5] = "-- ";
i__2[6] = 16, a__2[6] = "LEFT 1 RIGHT 72 ";
s_cat(lstyle, a__2, i__2, &c__7, (ftnlen)120);
/* The following styles will be used for logging of */
/* commands and for commenting them out. */
s_copy(vstyle, "LEFT 1 RIGHT 78 ", (ftnlen)120, (ftnlen)16);
/* Writing concatenation */
i__3[0] = 23, a__3[0] = "LEFT 1 RIGHT 78 LEADER ";
i__3[1] = 1, a__3[1] = delim;
i__3[2] = 3, a__3[2] = "-- ";
s_cat(hstyle, a__3, i__3, &c__3, (ftnlen)120);
nspsty_(sstyle, lstyle, (ftnlen)120, (ftnlen)120);
nsplgs_(vstyle, hstyle, delim, (ftnlen)120, (ftnlen)120, delim_len);
nspslr_(&c__1, &c__78);
/* See whether or not a log file should be used and if so */
/* what it's name should be. */
logchk_(lognam, usenam, &dolog, lognam_len, (ftnlen)255);
/* Open a log file. */
if (dolog) {
nspopl_(usenam, versn, (ftnlen)255, versn_len);
}
if (have_(error, (ftnlen)1760)) {
nsperr_(commnd, error, (ftnlen)1024, (ftnlen)1760);
}
/* Present a greeting to the user and perform any override */
/* or special initializations that need to be local to this */
/* routine. */
(*greet)(versn, versn_len);
/* Get the input command line. This may have */
/* several useful bits of information to tell us how */
/* to run the program. */
/* -b means run the program in batch mode. In this case */
/* we should never prompt the user for information. */
/* -start means we have a startup file to use and we want to */
/* use the name of that file to determine how to */
/* proceed. */
cmstup_();
/* Fetch and log the first command. */
trap = TRUE_;
/* Get the next command and resolve any symbols or */
/* queries that might show up in it, */
while(trap) {
getcom_(com2do, &from, (ftnlen)1024);
edtcom_(delim, prompt, com2do, &from, delim_len, prompt_len, (ftnlen)
1024);
if (no_(error, (ftnlen)1760) && log__[(i__4 = from) < 4 && 0 <= i__4 ?
i__4 : s_rnge("log", i__4, "cmloop_", (ftnlen)430)]) {
nsplog_(com2do, &c_false, (ftnlen)1024);
}
if (no_(error, (ftnlen)1760)) {
ressym_(com2do, commnd, (ftnlen)1024, (ftnlen)1024);
echo_(com2do, commnd, (ftnlen)1024, (ftnlen)1024);
}
if (no_(error, (ftnlen)1760)) {
cmredo_(commnd, &from, &trap, (ftnlen)1024);
}
if (have_(error, (ftnlen)1760)) {
trap = FALSE_;
}
}
/* Now apply the user's preprocessing software */
/* to the comman. */
s_copy(com2do, commnd, (ftnlen)1024, (ftnlen)1024);
(*preprc)(com2do, commnd, (ftnlen)1024, (ftnlen)1024);
/* Now process commands until we get an EXIT command. */
while(cmmore_(commnd, (ftnlen)1024)) {
/* Perform any preprocessing that can be performed easily */
/* on this command. */
if (no_(error, (ftnlen)1760)) {
builtn_(commnd, &hit, error, (ftnlen)1024, (ftnlen)1760);
}
if (no_(error, (ftnlen)1760) && ! hit) {
l = ltrim_(commnd, (ftnlen)1024);
rest = qrtrim_(commnd, (ftnlen)1024) + 1;
if (isrchc_(commnd + (l - 1), &c__2, spcial, rest - (l - 1), (
ftnlen)8) == 0) {
(*action)(commnd, error, (ftnlen)1024, (ftnlen)1760);
}
}
problm = have_(error, (ftnlen)1760);
/* Process any errors that were diagnosed. */
nsperr_(commnd, error, (ftnlen)1024, (ftnlen)1760);
/* Fetch and log the next command. */
trap = TRUE_;
while(trap) {
getcom_(com2do, &from, (ftnlen)1024);
edtcom_(delim, prompt, com2do, &from, delim_len, prompt_len, (
ftnlen)1024);
if (no_(error, (ftnlen)1760) && log__[(i__4 = from) < 4 && 0 <=
i__4 ? i__4 : s_rnge("log", i__4, "cmloop_", (ftnlen)496)]
) {
nsplog_(com2do, &c_false, (ftnlen)1024);
}
if (no_(error, (ftnlen)1760)) {
ressym_(com2do, commnd, (ftnlen)1024, (ftnlen)1024);
echo_(com2do, commnd, (ftnlen)1024, (ftnlen)1024);
}
if (no_(error, (ftnlen)1760)) {
cmredo_(commnd, &from, &trap, (ftnlen)1024);
}
if (have_(error, (ftnlen)1760)) {
trap = FALSE_;
}
}
/* Now apply the user's preprocessing software */
/* to the comman. */
s_copy(com2do, commnd, (ftnlen)1024, (ftnlen)1024);
(*preprc)(com2do, commnd, (ftnlen)1024, (ftnlen)1024);
}
/* Take care of closing files and so on. */
if (log__[(i__4 = from) < 4 && 0 <= i__4 ? i__4 : s_rnge("log", i__4,
"cmloop_", (ftnlen)526)]) {
nspend_();
}
return 0;
} /* cmloop_ */
