/* $Procedure HX2INT ( Signed hexadecimal string to integer ) */
/* Subroutine */ int hx2int_(char *string, integer *number, logical *error,
char *errmsg, ftnlen string_len, ftnlen errmsg_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
char ch__1[1];
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen);
/* Local variables */
static integer mini, maxi;
logical more;
extern /* Subroutine */ int repmc_(char *, char *, char *, char *, ftnlen,
ftnlen, ftnlen, ftnlen);
static integer iplus, lccbeg, digbeg, lccend, uccbeg, digend, uccend,
ispace;
integer idigit;
static integer minmod, maxmod;
integer strbeg;
logical negtiv;
extern integer intmin_(void), intmax_(void);
integer letter, strend;
static integer iminus;
integer tmpnum, pos;
/* $ Abstract */
/* Convert a signed hexadecimal string representation of an integer */
/* to its equivalent integer. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* ALPHANUMERIC */
/* CONVERSION */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* STRING I Hexadecimal string to be converted to an integer. */
/* NUMBER O Integer value to be returned. */
/* ERROR O A logical flag which is .TRUE. on error. */
/* ERRMSG O A descriptive error message. */
/* $ Detailed_Input */
/* STRING The hexadecimal string to be converted to an integer. */
/* The following table describes the character set used */
/* to represent the hexadecimal digits and their */
/* corresponding values. */
/* Character Value Character Value */
/* --------- ----- --------- ----- */
/* '0' 0 '8' 8 */
/* '1' 1 '9' 9 */
/* '2' 2 'A','a' 10 */
/* '3' 3 'B','b' 11 */
/* '4' 4 'C','c' 12 */
/* '5' 5 'D','d' 13 */
/* '6' 6 'E','e' 14 */
/* '7' 7 'F','f' 15 */
/* The plus sign, '+', and the minus sign, '-', are used as */
/* well, and they have their usual meanings. */
/* A hexadecimal character string parsed by this routine */
/* should consist of a sign, '+' or '-' (the plus sign is */
/* optional for nonnegative numbers), followed immediately */
/* by a contiguous sequence of hexadecimal digits, e.g.: */
/* (1) +h h ... h */
/* 1 2 n */
/* (2) -h h ... h */
/* 1 2 n */
/* (3) h h ... h */
/* 1 2 n */
/* where h represents an hexadecimal digit. */
/* i */
/* STRING may have leading and trailing blanks, but blanks */
/* embedded within the signficant portion of the character */
/* string are not allowed. This includes any blanks which */
/* appear between the sign character and the first */
/* hexadecimal digit. */
/* $ Detailed_Output */
/* NUMBER The integer value to be returned. The value of this */
/* variable is not changed if an error occurs while parsing */
/* the hexadecimal character string. */
/* ERROR A logical flag which indicates whether an error occurred */
/* while attempting to parse NUMBER from the hexadecimal */
/* character string STRING. ERROR will have the value */
/* .TRUE. if an error occurs. It will have the value */
/* .FALSE. otherwise. */
/* ERRMSG Contains a descriptive error message if an error */
/* occurs while attempting to parse NUMBER from the */
/* hexadecimal character string STRING, blank otherwise. */
/* The error message will be left justified. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* 1) If an unexpected character is encountered while parsing the */
/* hexadecimal character string, an appropriate error message */
/* will be set, and the routine will exit. The value of NUMBER */
/* will be unchanged. */
/* 2) If the string represents a number that is larger than */
/* the maximum representable integer an appropriate error */
/* message will be set, and the routine will exit. The value */
/* of NUMBER will be unchanged. */
/* 3) If the string represents a number that is smaller than */
/* the minimum representable integer, an appropriate error */
/* message will be set, and the routine will exit. The value */
/* of NUMBER will be unchanged. */
/* 4) If the input string is blank, an appropriate error message */
/* will be set, and the routine will exit. The value of NUMBER */
/* will be unchanged. */
/* 5) If the error message string is not long enough to contain */
/* the entire error message, the error message will be */
/* truncated on the right. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine will convert a signed hexadecimal character string */
/* representation of an integer into its equivalent integer. This */
/* provides a machine independent mechanism for storing or porting */
/* integer values. This routine is used by the routine HX2DP which */
/* converts a character string representation of a double precision */
/* into its equivalent double precision value. */
/* This routine is one of a pair of routines which are used to */
/* perform conversions between integers and equivalent signed */
/* hexadecimal character strings: */
/* INT2HX -- Convert an integer into a signed hexadecimal */
/* character string. */
/* HX2INT -- Convert a signed hexadecimal character string */
/* into an integer. */
/* $ Examples */
/* All of the values shown are for a two's complement 32 bit */
/* representation for signed integers. */
/* The following argument values illustrate the action of HX2INT for */
/* various input values. */
/* STRING NUMBER ERROR ERRMSG */
/* --------------------- ------------ ------ ------ */
/* '1' 1 .FALSE. ' ' */
/* '-1' -1 .FALSE. ' ' */
/* 'DF' 223 .FALSE. ' ' */
/* 'Df' 223 .FALSE. ' ' */
/* '+3ABC' 15036 .FALSE. ' ' */
/* 'ff' 255 .FALSE. ' ' */
/* '-20' -32 .FALSE. ' ' */
/* '0' 0 .FALSE. ' ' */
/* '7FFFFFFF' 2147483647 .FALSE. ' ' */
/* (Maximum 32 bit integer) */
/* '-7FFFFFFF' -2147483647 .FALSE. ' ' */
/* (Minimum 32 bit integer + 1) */
/* '-80000000' -2147483648 .FALSE. ' ' */
/* (Minimum 32 bit integer) */
/* STRING = ' ' */
/* NUMBER = ( Not defined ) */
/* ERROR = .TRUE. */
/* ERRMSG = 'ERROR: A blank input string is not allowed.' */
/* STRING = '-AB238Q' */
/* NUMBER = ( Not defined ) */
/* ERROR = .TRUE. */
/* ERRMSG = 'ERROR: Illegal character ''Q'' encountered.' */
/* STRING = '- AAA' */
/* NUMBER = ( Not defined ) */
/* ERROR = .TRUE. */
/* ERRMSG = 'ERROR: Illegal character '' '' encountered.' */
/* STRING = '80000000' */
/* NUMBER = ( Not defined ) */
/* ERROR = .TRUE. */
/* ERRMSG = 'ERROR: Integer too large to be represented.' */
/* STRING = '-800F0000' */
/* NUMBER = ( Not defined ) */
/* ERROR = .TRUE. */
/* ERRMSG = 'ERROR: Integer too small to be represented.' */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.1.0, 10-MAR-1994 (KRG) */
/* Changed an IF test operand from .LE. to .LT. so that */
/* the ELSE IF clause could be reached. This change has */
/* NO effect on the execution of the routine because it */
/* makes use of a base that is a power of 2 (16), so the */
/* ELSE IF clause never needs to be reached. The algorithm */
/* was meant to be as general as possible, however, so that */
/* only the base and digits would need to be changed in order to */
/* implement a different number base. */
/* - SPICELIB Version 1.0.0, 22-OCT-1992 (KRG) */
/* -& */
/* $ Index_Entries */
/* convert signed hexadecimal string to integer */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.1.0, 10-MAR-1994 (KRG) */
/* Changed an IF test operand from .LE. to .LT. so that */
/* the ELSE IF clause could be reached. This change has */
/* NO effect on the execution of the routine because it */
/* makes use of a base that is a power of 2 (16), so the */
/* ELSE IF clause never needs to be reached. The algorithm */
/* was meant to be as general as possible, however, so that */
/* only the base and digits would need to be changed in order to */
/* implement a different number base. */
/* Old code was: */
/* IF ( TMPNUM .LE. MAXI ) THEN */
/* TMPNUM = TMPNUM * BASE + IDIGIT */
/* POS = POS + 1 */
/* ELSE IF ( ( TMPNUM .EQ. MAXI ) .AND. */
/* . ( IDIGIT .LE. MAXMOD ) ) THEN */
/* TMPNUM = TMPNUM * BASE + IDIGIT */
/* POS = POS + 1 */
/* ELSE ... */
/* New code: */
/* IF ( TMPNUM .LT. MAXI ) THEN */
/* TMPNUM = TMPNUM * BASE + IDIGIT */
/* POS = POS + 1 */
/* ELSE IF ( ( TMPNUM .EQ. MAXI ) .AND. */
/* . ( IDIGIT .LE. MAXMOD ) ) THEN */
/* TMPNUM = TMPNUM * BASE + IDIGIT */
/* POS = POS + 1 */
/* ELSE ... */
/* -& */
/* SPICELIB functions */
/* Local Parameters */
/* Local variables */
/* Saved variables */
/* Initial values */
/* The input hexadecimal string is scanned from left to right, and */
/* the integer is generated by repeated multiplications and additions */
/* or subtractions. */
/* If this is the first time that this routine has been called, */
/* we need to do some setup stuff. */
if (first) {
first = FALSE_;
/* Initialize the upper and lower bounds for the decimal digits, */
/* the upper and lower bounds for the uppercase hexadecimal */
/* digits, the upper and lower bounds for the lowercase */
/* hexadecimal digits, the space, the plus sign, and the minus */
/* sign in the character sequence. */
digbeg = '0';
digend = '9';
uccbeg = 'A';
uccend = 'F';
lccbeg = 'a';
lccend = 'f';
iminus = '-';
iplus = '+';
ispace = ' ';
/* Initialize some boundary values for error checking while */
/* constructing the desired integer. These are used to help */
/* determine integer overflow or integer underflow errors. */
mini = intmin_() / 16;
minmod = (mini << 4) - intmin_();
maxi = intmax_() / 16;
maxmod = intmax_() - (maxi << 4);
}
/* There are no errors initially, so set the error flag to */
/* .FALSE. */
*error = FALSE_;
/* If the string is blank, set the error flag and return immediately. */
if (s_cmp(string, " ", string_len, (ftnlen)1) == 0) {
*error = TRUE_;
s_copy(errmsg, "ERROR: A blank input string is not allowed.",
errmsg_len, (ftnlen)43);
return 0;
}
/* Initialize a few other things. */
s_copy(errmsg, " ", errmsg_len, (ftnlen)1);
tmpnum = 0;
/* Assume that the number is nonnegative. */
negtiv = FALSE_;
/* Skip any leading white space. We know that there is at least */
/* one nonblank character at this point, so we will not loop */
/* off the end of the string. */
strbeg = 1;
while(*(unsigned char *)&string[strbeg - 1] == ispace) {
++strbeg;
}
/* Now, we want to find the end of the significant portion of */
/* the input string. */
strend = strbeg + 1;
more = TRUE_;
while(more) {
if (strend <= i_len(string, string_len)) {
if (s_cmp(string + (strend - 1), " ", string_len - (strend - 1), (
ftnlen)1) != 0) {
++strend;
} else {
more = FALSE_;
}
} else {
more = FALSE_;
}
}
/* At this point, STREND is one larger than the length of the */
/* significant portion of the string because we incremented */
/* its value after the test. We will subtract one from the */
/* value of STREND so that it exactly represents the position */
/* of the last significant character in the string. */
--strend;
/* Set the position pointer to the beginning of the significant */
/* part, i.e., the nonblank part, of the string, because we are */
/* now ready to try and parse the number. */
pos = strbeg;
/* The first character should be a plus sign, '+', a minus sign, */
/* '-', or a digit, '0' - '9', 'A' - 'F', or 'a' - 'f'. Anything */
/* else is bogus, and we will catch it in the main loop below. */
/* If the character is a minus sign, we want to set the value of */
/* NEGTIV to .TRUE. and increment the position. */
/* If the character is a plus sign, we want to increment the */
/* position. */
if (*(unsigned char *)&string[pos - 1] == iminus) {
negtiv = TRUE_;
++pos;
} else if (*(unsigned char *)&string[pos - 1] == iplus) {
++pos;
}
/* When we build up the number from the hexadecimal string we */
/* need to treat nonnegative numbers differently from negative */
/* numbers. This is because on many computers the minimum */
/* integer is one less than the negation of the maximum integer. */
/* Negative numbers are the ones which truly might cause */
/* problems, because ABS(minimum integer) may equal ABS(maximum */
/* integer) + 1, on some machines. For example, on many machines */
/* with 32 bit numbers, INTMIN = -2147483648 and INTMAX = */
/* 2147483647. */
/* Build up the number from the hexadecimal character string. */
if (negtiv) {
while(pos <= strend) {
letter = *(unsigned char *)&string[pos - 1];
if (letter >= digbeg && letter <= digend) {
idigit = letter - digbeg;
} else if (letter >= uccbeg && letter <= uccend) {
idigit = letter + 10 - uccbeg;
} else if (letter >= lccbeg && letter <= lccend) {
idigit = letter + 10 - lccbeg;
} else {
*error = TRUE_;
s_copy(errmsg, "ERROR: Illegal character '#' encountered.",
errmsg_len, (ftnlen)41);
*(unsigned char *)&ch__1[0] = letter;
repmc_(errmsg, "#", ch__1, errmsg, errmsg_len, (ftnlen)1, (
ftnlen)1, errmsg_len);
return 0;
}
if (tmpnum > mini) {
tmpnum = (tmpnum << 4) - idigit;
++pos;
} else if (tmpnum == mini && idigit <= minmod) {
tmpnum = (tmpnum << 4) - idigit;
++pos;
} else {
*error = TRUE_;
s_copy(errmsg, "ERROR: Integer too small to be represented.",
errmsg_len, (ftnlen)43);
return 0;
}
}
} else {
while(pos <= strend) {
letter = *(unsigned char *)&string[pos - 1];
if (letter >= digbeg && letter <= digend) {
idigit = letter - digbeg;
} else if (letter >= uccbeg && letter <= uccend) {
idigit = letter + 10 - uccbeg;
} else if (letter >= lccbeg && letter <= lccend) {
idigit = letter + 10 - lccbeg;
} else {
*error = TRUE_;
s_copy(errmsg, "ERROR: Illegal character '#' encountered.",
errmsg_len, (ftnlen)41);
*(unsigned char *)&ch__1[0] = letter;
repmc_(errmsg, "#", ch__1, errmsg, errmsg_len, (ftnlen)1, (
ftnlen)1, errmsg_len);
return 0;
}
if (tmpnum < maxi) {
tmpnum = (tmpnum << 4) + idigit;
++pos;
} else if (tmpnum == maxi && idigit <= maxmod) {
tmpnum = (tmpnum << 4) + idigit;
++pos;
} else {
*error = TRUE_;
s_copy(errmsg, "ERROR: Integer too large to be represented.",
errmsg_len, (ftnlen)43);
return 0;
}
}
}
/* If we got to here, we have successfully parsed the hexadecimal */
/* string into an integer. Set the value and return. */
*number = tmpnum;
return 0;
} /* hx2int_ */
/* $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 ETCAL ( Convert ET to Calendar format ) */
/* Subroutine */ int etcal_(doublereal *et, char *string, ftnlen string_len)
{
/* Initialized data */
static logical first = TRUE_;
static integer extra[12] = { 0,0,1,1,1,1,1,1,1,1,1,1 };
static integer dpjan0[12] = { 0,31,59,90,120,151,181,212,243,273,304,334 }
;
static integer dpbegl[12] = { 0,31,60,91,121,152,182,213,244,274,305,335 }
;
static char months[3*12] = "JAN" "FEB" "MAR" "APR" "MAY" "JUN" "JUL"
"AUG" "SEP" "OCT" "NOV" "DEC";
/* System generated locals */
address a__1[12];
integer i__1, i__2, i__3[12];
doublereal d__1;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
double d_int(doublereal *);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
/* Local variables */
static integer dn2000;
static doublereal dp2000, frac;
static char date[180];
static doublereal remd, secs;
static integer year, mins;
static char dstr[16], hstr[16], mstr[16], sstr[16], ystr[16];
static doublereal halfd, q;
static integer tsecs, dofyr, month, hours;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
static doublereal mynum;
static integer bh, bm, iq;
static doublereal secspd;
static char messge[16];
static integer offset;
static doublereal dmnint;
static logical adjust;
static integer daynum;
extern integer intmin_(void), intmax_(void);
extern /* Subroutine */ int dpstrf_(doublereal *, integer *, char *, char
*, ftnlen, ftnlen);
static doublereal dmxint, mydnom;
extern /* Subroutine */ int cmprss_(char *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen);
extern integer lstlti_(integer *, integer *, integer *);
extern /* Subroutine */ int intstr_(integer *, char *, ftnlen);
static integer yr1, yr4;
static char era[16];
static integer day, rem;
extern doublereal spd_(void);
static integer yr100, yr400;
/* $ Abstract */
/* Convert from an ephemeris epoch measured in seconds past */
/* the epoch of J2000 to a calendar string format using a */
/* formal calendar free of leapseconds. */
/* $ 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 */
/* TIME */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* ET I Ephemeris time measured in seconds past J2000. */
/* STRING O A standard calendar representation of ET. */
/* $ Detailed_Input */
/* ET is an epoch measured in ephemeris seconds */
/* past the epoch of J2000. */
/* $ Detailed_Output */
/* STRING is a calendar string representing the input ephemeris */
/* epoch. This string is based upon extending the */
/* Gregorian Calendar backward and forward indefinitely */
/* keeping the same rules for determining leap years. */
/* Moreover, there is no accounting for leapseconds. */
/* To be sure that all of the date can be stored in */
/* STRING, it should be declared to have length at */
/* least 48 characters. */
/* The string will have the following format */
/* year (era) mon day hr:mn:sc.sss */
/* Where: */
/* year --- is the year */
/* era --- is the chronological era associated with */
/* the date. For years after 999 A.D. */
/* the era is omitted. For years */
/* between 1 A.D. and 999 A.D. (inclusive) */
/* era is the string 'A.D.' For epochs */
/* before 1 A.D. Jan 1 00:00:00, era is */
/* given as 'B.C.' and the year is converted */
/* to years before the "Christian Era". */
/* The last B.C. epoch is */
/* 1 B.C. DEC 31 23:59:59.999 */
/* The first A.D. epoch (which occurs .001 */
/* seconds after the last B.C. epoch) is: */
/* 1 A.D. JAN 1 00:00:00.000 */
/* Note: there is no year 0 A.D. or 0 B.C. */
/* mon --- is a 3-letter abbreviation for the month */
/* in all capital letters. */
/* day --- is the day of the month */
/* hr --- is the hour of the day (between 0 and 23) */
/* leading zeros are added to hr if the */
/* numeric value is less than 10. */
/* mn --- is the minute of the hour (0 to 59) */
/* leading zeros are added to mn if the */
/* numeric value is less than 10. */
/* sc.sss is the second of the minute to 3 decimal */
/* places ( 0 to 59.999). Leading zeros */
/* are added if the numeric value is less */
/* than 10. Seconds are truncated, not */
/* rounded. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* 1) If the input ET is so large that the corresponding */
/* number of days since 1 A.D. Jan 1, 00:00:00 is */
/* within 1 of overflowing or underflowing an integer, */
/* ET will not be converted to the correct string */
/* representation rather, the string returned will */
/* state that the epoch was before or after the day */
/* that is INTMIN +1 or INTMAX - 1 days after */
/* 1 A.D. Jan 1, 00:00:00. */
/* 2) If the output string is not sufficiently long to hold */
/* the full date, it will be truncated on the right. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This is an error free routine for converting ephemeris epochs */
/* represented as seconds past the J2000 epoch to formal */
/* calendar strings based upon the Gregorian Calendar. This formal */
/* time is often useful when one needs a human recognizable */
/* form of an ephemeris epoch. There is no accounting for leap */
/* seconds in the output times produced. */
/* Note: The calendar epochs produced are not the same as the */
/* UTC calendar epochs that correspond to ET. The strings */
/* produced by this routine may vary from the corresponding */
/* UTC epochs by more than 1 minute. */
/* This routine can be used in creating error messages or */
/* in routines and programs in which one prefers to report */
/* times without employing leapseconds to produce exact UTC */
/* epochs. */
/* $ Examples */
/* Suppose you wish to report that no data is */
/* available at a particular ephemeris epoch ET. The following */
/* code shows how you might accomplish this task. */
/* CALL DPSTRF ( ET, 6, 'F', ETSTR ) */
/* CALL ETCAL ( ET, STRING ) */
/* E1 = RTRIM ( STRING ) */
/* E2 = RTRIM ( ETSTR ) */
/* WRITE (*,*) 'There is no data available for the body ' */
/* WRITE (*,*) 'at requested time: ' */
/* WRITE (*,*) ' ', STRING(1:E1), ' (', ETSTR(1:E2), ')' */
/* $ Restrictions */
/* One must keep in mind when using this routine that */
/* ancient times are not based upon the Gregorian */
/* calendar. For example the 0 point of the Julian */
/* Date system is 4713 B.C. Jan 1, 12:00:00 on the Julian */
/* Calendar. If one formalized the Gregorian calendar */
/* and extended it indefinitely, the zero point of the Julian */
/* date system corresponds to 4714 B.C. NOV 24 12:00:00 on */
/* the Gregorian calendar. There are several reasons for this. */
/* Leap years in the Julian calendar occur every */
/* 4 years (including *all* centuries). Moreover, the */
/* Gregorian calendar "effectively" begins on 15 Oct, 1582 A.D. */
/* which is 5 Oct, 1582 A.D. in the Julian Calendar. */
/* Therefore you must be careful in your interpretation */
/* of ancient dates produced by this routine. */
/* $ Literature_References */
/* 1. "From Sundial to Atomic Clocks---Understanding Time and */
/* Frequency" by James Jespersen and Jane Fitz-Randolph */
/* Dover Publications, Inc. New York (1982). */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* K.R. Gehringer (JPL) */
/* $ Version */
/* - SPICELIB Version 2.2.0, 05-MAR-1998 (WLT) */
/* The documentation concerning the appearance of the output */
/* time string was corrected so that it does not suggest */
/* a comma is inserted after the day of the month. The */
/* comma was removed from the output string in Version 2.0.0 */
/* (see the note below) but the documentation was not upgraded */
/* accordingly. */
/* - SPICELIB Version 2.1.0, 20-MAY-1996 (WLT) */
/* Two arrays that were initialized but never used were */
/* removed. */
/* - SPICELIB Version 2.0.0, 16-AUG-1995 (KRG) */
/* If the day number was less than 10, the spacing was off for */
/* the rest of the time by one space, that for the "tens" digit. */
/* This has been fixed by using a leading zero when the number of */
/* days is < 10. */
/* Also, the comma that appeared between the month/day/year */
/* and the hour:minute:seconds tokens has been removed. This was */
/* done in order to make the calendar date format of ETCAL */
/* consistent with the calendar date format of ET2UTC. */
/* - SPICELIB Version 1.0.0, 14-DEC-1993 (WLT) */
/* -& */
/* $ Index_Entries */
/* Convert ephemeris time to a formal calendar date */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.1.0, 20-MAY-1996 (WLT) */
/* Two arrays that were initialized but never used were */
/* removed. */
/* - SPICELIB Version 2.0.0, 16-AUG-1995 (KRG) */
/* If the day number was less than 10, the spacing was off for */
/* the rest of the time by one space, that for the "tens" digit. */
/* This has been fixed byusing a leading zero when the number of */
/* days is < 10. */
/* Also, the comma that appeared between the month/day/year */
/* and the hour:minute:seconds tokens has been removed. This was */
/* done in order to make the calendar date format of ETCAL */
/* consistent with the calendar date format of ET2UTC. */
/* - SPICELIB Version 1.0.0, 14-DEC-1993 (WLT) */
/* -& */
/* Spicelib Functions. */
/* We declare the variables that contain the number of days in */
/* 400 years, 100 years, 4 years and 1 year. */
/* The following integers give the number of days during the */
/* associated month of a non-leap year. */
/* The integers that follow give the number of days in a normal */
/* year that precede the first of the month. */
/* The integers that follow give the number of days in a leap */
/* year that precede the first of the month. */
/* The variables below hold the components of the output string */
/* before they are put together. */
/* We will construct our string using the local variable DATE */
/* and transfer the results to the output STRING when we are */
/* done. */
/* MONTHS contains 3-letter abbreviations for the months of the year */
/* The array EXTRA contains the number of additional days that */
/* appear before the first of a month during a leap year (as opposed */
/* to a non-leap year). */
/* DPJAN0(I) gives the number of days that occur before the I'th */
/* month of a normal year. */
/* Definitions of statement functions. */
/* The number of days elapsed since Jan 1, of year 1 A.D. to */
/* Jan 1 of YEAR is given by: */
/* The number of leap days in a year is given by: */
/* To compute the day of the year we */
/* look up the number of days to the beginning of the month, */
/* add on the number leap days that occurred prior to that */
/* time */
/* add on the number of days into the month */
/* The number of days since 1 Jan 1 A.D. is given by: */
if (first) {
first = FALSE_;
halfd = spd_() / 2.;
secspd = spd_();
dn2000 = (c__2000 - 1) * 365 + (c__2000 - 1) / 4 - (c__2000 - 1) /
100 + (c__2000 - 1) / 400 + (dpjan0[(i__1 = c__1 - 1) < 12 &&
0 <= i__1 ? i__1 : s_rnge("dpjan0", i__1, "etcal_", (ftnlen)
571)] + extra[(i__2 = c__1 - 1) < 12 && 0 <= i__2 ? i__2 :
s_rnge("extra", i__2, "etcal_", (ftnlen)571)] * ((c__2000 / 4
<< 2) / c__2000 - c__2000 / 100 * 100 / c__2000 + c__2000 /
400 * 400 / c__2000) + c__1) - 1;
dmxint = (doublereal) intmax_();
dmnint = (doublereal) intmin_();
}
/* Now we "in-line" compute the following call. */
/* call rmaind ( et + halfd, secspd, dp2000, secs ) */
/* because we can't make a call to rmaind. */
/* The reader may wonder why we use et + halfd. The value */
/* et is seconds past the ephemeris epoch of J2000 which */
/* is at 2000 Jan 1, 12:00:00. We want to compute days past */
/* 2000 Jan 1, 00:00:00. The seconds past THAT epoch is et + halfd. */
/* We add on 0.0005 seconds so that the string produced will be */
/* rounded to the nearest millisecond. */
mydnom = secspd;
mynum = *et + halfd;
d__1 = mynum / mydnom;
q = d_int(&d__1);
remd = mynum - q * mydnom;
if (remd < 0.) {
q += -1.;
remd += mydnom;
}
secs = remd;
dp2000 = q;
/* Do something about the problem when ET is vastly */
/* out of range. (Day number outside MAX and MIN integer). */
if (dp2000 + dn2000 < dmnint + 1) {
dp2000 = dmnint - dn2000 + 1;
s_copy(messge, "Epoch before ", (ftnlen)16, (ftnlen)13);
secs = 0.;
} else if (dp2000 + dn2000 > dmxint - 1) {
dp2000 = dmxint - dn2000 - 1;
s_copy(messge, "Epoch after ", (ftnlen)16, (ftnlen)12);
secs = 0.;
} else {
s_copy(messge, " ", (ftnlen)16, (ftnlen)1);
}
/* Compute the number of days since 1 .A.D. Jan 1, 00:00:00. */
/* From the tests in the previous IF-ELSE IF-ELSE block this */
/* addition is guaranteed not to overflow. */
daynum = (integer) (dp2000 + (doublereal) dn2000);
/* If the number of days is negative, we need to do a little */
/* work so that we can represent the date in the B.C. era. */
/* We add enough multiples of 400 years so that the year will */
/* be positive and then we subtract off the appropriate multiple */
/* of 400 years later. */
if (daynum < 0) {
/* Since we can't make the call below and remain */
/* error free, we compute it ourselves. */
/* call rmaini ( daynum, dp400y, offset, daynum ) */
iq = daynum / 146097;
rem = daynum - iq * 146097;
if (rem < 0) {
--iq;
rem += 146097;
}
offset = iq;
daynum = rem;
adjust = TRUE_;
} else {
adjust = FALSE_;
}
/* Next we compute the year. Divide out multiples of 400, 100 */
/* 4 and 1 year. Finally combine these to get the correct */
/* value for year. (Note this is all integer arithmetic.) */
/* Recall that DP1Y = 365 */
/* DP4Y = 4*DPY + 1 */
/* DP100Y = 25*DP4Y - 1 */
/* DP400Y = 4*DP100Y + 1 */
yr400 = daynum / 146097;
rem = daynum - yr400 * 146097;
/* Computing MIN */
i__1 = 3, i__2 = rem / 36524;
yr100 = min(i__1,i__2);
rem -= yr100 * 36524;
/* Computing MIN */
i__1 = 24, i__2 = rem / 1461;
yr4 = min(i__1,i__2);
rem -= yr4 * 1461;
/* Computing MIN */
i__1 = 3, i__2 = rem / 365;
yr1 = min(i__1,i__2);
rem -= yr1 * 365;
dofyr = rem + 1;
year = yr400 * 400 + yr100 * 100 + (yr4 << 2) + yr1 + 1;
/* Get the month, and day of month (depending upon whether */
/* we have a leap year or not). */
if ((year / 4 << 2) / year - year / 100 * 100 / year + year / 400 * 400 /
year == 0) {
month = lstlti_(&dofyr, &c__12, dpjan0);
day = dofyr - dpjan0[(i__1 = month - 1) < 12 && 0 <= i__1 ? i__1 :
s_rnge("dpjan0", i__1, "etcal_", (ftnlen)698)];
} else {
month = lstlti_(&dofyr, &c__12, dpbegl);
day = dofyr - dpbegl[(i__1 = month - 1) < 12 && 0 <= i__1 ? i__1 :
s_rnge("dpbegl", i__1, "etcal_", (ftnlen)701)];
}
/* If we had to adjust the year to make it positive, we now */
/* need to correct it and then convert it to a B.C. year. */
if (adjust) {
year += offset * 400;
year = -year + 1;
s_copy(era, " B.C. ", (ftnlen)16, (ftnlen)6);
} else {
/* If the year is less than 1000, we can't just write it */
/* out. We need to add the era. If we don't do this */
/* the dates look very confusing. */
if (year < 1000) {
s_copy(era, " A.D. ", (ftnlen)16, (ftnlen)6);
} else {
s_copy(era, " ", (ftnlen)16, (ftnlen)1);
}
}
/* Convert Seconds to Hours, Minute and Seconds. */
/* We work with thousandths of a second in integer arithmetic */
/* so that all of the truncation work with seconds will already */
/* be done. (Note that we already know that SECS is greater than */
/* or equal to zero so we'll have no problems with HOURS, MINS */
/* or SECS becoming negative.) */
tsecs = (integer) (secs * 1e3);
frac = secs - (doublereal) tsecs;
hours = tsecs / 3600000;
tsecs -= hours * 3600000;
mins = tsecs / 60000;
tsecs -= mins * 60000;
secs = (doublereal) tsecs / 1e3;
/* We round seconds if we can do so without getting seconds to be */
/* bigger than 60. */
if (secs + 5e-4 < 60.) {
secs += 5e-4;
}
/* Finally, get the components of our date string. */
intstr_(&year, ystr, (ftnlen)16);
if (day >= 10) {
intstr_(&day, dstr, (ftnlen)16);
} else {
s_copy(dstr, "0", (ftnlen)16, (ftnlen)1);
intstr_(&day, dstr + 1, (ftnlen)15);
}
/* We want to zero pad the hours minutes and seconds. */
if (hours < 10) {
bh = 2;
} else {
bh = 1;
}
if (mins < 10) {
bm = 2;
} else {
bm = 1;
}
s_copy(mstr, "00", (ftnlen)16, (ftnlen)2);
s_copy(hstr, "00", (ftnlen)16, (ftnlen)2);
s_copy(sstr, " ", (ftnlen)16, (ftnlen)1);
/* Now construct the string components for hours, minutes and */
/* seconds. */
secs = (integer) (secs * 1e3) / 1e3;
intstr_(&hours, hstr + (bh - 1), 16 - (bh - 1));
intstr_(&mins, mstr + (bm - 1), 16 - (bm - 1));
dpstrf_(&secs, &c__6, "F", sstr, (ftnlen)1, (ftnlen)16);
/* The form of the output for SSTR has a leading blank followed by */
/* the first significant digit. If a decimal point is in the */
/* third slot, then SSTR is of the form ' x.xxxxx' and we need */
/* to insert a leading zero. */
if (*(unsigned char *)&sstr[2] == '.') {
*(unsigned char *)sstr = '0';
}
/* We don't want any leading spaces in SSTR, (HSTR and MSTR don't */
/* have leading spaces by construction. */
ljust_(sstr, sstr, (ftnlen)16, (ftnlen)16);
/* Now form the date string, squeeze out extra spaces and */
/* left justify the whole thing. */
/* Writing concatenation */
i__3[0] = 16, a__1[0] = messge;
i__3[1] = 16, a__1[1] = ystr;
i__3[2] = 16, a__1[2] = era;
i__3[3] = 3, a__1[3] = months + ((i__1 = month - 1) < 12 && 0 <= i__1 ?
i__1 : s_rnge("months", i__1, "etcal_", (ftnlen)810)) * 3;
i__3[4] = 1, a__1[4] = " ";
i__3[5] = 3, a__1[5] = dstr;
i__3[6] = 1, a__1[6] = " ";
i__3[7] = 2, a__1[7] = hstr;
i__3[8] = 1, a__1[8] = ":";
i__3[9] = 2, a__1[9] = mstr;
i__3[10] = 1, a__1[10] = ":";
i__3[11] = 6, a__1[11] = sstr;
s_cat(date, a__1, i__3, &c__12, (ftnlen)180);
cmprss_(" ", &c__1, date, date, (ftnlen)1, (ftnlen)180, (ftnlen)180);
ljust_(date, date, (ftnlen)180, (ftnlen)180);
s_copy(string, date, string_len, (ftnlen)180);
return 0;
} /* etcal_ */
/* $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_ */
