/* Subroutine */ int langua_0_(int n__, char *string, ftnlen string_len)
{
/* Initialized data */
static char lang[32] = "ENGLISH ";
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen),
ljust_(char *, char *, ftnlen, ftnlen);
/* $ 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 */
/* This subroutine is used by CMLOOP to store the language that */
/* is currently used by the user's program. You may freely use */
/* it throughout the rest of your program if you make your */
/* program language sensitive. */
switch(n__) {
case 1: goto L_setlan;
case 2: goto L_getlan;
}
s_copy(string, " ", string_len, (ftnlen)1);
return 0;
/* The SETLAN entry point is used for setting the language. */
L_setlan:
ljust_(string, lang, string_len, (ftnlen)32);
ucase_(lang, lang, (ftnlen)32, (ftnlen)32);
return 0;
/* Use the GETLAN entry point to get the language. */
L_getlan:
s_copy(string, lang, string_len, (ftnlen)32);
return 0;
} /* langua_ */
/* Subroutine */ int shosym_(char *templt, ftnlen templt_len)
{
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
char name__[32], line[132];
integer ncol, item[3];
logical tran;
integer size[3];
char rest[132];
integer i__, n, r__, space[3];
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen),
repmc_(char *, char *, char *, char *, ftnlen, ftnlen, ftnlen,
ftnlen);
char value[2000];
integer width[3];
extern /* Subroutine */ int stran_(char *, char *, logical *, ftnlen,
ftnlen);
extern integer rtrim_(char *, ftnlen);
logical justr[3];
integer lmarge, pagewd;
char spcial[1*3];
extern /* Subroutine */ int pagscn_(char *, ftnlen);
char margin[32], messge[132];
extern /* Subroutine */ int pagset_(char *, integer *, ftnlen), tabrpt_(
integer *, integer *, integer *, integer *, logical *, logical *,
char *, integer *, integer *, U_fp, ftnlen);
char myline[132];
extern /* Subroutine */ int pagrst_(void), nspmrg_(char *, ftnlen),
symget_(char *, char *, ftnlen, ftnlen);
char frstwd[32];
extern /* Subroutine */ int nspglr_(integer *, integer *), nextwd_(char *,
char *, char *, ftnlen, ftnlen, ftnlen), sympat_(char *, ftnlen),
nspwln_(char *, ftnlen);
extern /* Subroutine */ int retsym_();
logical presrv[3];
extern /* Subroutine */ int setsym_(char *, char *, char *, ftnlen,
ftnlen, ftnlen);
char def[2000];
extern /* Subroutine */ int nicepr_1__(char *, char *, S_fp, ftnlen,
ftnlen);
r__ = rtrim_(templt, templt_len);
sympat_(templt, r__);
symget_(name__, def, (ftnlen)32, (ftnlen)2000);
nspmrg_(margin, (ftnlen)32);
if (s_cmp(name__, " ", (ftnlen)32, (ftnlen)1) == 0) {
s_copy(messge, "There are no symbols that match the template \"#\".",
(ftnlen)132, (ftnlen)49);
repmc_(messge, "#", templt, messge, (ftnlen)132, (ftnlen)1, r__, (
ftnlen)132);
nicepr_1__(messge, margin, (S_fp)nspwln_, (ftnlen)132, (ftnlen)32);
return 0;
}
/* If still here there are some matching symbols. Set up the */
/* standard defaults. */
s_copy(line, "=========================================================="
"================================================================"
"==============================================", (ftnlen)132, (
ftnlen)168);
presrv[0] = TRUE_;
presrv[1] = TRUE_;
presrv[2] = TRUE_;
lmarge = 1;
space[0] = 2;
space[1] = 2;
space[2] = 2;
*(unsigned char *)&spcial[0] = ' ';
*(unsigned char *)&spcial[1] = ' ';
*(unsigned char *)&spcial[2] = ' ';
justr[0] = FALSE_;
justr[1] = FALSE_;
justr[2] = FALSE_;
/* Get the width of the page and based upon that determine */
/* the basic table style that will be used to display the */
/* symbol definition. */
nspglr_(&n, &pagewd);
width[0] = 14;
width[1] = 30;
width[2] = 30;
size[0] = 1;
size[1] = 1;
size[2] = 1;
item[0] = 1;
item[1] = 2;
item[2] = 3;
ncol = 3;
/* Adjust all of the columns */
i__1 = ncol;
for (i__ = 1; i__ <= i__1; ++i__) {
width[(i__2 = i__ - 1) < 3 && 0 <= i__2 ? i__2 : s_rnge("width", i__2,
"shosym_", (ftnlen)156)] = width[(i__3 = i__ - 1) < 3 && 0 <=
i__3 ? i__3 : s_rnge("width", i__3, "shosym_", (ftnlen)156)]
* pagewd / 80;
}
pagewd = 0;
i__1 = ncol;
for (i__ = 1; i__ <= i__1; ++i__) {
pagewd = width[(i__2 = i__ - 1) < 3 && 0 <= i__2 ? i__2 : s_rnge(
"width", i__2, "shosym_", (ftnlen)162)] + space[(i__3 = i__ -
1) < 3 && 0 <= i__3 ? i__3 : s_rnge("space", i__3, "shosym_",
(ftnlen)162)] + pagewd;
}
pagewd -= space[(i__1 = ncol - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge("space"
, i__1, "shosym_", (ftnlen)165)];
nspwln_(" ", (ftnlen)1);
nspwln_("Symbols Matching Request: ", (ftnlen)26);
nspwln_(" ", (ftnlen)1);
pagrst_();
pagset_("PAGEWIDTH", &pagewd, (ftnlen)9);
pagscn_("BODY", (ftnlen)4);
setsym_("Symbol Name", "Definition", "Expanded Value", (ftnlen)11, (
ftnlen)10, (ftnlen)14);
tabrpt_(&ncol, item, size, width, justr, presrv, spcial, &lmarge, space, (
U_fp)retsym_, (ftnlen)1);
s_copy(myline, line, (ftnlen)132, pagewd);
nspwln_(myline, (ftnlen)132);
while(s_cmp(name__, " ", (ftnlen)32, (ftnlen)1) != 0) {
/* Expand this symbol until there's nothing left to do. */
s_copy(value, def, (ftnlen)2000, (ftnlen)2000);
tran = TRUE_;
while(tran) {
nextwd_(def, frstwd, rest, (ftnlen)2000, (ftnlen)32, (ftnlen)132);
ucase_(frstwd, frstwd, (ftnlen)32, (ftnlen)32);
if (s_cmp(frstwd, "DEFINE", (ftnlen)32, (ftnlen)6) != 0 && s_cmp(
frstwd, "UNDEFINE", (ftnlen)32, (ftnlen)8) != 0) {
stran_(value, value, &tran, (ftnlen)2000, (ftnlen)2000);
} else {
tran = FALSE_;
}
}
setsym_(name__, def, value, (ftnlen)32, (ftnlen)2000, (ftnlen)2000);
tabrpt_(&ncol, item, size, width, justr, presrv, spcial, &lmarge,
space, (U_fp)retsym_, (ftnlen)1);
symget_(name__, def, (ftnlen)32, (ftnlen)2000);
}
nspwln_(" ", (ftnlen)1);
return 0;
} /* shosym_ */
/* $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 WRLINE ( Write Output Line to a Device ) */
/* Subroutine */ int wrline_0_(int n__, char *device, char *line, ftnlen
device_len, ftnlen line_len)
{
/* System generated locals */
integer i__1;
cilist ci__1;
olist o__1;
cllist cl__1;
inlist ioin__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
integer *, char *, ftnlen), e_wsfe(void), f_inqu(inlist *),
s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void), f_open(olist *);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer f_clos(cllist *);
/* Local variables */
integer unit;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
extern integer ltrim_(char *, ftnlen);
char error[240];
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
logical opened;
extern /* Subroutine */ int fndlun_(integer *);
char tmpnam[128];
integer iostat;
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen);
logical exists;
char errstr[11];
extern /* Subroutine */ int intstr_(integer *, char *, ftnlen);
/* Fortran I/O blocks */
static cilist io___6 = { 0, 6, 0, 0, 0 };
static cilist io___7 = { 0, 6, 0, 0, 0 };
static cilist io___8 = { 0, 6, 0, 0, 0 };
static cilist io___9 = { 0, 6, 0, 0, 0 };
static cilist io___10 = { 0, 6, 0, 0, 0 };
static cilist io___11 = { 0, 6, 0, 0, 0 };
static cilist io___12 = { 0, 6, 0, 0, 0 };
static cilist io___15 = { 0, 6, 0, 0, 0 };
static cilist io___16 = { 0, 6, 0, 0, 0 };
static cilist io___17 = { 0, 6, 0, 0, 0 };
static cilist io___18 = { 0, 6, 0, 0, 0 };
/* $ Abstract */
/* Write a character string to an output device. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* TEXT */
/* FILES */
/* ERROR */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* DEVICE I A string specifying an output device. */
/* LINE I A line of text to be output. */
/* FILEN P Maximum length of a file name. */
/* $ Detailed_Input */
/* LINE is a line of text to be written to the output */
/* device specified by DEVICE. */
/* DEVICE is the output device to which the line of text */
/* will be written. */
/* Possible values and meanings of DEVICE are: */
/* a device name This may be the name of a */
/* file, or any other name that */
/* is valid in a FORTRAN OPEN */
/* statement. For example, on a */
/* VAX, a logical name may be */
/* used. */
/* The device name must not */
/* be any of the reserved strings */
/* below. */
/* 'SCREEN' The output will go to the */
/* terminal screen. */
/* 'NULL' The data will not be output. */
/* 'SCREEN' and 'NULL' can be written in mixed */
/* case. For example, the following call will work: */
/* CALL WRLINE ( 'screEn', LINE ) */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* FILEN is the maximum length of a file name. */
/* $ Exceptions */
/* This routine is a special case as far as error handling */
/* is concerned because it is called to output error */
/* messages resulting from errors detected by other routines. */
/* In such a case, calling SIGERR would constitute recursion. */
/* Therefore, this routine prints error messages rather */
/* than signalling errors via SIGERR and setting the long */
/* error message via SETMSG. */
/* The following exceptional cases are treated as errors: */
/* 1) SPICE(NOFREELOGICALUNIT) -- No logical unit number */
/* is available to refer to the device. */
/* 2) SPICE(FILEOPENFAILED) -- General file open error. */
/* 3) SPICE(FILEWRITEFAILED) -- General file write error. */
/* 4) SPICE(INQUIREFAILED) -- INQUIRE statement failed. */
/* 5) Leading blanks in (non-blank) file names are not */
/* significant. The file names */
/* 'MYFILE.DAT' */
/* ' MYFILE.DAT' */
/* are considered to name the same file. */
/* 6) If different names that indicate the same file are supplied */
/* to this routine on different calls, all output associated */
/* with these calls WILL be written to the file. For example, */
/* on a system where logical filenames are supported, if */
/* ALIAS is a logical name pointing to MYFILE, then the calls */
/* CALL WRLINE ( 'MYFILE', 'This is the first line' ) */
/* CALL WRLINE ( 'ALIAS', 'This is the second line' ) */
/* will place the lines of text */
/* 'This is the first line' */
/* 'This is the second line' */
/* in MYFILE. See $Restrictions for more information on use */
/* of logical names on VAX systems. */
/* $ Files */
/* 1) If DEVICE specifies a device other than 'SCREEN' or 'NULL', */
/* that device is opened (if it's not already open) as a NEW, */
/* SEQUENTIAL, FORMATTED file. The logical unit used is */
/* determined at run time. */
/* $ Particulars */
/* If the output device is a file that is not open, the file will */
/* be opened (if possible) as a NEW, sequential, formatted file, */
/* and the line of text will be written to the file. If the file */
/* is already opened as a sequential, formatted file, the line of */
/* text will be written to the file. */
/* Use the entry point CLLINE to close files opened by WRLINE. */
/* $ Examples */
/* 1) Write a message to the screen: */
/* CALL WRLINE ( 'SCREEN', 'Here''s a message.' ) */
/* The text */
/* Here's a message. */
/* will be written to the screen. */
/* 2) Write out all of the elements of a character string array */
/* to a file. */
/* CHARACTER*(80) STRING ( ASIZE ) */
/* . */
/* . */
/* . */
/* DO I = 1, ASIZE */
/* CALL WRLINE ( FILE, STRING(I) ) */
/* END DO */
/* 3) Set DEVICE to NULL to suppress output: */
/* C */
/* C Ask the user whether verbose program output is */
/* C desired. Set the output device accordingly. */
/* C */
/* WRITE (*,*) 'Do you want to see test results ' // */
/* . 'on the screen?' */
/* READ (*,FMT='(A)') VERBOS */
/* CALL LJUST ( VERBOS, VERBOS ) */
/* CALL UCASE ( VERBOS, VERBOS ) */
/* IF ( VERBOS(1:1) .EQ. 'Y' ) THEN */
/* DEVICE = 'SCREEN' */
/* ELSE */
/* DEVICE = 'NULL' */
/* ENDIF */
/* . */
/* . */
/* . */
/* C */
/* C Output test results. */
/* C */
/* CALL WRLINE ( DEVICE, STRING ) */
/* . */
/* . */
/* . */
/* $ Restrictions */
/* 1) File names must not exceed FILEN characters. */
/* 2) On VAX systems, caution should be exercised when using */
/* multiple logical names to point to the same file. Logical */
/* name translation supporting execution of the Fortran */
/* INQUIRE statement does not appear to work reliably in all */
/* cases, which may lead this routine to believe that different */
/* logical names indicate different files. The specific problem */
/* that has been observed is that logical names that include */
/* disk specifications are not always recognized as pointing */
/* to the file they actually name. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* $ Version */
/* - SPICELIB Version 4.25.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 4.24.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 4.23.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 4.22.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.21.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 4.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 4.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 4.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 4.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 4.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 4.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 4.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 4.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 4.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 4.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 4.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 4.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 4.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 4.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 4.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 4.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 4.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 4.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 4.0.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 4.0.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 4.0.3, 16-SEP-1999 (NJB) */
/* CSPICE environments were added. Some typos were corrected. */
/* - SPICELIB Version 4.0.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 4.0.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 4.0.0, 07-APR-1998 (NJB) */
/* References to the PC-LINUX environment were added. The */
/* write format for the case where the output device is the */
/* screen has been made system-dependent; list-directed output */
/* format is now used for systems that require a leading carriage */
/* control character; other systems use character format. The */
/* write format for the case where the output device is a file */
/* has been changed from list-directed to character. */
/* - SPICELIB Version 3.0.0, 11-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* and the appropriate OPEN statement for the Silicon */
/* Graphics, DEC Alpha-OSF/1, and NeXT platforms. The previous */
/* value of 256 for Unix platforms was changed to 255. */
/* - SPICELIB Version 2.1.0, 13-OCT-1992 (HAN) */
/* Module was updated to include the value of FILEN for the */
/* Hewlett Packard UX 9000/750 environment. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 2.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 2.0.0, 26-MAR-1991 (NJB) */
/* This routine now can write to files that have been opened */
/* by other routines. */
/* The limit imposed by this routine on the number of files it */
/* can open has been removed. */
/* The output file is now opened as a normal text file on */
/* VAX systems. */
/* Improper treatment of the case where DEVICE is blank was */
/* remedied. */
/* Unneeded variable declarations and references were removed. */
/* Initialization of SAVED variables was added. */
/* All occurrences of "PRINT *" have been replaced by */
/* "WRITE (*,*)". */
/* Calls to UCASE and LJUST replace in-line code that performed */
/* these operations. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (NJB) */
/* -& */
/* $ Index_Entries */
/* write output line to a device */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 4.0.0, 07-APR-1998 (NJB) */
/* References to the PC-LINUX environment were added. */
/* The write format for the case where the output device is the */
/* screen has been made system-dependent; list-directed output */
/* format is now used for systems that require a leading carriage */
/* control character; other systems use character format. The */
/* write format for the case where the output device is a file */
/* has been changed from list-directed to character. */
/* - SPICELIB Version 3.0.0, 11-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* and the appropriate OPEN statement for the Silicon */
/* Graphics, DEC Alpha-OSF/1, and NeXT platforms. The previous */
/* value of 256 for Unix platforms was changed to 255. */
/* - SPICELIB Version 2.1.0, 13-OCT-1992 (HAN) */
/* Module was updated to include the value of FILEN for the */
/* Hewlett Packard UX 9000/750 environment. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 2.0.0, 25-MAR-1991 (NJB) */
/* 1) This routine now can write to files that have been opened */
/* by other routines. WRLINE uses an INQUIRE statement to */
/* determine whether the file indicated by DEVICE is open, */
/* and if it is, WRLINE does not attempt to open it. This */
/* allows use of WRLINE to feed error output into a log file */
/* opened by another routine. */
/* The header has been updated accordingly. */
/* This fix also fixes a bug wherein this routine would treat */
/* different character strings naming the same file as though */
/* they indicated different files. */
/* 2) The limit imposed by this routine on the number of files it */
/* can open has been removed. The file database used in */
/* previous versions of this routine is no longer used. */
/* 3) On VAX systems, this routine now opens the output file */
/* (when required to do so) as a normal text file. */
/* 4) Improper treatment of the case where DEVICE is blank was */
/* remedied. Any value of DEVICE that is not equal to */
/* 'SCREEN' or 'NULL' after being left-justified and */
/* converted to upper case is considered to be a file name. */
/* 5) Unneeded variable declarations and references were removed. */
/* The arrays called STATUS and FILES are not needed. */
/* 6) All instances if "PRINT *" have been replaced by */
/* "WRITE (*,*)" because Language Systems Fortran on the */
/* Macintosh interprets "PRINT *" in a non-standard manner. */
/* 7) Use of the EXIST specifier was added to the INQUIRE */
/* statement used to determine whether the file named by */
/* DEVICE is open. This is a work-around for a rather */
/* peculiar behavior of at least one version of Sun Fortran: */
/* files that don't exist may be considered to be open, as */
/* indicated by the OPENED specifier of the INQUIRE statement. */
/* 8) One other thing: now that LJUST and UCASE are error-free, */
/* WRLINE uses them; this simplifies the code. */
/* - Beta Version 1.2.0, 27-FEB-1989 (NJB) */
/* Call to GETLUN replaced by call to FNDLUN, which is error-free. */
/* Call to IOERR replaced with in-line code to construct long */
/* error message indicating file open failure. Arrangement of */
/* declarations changed. Keywords added. FILEN declaration */
/* moved to "declarations" section. Parameters section added. */
/* - Beta Version 1.1.0, 06-OCT-1988 (NJB) */
/* Upper bound of written substring changed to prevent use of */
/* invalid substring bound. Specifically, LASTNB ( LINE ) was */
/* replaced by MAX ( 1, LASTNB (LINE) ). This upper bound */
/* now used in the PRINT statement as well. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Executable Code: */
switch(n__) {
case 1: goto L_clline;
}
ljust_(device, tmpnam, device_len, (ftnlen)128);
ucase_(tmpnam, tmpnam, (ftnlen)128, (ftnlen)128);
/* TMPNAM is now left justified and is in upper case. */
if (s_cmp(tmpnam, "NULL", (ftnlen)128, (ftnlen)4) == 0) {
return 0;
} else if (s_cmp(tmpnam, "SCREEN", (ftnlen)128, (ftnlen)6) == 0) {
ci__1.cierr = 1;
ci__1.ciunit = 6;
ci__1.cifmt = "(A)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
iostat = do_fio(&c__1, line, rtrim_(line, line_len));
if (iostat != 0) {
goto L100001;
}
iostat = e_wsfe();
L100001:
return 0;
}
/* Find out whether we'll need to open the file. */
/* We use the EXIST inquiry specifier because files that don't exist */
/* may be (possibly due to a Sun compiler bug) deemed to be OPEN by */
/* Sun Fortran. */
i__1 = ltrim_(device, device_len) - 1;
ioin__1.inerr = 1;
ioin__1.infilen = device_len - i__1;
ioin__1.infile = device + i__1;
ioin__1.inex = &exists;
ioin__1.inopen = &opened;
ioin__1.innum = &unit;
ioin__1.innamed = 0;
ioin__1.inname = 0;
ioin__1.inacc = 0;
ioin__1.inseq = 0;
ioin__1.indir = 0;
ioin__1.infmt = 0;
ioin__1.inform = 0;
ioin__1.inunf = 0;
ioin__1.inrecl = 0;
ioin__1.innrec = 0;
ioin__1.inblank = 0;
iostat = f_inqu(&ioin__1);
if (iostat != 0) {
/* This is weird. How can an INQUIRE statement fail, */
/* if the syntax is correct? But just in case... */
s_wsle(&io___6);
do_lio(&c__9, &c__1, "SPICE(INQUIREFAILED)", (ftnlen)20);
e_wsle();
s_wsle(&io___7);
do_lio(&c__9, &c__1, "WRLINE: File = ", (ftnlen)15);
do_lio(&c__9, &c__1, device, device_len);
do_lio(&c__9, &c__1, "IOSTAT = ", (ftnlen)9);
do_lio(&c__3, &c__1, (char *)&iostat, (ftnlen)sizeof(integer));
e_wsle();
return 0;
}
if (! (opened && exists)) {
/* We will need a free logical unit. There is always the chance */
/* that no units are available. */
fndlun_(&unit);
if (unit < 1) {
s_wsle(&io___8);
do_lio(&c__9, &c__1, "SPICE(NOFREELOGICALUNIT)", (ftnlen)24);
e_wsle();
s_wsle(&io___9);
do_lio(&c__9, &c__1, " ", (ftnlen)1);
e_wsle();
s_wsle(&io___10);
do_lio(&c__9, &c__1, "WRLINE: Maximum number of logical units th"
"at can be allocated by SPICELIB has already been reached",
(ftnlen)98);
e_wsle();
return 0;
}
/* Okay, we have a unit. Open the file, and hope nothing */
/* goes awry. (On the VAX, the qualifier */
/* CARRIAGECONTROL = 'LIST' */
/* may be inserted into the OPEN statement.) */
i__1 = ltrim_(device, device_len) - 1;
o__1.oerr = 1;
o__1.ounit = unit;
o__1.ofnmlen = device_len - i__1;
o__1.ofnm = device + i__1;
o__1.orl = 0;
o__1.osta = "NEW";
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
iostat = f_open(&o__1);
if (iostat != 0) {
s_wsle(&io___11);
do_lio(&c__9, &c__1, "SPICE(FILEOPENFAILED)", (ftnlen)21);
e_wsle();
s_wsle(&io___12);
do_lio(&c__9, &c__1, " ", (ftnlen)1);
e_wsle();
s_copy(error, "WRLINE: An error occurred while attempting to open"
, (ftnlen)240, (ftnlen)50);
suffix_(device, &c__1, error, device_len, (ftnlen)240);
suffix_(".", &c__0, error, (ftnlen)1, (ftnlen)240);
suffix_("The value of IOSTAT returned was", &c__2, error, (ftnlen)
32, (ftnlen)240);
suffix_(":", &c__0, error, (ftnlen)1, (ftnlen)240);
intstr_(&iostat, errstr, (ftnlen)11);
suffix_(errstr, &c__1, error, (ftnlen)11, (ftnlen)240);
suffix_(".", &c__0, error, (ftnlen)1, (ftnlen)240);
s_wsle(&io___15);
do_lio(&c__9, &c__1, error, (ftnlen)240);
e_wsle();
return 0;
}
/* Whew! We're ready to write to this file. */
}
/* At this point, either we opened the file, or it was already */
/* opened by somebody else. */
/* This is the easy part. Write the next line to the file. */
ci__1.cierr = 1;
ci__1.ciunit = unit;
ci__1.cifmt = "(A)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100002;
}
iostat = do_fio(&c__1, line, rtrim_(line, line_len));
if (iostat != 0) {
goto L100002;
}
iostat = e_wsfe();
L100002:
/* Well, what happened? Any non-zero value for IOSTAT indicates */
/* an error. */
if (iostat != 0) {
s_copy(error, "WRLINE: An error occurred while attempting to WRITE t"
"o ", (ftnlen)240, (ftnlen)55);
suffix_(device, &c__1, error, device_len, (ftnlen)240);
suffix_(".", &c__0, error, (ftnlen)1, (ftnlen)240);
suffix_("The value of IOSTAT returned was", &c__2, error, (ftnlen)32,
(ftnlen)240);
suffix_(":", &c__0, error, (ftnlen)1, (ftnlen)240);
intstr_(&iostat, errstr, (ftnlen)11);
suffix_(errstr, &c__1, error, (ftnlen)11, (ftnlen)240);
suffix_(".", &c__0, error, (ftnlen)1, (ftnlen)240);
s_wsle(&io___16);
do_lio(&c__9, &c__1, error, (ftnlen)240);
e_wsle();
return 0;
}
return 0;
/* $Procedure CLLINE ( Close a device ) */
L_clline:
/* $ Abstract */
/* Close a device. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* TEXT, FILES, ERROR */
/* $ Declarations */
/* CHARACTER*(*) DEVICE */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* DEVICE I Device to be closed. */
/* $ Detailed_Input */
/* DEVICE is the name of a device which is currently */
/* opened for reading or writing. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* This routine is called by SPICELIB error handling routines, so */
/* it cannot use the normal SPICELIB error signalling mechanism. */
/* Instead, it writes error messages to the screen if necessary. */
/* 1) If the device indicated by DEVICE was not opened by WRLINE, */
/* this routine closes it anyway. */
/* 2) If the INQUIRE performed by this routine fails, an error */
/* diagnosis is printed to the screen. */
/* $ Files */
/* This routin */
/* $ Particulars */
/* CLLINE closes a device that is currently open. */
/* $ Examples */
/* 1) Write two lines to the file, SPUD.DAT (VAX file name */
/* syntax), and then close the file. */
/* CALL WRLINE ( 'SPUD.DAT', ' This is line 1 ' ) */
/* CALL WRLINE ( 'SPUD.DAT', ' This is line 2 ' ) */
/* CALL CLLINE ( 'SPUD.DAT' ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 4.0.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 4.0.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 4.0.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 4.0.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 2.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 2.0.0, 26-MAR-1991 (NJB) */
/* All occurrences of "PRINT *" have been replaced by */
/* "WRITE (*,*)". */
/* Also, this routine now closes the device named by DEVICE */
/* whether or not the device was opened by WRLINE. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (NJB) */
/* -& */
/* $ Index_Entries */
/* None. */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 26-MAR-1991 (NJB) */
/* All instances if "PRINT *" have been replaced by "WRITE (*,*)" */
/* because Language Systems Fortran on the Macintosh interprets */
/* "PRINT *" in a non-standard manner. */
/* This routine no longer has to maintain the file database, since */
/* WRLINE does not use it any more. */
/* Also, this routine now closes the device named by DEVICE, */
/* whether or not the device was opened by WRLINE. */
/* - Beta Version 1.0.1, 08-NOV-1988 (NJB) */
/* Keywords added. */
/* -& */
/* Find the unit connected to DEVICE. */
i__1 = ltrim_(device, device_len) - 1;
ioin__1.inerr = 1;
ioin__1.infilen = device_len - i__1;
ioin__1.infile = device + i__1;
ioin__1.inex = 0;
ioin__1.inopen = 0;
ioin__1.innum = &unit;
ioin__1.innamed = 0;
ioin__1.inname = 0;
ioin__1.inacc = 0;
ioin__1.inseq = 0;
ioin__1.indir = 0;
ioin__1.infmt = 0;
ioin__1.inform = 0;
ioin__1.inunf = 0;
ioin__1.inrecl = 0;
ioin__1.innrec = 0;
ioin__1.inblank = 0;
iostat = f_inqu(&ioin__1);
if (iostat != 0) {
/* This is weird. How can an INQUIRE statement fail, */
/* if the syntax is correct? But just in case... */
s_wsle(&io___17);
do_lio(&c__9, &c__1, "SPICE(INQUIREFAILED)", (ftnlen)20);
e_wsle();
s_wsle(&io___18);
do_lio(&c__9, &c__1, "CLLINE: File = ", (ftnlen)16);
do_lio(&c__9, &c__1, device, device_len);
do_lio(&c__9, &c__1, "IOSTAT = ", (ftnlen)9);
do_lio(&c__3, &c__1, (char *)&iostat, (ftnlen)sizeof(integer));
e_wsle();
return 0;
}
cl__1.cerr = 0;
cl__1.cunit = unit;
cl__1.csta = 0;
f_clos(&cl__1);
return 0;
} /* wrline_ */
/* $Procedure 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 DELTET ( Delta ET, ET - UTC ) */
/* Subroutine */ int deltet_(doublereal *epoch, char *eptype, doublereal *
delta, ftnlen eptype_len)
{
/* Initialized data */
static char missed[20*5] = "DELTET/DELTA_T_A, # " "DELTET/K, # "
"DELTET/EB, # " "DELTET/M, # " "DELTET/DELTA_AT, "
"# ";
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
double d_nint(doublereal *), sin(doublereal);
/* Local variables */
char type__[4];
integer i__;
doublereal k, m[2];
integer n;
doublereal dleap[400] /* was [2][200] */;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer nleap;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen),
errch_(char *, char *, ftnlen, ftnlen);
doublereal leaps, ettai;
logical found[5];
char dtype[1];
doublereal ea, eb, ma, et;
extern /* Subroutine */ int gdpool_(char *, integer *, integer *, integer
*, doublereal *, logical *, ftnlen), sigerr_(char *, ftnlen),
chkout_(char *, ftnlen), dtpool_(char *, logical *, integer *,
char *, ftnlen, ftnlen), setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen);
extern logical return_(void);
doublereal dta, aet;
/* $ Abstract */
/* Return the value of Delta ET (ET-UTC) for an input epoch. */
/* $ 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 */
/* TIME */
/* KERNEL */
/* $ Keywords */
/* TIME */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* EPOCH I Input epoch (seconds past J2000). */
/* EPTYPE I Type of input epoch ('UTC' or 'ET'). */
/* DELTA O Delta ET (ET-UTC) at input epoch. */
/* $ Detailed_Input */
/* EPOCH is the epoch at which Delta ET is to be computed. */
/* This may be either UTC or ephemeris seconds past */
/* J2000, as specified by EPTYPE. */
/* EPTYPE indicates the type of input epoch. It may be either */
/* of the following: */
/* 'UTC' input is UTC seconds past J2000. */
/* 'ET' input is ephemeris seconds past J2000. */
/* $ Detailed_Output */
/* DELTA is the value of */
/* Delta ET = ET - UTC */
/* at the input epoch. This is added to UTC to give */
/* ET, or subtracted from ET to give UTC. The routine */
/* is reversible: that is, given the following calls, */
/* CALL DELTET ( UTC, 'UTC', DEL1 ) */
/* CALL DELTET ( UTC+DEL1, 'ET', DEL2 ) */
/* the expression */
/* ( DEL1 .EQ. DEL2 ) */
/* is always true. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the input epoch is not recognized, the error */
/* SPICE(INVALIDEPOCH) is signaled. */
/* 2) If the variables necessary for the computation of DELTA */
/* have not been loaded into the kernel pool, the error */
/* SPICE(KERNELVARNOTFOUND) is signaled. */
/* 3) If the number of leapseconds in the pool is greater than */
/* the local leapseconds buffer size, the error */
/* SPICE(BUFFEROVERFLOW) is signaled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The constants necessary for computing the offset are taken */
/* from the kernel pool, where they are assumed to have been */
/* loaded from a kernel file. */
/* The tables are consulted to determine the number of leap seconds */
/* preceding the input epoch. Also, an approximation to the periodic */
/* yearly variation (which has an amplitude of just under two */
/* milliseconds) in the difference between ET and TAI (Atomic Time) */
/* is computed. The final value of Delta ET is given by */
/* Delta ET = ( ET - TAI ) + leap seconds */
/* $ Examples */
/* The following example shows how DELTET may be used to convert */
/* from UTC seconds past J2000 to ephemeris seconds past J2000. */
/* CALL DELTET ( UTCSEC, 'UTC', DELTA ) */
/* ET = UTCSEC + DELTA */
/* The following example shows how DELTET may be used to convert */
/* from ephemeris seconds past J2000 to UTC seconds past J2000. */
/* CALL DELTET ( ET, 'ET', DELTA ) */
/* UTCSEC = ET - DELTA */
/* See the TIME required reading for further examples. */
/* $ Restrictions */
/* The routines UTC2ET and ET2UTC are preferred for conversions */
/* between UTC and ET. This routine is provided mainly as a utility */
/* for UTC2ET and ET2UTC. */
/* The kernel pool containing leapseconds and relativistic terms */
/* MUST be loaded prior to calling this subroutine. Examples */
/* demonstrating how to load a kernel pool are included in the */
/* Required Reading file time.req and in the "Examples" */
/* section of this header. For more general information about */
/* kernel pools, please consult the Required Reading file */
/* kernel.req. */
/* $ Literature_References */
/* Astronomical Almanac. */
/* $ Author_and_Institution */
/* W.M. Owen (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.2.2, 18-APR-2014 (BVS) */
/* Minor header edits. */
/* - SPICELIB Version 1.2.1, 18-MAY-2010 (BVS) */
/* Removed "C$" marker from text in the header. */
/* - SPICELIB Version 1.2.0, 24-AUG-1998 (WLT) */
/* The previous upgrade introduced an error in the fetch */
/* of the variable DELTET/M from the kernel pool. This */
/* error was corrected. */
/* - SPICELIB Version 1.1.0, 20-APR-1998 (NJB) */
/* Calls to RTPOOL were replaced with calls to GDPOOL, which */
/* does more robust error checking. Check for buffer overflow */
/* was added. Local declarations were re-organized. */
/* - 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 (WMO) (IMU) */
/* -& */
/* $ Index_Entries */
/* difference between ephemeris time and utc */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.2.0, 24-AUG-1998 (WLT) */
/* The previous upgrade introduced an error in the fetch */
/* of the variable DELTET/M from the kernel pool. This */
/* error was corrected. */
/* - SPICELIB Version 1.1.0, 20-APR-1998 (NJB) */
/* Calls to RTPOOL were replaced with calls to GDPOOL, which */
/* does more robust error checking. */
/* - Beta Version 1.1.0, 06-OCT-1988 (IMU) */
/* Tim Colvin of Rand noticed that times returned by UTC2ET */
/* and TPARSE differed by one second. Upon closer inspection, */
/* crack NAIF staff members deduced that in fact Mr. Colvin */
/* had not loaded the kernel pool, and were surprised to learn */
/* that no error had occurred. */
/* Multiple FOUND flags and a bevy of new error messages were */
/* implemented to cope with this unfortunate oversight. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Saved variables */
/* Initial values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("DELTET", (ftnlen)6);
}
/* Convert the epoch type to uppercase, to simplify comparisons. */
ucase_(eptype, type__, eptype_len, (ftnlen)4);
/* Extract the necessary constants from the kernel pool. */
/* Leap seconds and their epochs are interleaved in DELTA_AT. */
/* DLEAP(1,i) is the number of leap seconds at DLEAP(2,i) UTC */
/* seconds past J2000. */
gdpool_("DELTET/DELTA_T_A", &c__1, &c__1, &n, &dta, found, (ftnlen)16);
gdpool_("DELTET/K", &c__1, &c__1, &n, &k, &found[1], (ftnlen)8);
gdpool_("DELTET/EB", &c__1, &c__1, &n, &eb, &found[2], (ftnlen)9);
gdpool_("DELTET/M", &c__1, &c__2, &n, m, &found[3], (ftnlen)8);
/* Check that the number of leapseconds is not too great for our */
/* buffer size (not likely). */
dtpool_("DELTET/DELTA_AT", &found[4], &nleap, dtype, (ftnlen)15, (ftnlen)
1);
if (nleap > 400) {
setmsg_("Number of leapseconds, #, is greater than the number that c"
"an be buffered, #.", (ftnlen)77);
i__1 = nleap / 2;
errint_("#", &i__1, (ftnlen)1);
errint_("#", &c__200, (ftnlen)1);
sigerr_("SPICE(BUFFERTOOSMALL)", (ftnlen)21);
chkout_("DELTET", (ftnlen)6);
return 0;
}
gdpool_("DELTET/DELTA_AT", &c__1, &c__400, &nleap, dleap, &found[4], (
ftnlen)15);
nleap /= 2;
if (! (found[0] && found[1] && found[2] && found[3] && found[4])) {
setmsg_("The following, needed to compute Delta ET (ET - UTC), could"
" not be found in the kernel pool: #", (ftnlen)94);
for (i__ = 1; i__ <= 5; ++i__) {
if (! found[(i__1 = i__ - 1) < 5 && 0 <= i__1 ? i__1 : s_rnge(
"found", i__1, "deltet_", (ftnlen)341)]) {
errch_("#", missed + ((i__1 = i__ - 1) < 5 && 0 <= i__1 ?
i__1 : s_rnge("missed", i__1, "deltet_", (ftnlen)342))
* 20, (ftnlen)1, (ftnlen)20);
}
}
errch_(", #", ".", (ftnlen)3, (ftnlen)1);
sigerr_("SPICE(KERNELVARNOTFOUND)", (ftnlen)24);
chkout_("DELTET", (ftnlen)6);
return 0;
}
/* There are two separate quantities to be determined. First, */
/* the appropriate number of leap seconds. Second, the size of */
/* the periodic term ET-TAI. */
/* For epochs before the first leap second, return Delta ET at */
/* the epoch of the leap second minus one second. */
leaps = dleap[0] - 1;
/* When counting leap seconds for UTC epochs, we can compare */
/* directly against the values in DLEAP. */
if (s_cmp(type__, "UTC", (ftnlen)4, (ftnlen)3) == 0) {
i__1 = nleap;
for (i__ = 1; i__ <= i__1; ++i__) {
if (*epoch >= dleap[(i__2 = (i__ << 1) - 1) < 400 && 0 <= i__2 ?
i__2 : s_rnge("dleap", i__2, "deltet_", (ftnlen)375)]) {
leaps = dleap[(i__2 = (i__ << 1) - 2) < 400 && 0 <= i__2 ?
i__2 : s_rnge("dleap", i__2, "deltet_", (ftnlen)376)];
}
}
/* For ET epochs, things are a little tougher. In order to compare */
/* the input epoch against the epochs of the leap seconds, we need */
/* to compute ET-TAI at each of the leap epochs. To make sure that */
/* the computation is reversible, it is always done at the nearest */
/* ET second (the "approximate ET", or AET). */
/* There must be a hundred ways to do this more efficiently. */
/* For now, we'll settle for one that works. */
} else if (s_cmp(type__, "ET", (ftnlen)4, (ftnlen)2) == 0) {
i__1 = nleap;
for (i__ = 1; i__ <= i__1; ++i__) {
if (*epoch > dleap[(i__2 = (i__ << 1) - 1) < 400 && 0 <= i__2 ?
i__2 : s_rnge("dleap", i__2, "deltet_", (ftnlen)393)]) {
d__1 = dleap[(i__2 = (i__ << 1) - 1) < 400 && 0 <= i__2 ?
i__2 : s_rnge("dleap", i__2, "deltet_", (ftnlen)395)]
+ dta + dleap[(i__3 = (i__ << 1) - 2) < 400 && 0 <=
i__3 ? i__3 : s_rnge("dleap", i__3, "deltet_", (
ftnlen)395)];
aet = d_nint(&d__1);
ma = m[0] + m[1] * aet;
ea = ma + eb * sin(ma);
ettai = k * sin(ea);
et = dleap[(i__2 = (i__ << 1) - 1) < 400 && 0 <= i__2 ? i__2 :
s_rnge("dleap", i__2, "deltet_", (ftnlen)401)] + dta
+ dleap[(i__3 = (i__ << 1) - 2) < 400 && 0 <= i__3 ?
i__3 : s_rnge("dleap", i__3, "deltet_", (ftnlen)401)]
+ ettai;
if (*epoch >= et) {
leaps = dleap[(i__2 = (i__ << 1) - 2) < 400 && 0 <= i__2 ?
i__2 : s_rnge("dleap", i__2, "deltet_", (ftnlen)
404)];
}
}
}
/* Uh, those are the only choices. */
} else {
setmsg_("Epoch type was #", (ftnlen)16);
errch_("#", type__, (ftnlen)1, (ftnlen)4);
sigerr_("SPICE(INVALIDEPOCH)", (ftnlen)19);
chkout_("DELTET", (ftnlen)6);
return 0;
}
/* Add the constant offset, leap seconds, and the relativistic term */
/* (as before, computed at the nearest ET second). */
if (s_cmp(type__, "ET", (ftnlen)4, (ftnlen)2) == 0) {
aet = d_nint(epoch);
} else if (s_cmp(type__, "UTC", (ftnlen)4, (ftnlen)3) == 0) {
d__1 = *epoch + dta + leaps;
aet = d_nint(&d__1);
}
ma = m[0] + m[1] * aet;
ea = ma + eb * sin(ma);
ettai = k * sin(ea);
*delta = dta + leaps + ettai;
chkout_("DELTET", (ftnlen)6);
return 0;
} /* deltet_ */
/* $Procedure VERSION ( Print library version information ) */
/* Main program */ MAIN__(void)
{
/* System generated locals */
address a__1[2], a__2[4];
integer i__1[2], i__2, i__3[4], i__4;
doublereal d__1;
char ch__1[25], ch__2[99];
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen),
s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
char line[80], vrsn[6];
extern /* Subroutine */ int zzplatfm_(char *, char *, ftnlen, ftnlen);
integer i__;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
extern doublereal dpmin_(void);
extern /* Subroutine */ int repmd_(char *, char *, doublereal *, integer *
, char *, ftnlen, ftnlen, ftnlen);
extern doublereal dpmax_(void);
char fform[80];
extern /* Subroutine */ int repmi_(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
char cmplr[80];
extern integer wdcnt_(char *, ftnlen);
char tform[80];
extern integer rtrim_(char *, ftnlen);
char os[80];
extern /* Subroutine */ int getcml_(char *, ftnlen), byebye_(char *,
ftnlen);
extern integer intmin_(void), intmax_(void);
char linout[80*6];
extern /* Subroutine */ int tostdo_(char *, ftnlen), tkvrsn_(char *, char
*, ftnlen, ftnlen);
extern integer pos_(char *, char *, integer *, ftnlen, ftnlen);
char sys[80];
/* $ Abstract */
/* This program prints to standard output the current SPICE */
/* distribution version number, hardware system ID, operating */
/* system ID, compiler name, the format of double precision */
/* numbers for the hardware architecture, and the max and min */
/* values for double precision and integer numbers. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keyword */
/* VERSION */
/* UTILITY */
/* $ Parameters */
/* LINELN length of line output string, set to 80. */
/* DATEID update version time string, set to 20. */
/* $ Exceptions */
/* None. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The version utility may use 3 different command line arguments. */
/* The default (no arguments) returns the Toolkit version string. */
/* Usage: $ version [OPTION] */
/* $ Description */
/* None. */
/* $ Examples */
/* Default behavior: */
/* $ version */
/* N0051 */
/* Display all (-a) information: */
/* $version -a */
/* Toolkit version : N0051 */
/* System : PC */
/* Operating System : LINUX */
/* Compiler : LINUX G77 */
/* File Format : LTL-IEEE */
/* MAX DP : 1.7976931348623E+308 */
/* MIN DP : -1.7976931348623E+308 */
/* MAX INT : 2147483647 */
/* MIN INT : -2147483647 */
/* Display version (-v) information: */
/* $version -v */
/* Version Utility for SPICE Toolkit edition N0051, */
/* last update: 1.1.0, 05-OCT-2001 */
/* Display help (-h) information: */
/* $version -h */
/* Usage: version [OPTION] */
/* no arguments output only the SPICE toolkit version string. */
/* -a(ll) output all environment variables; SPICE toolkit */
/* version, system ID, operating system, compiler, */
/* binary file format, max and min values for */
/* double precision and integer numbers. */
/* -v(ersion) output the version of the utility. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* F.S. Turner (JPL) */
/* E.D. Wright (JPL) */
/* $ Version */
/* SPICELIB Version 1.1.0 26-SEP-2001 (FST) (EDW) */
/* Added TEXT_FORMAT output. */
/* Included options for SYSTEM, O/S, COMPILER, FILE_FORMAT, */
/* max/min DPs & integers, outputs, version, and help. */
/* Added proper SPICE header. */
/* SPICELIB Version 1.0.0 13-NOV-2001 (WLT) */
/* First version, Thu NOV 13 10:04:41 PST 1997 W.L. Taber */
/* -& */
/* SPICELIB functions. */
/* Local Parameters. */
/* Local Variables. */
/* Get command line. */
getcml_(line, (ftnlen)80);
ucase_(line, line, (ftnlen)80, (ftnlen)80);
tkvrsn_("TOOLKIT", vrsn, (ftnlen)7, (ftnlen)6);
/* Parse the command line for arguments. Appropriately respond. */
if (wdcnt_(line, (ftnlen)80) == 0) {
/* No arguments, default to the toolkit version string. */
tostdo_(vrsn, rtrim_(vrsn, (ftnlen)6));
} else if (pos_(line, "-A", &c__1, (ftnlen)80, (ftnlen)2) == 1) {
/* All. Output everything. */
tostdo_(" ", (ftnlen)1);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "Toolkit version : ";
i__1[1] = 6, a__1[1] = vrsn;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)25);
tostdo_(ch__1, (ftnlen)25);
zzplatfm_("SYSTEM", sys, (ftnlen)6, (ftnlen)80);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "System : ";
i__1[1] = 80, a__1[1] = sys;
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)99);
tostdo_(ch__2, (ftnlen)99);
zzplatfm_("O/S", os, (ftnlen)3, (ftnlen)80);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "Operating System : ";
i__1[1] = 80, a__1[1] = os;
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)99);
tostdo_(ch__2, (ftnlen)99);
zzplatfm_("COMPILER", cmplr, (ftnlen)8, (ftnlen)80);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "Compiler : ";
i__1[1] = 80, a__1[1] = cmplr;
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)99);
tostdo_(ch__2, (ftnlen)99);
zzplatfm_("FILE_FORMAT", fform, (ftnlen)11, (ftnlen)80);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "File Format : ";
i__1[1] = 80, a__1[1] = fform;
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)99);
tostdo_(ch__2, (ftnlen)99);
zzplatfm_("TEXT_FORMAT", tform, (ftnlen)11, (ftnlen)80);
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "Text File Format : ";
i__1[1] = 80, a__1[1] = tform;
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)99);
tostdo_(ch__2, (ftnlen)99);
s_copy(linout, "MAX DP : #", (ftnlen)80, (ftnlen)21);
d__1 = dpmax_();
repmd_(linout, "#", &d__1, &c__23, linout, (ftnlen)80, (ftnlen)1, (
ftnlen)80);
tostdo_(linout, (ftnlen)80);
s_copy(linout + 80, "MIN DP : #", (ftnlen)80, (ftnlen)20);
d__1 = dpmin_();
repmd_(linout + 80, "#", &d__1, &c__23, linout + 80, (ftnlen)80, (
ftnlen)1, (ftnlen)80);
tostdo_(linout + 80, (ftnlen)80);
s_copy(linout + 160, "MAX INT : #", (ftnlen)80, (ftnlen)21);
i__2 = intmax_();
repmi_(linout + 160, "#", &i__2, linout + 160, (ftnlen)80, (ftnlen)1,
(ftnlen)80);
tostdo_(linout + 160, (ftnlen)80);
s_copy(linout + 240, "MIN INT : #", (ftnlen)80, (ftnlen)20);
i__2 = intmin_();
repmi_(linout + 240, "#", &i__2, linout + 240, (ftnlen)80, (ftnlen)1,
(ftnlen)80);
tostdo_(linout + 240, (ftnlen)80);
tostdo_(" ", (ftnlen)1);
} else if (pos_(line, "-V", &c__1, (ftnlen)80, (ftnlen)2) == 1) {
/* Version. Output the utility version string. */
/* Writing concatenation */
i__3[0] = 42, a__2[0] = "Version Utility for SPICE Toolkit edition ";
i__3[1] = rtrim_(vrsn, (ftnlen)6), a__2[1] = vrsn;
i__3[2] = 15, a__2[2] = ", last update: ";
i__3[3] = 18, a__2[3] = "1.1.0, 07-JAN-2002 ";
s_cat(linout, a__2, i__3, &c__4, (ftnlen)80);
tostdo_(" ", (ftnlen)1);
tostdo_(linout, (ftnlen)80);
tostdo_(" ", (ftnlen)1);
} else if (pos_(line, "-H", &c__1, (ftnlen)80, (ftnlen)2) == 1) {
/* Help. How does does one use this perplexing routine? */
s_copy(linout, "Usage: version [OPTION]", (ftnlen)80, (ftnlen)23);
s_copy(linout + 80, " no arguments output only the SPICE toolkit v"
"ersion string.", (ftnlen)80, (ftnlen)61);
s_copy(linout + 160, " -a(ll) output all environment variabl"
"es; SPICE toolkit version, system", (ftnlen)80, (ftnlen)79);
s_copy(linout + 240, " ID, operating system, compiler"
", and binary file format, ", (ftnlen)80, (ftnlen)72);
s_copy(linout + 320, " max and min values for double "
"precision and integer numbers.", (ftnlen)80, (ftnlen)76);
s_copy(linout + 400, " -v(ersion) output the version of the util"
"ity.", (ftnlen)80, (ftnlen)50);
tostdo_(" ", (ftnlen)1);
for (i__ = 1; i__ <= 6; ++i__) {
tostdo_(linout + ((i__2 = i__ - 1) < 6 && 0 <= i__2 ? i__2 :
s_rnge("linout", i__2, "version_", (ftnlen)272)) * 80,
rtrim_(linout + ((i__4 = i__ - 1) < 6 && 0 <= i__4 ? i__4
: s_rnge("linout", i__4, "version_", (ftnlen)272)) * 80, (
ftnlen)80));
}
tostdo_(" ", (ftnlen)1);
} else {
/* The user put something on the command line, but nothing */
/* known. Return the toolkit version string. */
tostdo_(vrsn, rtrim_(vrsn, (ftnlen)6));
}
/* Done. Indicate as much. Say bye. */
byebye_("SUCCESS", (ftnlen)7);
s_stop("", (ftnlen)0);
return 0;
} /* MAIN__ */
/* $Procedure PRTPKG ( Declare Arguments for Error Message Routines ) */
logical prtpkg_0_(int n__, logical *short__, logical *long__, logical *expl,
logical *trace, logical *dfault, char *type__, ftnlen type_len)
{
/* Initialized data */
static logical svshrt = TRUE_;
static logical svexpl = TRUE_;
static logical svlong = TRUE_;
static logical svtrac = TRUE_;
static logical svdflt = TRUE_;
/* System generated locals */
address a__1[2];
integer i__1[2];
logical ret_val;
char ch__1[96];
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
/* Local variables */
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
char ltype[10];
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
char device[128];
extern /* Subroutine */ int getdev_(char *, ftnlen), wrline_(char *, char
*, ftnlen, ftnlen);
char loctyp[10];
/* $ Abstract */
/* Declare the arguments for the error message selection entry */
/* points. DO NOT CALL THIS ROUTINE. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* ERROR */
/* $ Keywords */
/* ERROR */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O ENTRY */
/* -------- --- -------------------------------------------------- */
/* SHORT I SETPRT */
/* EXPL I SETPRT */
/* LONG I SETPRT */
/* TRACE I SETPRT */
/* DFAULT I SETPRT */
/* TYPE I MSGSEL */
/* FILEN P MSGSEL */
/* $ Detailed_Input */
/* See the ENTRY points for discussions of their arguments. */
/* $ Detailed_Output */
/* See the ENTRY points for discussions of their arguments. */
/* $ Parameters */
/* See the ENTRY points for discussions of their parameters. */
/* $ Exceptions */
/* This routine signals an error IF IT IS CALLED. */
/* $ Files */
/* None. */
/* $ Particulars */
/* DO NOT CALL THIS ROUTINE. */
/* The entry points declared in this routine are: */
/* SETPRT */
/* MSGSEL */
/* There is no reason to call this subroutine. */
/* The purpose of this subroutine is to make the */
/* declarations required by the various entry points. */
/* This routine has no run-time function. */
/* $ Examples */
/* None. DO NOT CALL THIS ROUTINE. */
/* $ Restrictions */
/* DO NOT CALL THIS ROUTINE. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* $ Version */
/* - SPICELIB Version 3.25.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 3.24.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 3.23.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 3.22.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 3.21.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 3.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 3.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 3.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 3.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 3.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 3.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 3.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 3.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 3.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 3.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 3.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 3.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 3.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 3.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 3.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 3.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 3.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 3.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 3.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 3.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 3.0.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 3.0.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 3.0.3, 24-SEP-1999 (NJB) */
/* CSPICE environments were added. Some typos were corrected. */
/* - SPICELIB Version 3.0.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 3.0.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 3.0.0, 07-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 2.0.0, 9-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* for the Silicon Graphics, DEC Alpha-OSF/1, and */
/* NeXT platforms. Also, the previous value of 256 for */
/* Unix platforms was changed to 255. */
/* - SPICELIB Version 1.1.0, 12-OCT-1992 (HAN) */
/* Updated module for multiple environments. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 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 (NJB) */
/* -& */
/* $ Index_Entries */
/* None. */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 3.0.0, 07-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 2.0.0, 9-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* for the Silicon Graphics, DEC Alpha-OSF/1, and */
/* NeXT platforms. Also, the previous value of 256 for */
/* Unix platforms was changed to 255. */
/* - SPICELIB Version 1.1.0, 12-OCT-1992 (HAN) */
/* Updated module for multiple environments. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - Beta Version 1.1.0, 13-DEC-1989 (NJB) */
/* PRTPKG, though it performs no run-time function, must */
/* still return a value, in order to comply with the Fortran */
/* standard. So, now it does. */
/* - Beta Version 1.0.1, 08-FEB-1989 (NJB) */
/* Warnings added to discourage use of this routine. */
/* Parameter declarations moved to "Declarations" section. */
/* Two local declarations moved to the correct location. */
/* -& */
/* SPICELIB functions */
/* Local variables: */
/* Saved variables: */
/* Initial values: */
switch(n__) {
case 1: goto L_setprt;
case 2: goto L_msgsel;
}
/* Executable Code: */
getdev_(device, (ftnlen)128);
wrline_(device, "PRTPKG: You have called an entry point which has no ru"
"n-time function; this may indicate a program bug. Please check "
"the PRTPKG documentation. ", (ftnlen)128, (ftnlen)146);
wrline_(device, "SPICE(BOGUSENTRY)", (ftnlen)128, (ftnlen)17);
ret_val = FALSE_;
return ret_val;
/* $Procedure SETPRT ( Store Error Message Types to be Output ) */
L_setprt:
/* $ Abstract */
/* Store (a representation of) the selection of types of error */
/* messages to be output. DO NOT CALL THIS ROUTINE. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* ERROR */
/* $ Keywords */
/* ERROR */
/* $ Declarations */
/* LOGICAL SHORT */
/* LOGICAL EXPL */
/* LOGICAL LONG */
/* LOGICAL TRACE */
/* LOGICAL DFAULT */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* SHORT I Select output of short error message? */
/* EXPL I Select output of explanation of short message? */
/* LONG I Select output of long error message? */
/* TRACE I Select output of traceback? */
/* DFAULT I Select output of default message? */
/* $ Detailed_Input */
/* SHORT indicates whether the short error message is selected */
/* as one of the error messages to be output when an error */
/* is detected. A value of .TRUE. indicates that the */
/* short error message IS selected. */
/* EXPL indicates whether the explanatory text for the short */
/* error message is selected as one of the error messages */
/* to be output when an error is detected. A value of */
/* .TRUE. indicates that the explanatory text for the */
/* short error message IS selected. */
/* LONG indicates whether the long error message is selected */
/* as one of the error messages to be output when an error */
/* is detected. A value of .TRUE. indicates that the */
/* long error message IS selected. */
/* TRACE indicates whether the traceback is selected */
/* as one of the error messages to be output when an error */
/* is detected. A value of .TRUE. indicates that the */
/* traceback IS selected. */
/* DFAULT indicates whether the default message is selected */
/* as one of the error messages to be output when an error */
/* is detected. A value of .TRUE. indicates that the */
/* default message IS selected. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Files */
/* None. */
/* $ Particulars */
/* DO NOT CALL THIS ROUTINE. */
/* The effect of this routine is an ENVIRONMENTAL one. This */
/* routine performs no output; it stores the error message */
/* selection provided as input. */
/* Note that the actual output of error messages depends not */
/* only on the selection made using this routine, but also */
/* on the selection of the error output device (see ERRDEV) */
/* and the choice of error response action (see ERRACT). If */
/* the action is not 'IGNORE' (possible choices are */
/* 'IGNORE', 'ABORT', 'DEFAULT', 'REPORT', and 'RETURN'), */
/* the selected error messages will be written to the chosen */
/* output device when an error is detected. */
/* $ Examples */
/* 1. In this example, the short and long messages are selected. */
/* C */
/* C Select short and long error messages for output */
/* C (We don't examine the status returned because no */
/* C errors are detected by SETPRT): */
/* C */
/* STATUS = SETPRT ( .TRUE., .FALSE., .TRUE., .FALSE., */
/* . .FALSE. ) */
/* $ Restrictions */
/* DO NOT CALL THIS ROUTINE. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 3.0.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 3.0.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 3.0.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 3.0.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - 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 (NJB) */
/* -& */
/* $ Index_Entries */
/* None. */
/* -& */
/* $ Revisions */
/* - Beta Version 1.0.1, 08-FEB-1989 (NJB) */
/* Warnings added to discourage use of this routine in */
/* non-error-handling code. Parameters section added. */
/* -& */
/* Executable Code: */
if (*short__) {
svshrt = TRUE_;
} else {
svshrt = FALSE_;
}
if (*expl) {
svexpl = TRUE_;
} else {
svexpl = FALSE_;
}
if (*long__) {
svlong = TRUE_;
} else {
svlong = FALSE_;
}
if (*trace) {
svtrac = TRUE_;
} else {
svtrac = FALSE_;
}
if (*dfault) {
svdflt = TRUE_;
} else {
svdflt = FALSE_;
}
/* We assign a value to SETPRT, but this value is */
/* not meaningful... */
ret_val = TRUE_;
return ret_val;
/* $Procedure MSGSEL ( Is This Message Type Selected for Output? ) */
L_msgsel:
/* $ Abstract */
/* Indicate whether the specified message type has been selected */
/* for output. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* ERROR */
/* $ Keywords */
/* ERROR */
/* $ Declarations */
/* TYPE */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* TYPE I Type of message whose selection status is queried. */
/* FILEN P Maximum length of a file name. */
/* The function takes the value .TRUE. if the message type indicated */
/* by TYPE has been selected for output to the error output device. */
/* $ Detailed_Input */
/* TYPE Refers to a type of error message. Possible values */
/* are 'SHORT', 'EXPLAIN', 'LONG', 'DEFAULT', */
/* and 'TRACEBACK'. */
/* $ Detailed_Output */
/* The function takes the value .TRUE. if the message type indicated */
/* by TYPE has been selected for output to the error output device. */
/* $ Parameters */
/* FILEN is the maximum length of a file name. */
/* $ Exceptions */
/* Additionally, invalid values of TYPE are detected. */
/* The short error message set in this case is: */
/* 'SPICE(INVALIDMSGTYPE)' */
/* The handling of this error is a special case; to avoid recursion */
/* problems, SIGERR is not called when the error is detected. */
/* Instead, the short and long error messages are output directly. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine is part of the SPICELIB error handling mechanism. */
/* Note that even though a given type of message may have been */
/* selected for output, the output device and error response */
/* action must also have been selected appropriately. */
/* Use ERRDEV to choose the output device for error messages. */
/* Use ERRACT to choose the error response action. Any action */
/* other than 'IGNORE' will result in error messages being */
/* written to the error output device when errors are detected. */
/* See ERRACT for details. */
/* $ Examples */
/* 1. We want to know if the short message has been selected */
/* for output: */
/* C */
/* C Test whether the short message has been selected: */
/* C */
/* SELECT = MSGSEL ( 'SHORT' ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 3.0.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 3.0.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 3.0.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 3.0.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - 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 (NJB) */
/* -& */
/* $ Index_Entries */
/* None. */
/* -& */
/* $ Revisions */
/* - Beta Version 1.0.1, 08-FEB-1989 (NJB) */
/* Parameters section added; parameter declaration added */
/* to brief I/O section as well. */
/* -& */
/* Executable Code: */
ljust_(type__, ltype, type_len, (ftnlen)10);
ucase_(ltype, ltype, (ftnlen)10, (ftnlen)10);
if (s_cmp(ltype, "SHORT", (ftnlen)10, (ftnlen)5) == 0) {
ret_val = svshrt;
} else if (s_cmp(ltype, "EXPLAIN", (ftnlen)10, (ftnlen)7) == 0) {
ret_val = svexpl;
} else if (s_cmp(ltype, "LONG", (ftnlen)10, (ftnlen)4) == 0) {
ret_val = svlong;
} else if (s_cmp(ltype, "TRACEBACK", (ftnlen)10, (ftnlen)9) == 0) {
ret_val = svtrac;
} else if (s_cmp(ltype, "DEFAULT", (ftnlen)10, (ftnlen)7) == 0) {
ret_val = svdflt;
} else {
/* Bad value of type! We have a special case here; to */
/* avoid recursion, we output the messages directly, */
/* rather than call SIGERR. */
getdev_(device, (ftnlen)128);
wrline_(device, "SPICE(INVALIDMSGTYPE)", (ftnlen)128, (ftnlen)21);
wrline_(device, " ", (ftnlen)128, (ftnlen)1);
s_copy(loctyp, type__, (ftnlen)10, type_len);
/* Note: What looks like a typo below isn't; there's */
/* a line break after the substring 'specified' of */
/* the "word" 'specifiedwas'. */
/* Writing concatenation */
i__1[0] = 86, a__1[0] = "MSGSEL: An invalid error message type was "
"supplied as input; the type specifiedwas: ";
i__1[1] = 10, a__1[1] = loctyp;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)96);
wrline_(device, ch__1, (ftnlen)128, (ftnlen)96);
}
return ret_val;
} /* prtpkg_ */
/* $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 CNFIRM_1 ( Return status of a yes/no query ) */
/* Subroutine */ int cnfirm_1__(char *prmpt, logical *torf, ftnlen prmpt_len)
{
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
logical yesno;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
char respns[256];
extern /* Subroutine */ int prompt_(char *, char *, ftnlen, ftnlen);
/* $ Abstract */
/* Return the .TRUE./.FALSE. status of a query which has a yes/no */
/* response. */
/* $ 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 */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* PRMPT I The prompt used to elicit a yes/no response. */
/* TORF O The truth value of a yes/no response. */
/* $ Detailed_Input */
/* PRMPT The prompt which is used to elicit a yes/no response. */
/* $ Detailed_Output */
/* TORF A logical flag which indicates the truth value of a */
/* yes/no response to a continue/try again prompt. If the */
/* response was equivalent to yes, TORF = .TRUE.. If the */
/* response was equivalent to no, TORF = .FALSE.. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* 1) Any input value that is not equivalent to 'Y', 'YES', 'N' */
/* or 'NO' (or lower case equivalents), will cause the routine */
/* to redisplay the prompt. A yes/no response MUST be given, */
/* there are no implicit values for any other response. */
/* $ Files */
/* None. */
/* $ Particulars */
/* Often a program needs to ask whether or not a user wishes */
/* to exercise some option. This routine simplifies the task */
/* of converting the answer to a logical value. */
/* If the response to a yes/no question is logically equivalent */
/* to 'YES' the variable TORF will be set to a value of .TRUE. */
/* If the response to a yes/no question is logically equivalent */
/* to 'NO' the variable TORF will be set to a value of .FALSE. */
/* Any other response will cause the routine to redisplay the */
/* prompt. */
/* $ Examples */
/* Suppose you need to ask a user whether or not diagnostic */
/* information about the behaviour of a program should be */
/* written to a file. Using this routine, you can easily */
/* take the action desired and avoid the details of parsing */
/* the user's answer. */
/* PRMPT = 'Log information to a file? (Yes/No) ' */
/* OK = .FALSE. */
/* CALL CONFRM( PRMPT, OK ) */
/* IF ( OK ) THEN */
/* ...enable recording diagnostics in the log file. */
/* ELSE */
/* ...disable recording of diagnostics. */
/* END IF */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - META/2 Configured Version 2.0.0, 9-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 9, 1994 */
/* - META/2 Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of META/2 */
/* software as of May 3, 1994 */
/* - Beta Version 1.0.0, 09-SEP-1992 (KRG) */
/* -& */
/* $ Index_Entries */
/* prompt with a yes/no query and return logical response */
/* -& */
/* SPICELIB functions */
/* None. */
/* Local Parameters */
/* Local Variables */
/* Do while we have not gotten a yes/no response */
yesno = FALSE_;
while(! yesno) {
/* Prompt for a response */
prompt_(prmpt, respns, prmpt_len, (ftnlen)256);
/* Left justify the response string, RESPNS, and convert it to */
/* uppercase. */
ljust_(respns, respns, (ftnlen)256, (ftnlen)256);
ucase_(respns, respns, (ftnlen)256, (ftnlen)256);
if (s_cmp(respns, "Y", (ftnlen)256, (ftnlen)1) == 0 || s_cmp(respns,
"YES", (ftnlen)256, (ftnlen)3) == 0) {
*torf = TRUE_;
yesno = TRUE_;
} else if (s_cmp(respns, "N", (ftnlen)256, (ftnlen)1) == 0 || s_cmp(
respns, "NO", (ftnlen)256, (ftnlen)2) == 0) {
*torf = FALSE_;
yesno = TRUE_;
}
}
return 0;
} /* cnfirm_1__ */
/* $Procedure ZZEDTERM ( Ellipsoid terminator ) */
/* Subroutine */ int zzedterm_(char *type__, doublereal *a, doublereal *b,
doublereal *c__, doublereal *srcrad, doublereal *srcpos, integer *
npts, doublereal *trmpts, ftnlen type_len)
{
/* System generated locals */
integer trmpts_dim2, i__1, i__2;
doublereal d__1, d__2, d__3;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
double asin(doublereal);
integer s_rnge(char *, integer, char *, integer);
double d_sign(doublereal *, doublereal *);
/* Local variables */
extern /* Subroutine */ int vadd_(doublereal *, doublereal *, doublereal *
);
doublereal rmin, rmax;
extern /* Subroutine */ int vscl_(doublereal *, doublereal *, doublereal *
);
extern doublereal vdot_(doublereal *, doublereal *), vsep_(doublereal *,
doublereal *);
integer nitr;
extern /* Subroutine */ int vsub_(doublereal *, doublereal *, doublereal *
), vequ_(doublereal *, doublereal *);
doublereal d__, e[3];
integer i__;
doublereal s, angle, v[3], x[3], delta, y[3], z__[3], inang;
extern /* Subroutine */ int chkin_(char *, ftnlen), frame_(doublereal *,
doublereal *, doublereal *);
doublereal plane[4];
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen),
errch_(char *, char *, ftnlen, ftnlen), vpack_(doublereal *,
doublereal *, doublereal *, doublereal *);
doublereal theta;
extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen);
doublereal trans[9] /* was [3][3] */, srcpt[3], vtemp[3];
extern doublereal vnorm_(doublereal *), twopi_(void);
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen),
pl2nvc_(doublereal *, doublereal *, doublereal *);
doublereal lambda;
extern /* Subroutine */ int nvp2pl_(doublereal *, doublereal *,
doublereal *);
extern doublereal halfpi_(void);
doublereal minang, minrad, maxang, maxrad;
extern /* Subroutine */ int latrec_(doublereal *, doublereal *,
doublereal *, doublereal *);
doublereal angerr;
logical umbral;
extern doublereal touchd_(doublereal *);
doublereal offset[3], prvdif;
extern /* Subroutine */ int sigerr_(char *, ftnlen);
doublereal outang, plcons, prvang;
extern /* Subroutine */ int chkout_(char *, ftnlen), setmsg_(char *,
ftnlen), errint_(char *, integer *, ftnlen);
char loctyp[50];
extern logical return_(void);
extern /* Subroutine */ int vminus_(doublereal *, doublereal *);
doublereal dir[3];
extern /* Subroutine */ int mxv_(doublereal *, doublereal *, doublereal *)
;
doublereal vtx[3];
/* $ 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. */
/* Compute a set of points on the umbral or penumbral terminator of */
/* a specified ellipsoid, given a spherical light source. */
/* $ 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 */
/* ELLIPSES */
/* $ Keywords */
/* BODY */
/* GEOMETRY */
/* MATH */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* TYPE I Terminator type. */
/* A I Length of ellipsoid semi-axis lying on the x-axis. */
/* B I Length of ellipsoid semi-axis lying on the y-axis. */
/* C I Length of ellipsoid semi-axis lying on the z-axis. */
/* SRCRAD I Radius of light source. */
/* SRCPOS I Position of center of light source. */
/* NPTS I Number of points in terminator point set. */
/* TRMPTS O Terminator point set. */
/* $ Detailed_Input */
/* TYPE is a string indicating the type of terminator to */
/* compute: umbral or penumbral. The umbral */
/* terminator is the boundary of the portion of the */
/* ellipsoid surface in total shadow. The penumbral */
/* terminator is the boundary of the portion of the */
/* surface that is completely illuminated. Possible */
/* values of TYPE are */
/* 'UMBRAL' */
/* 'PENUMBRAL' */
/* Case and leading or trailing blanks in TYPE are */
/* not significant. */
/* A, */
/* B, */
/* C are the lengths of the semi-axes of a triaxial */
/* ellipsoid. The ellipsoid is centered at the */
/* origin and oriented so that its axes lie on the */
/* x, y and z axes. A, B, and C are the lengths of */
/* the semi-axes that point in the x, y, and z */
/* directions respectively. */
/* Length units associated with A, B, and C must */
/* match those associated with SRCRAD, SRCPOS, */
/* and the output TRMPTS. */
/* SRCRAD is the radius of the spherical light source. */
/* SRCPOS is the position of the center of the light source */
/* relative to the center of the ellipsoid. */
/* NPTS is the number of terminator points to compute. */
/* $ Detailed_Output */
/* TRMPTS is an array of points on the umbral or penumbral */
/* terminator of the ellipsoid, as specified by the */
/* input argument TYPE. The Ith point is contained */
/* in the array elements */
/* TRMPTS(J,I), J = 1, 2, 3 */
/* The terminator points are expressed in the */
/* body-fixed reference frame associated with the */
/* ellipsoid. Units are those associated with */
/* the input axis lengths. */
/* Each terminator point is the point of tangency of */
/* a plane that is also tangent to the light source. */
/* These associated points of tangency on the light */
/* source have uniform distribution in longitude when */
/* expressed in a cylindrical coordinate system whose */
/* Z-axis is SRCPOS. The magnitude of the separation */
/* in longitude between these tangency points on the */
/* light source is */
/* 2*Pi / NPTS */
/* If the target is spherical, the terminator points */
/* also are uniformly distributed in longitude in the */
/* cylindrical system described above. If the target */
/* is non-spherical, the longitude distribution of */
/* the points generally is not uniform. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the terminator type is not recognized, the error */
/* SPICE(NOTSUPPORTED) is signaled. */
/* 2) If the set size NPTS is not at least 1, the error */
/* SPICE(INVALIDSIZE) is signaled. */
/* 3) If any of the ellipsoid's semi-axis lengths is non-positive, */
/* the error SPICE(INVALIDAXISLENGTH) is signaled. */
/* 4) If the light source has non-positive radius, the error */
/* SPICE(INVALIDRADIUS) is signaled. */
/* 5) If the light source intersects the smallest sphere */
/* centered at the origin and containing the ellipsoid, the */
/* error SPICE(OBJECTSTOOCLOSE) is signaled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine models the boundaries of shadow regions on an */
/* ellipsoid "illuminated" by a spherical light source. Light rays */
/* are assumed to travel along straight lines; refraction is not */
/* modeled. */
/* Points on the ellipsoid at which the entire cap of the light */
/* source is visible are considered to be completely illuminated. */
/* Points on the ellipsoid at which some portion (or all) of the cap */
/* of the light source are blocked are considered to be in partial */
/* (or total) shadow. */
/* In this routine, we use the term "umbral terminator" to denote */
/* the curve ususally called the "terminator": this curve is the */
/* boundary of the portion of the surface that lies in total shadow. */
/* We use the term "penumbral terminator" to denote the boundary of */
/* the completely illuminated portion of the surface. */
/* In general, the terminator on an ellipsoid is a more complicated */
/* curve than the limb (which is always an ellipse). Aside from */
/* various special cases, the terminator does not lie in a plane. */
/* However, the condition for a point X on the ellipsoid to lie on */
/* the terminator is simple: a plane tangent to the ellipsoid at X */
/* must also be tangent to the light source. If this tangent plane */
/* does not intersect the vector from the center of the ellipsoid to */
/* the center of the light source, then X lies on the umbral */
/* terminator; otherwise X lies on the penumbral terminator. */
/* $ Examples */
/* See the SPICELIB routine EDTERM. */
/* $ Restrictions */
/* This is a private SPICELIB routine. User applications should not */
/* call this routine. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 03-FEB-2007 (NJB) */
/* -& */
/* $ Index_Entries */
/* find terminator on ellipsoid */
/* find umbral terminator on ellipsoid */
/* find penumbral terminator on ellipsoid */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICELIB error handling. */
/* Parameter adjustments */
trmpts_dim2 = *npts;
/* Function Body */
if (return_()) {
return 0;
}
chkin_("ZZEDTERM", (ftnlen)8);
/* Check the terminator type. */
ljust_(type__, loctyp, type_len, (ftnlen)50);
ucase_(loctyp, loctyp, (ftnlen)50, (ftnlen)50);
if (s_cmp(loctyp, "UMBRAL", (ftnlen)50, (ftnlen)6) == 0) {
umbral = TRUE_;
} else if (s_cmp(loctyp, "PENUMBRAL", (ftnlen)50, (ftnlen)9) == 0) {
umbral = FALSE_;
} else {
setmsg_("Terminator type must be UMBRAL or PENUMBRAL but was actuall"
"y #.", (ftnlen)63);
errch_("#", type__, (ftnlen)1, type_len);
sigerr_("SPICE(NOTSUPPORTED)", (ftnlen)19);
chkout_("ZZEDTERM", (ftnlen)8);
return 0;
}
/* Check the terminator set dimension. */
if (*npts < 1) {
setmsg_("Set must contain at least one point; NPTS = #.", (ftnlen)47)
;
errint_("#", npts, (ftnlen)1);
sigerr_("SPICE(INVALIDSIZE)", (ftnlen)18);
chkout_("ZZEDTERM", (ftnlen)8);
return 0;
}
/* The ellipsoid semi-axes must have positive length. */
if (*a <= 0. || *b <= 0. || *c__ <= 0.) {
setmsg_("Semi-axis lengths: A = #, B = #, C = #. ", (ftnlen)41);
errdp_("#", a, (ftnlen)1);
errdp_("#", b, (ftnlen)1);
errdp_("#", c__, (ftnlen)1);
sigerr_("SPICE(INVALIDAXISLENGTH)", (ftnlen)24);
chkout_("ZZEDTERM", (ftnlen)8);
return 0;
}
/* Check the input light source radius. */
if (*srcrad <= 0.) {
setmsg_("Light source must have positive radius; actual radius was #."
, (ftnlen)60);
errdp_("#", srcrad, (ftnlen)1);
sigerr_("SPICE(INVALIDRADIUS)", (ftnlen)20);
chkout_("ZZEDTERM", (ftnlen)8);
return 0;
}
/* The light source must not intersect the outer bounding */
/* sphere of the ellipsoid. */
d__ = vnorm_(srcpos);
/* Computing MAX */
d__1 = max(*a,*b);
rmax = max(d__1,*c__);
/* Computing MIN */
d__1 = min(*a,*b);
rmin = min(d__1,*c__);
if (*srcrad + rmax >= d__) {
/* The light source is too close. */
setmsg_("Light source intersects outer bounding sphere of the ellips"
"oid. Light source radius = #; ellipsoid's longest axis = #;"
" sum = #; distance between centers = #.", (ftnlen)158);
errdp_("#", srcrad, (ftnlen)1);
errdp_("#", &rmax, (ftnlen)1);
d__1 = *srcrad + rmax;
errdp_("#", &d__1, (ftnlen)1);
errdp_("#", &d__, (ftnlen)1);
sigerr_("SPICE(OBJECTSTOOCLOSE)", (ftnlen)22);
chkout_("ZZEDTERM", (ftnlen)8);
return 0;
}
/* Find bounds on the angular size of the target as seen */
/* from the source. */
/* Computing MIN */
d__1 = rmax / d__;
minang = asin((min(d__1,1.)));
/* Computing MIN */
d__1 = rmin / d__;
maxang = asin((min(d__1,1.)));
/* Let the inverse of the ellipsoid-light source vector be the */
/* Z-axis of a frame we'll use to generate the terminator set. */
vminus_(srcpos, z__);
frame_(z__, x, y);
/* Create the rotation matrix required to convert vectors */
/* from the source-centered frame back to the target body-fixed */
/* frame. */
vequ_(x, trans);
vequ_(y, &trans[3]);
vequ_(z__, &trans[6]);
/* Find the maximum and minimum target radii. */
/* Computing MAX */
d__1 = max(*a,*b);
maxrad = max(d__1,*c__);
/* Computing MIN */
d__1 = min(*a,*b);
minrad = min(d__1,*c__);
if (umbral) {
/* Compute the angular offsets from the axis of rays tangent to */
/* both the source and the bounding spheres of the target, where */
/* the tangency points lie in a half-plane bounded by the line */
/* containing the origin and SRCPOS. (We'll call this line */
/* the "axis.") */
/* OUTANG corresponds to the target's outer bounding sphere; */
/* INANG to the inner bounding sphere. */
outang = asin((*srcrad - maxrad) / d__);
inang = asin((*srcrad - minrad) / d__);
} else {
/* Compute the angular offsets from the axis of rays tangent to */
/* both the source and the bounding spheres of the target, where */
/* the tangency points lie in opposite half-planes bounded by the */
/* axis (compare the case above). */
/* OUTANG corresponds to the target's outer bounding sphere; */
/* INANG to the inner bounding sphere. */
outang = asin((*srcrad + maxrad) / d__);
inang = asin((*srcrad + minrad) / d__);
}
/* Compute the angular delta we'll use for generating */
/* terminator points. */
delta = twopi_() / *npts;
/* Generate the terminator points. */
i__1 = *npts;
for (i__ = 1; i__ <= i__1; ++i__) {
theta = (i__ - 1) * delta;
/* Let SRCPT be the surface point on the source lying in */
/* the X-Y plane of the frame produced by FRAME */
/* and corresponding to the angle THETA. */
latrec_(srcrad, &theta, &c_b30, srcpt);
/* Now solve for the angle by which SRCPT must be rotated (toward */
/* +Z in the umbral case, away from +Z in the penumbral case) */
/* so that a plane tangent to the source at SRCPT is also tangent */
/* to the target. The rotation is bracketed by OUTANG on the low */
/* side and INANG on the high side in the umbral case; the */
/* bracketing values are reversed in the penumbral case. */
if (umbral) {
angle = outang;
} else {
angle = inang;
}
prvdif = twopi_();
prvang = angle + halfpi_();
nitr = 0;
for(;;) { /* while(complicated condition) */
d__2 = (d__1 = angle - prvang, abs(d__1));
if (!(nitr <= 10 && touchd_(&d__2) < prvdif))
break;
++nitr;
d__2 = (d__1 = angle - prvang, abs(d__1));
prvdif = touchd_(&d__2);
prvang = angle;
/* Find the closest point on the ellipsoid to the plane */
/* corresponding to "ANGLE". */
/* The tangent point on the source is obtained by rotating */
/* SRCPT by ANGLE towards +Z. The plane's normal vector is */
/* parallel to VTX in the source-centered frame. */
latrec_(srcrad, &theta, &angle, vtx);
vequ_(vtx, dir);
/* VTX and DIR are expressed in the source-centered frame. We */
/* must translate VTX to the target frame and rotate both */
/* vectors into that frame. */
mxv_(trans, vtx, vtemp);
vadd_(srcpos, vtemp, vtx);
mxv_(trans, dir, vtemp);
vequ_(vtemp, dir);
/* Create the plane defined by VTX and DIR. */
nvp2pl_(dir, vtx, plane);
/* Find the closest point on the ellipsoid to the plane. At */
/* the point we seek, the outward normal on the ellipsoid is */
/* parallel to the choice of plane normal that points away */
/* from the origin. We can always obtain this choice from */
/* PL2NVC. */
pl2nvc_(plane, dir, &plcons);
/* At the point */
/* E = (x, y, z) */
/* on the ellipsoid's surface, an outward normal */
/* is */
/* N = ( x/A**2, y/B**2, z/C**2 ) */
/* which is also */
/* lambda * ( DIR(1), DIR(2), DIR(3) ) */
/* Equating components in the normal vectors yields */
/* E = lambda * ( DIR(1)*A**2, DIR(2)*B**2, DIR(3)*C**2 ) */
/* Taking the inner product with the point E itself and */
/* applying the ellipsoid equation, we find */
/* lambda * <DIR, E> = < N, E > = 1 */
/* The first term above is */
/* lambda**2 * || ( A*DIR(1), B*DIR(2), C*DIR(3) ) ||**2 */
/* So the positive root lambda is */
/* 1 / || ( A*DIR(1), B*DIR(2), C*DIR(3) ) || */
/* Having lambda we can compute E. */
d__1 = *a * dir[0];
d__2 = *b * dir[1];
d__3 = *c__ * dir[2];
vpack_(&d__1, &d__2, &d__3, v);
lambda = 1. / vnorm_(v);
d__1 = *a * v[0];
d__2 = *b * v[1];
d__3 = *c__ * v[2];
vpack_(&d__1, &d__2, &d__3, e);
vscl_(&lambda, e, &trmpts[(i__2 = i__ * 3 - 3) < trmpts_dim2 * 3
&& 0 <= i__2 ? i__2 : s_rnge("trmpts", i__2, "zzedterm_",
(ftnlen)586)]);
/* Make a new estimate of the plane rotation required to touch */
/* the target. */
vsub_(&trmpts[(i__2 = i__ * 3 - 3) < trmpts_dim2 * 3 && 0 <= i__2
? i__2 : s_rnge("trmpts", i__2, "zzedterm_", (ftnlen)592)]
, vtx, offset);
/* Let ANGERR be an estimate of the magnitude of angular error */
/* between the plane and the terminator. */
angerr = vsep_(dir, offset) - halfpi_();
/* Let S indicate the sign of the altitude error: where */
/* S is positive, the plane is above E. */
d__1 = vdot_(e, dir);
s = d_sign(&c_b35, &d__1);
if (umbral) {
/* If the plane is above the target, increase the */
/* rotation angle; otherwise decrease the angle. */
angle += s * angerr;
} else {
/* This is the penumbral case; decreasing the angle */
/* "lowers" the plane toward the target. */
angle -= s * angerr;
}
}
}
chkout_("ZZEDTERM", (ftnlen)8);
return 0;
} /* zzedterm_ */
/* $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 ZZBODBLT ( Private --- Retrieve Built-In Body-Code Maps ) */
/* Subroutine */ int zzbodblt_0_(int n__, integer *room, char *names, char *
nornam, integer *codes, integer *nvals, char *device, char *reqst,
ftnlen names_len, ftnlen nornam_len, ftnlen device_len, ftnlen
reqst_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
address a__1[2], a__2[3];
integer i__1, i__2, i__3[2], i__4[3];
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen), movec_(char *, integer *, char *, ftnlen,
ftnlen), movei_(integer *, integer *, integer *);
extern logical eqstr_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
char zzint[36];
static integer bltcod[563];
static char bltnam[36*563];
extern /* Subroutine */ int orderc_(char *, integer *, integer *, ftnlen);
extern integer lastnb_(char *, ftnlen);
extern /* Subroutine */ int orderi_(integer *, integer *, integer *),
sigerr_(char *, ftnlen), chkout_(char *, ftnlen);
static char bltnor[36*563];
extern /* Subroutine */ int wrline_(char *, char *, ftnlen, ftnlen),
setmsg_(char *, ftnlen), errint_(char *, integer *, ftnlen),
cmprss_(char *, integer *, char *, char *, ftnlen, ftnlen, ftnlen)
;
integer zzocod[563];
char zzline[75];
integer zzonam[563];
extern logical return_(void);
extern /* Subroutine */ int intstr_(integer *, char *, ftnlen);
char zzrqst[4];
extern /* Subroutine */ int zzidmap_(integer *, 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. */
/* This is the umbrella routine that contains entry points to */
/* access the built-in body name-code mappings. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* BODY */
/* $ Declarations */
/* $ Abstract */
/* This include file lists the parameter collection */
/* defining the number of SPICE ID -> NAME mappings. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* naif_ids.req */
/* $ Keywords */
/* Body mappings. */
/* $ Author_and_Institution */
/* E.D. Wright (JPL) */
/* $ Version */
/* SPICELIB 1.0.0 Thu May 20 07:57:58 2010 (EDW) */
/* A script generates this file. Do not edit by hand. */
/* Edit the creation script to modify the contents of */
/* ZZBODTRN.INC. */
/* Maximum size of a NAME string */
/* Count of default SPICE mapping assignments. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ROOM I ZZBODGET */
/* NAMES O ZZBODGET */
/* NORNAM O ZZBODGET */
/* CODES O ZZBODGET */
/* NVALS O ZZBODGET */
/* DEVICE I ZZBODLST */
/* REQST I ZZBODLST */
/* $ Detailed_Input */
/* See the entry points for a discussion of their arguments. */
/* $ Detailed_Output */
/* See the entry points for a discussion of their arguments. */
/* $ Parameters */
/* See the include file 'zzbodtrn.inc' for the list of parameters */
/* this routine utilizes. */
/* $ Exceptions */
/* 1) The error SPICE(BOGUSENTRY) is signaled if ZZBODBLT is */
/* called directly. */
/* $ Files */
/* None. */
/* $ Particulars */
/* ZZBODBLT should never be called directly, instead access */
/* the entry points: */
/* ZZBODGET Fetch the built-in body name/code list. */
/* ZZBODLST Output the name-ID mapping list. */
/* $ Examples */
/* See ZZBODTRN and its entry points for details. */
/* $ Restrictions */
/* 1) No duplicate entries should appear in the built-in */
/* BLTNAM list. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 2.3.1, 27-FEB-2007 (EDW) */
/* Completed the ZZBODLST decalrations section. */
/* - SPICELIB Version 2.3.0, 17-MAR-2003 (EDW) */
/* Added a call to ZZIDMAP to retrieve the default */
/* mapping list. "zzbodtrn.inc" no longer */
/* contains the default mapping list. */
/* - SPICELIB Version 2.2.0 21-FEB-2003 (BVS) */
/* Changed MER-A and MER-B to MER-1 and MER-2. */
/* - SPICELIB Version 2.1.0 04-DEC-2002 (EDW) */
/* Added new assignments to the default collection: */
/* -226 ROSETTA */
/* 517 CALLIRRHOE */
/* 518 THEMISTO */
/* 519 MAGACLITE */
/* 520 TAYGETE */
/* 521 CHALDENE */
/* 522 HARPALYKE */
/* 523 KALYKE */
/* 524 IOCASTE */
/* 525 ERINOME */
/* 526 ISONOE */
/* 527 PRAXIDIKE */
/* - SPICELIB Version 2.0.0, 23-AUG-2002 (FST) */
/* Initial release. This begins at Version 2.0.0 because */
/* the entry point ZZBODLST was cut out of ZZBODTRN and */
/* placed here at Version 1.0.0. */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 23-AUG-2002 (FST) */
/* The entries following this one were copied from */
/* the version section of ZZBODTRN. SPICELIB has */
/* been changed to ZZBODTRN for convenience in noting */
/* version information relevant for that module. */
/* This was done to carry the history of body name-code */
/* additions with this new umbrella. */
/* Added to the collection: */
/* -236 MESSENGER */
/* - ZZBODTRN Version 3.2.0, 14-AUG-2002 (EDW) */
/* Added the ZZBODKIK entry point. */
/* Moved the NAIF_BODY_NAME/CODE to subroutine */
/* ZZBODKER. No change in logic. */
/* Added logic to enforce the precedence masking; */
/* logic removes duplicate assignments of ZZBODDEF. */
/* Removed the NAMENOTUNIQUE error block. */
/* - ZZBODTRN Version 3.1.5, 27-NOV-2001 (EDW) */
/* Added to the collection: */
/* -200 CONTOUR */
/* -146 LUNAR-A */
/* -135 DRTS-W */
/* Added the subroutine ZZBODLST as an entry point. */
/* The routine outputs the current name-ID mapping */
/* list to some output device. */
/* - ZZBODTRN Version 3.1.0, 17-OCT-2001 (EDW) */
/* To improve clarity, the BEGXX block initialization now */
/* exists in the include file zzbodtrn.inc. */
/* Removed the comments concerning the 851, 852, ... temporary */
/* codes. */
/* Set the WNAMES assignment to NAIF_BODY_CODE, NAIF_BODY_NAME */
/* as a DATA statement. */
/* Edited headers to match information in naif_ids required */
/* reading. */
/* Edited headers, removed typos and bad grammar, clarified */
/* descriptions. */
/* Added to the collection */
/* -41 MARS EXPRESS, MEX */
/* -44 BEAGLE 2, BEAGLE2 */
/* -70 DEEP IMPACT IMPACTOR SPACECRAFT */
/* -94 MO, MARS OBSERVER */
/* -140 DEEP IMPACT FLYBY SPACECRAFT */
/* -172 SLCOMB, STARLIGHT COMBINER */
/* -205 SLCOLL, STARLIGHT COLLECTOR */
/* -253 MER-A */
/* -254 MER-B */
/* Corrected typo, vehicle -188 should properly be MUSES-C, */
/* previous versions listed the name as MUSES-B. */
/* Removed from collection */
/* -84 MARS SURVEYOR 01 LANDER */
/* -154 EOS-PM1 */
/* -200 PLUTO EXPRESS 1, PEX1 */
/* -202 PLUTO EXPRESS 2, PEX2 */
/* - ZZBODTRN Version 3.0.0, 29-MAR-2000 (WLT) */
/* The ID codes for Cluster 1, 2, 3 and 4 were added. The */
/* ID coded for Pluto Express were removed. The ID codes */
/* for Pluto-Kuiper Express, Pluto-Kuiper Express Simulation */
/* and Contour were added. */
/* - ZZBODTRN Version 2.0.0, 26-JAN-1998 (EDW) */
/* The Galileo probe ID -228 replaces the incorrect ID -344. */
/* DSS stations 5 through 65 added to the collection. */
/* Added to the collection */
/* -107 TROPICAL RAINFALL MEASURING MISSION, TRMM */
/* -154, EOS-PM1 */
/* -142 EOS-AM1 */
/* -151 AXAF */
/* -1 GEOTAIL */
/* -13 POLAR */
/* -21 SOHO */
/* -8 WIND */
/* -25 LUNAR PROSPECTOR, LPM */
/* -116 MARS POLAR LANDER, MPL */
/* -127 MARS CLIMATE ORBITER, MCO */
/* -188 MUSES-C */
/* -97 TOPEX/POSEIDON */
/* -6 PIONEER-6, P6 */
/* -7 PIONEER-7, P7 */
/* -20 PIONEER-8, P8 */
/* -23 PIONEER-10, P10 */
/* -24 PIONEER-11, P11 */
/* -178 NOZOMI, PLANET-B */
/* -79 SPACE INFRARED TELESCOPE FACILITY, SIRTF */
/* -29 STARDUST, SDU */
/* -47 GENESIS */
/* -48 HUBBLE SPACE TELESCOPE, HST */
/* -200 PLUTO EXPRESS 1, PEX1 */
/* -202 PLUTO EXPRESS 2, PEX2 */
/* -164 YOHKOH, SOLAR-A */
/* -165 MAP */
/* -166 IMAGE */
/* -53 MARS SURVEYOR 01 ORBITER */
/* 618 PAN */
/* 716 CALIBAN */
/* 717 SYCORAX */
/* -30 DS-1 (low priority) */
/* -58 HALCA */
/* -150 HUYGEN PROBE, CASP */
/* -55 ULS */
/* Modified ZZBODC2N and ZZBODN2C so the user may load an */
/* external IDs kernel to override or supplement the standard */
/* collection. The kernel must be loaded prior a call to */
/* ZZBODC2N or ZZBODN2C. */
/* - ZZBODTRN Version 1.1.0, 22-MAY-1996 (WLT) */
/* Added the id-code for Comet Hyakutake, Comet Hale-Bopp, */
/* Mars 96, Cassini Simulation, MGS Simulation. */
/* - ZZBODTRN Version 1.0.0, 25-SEP-1995 (BVS) */
/* Renamed umbrella subroutine and entry points to */
/* correspond private routine convention (ZZ...). Added IDs for */
/* tracking stations Goldstone (399001), Canberra (399002), */
/* Madrid (399003), Usuda (399004). */
/* - ZZBODTRN Version 2.2.0, 01-AUG-1995 (HAN) */
/* Added the IDs for Near Earth Asteroid Rendezvous (-93), */
/* Mars Pathfinder (-53), Ulysses (-55), VSOP (-58), */
/* Radioastron (-59), Cassini spacecraft (-82), and Cassini */
/* Huygens probe (-150). */
/* Mars Observer (-94) was replaced with Mars Global */
/* Surveyor (-94). */
/* - ZZBODTRN Version 2.1.0, 15-MAR-1995 (KSZ) (HAN) */
/* Two Shoemaker Levy 9 fragments were added, Q1 and P2 */
/* (IDs 50000022 and 50000023). Two asteroids were added, */
/* Eros and Mathilde (IDs 2000433 and 2000253). The */
/* Saturnian satellite Pan (ID 618) was added. */
/* - ZZBODTRN Version 2.0.0, 03-FEB-1995 (NJB) */
/* The Galileo probe (ID -344) has been added to the permanent */
/* collection. */
/* - ZZBODTRN Version 1.0.0, 29-APR-1994 (MJS) */
/* SPICELIB symbol tables are no longer used. Instead, two order */
/* vectors are used to index the NAMES and CODES arrays. Also, */
/* this version does not support reading body name ID pairs from a */
/* file. */
/* - ZZBODTRN Version 2.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - ZZBODTRN Version 2.0.0, 15-JUL-1991 (WLT) */
/* The body id's for the Uranian satellites discovered by Voyager */
/* were modified to conform to those established by the IAU */
/* nomenclature committee. In addition the id's for Gaspra and */
/* Ida were added. */
/* - ZZBODTRN Version 1.0.0, 7-MAR-1991 (WLT) */
/* Some items previously considered errors were removed */
/* and some minor modifications were made to improve the */
/* robustness of the routines. */
/* - ZZBODTRN Version 1.0.0, 28-JUN-1990 (JEM) */
/* -& */
/* SPICELIB Functions */
/* Local Parameters */
/* Local Variables */
/* Saved Variables */
/* Data Statements */
/* Parameter adjustments */
if (names) {
}
if (nornam) {
}
if (codes) {
}
/* Function Body */
switch(n__) {
case 1: goto L_zzbodget;
case 2: goto L_zzbodlst;
}
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZBODBLT", (ftnlen)8);
sigerr_("SPICE(BOGUSENTRY)", (ftnlen)17);
chkout_("ZZBODBLT", (ftnlen)8);
}
return 0;
/* $Procedure ZZBODGET ( Private --- Body-Code Get Built-In List ) */
L_zzbodget:
/* $ 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. */
/* Retrieve a copy of the built-in body name-code mapping lists. */
/* $ 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 */
/* BODY */
/* $ Declarations */
/* INTEGER ROOM */
/* CHARACTER*(*) NAMES ( * ) */
/* CHARACTER*(*) NORNAM ( * ) */
/* INTEGER CODES ( * ) */
/* INTEGER NVALS */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ROOM I Space available in NAMES, NORNAM, and CODES. */
/* NAMES O Array of built-in body names. */
/* NORNAM O Array of normalized built-in body names. */
/* CODES O Array of built-in ID codes for NAMES/NORNAM. */
/* NVALS O Length of NAMES, NORNAM, CODES, and ORDNOM arrays. */
/* $ Detailed_Input */
/* ROOM is the maximum number of entries that NAMES, NORNAM, */
/* and CODES may receive. */
/* $ Detailed_Output */
/* NAMES the array of built-in names. This array is parallel */
/* to NORNAM and CODES. */
/* NORNAM the array of normalized built-in body names. This */
/* array is computed from the NAMES array by compressing */
/* groups of spaces into a single space, left-justifying */
/* the name, and uppercasing the letters. */
/* CODES the array of built-in codes associated with NAMES */
/* and NORNAM entries. */
/* NVALS the number of items returned in NAMES, NORNAM, */
/* and CODES. */
/* $ Parameters */
/* NPERM the number of permanent, or built-in, body name-code */
/* mappings. */
/* $ Exceptions */
/* 1) SPICE(BUG) is signaled if ROOM is less than NPERM, the */
/* amount of space required to store the entire list of */
/* body names and codes. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine simply copies it's local buffered version of the */
/* built-in name-code mappings to the output arguments. */
/* $ Examples */
/* See ZZBODTRN for sample usage. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* $ Version */
/* - SPICELIB Version 2.1.0, 17-MAR-2003 (EDW) */
/* Added a call to ZZIDMAP to retrieve the default */
/* mapping list. "zzbodtrn.inc" no longer */
/* contains the default mapping list. */
/* - SPICELIB Version 2.0.0, 23-AUG-2002 (FST) */
/* -& */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZBODGET", (ftnlen)8);
}
/* On the first invocation compute the normalized forms of BLTNAM */
/* and store them in BLTNOR. */
if (first) {
/* Retrieve the default mapping list. */
zzidmap_(bltcod, bltnam, (ftnlen)36);
for (i__ = 1; i__ <= 563; ++i__) {
ljust_(bltnam + ((i__1 = i__ - 1) < 563 && 0 <= i__1 ? i__1 :
s_rnge("bltnam", i__1, "zzbodblt_", (ftnlen)565)) * 36,
bltnor + ((i__2 = i__ - 1) < 563 && 0 <= i__2 ? i__2 :
s_rnge("bltnor", i__2, "zzbodblt_", (ftnlen)565)) * 36, (
ftnlen)36, (ftnlen)36);
ucase_(bltnor + ((i__1 = i__ - 1) < 563 && 0 <= i__1 ? i__1 :
s_rnge("bltnor", i__1, "zzbodblt_", (ftnlen)566)) * 36,
bltnor + ((i__2 = i__ - 1) < 563 && 0 <= i__2 ? i__2 :
s_rnge("bltnor", i__2, "zzbodblt_", (ftnlen)566)) * 36, (
ftnlen)36, (ftnlen)36);
cmprss_(" ", &c__1, bltnor + ((i__1 = i__ - 1) < 563 && 0 <= i__1
? i__1 : s_rnge("bltnor", i__1, "zzbodblt_", (ftnlen)567))
* 36, bltnor + ((i__2 = i__ - 1) < 563 && 0 <= i__2 ?
i__2 : s_rnge("bltnor", i__2, "zzbodblt_", (ftnlen)567)) *
36, (ftnlen)1, (ftnlen)36, (ftnlen)36);
}
/* Do not do this again. */
first = FALSE_;
}
/* Copy the contents of BLTNAM, BLTNOR, and BLTCOD to the output */
/* arguments, but only if there is sufficient room. */
if (*room < 563) {
setmsg_("Insufficient room to copy the stored body name-code mapping"
"s to the output arguments. Space required is #, but the cal"
"ler supplied #.", (ftnlen)134);
errint_("#", &c__563, (ftnlen)1);
errint_("#", room, (ftnlen)1);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZBODGET", (ftnlen)8);
return 0;
}
movec_(bltnam, &c__563, names, (ftnlen)36, names_len);
movec_(bltnor, &c__563, nornam, (ftnlen)36, nornam_len);
movei_(bltcod, &c__563, codes);
*nvals = 563;
chkout_("ZZBODGET", (ftnlen)8);
return 0;
/* $Procedure ZZBODLST ( Output permanent collection to some device. ) */
L_zzbodlst:
/* $ Abstract */
/* Output the complete list of built-in body/ID mappings to */
/* some output devide. Thw routine generates 2 lists: one */
/* sorted by ID number, one sorted by name. */
/* $ 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 */
/* BODY */
/* $ Declarations */
/* CHARACTER*(*) DEVICE */
/* CHARACTER*(*) REQST */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* DEVICE I Device name to receive the output. */
/* REQST I Data list name to output. */
/* $ Detailed_Input */
/* DEVICE identifies the device to receive the */
/* body/ID mapping list. WRLINE performs the */
/* output function and so DEVICE may have */
/* the values 'SCREEN' (to generate a screen dump), */
/* 'NULL' (do nothing), or a device name (a */
/* file, or any other name valid in a FORTRAN OPEN */
/* statement). */
/* REQST A case insensitive string indicating the data */
/* set to output. REQST may have the value 'ID', */
/* 'NAME', or 'BOTH'. 'ID' outputs the name/ID mapping */
/* ordered by ID number from least to highest value. */
/* 'NAME' outputs the name/ID mapping ordered by ASCII */
/* sort on the name string. 'BOTH' outputs both */
/* ordered lists. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The entry point outputs ordered lists of the name/ID mappings */
/* defined in ZZBODTRN. */
/* $ Examples */
/* 1. Write both sorted lists to screen. */
/* PROGRAM X */
/* CALL ZZBODLST( 'SCREEN', 'BOTH' ) */
/* END */
/* 2. Write an ID number sorted list to a file, "body.txt". */
/* PROGRAM X */
/* CALL ZZBODLST( 'body.txt', 'ID' ) */
/* END */
/* With SCREEN output of the form: */
/* Total number of name/ID mappings: 414 */
/* ID to name mappings. */
/* -550 | M96 */
/* -550 | MARS 96 */
/* -550 | MARS-96 */
/* -550 | MARS96 */
/* -254 | MER-2 */
/* -253 | MER-1 */
/* .. .. */
/* 50000020 | SHOEMAKER-LEVY 9-B */
/* 50000021 | SHOEMAKER-LEVY 9-A */
/* 50000022 | SHOEMAKER-LEVY 9-Q1 */
/* 50000023 | SHOEMAKER-LEVY 9-P2 */
/* Name to ID mappings. */
/* 1978P1 | 901 */
/* 1979J1 | 515 */
/* .. .. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* E.D. Wright (JPL) */
/* $ Version */
/* - SPICELIB Version 2.1.1, 27-FEB-2007 (EDW) */
/* Completed the ZZBODLST declarations section. */
/* - SPICELIB Version 2.1.0, 17-MAR-2003 (EDW) */
/* Added a call to ZZIDMAP to retrieve the default */
/* mapping list. "zzbodtrn.inc" no longer */
/* contains the default mapping list. */
/* - SPICELIB Version 2.0.0, 23-AUG-2002 (FST) */
/* This entry point was moved into ZZBODBLT and some */
/* variable names were changed to refer to variables */
/* in the umbrella. */
/* - SPICELIB Version 1.0.0, 26-NOV-2001 (EDW) */
/* -& */
if (return_()) {
return 0;
} else {
chkin_("ZZBODLST", (ftnlen)8);
}
/* Upper case the ZZRQST value. */
ucase_(reqst, zzrqst, reqst_len, (ftnlen)4);
intstr_(&c__563, zzint, (ftnlen)36);
/* Writing concatenation */
i__3[0] = 34, a__1[0] = "Total number of name/ID mappings: ";
i__3[1] = 36, a__1[1] = zzint;
s_cat(zzline, a__1, i__3, &c__2, (ftnlen)75);
wrline_(device, zzline, device_len, lastnb_(zzline, (ftnlen)75));
/* Retrieve the current set of name/ID mappings */
zzidmap_(bltcod, bltnam, (ftnlen)36);
/* Branch as defined by the value of ZZRQST. 'ID' or 'BOTH'. */
if (eqstr_(zzrqst, "ID", (ftnlen)4, (ftnlen)2) || eqstr_(zzrqst, "BOTH", (
ftnlen)4, (ftnlen)4)) {
orderi_(bltcod, &c__563, zzocod);
wrline_(device, " ", device_len, (ftnlen)1);
wrline_(device, "ID to name mappings.", device_len, (ftnlen)20);
for (i__ = 1; i__ <= 563; ++i__) {
intstr_(&bltcod[(i__2 = zzocod[(i__1 = i__ - 1) < 563 && 0 <=
i__1 ? i__1 : s_rnge("zzocod", i__1, "zzbodblt_", (ftnlen)
812)] - 1) < 563 && 0 <= i__2 ? i__2 : s_rnge("bltcod",
i__2, "zzbodblt_", (ftnlen)812)], zzint, (ftnlen)36);
/* Writing concatenation */
i__4[0] = 36, a__2[0] = zzint;
i__4[1] = 3, a__2[1] = " | ";
i__4[2] = 36, a__2[2] = bltnam + ((i__2 = zzocod[(i__1 = i__ - 1)
< 563 && 0 <= i__1 ? i__1 : s_rnge("zzocod", i__1, "zzbo"
"dblt_", (ftnlen)814)] - 1) < 563 && 0 <= i__2 ? i__2 :
s_rnge("bltnam", i__2, "zzbodblt_", (ftnlen)814)) * 36;
s_cat(zzline, a__2, i__4, &c__3, (ftnlen)75);
wrline_(device, zzline, device_len, lastnb_(zzline, (ftnlen)75));
}
}
/* ... 'NAME' or 'BOTH'. */
if (eqstr_(zzrqst, "NAME", (ftnlen)4, (ftnlen)4) || eqstr_(zzrqst, "BOTH",
(ftnlen)4, (ftnlen)4)) {
orderc_(bltnam, &c__563, zzonam, (ftnlen)36);
wrline_(device, " ", device_len, (ftnlen)1);
wrline_(device, "Name to ID mappings.", device_len, (ftnlen)20);
for (i__ = 1; i__ <= 563; ++i__) {
intstr_(&bltcod[(i__2 = zzonam[(i__1 = i__ - 1) < 563 && 0 <=
i__1 ? i__1 : s_rnge("zzonam", i__1, "zzbodblt_", (ftnlen)
834)] - 1) < 563 && 0 <= i__2 ? i__2 : s_rnge("bltcod",
i__2, "zzbodblt_", (ftnlen)834)], zzint, (ftnlen)36);
/* Writing concatenation */
i__4[0] = 36, a__2[0] = bltnam + ((i__2 = zzonam[(i__1 = i__ - 1)
< 563 && 0 <= i__1 ? i__1 : s_rnge("zzonam", i__1, "zzbo"
"dblt_", (ftnlen)836)] - 1) < 563 && 0 <= i__2 ? i__2 :
s_rnge("bltnam", i__2, "zzbodblt_", (ftnlen)836)) * 36;
i__4[1] = 3, a__2[1] = " | ";
i__4[2] = 36, a__2[2] = zzint;
s_cat(zzline, a__2, i__4, &c__3, (ftnlen)75);
wrline_(device, zzline, device_len, lastnb_(zzline, (ftnlen)75));
}
}
chkout_("ZZBODLST", (ftnlen)8);
return 0;
} /* zzbodblt_ */
/* $Procedure REPMF ( Replace marker with formatted d.p. value ) */
/* Subroutine */ int repmf_(char *in, char *marker, doublereal *value,
integer *sigdig, char *format, char *out, ftnlen in_len, ftnlen
marker_len, ftnlen format_len, ftnlen out_len)
{
/* 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 i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int zzrepsub_(char *, integer *, integer *, char *
, char *, ftnlen, ftnlen, ftnlen), ucase_(char *, char *, ftnlen,
ftnlen);
char gdfmt[1];
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
extern integer lastnb_(char *, ftnlen), frstnb_(char *, ftnlen);
extern /* Subroutine */ int dpstrf_(doublereal *, integer *, char *, char
*, ftnlen, ftnlen);
integer mrkpos;
char substr[56];
/* $ Abstract */
/* Replace a marker in a string with a formatted double precision */
/* value. */
/* $ 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 */
/* CHARACTER */
/* CONVERSION */
/* STRING */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* IN I Input string. */
/* MARKER I Marker to be replaced. */
/* VALUE I Replacement value. */
/* SIGDIG I Significant digits in replacement text. */
/* FORMAT I Format: 'E' or 'F'. */
/* OUT O Output string. */
/* MAXLFD P Maximum length of a formatted DP number. */
/* $ Detailed_Input */
/* IN is an arbitrary character string. */
/* MARKER is an arbitrary character string. The first */
/* occurrence of MARKER in the input string is */
/* to be replaced by VALUE. */
/* Leading and trailing blanks in MARKER are NOT */
/* significant. In particular, no substitution is */
/* performed if MARKER is blank. */
/* VALUE is an arbitrary double precision number. */
/* SIGDIG is the number of significant digits with */
/* which VALUE is to be represented. SIGDIG */
/* must be greater than zero and less than 15. */
/* FORMAT is the format in which VALUE is to be represented. */
/* FORMAT may be any of the following: */
/* FORMAT Meaning Example */
/* ------ ----------- ---------------- */
/* E, e Scientific 3.14159E+03 */
/* (exponent) */
/* notation */
/* F, f Fixed-point 3141.59 */
/* notation */
/* $ Detailed_Output */
/* OUT is the string obtained by substituting the text */
/* representation of VALUE for the first occurrence */
/* of MARKER in the input string. */
/* The text representation of VALUE is in scientific */
/* (exponent) or fixed-point notation, depending on */
/* having the value of FORMAT, and having the number */
/* of significant digits specified by SIGDIG. */
/* The representation of VALUE is produced by the */
/* routine DPSTRF; see that routine for details */
/* concerning the representation of double precision */
/* numbers. */
/* OUT and IN must be identical or disjoint. */
/* $ Parameters */
/* MAXLFD is the maximum expected length of the text */
/* representation of a formatted double precision */
/* number. 56 characters are sufficient to hold any */
/* result returned by DPSTRF. (See $Restrictions.) */
/* $ Files */
/* None. */
/* $ Exceptions */
/* Error Free. */
/* 1) If OUT does not have sufficient length to accommodate the */
/* result of the substitution, the result will be truncated on */
/* the right. */
/* 2) If MARKER is blank, or if MARKER is not a substring of IN, */
/* no substitution is performed. (OUT and IN are identical.) */
/* $ Particulars */
/* This is one of a family of related routines for inserting values */
/* into strings. They are typically to construct messages that */
/* are partly fixed, and partly determined at run time. For example, */
/* a message like */
/* 'Fifty-one pictures were found in directory [USER.DATA].' */
/* might be constructed from the fixed string */
/* '#1 pictures were found in directory #2.' */
/* by the calls */
/* CALL REPMCT ( STRING, '#1', N_PICS, 'C', STRING ) */
/* CALL REPMC ( STRING, '#2', DIR_NAME, STRING ) */
/* which substitute the cardinal text 'Fifty-one' and the character */
/* string '[USER.DATA]' for the markers '#1' and '#2' respectively. */
/* The complete list of routines is shown below. */
/* REPMC ( Replace marker with character string value ) */
/* REPMD ( Replace marker with double precision value ) */
/* REPMF ( Replace marker with formatted d.p. value ) */
/* REPMI ( Replace marker with integer value ) */
/* REPMCT ( Replace marker with cardinal text) */
/* REPMOT ( Replace marker with ordinal text ) */
/* $ Examples */
/* 1. Let */
/* IN = 'Invalid operation value. The value was #.' */
/* Then following the call, */
/* CALL REPMF ( IN, '#', 5.0D1, 2, 'E', IN ) */
/* IN is */
/* 'Invalid operation value. The value was 5.0E+01.' */
/* 2. Let */
/* IN = 'Left endpoint exceeded right endpoint. The left */
/* endpoint was: XX. The right endpoint was: XX.' */
/* Then following the call, */
/* CALL REPMF ( IN, ' XX ', -5.2D-9, 3, 'E', OUT ) */
/* OUT is */
/* 'Left endpoint exceeded right endpoint. The left */
/* endpoint was: -5.20E-09. The right endpoint was: XX.' */
/* 3. Let */
/* IN = 'Invalid operation value. The value was # units.' */
/* Then following the call, */
/* CALL REPMF ( IN, '#', 5.0D1, 3, 'F', IN ) */
/* IN is */
/* 'Invalid operation value. The value was 50.0 units..' */
/* 4. In the above example, if SIGDIG is 1 instead of 3, IN becomes */
/* 'Invalid operation value. The value was 50 units.' */
/* 5. Let */
/* IN = 'Invalid operation value. The value was #.' */
/* Then following the call, */
/* CALL REPMF ( IN, '#', 5.0D1, 100, 'E', IN ) */
/* IN is */
/* 'Invalid operation value. The value was */
/* 5.0000000000000E+01.' */
/* Note that even though 100 digits of precision were requested, */
/* only 14 were returned. */
/* 6. Let */
/* MARKER = '&' */
/* NUM = 23 */
/* CHANCE = 'fair' */
/* SCORE = 4.665D0 */
/* Then following the sequence of calls, */
/* CALL REPMI ( 'There are & routines that have a ' // */
/* . '& chance of meeting your needs.' // */
/* . 'The maximum score was &.', */
/* . '&', */
/* . NUM, */
/* . MSG ) */
/* CALL REPMC ( MSG, '&', CHANCE, MSG ) */
/* CALL REPMF ( MSG, '&', SCORE, 4, 'F', MSG ) */
/* MSG is */
/* 'There are 23 routines that have a fair chance of */
/* meeting your needs. The maximum score was 4.665.' */
/* $ Restrictions */
/* 1) The maximum number of significant digits returned is 14. */
/* 2) This routine makes explicit use of the format of the string */
/* returned by DPSTRF; should that routine change, substantial */
/* work may be required to bring this routine back up to snuff. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.0, 15-AUG-2002 (WLT) */
/* The routine is now error free. */
/* - 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, 30-AUG-1990 (NJB) (IMU) */
/* -& */
/* $ Index_Entries */
/* replace marker with formatted d.p. value */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* If MARKER is blank, no substitution is possible. */
if (s_cmp(marker, " ", marker_len, (ftnlen)1) == 0) {
s_copy(out, in, out_len, in_len);
return 0;
}
/* Locate the leftmost occurrence of MARKER, if there is one */
/* (ignoring leading and trailing blanks). If MARKER is not */
/* a substring of IN, no substitution can be performed. */
i__1 = frstnb_(marker, marker_len) - 1;
mrkpos = i_indx(in, marker + i__1, in_len, lastnb_(marker, marker_len) -
i__1);
if (mrkpos == 0) {
s_copy(out, in, out_len, in_len);
return 0;
}
/* Okay, MARKER is non-blank and has been found. Convert the */
/* number to text, and substitute the text for the marker. */
ljust_(format, gdfmt, format_len, (ftnlen)1);
ucase_(gdfmt, gdfmt, (ftnlen)1, (ftnlen)1);
dpstrf_(value, sigdig, gdfmt, substr, (ftnlen)1, (ftnlen)56);
if (lastnb_(substr, (ftnlen)56) != 0) {
i__1 = frstnb_(substr, (ftnlen)56) - 1;
i__2 = mrkpos + lastnb_(marker, marker_len) - frstnb_(marker,
marker_len);
zzrepsub_(in, &mrkpos, &i__2, substr + i__1, out, in_len, lastnb_(
substr, (ftnlen)56) - i__1, out_len);
}
return 0;
} /* repmf_ */
/* $Procedure DRDPGR ( Derivative of rectangular w.r.t. planetographic ) */
/* Subroutine */ int drdpgr_(char *body, doublereal *lon, doublereal *lat,
doublereal *alt, doublereal *re, doublereal *f, doublereal *jacobi,
ftnlen body_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), s_rnge(char *, integer,
char *, integer);
/* Local variables */
integer i__, n;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen), errch_(char *, char *, ftnlen, ftnlen);
logical found;
extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen);
integer sense;
extern /* Subroutine */ int repmi_(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen), bods2c_(char *, integer *, logical *,
ftnlen), drdgeo_(doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
integer bodyid;
doublereal geolon;
extern /* Subroutine */ int gcpool_(char *, integer *, integer *, integer
*, char *, logical *, ftnlen, ftnlen);
char kvalue[80];
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen);
char pmkvar[32], pgrlon[4];
extern /* Subroutine */ int setmsg_(char *, ftnlen), cmprss_(char *,
integer *, char *, char *, ftnlen, ftnlen, ftnlen);
extern integer plnsns_(integer *);
extern logical return_(void);
char tmpstr[32];
/* $ Abstract */
/* This routine computes the Jacobian matrix of the transformation */
/* from planetographic to rectangular coordinates. */
/* $ 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 */
/* COORDINATES */
/* DERIVATIVES */
/* MATRIX */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* BODY I Name of body with which coordinates are associated. */
/* LON I Planetographic longitude of a point (radians). */
/* LAT I Planetographic latitude of a point (radians). */
/* ALT I Altitude of a point above reference spheroid. */
/* RE I Equatorial radius of the reference spheroid. */
/* F I Flattening coefficient. */
/* JACOBI O Matrix of partial derivatives. */
/* $ Detailed_Input */
/* BODY Name of the body with which the planetographic */
/* coordinate system is associated. */
/* BODY is used by this routine to look up from the */
/* kernel pool the prime meridian rate coefficient giving */
/* the body's spin sense. See the Files and Particulars */
/* header sections below for details. */
/* LON Planetographic longitude of the input point. This is */
/* the angle between the prime meridian and the meridian */
/* containing the input point. For bodies having */
/* prograde (aka direct) rotation, the direction of */
/* increasing longitude is positive west: from the +X */
/* axis of the rectangular coordinate system toward the */
/* -Y axis. For bodies having retrograde rotation, the */
/* direction of increasing longitude is positive east: */
/* from the +X axis toward the +Y axis. */
/* The earth, moon, and sun are exceptions: */
/* planetographic longitude is measured positive east for */
/* these bodies. */
/* The default interpretation of longitude by this */
/* and the other planetographic coordinate conversion */
/* routines can be overridden; see the discussion in */
/* Particulars below for details. */
/* Longitude is measured in radians. On input, the range */
/* of longitude is unrestricted. */
/* LAT Planetographic latitude of the input point. For a */
/* point P on the reference spheroid, this is the angle */
/* between the XY plane and the outward normal vector at */
/* P. For a point P not on the reference spheroid, the */
/* planetographic latitude is that of the closest point */
/* to P on the spheroid. */
/* Latitude is measured in radians. On input, the */
/* range of latitude is unrestricted. */
/* ALT Altitude of point above the reference spheroid. */
/* Units of ALT must match those of RE. */
/* RE Equatorial radius of a reference spheroid. This */
/* spheroid is a volume of revolution: its horizontal */
/* cross sections are circular. The shape of the */
/* spheroid is defined by an equatorial radius RE and */
/* a polar radius RP. Units of RE must match those of */
/* ALT. */
/* F Flattening coefficient = */
/* (RE-RP) / RE */
/* where RP is the polar radius of the spheroid, and the */
/* units of RP match those of RE. */
/* $ Detailed_Output */
/* JACOBI is the matrix of partial derivatives of the conversion */
/* from planetographic to rectangular coordinates. It */
/* has the form */
/* .- -. */
/* | DX/DLON DX/DLAT DX/DALT | */
/* | DY/DLON DY/DLAT DY/DALT | */
/* | DZ/DLON DZ/DLAT DZ/DALT | */
/* `- -' */
/* evaluated at the input values of LON, LAT and ALT. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the body name BODY cannot be mapped to a NAIF ID code, */
/* and if BODY is not a string representation of an integer, */
/* the error SPICE(IDCODENOTFOUND) will be signaled. */
/* 2) If the kernel variable */
/* BODY<ID code>_PGR_POSITIVE_LON */
/* is present in the kernel pool but has a value other */
/* than one of */
/* 'EAST' */
/* 'WEST' */
/* the error SPICE(INVALIDOPTION) will be signaled. Case */
/* and blanks are ignored when these values are interpreted. */
/* 3) If polynomial coefficients for the prime meridian of BODY */
/* are not available in the kernel pool, and if the kernel */
/* variable BODY<ID code>_PGR_POSITIVE_LON is not present in */
/* the kernel pool, the error SPICE(MISSINGDATA) will be signaled. */
/* 4) If the equatorial radius is non-positive, the error */
/* SPICE(VALUEOUTOFRANGE) is signaled. */
/* 5) If the flattening coefficient is greater than or equal to one, */
/* the error SPICE(VALUEOUTOFRANGE) is signaled. */
/* $ Files */
/* This routine expects a kernel variable giving BODY's prime */
/* meridian angle as a function of time to be available in the */
/* kernel pool. Normally this item is provided by loading a PCK */
/* file. The required kernel variable is named */
/* BODY<body ID>_PM */
/* where <body ID> represents a string containing the NAIF integer */
/* ID code for BODY. For example, if BODY is 'JUPITER', then */
/* the name of the kernel variable containing the prime meridian */
/* angle coefficients is */
/* BODY599_PM */
/* See the PCK Required Reading for details concerning the prime */
/* meridian kernel variable. */
/* The optional kernel variable */
/* BODY<body ID>_PGR_POSITIVE_LON */
/* also is normally defined via loading a text kernel. When this */
/* variable is present in the kernel pool, the prime meridian */
/* coefficients for BODY are not required by this routine. See the */
/* Particulars section below for details. */
/* $ Particulars */
/* It is often convenient to describe the motion of an object in the */
/* planetographic coordinate system. However, when performing */
/* vector computations it's hard to beat rectangular coordinates. */
/* To transform states given with respect to planetographic */
/* coordinates to states with respect to rectangular coordinates, */
/* one makes use of the Jacobian of the transformation between the */
/* two systems. */
/* Given a state in planetographic coordinates */
/* ( lon, lat, alt, dlon, dlat, dalt ) */
/* the velocity in rectangular coordinates is given by the matrix */
/* equation: */
/* t | t */
/* (dx, dy, dz) = JACOBI| * (dlon, dlat, dalt) */
/* |(lon,lat,alt) */
/* This routine computes the matrix */
/* | */
/* JACOBI| */
/* |(lon,lat,alt) */
/* In the planetographic coordinate system, longitude is defined */
/* using the spin sense of the body. Longitude is positive to the */
/* west if the spin is prograde and positive to the east if the spin */
/* is retrograde. The spin sense is given by the sign of the first */
/* degree term of the time-dependent polynomial for the body's prime */
/* meridian Euler angle "W": the spin is retrograde if this term is */
/* negative and prograde otherwise. For the sun, planets, most */
/* natural satellites, and selected asteroids, the polynomial */
/* expression for W may be found in a SPICE PCK kernel. */
/* The earth, moon, and sun are exceptions: planetographic longitude */
/* is measured positive east for these bodies. */
/* If you wish to override the default sense of positive longitude */
/* for a particular body, you can do so by defining the kernel */
/* variable */
/* BODY<body ID>_PGR_POSITIVE_LON */
/* where <body ID> represents the NAIF ID code of the body. This */
/* variable may be assigned either of the values */
/* 'WEST' */
/* 'EAST' */
/* For example, you can have this routine treat the longitude */
/* of the earth as increasing to the west using the kernel */
/* variable assignment */
/* BODY399_PGR_POSITIVE_LON = 'WEST' */
/* Normally such assignments are made by placing them in a text */
/* kernel and loading that kernel via FURNSH. */
/* The definition of this kernel variable controls the behavior of */
/* the SPICELIB planetographic routines */
/* PGRREC */
/* RECPGR */
/* DPGRDR */
/* DRDPGR */
/* It does not affect the other SPICELIB coordinate conversion */
/* routines. */
/* $ Examples */
/* Numerical results shown for this example may differ between */
/* platforms as the results depend on the SPICE kernels used as */
/* input and the machine specific arithmetic implementation. */
/* Find the planetographic state of the earth as seen from */
/* Mars in the J2000 reference frame at January 1, 2005 TDB. */
/* Map this state back to rectangular coordinates as a check. */
/* PROGRAM EX1 */
/* IMPLICIT NONE */
/* C */
/* C SPICELIB functions */
/* C */
/* DOUBLE PRECISION RPD */
/* C */
/* C Local variables */
/* C */
/* DOUBLE PRECISION ALT */
/* DOUBLE PRECISION DRECTN ( 3 ) */
/* DOUBLE PRECISION ET */
/* DOUBLE PRECISION F */
/* DOUBLE PRECISION JACOBI ( 3, 3 ) */
/* DOUBLE PRECISION LAT */
/* DOUBLE PRECISION LON */
/* DOUBLE PRECISION LT */
/* DOUBLE PRECISION PGRVEL ( 3 ) */
/* DOUBLE PRECISION RADII ( 3 ) */
/* DOUBLE PRECISION RE */
/* DOUBLE PRECISION RECTAN ( 3 ) */
/* DOUBLE PRECISION RP */
/* DOUBLE PRECISION STATE ( 6 ) */
/* INTEGER N */
/* C */
/* C Load a PCK file containing a triaxial */
/* C ellipsoidal shape model and orientation */
/* C data for Mars. */
/* C */
/* CALL FURNSH ( 'pck00008.tpc' ) */
/* C */
/* C Load an SPK file giving ephemerides of earth and Mars. */
/* C */
/* CALL FURNSH ( 'de405.bsp' ) */
/* C */
/* C Load a leapseconds kernel to support time conversion. */
/* C */
/* CALL FURNSH ( 'naif0007.tls' ) */
/* C */
/* C Look up the radii for Mars. Although we */
/* C omit it here, we could first call BADKPV */
/* C to make sure the variable BODY499_RADII */
/* C has three elements and numeric data type. */
/* C If the variable is not present in the kernel */
/* C pool, BODVRD will signal an error. */
/* C */
/* CALL BODVRD ( 'MARS', 'RADII', 3, N, RADII ) */
/* C */
/* C Compute flattening coefficient. */
/* C */
/* RE = RADII(1) */
/* RP = RADII(3) */
/* F = ( RE - RP ) / RE */
/* C */
/* C Look up the geometric state of earth as seen from Mars at */
/* C January 1, 2005 TDB, relative to the J2000 reference */
/* C frame. */
/* C */
/* CALL STR2ET ( 'January 1, 2005 TDB', ET ) */
/* CALL SPKEZR ( 'Earth', ET, 'J2000', 'LT+S', */
/* . 'Mars', STATE, LT ) */
/* C */
/* C Convert position to planetographic coordinates. */
/* C */
/* CALL RECPGR ( 'MARS', STATE, RE, F, LON, LAT, ALT ) */
/* C */
/* C Convert velocity to planetographic coordinates. */
/* C */
/* CALL DPGRDR ( 'MARS', STATE(1), STATE(2), STATE(3), */
/* . RE, F, JACOBI ) */
/* CALL MXV ( JACOBI, STATE(4), PGRVEL ) */
/* C */
/* C As a check, convert the planetographic state back to */
/* C rectangular coordinates. */
/* C */
/* CALL PGRREC ( 'MARS', LON, LAT, ALT, RE, F, RECTAN ) */
/* CALL DRDPGR ( 'MARS', LON, LAT, ALT, RE, F, JACOBI ) */
/* CALL MXV ( JACOBI, PGRVEL, DRECTN ) */
/* WRITE(*,*) ' ' */
/* WRITE(*,*) 'Rectangular coordinates:' */
/* WRITE(*,*) ' ' */
/* WRITE(*,*) ' X (km) = ', STATE(1) */
/* WRITE(*,*) ' Y (km) = ', STATE(2) */
/* WRITE(*,*) ' Z (km) = ', STATE(3) */
/* WRITE(*,*) ' ' */
/* WRITE(*,*) 'Rectangular velocity:' */
/* WRITE(*,*) ' ' */
/* WRITE(*,*) ' dX/dt (km/s) = ', STATE(4) */
/* WRITE(*,*) ' dY/dt (km/s) = ', STATE(5) */
/* WRITE(*,*) ' dZ/dt (km/s) = ', STATE(6) */
/* WRITE(*,*) ' ' */
/* WRITE(*,*) 'Ellipsoid shape parameters: ' */
/* WRITE(*,*) ' ' */
/* WRITE(*,*) ' Equatorial radius (km) = ', RE */
/* WRITE(*,*) ' Polar radius (km) = ', RP */
/* WRITE(*,*) ' Flattening coefficient = ', F */
/* WRITE(*,*) ' ' */
/* WRITE(*,*) 'Planetographic coordinates:' */
/* WRITE(*,*) ' ' */
/* WRITE(*,*) ' Longitude (deg) = ', LON / RPD() */
/* WRITE(*,*) ' Latitude (deg) = ', LAT / RPD() */
/* WRITE(*,*) ' Altitude (km) = ', ALT */
/* WRITE(*,*) ' ' */
/* WRITE(*,*) 'Planetographic velocity:' */
/* WRITE(*,*) ' ' */
/* WRITE(*,*) ' d Longitude/dt (deg/s) = ', PGRVEL(1)/RPD() */
/* WRITE(*,*) ' d Latitude/dt (deg/s) = ', PGRVEL(2)/RPD() */
/* WRITE(*,*) ' d Altitude/dt (km/s) = ', PGRVEL(3) */
/* WRITE(*,*) ' ' */
/* WRITE(*,*) 'Rectangular coordinates from inverse ' // */
/* . 'mapping:' */
/* WRITE(*,*) ' ' */
/* WRITE(*,*) ' X (km) = ', RECTAN(1) */
/* WRITE(*,*) ' Y (km) = ', RECTAN(2) */
/* WRITE(*,*) ' Z (km) = ', RECTAN(3) */
/* WRITE(*,*) ' ' */
/* WRITE(*,*) 'Rectangular velocity from inverse mapping:' */
/* WRITE(*,*) ' ' */
/* WRITE(*,*) ' dX/dt (km/s) = ', DRECTN(1) */
/* WRITE(*,*) ' dY/dt (km/s) = ', DRECTN(2) */
/* WRITE(*,*) ' dZ/dt (km/s) = ', DRECTN(3) */
/* WRITE(*,*) ' ' */
/* END */
/* Output from this program should be similar to the following */
/* (rounding and formatting differ across platforms): */
/* Rectangular coordinates: */
/* X (km) = 146039732. */
/* Y (km) = 278546607. */
/* Z (km) = 119750315. */
/* Rectangular velocity: */
/* dX/dt (km/s) = -47.0428824 */
/* dY/dt (km/s) = 9.07021778 */
/* dZ/dt (km/s) = 4.75656274 */
/* Ellipsoid shape parameters: */
/* Equatorial radius (km) = 3396.19 */
/* Polar radius (km) = 3376.2 */
/* Flattening coefficient = 0.00588600756 */
/* Planetographic coordinates: */
/* Longitude (deg) = 297.667659 */
/* Latitude (deg) = 20.844504 */
/* Altitude (km) = 336531825. */
/* Planetographic velocity: */
/* d Longitude/dt (deg/s) = -8.35738632E-06 */
/* d Latitude/dt (deg/s) = 1.59349355E-06 */
/* d Altitude/dt (km/s) = -11.2144327 */
/* Rectangular coordinates from inverse mapping: */
/* X (km) = 146039732. */
/* Y (km) = 278546607. */
/* Z (km) = 119750315. */
/* Rectangular velocity from inverse mapping: */
/* dX/dt (km/s) = -47.0428824 */
/* dY/dt (km/s) = 9.07021778 */
/* dZ/dt (km/s) = 4.75656274 */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 26-DEC-2004 (NJB) (WLT) */
/* -& */
/* $ Index_Entries */
/* Jacobian of rectangular w.r.t. planetographic coordinates */
/* -& */
/* $ Revisions */
/* None. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
chkin_("DRDPGR", (ftnlen)6);
/* Convert the body name to an ID code. */
bods2c_(body, &bodyid, &found, body_len);
if (! found) {
setmsg_("The value of the input argument BODY is #, this is not a re"
"cognized name of an ephemeris object. The cause of this prob"
"lem may be that you need an updated version of the SPICE Too"
"lkit. ", (ftnlen)185);
errch_("#", body, (ftnlen)1, body_len);
sigerr_("SPICE(IDCODENOTFOUND)", (ftnlen)21);
chkout_("DRDPGR", (ftnlen)6);
return 0;
}
/* The equatorial radius must be positive. If not, signal an error */
/* and check out. */
if (*re <= 0.) {
setmsg_("Equatorial radius was #.", (ftnlen)24);
errdp_("#", re, (ftnlen)1);
sigerr_("SPICE(VALUEOUTOFRANGE)", (ftnlen)22);
chkout_("DRDPGR", (ftnlen)6);
return 0;
}
/* If the flattening coefficient is greater than 1, the polar radius */
/* is negative. If F is equal to 1, the polar radius is zero. Either */
/* case is a problem, so signal an error and check out. */
if (*f >= 1.) {
setmsg_("Flattening coefficient was #.", (ftnlen)29);
errdp_("#", f, (ftnlen)1);
sigerr_("SPICE(VALUEOUTOFRANGE)", (ftnlen)22);
chkout_("DRDPGR", (ftnlen)6);
return 0;
}
/* Look up the longitude sense override variable from the */
/* kernel pool. */
repmi_("BODY#_PGR_POSITIVE_LON", "#", &bodyid, pmkvar, (ftnlen)22, (
ftnlen)1, (ftnlen)32);
gcpool_(pmkvar, &c__1, &c__1, &n, kvalue, &found, (ftnlen)32, (ftnlen)80);
if (found) {
/* Make sure we recognize the value of PGRLON. */
cmprss_(" ", &c__0, kvalue, tmpstr, (ftnlen)1, (ftnlen)80, (ftnlen)32)
;
ucase_(tmpstr, pgrlon, (ftnlen)32, (ftnlen)4);
if (s_cmp(pgrlon, "EAST", (ftnlen)4, (ftnlen)4) == 0) {
sense = 1;
} else if (s_cmp(pgrlon, "WEST", (ftnlen)4, (ftnlen)4) == 0) {
sense = -1;
} else {
setmsg_("Kernel variable # may have the values EAST or WEST. Ac"
"tual value was #.", (ftnlen)72);
errch_("#", pmkvar, (ftnlen)1, (ftnlen)32);
errch_("#", kvalue, (ftnlen)1, (ftnlen)80);
sigerr_("SPICE(INVALIDOPTION)", (ftnlen)20);
chkout_("DRDPGR", (ftnlen)6);
return 0;
}
} else {
/* Look up the spin sense of the body's prime meridian. */
sense = plnsns_(&bodyid);
/* If the required prime meridian rate was not available, */
/* PLNSNS returns the code 0. Here we consider this situation */
/* to be an error. */
if (sense == 0) {
repmi_("BODY#_PM", "#", &bodyid, pmkvar, (ftnlen)8, (ftnlen)1, (
ftnlen)32);
setmsg_("Prime meridian rate coefficient defined by kernel varia"
"ble # is required but not available for body #. ", (
ftnlen)103);
errch_("#", pmkvar, (ftnlen)1, (ftnlen)32);
errch_("#", body, (ftnlen)1, body_len);
sigerr_("SPICE(MISSINGDATA)", (ftnlen)18);
chkout_("DRDPGR", (ftnlen)6);
return 0;
}
/* Handle the special cases: earth, moon, and sun. */
if (bodyid == 399 || bodyid == 301 || bodyid == 10) {
sense = 1;
}
}
/* At this point, SENSE is set to +/- 1. */
/* Adjust the longitude according to the sense of the body's */
/* spin, or according to the override value if one is provided. */
/* We want positive east longitude. */
geolon = sense * *lon;
/* Now that we have geodetic longitude in hand, use the */
/* geodetic equivalent of the input coordinates to find the */
/* Jacobian matrix of rectangular coordinates with respect */
/* to geodetic coordinates. */
drdgeo_(&geolon, lat, alt, re, f, jacobi);
/* The matrix JACOBI is */
/* .- -. */
/* | DX/DGEOLON DX/DLAT DX/DALT | */
/* | DY/DGEOLON DY/DLAT DY/DALT | */
/* | DZ/DGEOLON DZ/DLAT DZ/DALT | */
/* `- -' */
/* which, applying the chain rule to D(*)/DGEOLON, is equivalent to */
/* .- -. */
/* | (1/SENSE) * DX/DLON DX/DLAT DX/DALT | */
/* | (1/SENSE) * DY/DLON DY/DLAT DY/DALT | */
/* | (1/SENSE) * DZ/DLON DZ/DLAT DZ/DALT | */
/* `- -' */
/* So, multiplying the first column of JACOBI by SENSE gives us the */
/* matrix we actually want to compute: the Jacobian matrix of */
/* rectangular coordinates with respect to planetographic */
/* coordinates. */
for (i__ = 1; i__ <= 3; ++i__) {
jacobi[(i__1 = i__ - 1) < 9 && 0 <= i__1 ? i__1 : s_rnge("jacobi",
i__1, "drdpgr_", (ftnlen)736)] = sense * jacobi[(i__2 = i__ -
1) < 9 && 0 <= i__2 ? i__2 : s_rnge("jacobi", i__2, "drdpgr_",
(ftnlen)736)];
}
chkout_("DRDPGR", (ftnlen)6);
return 0;
} /* drdpgr_ */
/* $Procedure OUTMSG ( Output Error Messages ) */
/* Subroutine */ int outmsg_(char *list, ftnlen list_len)
{
/* Initialized data */
static char defmsg[80*4] = "Oh, by the way: The SPICELIB error handling"
" actions are USER-TAILORABLE. You " "can choose whether the To"
"olkit aborts or continues when errors occur, which " "error "
"messages to output, and where to send the output. Please read t"
"he ERROR " "\"Required Reading\" file, or see the routines ERRA"
"CT, ERRDEV, and ERRPRT. ";
static logical first = TRUE_;
/* System generated locals */
address a__1[2], a__2[3];
integer i__1, i__2, i__3[2], i__4[3];
char ch__1[38];
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen),
s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char name__[32], line[80];
logical long__;
char lmsg[1840];
logical expl;
char smsg[25], xmsg[80];
integer i__;
logical trace;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
integer depth, index;
extern integer wdcnt_(char *, ftnlen);
extern /* Subroutine */ int expln_(char *, char *, ftnlen, ftnlen);
extern integer rtrim_(char *, ftnlen);
char versn[80], words[9*5];
integer start;
logical short__;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
char device[255];
integer remain;
static char border[80];
extern /* Subroutine */ int getdev_(char *, ftnlen);
logical dfault;
integer length;
extern /* Subroutine */ int trcdep_(integer *);
extern integer lastnb_(char *, ftnlen);
extern /* Subroutine */ int trcnam_(integer *, char *, ftnlen), lparse_(
char *, char *, integer *, integer *, char *, ftnlen, ftnlen,
ftnlen);
extern logical msgsel_(char *, ftnlen);
integer wrdlen;
extern /* Subroutine */ int getlms_(char *, ftnlen), wrline_(char *, char
*, ftnlen, ftnlen), getsms_(char *, ftnlen), suffix_(char *,
integer *, char *, ftnlen, ftnlen);
char tmpmsg[105];
extern /* Subroutine */ int nextwd_(char *, char *, char *, ftnlen,
ftnlen, ftnlen);
integer numwrd;
char upword[9], outwrd[1840];
extern /* Subroutine */ int tkvrsn_(char *, char *, ftnlen, ftnlen);
logical output;
/* $ Abstract */
/* Output error messages. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* ERROR */
/* $ Keywords */
/* ERROR */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include File: SPICELIB Error Handling Parameters */
/* errhnd.inc Version 2 18-JUN-1997 (WLT) */
/* The size of the long error message was */
/* reduced from 25*80 to 23*80 so that it */
/* will be accepted by the Microsoft Power Station */
/* FORTRAN compiler which has an upper bound */
/* of 1900 for the length of a character string. */
/* errhnd.inc Version 1 29-JUL-1997 (NJB) */
/* Maximum length of the long error message: */
/* Maximum length of the short error message: */
/* End Include File: SPICELIB Error Handling Parameters */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* LIST I A list of error message types. */
/* FILEN P Maximum length of file name. */
/* NAMLEN P Maximum length of module name. See TRCPKG. */
/* LL P Output line length. */
/* $ Detailed_Input */
/* LIST is a list of error message types. A list is a */
/* character string containing one or more words */
/* from the following list, separated by commas. */
/* SHORT */
/* EXPLAIN */
/* LONG */
/* TRACEBACK */
/* DEFAULT */
/* Each type of error message specified in LIST will */
/* be output when an error is detected, if it is */
/* enabled for output. Note that DEFAULT does */
/* NOT refer to the "default message selection," */
/* but rather to a special message that is output */
/* when the error action is 'DEFAULT'. This message */
/* is a statement referring the user to the error */
/* handling documentation. */
/* Messages are never duplicated in the output; for */
/* instance, supplying a value of LIST such as */
/* 'SHORT, SHORT' */
/* does NOT result in the output of two short */
/* messages. */
/* The words in LIST may appear in mixed case; */
/* for example, the call */
/* CALL OUTMSG ( 'ShOrT' ) */
/* will work. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* FILEN is the maximum device name length that can be */
/* accommodated by this routine. */
/* NAMELN is the maximum length of an individual module name. */
/* LL is the maximum line length for the output message. */
/* If the output message string is very long, it is */
/* displayed over several lines, each of which has a */
/* maximum length of LL characters. */
/* $ Exceptions */
/* 1) This routine detects invalid message types in the argument, */
/* LIST. The short error message in this case is */
/* 'SPICE(INVALIDLISTITEM)' */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine is part of the SPICELIB error handling */
/* mechanism. */
/* This routine outputs the error messages specified in LIST that */
/* have been enabled for output (use the SPICELIB routine ERRPRT */
/* to enable or disable output of specified types of error */
/* messages). A border is written out preceding and following the */
/* messages. Output is directed to the current error output device. */
/* $ Examples */
/* 1) Output the short and long error messages: */
/* C */
/* C Output short and long messages: */
/* C */
/* CALL OUTMSG ( 'SHORT, LONG' ) */
/* $ Restrictions */
/* 1) This routine is intended for use by the SPICELIB error */
/* handling mechanism. SPICELIB users are not expected to */
/* need to call this routine. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* K.R. Gehringer (JPL) */
/* H.A. Neilan (JPL) */
/* M.J. Spencer (JPL) */
/* $ Version */
/* - SPICELIB Version 5.27.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 5.26.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 5.25.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 5.24.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 5.23.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 5.22.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 5.21.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 5.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 5.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 5.18.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 5.17.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 5.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 5.15.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 5.14.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 5.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 5.12.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 5.11.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 5.10.0, 01-MAR-2009 (NJB) */
/* Bug fix: truncation of long words in */
/* output has been corrected. Local parameter */
/* TMPLEN was added and is used in declaration */
/* of TMPMSG. */
/* - SPICELIB Version 5.9.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 5.8.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 5.7.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 5.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 5.5.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 5.4.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 5.3.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 5.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 5.1.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 5.1.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 5.1.3, 24-SEP-1999 (NJB) */
/* CSPICE environments were added. Some typos were corrected. */
/* - SPICELIB Version 5.1.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 5.1.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 5.1.0, 13-JAN-1999 (BVS) */
/* ``errhnd.inc'' file was included. Long and short error */
/* message lengths parameter declarations were deleted. Long */
/* and short error message string sizes were changed to those */
/* declared in ``errhnd.inc''. */
/* - SPICELIB Version 5.0.0, 08-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 4.0.0, 09-MAY-1996 (KRG) */
/* Added the toolkit version to the output error message. */
/* Updated this routine to be consistent with the trace package */
/* revisions. This primarily affects the creation of the */
/* traceback string. */
/* Long error messages are now wrapped on word boundaries when */
/* they are longer than the output line length. Note that this */
/* only happens for long error messages obtained from GETLMS, */
/* and not for the error messages displayed by this subroutine */
/* and other error handling subroutines that write their own */
/* error messages. */
/* - SPICELIB Version 3.0.0, 09-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* for the Silicon Graphics, DEC Alpha-OSF/1, and */
/* NeXT platforms. Also, the previous value of 256 for */
/* Unix platforms was changed to 255. */
/* - SPICELIB Version 2.2.0, 12-OCT-1992 (HAN) */
/* Updated module for multiple environments. Moved the parameter */
/* LL to the Declarations section of the header since it's */
/* environment dependent. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 2.1.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 2.1.0, 15-MAY-1991 (MJS) */
/* Module was updated to include the value of LL for the */
/* Macintosh. */
/* - SPICELIB Version 2.0.0, 28-MAR-1991 (NJB) */
/* Work-around for MS Fortran compiler error under DOS 3.10 */
/* was made. Some substring bounds were simplified using RTRIM. */
/* Updates were made to the header to clarify the text and */
/* improve the header's appearance. The default error message */
/* was slightly de-uglified. */
/* The IBM PC version of this routine now uses an output line */
/* length of 78 characters rather than 80. This prevents */
/* wrapping of the message borders and default error message. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (NJB) */
/* -& */
/* $ Index_Entries */
/* None. */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 5.1.0, 13-JAN-1999 (BVS) */
/* ``errhnd.inc'' file was included. Long and short error */
/* message lengths parameter declarations were deleted. Long */
/* and short error message string size were changed to those */
/* declared in ``errhnd.inc''. */
/* - SPICELIB Version 5.0.0, 08-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 4.0.0, 09-MAY-1996 (KRG) */
/* Added the toolkit version to the output error message. */
/* Updated this routine to be consistent with the trace package */
/* revisions. This primarily affects the creation of the */
/* traceback string. */
/* Long error messages are now wrapped on word boundaries when */
/* they are longer than the output line length. Note that this */
/* only happens for long error messages obtained from GETLMS, */
/* and not for the error messages displayed by this subroutine */
/* and other error handling subroutines that write their own */
/* error messages. */
/* - SPICELIB Version 3.0.0, 9-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* for the Silicon Graphics, DEC Alpha-OSF/1, and */
/* NeXT platforms. Also, the previous value of 256 for */
/* Unix platforms was changed to 255. */
/* - SPICELIB Version 2.2.0, 12-OCT-1992 (HAN) */
/* Updated module for multiple environments. Moved the */
/* parameter LL to the Declarations section of the header since */
/* it's environment dependent. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 2.1.0, 15-MAY-1991 (MJS) */
/* Module was updated to include the value of LL for the */
/* Macintosh. */
/* - SPICELIB Version 2.0.0, 28-MAR-1991 (NJB) */
/* 1) Work-around for MS Fortran compiler error under DOS 3.10 */
/* was made. The compiler did not correctly handle code that */
/* concatenated strings whose bounds involved the intrinsic */
/* MAX function. */
/* 2) Some substring bounds were simplified using RTRIM. */
/* 3) Updates were made to the header to clarify the text and */
/* improve the header's appearance. */
/* 4) Declarations were re-organized. */
/* 5) The default error message was slightly de-uglified. */
/* 6) The IBM PC version of this routine now uses an output line */
/* length of 78 characters rather than 80. This prevents */
/* wrapping of the message borders and default error message. */
/* - Beta Version 1.3.0, 19-JUL-1989 (NJB) */
/* Calls to REMSUB removed; blanking and left-justifying used */
/* instead. This was done because REMSUB handles substring */
/* bounds differently than in previous versions, and no longer */
/* handles all possible inputs as required by this routine. */
/* LJUST, which is used now, is error free. */
/* Also, an instance of .LT. was changed to .LE. The old code */
/* caused a line break one character too soon. A minor bug, but */
/* a bug nonetheless. */
/* Also, two substring bounds were changed to ensure that they */
/* remain greater than zero. */
/* - Beta Version 1.2.0, 16-FEB-1989 (NJB) */
/* Warnings added to discourage use of this routine in */
/* non-error-handling code. Parameters section updated to */
/* describe FILEN and NAMLEN. */
/* Declaration of unused function FAILED removed. */
/* - Beta Version 1.1.0, 06-OCT-1988 (NJB) */
/* Test added to ensure substring upper bound is greater than 0. */
/* REMAIN must be greater than 0 when used as the upper bound */
/* for a substring of NAME. Also, substring upper bound in */
/* WRLINE call is now forced to be greater than 0. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* These parameters are system-independent. */
/* Local variables */
/* Saved variables */
/* Initial Values: */
/* Executable Code: */
/* The first time through, set up the output borders. */
if (first) {
first = FALSE_;
for (i__ = 1; i__ <= 80; ++i__) {
*(unsigned char *)&border[i__ - 1] = '=';
}
}
/* No messages are to be output which are not specified */
/* in LIST: */
short__ = FALSE_;
expl = FALSE_;
long__ = FALSE_;
trace = FALSE_;
dfault = FALSE_;
/* We parse the list of message types, and set local flags */
/* indicating which ones are to be output. If we find */
/* a word we don't recognize in the list, we signal an error */
/* and continue parsing the list. */
lparse_(list, ",", &c__5, &numwrd, words, list_len, (ftnlen)1, (ftnlen)9);
i__1 = numwrd;
for (i__ = 1; i__ <= i__1; ++i__) {
ucase_(words + ((i__2 = i__ - 1) < 5 && 0 <= i__2 ? i__2 : s_rnge(
"words", i__2, "outmsg_", (ftnlen)613)) * 9, upword, (ftnlen)
9, (ftnlen)9);
if (s_cmp(upword, "SHORT", (ftnlen)9, (ftnlen)5) == 0) {
short__ = TRUE_;
} else if (s_cmp(upword, "EXPLAIN", (ftnlen)9, (ftnlen)7) == 0) {
expl = TRUE_;
} else if (s_cmp(upword, "LONG", (ftnlen)9, (ftnlen)4) == 0) {
long__ = TRUE_;
} else if (s_cmp(upword, "TRACEBACK", (ftnlen)9, (ftnlen)9) == 0) {
trace = TRUE_;
} else if (s_cmp(upword, "DEFAULT", (ftnlen)9, (ftnlen)7) == 0) {
dfault = TRUE_;
} else {
/* Unrecognized word! This is an error... */
/* We have a special case on our hands; this routine */
/* is itself called by SIGERR, so a recursion error will */
/* result if this routine calls SIGERR. So we output */
/* the error message directly: */
getdev_(device, (ftnlen)255);
wrline_(device, "SPICE(INVALIDLISTITEM)", (ftnlen)255, (ftnlen)22)
;
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
wrline_(device, "OUTMSG: An invalid message type was specified "
"in the type list. ", (ftnlen)255, (ftnlen)65);
/* Writing concatenation */
i__3[0] = 29, a__1[0] = "The invalid message type was ";
i__3[1] = 9, a__1[1] = words + ((i__2 = i__ - 1) < 5 && 0 <= i__2
? i__2 : s_rnge("words", i__2, "outmsg_", (ftnlen)650)) *
9;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)38);
wrline_(device, ch__1, (ftnlen)255, (ftnlen)38);
}
}
/* LIST has been parsed. */
/* Now, we output those error messages that were specified by LIST */
/* and which belong to the set of messages selected for output. */
/* We get the default error output device: */
getdev_(device, (ftnlen)255);
output = short__ && msgsel_("SHORT", (ftnlen)5) || expl && msgsel_("EXPL"
"AIN", (ftnlen)7) || long__ && msgsel_("LONG", (ftnlen)4) || trace
&& msgsel_("TRACEBACK", (ftnlen)9) || dfault && msgsel_("DEFAULT",
(ftnlen)7) && s_cmp(device, "NULL", (ftnlen)255, (ftnlen)4) != 0;
/* We go ahead and output those messages that have been specified */
/* in the list and also are enabled for output. The order of the */
/* cases below IS significant; the order in which the messages */
/* appear in the output depends on it. */
/* If there's nothing to output, we can leave now. */
if (! output) {
return 0;
}
/* Write the starting border: skip a line, write the border, */
/* skip a line. */
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
wrline_(device, border, (ftnlen)255, (ftnlen)80);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
/* Output the toolkit version and skip a line. */
tkvrsn_("TOOLKIT", versn, (ftnlen)7, (ftnlen)80);
/* Writing concatenation */
i__3[0] = 17, a__1[0] = "Toolkit version: ";
i__3[1] = 80, a__1[1] = versn;
s_cat(line, a__1, i__3, &c__2, (ftnlen)80);
wrline_(device, line, (ftnlen)255, (ftnlen)80);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
/* Next, we output the messages specified in the list */
/* that have been enabled. */
/* We start with the short message and its accompanying */
/* explanation. If both are to be output, they are */
/* concatenated into a single message. */
if (short__ && msgsel_("SHORT", (ftnlen)5) && (expl && msgsel_("EXPLAIN",
(ftnlen)7))) {
/* Extract the short message from global storage; then get */
/* the corresponding explanation. */
getsms_(smsg, (ftnlen)25);
expln_(smsg, xmsg, (ftnlen)25, (ftnlen)80);
/* Writing concatenation */
i__4[0] = rtrim_(smsg, (ftnlen)25), a__2[0] = smsg;
i__4[1] = 4, a__2[1] = " -- ";
i__4[2] = 80, a__2[2] = xmsg;
s_cat(tmpmsg, a__2, i__4, &c__3, (ftnlen)105);
wrline_(device, tmpmsg, (ftnlen)255, (ftnlen)105);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
} else if (short__ && msgsel_("SHORT", (ftnlen)5)) {
/* Output the short error message without the explanation. */
getsms_(smsg, (ftnlen)25);
wrline_(device, smsg, (ftnlen)255, (ftnlen)25);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
} else if (expl && msgsel_("EXPLAIN", (ftnlen)7)) {
/* Obtain the explanatory text for the short error */
/* message and output it: */
getsms_(smsg, (ftnlen)25);
expln_(smsg, xmsg, (ftnlen)25, (ftnlen)80);
wrline_(device, xmsg, (ftnlen)255, (ftnlen)80);
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
if (long__ && msgsel_("LONG", (ftnlen)4)) {
/* Extract the long message from global storage and */
/* output it: */
getlms_(lmsg, (ftnlen)1840);
/* Get the number of words in the error message. */
numwrd = wdcnt_(lmsg, (ftnlen)1840);
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
start = 1;
/* Format the words into output lines and display them as */
/* needed. */
i__1 = numwrd;
for (i__ = 1; i__ <= i__1; ++i__) {
nextwd_(lmsg, outwrd, lmsg, (ftnlen)1840, (ftnlen)1840, (ftnlen)
1840);
wrdlen = rtrim_(outwrd, (ftnlen)1840);
if (start + wrdlen <= 80) {
s_copy(line + (start - 1), outwrd, 80 - (start - 1), (ftnlen)
1840);
start = start + wrdlen + 1;
} else {
if (wrdlen <= 80) {
/* We had a short word, so just write the line and */
/* continue. */
wrline_(device, line, (ftnlen)255, (ftnlen)80);
start = wrdlen + 2;
s_copy(line, outwrd, (ftnlen)80, (ftnlen)1840);
} else {
/* We got a very long word here, so we break it up and */
/* write it out. We fit as much of it as we an into line */
/* as possible before writing it. */
/* Get the remaining space. If START is > 1 we have at */
/* least one word already in the line, including it's */
/* trailing space, otherwise the line is blank. If line */
/* is empty, we have all of the space available. */
if (start > 1) {
remain = 80 - start;
} else {
remain = 80;
}
/* Now we stuff bits of the word into the output line */
/* until we're done, i.e., until we have a word part */
/* that is less than the output length. First, we */
/* check to see if there is a "significant" amount of */
/* room left in the current output line. If not, we */
/* write it and then begin stuffing the long word into */
/* output lines. */
if (remain < 10) {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
remain = 80;
start = 1;
}
/* Stuff the word a chunk at a time into output lines */
/* and write them. After writing a line, we clear the */
/* part of the long word that we just wrote, left */
/* justifying the remaining part before proceeding. */
while(wrdlen > 80) {
s_copy(line + (start - 1), outwrd, 80 - (start - 1),
remain);
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(outwrd, " ", remain, (ftnlen)1);
ljust_(outwrd, outwrd, (ftnlen)1840, (ftnlen)1840);
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
wrdlen -= remain;
remain = 80;
start = 1;
}
/* If we had a part of the long word left, get set up to */
/* append more words from the error message to the output */
/* line. If we finished the word, WRDLEN .EQ. 0, then */
/* START and LINE have already been initialized. */
if (wrdlen > 0) {
start = wrdlen + 2;
s_copy(line, outwrd, (ftnlen)80, (ftnlen)1840);
}
}
}
}
/* We may need to write the remaining part of a line. */
if (s_cmp(line, " ", (ftnlen)80, (ftnlen)1) != 0) {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
}
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
if (trace && msgsel_("TRACEBACK", (ftnlen)9)) {
/* Extract the traceback from global storage and */
/* output it: */
trcdep_(&depth);
if (depth > 0) {
/* We know we'll be outputting some trace information. */
/* So, write a line telling the reader what's coming. */
wrline_(device, "A traceback follows. The name of the highest l"
"evel module is first.", (ftnlen)255, (ftnlen)68);
/* While there are more names in the traceback */
/* representation, we stuff them into output lines and */
/* write the lines out when they are full. */
s_copy(line, " ", (ftnlen)80, (ftnlen)1);
remain = 80;
i__1 = depth;
for (index = 1; index <= i__1; ++index) {
/* For each module name in the traceback representation, */
/* retrieve module name and stuff it into one or more */
/* lines for output. */
/* Get a name and add the call order sign. We */
/* indicate calling order by a ' --> ' delimiter; e.g. */
/* "A calls B" is indicated by 'A --> B'. */
trcnam_(&index, name__, (ftnlen)32);
length = lastnb_(name__, (ftnlen)32);
/* If it's the first name, just put it into the output */
/* line, otherwise, add the call order sign and put the */
/* name into the output line. */
if (index == 1) {
suffix_(name__, &c__0, line, (ftnlen)32, (ftnlen)80);
remain -= length;
} else {
/* Add the calling order indicator, if it will fit. */
/* If not, write the line and put the indicator as */
/* the first thing on the next line. */
if (remain >= 4) {
suffix_("-->", &c__1, line, (ftnlen)3, (ftnlen)80);
remain += -4;
} else {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(line, "-->", (ftnlen)80, (ftnlen)3);
remain = 77;
}
/* The name fits or it doesn't. If it does, just add */
/* it, if it doesn't, write it, then make the name */
/* the first thing on the next line. */
if (remain >= length) {
suffix_(name__, &c__1, line, (ftnlen)32, (ftnlen)80);
remain = remain - length - 1;
} else {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
s_copy(line, name__, (ftnlen)80, (ftnlen)32);
remain = 80 - length;
}
}
}
/* At this point, no more names are left in the */
/* trace representation. LINE may still contain */
/* names, or part of a long name. If it does, */
/* we now write it out. */
if (s_cmp(line, " ", (ftnlen)80, (ftnlen)1) != 0) {
wrline_(device, line, (ftnlen)255, (ftnlen)80);
}
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
/* At this point, either we have output the trace */
/* representation, or the trace representation was */
/* empty. */
}
if (dfault && msgsel_("DEFAULT", (ftnlen)7)) {
/* Output the default message: */
for (i__ = 1; i__ <= 4; ++i__) {
wrline_(device, defmsg + ((i__1 = i__ - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("defmsg", i__1, "outmsg_", (ftnlen)971)) *
80, (ftnlen)255, (ftnlen)80);
}
wrline_(device, " ", (ftnlen)255, (ftnlen)1);
}
/* At this point, we've output all of the enabled messages */
/* that were specified in LIST. At least one message that */
/* was specified was enabled. */
/* Write the ending border out: */
wrline_(device, border, (ftnlen)255, (ftnlen)80);
return 0;
} /* outmsg_ */
/* $Procedure REPMCT ( Replace marker with cardinal text ) */
/* Subroutine */ int repmct_(char *in, char *marker, integer *value, char *
case__, char *out, ftnlen in_len, ftnlen marker_len, ftnlen case_len,
ftnlen out_len)
{
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
char card[145];
extern /* Subroutine */ int lcase_(char *, char *, ftnlen, ftnlen),
chkin_(char *, ftnlen), ucase_(char *, char *, ftnlen, ftnlen),
errch_(char *, char *, ftnlen, ftnlen), ljust_(char *, char *,
ftnlen, ftnlen);
integer mrknbf;
extern integer lastnb_(char *, ftnlen);
integer mrknbl;
char tmpcas[1];
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen);
extern integer frstnb_(char *, ftnlen);
integer mrkpsb;
extern /* Subroutine */ int repsub_(char *, integer *, integer *, char *,
char *, ftnlen, ftnlen, ftnlen);
integer mrkpse;
extern /* Subroutine */ int setmsg_(char *, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int inttxt_(integer *, char *, ftnlen);
/* $ Abstract */
/* Replace a marker with the text representation of a */
/* cardinal number. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* CHARACTER */
/* CONVERSION */
/* STRING */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* IN I Input string. */
/* MARKER I Marker to be replaced. */
/* VALUE I Cardinal value. */
/* CASE I Case of replacement text. */
/* OUT O Output string. */
/* MAXLCN P Maximum length of a cardinal number. */
/* $ Detailed_Input */
/* IN is an arbitrary character string. */
/* MARKER is an arbitrary character string. The first */
/* occurrence of MARKER in the input string is */
/* to be replaced by the text representation of */
/* the cardinal number VALUE. */
/* Leading and trailing blanks in MARKER are NOT */
/* significant. In particular, no substitution is */
/* performed if MARKER is blank. */
/* VALUE is an arbitrary integer. */
/* CASE indicates the case of the replacement text. */
/* CASE may be any of the following: */
/* CASE Meaning Example */
/* ---- ----------- ----------------------- */
/* U, u Uppercase ONE HUNDRED FIFTY-THREE */
/* L, l Lowercase one hundred fifty-three */
/* C, c Capitalized One hundred fifty-three */
/* $ Detailed_Output */
/* OUT is the string obtained by substituting the text */
/* representation of the cardinal number VALUE for */
/* the first occurrence of MARKER in the input string. */
/* OUT and IN must be identical or disjoint. */
/* $ Parameters */
/* MAXLCN is the maximum expected length of any cardinal */
/* text. 145 characters are sufficient to hold the */
/* text representing any value in the range */
/* ( -10**12, 10**12 ) */
/* An example of a number whose text representation */
/* is of maximum length is */
/* - 777 777 777 777 */
/* $ Exceptions */
/* 1) If OUT does not have sufficient length to accommodate the */
/* result of the substitution, the result will be truncated on */
/* the right. */
/* 2) If MARKER is blank, or if MARKER is not a substring of IN, */
/* no substitution is performed. (OUT and IN are identical.) */
/* 3) If the value of CASE is not recognized, the error */
/* SPICE(INVALIDCASE) is signalled. OUT is not changed. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This is one of a family of related routines for inserting values */
/* into strings. They are typically used to construct messages that */
/* are partly fixed, and partly determined at run time. For example, */
/* a message like */
/* 'Fifty-one pictures were found in directory [USER.DATA].' */
/* might be constructed from the fixed string */
/* '#1 pictures were found in directory #2.' */
/* by the calls */
/* CALL REPMCT ( STRING, '#1', NPICS, 'C', STRING ) */
/* CALL REPMC ( STRING, '#2', DIRNAM, STRING ) */
/* which substitute the cardinal text 'Fifty-one' and the character */
/* string '[USER.DATA]' for the markers '#1' and '#2' respectively. */
/* The complete list of routines is shown below. */
/* REPMC ( Replace marker with character string value ) */
/* REPMD ( Replace marker with double precision value ) */
/* REPMF ( Replace marker with formatted d.p. value ) */
/* REPMI ( Replace marker with integer value ) */
/* REPMCT ( Replace marker with cardinal text) */
/* REPMOT ( Replace marker with ordinal text ) */
/* $ Examples */
/* The following examples illustrate the use of REPMCT to */
/* replace a marker within a string with the cardinal text */
/* corresponding to an integer. */
/* Uppercase */
/* --------- */
/* Let */
/* MARKER = '#' */
/* IN = 'INVALID COMMAND. WORD # WAS NOT RECOGNIZED.' */
/* Then following the call, */
/* CALL REPMCT ( IN, '#', 5, 'U', IN ) */
/* IN is */
/* 'INVALID COMMAND. WORD FIVE WAS NOT RECOGNIZED.' */
/* Lowercase */
/* --------- */
/* Let */
/* MARKER = ' XX ' */
/* IN = 'Word XX of the XX sentence was misspelled.' */
/* Then following the call, */
/* CALL REPMCT ( IN, ' XX ', 5, 'L', OUT ) */
/* OUT is */
/* 'Word five of the XX sentence was misspelled.' */
/* Capitalized */
/* ----------- */
/* Let */
/* MARKER = ' XX ' */
/* IN = 'Name: YY. Rank: XX.' */
/* Then following the calls, */
/* CALL REPMC ( IN, 'YY', 'Moriarty', OUT ) */
/* CALL REPMCT ( OUT, 'XX', 1, 'C', OUT ) */
/* OUT is */
/* 'Name: Moriarty. Rank: One.' */
/* $ Restrictions */
/* 1) VALUE must be in the range accepted by subroutine INTTXT. */
/* This range is currently */
/* ( -10**12, 10**12 ) */
/* Note that the endpoints of the interval are excluded. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* B.V. Semenov (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.0, 21-SEP-2013 (BVS) */
/* Minor efficiency update: the routine now looks up the first */
/* and last non-blank characters only once. */
/* - 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, 30-AUG-1990 (NJB) (IMU) */
/* -& */
/* $ Index_Entries */
/* replace marker with cardinal text */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("REPMCT", (ftnlen)6);
}
/* Bail out if CASE is not recognized. */
ljust_(case__, tmpcas, (ftnlen)1, (ftnlen)1);
ucase_(tmpcas, tmpcas, (ftnlen)1, (ftnlen)1);
if (*(unsigned char *)tmpcas != 'U' && *(unsigned char *)tmpcas != 'L' &&
*(unsigned char *)tmpcas != 'C') {
setmsg_("Case (#) must be U, L, or C.", (ftnlen)28);
errch_("#", case__, (ftnlen)1, (ftnlen)1);
sigerr_("SPICE(INVALIDCASE)", (ftnlen)18);
chkout_("REPMCT", (ftnlen)6);
return 0;
}
/* If MARKER is blank, no substitution is possible. */
if (s_cmp(marker, " ", marker_len, (ftnlen)1) == 0) {
s_copy(out, in, out_len, in_len);
chkout_("REPMCT", (ftnlen)6);
return 0;
}
/* Locate the leftmost occurrence of MARKER, if there is one */
/* (ignoring leading and trailing blanks). If MARKER is not */
/* a substring of IN, no substitution can be performed. */
mrknbf = frstnb_(marker, marker_len);
mrknbl = lastnb_(marker, marker_len);
mrkpsb = i_indx(in, marker + (mrknbf - 1), in_len, mrknbl - (mrknbf - 1));
if (mrkpsb == 0) {
s_copy(out, in, out_len, in_len);
chkout_("REPMCT", (ftnlen)6);
return 0;
}
mrkpse = mrkpsb + mrknbl - mrknbf;
/* Okay, CASE is recognized and MARKER has been found. */
/* Generate the cardinal text corresponding to VALUE. */
inttxt_(value, card, (ftnlen)145);
/* CARD is always returned in upper case; change to the specified */
/* case, if required. */
if (*(unsigned char *)tmpcas == 'L') {
lcase_(card, card, (ftnlen)145, (ftnlen)145);
} else if (*(unsigned char *)tmpcas == 'C') {
lcase_(card + 1, card + 1, (ftnlen)144, (ftnlen)144);
}
/* Replace MARKER with CARD. */
repsub_(in, &mrkpsb, &mrkpse, card, out, in_len, lastnb_(card, (ftnlen)
145), out_len);
chkout_("REPMCT", (ftnlen)6);
return 0;
} /* repmct_ */
/* $Procedure PRTRAP */
/* Subroutine */ int prtrap_(char *command, logical *tran, ftnlen command_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Local variables */
char word[33*3];
integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen), errch_(char *, char *, ftnlen, ftnlen), nthwd_(
char *, integer *, char *, integer *, ftnlen, ftnlen);
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen);
integer loc;
/* $ Abstract */
/* Determine whether the given command should be trapped (left */
/* untranslated). */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Keywords */
/* PERCY */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* COMMND I PERCY command to be evaluated. */
/* TRAN I True if further translation is needed. */
/* $ Detailed_Input */
/* COMMAND is the input PERCY command. The following commands */
/* should not be translated fully. (A moment's thought */
/* will show why.) */
/* - SHOW SYMBOL <symbol> */
/* - INQUIRE <symbol> */
/* If translation has proceeded far enough for either */
/* of these statements to be recognized, then it has */
/* gone far enough. */
/* $ Detailed_Output */
/* TRAN is true if further translation of COMMAND is okay. */
/* If any of the statements mentioned above is recognized, */
/* TRAN is false. (This will prevent PERCY from trying */
/* to resolve any more symbols.) */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* See 'SYMBOLS.INC'. */
/* $ Detailed_Description */
/* Get the first three words of COMMAND. */
/* - If the first two words are SHOW SYMBOL, and the */
/* third word is not blank and does not end with '?', */
/* then this should be trapped. */
/* - If the first word is INQUIRE and the second word */
/* is not blank and does not end with '?', then this */
/* should be trapped. */
/* If the statement should be trapped, set TRAN to false and return. */
/* $ Examples */
/* Command Trap? */
/* ------------------------------------ ----- */
/* 'SHOW SYMBOL CARROT ' Y */
/* 'SHOW SYMBOL ' N */
/* 'SHOW SYMBOL SYMBOL_NAME? ' N */
/* 'INQUIRE PRIMARY_PLANET ' N */
/* 'INQUIRE ' Y */
/* 'INQUIRE QUERY_NAME? ' Y */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* W. L. Taber (JPL) */
/* I. M. Underwood (JPL) */
/* $ Version_and_Date */
/* Version 1, 17-SEP-1986 */
/* -& */
/* Spicelib Functions */
/* Local variables */
/* Get the first three words of COMMAND. */
for (i__ = 1; i__ <= 3; ++i__) {
nthwd_(command, &i__, word + ((i__1 = i__ - 1) < 3 && 0 <= i__1 ?
i__1 : s_rnge("word", i__1, "prtrap_", (ftnlen)144)) * 33, &
loc, command_len, (ftnlen)33);
ucase_(word + ((i__1 = i__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
"word", i__1, "prtrap_", (ftnlen)145)) * 33, word + ((i__2 =
i__ - 1) < 3 && 0 <= i__2 ? i__2 : s_rnge("word", i__2, "prt"
"rap_", (ftnlen)145)) * 33, (ftnlen)33, (ftnlen)33);
}
/* Is this a SHOW SYMBOL command? */
if (s_cmp(word, "SHOW", (ftnlen)33, (ftnlen)4) == 0 && s_cmp(word + 33,
"SYMBOL", (ftnlen)33, (ftnlen)6) == 0) {
/* The third word must not be blank, and must not end with '?'. */
/* (WORD is longer than any allowable symbol or query, so there */
/* should always be a blank at the end.) */
if (s_cmp(word + 66, " ", (ftnlen)33, (ftnlen)1) != 0) {
loc = rtrim_(word + 66, (ftnlen)33);
if (*(unsigned char *)&word[loc + 65] != '?') {
*tran = FALSE_;
return 0;
}
}
/* Is this an INQUIRE command? */
} else if (s_cmp(word, "INQUIRE", (ftnlen)33, (ftnlen)7) == 0) {
/* The second word must not be blank, and must not end with '?'. */
if (s_cmp(word + 33, " ", (ftnlen)33, (ftnlen)1) != 0) {
loc = rtrim_(word + 33, (ftnlen)33);
if (*(unsigned char *)&word[loc + 32] == '?') {
*tran = FALSE_;
chkin_("PRTRAP", (ftnlen)6);
setmsg_("INQUIRE commands must be of the form INQUIRE <symbo"
"l_name>, You have INQUIRE # which is inquiring for "
"the value of a query. This kind of INQUIRE is not su"
"pported. ", (ftnlen)164);
errch_("#", word + 33, (ftnlen)1, (ftnlen)33);
sigerr_("INVALID_INQUIRE", (ftnlen)15);
chkout_("PRTRAP", (ftnlen)6);
return 0;
}
}
}
/* No reason to trap this. */
*tran = TRUE_;
return 0;
} /* prtrap_ */
/* $Procedure STRAN */
/* Subroutine */ int stran_0_(int n__, char *input, char *output, logical *
tran, ftnlen input_len, ftnlen output_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen), i_indx(char *, char *,
ftnlen, ftnlen), s_rnge(char *, integer, char *, integer), i_len(
char *, ftnlen);
/* Local variables */
static integer ldef, leno, vdim, slot, lout, lsym, ptrs[810], i__, j;
extern integer cardc_(char *, ftnlen);
static integer l, n;
static logical check[200];
extern logical batch_(void);
static integer place;
extern /* Subroutine */ int lcase_(char *, char *, ftnlen, ftnlen);
static char delim[1];
extern /* Subroutine */ int chkin_(char *, ftnlen);
static integer nname;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
static char names[32*206];
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen),
geteq_(char *, ftnlen);
extern integer ncpos_(char *, char *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int nthwd_(char *, integer *, char *, integer *,
ftnlen, ftnlen);
static char symbl[33];
static integer psize;
extern integer rtrim_(char *, ftnlen);
static logical checkd[200];
extern logical failed_(void);
static char alphab[32];
extern /* Subroutine */ int getdel_(char *, ftnlen);
extern logical matchm_(char *, char *, char *, char *, char *, char *,
ftnlen, ftnlen, ftnlen, ftnlen, ftnlen, ftnlen);
static char buffer[256*52];
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen),
lastnb_(char *, ftnlen);
static logical gotone;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), repsub_(char *, integer *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen);
static char equote[1];
extern /* Subroutine */ int setmsg_(char *, ftnlen);
static char resvrd[32*12], symbol[33], pattrn[80];
static integer nxtchr;
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen), rdstmn_(char *, char *, char *, ftnlen, ftnlen, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int sbget_1__(char *, char *, integer *, char *,
char *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), nthuqw_(char *
, integer *, char *, char *, integer *, ftnlen, ftnlen, ftnlen);
static char myprmt[80];
extern /* Subroutine */ int sbrem_1__(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
static integer lsttry;
extern /* Subroutine */ int sbset_1__(char *, char *, char *, integer *,
char *, ftnlen, ftnlen, ftnlen, ftnlen);
static char def[1024];
static integer loc;
static char key[32];
static logical new__;
extern /* Subroutine */ int sbinit_1__(integer *, integer *, integer *,
char *, integer *, char *, ftnlen, ftnlen);
/* $ Abstract */
/* Translate the symbols in an input string. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Keywords */
/* PARSE */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* INPUT I Input string containing symbols to be translated. */
/* OUTPUT O Output string, with all symbols translated. */
/* $ Detailed_Input */
/* INPUT is the input string to be translated. INPUT may contain */
/* any number of known symbols. */
/* $ Detailed_Output */
/* OUTPUT is the translation of the input string. The first */
/* of the symbols in INPUT will have been translated. */
/* When INPUT is either a DEFINE or an UNDEFINE command, */
/* OUTPUT is blank. */
/* OUTPUT may overwrite INPUT. */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* None. */
/* $ Exceptions */
/* The following exceptions are detected by this routine: */
/* 1) Attempt to define or undefine a symbol that does */
/* not begin with a letter. */
/* 2) Attempt to define or undefine a symbol that ends with */
/* a question mark '?' . */
/* 3) Failure to specify a symbol to define or undefine. */
/* 4) Attempting to define a reserved word. The reserved */
/* words are: */
/* 'START' */
/* 'STOP' */
/* 'EXIT' */
/* 'INQUIRE' */
/* 'SHOW' */
/* 'DEFINE' */
/* 'SHOW' */
/* 'UNDEFINE' */
/* 'HELP' */
/* In all of the above cases OUTPUT is set to blank and TRAN to */
/* FALSE. No new symbol is placed in the table of symbol */
/* definitions. */
/* In all of these cases the error BAD_SYMBOL_SPC is signalled. */
/* 5) Recursive symbol definitions are detected and disallowed. */
/* A long error message diagnosing the problem is set and */
/* the error RECURSIVE_SYMBOL is signalled. */
/* 5) Overflow of the input command caused by symbol resolution. */
/* In this case the OUTPUT is left at the state it had reached */
/* prior to the overflow condition and TRAN is returned as */
/* FALSE. The error SYMBOL_OVERFLOW is signalled. */
/* $ Detailed_Description */
/* A new symbol may be defined with the DEFINE command. The */
/* syntax is: */
/* DEFINE <symbol> <definition> */
/* where <symbol> is a valid symbol name and <definition> is any */
/* valid definition. The DEFINE command, the symbol name, and the */
/* definition are delimited by blanks. */
/* When a symbol is defined, the symbol and definition are inserted */
/* into the symbol table. */
/* An existing symbol may be removed from the table with the */
/* UNDEFINE command. The syntax is: */
/* UNDEFINE <symbol> */
/* where <symbol> is the name of an existing symbol. The UNDEFINE */
/* command and the symbol name are delimited by blanks. */
/* If the input string does not contain a definition statement, */
/* STRANS searches the input string for potential symbol names. */
/* When a valid symbol is encountered, it is removed from the */
/* string and replaced by the corresponding definition. This */
/* continues until no untranslated symbols remain. */
/* $ Examples */
/* Suppose that we are given the following definitions: */
/* DEFINE BODIES PLANET AND SATS */
/* DEFINE EUROPA 502 */
/* DEFINE GANYMEDE 503 */
/* DEFINE IO 501 */
/* DEFINE JUPITER 599 */
/* DEFINE PLANET JUPITER */
/* DEFINE CALLISTO 504 */
/* DEFINE SATS IO EUROPA GANYMEDE CALLISTO */
/* Then the string 'BODIES AND SOULS' would translate, */
/* at various stages, to: */
/* 'PLANET AND SATS AND SOULS' */
/* 'JUPITER AND SATS AND SOULS' */
/* '599 AND SATS AND SOULS' */
/* '599 AND IO EUROPA GANYMEDE CALLISTO AND SOULS' */
/* '599 AND 501 EUROPA GANYMEDE CALLISTO AND SOULS' */
/* '599 AND 501 502 GANYMEDE CALLISTO AND SOULS' */
/* '599 AND 501 502 503 CALLISTO AND SOULS' */
/* '599 AND 501 502 503 504 AND SOULS' */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* I. M. Underwood (JPL) */
/* $ Version_and_Date */
/* Version 1.2.0 29-Aug-1996 (WLT) */
/* Fixed the error message for the case in which someone */
/* tries to create a symbol that is more than 32 characters */
/* in length. */
/* Version 1.1, 14-SEP-1995 */
/* Reference to unused variable WORD deleted. */
/* Version 1, 8-SEP-1986 */
/* -& */
/* SPICELIB Functions */
/* Other supporting functions */
/* The following parameters are used to define our table */
/* of symbol translations. */
/* Longest allowed symbol name is given by WDSIZE */
/* Maximum number of allowed symbols is MAXN */
/* The longest we expect any symbol to be is MAXL characters */
/* The average number of characters per symbol is AVGL */
/* Finally, here are the arrays used to hold the symbol translations. */
/* Here's the storage we need for the reserved words. */
switch(n__) {
case 1: goto L_sympat;
case 2: goto L_symget;
}
/* Set up all of the data structures and special strings in */
/* the first pass through the routine. */
if (return_()) {
return 0;
}
chkin_("STRAN", (ftnlen)5);
if (first) {
first = FALSE_;
vdim = 51;
psize = 804;
nname = 200;
sbinit_1__(&nname, &psize, &vdim, names, ptrs, buffer, (ftnlen)32, (
ftnlen)256);
s_copy(resvrd, "START", (ftnlen)32, (ftnlen)5);
s_copy(resvrd + 32, "STOP", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 64, "EXIT", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 96, "INQUIRE", (ftnlen)32, (ftnlen)7);
s_copy(resvrd + 128, "SHOW", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 160, "DEFINE", (ftnlen)32, (ftnlen)6);
s_copy(resvrd + 192, "SHOW", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 224, "UNDEFINE", (ftnlen)32, (ftnlen)8);
s_copy(resvrd + 256, "HELP", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 288, "RECALL", (ftnlen)32, (ftnlen)6);
s_copy(resvrd + 320, "DO", (ftnlen)32, (ftnlen)2);
s_copy(resvrd + 352, "EDIT", (ftnlen)32, (ftnlen)4);
s_copy(alphab, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", (ftnlen)32, (ftnlen)26);
}
/* Find out what the special marker character is for suppressing */
/* symbol evaluation. */
geteq_(equote, (ftnlen)1);
/* Is this a definition statement? The presence of DEFINE, INQUIRE or */
/* UNDEFINE at the beginning of the string will confirm this. */
nthwd_(input, &c__1, key, &loc, input_len, (ftnlen)32);
ucase_(key, key, (ftnlen)32, (ftnlen)32);
/* The keyword must be followed by a valid symbol name. */
if (s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0 || s_cmp(key, "INQU"
"IRE", (ftnlen)32, (ftnlen)7) == 0 || s_cmp(key, "UNDEFINE", (
ftnlen)32, (ftnlen)8) == 0) {
nthwd_(input, &c__2, symbl, &loc, input_len, (ftnlen)33);
ucase_(symbl, symbol, (ftnlen)33, (ftnlen)33);
l = rtrim_(symbol, (ftnlen)33);
if (s_cmp(symbol, " ", (ftnlen)33, (ftnlen)1) == 0) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
setmsg_("The \"#\" command must be followed by the name of the s"
"ymbol that you want to #. ", (ftnlen)79);
errch_("#", key, (ftnlen)1, (ftnlen)32);
lcase_(key, key, (ftnlen)32, (ftnlen)32);
errch_("#", key, (ftnlen)1, (ftnlen)32);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (i_indx(alphab, symbol, (ftnlen)32, (ftnlen)1) == 0) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
lcase_(key, key, (ftnlen)32, (ftnlen)32);
setmsg_("You cannot # \"#\". Symbols must begin with a letter ("
"A-Z) ", (ftnlen)58);
errch_("#", key, (ftnlen)1, (ftnlen)32);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (l > 32) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
lcase_(key, key, (ftnlen)32, (ftnlen)32);
setmsg_("You cannot # \"#...\". Symbols may not be longer than "
"32 characters in length.", (ftnlen)77);
errch_("#", key, (ftnlen)1, (ftnlen)32);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (*(unsigned char *)&symbol[l - 1] == '?') {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
lcase_(key, key, (ftnlen)32, (ftnlen)32);
setmsg_("You cannot # \"#\". Symbols may not end with a questio"
"n mark '?'. ", (ftnlen)65);
errch_("#", key, (ftnlen)1, (ftnlen)32);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if ((s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0 || s_cmp(
key, "INQUIRE", (ftnlen)32, (ftnlen)7) == 0) && isrchc_(
symbol, &c__12, resvrd, (ftnlen)33, (ftnlen)32) > 0) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
setmsg_("The word '#' is a reserved word. You may not redefine i"
"t. ", (ftnlen)58);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
}
}
if (s_cmp(key, "INQUIRE", (ftnlen)32, (ftnlen)7) == 0) {
/* First of all we, can only INQUIRE for symbol definitions */
/* if the program is not running in "batch" mode. */
if (batch_()) {
setmsg_("You've attempted to INQUIRE for the value of a symbol w"
"hile the program is running in \"batch\" mode. You can I"
"NQUIRE for a symbol value only if you are running in INT"
"ERACTIVE mode. ", (ftnlen)180);
sigerr_("WRONG_MODE", (ftnlen)10);
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* See if there is anything following the symbol that is */
/* to be defined. This will be used as our prompt value. */
/* Computing MAX */
i__3 = loc + l;
i__1 = loc + l, i__2 = ncpos_(input, " ", &i__3, input_len, (ftnlen)1)
;
nxtchr = max(i__1,i__2);
if (s_cmp(input + (nxtchr - 1), " ", input_len - (nxtchr - 1), (
ftnlen)1) != 0) {
s_copy(myprmt, input + (nxtchr - 1), (ftnlen)80, input_len - (
nxtchr - 1));
} else {
s_copy(myprmt, "Enter definition for", (ftnlen)80, (ftnlen)20);
suffix_(symbol, &c__1, myprmt, (ftnlen)33, (ftnlen)80);
suffix_(">", &c__1, myprmt, (ftnlen)1, (ftnlen)80);
}
getdel_(delim, (ftnlen)1);
rdstmn_(myprmt, delim, def, (ftnlen)80, (ftnlen)1, (ftnlen)1024);
sbset_1__(symbol, def, names, ptrs, buffer, (ftnlen)33, (ftnlen)1024,
(ftnlen)32, (ftnlen)256);
}
/* If this is a definition, and the symbol already exists in the */
/* symbol table, simply replace the existing definition with the */
/* string following the symbol name. If this is a new symbol, */
/* find the first symbol in the list that should follow the new */
/* one. Move the rest of the symbols back, and insert the new one */
/* at this point. */
if (s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0) {
/* Computing MAX */
i__3 = loc + l;
i__1 = loc + l, i__2 = ncpos_(input, " ", &i__3, input_len, (ftnlen)1)
;
nxtchr = max(i__1,i__2);
sbset_1__(symbol, input + (nxtchr - 1), names, ptrs, buffer, (ftnlen)
33, input_len - (nxtchr - 1), (ftnlen)32, (ftnlen)256);
}
if (s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0 || s_cmp(key, "INQU"
"IRE", (ftnlen)32, (ftnlen)7) == 0) {
if (failed_()) {
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* Now check for a recursive definition. To do this we have */
/* two parallel arrays to the NAMES array of the string */
/* buffer. The first array CHECK is used to indicate that */
/* in the course of the definition resolution of the */
/* new symbol, another symbol shows up. The second array */
/* called CHECKD indicats whether or not we have examined this */
/* existing symbol to see if contains the newly created */
/* symbol as part of its definition. */
/* So far we have nothing to check and haven't checked anything. */
n = cardc_(names, (ftnlen)32);
i__1 = n;
for (j = 1; j <= i__1; ++j) {
check[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge("check",
i__2, "stran_", (ftnlen)545)] = FALSE_;
checkd[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge("checkd",
i__2, "stran_", (ftnlen)546)] = FALSE_;
}
/* Find the location of our new symbol in the NAMES cell. */
place = isrchc_(symbol, &n, names + 192, (ftnlen)33, (ftnlen)32);
new__ = TRUE_;
while(new__) {
/* Look up the definition currently associated with */
/* the symbol we are checking. */
sbget_1__(symbol, names, ptrs, buffer, def, &i__, (ftnlen)33, (
ftnlen)32, (ftnlen)256, (ftnlen)1024);
j = 1;
nthuqw_(def, &j, equote, symbol, &loc, (ftnlen)1024, (ftnlen)1, (
ftnlen)33);
while(loc > 0) {
ucase_(symbol, symbol, (ftnlen)33, (ftnlen)33);
slot = isrchc_(symbol, &n, names + 192, (ftnlen)33, (ftnlen)
32);
/* If the word is located in the same place as the */
/* symbol we've just defined, we've introduced */
/* a recursive symbol definition. Remove this */
/* symbol and diagnose the error. */
if (slot == place) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
s_copy(symbol, names + (((i__1 = place + 5) < 206 && 0 <=
i__1 ? i__1 : s_rnge("names", i__1, "stran_", (
ftnlen)582)) << 5), (ftnlen)33, (ftnlen)32);
sbrem_1__(symbol, names, ptrs, buffer, (ftnlen)33, (
ftnlen)32, (ftnlen)256);
setmsg_("The definition of '#' is recursive. Recursivel"
"y defined symbol definitions are not allowed. ", (
ftnlen)93);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("RECURSIVE_SYMBOL", (ftnlen)16);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (slot > 0) {
/* Otherwise if this word is in the names list */
/* we may need to check this symbol to see if */
/* it lists the just defined symbol in its definition. */
if (checkd[(i__1 = slot - 1) < 200 && 0 <= i__1 ? i__1 :
s_rnge("checkd", i__1, "stran_", (ftnlen)602)]) {
check[(i__1 = slot - 1) < 200 && 0 <= i__1 ? i__1 :
s_rnge("check", i__1, "stran_", (ftnlen)603)]
= FALSE_;
} else {
check[(i__1 = slot - 1) < 200 && 0 <= i__1 ? i__1 :
s_rnge("check", i__1, "stran_", (ftnlen)605)]
= TRUE_;
}
}
/* Locate the next unquoted word in the definition. */
++j;
nthuqw_(def, &j, equote, symbol, &loc, (ftnlen)1024, (ftnlen)
1, (ftnlen)33);
}
/* See if there are any new items to check. If there */
/* are create a new value for symbol, and mark the */
/* new item as being checked. */
new__ = FALSE_;
i__1 = n;
for (j = 1; j <= i__1; ++j) {
if (check[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge(
"check", i__2, "stran_", (ftnlen)625)] && ! new__) {
s_copy(symbol, names + (((i__2 = j + 5) < 206 && 0 <=
i__2 ? i__2 : s_rnge("names", i__2, "stran_", (
ftnlen)626)) << 5), (ftnlen)33, (ftnlen)32);
check[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge(
"check", i__2, "stran_", (ftnlen)627)] = FALSE_;
checkd[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge(
"checkd", i__2, "stran_", (ftnlen)628)] = TRUE_;
new__ = TRUE_;
}
}
}
/* If we get to this point, we have a new non-recursively */
/* defined symbol. */
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* If this is a deletion, and the symbol already exists in the */
/* symbol table, simply move the symbols that follow toward the */
/* front of the table. */
if (s_cmp(key, "UNDEFINE", (ftnlen)32, (ftnlen)8) == 0) {
sbrem_1__(symbol, names, ptrs, buffer, (ftnlen)33, (ftnlen)32, (
ftnlen)256);
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* This is not a definition statement. Look for potential symbols. */
/* Try to resolve the first symbol in the string by substituting the */
/* corresponding definition for the existing symbol. */
s_copy(output, input, output_len, input_len);
*tran = FALSE_;
j = 1;
nthuqw_(output, &j, equote, symbol, &loc, output_len, (ftnlen)1, (ftnlen)
33);
while(! (*tran) && s_cmp(symbol, " ", (ftnlen)33, (ftnlen)1) != 0) {
ucase_(symbol, symbol, (ftnlen)33, (ftnlen)33);
sbget_1__(symbol, names, ptrs, buffer, def, &i__, (ftnlen)33, (ftnlen)
32, (ftnlen)256, (ftnlen)1024);
if (i__ > 0) {
lsym = lastnb_(symbol, (ftnlen)33);
ldef = lastnb_(def, (ftnlen)1024) + 1;
lout = lastnb_(output, output_len);
leno = i_len(output, output_len);
if (lout - lsym + ldef > leno) {
*tran = FALSE_;
setmsg_("As a result of attempting to resolve the symbols in"
" the input command, the command has overflowed the a"
"llocated memory. This is may be due to unintentional"
"ly using symbols that you had not intended to use. "
"You may protect portions of your string from symbol "
"evaluation by enclosing that portion of your string "
"between the character # as in 'DO #THIS PART WITHOUT"
" SYMBOLS#' . ", (ftnlen)376);
errch_("#", equote, (ftnlen)1, (ftnlen)1);
errch_("#", equote, (ftnlen)1, (ftnlen)1);
errch_("#", equote, (ftnlen)1, (ftnlen)1);
sigerr_("SYMBOL_OVERFLOW", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
}
i__1 = loc + lsym - 1;
repsub_(output, &loc, &i__1, def, output, output_len, ldef,
output_len);
*tran = TRUE_;
} else {
++j;
}
nthuqw_(output, &j, equote, symbol, &loc, output_len, (ftnlen)1, (
ftnlen)33);
}
chkout_("STRAN", (ftnlen)5);
return 0;
/* The following entry point allows us to set up a search */
/* of defined symbols that match a wild-card pattern. It must */
/* be called prior to getting any symbol definitions. */
L_sympat:
lsttry = 0;
s_copy(pattrn, input, (ftnlen)80, input_len);
return 0;
/* The following entry point fetches the next symbol and its */
/* definition for the next SYMBOL whose name */
/* matches a previously supplied template via the entry point */
/* above --- SYMPAT. */
/* If there is no matching symbol, we get back blanks. Note */
/* that no translation of the definition is performed. */
L_symget:
s_copy(input, " ", input_len, (ftnlen)1);
s_copy(output, " ", output_len, (ftnlen)1);
n = cardc_(names, (ftnlen)32);
while(lsttry < n) {
++lsttry;
gotone = matchm_(names + (((i__1 = lsttry + 5) < 206 && 0 <= i__1 ?
i__1 : s_rnge("names", i__1, "stran_", (ftnlen)767)) << 5),
pattrn, "*", "%", "~", "|", (ftnlen)32, (ftnlen)80, (ftnlen)1,
(ftnlen)1, (ftnlen)1, (ftnlen)1);
if (gotone) {
s_copy(symbol, names + (((i__1 = lsttry + 5) < 206 && 0 <= i__1 ?
i__1 : s_rnge("names", i__1, "stran_", (ftnlen)771)) << 5)
, (ftnlen)33, (ftnlen)32);
s_copy(input, names + (((i__1 = lsttry + 5) < 206 && 0 <= i__1 ?
i__1 : s_rnge("names", i__1, "stran_", (ftnlen)772)) << 5)
, input_len, (ftnlen)32);
sbget_1__(symbol, names, ptrs, buffer, output, &i__, (ftnlen)33, (
ftnlen)32, (ftnlen)256, output_len);
return 0;
}
}
return 0;
} /* stran_ */
/* $Procedure 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 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 GETFAT ( Get file architecture and type ) */
/* Subroutine */ int getfat_(char *file, char *arch, char *kertyp, ftnlen
file_len, ftnlen arch_len, ftnlen kertyp_len)
{
/* System generated locals */
integer i__1;
cilist ci__1;
olist o__1;
cllist cl__1;
inlist ioin__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen), f_inqu(inlist *), s_rnge(
char *, integer, char *, integer), f_open(olist *), s_rdue(cilist
*), do_uio(integer *, char *, ftnlen), e_rdue(void), f_clos(
cllist *), s_rsfe(cilist *), do_fio(integer *, char *, ftnlen),
e_rsfe(void);
/* Local variables */
integer unit;
extern /* Subroutine */ int zzddhfnh_(char *, integer *, logical *,
ftnlen), zzddhgsd_(char *, integer *, char *, ftnlen, ftnlen),
zzddhnfo_(integer *, char *, integer *, integer *, integer *,
logical *, ftnlen), zzddhhlu_(integer *, char *, logical *,
integer *, ftnlen);
integer i__;
extern integer cardi_(integer *);
char fname[255];
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen);
integer which;
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen);
logical found, exist;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen),
idw2at_(char *, char *, char *, ftnlen, ftnlen, ftnlen);
integer handle;
extern /* Subroutine */ int dafcls_(integer *);
char filarc[32];
extern /* Subroutine */ int dashof_(integer *);
integer intbff;
logical opened;
extern /* Subroutine */ int dafopr_(char *, integer *, ftnlen);
integer intarc;
extern /* Subroutine */ int dashlu_(integer *, integer *);
char idword[12];
integer intamn, number;
logical diropn, notdas;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), getlun_(integer *), setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen), ssizei_(
integer *, integer *), nextwd_(char *, char *, char *, ftnlen,
ftnlen, ftnlen);
char tmpwrd[12];
extern logical return_(void);
integer myunit, handles[106];
extern /* Subroutine */ int zzckspk_(integer *, char *, ftnlen);
/* Fortran I/O blocks */
static cilist io___19 = { 1, 0, 1, 0, 1 };
/* $ Abstract */
/* Determine the architecture and type of SPICE kernels. */
/* $ 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 */
/* KERNEL */
/* UTILITY */
/* $ 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 */
/* -------- --- -------------------------------------------------- */
/* FILE I The name of a file to be examined. */
/* ARCH O The architecture of the kernel file. */
/* KERTYP O The type of the kernel file. */
/* $ Detailed_Input */
/* FILE is the name of a SPICE kernel file whose architecture */
/* and type are desired. */
/* $ Detailed_Output */
/* ARCH is the file architecture of the SPICE kernel file */
/* specified be FILE. If the architecture cannot be */
/* determined or is not recognized the value '?' is */
/* returned. */
/* Architectures currently recognized are: */
/* DAF - The file is based on the DAF architecture. */
/* DAS - The file is based on the DAS architecture. */
/* XFR - The file is in a SPICE transfer file format. */
/* DEC - The file is an old SPICE decimal text file. */
/* ASC -- An ASCII text file. */
/* KPL -- Kernel Pool File (i.e., a text kernel) */
/* TXT -- An ASCII text file. */
/* TE1 -- Text E-Kernel type 1. */
/* ? - The architecture could not be determined. */
/* This variable must be at least 3 characters long. */
/* KERTYP is the type of the SPICE kernel file. If the type */
/* can not be determined the value '?' is returned. */
/* Kernel file types may be any sequence of at most four */
/* printing characters. NAIF has reserved for its use */
/* types which contain all upper case letters. */
/* A file type of 'PRE' means that the file is a */
/* pre-release file. */
/* This variable may be at most 4 characters long. */
/* $ Parameters */
/* RECL is the record length of a binary kernel file. Each */
/* record must be large enough to hold 128 double */
/* precision numbers. The units in which the record */
/* length must be specified vary from environment to */
/* environment. For example, VAX Fortran requires */
/* record lengths to be specified in longwords, */
/* where two longwords equal one double precision */
/* number. */
/* $ Exceptions */
/* 1) If the filename specified is blank, then the error */
/* SPICE(BLANKFILENAME) is signaled. */
/* 2) If any inquire on the filename specified by FILE fails for */
/* some reason, the error SPICE(INQUIREERROR) is signaled. */
/* 3) If the file specified by FILE does not exist, the error */
/* SPICE(FILENOTFOUND) is signaled. */
/* 4) If the file specified by FILE is already open but not through */
/* SPICE interfaces, the error SPICE(EXTERNALOPEN) is signaled. */
/* 5) If an attempt to open the file specified by FILE fails when */
/* this routine requires that it succeed, the error */
/* SPICE(FILEOPENFAILED) is signaled. */
/* 6) If an attempt to read the file specified by FILE fails when */
/* this routine requires that it succeed, the error */
/* SPICE(FILEREADFAILED) is signaled. */
/* 7) Routines in the call tree of this routine may trap and */
/* signal errors. */
/* 8) If the ID word in a DAF based kernel is NAIF/DAF, then the */
/* algorithm GETFAT uses to distinguish between CK and SPK */
/* kernels may result in an indeterminate KERTYP if the SPK or */
/* CK files have invalid first segments. */
/* $ Files */
/* The SPICE kernel file specified by FILE is examined by this */
/* routine to determine its architecture and type. If the file */
/* named by FILE is not connected to a logical unit or loaded */
/* in the handle manager, this routine will OPEN and CLOSE it. */
/* $ Particulars */
/* This subroutine is a support utility routine that determines the */
/* architecture and type of a SPICE kernel file. */
/* $ Examples */
/* Suppose you wish to write a single routine for loading binary */
/* kernels. You can use this routine to determine the type of the */
/* file and then pass the file to the appropriate low level file */
/* loader to handle the actual loading of the file. */
/* CALL GETFAT ( FILE, ARCH, KERTYP ) */
/* IF ( KERTYP .EQ. 'SPK' ) THEN */
/* CALL SPKLEF ( FILE, HANDLE ) */
/* ELSE IF ( KERTYP .EQ. 'CK' ) THEN */
/* CALL CKLPF ( FILE, HANDLE ) */
/* ELSE IF ( KERTYP .EQ. 'EK' ) THEN */
/* CALL EKLEF ( FILE, HANDLE ) */
/* ELSE */
/* WRITE (*,*) 'The file could not be identified as a known' */
/* WRITE (*,*) 'kernel type. Did you load the wrong file' */
/* WRITE (*,*) 'by mistake?' */
/* END IF */
/* $ Restrictions */
/* 1) In order to properly determine the type of DAF based binary */
/* kernels, the routine requires that their first segments and */
/* the meta data necessary to address them are valid. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* F.S. Turner (JPL) */
/* E.D. Wright (JPL) */
/* $ Version */
/* - SPICELIB Version 4.25.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 4.24.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 4.23.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 4.22.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.21.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 4.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 4.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 4.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 4.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 4.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 4.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 4.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 4.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 4.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 4.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 4.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 4.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 4.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 4.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 4.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 4.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 4.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 4.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 4.0.2, 24-APR-2003 (EDW) */
/* Added MAC-OSX-F77 to the list of platforms */
/* that require READONLY to read write protected */
/* kernels. */
/* - SPICELIB Version 4.0.1, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 4.0.0, 22-AUG-2001 (WLT) (FST) (EDW) */
/* Added code so that the architecture and type of open binary */
/* SPICE kernels can be determined. */
/* Added exception for MACPPC_C (CodeWarrior Mac classic). */
/* Reduced RECL value to 12 to prevent expression of */
/* the fseek bug. */
/* - SPICELIB Version 3.2.0, 06-DEC-1999 (WLT) */
/* The heuristics for distinguishing between CK and SPK have */
/* been enhanced so that the routine is no longer requires */
/* that TICKS in C-kernels be positive or integral. */
/* - SPICELIB Version 3.1.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 3.1.3, 22-SEP-1999 (NJB) */
/* CSPICE environments were added. Some typos were corrected. */
/* - SPICELIB Version 3.1.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 3.1.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 3.1.0, 11-FEB-1999 (FST) */
/* Added an integrality check to Test 3. If LASTDP is not */
/* an integral value, then GETFAT simply returns KERTYP = '?', */
/* since it is of an indeterminate type. */
/* - SPICELIB Version 3.0.0, 07-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 2.0.0, 19-DEC-1995 (KRG) */
/* Added several new features to the subroutine: */
/* - Error handling has been enhanced. */
/* - Several new file architectures have been added. */
/* Removed the mention of 1000 characters as a candidate for the */
/* record length of a file. */
/* Added the exception for a blank filename to the header. The */
/* error is signalled, but it was not listed in the header. */
/* Added IOSTAT values to the appropriate error messages. */
/* Non-printing characters are replaced with blanks in the ID */
/* word when it is read. This deals with the case where a */
/* platform allows a text file to be opened as an unformatted */
/* file and the ID word does not completely fill 8 characters. */
/* - SPICELIB Version 1.4.0, 5-JAN-1995 (HAN) */
/* Removed ENV11 since it is now the same as ENV2. */
/* Removed ENV10 since it is the same as the VAX environment. */
/* - SPICELIB Version 1.3.0, 30-AUG-1994 (HAN) */
/* Added two new environments, DEC Alpha/OpenVMS and */
/* Sun/Solaris, to the source master file. */
/* - SPICELIB Version 1.2.0, 25-MAR-1994 (HAN) */
/* Added two new environments, DEC Alpha/OpenVMS and */
/* Sun/Solaris, to the source master file. */
/* - SPICELIB Version 1.1.0, 25-MAR-1994 (HAN) */
/* Modified master source code file to use READONLY on platforms */
/* that support it. Also, changed some local declaration comment */
/* lines to match the standard NAIF template. */
/* - SPICELIB Version 1.0.0, 24-JUL-1993 (WLT) (HAN) (KRG) */
/* -& */
/* $ Index_Entries */
/* determine the architecture and type of a kernel file */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 4.0.0, 22-AUG-2001 (WLT) (FST) */
/* Added code so that the architecture and type of open binary */
/* SPICE kernels can be determined. This uses the new DAF/DAS */
/* handle manager as well as examination of handles of open DAS */
/* files. Currently the handle manager deals only with DAF */
/* files. This routine should be updated again when the DAS */
/* system is integrated with the handle manager. */
/* Some slight changes were required to support ZZDDHFNH on */
/* the VAX environment. This resulted in the addition of */
/* the logical USEFNH that is set to true in most */
/* environments, and never used again other than to allow */
/* the invocation of the ZZDDHFNH module. */
/* - SPICELIB Version 2.0.0, 19-DEC-1995 (KRG) */
/* Added several new features to the subroutine: */
/* - Error handling has been enhanced. */
/* - Several new file architectures have been added. */
/* Removed the mention of 1000 characters as a candidate for the */
/* record length of a file. It seems unlikely that we will */
/* encounter an environment where 1000 characters of storage is */
/* larger than the storage necessary for 128 double precision */
/* numbers; typically there are 8 characters per double precision */
/* number, yeilding 1024 characters. */
/* Added the exception for a blank filename to the header. The */
/* error is signalled, but it was not listed in the header. */
/* Added IOSTAT values to the appropriate error messages. */
/* Non-printing characters are replaced with blanks in the ID */
/* word when it is read. This deals with the case where a */
/* platform allows a text file to be opened as an unformatted */
/* file and the ID word does not completely fill 8 characters. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Set the length of a SPICE kernel file ID word. */
/* Set minimum and maximum values for the range of ASCII printing */
/* characters. */
/* Local Variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("GETFAT", (ftnlen)6);
}
/* Initialize the temporary storage variables that we use. */
s_copy(idword, " ", (ftnlen)12, (ftnlen)1);
/* If the filename we have is blank, signal an error and return. */
if (s_cmp(file, " ", file_len, (ftnlen)1) == 0) {
setmsg_("The file name is blank.", (ftnlen)23);
sigerr_("SPICE(BLANKFILENAME)", (ftnlen)20);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* See if this is a binary file that is currently open */
/* within the SPICE binary file management subsystem. At */
/* the moment, as far as we know, the file is not opened. */
opened = FALSE_;
zzddhfnh_(file, &handle, &found, file_len);
if (found) {
/* If the file was recognized, we need to get the unit number */
/* associated with it. */
zzddhnfo_(&handle, fname, &intarc, &intbff, &intamn, &found, (ftnlen)
255);
/* Translate the architecture ID to a string and retrieve the */
/* logical unit to use with this file. */
zzddhgsd_("ARCH", &intarc, filarc, (ftnlen)4, (ftnlen)32);
zzddhhlu_(&handle, filarc, &c_false, &number, (ftnlen)32);
opened = TRUE_;
} else {
/* We'll do a bit of inquiring before we try opening anything. */
ioin__1.inerr = 1;
ioin__1.infilen = file_len;
ioin__1.infile = file;
ioin__1.inex = ∃
ioin__1.inopen = &opened;
ioin__1.innum = 0;
ioin__1.innamed = 0;
ioin__1.inname = 0;
ioin__1.inacc = 0;
ioin__1.inseq = 0;
ioin__1.indir = 0;
ioin__1.infmt = 0;
ioin__1.inform = 0;
ioin__1.inunf = 0;
ioin__1.inrecl = 0;
ioin__1.innrec = 0;
ioin__1.inblank = 0;
iostat = f_inqu(&ioin__1);
/* Not too likely, but if the INQUIRE statement fails... */
if (iostat != 0) {
setmsg_("IOSTAT error in INQUIRE statement. IOSTAT = #.", (ftnlen)
46);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(INQUIREERROR)", (ftnlen)19);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* Note: the following two tests MUST be performed in the order */
/* in which they appear, since in some environments files that do */
/* not exist are considered to be open. */
if (! exist) {
setmsg_("The kernel file '#' does not exist.", (ftnlen)35);
errch_("#", file, (ftnlen)1, file_len);
sigerr_("SPICE(FILENOTFOUND)", (ftnlen)19);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* If the file is already open, it may be a DAS file. */
if (opened) {
/* At the moment, the handle manager doesn't manage DAS */
/* handles. As a result we need to treat the case of an open */
/* DAS separately. When the Handle Manager is hooked in with */
/* DAS as well as DAF, we should remove the block below. */
/* =================================================== */
/* DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS */
/* vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv */
/* This file may or may not be a DAS file. Until we */
/* have determined otherwise, we assume it is not */
/* a DAS file. */
notdas = TRUE_;
ioin__1.inerr = 1;
ioin__1.infilen = file_len;
ioin__1.infile = file;
ioin__1.inex = 0;
ioin__1.inopen = 0;
ioin__1.innum = &unit;
ioin__1.innamed = 0;
ioin__1.inname = 0;
ioin__1.inacc = 0;
ioin__1.inseq = 0;
ioin__1.indir = 0;
ioin__1.infmt = 0;
ioin__1.inform = 0;
ioin__1.inunf = 0;
ioin__1.inrecl = 0;
ioin__1.innrec = 0;
ioin__1.inblank = 0;
iostat = f_inqu(&ioin__1);
if (iostat != 0) {
setmsg_("IOSTAT error in INQUIRE statement. IOSTAT = #.", (
ftnlen)46);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(INQUIREERROR)", (ftnlen)19);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* Get the set of handles of open DAS files. We will */
/* translate each of these handles to the associated */
/* logical unit. If the tranlation matches the result */
/* of the inquire, this must be a DAS file and we */
/* can proceed to determine the type. */
ssizei_(&c__100, handles);
dashof_(handles);
which = cardi_(handles);
while(which > 0) {
dashlu_(&handles[(i__1 = which + 5) < 106 && 0 <= i__1 ? i__1
: s_rnge("handles", i__1, "getfat_", (ftnlen)654)], &
myunit);
if (unit == myunit) {
number = myunit;
which = 0;
notdas = FALSE_;
} else {
--which;
}
}
/* If we reach this point and do not have a DAS, there */
/* is no point in going on. The user has opened this */
/* file outside the SPICE system. We shall not attempt */
/* to determine its type. */
if (notdas) {
setmsg_("The file '#' is already open.", (ftnlen)29);
errch_("#", file, (ftnlen)1, file_len);
sigerr_("SPICE(EXTERNALOPEN)", (ftnlen)19);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ */
/* DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS */
/* =================================================== */
}
}
/* Open the file with a record length of RECL (the length of the */
/* DAF and DAS records). We assume, for now, that opening the file as */
/* a direct access file will work. */
diropn = TRUE_;
/* If the file is not already open (probably the case that */
/* happens most frequently) we try opening it for direct access */
/* and see if we can locate the idword. */
if (! opened) {
getlun_(&number);
o__1.oerr = 1;
o__1.ounit = number;
o__1.ofnmlen = file_len;
o__1.ofnm = file;
o__1.orl = 1024;
o__1.osta = "OLD";
o__1.oacc = "DIRECT";
o__1.ofm = 0;
o__1.oblnk = 0;
iostat = f_open(&o__1);
/* If we had trouble opening the file, try opening it as a */
/* sequential file. */
if (iostat != 0) {
diropn = FALSE_;
o__1.oerr = 1;
o__1.ounit = number;
o__1.ofnmlen = file_len;
o__1.ofnm = file;
o__1.orl = 0;
o__1.osta = "OLD";
o__1.oacc = "SEQUENTIAL";
o__1.ofm = 0;
o__1.oblnk = 0;
iostat = f_open(&o__1);
/* If we still have problems opening the file, we don't have a */
/* clue about the file architecture and type. */
if (iostat != 0) {
s_copy(arch, "?", arch_len, (ftnlen)1);
s_copy(kertyp, "?", kertyp_len, (ftnlen)1);
setmsg_("Attempt to open the file '#' failed. IOSTAT = #.", (
ftnlen)48);
errch_("#", file, (ftnlen)1, file_len);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEOPENFAILED)", (ftnlen)21);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
}
}
/* We opened the file successfully, so let's try to read from the */
/* file. We need to be sure to use the correct form of the read */
/* statement, depending on whether the file was opened with direct */
/* acces or sequential access. */
if (diropn) {
io___19.ciunit = number;
iostat = s_rdue(&io___19);
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, tmpwrd, (ftnlen)12);
if (iostat != 0) {
goto L100001;
}
iostat = e_rdue();
L100001:
/* If we couldn't read from the file as a direct access file with */
/* a fixed record length, then try to open the file as a */
/* sequential file and read from it. */
if (iostat != 0) {
if (opened) {
/* Something has gone wrong here. The file was opened */
/* as either a DAF or DAS prior to the call to GETFAT. */
/* We retrieved the unit number maintained by the */
/* underlying binary file management system, but we */
/* were unable to read the file as direct access. */
/* There's nothing we can do but abandon our quest to */
/* determine the type of the file. */
setmsg_("The file '#' is opened as a binary SPICE kernel. B"
"ut it cannot be read using a direct access read. The"
" value of IOSTAT returned by the attempted READ is #"
". ", (ftnlen)157);
errch_("#", file, (ftnlen)1, file_len);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* If we reach this point, the file was opened locally */
/* as a direct access file. We could not read it that */
/* way, so we'll try using a sequential read. However, */
/* we first need to close the file and then reopen it */
/* for sequential reading. */
cl__1.cerr = 0;
cl__1.cunit = number;
cl__1.csta = 0;
f_clos(&cl__1);
o__1.oerr = 1;
o__1.ounit = number;
o__1.ofnmlen = file_len;
o__1.ofnm = file;
o__1.orl = 0;
o__1.osta = "OLD";
o__1.oacc = "SEQUENTIAL";
o__1.ofm = 0;
o__1.oblnk = 0;
iostat = f_open(&o__1);
/* If we could not open the file, we don't have a clue about */
/* the file architecture and type. */
if (iostat != 0) {
s_copy(arch, "?", arch_len, (ftnlen)1);
s_copy(kertyp, "?", kertyp_len, (ftnlen)1);
setmsg_("Attempt to open the file '#' failed. IOSTAT = #.", (
ftnlen)48);
errch_("#", file, (ftnlen)1, file_len);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEOPENFAILED)", (ftnlen)21);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* Try to read from the file. */
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = number;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100002;
}
iostat = do_fio(&c__1, tmpwrd, (ftnlen)12);
if (iostat != 0) {
goto L100002;
}
iostat = e_rsfe();
L100002:
;
}
} else {
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = number;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100003;
}
iostat = do_fio(&c__1, tmpwrd, (ftnlen)12);
if (iostat != 0) {
goto L100003;
}
iostat = e_rsfe();
L100003:
;
}
/* If we had an error while reading, we don't recognize this file. */
if (iostat != 0) {
s_copy(arch, "?", arch_len, (ftnlen)1);
s_copy(kertyp, "?", kertyp_len, (ftnlen)1);
cl__1.cerr = 0;
cl__1.cunit = number;
cl__1.csta = 0;
f_clos(&cl__1);
setmsg_("Attempt to read from file '#' failed. IOSTAT = #.", (ftnlen)
49);
errch_("#", file, (ftnlen)1, file_len);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* Close the file (if we opened it here), as we do not need it */
/* to be open any more. */
if (! opened) {
cl__1.cerr = 0;
cl__1.cunit = number;
cl__1.csta = 0;
f_clos(&cl__1);
}
/* At this point, we have a candidate for an ID word. To avoid */
/* difficulties with Fortran I/O and other things, we will now */
/* replace any non printing ASCII characters with blanks. */
for (i__ = 1; i__ <= 12; ++i__) {
if (*(unsigned char *)&tmpwrd[i__ - 1] < 32 || *(unsigned char *)&
tmpwrd[i__ - 1] > 126) {
*(unsigned char *)&tmpwrd[i__ - 1] = ' ';
}
}
/* Identify the architecture and type, if we can. */
ljust_(tmpwrd, tmpwrd, (ftnlen)12, (ftnlen)12);
ucase_(tmpwrd, tmpwrd, (ftnlen)12, (ftnlen)12);
nextwd_(tmpwrd, idword, tmpwrd, (ftnlen)12, (ftnlen)12, (ftnlen)12);
if (s_cmp(idword, "DAFETF", (ftnlen)12, (ftnlen)6) == 0) {
/* We have a DAF encoded transfer file. */
s_copy(arch, "XFR", arch_len, (ftnlen)3);
s_copy(kertyp, "DAF", kertyp_len, (ftnlen)3);
} else if (s_cmp(idword, "DASETF", (ftnlen)12, (ftnlen)6) == 0) {
/* We have a DAS encoded transfer file. */
s_copy(arch, "XFR", arch_len, (ftnlen)3);
s_copy(kertyp, "DAS", kertyp_len, (ftnlen)3);
} else if (s_cmp(idword, "'NAIF/DAF'", (ftnlen)10, (ftnlen)10) == 0) {
/* We have an old DAF decimal text file. */
s_copy(arch, "DEC", arch_len, (ftnlen)3);
s_copy(kertyp, "DAF", kertyp_len, (ftnlen)3);
} else if (s_cmp(idword, "NAIF/DAS", (ftnlen)8, (ftnlen)8) == 0) {
/* We have a pre release DAS binary file. */
s_copy(arch, "DAS", arch_len, (ftnlen)3);
s_copy(kertyp, "PRE", kertyp_len, (ftnlen)3);
} else {
/* Get the architecture and type from the ID word, if we can. */
idw2at_(idword, arch, kertyp, (ftnlen)8, arch_len, kertyp_len);
}
/* If the architecture is DAF and the type is unknown, '?', then we */
/* have either an SPK file, a CK file, or something we don't */
/* understand. Let's check it out. */
if (s_cmp(arch, "DAF", arch_len, (ftnlen)3) == 0 && s_cmp(kertyp, "?",
kertyp_len, (ftnlen)1) == 0) {
/* We have a DAF file and we do not know what the type is. This */
/* situation can occur for older SPK and CK files, before the ID */
/* word was used to store type information. */
/* We use Bill's (WLT'S) magic heuristics to determine the type */
/* of the file. */
/* Open the file and pass the handle to the private routine */
/* that deals with the dirty work. */
dafopr_(file, &handle, file_len);
zzckspk_(&handle, kertyp, kertyp_len);
dafcls_(&handle);
}
chkout_("GETFAT", (ftnlen)6);
return 0;
} /* getfat_ */
/* $Procedure TKFRAM (Text kernel frame transformation ) */
/* Subroutine */ int tkfram_(integer *id, doublereal *rot, integer *frame,
logical *found)
{
/* Initialized data */
static integer at = 0;
static logical first = TRUE_;
/* System generated locals */
address a__1[2];
integer i__1, i__2[2], i__3;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static char name__[32];
static integer tail;
static char spec[32], item[32*14];
static integer idnt[1], axes[3];
static logical full;
static integer pool[52] /* was [2][26] */;
extern doublereal vdot_(doublereal *, doublereal *);
static char type__[1];
static doublereal qtmp[4];
extern /* Subroutine */ int eul2m_(doublereal *, doublereal *, doublereal
*, integer *, integer *, integer *, doublereal *);
static integer i__, n, r__;
static doublereal buffd[180] /* was [9][20] */;
static integer buffi[20] /* was [1][20] */, oldid;
extern /* Subroutine */ int chkin_(char *, ftnlen);
static char agent[32];
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen),
ident_(doublereal *), errch_(char *, char *, ftnlen, ftnlen);
static doublereal tempd;
extern /* Subroutine */ int moved_(doublereal *, integer *, doublereal *),
repmi_(char *, char *, integer *, char *, ftnlen, ftnlen, ftnlen)
, vhatg_(doublereal *, integer *, doublereal *);
extern integer lnktl_(integer *, integer *);
static char idstr[32];
extern integer rtrim_(char *, ftnlen);
static char versn[8], units[32];
static integer ar;
extern logical failed_(void), badkpv_(char *, char *, char *, integer *,
integer *, char *, ftnlen, ftnlen, ftnlen, ftnlen);
static char frname[32];
static doublereal angles[3];
static char oldagt[32];
static logical buffrd;
extern /* Subroutine */ int locati_(integer *, integer *, integer *,
integer *, integer *, logical *), frmnam_(integer *, char *,
ftnlen), namfrm_(char *, integer *, ftnlen);
static logical update;
static char altnat[32];
extern /* Subroutine */ int lnkini_(integer *, integer *);
extern integer lnknfn_(integer *);
static integer idents[20] /* was [1][20] */;
extern /* Subroutine */ int gcpool_(char *, integer *, integer *, integer
*, char *, logical *, ftnlen, ftnlen), gdpool_(char *, integer *,
integer *, integer *, doublereal *, logical *, ftnlen), sigerr_(
char *, ftnlen), gipool_(char *, integer *, integer *, integer *,
integer *, logical *, ftnlen), chkout_(char *, ftnlen), sharpr_(
doublereal *), dtpool_(char *, logical *, integer *, char *,
ftnlen, ftnlen), setmsg_(char *, ftnlen);
static doublereal matrix[9] /* was [3][3] */;
extern /* Subroutine */ int cvpool_(char *, logical *, ftnlen), dwpool_(
char *, ftnlen), errint_(char *, integer *, ftnlen), vsclip_(
doublereal *, doublereal *);
static doublereal quatrn[4];
extern /* Subroutine */ int convrt_(doublereal *, char *, char *,
doublereal *, ftnlen, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int q2m_(doublereal *, doublereal *), intstr_(
integer *, char *, ftnlen), swpool_(char *, integer *, char *,
ftnlen, ftnlen);
static logical fnd;
static char alt[32*14];
/* $ Abstract */
/* This routine returns the rotation from the input frame */
/* specified by ID to the associated frame given by FRAME. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* FRAMES */
/* $ Keywords */
/* POINTING */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- ---------------------------------------------- */
/* ID I Class identification code for the instrument */
/* ROT O The rotation from ID to FRAME. */
/* FRAME O The integer code of some reference frame. */
/* FOUND O TRUE if the rotation could be determined. */
/* $ Detailed_Input */
/* ID The identification code used to specify an */
/* instrument in the SPICE system. */
/* $ Detailed_Output */
/* ROT is a rotation matrix that gives the transformation */
/* from the frame specified by ID to the frame */
/* specified by FRAME. */
/* FRAME is the id code of the frame used to define the */
/* orientation of the frame given by ID. ROT gives */
/* the transformation from the IF frame to */
/* the frame specified by FRAME. */
/* FOUND is a logical indicating whether or not a frame */
/* definition for frame ID was constructed from */
/* kernel pool data. If ROT and FRAME were constructed */
/* FOUND will be returned with the value TRUE. */
/* Otherwise it will be returned with the value FALSE. */
/* $ Parameters */
/* BUFSIZ is the number of rotation, frame id pairs that */
/* can have their instance data buffered for the */
/* sake of improving run-time performance. This */
/* value MUST be positive and should probably be */
/* at least 10. */
/* $ Exceptions */
/* 1) If some instance value associated with this frame */
/* cannot be located, or does not have the proper type */
/* or dimension, the error will be diagnosed by the */
/* routine BADKPV. In such a case FOUND will be set to .FALSE. */
/* 2) If the input ID has the value 0, the error */
/* SPICE(ZEROFRAMEID) will be signaled. FOUND will be set */
/* to FALSE. */
/* 3) If the name of the frame corresponding to ID cannot be */
/* determined, the error 'SPICE(INCOMPLETEFRAME)' is signaled. */
/* 4) If the frame given by ID is defined relative to a frame */
/* that is unrecognized, the error SPICE(BADFRAMESPEC) */
/* will be signaled. FOUND will be set to FALSE. */
/* 5) If the kernel pool specification for ID is not one of */
/* MATRIX, ANGLES, or QUATERNION, then the error */
/* SPICE(UNKNOWNFRAMESPEC) will be signaled. FOUND will be */
/* set to FALSE. */
/* $ Files */
/* This routine makes use of the loaded text kernels to */
/* determine the rotation from a constant offset frame */
/* to its defining frame. */
/* $ Particulars */
/* This routine is used to construct the rotation from some frame */
/* that is a constant rotation offset from some other reference */
/* frame. This rotation is derived from data stored in the kernel */
/* pool. */
/* It is considered to be an low level routine that */
/* will need to be called directly only by persons performing */
/* high volume processing. */
/* $ Examples */
/* This is intended to be used as a low level routine by */
/* the frame system software. However, you could use this */
/* routine to directly retrieve the rotation from an offset */
/* frame to its relative frame. One instance in which you */
/* might do this is if you have a properly specified topocentric */
/* frame for some site on earth and you wish to determine */
/* the geodetic latitude and longitude of the site. Here's how. */
/* Suppose the name of the topocentric frame is: 'MYTOPO'. */
/* First we get the id-code of the topocentric frame. */
/* CALL NAMFRM ( 'MYTOPO', FRCODE ) */
/* Next get the rotation from the topocentric frame to */
/* the bodyfixed frame. */
/* CALL TKFRAM ( FRCODE, ROT, FRAME, FOUND ) */
/* Make sure the topoframe is relative to one of the earth */
/* fixed frames. */
/* CALL FRMNAM( FRAME, TEST ) */
/* IF ( TEST .NE. 'IAU_EARTH' */
/* . .AND. TEST .NE. 'EARTH_FIXED' */
/* . .AND. TEST .NE. 'ITRF93' ) THEN */
/* WRITE (*,*) 'The frame MYTOPO does not appear to be ' */
/* WRITE (*,*) 'defined relative to an earth fixed frame.' */
/* STOP */
/* END IF */
/* Things look ok. Get the location of the Z-axis in the */
/* topocentric frame. */
/* Z(1) = ROT(1,3) */
/* Z(2) = ROT(2,3) */
/* Z(3) = ROT(3,3) */
/* Convert the Z vector to latitude longitude and radius. */
/* CALL RECLAT ( Z, LAT, LONG, RAD ) */
/* WRITE (*,*) 'The geodetic coordinates of the center of' */
/* WRITE (*,*) 'the topographic frame are: ' */
/* WRITE (*,*) */
/* WRITE (*,*) 'Latitude (deg): ', LAT *DPR() */
/* WRITE (*,*) 'Longitude (deg): ', LONG*DPR() */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 2.1.0, 23-APR-2009 (NJB) */
/* Bug fix: watch is deleted only for frames */
/* that are deleted from the buffer. */
/* - SPICELIB Version 2.0.0, 19-MAR-2009 (NJB) */
/* Bug fix: this routine now deletes watches set on */
/* kernel variables of frames that are discarded from */
/* the local buffering system. */
/* - SPICELIB Version 1.2.0, 09-SEP-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in CONVRT, UCRSS, VHATG and VSCL calls. */
/* - SPICELIB Version 1.1.0, 21-NOV-2001 (FST) */
/* Updated this routine to dump the buffer of frame ID codes */
/* it saves when it or one of the modules in its call tree signals */
/* an error. This fixes a bug where a frame's ID code is */
/* buffered, but the matrix and kernel pool watcher were not set */
/* properly. */
/* - SPICELIB Version 1.0.0, 18-NOV-1996 (WLT) */
/* -& */
/* $ Index_Entries */
/* Fetch the rotation and frame of a text kernel frame */
/* Fetch the rotation and frame of a constant offset frame */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.2.0, 09-SEP-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in CONVRT, UCRSS, VHATG and VSCL calls. */
/* -& */
/* Spicelib Functions */
/* Local Parameters */
/* Local Variables */
/* Saved variables */
/* Initial values */
/* Programmer's note: this routine makes use of the *implementation* */
/* of LOCATI. If that routine is changed, the logic this routine */
/* uses to locate buffered, old frame IDs may need to change as well. */
/* Before we even check in, if N is less than 1 we can */
/* just return. */
/* Perform any initializations that might be needed for this */
/* routine. */
if (first) {
first = FALSE_;
s_copy(versn, "1.0.0", (ftnlen)8, (ftnlen)5);
lnkini_(&c__20, pool);
}
/* Now do the standard SPICE error handling. Sure this is */
/* a bit unconventional, but nothing will be hurt by doing */
/* the stuff above first. */
if (return_()) {
return 0;
}
chkin_("TKFRAM", (ftnlen)6);
/* So far, we've not FOUND the rotation to the specified frame. */
*found = FALSE_;
/* Check the ID to make sure it is non-zero. */
if (*id == 0) {
lnkini_(&c__20, pool);
setmsg_("Frame identification codes are required to be non-zero. Yo"
"u've specified a frame with ID value zero. ", (ftnlen)102);
sigerr_("SPICE(ZEROFRAMEID)", (ftnlen)18);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* Find out whether our linked list pool is already full. */
/* We'll use this information later to decide whether we're */
/* going to have to delete a watcher. */
full = lnknfn_(pool) == 0;
if (full) {
/* If the input frame ID is not buffered, we'll need to */
/* overwrite an existing buffer entry. In this case */
/* the call to LOCATI we're about to make will overwrite */
/* the ID code in the slot we're about to use. We need */
/* this ID code, so extract it now while we have the */
/* opportunity. The old ID sits at the tail of the list */
/* whose head node is AT. */
tail = lnktl_(&at, pool);
oldid = idents[(i__1 = tail - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge(
"idents", i__1, "tkfram_", (ftnlen)413)];
/* Create the name of the agent associated with the old */
/* frame. */
s_copy(oldagt, "TKFRAME_#", (ftnlen)32, (ftnlen)9);
repmi_(oldagt, "#", &oldid, oldagt, (ftnlen)32, (ftnlen)1, (ftnlen)32)
;
}
/* Look up the address of the instance data. */
idnt[0] = *id;
locati_(idnt, &c__1, idents, pool, &at, &buffrd);
if (full && ! buffrd) {
/* Since the buffer is already full, we'll delete the watcher for */
/* the kernel variables associated with OLDID, since there's no */
/* longer a need for that watcher. */
/* First clear the update status of the old agent; DWPOOL won't */
/* delete an agent with a unchecked update. */
cvpool_(oldagt, &update, (ftnlen)32);
dwpool_(oldagt, (ftnlen)32);
}
/* Until we have better information we put the identity matrix */
/* into the output rotation and set FRAME to zero. */
ident_(rot);
*frame = 0;
/* If we have to look up the data for our frame, we do */
/* it now and perform any conversions and computations that */
/* will be needed when it's time to convert coordinates to */
/* directions. */
/* Construct the name of the agent associated with the */
/* requested frame. (Each frame has its own agent). */
intstr_(id, idstr, (ftnlen)32);
frmnam_(id, frname, (ftnlen)32);
if (s_cmp(frname, " ", (ftnlen)32, (ftnlen)1) == 0) {
lnkini_(&c__20, pool);
setmsg_("The Text Kernel (TK) frame with id-code # does not have a r"
"ecognized name. ", (ftnlen)75);
errint_("#", id, (ftnlen)1);
sigerr_("SPICE(INCOMPLETFRAME)", (ftnlen)21);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* Writing concatenation */
i__2[0] = 8, a__1[0] = "TKFRAME_";
i__2[1] = 32, a__1[1] = idstr;
s_cat(agent, a__1, i__2, &c__2, (ftnlen)32);
r__ = rtrim_(agent, (ftnlen)32);
/* Writing concatenation */
i__2[0] = 8, a__1[0] = "TKFRAME_";
i__2[1] = 32, a__1[1] = frname;
s_cat(altnat, a__1, i__2, &c__2, (ftnlen)32);
ar = rtrim_(altnat, (ftnlen)32);
/* If the frame is buffered, we check the kernel pool to */
/* see if there has been an update to this frame. */
if (buffrd) {
cvpool_(agent, &update, r__);
} else {
/* If the frame is not buffered we definitely need to update */
/* things. */
update = TRUE_;
}
if (! update) {
/* Just look up the rotation matrix and relative-to */
/* information from the local buffer. */
rot[0] = buffd[(i__1 = at * 9 - 9) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)506)];
rot[1] = buffd[(i__1 = at * 9 - 8) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)507)];
rot[2] = buffd[(i__1 = at * 9 - 7) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)508)];
rot[3] = buffd[(i__1 = at * 9 - 6) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)509)];
rot[4] = buffd[(i__1 = at * 9 - 5) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)510)];
rot[5] = buffd[(i__1 = at * 9 - 4) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)511)];
rot[6] = buffd[(i__1 = at * 9 - 3) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)512)];
rot[7] = buffd[(i__1 = at * 9 - 2) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)513)];
rot[8] = buffd[(i__1 = at * 9 - 1) < 180 && 0 <= i__1 ? i__1 : s_rnge(
"buffd", i__1, "tkfram_", (ftnlen)514)];
*frame = buffi[(i__1 = at - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge(
"buffi", i__1, "tkfram_", (ftnlen)516)];
} else {
/* Determine how the frame is specified and what it */
/* is relative to. The variables that specify */
/* how the frame is represented and what it is relative to */
/* are TKFRAME_#_SPEC and TKFRAME_#_RELATIVE where # is */
/* replaced by the text value of ID or the frame name. */
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 5, a__1[1] = "_SPEC";
s_cat(item, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 9, a__1[1] = "_RELATIVE";
s_cat(item + 32, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 5, a__1[1] = "_SPEC";
s_cat(alt, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 9, a__1[1] = "_RELATIVE";
s_cat(alt + 32, a__1, i__2, &c__2, (ftnlen)32);
/* See if the friendlier version of the kernel pool variables */
/* are available. */
for (i__ = 1; i__ <= 2; ++i__) {
dtpool_(alt + (((i__1 = i__ - 1) < 14 && 0 <= i__1 ? i__1 :
s_rnge("alt", i__1, "tkfram_", (ftnlen)537)) << 5), found,
&n, type__, (ftnlen)32, (ftnlen)1);
if (*found) {
s_copy(item + (((i__1 = i__ - 1) < 14 && 0 <= i__1 ? i__1 :
s_rnge("item", i__1, "tkfram_", (ftnlen)540)) << 5),
alt + (((i__3 = i__ - 1) < 14 && 0 <= i__3 ? i__3 :
s_rnge("alt", i__3, "tkfram_", (ftnlen)540)) << 5), (
ftnlen)32, (ftnlen)32);
}
}
/* If either the SPEC or RELATIVE frame are missing from */
/* the kernel pool, we simply return. */
if (badkpv_("TKFRAM", item, "=", &c__1, &c__1, "C", (ftnlen)6, (
ftnlen)32, (ftnlen)1, (ftnlen)1) || badkpv_("TKFRAM", item +
32, "=", &c__1, &c__1, "C", (ftnlen)6, (ftnlen)32, (ftnlen)1,
(ftnlen)1)) {
lnkini_(&c__20, pool);
*frame = 0;
ident_(rot);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* If we make it this far, look up the SPEC and RELATIVE frame. */
gcpool_(item, &c__1, &c__1, &n, spec, &fnd, (ftnlen)32, (ftnlen)32);
gcpool_(item + 32, &c__1, &c__1, &n, name__, &fnd, (ftnlen)32, (
ftnlen)32);
/* Look up the id-code for this frame. */
namfrm_(name__, frame, (ftnlen)32);
if (*frame == 0) {
lnkini_(&c__20, pool);
setmsg_("The frame to which frame # is relatively defined is not"
" recognized. The kernel pool specification of the relati"
"ve frame is '#'. This is not a recognized frame. ", (
ftnlen)161);
errint_("#", id, (ftnlen)1);
errch_("#", name__, (ftnlen)1, (ftnlen)32);
sigerr_("SPICE(BADFRAMESPEC)", (ftnlen)19);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* Convert SPEC to upper case so that we can easily check */
/* to see if this is one of the expected specification types. */
ucase_(spec, spec, (ftnlen)32, (ftnlen)32);
if (s_cmp(spec, "MATRIX", (ftnlen)32, (ftnlen)6) == 0) {
/* This is the easiest case. Just grab the matrix */
/* from the kernel pool (and polish it up a bit just */
/* to make sure we have a rotation matrix). */
/* We give preference to the kernel pool variable */
/* TKFRAME_<name>_MATRIX if it is available. */
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 7, a__1[1] = "_MATRIX";
s_cat(item + 64, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 7, a__1[1] = "_MATRIX";
s_cat(alt + 64, a__1, i__2, &c__2, (ftnlen)32);
dtpool_(alt + 64, found, &n, type__, (ftnlen)32, (ftnlen)1);
if (*found) {
s_copy(item + 64, alt + 64, (ftnlen)32, (ftnlen)32);
}
if (badkpv_("TKFRAM", item + 64, "=", &c__9, &c__1, "N", (ftnlen)
6, (ftnlen)32, (ftnlen)1, (ftnlen)1)) {
lnkini_(&c__20, pool);
*frame = 0;
ident_(rot);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* The variable meets current expectations, look it up */
/* from the kernel pool. */
gdpool_(item + 64, &c__1, &c__9, &n, matrix, &fnd, (ftnlen)32);
/* In this case the full transformation matrix has been */
/* specified. We simply polish it up a bit. */
moved_(matrix, &c__9, rot);
sharpr_(rot);
/* The matrix might not be right-handed, so correct */
/* the sense of the second and third columns if necessary. */
if (vdot_(&rot[3], &matrix[3]) < 0.) {
vsclip_(&c_b95, &rot[3]);
}
if (vdot_(&rot[6], &matrix[6]) < 0.) {
vsclip_(&c_b95, &rot[6]);
}
} else if (s_cmp(spec, "ANGLES", (ftnlen)32, (ftnlen)6) == 0) {
/* Look up the angles, their units and axes for the */
/* frame specified by ID. (Note that UNITS are optional). */
/* As in the previous case we give preference to the */
/* form TKFRAME_<name>_<item> over TKFRAME_<id>_<item>. */
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 7, a__1[1] = "_ANGLES";
s_cat(item + 64, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 5, a__1[1] = "_AXES";
s_cat(item + 96, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 6, a__1[1] = "_UNITS";
s_cat(item + 128, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 7, a__1[1] = "_ANGLES";
s_cat(alt + 64, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 5, a__1[1] = "_AXES";
s_cat(alt + 96, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 6, a__1[1] = "_UNITS";
s_cat(alt + 128, a__1, i__2, &c__2, (ftnlen)32);
/* Again, we give preference to the more friendly form */
/* of TKFRAME specification. */
for (i__ = 3; i__ <= 5; ++i__) {
dtpool_(alt + (((i__1 = i__ - 1) < 14 && 0 <= i__1 ? i__1 :
s_rnge("alt", i__1, "tkfram_", (ftnlen)668)) << 5),
found, &n, type__, (ftnlen)32, (ftnlen)1);
if (*found) {
s_copy(item + (((i__1 = i__ - 1) < 14 && 0 <= i__1 ? i__1
: s_rnge("item", i__1, "tkfram_", (ftnlen)671)) <<
5), alt + (((i__3 = i__ - 1) < 14 && 0 <= i__3 ?
i__3 : s_rnge("alt", i__3, "tkfram_", (ftnlen)671)
) << 5), (ftnlen)32, (ftnlen)32);
}
}
if (badkpv_("TKFRAM", item + 64, "=", &c__3, &c__1, "N", (ftnlen)
6, (ftnlen)32, (ftnlen)1, (ftnlen)1) || badkpv_("TKFRAM",
item + 96, "=", &c__3, &c__1, "N", (ftnlen)6, (ftnlen)32,
(ftnlen)1, (ftnlen)1)) {
lnkini_(&c__20, pool);
*frame = 0;
ident_(rot);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
s_copy(units, "RADIANS", (ftnlen)32, (ftnlen)7);
gdpool_(item + 64, &c__1, &c__3, &n, angles, &fnd, (ftnlen)32);
gipool_(item + 96, &c__1, &c__3, &n, axes, &fnd, (ftnlen)32);
gcpool_(item + 128, &c__1, &c__1, &n, units, &fnd, (ftnlen)32, (
ftnlen)32);
/* Convert angles to radians. */
for (i__ = 1; i__ <= 3; ++i__) {
convrt_(&angles[(i__1 = i__ - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("angles", i__1, "tkfram_", (ftnlen)700)],
units, "RADIANS", &tempd, (ftnlen)32, (ftnlen)7);
angles[(i__1 = i__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
"angles", i__1, "tkfram_", (ftnlen)701)] = tempd;
}
if (failed_()) {
lnkini_(&c__20, pool);
*frame = 0;
ident_(rot);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* Compute the rotation from instrument frame to CK frame. */
eul2m_(angles, &angles[1], &angles[2], axes, &axes[1], &axes[2],
rot);
} else if (s_cmp(spec, "QUATERNION", (ftnlen)32, (ftnlen)10) == 0) {
/* Look up the quaternion and convert it to a rotation */
/* matrix. Again there are two possible variables that */
/* may point to the quaternion. We give preference to */
/* the form TKFRAME_<name>_Q over the form TKFRAME_<id>_Q. */
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 2, a__1[1] = "_Q";
s_cat(item + 64, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 2, a__1[1] = "_Q";
s_cat(alt + 64, a__1, i__2, &c__2, (ftnlen)32);
dtpool_(alt + 64, found, &n, type__, (ftnlen)32, (ftnlen)1);
if (*found) {
s_copy(item + 64, alt + 64, (ftnlen)32, (ftnlen)32);
}
if (badkpv_("TKFRAM", item + 64, "=", &c__4, &c__1, "N", (ftnlen)
6, (ftnlen)32, (ftnlen)1, (ftnlen)1)) {
lnkini_(&c__20, pool);
*frame = 0;
ident_(rot);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* In this case we have the quaternion representation. */
/* Again, we do a small amount of polishing of the input. */
gdpool_(item + 64, &c__1, &c__4, &n, quatrn, &fnd, (ftnlen)32);
vhatg_(quatrn, &c__4, qtmp);
q2m_(qtmp, rot);
} else {
/* We don't recognize the SPEC for this frame. Say */
/* so. Also note that perhaps the user needs to upgrade */
/* the toolkit. */
lnkini_(&c__20, pool);
setmsg_("The frame specification \"# = '#'\" is not one of the r"
"econized means of specifying a text-kernel constant offs"
"et frame (as of version # of the routine TKFRAM). This m"
"ay reflect a typographical error or may indicate that yo"
"u need to consider updating your version of the SPICE to"
"olkit. ", (ftnlen)284);
errch_("#", item, (ftnlen)1, (ftnlen)32);
errch_("#", spec, (ftnlen)1, (ftnlen)32);
errch_("#", versn, (ftnlen)1, (ftnlen)8);
sigerr_("SPICE(UNKNOWNFRAMESPEC)", (ftnlen)23);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* Buffer the identifier, relative frame and rotation matrix. */
buffd[(i__1 = at * 9 - 9) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)784)] = rot[0];
buffd[(i__1 = at * 9 - 8) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)785)] = rot[1];
buffd[(i__1 = at * 9 - 7) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)786)] = rot[2];
buffd[(i__1 = at * 9 - 6) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)787)] = rot[3];
buffd[(i__1 = at * 9 - 5) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)788)] = rot[4];
buffd[(i__1 = at * 9 - 4) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)789)] = rot[5];
buffd[(i__1 = at * 9 - 3) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)790)] = rot[6];
buffd[(i__1 = at * 9 - 2) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)791)] = rot[7];
buffd[(i__1 = at * 9 - 1) < 180 && 0 <= i__1 ? i__1 : s_rnge("buffd",
i__1, "tkfram_", (ftnlen)792)] = rot[8];
buffi[(i__1 = at - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge("buffi", i__1,
"tkfram_", (ftnlen)794)] = *frame;
/* If these were not previously buffered, we need to set */
/* a watch on the various items that might be used to define */
/* this frame. */
if (! buffrd) {
/* Immediately check for an update so that we will */
/* not redundantly look for this item the next time this */
/* routine is called. */
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 9, a__1[1] = "_RELATIVE";
s_cat(item, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 5, a__1[1] = "_SPEC";
s_cat(item + 32, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 5, a__1[1] = "_AXES";
s_cat(item + 64, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 7, a__1[1] = "_MATRIX";
s_cat(item + 96, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 2, a__1[1] = "_Q";
s_cat(item + 128, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 7, a__1[1] = "_ANGLES";
s_cat(item + 160, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = r__, a__1[0] = agent;
i__2[1] = 6, a__1[1] = "_UNITS";
s_cat(item + 192, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 9, a__1[1] = "_RELATIVE";
s_cat(item + 224, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 5, a__1[1] = "_SPEC";
s_cat(item + 256, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 5, a__1[1] = "_AXES";
s_cat(item + 288, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 7, a__1[1] = "_MATRIX";
s_cat(item + 320, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 2, a__1[1] = "_Q";
s_cat(item + 352, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 7, a__1[1] = "_ANGLES";
s_cat(item + 384, a__1, i__2, &c__2, (ftnlen)32);
/* Writing concatenation */
i__2[0] = ar, a__1[0] = altnat;
i__2[1] = 6, a__1[1] = "_UNITS";
s_cat(item + 416, a__1, i__2, &c__2, (ftnlen)32);
swpool_(agent, &c__14, item, (ftnlen)32, (ftnlen)32);
cvpool_(agent, &update, (ftnlen)32);
}
}
if (failed_()) {
lnkini_(&c__20, pool);
chkout_("TKFRAM", (ftnlen)6);
return 0;
}
/* All errors cause the routine to exit before we get to this */
/* point. If we reach this point we didn't have an error and */
/* hence did find the rotation from ID to FRAME. */
*found = TRUE_;
/* That's it */
chkout_("TKFRAM", (ftnlen)6);
return 0;
} /* tkfram_ */
/* $Procedure 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 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 *);
char corr2[5];
integer i__, refid;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, 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 setmsg_(char *, ftnlen), irfnum_(char *,
integer *, ftnlen);
doublereal tstate[6];
integer maxitr;
extern /* Subroutine */ int cmprss_(char *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen);
extern logical return_(void);
static logical usestl;
extern logical odd_(integer *);
/* $ 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. */
/* 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). */
/* The 'CN' correction typically does not */
/* substantially improve accuracy because */
/* the errors made by ignoring */
/* relativistic effects may be larger than */
/* the improvement afforded by obtaining */
/* convergence of the light time solution. */
/* The 'CN' correction computation also */
/* requires a significantly greater number */
/* of CPU cycles than does the */
/* one-iteration light time correction. */
/* 'CN+S' Converged Newtonian light time */
/* and stellar aberration corrections. */
/* 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 and stellar */
/* aberration corrections. */
/* 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': apply both light time and stellar */
/* aberration corrections. */
/* Note that using light time corrections alone ('LT') 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: */
/* Use 'XLT+S': apply both light time and stellar */
/* aberration corrections for transmission. */
/* 3) Obtain an uncorrected state vector derived directly from */
/* data in an SPK file: */
/* Use 'NONE'. */
/* 4) Compute the apparent position of a target body relative */
/* to a star or other distant object: */
/* Use 'LT' or 'LT+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. */
/* 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 */
/* ============== */
/* ZZSPKAP1 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, ZZSPKAP1 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, ZZSPKAP1 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, ZZSPKSB1 and ZZSPKAP1 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 ZZSPKSB1 ( VGR2, EPOCH, 'J2000', STVGR2 ) */
/* CALL ZZSPKAP1 ( 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) SPICE Private routine. */
/* 2) The kernel files to be used by ZZSPKAP1 must be loaded */
/* (normally by the SPICELIB kernel loader FURNSH) before */
/* this routine is called. */
/* 3) 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. */
/* 4) 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) */
/* I.M. Underwood (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 12-DEC-2004 (NJB) */
/* Based on SPICELIB Version 3.0.1, 20-OCT-2003 (EDW) */
/* -& */
/* $ Index_Entries */
/* low-level aberration correction */
/* apparent state from spk file */
/* 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 ZZSPKAP1 */
/* 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 ZZSPKAP1 was determining what */
/* corrections to apply to the state. If the literal string */
/* 'LT' was assigned to ABCORR, ZZSPKAP1 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, ZZSPKAP1 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, then convert to upper case. */
cmprss_(" ", &c__0, abcorr, corr2, (ftnlen)1, abcorr_len, (ftnlen)5);
ucase_(corr2, corr, (ftnlen)5, (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_ */
/* $Procedure OCCULT ( find occultation type at time ) */
/* Subroutine */ int occult_(char *targ1, char *shape1, char *frame1, char *
targ2, char *shape2, char *frame2, char *abcorr, char *obsrvr,
doublereal *et, integer *ocltid, ftnlen targ1_len, ftnlen shape1_len,
ftnlen frame1_len, ftnlen targ2_len, ftnlen shape2_len, ftnlen
frame2_len, ftnlen abcorr_len, ftnlen obsrvr_len)
{
/* Initialized data */
static char occtyp[9*3] = "PARTIAL " "ANNULAR " "FULL ";
/* System generated locals */
integer i__1;
/* 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 back[36];
extern /* Subroutine */ int zzgfocin_(char *, char *, char *, char *,
char *, char *, char *, char *, char *, ftnlen, ftnlen, ftnlen,
ftnlen, ftnlen, ftnlen, ftnlen, ftnlen, ftnlen);
char shap1[9], shap2[9];
extern /* Subroutine */ int zzgfocst_(doublereal *, logical *);
integer i__;
char bname[36], fname[36];
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen);
integer index;
char front[36];
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
logical ellps2;
extern logical failed_(void);
char bframe[32], fframe[32], bshape[9], fshape[9];
integer mltfac;
logical ocstat;
extern /* Subroutine */ int chkout_(char *, ftnlen), setmsg_(char *,
ftnlen), errint_(char *, integer *, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int sigerr_(char *, ftnlen);
/* $ Abstract */
/* Determines the occultation condition (not occulted, partially, */
/* etc.) of one target relative to another target as seen by */
/* an observer at a given time. */
/* $ 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 */
/* TIME */
/* KERNEL */
/* $ Keywords */
/* GEOMETRY */
/* OCCULTATION */
/* ELLIPSOID */
/* $ Declarations */
/* $ Abstract */
/* This file contains public, global parameter declarations */
/* for the SPICELIB Geometry Finder (GF) subsystem. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* GF */
/* $ Keywords */
/* GEOMETRY */
/* ROOT */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* L.E. Elson (JPL) */
/* E.D. Wright (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.3.0, 01-OCT-2011 (NJB) */
/* Added NWILUM parameter. */
/* - SPICELIB Version 1.2.0, 14-SEP-2010 (EDW) */
/* Added NWPA parameter. */
/* - SPICELIB Version 1.1.0, 08-SEP-2009 (EDW) */
/* Added NWRR parameter. */
/* Added NWUDS parameter. */
/* - SPICELIB Version 1.0.0, 21-FEB-2009 (NJB) (LSE) (EDW) */
/* -& */
/* Root finding parameters: */
/* CNVTOL is the default convergence tolerance used by the */
/* high-level GF search API routines. This tolerance is */
/* used to terminate searches for binary state transitions: */
/* when the time at which a transition occurs is bracketed */
/* by two times that differ by no more than CNVTOL, the */
/* transition time is considered to have been found. */
/* Units are TDB seconds. */
/* NWMAX is the maximum number of windows allowed for user-defined */
/* workspace array. */
/* DOUBLE PRECISION WORK ( LBCELL : MW, NWMAX ) */
/* Currently no more than twelve windows are required; the three */
/* extra windows are spares. */
/* Callers of GFEVNT can include this file and use the parameter */
/* NWMAX to declare the second dimension of the workspace array */
/* if necessary. */
/* Callers of GFIDST should declare their workspace window */
/* count using NWDIST. */
/* Callers of GFSEP should declare their workspace window */
/* count using NWSEP. */
/* Callers of GFRR should declare their workspace window */
/* count using NWRR. */
/* Callers of GFUDS should declare their workspace window */
/* count using NWUDS. */
/* Callers of GFPA should declare their workspace window */
/* count using NWPA. */
/* Callers of GFILUM should declare their workspace window */
/* count using NWILUM. */
/* ADDWIN is a parameter used to expand each interval of the search */
/* (confinement) window by a small amount at both ends in order to */
/* accommodate searches using equality constraints. The loaded */
/* kernel files must accommodate these expanded time intervals. */
/* FRMNLN is a string length for frame names. */
/* NVRMAX is the maximum number of vertices if FOV type is "POLYGON" */
/* FOVTLN -- maximum length for FOV string. */
/* Specify the character strings that are allowed in the */
/* specification of field of view shapes. */
/* Character strings that are allowed in the */
/* specification of occultation types: */
/* Occultation target shape specifications: */
/* Specify the number of supported occultation types and occultation */
/* type string length: */
/* Instrument field-of-view (FOV) parameters */
/* Maximum number of FOV boundary vectors: */
/* FOV shape parameters: */
/* circle */
/* ellipse */
/* polygon */
/* rectangle */
/* End of file gf.inc. */
/* $ Abstract */
/* This file contains public, global parameter declarations */
/* for the SPICELIB occultation routines. */
/* $ 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 */
/* ELLIPSOID */
/* GEOMETRY */
/* OCCULTATION */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* S.C. Krening (JPL) */
/* N.J. Bachman (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 24-JAN-2012 (SCK) (NJB) */
/* -& */
/* The following integer codes indicate the geometric relationship */
/* of the three bodies. */
/* The meaning of the sign of each code is given below. */
/* Code sign Meaning */
/* --------- ------------------------------ */
/* > 0 The second ellipsoid is */
/* partially or fully occulted */
/* by the first. */
/* < 0 The first ellipsoid is */
/* partially of fully */
/* occulted by the second. */
/* = 0 No occultation. */
/* The meanings of the codes are given below. The variable names */
/* indicate the type of occultation and which target is in the back. */
/* For example, TOTAL1 represents a total occultation in which the */
/* first target is in the back (or occulted by) the second target. */
/* Name Code Meaning */
/* ------ ----- ------------------------------ */
/* TOTAL1 -3 Total occultation of first */
/* target by second. */
/* ANNLR1 -2 Annular occultation of first */
/* target by second. The second */
/* target does not block the limb */
/* of the first. */
/* PARTL1 -1 Partial occultation of first */
/* target by second target. */
/* NOOCC 0 No occultation or transit: both */
/* objects are completely visible */
/* to the observer. */
/* PARTL2 1 Partial occultation of second */
/* target by first target. */
/* ANNLR2 2 Annular occultation of second */
/* target by first. */
/* TOTAL2 3 Total occultation of second */
/* target by first. */
/* End include file occult.inc */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* TARG1 I Name or ID of first target. */
/* SHAPE1 I Type of shape model used for first target. */
/* FRAME1 I Body-fixed, body-centered frame for first body. */
/* TARG2 I Name or ID of second target. */
/* SHAPE2 I Type of shape model used for second target. */
/* FRAME2 I Body-fixed, body-centered frame for second body. */
/* ABCORR I Aberration correction flag. */
/* OBSRVR I Name or ID of the observer. */
/* ET I Time of the observation (seconds past J2000). */
/* OCLTID O Occultation identification code. */
/* $ Detailed_Input */
/* TARG1 is the name of the first target body. Both object */
/* names and NAIF IDs are accepted. For example, both */
/* 'Moon' and '301' are accepted. */
/* SHAPE1 is a string indicating the geometric model used to */
/* represent the shape of the first target body. The */
/* supported options are: */
/* 'ELLIPSOID' Use a triaxial ellipsoid model */
/* with radius values provided via the */
/* kernel pool. A kernel variable */
/* having a name of the form */
/* 'BODYnnn_RADII' */
/* where nnn represents the NAIF */
/* integer code associated with the */
/* body, must be present in the kernel */
/* pool. This variable must be */
/* associated with three numeric */
/* values giving the lengths of the */
/* ellipsoid's X, Y, and Z semi-axes. */
/* 'POINT' Treat the body as a single point. */
/* When a point target is specified, */
/* the occultation type must be */
/* set to 'ANY'. */
/* At least one of the target bodies TARG1 or TARG2 must */
/* be modeled as an ellipsoid. */
/* Case and leading or trailing blanks are not */
/* significant in the string. */
/* FRAME1 is the name of the body-fixed, body-centered reference */
/* frame associated with the first target body. Examples */
/* of such names are 'IAU_SATURN' (for Saturn) and */
/* 'ITRF93' (for the Earth). */
/* If the first target body is modeled as a point, FRAME1 */
/* should be left blank (Ex: ' '). */
/* Case and leading or trailing blanks bracketing a */
/* non-blank frame name are not significant in the string. */
/* TARG2 is the name of the second target body. See the */
/* description of TARG1 above for more details. */
/* SHAPE2 is the shape specification for the body designated */
/* by TARG2. See the description of SHAPE1 above for */
/* details. */
/* FRAME2 is the name of the body-fixed, body-centered reference */
/* frame associated with the second target body. See the */
/* description of FRAME1 above for more details. */
/* ABCORR indicates the aberration corrections to be applied to */
/* the state of each target body to account for one-way */
/* light time. Stellar aberration corrections are */
/* ignored if specified, since these corrections don't */
/* improve the accuracy of the occultation determination. */
/* See the header of the SPICE routine SPKEZR for a */
/* detailed description of the aberration correction */
/* options. For convenience, the options supported by */
/* this routine are listed below: */
/* 'NONE' Apply no correction. */
/* 'LT' "Reception" case: correct for */
/* one-way light time using a Newtonian */
/* formulation. */
/* 'CN' "Reception" case: converged */
/* Newtonian light time correction. */
/* 'XLT' "Transmission" case: correct for */
/* one-way light time using a Newtonian */
/* formulation. */
/* 'XCN' "Transmission" case: converged */
/* Newtonian light time correction. */
/* Case and blanks are not significant in the string */
/* ABCORR. */
/* OBSRVR is the name of the body from which the occultation */
/* is observed. See the description of TARG1 above for */
/* more details. */
/* ET is the observation time in seconds past the J2000 */
/* epoch. */
/* $ Detailed_Output */
/* OCLTID is an integer occultation code indicating the geometric */
/* relationship of the three bodies. */
/* The meaning of the sign of OCLTID is given below. */
/* Code sign Meaning */
/* --------- ------------------------------ */
/* > 0 The second ellipsoid is */
/* partially or fully occulted */
/* by the first. */
/* < 0 The first ellipsoid is */
/* partially of fully */
/* occulted by the second. */
/* = 0 No occultation. */
/* Possible OCLTID values and meanings are given below. */
/* The variable names indicate the type of occultation */
/* and which target is in the back. For example, TOTAL1 */
/* represents a total occultation in which the first */
/* target is in the back (or occulted by) the second */
/* target. */
/* Name Code Meaning */
/* ------ ----- ------------------------------ */
/* TOTAL1 -3 Total occultation of first */
/* target by second. */
/* ANNLR1 -2 Annular occultation of first */
/* target by second. The second */
/* target does not block the limb */
/* of the first. */
/* PARTL1 -1 Partial occultation of first */
/* target by second target. */
/* NOOCC 0 No occultation or transit: both */
/* objects are completely visible */
/* to the observer. */
/* PARTL2 1 Partial occultation of second */
/* target by first target. */
/* ANNLR2 2 Annular occultation of second */
/* target by first. */
/* TOTAL2 3 Total occultation of second */
/* target by first. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the target or observer body names input by the user are */
/* not recognized, the error will be diagnosed by a routine in */
/* the call tree of this routine. */
/* 2) If the input shapes are not accepted, the error will be */
/* diagnosed by a routine in the call tree of this routine. */
/* 3) If both input shapes are points, the error will be */
/* diagnosed by a routine in the call tree of this routine. */
/* 4) If the radii of a target body modeled as an ellipsoid cannot */
/* be determined by searching the kernel pool for a kernel */
/* variable having a name of the form */
/* 'BODYnnn_RADII' */
/* where nnn represents the NAIF integer code associated with */
/* the body, the error will be diagnosed by a routine in the */
/* call tree of this routine. */
/* 5) If any of the target or observer bodies (TARG1, TARG2, or */
/* OBSRVR) are the same, the error will be diagnosed */
/* by a routine in the call tree of this routine. */
/* 6) If the loaded kernels provide insufficient data to */
/* compute any required state vector, the deficiency will */
/* be diagnosed by a routine in the call tree of this routine. */
/* 7) If an error occurs while reading an SPK or other kernel, */
/* the error will be diagnosed by a routine in the call tree */
/* of this routine. */
/* 8) Invalid aberration correction specifications will be */
/* diagnosed by a routine in the call tree of this routine. */
/* $ Files */
/* Appropriate SPICE kernels must be loaded by the calling program */
/* before this routine is called. */
/* The following data are required: */
/* - SPK data: the calling application must load ephemeris data */
/* for the targets and observer for the specified input time. */
/* If aberration corrections are used, the states of the target */
/* bodies and of the observer relative to the solar system */
/* barycenter must be calculable from the available ephemeris */
/* data. Typically ephemeris data are made available by loading */
/* one or more SPK files via FURNSH. */
/* - PCK data: bodies modeled as triaxial ellipsoids must have */
/* semi-axis lengths provided by variables in the kernel pool. */
/* Typically these data are made available by loading a text */
/* PCK file via FURNSH. */
/* Kernel data are normally loaded once per program run, NOT every */
/* time this routine is called. */
/* $ Particulars */
/* For many purposes, modeling extended bodies as triaxial */
/* ellipsoids is adequate for determining whether one body is */
/* occulted by another as seen from a specified observer. */
/* $ Examples */
/* 1) Find whether MRO is occulted by Mars as seen by */
/* the DSS-13 ground station at a few specific */
/* times. */
/* Use the meta-kernel shown below to load the required SPICE */
/* kernels. */
/* KPL/MK */
/* File: mro_ex_occult.tm */
/* This is the meta-kernel file for the example problem for */
/* the subroutine OCCULT. These kernel files can be found in */
/* the NAIF archives. */
/* 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 */
/* --------- -------- */
/* de421.bsp Planetary ephemeris */
/* earthstns_itrf93_050714.bsp DSN station ephemeris */
/* pck00010.tpc Planet orientation and */
/* radii */
/* earth_000101_120409_120117.bpc High precision Earth */
/* orientation */
/* mro_psp_rec.bsp MRO ephemeris */
/* naif0010.tls Leapseconds */
/* earth_topo_050714.tf Topocentric reference */
/* frames for */
/* DSN stations */
/* \begindata */
/* KERNELS_TO_LOAD = ( 'de421.bsp', */
/* 'earthstns_itrf93_050714.bsp', */
/* 'pck00010.tpc', */
/* 'earth_000101_120409_120117.bpc', */
/* 'mro_psp_rec.bsp', */
/* 'naif0010.tls', */
/* 'earth_topo_050714.tf' ) */
/* \begintext */
/* Example code begins here. */
/* PROGRAM OCCULT_MRO */
/* IMPLICIT NONE */
/* INCLUDE 'occult.inc' */
/* C */
/* C Local parameters */
/* C */
/* CHARACTER*(*) META */
/* PARAMETER ( META = mro_ex_occult.tm' ) */
/* CHARACTER*(*) FRMT */
/* PARAMETER ( FRMT = '(A18, A5, A21, A5, A4, A6)' ) */
/* INTEGER CHSIZ */
/* PARAMETER ( CHSIZ = 30 ) */
/* C */
/* C Local variables */
/* C */
/* CHARACTER*(CHSIZ) ABCORR */
/* CHARACTER*(CHSIZ) FORM */
/* CHARACTER*(CHSIZ) OBSRVR */
/* CHARACTER*(CHSIZ) SHAPE1 */
/* CHARACTER*(CHSIZ) SHAPE2 */
/* CHARACTER*(CHSIZ) TARG1 */
/* CHARACTER*(CHSIZ) TARG2 */
/* CHARACTER*(CHSIZ) TIME */
/* CHARACTER*(CHSIZ) TSTART */
/* CHARACTER*(CHSIZ) TEND */
/* CHARACTER*(CHSIZ) OUTCH ( 4 ) */
/* DOUBLE PRECISION ET */
/* DOUBLE PRECISION ET1 */
/* DOUBLE PRECISION ETEND */
/* INTEGER DT */
/* INTEGER OCLTID */
/* C */
/* C Saved variables */
/* C */
/* SAVE OUTCH */
/* DATA OUTCH ( 1 ) / 'totally occulted by' / */
/* DATA OUTCH ( 2 ) / 'transited by' / */
/* DATA OUTCH ( 3 ) / 'partially occulted by' / */
/* DATA OUTCH ( 4 ) / 'not occulted by' / */
/* C */
/* C Initialize the time range. Set the output time */
/* C format to PST. Set DT to an hour interval in */
/* C units of seconds. */
/* C */
/* TSTART = '2012-JAN-5 1:15:00 UTC' */
/* TEND = '2012-JAN-5 2:50:00 UTC' */
/* FORM = 'YYYY-MON-DD HR:MN ::UTC-8' */
/* DT = 1000 */
/* C */
/* C Initialize the targets, observer, and aberration */
/* C correction. */
/* C */
/* TARG1 = 'MRO' */
/* SHAPE1 = 'POINT' */
/* TARG2 = 'MARS' */
/* SHAPE2 = 'ELLIPSOID' */
/* OBSRVR = 'DSS-13' */
/* ABCORR = 'CN' */
/* C */
/* C Load kernel files via the meta-kernel. */
/* C */
/* CALL FURNSH ( META ) */
/* C */
/* C Calculate the start and stop times in ET. */
/* C */
/* CALL STR2ET ( TSTART, ET1 ) */
/* CALL STR2ET ( TEND, ETEND ) */
/* ET = ET1 */
/* DO WHILE ( ET .LT. ETEND ) */
/* C */
/* C Calculate the type of occultation that */
/* C corresponds to time ET. */
/* C */
/* CALL OCCULT ( TARG1, SHAPE1, ' ', */
/* . TARG2, SHAPE2, 'IAU_MARS', */
/* . ABCORR, OBSRVR, ET, OCLTID ) */
/* C */
/* C Output the results. */
/* C */
/* CALL TIMOUT ( ET, FORM, TIME ) */
/* IF ( OCLTID .EQ. TOTAL1 ) THEN */
/* WRITE (*,FRMT) TIME, TARG1, OUTCH(1), TARG2, */
/* . 'wrt ', OBSRVR */
/* ELSEIF ( OCLTID .EQ. ANNLR1 ) THEN */
/* WRITE (*,FRMT) TIME, TARG1, OUTCH(2), TARG2, */
/* . 'wrt ', OBSRVR */
/* ELSEIF ( OCLTID .EQ. PARTL1 ) THEN */
/* WRITE (*,FRMT) TIME, TARG1, OUTCH(3), TARG2, */
/* . 'wrt ', OBSRVR, */
/* . 'NOT POSSIBLE FOR POINT' */
/* ELSEIF ( OCLTID .EQ. NOOCC ) THEN */
/* WRITE (*,FRMT) TIME, TARG1, OUTCH(4), TARG2, */
/* . 'wrt ', OBSRVR */
/* ELSEIF ( OCLTID .EQ. PARTL2 ) THEN */
/* WRITE (*,FRMT) TIME, TARG2, OUTCH(3), TARG1, */
/* . 'wrt ', OBSRVR, */
/* . 'NOT POSSIBLE FOR POINT' */
/* ELSEIF ( OCLTID .EQ. ANNLR2 ) THEN */
/* WRITE (*,FRMT) TIME, TARG2, OUTCH(2), TARG1, */
/* . 'wrt ', OBSRVR */
/* ELSEIF ( OCLTID .EQ. TOTAL2 ) THEN */
/* WRITE (*,FRMT) TIME, TARG2, OUTCH(1), TARG1, */
/* . 'wrt ', OBSRVR */
/* ELSE */
/* WRITE (*,*) 'Bad occultation ID: ', OCLTID */
/* END IF */
/* C */
/* C Increment the time. */
/* C */
/* ET = ET + DT */
/* END DO */
/* END */
/* When this program was executed using gfortran on a PC Linux */
/* 64 bit environment, the output was: */
/* 2012-JAN-04 17:15 MARS transited by MRO wrt DSS-13 */
/* 2012-JAN-04 17:31 MRO not occulted by MARS wrt DSS-13 */
/* 2012-JAN-04 17:48 MRO totally occulted by MARS wrt DSS-13 */
/* 2012-JAN-04 18:04 MRO totally occulted by MARS wrt DSS-13 */
/* 2012-JAN-04 18:21 MRO not occulted by MARS wrt DSS-13 */
/* 2012-JAN-04 18:38 MARS transited by MRO wrt DSS-13 */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* S.C. Krening (JPL) */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 14-NOV-2013 (SCK) (NJB) */
/* -& */
/* $ Index_Entries */
/* occultation type at a specified time */
/* -& */
/* SPICELIB functions */
/* External routines */
/* Local parameters */
/* Local variables */
/* Saved variables */
/* The variable OCCTYP associates the string of an occultation */
/* type (from gf.inc) with its positive integer code (from */
/* occult.inc). The variable OCCTYP is set up so each string is */
/* stored at the index relating to that configuration's positive */
/* integer code. The positive integer codes assume the first */
/* target is occulting (in front of) the second target. */
/* Ex: PARTL2 = 1 (from occult.inc) */
/* OCCTYP ( 1 ) = 'PARTIAL' (from gf.inc) */
/* The table below shows the relation between each index of OCCTYP, */
/* the occultation condition, which target is in front and back, the */
/* multiplication factor, and the output integer occultation code. */
/* Note that the output integer occultation code is the integer index */
/* of OCCTYP multiplied by the multiplication factor. */
/* OCLTID = Index * MLTFAC */
/* MLTFAC is 1 if TARG1 is in front, and -1 if TARG1 is in back. */
/* The setup of OCCTYP could be changed, but it is important to keep */
/* the output integer occultation codes consistent with the values */
/* from occult.inc. */
/* Index Occult. Condition Front Back MLTFAC OCLTID */
/* ----- ----------------- ----- ----- ------ ------ */
/* 1 Partial TARG1 TARG2 1 1 */
/* 1 Partial TARG2 TARG1 -1 -1 */
/* 2 Annular TARG1 TARG2 1 2 */
/* 2 Annular TARG2 TARG1 -1 -2 */
/* 3 Total TARG1 TARG2 1 3 */
/* 3 Total TARG2 TARG1 -1 -3 */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
chkin_("OCCULT", (ftnlen)6);
/* Left justify the shapes and target names and make them upper case. */
ljust_(shape1, shap1, shape1_len, (ftnlen)9);
ucase_(shap1, shap1, (ftnlen)9, (ftnlen)9);
ljust_(shape2, shap2, shape2_len, (ftnlen)9);
ucase_(shap2, shap2, (ftnlen)9, (ftnlen)9);
ljust_(targ1, fname, targ1_len, (ftnlen)36);
ucase_(fname, fname, (ftnlen)36, (ftnlen)36);
ljust_(targ2, bname, targ2_len, (ftnlen)36);
ucase_(bname, bname, (ftnlen)36, (ftnlen)36);
/* The variable ELLPS2 is a flag that relates if both targets are */
/* represented as ellipsoids. If not, only the 'any' occultation */
/* check can be completed. */
if (s_cmp(shap1, "ELLIPSOID", (ftnlen)9, (ftnlen)9) == 0 && s_cmp(shap2,
"ELLIPSOID", (ftnlen)9, (ftnlen)9) == 0) {
ellps2 = TRUE_;
} else {
ellps2 = FALSE_;
}
/* Test two main cases: */
/* 1) The first target is the front body. */
/* 2) The second target is the front body. */
/* First, initialize the occultation code to reflect no occultation. */
*ocltid = 0;
for (i__ = 1; i__ <= 2; ++i__) {
/* The first time through, make the first target the */
/* front. On the second time, make the second target the front. */
/* For details on the variable MLTFAC, please see the detailed */
/* explanation of the OCCTYP variable near the start of the code. */
if (i__ == 1) {
s_copy(front, fname, (ftnlen)36, (ftnlen)36);
s_copy(fshape, shap1, (ftnlen)9, (ftnlen)9);
s_copy(fframe, frame1, (ftnlen)32, frame1_len);
s_copy(back, bname, (ftnlen)36, (ftnlen)36);
s_copy(bshape, shap2, (ftnlen)9, (ftnlen)9);
s_copy(bframe, frame2, (ftnlen)32, frame2_len);
mltfac = 1;
} else {
s_copy(front, bname, (ftnlen)36, (ftnlen)36);
s_copy(fshape, shap2, (ftnlen)9, (ftnlen)9);
s_copy(fframe, frame2, (ftnlen)32, frame2_len);
s_copy(back, fname, (ftnlen)36, (ftnlen)36);
s_copy(bshape, shap1, (ftnlen)9, (ftnlen)9);
s_copy(bframe, frame1, (ftnlen)32, frame1_len);
mltfac = -1;
}
/* Check if there is any occultation with the current front/back */
/* configuration. ZZGFOCIN performs initializations. ZZGFOCST */
/* returns a true/false logical indicating if there is an */
/* occultation. */
zzgfocin_("ANY", front, fshape, fframe, back, bshape, bframe, obsrvr,
abcorr, (ftnlen)3, (ftnlen)36, (ftnlen)9, (ftnlen)32, (ftnlen)
36, (ftnlen)9, (ftnlen)32, obsrvr_len, abcorr_len);
if (failed_()) {
chkout_("OCCULT", (ftnlen)6);
return 0;
}
zzgfocst_(et, &ocstat);
if (failed_()) {
chkout_("OCCULT", (ftnlen)6);
return 0;
}
/* If there was an occultation, and both targets are represented */
/* as ellipsoids, test the three types of occultations: partial, */
/* annular, and full. Note: If the integer parameters within */
/* occult.inc are changed, the following DO loop will need to be */
/* altered. */
if (ocstat && ellps2) {
for (index = 1; index <= 3; ++index) {
zzgfocin_(occtyp + ((i__1 = index - 1) < 3 && 0 <= i__1 ?
i__1 : s_rnge("occtyp", i__1, "occult_", (ftnlen)718))
* 9, front, fshape, fframe, back, bshape, bframe,
obsrvr, abcorr, (ftnlen)9, (ftnlen)36, (ftnlen)9, (
ftnlen)32, (ftnlen)36, (ftnlen)9, (ftnlen)32,
obsrvr_len, abcorr_len);
if (failed_()) {
chkout_("OCCULT", (ftnlen)6);
return 0;
}
zzgfocst_(et, &ocstat);
if (failed_()) {
chkout_("OCCULT", (ftnlen)6);
return 0;
}
/* If the occultation condition is true, return the integer */
/* occultation ID code. */
if (ocstat) {
*ocltid = mltfac * index;
chkout_("OCCULT", (ftnlen)6);
return 0;
}
/* End the DO loop that checks the occultation type. */
}
/* If the search for 'any' occultation was true and the front */
/* target is an ellipse, this is a total occultation. (Other */
/* target is a point). */
} else if (ocstat && s_cmp(fshape, "ELLIPSOID", (ftnlen)9, (ftnlen)9)
== 0) {
*ocltid = mltfac * 3;
chkout_("OCCULT", (ftnlen)6);
return 0;
/* If the search for 'any' occultation was true and the back */
/* target is an ellipse, this is an annular occultation. (Other */
/* target is a point). */
} else if (ocstat && s_cmp(bshape, "ELLIPSOID", (ftnlen)9, (ftnlen)9)
== 0) {
*ocltid = mltfac << 1;
chkout_("OCCULT", (ftnlen)6);
return 0;
}
/* End the DO loop that checks the front/back orientation of */
/* the input targets. */
}
/* If the occultation searches show that there was no occultation */
/* at the given time, return an occultation code that indicates */
/* no occultation. If this part of the code has been reached and */
/* the occultation code indicates an occultation was found, an error */
/* has occurred. */
if (*ocltid != 0) {
setmsg_("This error should never be reached; the occultation code re"
"sult # is invalid.", (ftnlen)77);
errint_("#", ocltid, (ftnlen)1);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("OCCULT", (ftnlen)6);
return 0;
}
chkout_("OCCULT", (ftnlen)6);
return 0;
} /* occult_ */
/* $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 ET2LST ( ET to Local Solar Time ) */
/* Subroutine */ int et2lst_(doublereal *et, integer *body, doublereal *
long__, char *type__, integer *hr, integer *mn, integer *sc, char *
time, char *ampm, ftnlen type_len, ftnlen time_len, ftnlen ampm_len)
{
/* System generated locals */
address a__1[5], a__2[7];
integer i__1[5], i__2[7];
doublereal d__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
/* Local variables */
doublereal rate, slat, mins;
char h__[2], m[2];
integer n;
doublereal q;
char s[2];
doublereal angle;
char frame[32];
doublereal range;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen), errch_(char *, char *, ftnlen, ftnlen), dpfmt_(
doublereal *, char *, char *, ftnlen, ftnlen);
logical found;
extern /* Subroutine */ int repmi_(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
doublereal state[6], slong;
extern /* Subroutine */ int spkez_(integer *, doublereal *, char *, char *
, integer *, doublereal *, doublereal *, ftnlen, ftnlen);
doublereal hours;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
extern doublereal twopi_(void);
extern /* Subroutine */ int bodc2n_(integer *, char *, logical *, ftnlen);
extern doublereal pi_(void);
char bodnam[36];
doublereal lt;
integer frcode;
extern /* Subroutine */ int cidfrm_(integer *, integer *, char *, logical
*, ftnlen);
extern doublereal brcktd_(doublereal *, doublereal *, doublereal *);
extern /* Subroutine */ int reclat_(doublereal *, doublereal *,
doublereal *, doublereal *), rmaind_(doublereal *, doublereal *,
doublereal *, doublereal *);
doublereal secnds;
extern /* Subroutine */ int pgrrec_(char *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, ftnlen);
char bpmkwd[32];
integer hrampm;
doublereal tmpang;
extern /* Subroutine */ int gdpool_(char *, integer *, integer *, integer
*, doublereal *, logical *, ftnlen);
char amorpm[4];
doublereal tmpsec;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), dtpool_(char *, logical *, integer *, char *, ftnlen,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
doublereal mylong, spoint[3];
extern logical return_(void);
char kwtype[1];
extern /* Subroutine */ int intstr_(integer *, char *, ftnlen);
char mytype[32];
doublereal lat;
/* $ Abstract */
/* Given an ephemeris epoch ET, compute the local solar time for */
/* an object on the surface of a body at a specified longitude. */
/* $ 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 */
/* TIME */
/* $ Keywords */
/* TIME */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ET I Epoch in seconds past J2000 epoch */
/* BODY I ID-code of the body of interest */
/* LONG I Longitude of surface point (RADIANS) */
/* TYPE I Type of longitude 'PLANETOCENTRIC', etc. */
/* HR O Local hour on a "24 hour" clock */
/* MN O Minutes past the hour */
/* SC O Seconds past the minute */
/* TIME O String giving local time on 24 hour clock */
/* AMPM O String giving time on A.M./ P.M. scale */
/* $ Detailed_Input */
/* ET is the epoch expressed in TDB seconds past */
/* the J2000 epoch at which a local time is desired. */
/* BODY is the NAIF ID-code of a body on which local */
/* time is to be measured. */
/* LONG is the longitude (either planetocentric or */
/* planetographic) in radians of the site on the */
/* surface of body for which local time should be */
/* computed. */
/* TYPE is the form of longitude supplied by the variable */
/* LONG. Allowed values are 'PLANETOCENTRIC' and */
/* 'PLANETOGRAPHIC'. Note the case of the letters */
/* in TYPE is insignificant. Both 'PLANETOCENTRIC' */
/* and 'planetocentric' are recognized. */
/* $ Detailed_Output */
/* HR is the local "hour" of the site specified at the */
/* epoch ET. Note that an "hour" of local time does not */
/* have the same duration as an hour measured by */
/* conventional clocks. It is simply a representation */
/* of an angle. See the "Particulars" section for a more */
/* complete discussion of the meaning of local time. */
/* MN is the number of "minutes" past the hour of the */
/* local time of the site at the epoch ET. Again note */
/* that a "local minute" is not the same as a minute */
/* you would measure with conventional clocks. */
/* SC is the number of "seconds" past the minute of the */
/* local time of the site at the epoch ET. Again note */
/* that a "local second" is not the same as a second */
/* you would measure with conventional clocks. */
/* TIME is a string expressing the local time */
/* on a "24 hour" local clock. */
/* AMPM is a string expressing the local time on a "12 hour" */
/* local clock together with the traditional AM/PM */
/* label to indicate whether the sun has crossed */
/* the local zenith meridian. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) This routine defines local solar time for any point on the */
/* surface of the Sun to be 12:00:00 noon. */
/* 2) If the TYPE of the coordinates is not recognized, the */
/* error 'SPICE(UNKNOWNSYSTEM)' will be signaled. */
/* 3) If the body-fixed frame to associate with BODY cannot be */
/* determined, the error 'SPICE(CANTFINDFRAME)' is signaled. */
/* 4) If insufficient data is available to compute the */
/* location of the sun in body-fixed coordinates, the */
/* error will be diagnosed by a routine called by this one. */
/* 5) If the BODY#_PM keyword required to determine the body */
/* rotation sense is not found in the POOL or if it is found but */
/* is not a numeric keyword with at least two elements, the error */
/* 'SPICE(CANTGETROTATIONTYPE)' is signaled. */
/* $ Files */
/* Suitable SPK and PCK files must be loaded prior to calling this */
/* routine so that the body-fixed position of the sun relative to */
/* BODY can be computed. The PCK files must contain the standard */
/* BODY#_PM keyword need by this routine to determine the body */
/* rotation sense. */
/* When the input longitude is planetographic, the default */
/* interpretation of this value can be overridden using the optional */
/* kernel variable */
/* BODY<body ID>_PGR_POSITIVE_LON */
/* which is normally defined via loading a text kernel. */
/* $ Particulars */
/* This routine returns the local solar time at a user */
/* specified location on a user specified body. */
/* Let SUNLNG be the planetocentric longitude (in degrees) of */
/* the sun as viewed from the center of the body of interest. */
/* Let SITLNG be the planetocentric longitude (in degrees) of */
/* the site for which local time is desired. */
/* We define local time to be 12 + (SITLNG - SUNLNG)/15 */
/* (where appropriate care is taken to map ( SITLNG - SUNLNG ) */
/* into the range from -180 to 180). */
/* Using this definition, we see that from the point of view */
/* of this routine, local solar time is simply a measure of angles */
/* between meridians on the surface of a body. Consequently, */
/* this routine is not appropriate for computing "local times" */
/* in the sense of Pacific Standard Time. For computing times */
/* relative to standard time zones on earth, see the routines */
/* TIMOUT and STR2ET. */
/* Regarding planetographic longitude */
/* ---------------------------------- */
/* In the planetographic coordinate system, longitude is defined */
/* using the spin sense of the body. Longitude is positive to the */
/* west if the spin is prograde and positive to the east if the spin */
/* is retrograde. The spin sense is given by the sign of the first */
/* degree term of the time-dependent polynomial for the body's prime */
/* meridian Euler angle "W": the spin is retrograde if this term is */
/* negative and prograde otherwise. For the sun, planets, most */
/* natural satellites, and selected asteroids, the polynomial */
/* expression for W may be found in a SPICE PCK kernel. */
/* The earth, moon, and sun are exceptions: planetographic longitude */
/* is measured positive east for these bodies. */
/* If you wish to override the default sense of positive */
/* planetographic longitude for a particular body, you can do so by */
/* defining the kernel variable */
/* BODY<body ID>_PGR_POSITIVE_LON */
/* where <body ID> represents the NAIF ID code of the body. This */
/* variable may be assigned either of the values */
/* 'WEST' */
/* 'EAST' */
/* For example, you can have this routine treat the longitude */
/* of the earth as increasing to the west using the kernel */
/* variable assignment */
/* BODY399_PGR_POSITIVE_LON = 'WEST' */
/* Normally such assignments are made by placing them in a text */
/* kernel and loading that kernel via FURNSH. */
/* $ Examples */
/* The following code fragment illustrates how you */
/* could print the local time at a site on Mars with */
/* planetographic longitude 326.17 deg E at epoch ET. */
/* (This example assumes all required SPK and PCK files have */
/* been loaded). */
/* Convert the longitude to radians, set the type of the longitude */
/* and make up a mnemonic for Mars' ID-code. */
/* LONG = 326.17 * RPD() */
/* TYPE = 'PLANETOGRAPHIC' */
/* MARS = 499 */
/* CALL ET2LST ( ET, MARS, LONG, TYPE, HR, MN, SC, TIME, AMPM ) */
/* WRITE (*,*) 'The local time at Mars 326.17 degrees E ' */
/* WRITE (*,*) 'planetographic longitude is: ', AMPM */
/* $ Restrictions */
/* This routine relies on being able to determine the name */
/* of the body-fixed frame associated with BODY through the */
/* frames subsystem. If the BODY specified is NOT one of the */
/* nine planets or their satellites, you will need to load */
/* an appropriate frame definition kernel that contains */
/* the relationship between the body id and the body-fixed frame */
/* name. See the FRAMES required reading for more details */
/* on specifying this relationship. */
/* The routine determines the body rotation sense using the PCK */
/* keyword BODY#_PM. Therefore, you will need to a text PCK file */
/* defining the complete set of the standard PCK body rotation */
/* keywords for the body of interest. The text PCK file must be */
/* loaded independently of whether a binary PCK file providing */
/* rotation data for the same body is loaded or not. */
/* Although it is not currently the case for any of the Solar System */
/* bodies, it is possible that the retrograde rotation rate of a */
/* body would be slower than the orbital rate of the body rotation */
/* around the Sun. The routine does not account for such cases; for */
/* them it will compute incorrect the local time progressing */
/* backwards. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 3.0.2, 18-APR-2014 (BVS) */
/* Minor edits to long error messages. */
/* - SPICELIB Version 3.0.1, 09-SEP-2009 (EDW) */
/* Header edits: deleted a spurious C$ marker from the */
/* "Detailed_Output" section. The existence of the marker */
/* caused a failure in the HTML documentation creation script. */
/* Deleted the "Revisions" section as it contained several */
/* identical entries from the "Version" section. */
/* Corrected order of header sections. */
/* - SPICELIB Version 3.0.0, 28-OCT-2006 (BVS) */
/* Bug fix: incorrect computation of the local time for the */
/* bodies with the retrograde rotation causing the local time to */
/* flow backwards has been fixed. The local time for all types of */
/* bodies now progresses as expected -- midnight, increasing AM */
/* hours, noon, increasing PM hours, next midnight, and so on. */
/* - SPICELIB Version 2.0.0, 03-NOV-2005 (NJB) */
/* Bug fix: treatment of planetographic longitude has been */
/* updated to be consistent with the SPICE planetographic/ */
/* rectangular coordinate conversion routines. The effect of */
/* this change is that the default sense of positive longitude */
/* for the moon is now east; also, the default sense of positive */
/* planetographic longitude now may be overridden for any body */
/* (see Particulars above). */
/* Updated to remove non-standard use of duplicate arguments */
/* in RMAIND calls. */
/* - SPICELIB Version 1.1.0, 24-MAR-1998 (WLT) */
/* The integer variable SUN was never initialized in the */
/* previous version of the routine. Now it is set to */
/* the proper value of 10. */
/* - SPICELIB Version 1.0.0, 9-JUL-1997 (WLT) */
/* -& */
/* $ Index_Entries */
/* Compute the local time for a point on a body. */
/* -& */
/* SPICELIB Functions */
/* Local parameters */
/* Local Variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
chkin_("ET2LST", (ftnlen)6);
ljust_(type__, mytype, type_len, (ftnlen)32);
ucase_(mytype, mytype, (ftnlen)32, (ftnlen)32);
if (s_cmp(mytype, "PLANETOGRAPHIC", (ftnlen)32, (ftnlen)14) == 0) {
/* Find planetocentric longitude corresponding to the input */
/* longitude. We first represent in rectangular coordinates */
/* a surface point having zero latitude, zero altitude, and */
/* the input planetographic longitude. We then find the */
/* planetocentric longitude of this point. */
/* Since PGRREC accepts a body name, map the input code to */
/* a name, if possible. Otherwise, just convert the input code */
/* to a string. */
bodc2n_(body, bodnam, &found, (ftnlen)36);
if (! found) {
intstr_(body, bodnam, (ftnlen)36);
}
/* Convert planetographic coordinates to rectangular coordinates. */
/* All we care about here is longitude. Set the other inputs */
/* as follows: */
/* Latitude = 0 */
/* Altitude = 0 */
/* Equatorial radius = 1 */
/* Flattening factor = 0 */
pgrrec_(bodnam, long__, &c_b4, &c_b4, &c_b6, &c_b4, spoint, (ftnlen)
36);
/* The output MYLONG is planetocentric longitude. The other */
/* outputs are not used. Note that the variable RANGE appears */
/* later in another RECLAT call; it's not used after that. */
reclat_(spoint, &range, &mylong, &lat);
} else if (s_cmp(mytype, "PLANETOCENTRIC", (ftnlen)32, (ftnlen)14) == 0) {
mylong = *long__;
} else {
setmsg_("The coordinate system '#' is not a recognized system of lon"
"gitude. The recognized systems are 'PLANETOCENTRIC' and 'PL"
"ANETOGRAPHIC'. ", (ftnlen)134);
errch_("#", type__, (ftnlen)1, type_len);
sigerr_("SPICE(UNKNOWNSYSTEM)", (ftnlen)20);
chkout_("ET2LST", (ftnlen)6);
return 0;
}
/* It's always noon on the surface of the sun. */
if (*body == 10) {
*hr = 12;
*mn = 0;
*sc = 0;
s_copy(time, "12:00:00", time_len, (ftnlen)8);
s_copy(ampm, "12:00:00 P.M.", ampm_len, (ftnlen)13);
chkout_("ET2LST", (ftnlen)6);
return 0;
}
/* Get the body-fixed position of the sun. */
cidfrm_(body, &frcode, frame, &found, (ftnlen)32);
if (! found) {
setmsg_("The body-fixed frame associated with body # could not be de"
"termined. This information needs to be \"loaded\" via a fra"
"mes definition kernel. See frames.req for more details. ", (
ftnlen)174);
errint_("#", body, (ftnlen)1);
sigerr_("SPICE(CANTFINDFRAME)", (ftnlen)20);
chkout_("ET2LST", (ftnlen)6);
return 0;
}
spkez_(&c__10, et, frame, "LT+S", body, state, <, (ftnlen)32, (ftnlen)4)
;
reclat_(state, &range, &slong, &slat);
angle = mylong - slong;
/* Force the angle into the region from -PI to PI */
d__1 = twopi_();
rmaind_(&angle, &d__1, &q, &tmpang);
angle = tmpang;
if (angle > pi_()) {
angle -= twopi_();
}
/* Get the rotation sense of the body and invert the angle if the */
/* rotation sense is retrograde. Use the BODY#_PM PCK keyword to */
/* determine the sense of the body rotation. */
s_copy(bpmkwd, "BODY#_PM", (ftnlen)32, (ftnlen)8);
repmi_(bpmkwd, "#", body, bpmkwd, (ftnlen)32, (ftnlen)1, (ftnlen)32);
dtpool_(bpmkwd, &found, &n, kwtype, (ftnlen)32, (ftnlen)1);
if (! found || *(unsigned char *)kwtype != 'N' || n < 2) {
setmsg_("The rotation type for the body # could not be determined be"
"cause the # keyword was either not found in the POOL or or i"
"t was not of the expected type and/or dimension. This keywor"
"d is usually provided via a planetary constants kernel. See "
"pck.req for more details. ", (ftnlen)265);
errint_("#", body, (ftnlen)1);
errch_("#", bpmkwd, (ftnlen)1, (ftnlen)32);
sigerr_("SPICE(CANTGETROTATIONTYPE)", (ftnlen)26);
chkout_("ET2LST", (ftnlen)6);
return 0;
} else {
/* If the rotation rate is negative, invert the angle. */
gdpool_(bpmkwd, &c__2, &c__1, &n, &rate, &found, (ftnlen)32);
if (rate < 0.) {
angle = -angle;
}
}
/* Convert the angle to "angle seconds" before or after local noon. */
secnds = angle * 86400. / twopi_();
secnds = brcktd_(&secnds, &c_b32, &c_b33);
/* Get the hour, and minutes components of the local time. */
rmaind_(&secnds, &c_b34, &hours, &tmpsec);
rmaind_(&tmpsec, &c_b35, &mins, &secnds);
/* Construct the integer components of the local time. */
*hr = (integer) hours + 12;
*mn = (integer) mins;
*sc = (integer) secnds;
/* Set the A.M./P.M. components of local time. */
if (*hr == 24) {
*hr = 0;
hrampm = 12;
s_copy(amorpm, "A.M.", (ftnlen)4, (ftnlen)4);
} else if (*hr > 12) {
hrampm = *hr - 12;
s_copy(amorpm, "P.M.", (ftnlen)4, (ftnlen)4);
} else if (*hr == 12) {
hrampm = 12;
s_copy(amorpm, "P.M.", (ftnlen)4, (ftnlen)4);
} else if (*hr == 0) {
hrampm = 12;
s_copy(amorpm, "A.M.", (ftnlen)4, (ftnlen)4);
} else {
hrampm = *hr;
s_copy(amorpm, "A.M.", (ftnlen)4, (ftnlen)4);
}
/* Now construct the two strings we need. */
hours = (doublereal) (*hr);
mins = (doublereal) (*mn);
secnds = (doublereal) (*sc);
dpfmt_(&hours, "0x", h__, (ftnlen)2, (ftnlen)2);
dpfmt_(&mins, "0x", m, (ftnlen)2, (ftnlen)2);
dpfmt_(&secnds, "0x", s, (ftnlen)2, (ftnlen)2);
/* Writing concatenation */
i__1[0] = 2, a__1[0] = h__;
i__1[1] = 1, a__1[1] = ":";
i__1[2] = 2, a__1[2] = m;
i__1[3] = 1, a__1[3] = ":";
i__1[4] = 2, a__1[4] = s;
s_cat(time, a__1, i__1, &c__5, time_len);
hours = (doublereal) hrampm;
dpfmt_(&hours, "0x", h__, (ftnlen)2, (ftnlen)2);
/* Writing concatenation */
i__2[0] = 2, a__2[0] = h__;
i__2[1] = 1, a__2[1] = ":";
i__2[2] = 2, a__2[2] = m;
i__2[3] = 1, a__2[3] = ":";
i__2[4] = 2, a__2[4] = s;
i__2[5] = 1, a__2[5] = " ";
i__2[6] = 4, a__2[6] = amorpm;
s_cat(ampm, a__2, i__2, &c__7, ampm_len);
chkout_("ET2LST", (ftnlen)6);
return 0;
} /* et2lst_ */
/* $Procedure ZZBODKER ( Private --- Process Body-Name Kernel Pool Maps ) */
/* Subroutine */ int zzbodker_(char *names, char *nornam, integer *codes,
integer *nvals, integer *ordnom, integer *ordcod, integer *nocds,
logical *extker, ftnlen names_len, ftnlen nornam_len)
{
/* Initialized data */
static char nbc[32] = "NAIF_BODY_CODE ";
static char nbn[32] = "NAIF_BODY_NAME ";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
logical drop[2000];
char type__[1*2];
integer nsiz[2];
extern /* Subroutine */ int zzbodini_(char *, char *, integer *, integer *
, integer *, integer *, integer *, ftnlen, ftnlen);
integer i__, j;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen), errch_(char *, char *, ftnlen, ftnlen);
logical found;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
logical plfind[2];
extern /* Subroutine */ int orderc_(char *, integer *, integer *, ftnlen),
gcpool_(char *, integer *, integer *, integer *, char *, logical
*, ftnlen, ftnlen), gipool_(char *, integer *, integer *, integer
*, integer *, logical *, ftnlen), sigerr_(char *, ftnlen);
logical remdup;
extern /* Subroutine */ int chkout_(char *, ftnlen), dtpool_(char *,
logical *, integer *, char *, ftnlen, ftnlen), setmsg_(char *,
ftnlen), errint_(char *, integer *, ftnlen), cmprss_(char *,
integer *, char *, char *, ftnlen, ftnlen, ftnlen);
extern logical return_(void);
integer num[2];
/* $ 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. */
/* This routine processes the kernel pool vectors NAIF_BODY_NAME */
/* and NAIF_BODY_CODE into the formatted lists required by ZZBODTRN */
/* to successfully compute code-name mappings. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* NAIF_IDS */
/* $ Keywords */
/* BODY */
/* $ Declarations */
/* $ Abstract */
/* This include file lists the parameter collection */
/* defining the number of SPICE ID -> NAME mappings. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* naif_ids.req */
/* $ Keywords */
/* Body mappings. */
/* $ Author_and_Institution */
/* E.D. Wright (JPL) */
/* $ Version */
/* SPICELIB 1.0.0 Thu May 20 07:57:58 2010 (EDW) */
/* A script generates this file. Do not edit by hand. */
/* Edit the creation script to modify the contents of */
/* ZZBODTRN.INC. */
/* Maximum size of a NAME string */
/* Count of default SPICE mapping assignments. */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* NAMES O Array of kernel pool assigned names. */
/* NORNAM O Array of normalized kernel pool assigned names. */
/* CODES O Array of ID codes for NAMES/NORNAM. */
/* NVALS O Length of NAMES, NORNAM, CODES, and ORDNOM arrays. */
/* ORDNOM O Order vector for NORNAM. */
/* ORDCOD O Modified order vector for CODES. */
/* NOCDS O Length of ORDCOD array. */
/* EXTKER O Logical indicating presence of kernel pool names. */
/* MAXL P Maximum length of body name strings. */
/* NROOM P Maximum length of kernel pool data vectors. */
/* $ Detailed_Input */
/* None. */
/* $ Detailed_Output */
/* NAMES the array of highest precedent names extracted */
/* from the kernel pool vector NAIF_BODY_NAME. This */
/* array is parallel to NORNAM and CODES. */
/* NORNAM the array of highest precedent names extracted */
/* from the kernel pool vector NAIF_BODY_NAME. After */
/* extraction, each entry is converted to uppercase, */
/* and groups of spaces are compressed to a single */
/* space. This represents the canonical member of the */
/* equivalence class each parallel entry in NAMES */
/* belongs. */
/* CODES the array of highest precedent codes extracted */
/* from the kernel pool vector NAIF_BODY_CODE. This */
/* array is parallel to NAMES and NORNAM. */
/* NVALS the number of items contained in NAMES, NORNAM, */
/* CODES and ORDNOM. */
/* ORDNOM the order vector of indexes for NORNAM. The set */
/* of values NORNAM( ORDNOM(1) ), NORNAM( ORDNOM(2) ), */
/* ... forms an increasing list of name values. */
/* ORDCOD the modified ordering vector of indexes into */
/* CODES. The list CODES( ORDCOD(1) ), */
/* CODES( ORDCOD(2) ), ... , CODES( ORDCOD(NOCDS) ) */
/* forms an increasing non-repeating list of integers. */
/* Moreover, every value in CODES is listed exactly */
/* once in this sequence. */
/* NOCDS the number of indexes listed in ORDCOD. This */
/* value will never exceed NVALS. */
/* EXTKER is a logical that indicates to the caller whether */
/* any kernel pool name-code maps have been defined. */
/* If EXTKER is .FALSE., then the kernel pool variables */
/* NAIF_BODY_CODE and NAIF_BODY_NAME are empty and */
/* only the built-in and ZZBODDEF code-name mappings */
/* need consideration. If .TRUE., then the values */
/* returned by this module need consideration. */
/* $ Parameters */
/* MAXL is the maximum length of a body name. Defined in */
/* the include file 'zzbodtrn.inc'. */
/* NROOM is the maximum number of kernel pool data items */
/* that can be processed from the NAIF_BODY_CODE */
/* and NAIF_BODY_NAME lists. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* 1) The error SPICE(MISSINGKPV) is signaled when one of the */
/* NAIF_BODY_CODE and NAIF_BODY_NAME keywords is present in the */
/* kernel pool and the other is not. */
/* 2) The error SPICE(KERVARTOOBIG) is signaled if one or both of */
/* the NAIF_BODY_CODE and NAIF_BODY_NAME kernel pool vectors */
/* have a cardinality that exceeds NROOM. */
/* 3) The error SPICE(BADDIMENSIONS) is signaled if the cardinality */
/* of the NAIF_BODY_CODE and NAIF_BODY_NAME kernel pool vectors do */
/* not match. */
/* 4) The error SPICE(BLANKNAMEASSIGNED) is signaled if an entry */
/* in the NAIF_BODY_NAME kernel pool vector is a blank string. */
/* ID codes may not be assigned to a blank string. */
/* $ Particulars */
/* This routine examines the contents of the kernel pool, ingests */
/* the contents of the NAIF_BODY_CODE and NAIF_BODY_NAME keywords, */
/* and produces the order vectors and name/code lists that ZZBODTRN */
/* requires to resolve code to name and name to code mappings. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* E.D. Wright (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 23-AUG-2002 (EDW) (FST) */
/* -& */
/* SPICELIB Functions */
/* Local Parameters */
/* Local Variables */
/* Saved Variables */
/* Data Statements */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZBODKER", (ftnlen)8);
}
/* Until the code below proves otherwise, we shall assume */
/* we lack kernel pool name/code mappings. */
*extker = FALSE_;
/* Check for the external body ID variables in the kernel pool. */
gcpool_(nbn, &c__1, &c__2000, num, names, plfind, (ftnlen)32, (ftnlen)36);
gipool_(nbc, &c__1, &c__2000, &num[1], codes, &plfind[1], (ftnlen)32);
/* Examine PLFIND(1) and PLFIND(2) for problems. */
if (plfind[0] != plfind[1]) {
/* If they are not both present or absent, signal an error. */
setmsg_("The kernel pool vector, #, used in mapping between names an"
"d ID-codes is absent, while # is not. This is often due to "
"an improperly constructed text kernel. Check loaded kernels"
" for these keywords.", (ftnlen)199);
if (plfind[0]) {
errch_("#", nbc, (ftnlen)1, (ftnlen)32);
errch_("#", nbn, (ftnlen)1, (ftnlen)32);
} else {
errch_("#", nbn, (ftnlen)1, (ftnlen)32);
errch_("#", nbc, (ftnlen)1, (ftnlen)32);
}
sigerr_("SPICE(MISSINGKPV)", (ftnlen)17);
chkout_("ZZBODKER", (ftnlen)8);
return 0;
} else if (! plfind[0]) {
/* Return if both keywords are absent. */
chkout_("ZZBODKER", (ftnlen)8);
return 0;
}
/* If we reach here, then both kernel pool variables are present. */
/* Perform some simple sanity checks on their lengths. */
dtpool_(nbn, &found, nsiz, type__, (ftnlen)32, (ftnlen)1);
dtpool_(nbc, &found, &nsiz[1], type__ + 1, (ftnlen)32, (ftnlen)1);
if (nsiz[0] > 2000 || nsiz[1] > 2000) {
setmsg_("The kernel pool vectors used to define the names/ID-codes m"
"appingexceeds the max size. The size of the NAME vector is #"
"1. The size of the CODE vector is #2. The max number allowed"
" of elements is #3.", (ftnlen)198);
errint_("#1", nsiz, (ftnlen)2);
errint_("#2", &nsiz[1], (ftnlen)2);
errint_("#3", &c__2000, (ftnlen)2);
sigerr_("SPICE(KERVARTOOBIG)", (ftnlen)19);
chkout_("ZZBODKER", (ftnlen)8);
return 0;
} else if (nsiz[0] != nsiz[1]) {
setmsg_("The kernel pool vectors used for mapping between names and "
"ID-codes are not the same size. The size of the name vector"
", NAIF_BODY_NAME is #. The size of the ID-code vector, NAIF_"
"BODY_CODE is #. You need to examine the ID-code kernel you l"
"oaded and correct the mismatch.", (ftnlen)270);
errint_("#", nsiz, (ftnlen)1);
errint_("#", &nsiz[1], (ftnlen)1);
sigerr_("SPICE(BADDIMENSIONS)", (ftnlen)20);
chkout_("ZZBODKER", (ftnlen)8);
return 0;
}
/* Compute the canonical member of the equivalence class of NAMES, */
/* NORNAM. This normalization compresses groups of spaces into a */
/* single space, left justifies the string, and uppercases the */
/* contents. While passing through the NAMES array, look for any */
/* blank strings and signal an appropriate error. */
*nvals = num[0];
i__1 = *nvals;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Check for blank strings. */
if (s_cmp(names + ((i__2 = i__ - 1) < 2000 && 0 <= i__2 ? i__2 :
s_rnge("names", i__2, "zzbodker_", (ftnlen)345)) * 36, " ", (
ftnlen)36, (ftnlen)1) == 0) {
setmsg_("An attempt to assign the code, #, to a blank string was"
" made. Check loaded text kernels for a blank string in "
"the NAIF_BODY_NAME array.", (ftnlen)136);
errint_("#", &i__, (ftnlen)1);
sigerr_("SPICE(BLANKNAMEASSIGNED)", (ftnlen)24);
chkout_("ZZBODKER", (ftnlen)8);
return 0;
}
/* Compute the canonical member of the equivalence class. */
ljust_(names + ((i__2 = i__ - 1) < 2000 && 0 <= i__2 ? i__2 : s_rnge(
"names", i__2, "zzbodker_", (ftnlen)361)) * 36, nornam + ((
i__3 = i__ - 1) < 2000 && 0 <= i__3 ? i__3 : s_rnge("nornam",
i__3, "zzbodker_", (ftnlen)361)) * 36, (ftnlen)36, (ftnlen)36)
;
ucase_(nornam + ((i__2 = i__ - 1) < 2000 && 0 <= i__2 ? i__2 : s_rnge(
"nornam", i__2, "zzbodker_", (ftnlen)362)) * 36, nornam + ((
i__3 = i__ - 1) < 2000 && 0 <= i__3 ? i__3 : s_rnge("nornam",
i__3, "zzbodker_", (ftnlen)362)) * 36, (ftnlen)36, (ftnlen)36)
;
cmprss_(" ", &c__1, nornam + ((i__2 = i__ - 1) < 2000 && 0 <= i__2 ?
i__2 : s_rnge("nornam", i__2, "zzbodker_", (ftnlen)363)) * 36,
nornam + ((i__3 = i__ - 1) < 2000 && 0 <= i__3 ? i__3 :
s_rnge("nornam", i__3, "zzbodker_", (ftnlen)363)) * 36, (
ftnlen)1, (ftnlen)36, (ftnlen)36);
}
/* Determine a preliminary order vector for NORNAM. */
orderc_(nornam, nvals, ordnom, (ftnlen)36);
/* We are about to remove duplicates. Make some initial */
/* assumptions, no duplicates exist in NORNAM. */
i__1 = *nvals;
for (i__ = 1; i__ <= i__1; ++i__) {
drop[(i__2 = i__ - 1) < 2000 && 0 <= i__2 ? i__2 : s_rnge("drop",
i__2, "zzbodker_", (ftnlen)377)] = FALSE_;
}
remdup = FALSE_;
/* ORDERC clusters duplicate entries in NORNAM together. */
/* Use this fact to locate duplicates on one pass through */
/* NORNAM. */
i__1 = *nvals - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s_cmp(nornam + ((i__3 = ordnom[(i__2 = i__ - 1) < 2000 && 0 <=
i__2 ? i__2 : s_rnge("ordnom", i__2, "zzbodker_", (ftnlen)389)
] - 1) < 2000 && 0 <= i__3 ? i__3 : s_rnge("nornam", i__3,
"zzbodker_", (ftnlen)389)) * 36, nornam + ((i__5 = ordnom[(
i__4 = i__) < 2000 && 0 <= i__4 ? i__4 : s_rnge("ordnom",
i__4, "zzbodker_", (ftnlen)389)] - 1) < 2000 && 0 <= i__5 ?
i__5 : s_rnge("nornam", i__5, "zzbodker_", (ftnlen)389)) * 36,
(ftnlen)36, (ftnlen)36) == 0) {
/* We have at least one duplicate to remove. */
remdup = TRUE_;
/* If the normalized entries are equal, drop the one with */
/* the lower index in the NAMES array. Entries defined */
/* later in the kernel pool have higher precedence. */
if (ordnom[(i__2 = i__ - 1) < 2000 && 0 <= i__2 ? i__2 : s_rnge(
"ordnom", i__2, "zzbodker_", (ftnlen)401)] < ordnom[(i__3
= i__) < 2000 && 0 <= i__3 ? i__3 : s_rnge("ordnom", i__3,
"zzbodker_", (ftnlen)401)]) {
drop[(i__3 = ordnom[(i__2 = i__ - 1) < 2000 && 0 <= i__2 ?
i__2 : s_rnge("ordnom", i__2, "zzbodker_", (ftnlen)
402)] - 1) < 2000 && 0 <= i__3 ? i__3 : s_rnge("drop",
i__3, "zzbodker_", (ftnlen)402)] = TRUE_;
} else {
drop[(i__3 = ordnom[(i__2 = i__) < 2000 && 0 <= i__2 ? i__2 :
s_rnge("ordnom", i__2, "zzbodker_", (ftnlen)404)] - 1)
< 2000 && 0 <= i__3 ? i__3 : s_rnge("drop", i__3,
"zzbodker_", (ftnlen)404)] = TRUE_;
}
}
}
/* If necessary, remove duplicates. */
if (remdup) {
/* Sweep through the DROP array, compressing off any elements */
/* that are to be dropped. */
j = 0;
i__1 = *nvals;
for (i__ = 1; i__ <= i__1; ++i__) {
if (! drop[(i__2 = i__ - 1) < 2000 && 0 <= i__2 ? i__2 : s_rnge(
"drop", i__2, "zzbodker_", (ftnlen)423)]) {
++j;
s_copy(names + ((i__2 = j - 1) < 2000 && 0 <= i__2 ? i__2 :
s_rnge("names", i__2, "zzbodker_", (ftnlen)425)) * 36,
names + ((i__3 = i__ - 1) < 2000 && 0 <= i__3 ? i__3
: s_rnge("names", i__3, "zzbodker_", (ftnlen)425)) *
36, (ftnlen)36, (ftnlen)36);
s_copy(nornam + ((i__2 = j - 1) < 2000 && 0 <= i__2 ? i__2 :
s_rnge("nornam", i__2, "zzbodker_", (ftnlen)426)) *
36, nornam + ((i__3 = i__ - 1) < 2000 && 0 <= i__3 ?
i__3 : s_rnge("nornam", i__3, "zzbodker_", (ftnlen)
426)) * 36, (ftnlen)36, (ftnlen)36);
codes[(i__2 = j - 1) < 2000 && 0 <= i__2 ? i__2 : s_rnge(
"codes", i__2, "zzbodker_", (ftnlen)427)] = codes[(
i__3 = i__ - 1) < 2000 && 0 <= i__3 ? i__3 : s_rnge(
"codes", i__3, "zzbodker_", (ftnlen)427)];
}
}
/* Adjust NVALS to compensate for the number of elements that */
/* were compressed off the list. */
*nvals = j;
}
/* Compute the order vectors that ZZBODTRN requires. */
zzbodini_(names, nornam, codes, nvals, ordnom, ordcod, nocds, (ftnlen)36,
(ftnlen)36);
/* We're on the home stretch if we make it to this point. */
/* Set EXTKER to .TRUE., check out and return. */
*extker = TRUE_;
chkout_("ZZBODKER", (ftnlen)8);
return 0;
} /* zzbodker_ */
/* $Procedure GETFNM_1 ( Get a filename from standard input ) */
/* Subroutine */ int getfnm_1__(char *prmpt, char *fstat, char *fname,
logical *valid, ftnlen prmpt_len, ftnlen fstat_len, ftnlen fname_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
address a__1[2];
integer i__1, i__2[2];
char ch__1[1], ch__2[81];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
extern integer cpos_(char *, char *, integer *, ftnlen, ftnlen);
integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen), errch_(char *, char *, ftnlen, ftnlen), reset_(
void);
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
static char badchr[162];
extern logical failed_(void);
char oldact[10];
extern /* Subroutine */ int cnfirm_(char *, logical *, ftnlen), erract_(
char *, char *, ftnlen, ftnlen);
integer length;
extern integer lastnb_(char *, ftnlen);
char myfnam[1000];
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen);
logical tryagn, myvlid;
extern logical exists_(char *, ftnlen), return_(void);
extern /* Subroutine */ int prompt_(char *, char *, ftnlen, ftnlen),
writln_(char *, integer *, ftnlen);
char status[3], myprmt[80];
/* $ Abstract */
/* This routine prompts the user for a valid filename. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* PRMPT I The prompt to use when asking for the filename. */
/* FSTAT I Status of the file: 'OLD' or 'NEW'. */
/* FNAME O A valid filename typed in by the user. */
/* VALID O A logical flag indicating a valid filename. */
/* PRMLEN P Maximum length allowed for a prompt before */
/* truncation. */
/* $ Detailed_Input */
/* PRMPT is a character string that will be displayed from the */
/* current cursor position that informs a user that input */
/* is expected. Prompts should be fairly short, since we */
/* need to declare some local storage. The current maximum */
/* length of a prompt is given by the parameter PRMLEN. */
/* FSTAT This is the status of the filename entered. It should */
/* be 'OLD' when prompting for the filename of a file which */
/* already exists, and 'NEW' when prompting for the */
/* filename of a file which does not already exist or is to */
/* be over written. */
/* $ Detailed_Output */
/* FNAME is a character string that contains a valid filename */
/* typed in by the user. A valid filename is defined */
/* simply to be a nonblank character string with no */
/* embedded blanks, nonprinting characters, or characters */
/* having decimal values > 126. */
/* VALID A logical flag which indicates whether or not the */
/* filename entered is valid, i.e., a nonblank character */
/* string with no leading or embedded blanks, which */
/* satisfies the constraints for validity imposed. */
/* $ Parameters */
/* PRMLEN The maximum length for an input prompt string. */
/* $ Exceptions */
/* 1) If the input file status is not equal to 'NEW' or 'OLD' after */
/* being left justified and converted to upper case, the error */
/* SPICE(INVALIDARGUMENT) will be signalled. The error handling */
/* is then reset. */
/* 2) If the filename entered at the prompt is blank, the error */
/* SPICE(BLANKFILENAME) will be signalled. The error handling is */
/* then reset. */
/* 3) If the filename contains an illegal character, a nonprinting */
/* character or embedded blanks, the error */
/* SPICE(ILLEGALCHARACTER) will be signalled. */
/* 4) If the file status is equal to 'OLD' after being left */
/* justified and converted to upper case and the file specified */
/* by the filename entered at the prompt does not exist, the */
/* error SPICE(FILEDOESNOTEXIST) will be signalled. */
/* 5) If the file status is equal to 'NEW' after being left */
/* justified and converted to upper case and the file specified */
/* by the filename entered at the prompt already exists, the */
/* error SPICE(FILEALREADYEXISTS) will be signalled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This is a utility that allows you to "easily" request a valid, */
/* filename from a program user. At a high level, it frees you */
/* from the peculiarities of a particular FORTRAN's implementation */
/* of cursor control. */
/* A valid filename is defined as a nonblank character string with */
/* no embedded blanks, nonprinting characters, or characters with */
/* decimal values > 126. Leading blanks are removed, and trailing */
/* blanks are ignored. */
/* If an invalid filename is entered, this routine provides a */
/* descriptive error message and halts the execution of the */
/* process which called it by using a Fortran STOP. */
/* $ Examples */
/* EXAMPLE 1: */
/* FNAME = ' ' */
/* PRMPT = 'Filename? ' */
/* FSTAT = 'OLD' */
/* CALL GETFNM_1( PRMPT, FSTAT, FNAME, VALID ) */
/* The user sees the following displayed on the screen: */
/* Filename? _ */
/* where the underbar, '_', represents the cursor position. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* $ Version */
/* - SPICELIB Version 6.17.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 6.16.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 6.15.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 6.14.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 6.13.0, 14-DEC-2010 (EDW) */
/* Declared PROMPT as EXTERNAL. */
/* Unfied Version and Revision sections, eliminated Revision */
/* section. Corrected error in 09-DEC-1999 Version entry. */
/* Version ID changed to 6.0.9 from 7.0.0. */
/* - Beta Version 6.12.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - Beta Version 6.11.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - Beta Version 6.10.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - Beta Version 6.9.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - Beta Version 6.8.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - Beta Version 6.7.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - Beta Version 6.6.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - Beta Version 6.5.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - Beta Version 6.4.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - Beta Version 6.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - Beta Version 6.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - Beta Version 6.1.1, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - Beta Version 6.1.0, 16-AUG-2000 (WLT) */
/* Added PC-LINUX environment */
/* - Beta Version 6.0.9, 09-DEC-1999 (WLT) */
/* This routine now calls EXPFNM_2 only UNIX environments */
/* - Beta Version 6.0.0, 20-JAN-1998 (NJB) */
/* Now calls EXPFNM_2 to attempt to expand environment variables. */
/* Fixed a typo or two at various places in the header. */
/* - Beta Version 5.1.0, 31-JAN-1996 (KRG) */
/* Fixed a pedantic Fortran syntax error dealing with input */
/* strings that are dimensioned CHARACTER*(*). */
/* A local character string is now declared, and a parameter, */
/* PRMLEN, has been added to the interface description for this */
/* subroutine. PRMLEN defines the maximum length allowed for a */
/* prompt before it is truncated. */
/* - Beta Version 5.0.0, 05-JUL-1995 (KRG) */
/* Modified the routine to handle all of its own error messages */
/* and error conditions. The routine now signals an error */
/* immediately resetting the error handling when an exceptional */
/* condition is encountered. This is done so that input attempts */
/* may continue until a user decides to stop trying. */
/* Added several exceptions to the $ Exceptions section of the */
/* header. */
/* - Beta Version 4.0.1, 25-APR-1994 (KRG) */
/* Removed some incorrect comments from the $ Particulars section */
/* of the header. Something about a looping structure that is not */
/* a part of the code now, if it ever was. */
/* Fixed a typo or two at various places in the header. */
/* - Beta Version 4.0.0, 29-SEP-1993 (KRG) */
/* Added the character reperesnted by decimal 127 to the BADCHR. */
/* It should have been there, but it wasn't. */
/* - Beta Version 3.0.0, 10-SEP-1993 (KRG) */
/* Made the file status variable FSTAT case insensitive. */
/* Added code to the file status .EQ. 'NEW' case to set the */
/* valid flag to .FALSE. and set an appropriate error message */
/* about the file already existing. */
/* - Beta Version 2.0.0, 02-APR-1993 (KRG) */
/* The variable BADCHR was not saved which caused problems on */
/* some computers. This variable is now saved. */
/* - Beta Version 1.0.0, 01-JUN-1992 (KRG) */
/* -& */
/* $ Index_Entries */
/* prompt for a filename with error handling */
/* -& */
/* SPICELIB Functions */
/* Local Parameters */
/* Maximum length of a filename. */
/* Length of an error action */
/* Local Variables */
/* Saved Variables */
/* Initial Values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("GETFNM_1", (ftnlen)8);
}
/* We are going to be signalling errors and resetting the error */
/* handling, so we need to be in RETURN mode. First we get the */
/* current mode and save it, then we set the mode to return. Upon */
/* leaving the subroutine, we will restore the error handling mode */
/* that was in effect when we entered. */
erract_("GET", oldact, (ftnlen)3, (ftnlen)10);
erract_("SET", "RETURN", (ftnlen)3, (ftnlen)6);
/* If this is the first time this routine has been called, */
/* initialize the ``bad character'' string. */
if (first) {
first = FALSE_;
for (i__ = 0; i__ <= 32; ++i__) {
i__1 = i__;
*(unsigned char *)&ch__1[0] = i__;
s_copy(badchr + i__1, ch__1, i__ + 1 - i__1, (ftnlen)1);
}
for (i__ = 1; i__ <= 129; ++i__) {
i__1 = i__ + 32;
*(unsigned char *)&ch__1[0] = i__ + 126;
s_copy(badchr + i__1, ch__1, i__ + 33 - i__1, (ftnlen)1);
}
}
/* Left justify and convert the file status to upper case for */
/* comparisons. */
ljust_(fstat, status, fstat_len, (ftnlen)3);
ucase_(status, status, (ftnlen)3, (ftnlen)3);
/* Check to see if we have a valid status for the filename. */
if (s_cmp(status, "OLD", (ftnlen)3, (ftnlen)3) != 0 && s_cmp(status,
"NEW", (ftnlen)3, (ftnlen)3) != 0) {
setmsg_("The file status '#' was not valid. The file status must hav"
"e a value of 'NEW' or 'OLD'.", (ftnlen)87);
errch_("#", status, (ftnlen)1, (ftnlen)3);
sigerr_("SPICE(INVALIDARGUMENT)", (ftnlen)22);
chkout_("GETFNM_1", (ftnlen)8);
return 0;
}
/* Store the input value for the prompt into our local value. We do */
/* this for pedantic Fortran compilers that issue warnings for */
/* CHARACTER*(*) variables used with concatenation. */
s_copy(myprmt, prmpt, (ftnlen)80, prmpt_len);
/* Read in a potential filename, and test it for validity. */
tryagn = TRUE_;
while(tryagn) {
/* Set the value of the valid flag to .TRUE.. We assume that the */
/* name entered will be a valid one. */
myvlid = TRUE_;
/* Get the filename. */
if (s_cmp(myprmt, " ", (ftnlen)80, (ftnlen)1) == 0) {
prompt_("Filename? ", myfnam, (ftnlen)10, (ftnlen)1000);
} else {
/* Writing concatenation */
i__2[0] = lastnb_(myprmt, (ftnlen)80), a__1[0] = myprmt;
i__2[1] = 1, a__1[1] = " ";
s_cat(ch__2, a__1, i__2, &c__2, (ftnlen)81);
prompt_(ch__2, myfnam, lastnb_(myprmt, (ftnlen)80) + 1, (ftnlen)
1000);
}
if (failed_()) {
myvlid = FALSE_;
}
if (myvlid) {
if (s_cmp(myfnam, " ", (ftnlen)1000, (ftnlen)1) == 0) {
myvlid = FALSE_;
setmsg_("The filename entered was blank.", (ftnlen)31);
sigerr_("SPICE(BLANKFILENAME)", (ftnlen)20);
}
}
if (myvlid) {
/* Left justify the filename. */
ljust_(myfnam, myfnam, (ftnlen)1000, (ftnlen)1000);
/* Check for bad characters in the filename. */
length = lastnb_(myfnam, (ftnlen)1000);
i__ = cpos_(myfnam, badchr, &c__1, length, (ftnlen)162);
if (i__ > 0) {
myvlid = FALSE_;
setmsg_("The filename entered contains non printing characte"
"rs or embedded blanks.", (ftnlen)73);
sigerr_("SPICE(ILLEGALCHARACTER)", (ftnlen)23);
}
}
if (myvlid) {
/* We know that the filename that was entered was nonblank and */
/* had no bad characters. So, now we take care of the status */
/* question. */
if (s_cmp(status, "OLD", (ftnlen)3, (ftnlen)3) == 0) {
if (! exists_(myfnam, rtrim_(myfnam, (ftnlen)1000))) {
myvlid = FALSE_;
setmsg_("A file with the name '#' does not exist.", (
ftnlen)40);
errch_("#", myfnam, (ftnlen)1, (ftnlen)1000);
sigerr_("SPICE(FILEDOESNOTEXIST)", (ftnlen)23);
}
} else if (s_cmp(status, "NEW", (ftnlen)3, (ftnlen)3) == 0) {
if (exists_(myfnam, rtrim_(myfnam, (ftnlen)1000))) {
myvlid = FALSE_;
setmsg_("A file with the name '#' already exists.", (
ftnlen)40);
errch_("#", myfnam, (ftnlen)1, (ftnlen)1000);
sigerr_("SPICE(FILEALREADYEXISTS)", (ftnlen)24);
}
}
}
if (myvlid) {
tryagn = FALSE_;
} else {
writln_(" ", &c__6, (ftnlen)1);
cnfirm_("Try again? (Yes/No) ", &tryagn, (ftnlen)20);
writln_(" ", &c__6, (ftnlen)1);
if (tryagn) {
reset_();
}
}
}
/* At this point, we have done the best we can. If the status */
/* was new, we might still have an invalid filename, but the */
/* exact reasons for its invalidity are system dependent, and */
/* therefore hard to test. */
*valid = myvlid;
if (*valid) {
s_copy(fname, myfnam, fname_len, rtrim_(myfnam, (ftnlen)1000));
}
/* Restore the error action. */
erract_("SET", oldact, (ftnlen)3, (ftnlen)10);
chkout_("GETFNM_1", (ftnlen)8);
return 0;
} /* getfnm_1__ */
