char *ft_itoa(int n)
{
int len;
char *ret;
int i;
int sign;
if (n < -2147483647)
return (ft_strdup("-2147483648"));
sign = IS_NEG(n);
len = i_len(n) + sign;
ret = malloc(sizeof(char) * len + 1);
if (!ret)
return (ret);
ret[len] = '\0';
i = 0;
while (len - i - sign)
{
ret[len - i - 1] = '0' + ABS(n % 10);
n /= 10;
i++;
}
if (sign)
*ret = '-';
return (ret);
}
/* Subroutine */ int ddestX_(char *ctext, integer *ival, ftnlen ctext_len)
{
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Local variables */
static integer ilen;
ilen = i_len(ctext, ctext_len);
/* write(*,*) ctext(1:ilen), ival */
return 0;
} /* ddest_ */
integer lastnb_(char *cline, ftnlen cline_len)
{
/* System generated locals */
integer ret_val;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Local variables */
static integer npos;
/* Return the position of the last nonblank character in the input */
/* character string. CLINE is CHARACTER*(*). Even if CLINE is all */
/* blanks, LASTNB will be returned as 1 so that operations of the */
/* form CLINE(1:LASTNB) won't be garbage. */
/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
*/
/* Start at the end and work backwards until a nonblank is found. */
/* Loop back to 100 to check position # NPOS each time. */
npos = i_len(cline, cline_len);
L100:
/* quit if at the beginning */
if (npos <= 1) {
goto L200;
}
/* quit if not a blank or a null */
if (*(unsigned char *)&cline[npos - 1] != ' ' && *(unsigned char *)&cline[
npos - 1] != '\0') {
goto L200;
}
/* move back one position and try again */
--npos;
goto L100;
/* .......................................................................
*/
L200:
ret_val = npos;
return ret_val;
} /* lastnb_ */
/*new version will develope soon:D the precision of this is version is low*/
void ftoa(double c, char s[],int flength)
{
/*convert float number to ascii*/
/*flength : the length of decimal part.*/
int i_part, f_part_int;
int i, length_i;
double f_part;
i_part = (int)c; //take apart the integer part
f_part = c - (i_part); //decimal part of the given number
for (i = 0; i < flength; i++)
{
/*example: 0.563 ->5.63 ->56.3->563.0 */
f_part *= 10;
}
f_part_int = (int)f_part; //cast f_part to long type.
length_i = i_len(i_part); //length of integer part
itoa(i_part, s); //convert ineger part to array.
s[length_i] = '.'; //add . to arry.
itoa(f_part_int, s + length_i+1); //convert float part to a and concatenate it with integer part
}
/* $Procedure CPOSR ( Character position, reverse ) */
integer cposr_(char *str, char *chars, integer *start, ftnlen str_len, ftnlen
chars_len)
{
/* System generated locals */
integer ret_val;
/* Builtin functions */
integer i_len(char *, ftnlen), i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer b;
logical found;
integer lenstr;
/* $ Abstract */
/* Find the first occurrence in a string of a character belonging */
/* to a collection of characters, starting at a specified location, */
/* searching in reverse. */
/* $ 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 */
/* SCANNING */
/* $ Keywords */
/* CHARACTER */
/* SEARCH */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* STR I Any character string. */
/* CHARS I A collection of characters. */
/* START I Position to begin looking for one of CHARS */
/* The function returns the index of the last character of STR */
/* at or before index START that is in the collection CHARS. */
/* $ Detailed_Input */
/* STR is any character string. */
/* CHARS is a character string containing a collection of */
/* characters. Spaces in CHARS are significant. */
/* START is the position in STR to begin looking for one of the */
/* characters in CHARS. */
/* $ Detailed_Output */
/* The function returns the index of the last character of STR (at */
/* or before index START) that is one of the characters in the */
/* string CHARS. If none of the characters is found, the function */
/* returns zero. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error Free. */
/* 1) If START is less than 1, CPOSR returns zero. */
/* 2) If START is greater than LEN(STRING), the search begins */
/* at the last character of the string. */
/* $ Files */
/* None. */
/* $ Particulars */
/* CPOSR is case sensitive. */
/* An entire family of related SPICELIB routines (POS, CPOS, NCPOS, */
/* POSR, CPOSR, NCPOSR) is desribed in the Required Reading. */
/* Those familiar with the True BASIC language should note that */
/* these functions are equivalent to the True BASIC intrinsic */
/* functions with the same name. */
/* $ Examples */
/* Let STRING = 'BOB, JOHN, TED, AND MARTIN ' */
/* 123456789012345678901234567890 */
/* Normal (sequential) searching: */
/* ------------------------------ */
/* CPOSR( STRING, ' ,', 30 ) = 30 */
/* CPOSR( STRING, ' ,', 29 ) = 29 */
/* CPOSR( STRING, ' ,', 28 ) = 28 */
/* CPOSR( STRING, ' ,', 27 ) = 27 */
/* CPOSR( STRING, ' ,', 26 ) = 20 */
/* CPOSR( STRING, ' ,', 19 ) = 16 */
/* CPOSR( STRING, ' ,', 15 ) = 15 */
/* CPOSR( STRING, ' ,', 14 ) = 11 */
/* CPOSR( STRING, ' ,', 10 ) = 10 */
/* CPOSR( STRING, ' ,', 9 ) = 5 */
/* CPOSR( STRING, ' ,', 4 ) = 4 */
/* CPOSR( STRING, ' ,', 3 ) = 0 */
/* START out of bounds: */
/* -------------------- */
/* CPOSR( STRING, ' ,', 231 ) = 30 */
/* CPOSR( STRING, ' ,', 31 ) = 30 */
/* CPOSR( STRING, ' ,', 0 ) = 0 */
/* CPOSR( STRING, ' ,', -10 ) = 0 */
/* Order within CHARS */
/* ------------------ */
/* CPOSR( STRING, 'JOHN', 23 ) = 18 */
/* CPOSR( STRING, 'OHNJ', 23 ) = 18 */
/* CPOSR( STRING, 'HNJO', 23 ) = 18 */
/* CPOSR( STRING, 'NJOH', 23 ) = 18 */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* H.A. Neilan (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.3, 31-JAN-2008 (BVS) */
/* Removed non-standard end-of-declarations marker */
/* 'C%&END_DECLARATIONS' from comments. */
/* - SPICELIB Version 1.0.2, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.1, 26-MAR-1991 (HAN) */
/* The Required Reading file POSITION was renamed to SCANNING. */
/* This header was updated to reflect the change. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (WLT) */
/* -& */
/* $ Index_Entries */
/* backward search for the position of a character */
/* -& */
/* Local variables */
lenstr = i_len(str, str_len);
b = min(lenstr,*start);
found = FALSE_;
ret_val = 0;
while(! found) {
if (b <= 0) {
return ret_val;
} else if (i_indx(chars, str + (b - 1), chars_len, (ftnlen)1) != 0) {
ret_val = b;
return ret_val;
} else {
--b;
}
}
return ret_val;
} /* cposr_ */
/* $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 M2THNQ ( Find a META/2 qualified @then directive ) */
/* Subroutine */ int m2thnq_(char *string, integer *positn, char *label,
ftnlen string_len, ftnlen label_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern integer upto_(char *, char *, integer *, ftnlen, ftnlen);
static integer i__, j;
extern /* Subroutine */ int fndnwd_(char *, integer *, integer *, integer
*, ftnlen);
static integer length;
/* $ Abstract */
/* This utility routine locates a META/2 qualified @then directive */
/* and returns the position in the string immediately preceeding */
/* the directive as well as the label portion of the directive. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* The META/2 book. */
/* $ Keywords */
/* PARSING */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* STRING I A META/2 language specication string. */
/* POSITN O The position of the last character before @then(%*) */
/* LABEL O The label portion of the @then directive. */
/* $ Detailed_Input */
/* STRING A META/2 language specication string. */
/* $ Detailed_Output */
/* POSITN The index of the last character before a word */
/* that begins with '@then('. If there is no such word */
/* POSITN is assigned the index of the last character */
/* of the string. */
/* LABEL The label portion of the @then directive. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* 1) If there is no qualified @then, POSITN is set to the index of */
/* the last character of the string and LABEL is set to ' '. */
/* $ Particulars */
/* This is a utility routine that locates the first character */
/* before the first occurance of a substring of the form '@then(%*)'. */
/* It is intended for use only by META/2. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* I.M. Underwood (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, 18-MAY-1988 (WLT) (IMU) */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Get the lengtH of the string. */
length = i_len(string, string_len);
/* See if there is a qualified @then. */
*positn = upto_(string, "@then(", &c__1, string_len, (ftnlen)6);
if (*positn == length) {
s_copy(label, " ", label_len, (ftnlen)1);
} else {
fndnwd_(string, positn, &i__, &j, string_len);
if (j <= i__ + 6) {
*positn = length;
s_copy(label, " ", label_len, (ftnlen)1);
} else {
i__1 = i__ + 5;
s_copy(label, string + i__1, label_len, j - 1 - i__1);
}
}
return 0;
} /* m2thnq_ */
/* $Procedure ZZEKRD03 ( EK, read class 3 column entry elements ) */
/* Subroutine */ int zzekrd03_(integer *handle, integer *segdsc, integer *
coldsc, integer *recptr, integer *cvlen, char *cval, logical *isnull,
ftnlen cval_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer nrec, bpos;
extern integer zzekrp2n_(integer *, integer *, integer *);
integer epos, unit;
extern /* Subroutine */ int zzekcnam_(integer *, integer *, char *,
ftnlen), zzekpgbs_(integer *, integer *, integer *), zzekpgpg_(
integer *, integer *, integer *, integer *);
integer b, e, l, n, p, pbase, avail;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
integer recno, ncols;
extern /* Subroutine */ int dasrdc_(integer *, integer *, integer *,
integer *, integer *, char *, ftnlen), dasrdi_(integer *, integer
*, integer *, integer *);
char column[32];
integer colidx, datptr, relptr, ptrloc;
extern /* Subroutine */ int dashlu_(integer *, integer *), setmsg_(char *,
ftnlen), errint_(char *, integer *, ftnlen), errfnm_(char *,
integer *, ftnlen), sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), zzekgei_(integer *, integer *, integer *);
/* $ Abstract */
/* Read a column entry from a specified record in a class 3 column. */
/* Class 3 columns contain scalar character values. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* EK */
/* $ Keywords */
/* EK */
/* PRIVATE */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Boolean Enumerated Type */
/* ekbool.inc Version 1 21-DEC-1994 (NJB) */
/* Within the EK system, boolean values sometimes must be */
/* represented by integer or character codes. The codes and their */
/* meanings are listed below. */
/* Integer code indicating `true': */
/* Integer code indicating `false': */
/* Character code indicating `true': */
/* Character code indicating `false': */
/* End Include Section: EK Boolean Enumerated Type */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Column Descriptor Parameters */
/* ekcoldsc.inc Version 6 23-AUG-1995 (NJB) */
/* Note: The column descriptor size parameter CDSCSZ is */
/* declared separately in the include section CDSIZE$INC.FOR. */
/* Offset of column descriptors, relative to start of segment */
/* integer address range. This number, when added to the last */
/* integer address preceding the segment, yields the DAS integer */
/* base address of the first column descriptor. Currently, this */
/* offset is exactly the size of a segment descriptor. The */
/* parameter SDSCSZ, which defines the size of a segment descriptor, */
/* is declared in the include file eksegdsc.inc. */
/* Size of column descriptor */
/* Indices of various pieces of column descriptors: */
/* CLSIDX is the index of the column's class code. (We use the */
/* word `class' to distinguish this item from the column's data */
/* type.) */
/* TYPIDX is the index of the column's data type code (CHR, INT, DP, */
/* or TIME). The type is actually implied by the class, but it */
/* will frequently be convenient to look up the type directly. */
/* LENIDX is the index of the column's string length value, if the */
/* column has character type. A value of IFALSE in this element of */
/* the descriptor indicates that the strings have variable length. */
/* SIZIDX is the index of the column's element size value. This */
/* descriptor element is meaningful for columns with fixed-size */
/* entries. For variable-sized columns, this value is IFALSE. */
/* NAMIDX is the index of the base address of the column's name. */
/* IXTIDX is the data type of the column's index. IXTIDX */
/* contains a type value only if the column is indexed. For columns */
/* that are not indexed, the location IXTIDX contains the boolean */
/* value IFALSE. */
/* IXPIDX is a pointer to the column's index. IXTPDX contains a */
/* meaningful value only if the column is indexed. The */
/* interpretation of the pointer depends on the data type of the */
/* index. */
/* NFLIDX is the index of a flag indicating whether nulls are */
/* permitted in the column. The value at location NFLIDX is */
/* ITRUE if nulls are permitted and IFALSE otherwise. */
/* ORDIDX is the index of the column's ordinal position in the */
/* list of columns belonging to the column's parent segment. */
/* METIDX is the index of the column's integer metadata pointer. */
/* This pointer is a DAS integer address. */
/* The last position in the column descriptor is reserved. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Column Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Column Name Size */
/* ekcnamsz.inc Version 1 17-JAN-1995 (NJB) */
/* Size of column name, in characters. */
/* End Include Section: EK Column Name Size */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Data Page Parameters */
/* ekfilpar.inc Version 1 03-APR-1995 (NJB) */
/* These parameters apply to EK files using architecture 4. */
/* These files use a paged DAS file as their underlying file */
/* structure. */
/* In paged DAS EK files, data pages are structured: they contain */
/* metadata as well as data. The metadata is located in the last */
/* few addresses of each page, so as to interfere as little as */
/* possible with calculation of data addresses. */
/* Each data page belongs to exactly one segment. Some bookkeeping */
/* information, such as record pointers, is also stored in data */
/* pages. */
/* Each page contains a forward pointer that allows rapid lookup */
/* of data items that span multiple pages. Each page also keeps */
/* track of the current number of links from its parent segment */
/* to the page. Link counts enable pages to `know' when they */
/* are no longer in use by a segment; unused pages are deallocated */
/* and returned to the free list. */
/* The parameters in this include file depend on the parameters */
/* declared in the include file ekpage.inc. If those parameters */
/* change, this file must be updated. The specified parameter */
/* declarations we need from that file are: */
/* INTEGER PGSIZC */
/* PARAMETER ( PGSIZC = 1024 ) */
/* INTEGER PGSIZD */
/* PARAMETER ( PGSIZD = 128 ) */
/* INTEGER PGSIZI */
/* PARAMETER ( PGSIZI = 256 ) */
/* Character pages use an encoding mechanism to represent integer */
/* metadata. Each integer is encoded in five consecutive */
/* characters. */
/* Character data page parameters: */
/* Size of encoded integer: */
/* Usable page size: */
/* Location of character forward pointer: */
/* Location of character link count: */
/* Double precision data page parameters: */
/* Usable page size: */
/* Location of d.p. forward pointer: */
/* Location of d.p. link count: */
/* Integer data page parameters: */
/* Usable page size: */
/* Location of integer forward pointer: */
/* Location of integer link count: */
/* End Include Section: EK Data Page Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Record Pointer Parameters */
/* ekrecptr.inc Version 2 18-JUL-1995 (NJB) */
/* This file declares parameters used in EK record pointers. */
/* Each segment references data in a given record via two levels */
/* of indirection: a record number points to a record pointer, */
/* which is a structured array of metadata and data pointers. */
/* Record pointers always occupy contiguous ranges of integer */
/* addresses. */
/* The parameter declarations in this file depend on the assumption */
/* that integer pages contain 256 DAS integer words and that the */
/* maximum number of columns in a segment is 100. Record pointers */
/* are stored in integer data pages, so they must fit within the */
/* usable data area afforded by these pages. The size of the usable */
/* data area is given by the parameter IPSIZE which is declared in */
/* ekdatpag.inc. The assumed value of IPSIZE is 254. */
/* The first element of each record pointer is a status indicator. */
/* The meanings of status indicators depend on whether the parent EK */
/* is shadowed or not. For shadowed EKs, allowed status values and */
/* their meanings are: */
/* OLD The record has not been modified since */
/* the EK containing the record was opened. */
/* UPDATE The record is an update of a previously existing */
/* record. The original record is now on the */
/* modified record list. */
/* NEW The record has been added since the EK containing the */
/* record was opened. The record is not an update */
/* of a previously existing record. */
/* DELOLD This status applies only to a backup record. */
/* DELOLD status indicates that the record corresponds */
/* to a deleted OLD record in the source segment. */
/* DELNEW This status applies only to a backup record. */
/* DELNEW status indicates that the record corresponds */
/* to a deleted NEW record in the source segment. */
/* DELUPD This status applies only to a backup record. */
/* DELUPD status indicates that the record corresponds */
/* to a deleted UPDATEd record in the source segment. */
/* In EKs that are not shadowed, all records have status OLD. */
/* The following parameters refer to indices within the record */
/* pointer structure: */
/* Index of status indicator: */
/* Each record pointer contains a pointer to its companion: for a */
/* record belonging to a shadowed EK, this is the backup counterpart, */
/* or if the parent EK is itself a backup EK, a pointer to the */
/* record's source record. The pointer is UNINIT (see below) if the */
/* record is unmodified. */
/* Record companion pointers contain record numbers, not record */
/* base addresses. */
/* Index of record's companion pointer: */
/* Each data item is referenced by an integer. The meaning of */
/* this integer depends on the representation of data in the */
/* column to which the data item belongs. Actual lookup of a */
/* data item must be done by subroutines appropriate to the class of */
/* the column to which the item belongs. Note that data items don't */
/* necessarily occupy contiguous ranges of DAS addresses. */
/* Base address of data pointers: */
/* Maximum record pointer size: */
/* Data pointers are given the value UNINIT to start with; this */
/* indicates that the data item is uninitialized. UNINIT is */
/* distinct from the value NULL. NOBACK indicates an uninitialized */
/* backup column entry. */
/* End Include Section: EK Record Pointer Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Segment Descriptor Parameters */
/* eksegdsc.inc Version 8 06-NOV-1995 (NJB) */
/* All `base addresses' referred to below are the addresses */
/* *preceding* the item the base applies to. This convention */
/* enables simplied address calculations in many cases. */
/* Size of segment descriptor. Note: the include file ekcoldsc.inc */
/* must be updated if this parameter is changed. The parameter */
/* CDOFF in that file should be kept equal to SDSCSZ. */
/* Index of the segment type code: */
/* Index of the segment's number. This number is the segment's */
/* index in the list of segments contained in the EK to which */
/* the segment belongs. */
/* Index of the DAS integer base address of the segment's integer */
/* meta-data: */
/* Index of the DAS character base address of the table name: */
/* Index of the segment's column count: */
/* Index of the segment's record count: */
/* Index of the root page number of the record tree: */
/* Index of the root page number of the character data page tree: */
/* Index of the root page number of the double precision data page */
/* tree: */
/* Index of the root page number of the integer data page tree: */
/* Index of the `modified' flag: */
/* Index of the `initialized' flag: */
/* Index of the shadowing flag: */
/* Index of the companion file handle: */
/* Index of the companion segment number: */
/* The next three items are, respectively, the page numbers of the */
/* last character, d.p., and integer data pages allocated by the */
/* segment: */
/* The next three items are, respectively, the page-relative */
/* indices of the last DAS word in use in the segment's */
/* last character, d.p., and integer data pages: */
/* Index of the DAS character base address of the column name list: */
/* The last descriptor element is reserved for future use. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Segment Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Data Types */
/* ektype.inc Version 1 27-DEC-1994 (NJB) */
/* Within the EK system, data types of EK column contents are */
/* represented by integer codes. The codes and their meanings */
/* are listed below. */
/* Integer codes are also used within the DAS system to indicate */
/* data types; the EK system makes no assumptions about compatibility */
/* between the codes used here and those used in the DAS system. */
/* Character type: */
/* Double precision type: */
/* Integer type: */
/* `Time' type: */
/* Within the EK system, time values are represented as ephemeris */
/* seconds past J2000 (TDB), and double precision numbers are used */
/* to store these values. However, since time values require special */
/* treatment both on input and output, and since the `TIME' column */
/* has a special role in the EK specification and code, time values */
/* are identified as a type distinct from double precision numbers. */
/* End Include Section: EK Data Types */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle attached to EK file. */
/* SEGDSC I Segment descriptor. */
/* COLDSC I Column descriptor. */
/* RECPTR I Record pointer. */
/* CVLEN O Length of returned character value. */
/* CVAL O Character value in column entry. */
/* ISNULL O Flag indicating whether column entry is null. */
/* $ Detailed_Input */
/* HANDLE is an EK file handle. */
/* SEGDSC is the descriptor of the segment from which data is */
/* to be read. */
/* COLDSC is the descriptor of the column from which data is */
/* to be read. */
/* RECPTR is a pointer to the record containing the column */
/* entry to be written. */
/* $ Detailed_Output */
/* CVLEN is the length of the returned string value. This */
/* is the index of the last non-blank character of */
/* the string. This definition applies to both fixed- */
/* and variable-length strings. */
/* CVLEN is set to 1 if the column entry is null. */
/* CVAL is the value read from the specified column entry. */
/* If CVAL has insufficient length to hold the */
/* returned string value, the output value is */
/* truncated on the right. Entries that are shorter */
/* than the string length of CVAL are padded with */
/* trailing blanks. */
/* ISNULL is a logical flag indicating whether the entry is */
/* null. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If HANDLE is invalid, the error will be diagnosed by routines */
/* called by this routine. */
/* 2) If the specified column entry has not been initialized, the */
/* error SPICE(UNINITIALIZED) is signaled. */
/* 3) If the ordinal position of the column specified by COLDSC */
/* is out of range, the error SPICE(INVALIDINDEX) is signaled. */
/* 4) If the output string CVAL is too short to accommodate the */
/* returned string value, the output value is truncated on the */
/* right. No error is signaled. */
/* 5) If an I/O error occurs while reading the indicated file, */
/* the error will be diagnosed by routines called by this */
/* routine. */
/* $ Files */
/* See the EK Required Reading for a discussion of the EK file */
/* format. */
/* $ Particulars */
/* This routine is a utility for reading data from class 3 columns. */
/* $ Examples */
/* See EKRCEC. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.3.0, 31-MAY-2010 (NJB) */
/* Bug fix: call to DASRDI was overwriting local memory. This */
/* problem did not affect operation of the routine except on */
/* the Mac/Intel/OSX/ifort/32-bit platform, on which it caused */
/* a segmentation fault when this routine was compiled with */
/* default optimization. */
/* - SPICELIB Version 1.2.0, 23-JUL-1999 (NJB) */
/* Error check for string truncation on output was removed. */
/* This error check interfered with the use of this routine */
/* (via a call to ZZEKRSC) within ZZEKJSRT, which relies on */
/* being able to read into a buffer initial substrings of scalar */
/* data. */
/* - SPICELIB Version 1.1.0, 28-JUL-1997 (NJB) */
/* Error check for string truncation on output was added. */
/* SHORT error message SPICE(UNINITIALIZEDVALUE) was shortened */
/* to SPICE(UNINITIALIZED). Error messages were enhanced so */
/* as to use column names rather than indices. Miscellaneous */
/* header fixes were made. */
/* - SPICELIB Version 1.0.0, 18-OCT-1995 (NJB) */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.2.0, 23-JUL-1999 (NJB) */
/* Error check for string truncation on output was removed. */
/* This error check interfered with the use of this routine */
/* (via a call to ZZEKRSC) within ZZEKJSRT, which relies on */
/* being able to read into a buffer initial substrings of scalar */
/* data. */
/* - SPICELIB Version 1.1.0, 25-JUL-1997 (NJB) */
/* Error check for string truncation on output was added. */
/* SHORT error message SPICE(UNINITIALIZEDVALUE) was shortened */
/* to SPICE(UNINITIALIZED), since the previous string exceeded */
/* the maximum allowed length for the short error message. */
/* Error messages were enhanced so as to use column names rather */
/* than indices. */
/* -& */
/* Non-SPICELIB functions */
/* Local variables */
/* Use discovery check-in. */
/* Make sure the column exists. */
ncols = segdsc[4];
colidx = coldsc[8];
if (colidx < 1 || colidx > ncols) {
recno = zzekrp2n_(handle, &segdsc[1], recptr);
dashlu_(handle, &unit);
chkin_("ZZEKRD03", (ftnlen)8);
setmsg_("Column index = #; valid range is 1:#.SEGNO = #; RECNO = #; "
"EK = #", (ftnlen)65);
errint_("#", &colidx, (ftnlen)1);
errint_("#", &nrec, (ftnlen)1);
errint_("#", &segdsc[1], (ftnlen)1);
errint_("#", &recno, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(INVALIDINDEX)", (ftnlen)19);
chkout_("ZZEKRD03", (ftnlen)8);
return 0;
}
/* Compute the data pointer location, and read both the pointer */
/* and the stored string size. */
ptrloc = *recptr + 2 + colidx;
dasrdi_(handle, &ptrloc, &ptrloc, &datptr);
if (datptr > 0) {
/* Read the value. This is slightly more complicated than */
/* the numeric cases, because the value may be spread across */
/* multiple pages. Also, we must not write past the end of the */
/* output string. */
/* We'll need the number of the page at which the first character */
/* of the string is stored. This page contains at least one */
/* character of the data value. */
zzekgei_(handle, &datptr, cvlen);
/* Set the data pointer to the start of the string data, skipping */
/* over the encoded string length. */
datptr += 5;
/* Computing MIN */
i__1 = *cvlen, i__2 = i_len(cval, cval_len);
n = min(i__1,i__2);
/* Read the available data from the page under consideration. */
zzekpgpg_(&c__1, &datptr, &p, &pbase);
relptr = datptr - pbase;
/* Computing MIN */
i__1 = n, i__2 = 1014 - relptr + 1;
avail = min(i__1,i__2);
b = datptr;
e = datptr + avail - 1;
bpos = 1;
epos = avail;
l = epos - bpos + 1;
dasrdc_(handle, &b, &e, &bpos, &epos, cval, cval_len);
n -= l;
while(n > 0) {
/* Read the forward page pointer from the current page; find */
/* the base address of the referenced page. */
i__1 = pbase + 1015;
zzekgei_(handle, &i__1, &p);
zzekpgbs_(&c__1, &p, &pbase);
avail = min(n,1014);
b = pbase + 1;
e = pbase + avail;
bpos = epos + 1;
epos += avail;
dasrdc_(handle, &b, &e, &bpos, &epos, cval, cval_len);
n -= avail;
bpos = epos + 1;
}
/* Blank-pad CVAL if required. */
if (i_len(cval, cval_len) > epos) {
i__1 = epos;
s_copy(cval + i__1, " ", cval_len - i__1, (ftnlen)1);
}
*isnull = FALSE_;
} else if (datptr == -2) {
/* The value is null. */
*isnull = TRUE_;
*cvlen = 1;
} else if (datptr == -1 || datptr == -3) {
/* The data value is absent. This is an error. */
recno = zzekrp2n_(handle, &segdsc[1], recptr);
dashlu_(handle, &unit);
zzekcnam_(handle, coldsc, column, (ftnlen)32);
chkin_("ZZEKRD03", (ftnlen)8);
setmsg_("Attempted to read uninitialized column entry. SEGNO = #; C"
"OLUMN = #; RECNO = #; EK = #", (ftnlen)87);
errint_("#", &segdsc[1], (ftnlen)1);
errch_("#", column, (ftnlen)1, (ftnlen)32);
errint_("#", &recno, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(UNINITIALIZED)", (ftnlen)20);
chkout_("ZZEKRD03", (ftnlen)8);
return 0;
} else {
/* The data pointer is corrupted. */
recno = zzekrp2n_(handle, &segdsc[1], recptr);
dashlu_(handle, &unit);
zzekcnam_(handle, coldsc, column, (ftnlen)32);
chkin_("ZZEKRD03", (ftnlen)8);
setmsg_("Data pointer is corrupted. SEGNO = #; COLUMN = #; RECNO = "
"#; EK = #", (ftnlen)68);
errint_("#", &segdsc[1], (ftnlen)1);
errch_("#", column, (ftnlen)1, (ftnlen)32);
errint_("#", &recno, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZEKRD03", (ftnlen)8);
return 0;
}
return 0;
} /* zzekrd03_ */
/* Subroutine */ int pzvout_(integer *comm, integer *lout, integer *n,
doublecomplex *cx, integer *idigit, char *ifmt, ftnlen ifmt_len)
{
/* Format strings */
static char fmt_9999[] = "(/1x,a/1x,a)";
static char fmt_9998[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,2(\002"
"(\002,d10.3,\002,\002,d10.3,\002) \002))";
static char fmt_9997[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,1(\002"
"(\002,d10.3,\002,\002,d10.3,\002) \002))";
static char fmt_9988[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,2(\002"
"(\002,d12.5,\002,\002,d12.5,\002) \002))";
static char fmt_9987[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,1(\002"
"(\002,d12.5,\002,\002,d12.5,\002) \002))";
static char fmt_9978[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,2(\002"
"(\002,d14.7,\002,\002,d14.7,\002) \002))";
static char fmt_9977[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,1(\002"
"(\002,d14.7,\002,\002,d14.7,\002) \002))";
static char fmt_9968[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,1(\002"
"(\002,d20.13,\002,\002,d20.13,\002) \002))";
static char fmt_9958[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,4(\002"
"(\002,d10.3,\002,\002,d10.3,\002) \002))";
static char fmt_9957[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,3(\002"
"(\002,d10.3,\002,\002,d10.3,\002) \002))";
static char fmt_9956[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,2(\002"
"(\002,d10.3,\002,\002,d10.3,\002) \002))";
static char fmt_9955[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,1(\002"
"(\002,d10.3,\002,\002,d10.3,\002) \002))";
static char fmt_9948[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,3(\002"
"(\002,d12.5,\002,\002,d12.5,\002) \002))";
static char fmt_9947[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,2(\002"
"(\002,d12.5,\002,\002,d12.5,\002) \002))";
static char fmt_9946[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,1(\002"
"(\002,d12.5,\002,\002,d12.5,\002) \002))";
static char fmt_9938[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,3(\002"
"(\002,d14.7,\002,\002,d14.7,\002) \002))";
static char fmt_9937[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,2(\002"
"(\002,d14.7,\002,\002,d14.7,\002) \002))";
static char fmt_9936[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,1(\002"
"(\002,d14.7,\002,\002,d14.7,\002) \002))";
static char fmt_9928[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,2(\002"
"(\002,d20.13,\002,\002,d20.13,\002) \002))";
static char fmt_9927[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,1(\002"
"(\002,d20.13,\002,\002,d20.13,\002) \002))";
static char fmt_9994[] = "(1x,\002 \002)";
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer i_len(char *, ftnlen), s_wsfe(cilist *), do_fio(integer *, char *,
ftnlen), e_wsfe(void);
/* Local variables */
static integer i__, k1, k2, lll;
static char line[80];
static integer ierr, myid;
extern /* Subroutine */ int mpi_comm_rank__(integer *, integer *, integer
*);
static integer ndigit;
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___10 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___11 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___12 = { 0, 0, 0, fmt_9988, 0 };
static cilist io___13 = { 0, 0, 0, fmt_9987, 0 };
static cilist io___14 = { 0, 0, 0, fmt_9978, 0 };
static cilist io___15 = { 0, 0, 0, fmt_9977, 0 };
static cilist io___16 = { 0, 0, 0, fmt_9968, 0 };
static cilist io___17 = { 0, 0, 0, fmt_9958, 0 };
static cilist io___18 = { 0, 0, 0, fmt_9957, 0 };
static cilist io___19 = { 0, 0, 0, fmt_9956, 0 };
static cilist io___20 = { 0, 0, 0, fmt_9955, 0 };
static cilist io___21 = { 0, 0, 0, fmt_9948, 0 };
static cilist io___22 = { 0, 0, 0, fmt_9947, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9946, 0 };
static cilist io___24 = { 0, 0, 0, fmt_9938, 0 };
static cilist io___25 = { 0, 0, 0, fmt_9937, 0 };
static cilist io___26 = { 0, 0, 0, fmt_9936, 0 };
static cilist io___27 = { 0, 0, 0, fmt_9928, 0 };
static cilist io___28 = { 0, 0, 0, fmt_9927, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9994, 0 };
/* ... */
/* .. MPI VARIABLES AND FUNCTIONS .. */
/* .. Variable Declaration .. */
/* /+ */
/* * */
/* * (C) 1993 by Argonne National Laboratory and Mississipi State University. */
/* * All rights reserved. See COPYRIGHT in top-level directory. */
/* +/ */
/* /+ user include file for MPI programs, with no dependencies +/ */
/* /+ return codes +/ */
/* We handle datatypes by putting the variables that hold them into */
/* common. This way, a Fortran program can directly use the various */
/* datatypes and can even give them to C programs. */
/* MPI_BOTTOM needs to be a known address; here we put it at the */
/* beginning of the common block. The point-to-point and collective */
/* routines know about MPI_BOTTOM, but MPI_TYPE_STRUCT as yet does not. */
/* The types MPI_INTEGER1,2,4 and MPI_REAL4,8 are OPTIONAL. */
/* Their values are zero if they are not available. Note that */
/* using these reduces the portability of code (though may enhance */
/* portability between Crays and other systems) */
/* All other MPI routines are subroutines */
/* The attribute copy/delete functions are symbols that can be passed */
/* to MPI routines */
/* ... SPECIFICATIONS FOR ARGUMENTS */
/* ... */
/* ... SPECIFICATIONS FOR LOCAL VARIABLES */
/* ... */
/* ... FIRST EXECUTABLE STATEMENT */
/* Determine processor configuration */
/* Parameter adjustments */
--cx;
/* Function Body */
mpi_comm_rank__(comm, &myid, &ierr);
/* .. Only Processor 0 will write to file LOUT .. */
if (myid == 0) {
/* Computing MIN */
i__1 = i_len(ifmt, ifmt_len);
lll = min(i__1,80);
i__1 = lll;
for (i__ = 1; i__ <= i__1; ++i__) {
*(unsigned char *)&line[i__ - 1] = '-';
/* L10: */
}
for (i__ = lll + 1; i__ <= 80; ++i__) {
*(unsigned char *)&line[i__ - 1] = ' ';
/* L20: */
}
io___6.ciunit = *lout;
s_wsfe(&io___6);
do_fio(&c__1, ifmt, ifmt_len);
do_fio(&c__1, line, lll);
e_wsfe();
if (*n <= 0) {
return 0;
}
ndigit = *idigit;
if (*idigit == 0) {
ndigit = 4;
}
/* ======================================================================= */
/* CODE FOR OUTPUT USING 72 COLUMNS FORMAT */
/* ======================================================================= */
if (*idigit < 0) {
ndigit = -(*idigit);
if (ndigit <= 4) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 2) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 1;
k2 = min(i__2,i__3);
if (k1 != *n) {
io___10.ciunit = *lout;
s_wsfe(&io___10);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__2, (char *)&cx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
} else {
io___11.ciunit = *lout;
s_wsfe(&io___11);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__2, (char *)&cx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
}
/* L30: */
}
} else if (ndigit <= 6) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 2) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 1;
k2 = min(i__2,i__3);
if (k1 != *n) {
io___12.ciunit = *lout;
s_wsfe(&io___12);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__2, (char *)&cx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
} else {
io___13.ciunit = *lout;
s_wsfe(&io___13);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__2, (char *)&cx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
}
/* L40: */
}
} else if (ndigit <= 8) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 2) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 1;
k2 = min(i__2,i__3);
if (k1 != *n) {
io___14.ciunit = *lout;
s_wsfe(&io___14);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__2, (char *)&cx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
} else {
io___15.ciunit = *lout;
s_wsfe(&io___15);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__2, (char *)&cx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
}
/* L50: */
}
} else {
i__1 = *n;
for (k1 = 1; k1 <= i__1; ++k1) {
io___16.ciunit = *lout;
s_wsfe(&io___16);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__2, (char *)&cx[i__], (ftnlen)sizeof(doublereal)
);
e_wsfe();
/* L60: */
}
}
/* ======================================================================= */
/* CODE FOR OUTPUT USING 132 COLUMNS FORMAT */
/* ======================================================================= */
} else {
if (ndigit <= 4) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 4) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 3;
k2 = min(i__2,i__3);
if (k1 + 3 <= *n) {
io___17.ciunit = *lout;
s_wsfe(&io___17);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__2, (char *)&cx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
} else if (k1 + 3 - *n == 1) {
io___18.ciunit = *lout;
s_wsfe(&io___18);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__2, (char *)&cx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
} else if (k1 + 3 - *n == 2) {
io___19.ciunit = *lout;
s_wsfe(&io___19);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__2, (char *)&cx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
} else if (k1 + 3 - *n == 1) {
io___20.ciunit = *lout;
s_wsfe(&io___20);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__2, (char *)&cx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
}
/* L70: */
}
} else if (ndigit <= 6) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 3) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 2;
k2 = min(i__2,i__3);
if (k1 + 2 <= *n) {
io___21.ciunit = *lout;
s_wsfe(&io___21);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__2, (char *)&cx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
} else if (k1 + 2 - *n == 1) {
io___22.ciunit = *lout;
s_wsfe(&io___22);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__2, (char *)&cx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
} else if (k1 + 2 - *n == 2) {
io___23.ciunit = *lout;
s_wsfe(&io___23);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__2, (char *)&cx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
}
/* L80: */
}
} else if (ndigit <= 8) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 3) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 2;
k2 = min(i__2,i__3);
if (k1 + 2 <= *n) {
io___24.ciunit = *lout;
s_wsfe(&io___24);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__2, (char *)&cx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
} else if (k1 + 2 - *n == 1) {
io___25.ciunit = *lout;
s_wsfe(&io___25);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__2, (char *)&cx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
} else if (k1 + 2 - *n == 2) {
io___26.ciunit = *lout;
s_wsfe(&io___26);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__2, (char *)&cx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
}
/* L90: */
}
} else {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 2) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 1;
k2 = min(i__2,i__3);
if (k1 + 2 <= *n) {
io___27.ciunit = *lout;
s_wsfe(&io___27);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__2, (char *)&cx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
} else if (k1 + 2 - *n == 1) {
io___28.ciunit = *lout;
s_wsfe(&io___28);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__2, (char *)&cx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
}
/* L100: */
}
}
}
io___29.ciunit = *lout;
s_wsfe(&io___29);
e_wsfe();
}
return 0;
/* ======================================================================= */
/* FORMAT FOR 72 COLUMNS */
/* ======================================================================= */
/* DISPLAY 4 SIGNIFICANT DIGITS */
/* DISPLAY 6 SIGNIFICANT DIGITS */
/* DISPLAY 8 SIGNIFICANT DIGITS */
/* DISPLAY 13 SIGNIFICANT DIGITS */
/* ========================================================================= */
/* FORMAT FOR 132 COLUMNS */
/* ========================================================================= */
/* DISPLAY 4 SIGNIFICANT DIGITS */
/* DISPLAY 6 SIGNIFICANT DIGITS */
/* DISPLAY 8 SIGNIFICANT DIGITS */
/* DISPLAY 13 SIGNIFICANT DIGITS */
} /* pzvout_ */
/* Subroutine */ int zmout_(integer *lout, integer *m, integer *n,
doublecomplex *a, integer *lda, integer *idigit, char *ifmt, ftnlen
ifmt_len)
{
/* Initialized data */
static char icol[1*3] = "C" "o" "l";
/* Format strings */
static char fmt_9999[] = "(/1x,a/1x,a)";
static char fmt_9998[] = "(11x,4(9x,3a1,i4,9x))";
static char fmt_9994[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,2(\002("
"\002,d10.3,\002,\002,d10.3,\002) \002))";
static char fmt_9984[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,1(\002("
"\002,d10.3,\002,\002,d10.3,\002) \002))";
static char fmt_9997[] = "(10x,4(11x,3a1,i4,11x))";
static char fmt_9993[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,2(\002("
"\002,d12.5,\002,\002,d12.5,\002) \002))";
static char fmt_9983[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,1(\002("
"\002,d12.5,\002,\002,d12.5,\002) \002))";
static char fmt_9996[] = "(10x,3(13x,3a1,i4,13x))";
static char fmt_9992[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,2(\002("
"\002,d14.7,\002,\002,d14.7,\002) \002))";
static char fmt_9982[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,1(\002("
"\002,d14.7,\002,\002,d14.7,\002) \002))";
static char fmt_9995[] = "(12x,2(18x,3a1,i4,18x))";
static char fmt_9991[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,1(\002("
"\002,d20.13,\002,\002,d20.13,\002)\002))";
static char fmt_9974[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,4(\002("
"\002,d10.3,\002,\002,d10.3,\002) \002))";
static char fmt_9964[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,3(\002("
"\002,d10.3,\002,\002,d10.3,\002) \002))";
static char fmt_9954[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,2(\002("
"\002,d10.3,\002,\002,d10.3,\002) \002))";
static char fmt_9944[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,1(\002("
"\002,d10.3,\002,\002,d10.3,\002) \002))";
static char fmt_9973[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,3(\002("
"\002,d12.5,\002,\002,d12.5,\002) \002))";
static char fmt_9963[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,2(\002("
"\002,d12.5,\002,\002,d12.5,\002) \002))";
static char fmt_9953[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,1(\002("
"\002,d12.5,\002,\002,d12.5,\002) \002))";
static char fmt_9972[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,3(\002("
"\002,d14.7,\002,\002,d14.7,\002) \002))";
static char fmt_9962[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,2(\002("
"\002,d14.7,\002,\002,d14.7,\002) \002))";
static char fmt_9952[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,1(\002("
"\002,d14.7,\002,\002,d14.7,\002) \002))";
static char fmt_9971[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,2(\002("
"\002,d20.13,\002,\002,d20.13,\002) \002))";
static char fmt_9961[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,1(\002("
"\002,d20.13,\002,\002,d20.13,\002) \002))";
static char fmt_9990[] = "(1x,\002 \002)";
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
static integer i__, j, k1, k2, lll;
static char line[80];
static integer ndigit;
/* Fortran I/O blocks */
static cilist io___5 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___9 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___10 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___12 = { 0, 0, 0, fmt_9984, 0 };
static cilist io___13 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___14 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___15 = { 0, 0, 0, fmt_9983, 0 };
static cilist io___16 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___17 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___18 = { 0, 0, 0, fmt_9982, 0 };
static cilist io___19 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___20 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___21 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___22 = { 0, 0, 0, fmt_9974, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9964, 0 };
static cilist io___24 = { 0, 0, 0, fmt_9954, 0 };
static cilist io___25 = { 0, 0, 0, fmt_9944, 0 };
static cilist io___26 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___27 = { 0, 0, 0, fmt_9973, 0 };
static cilist io___28 = { 0, 0, 0, fmt_9963, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9953, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9972, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9962, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9952, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9971, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9961, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9990, 0 };
/* ... */
/* ... SPECIFICATIONS FOR ARGUMENTS */
/* ... */
/* ... SPECIFICATIONS FOR LOCAL VARIABLES */
/* ... */
/* ... SPECIFICATIONS INTRINSICS */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
/* ... */
/* ... FIRST EXECUTABLE STATEMENT */
/* Computing MIN */
i__1 = i_len(ifmt, ifmt_len);
lll = min(i__1,80);
i__1 = lll;
for (i__ = 1; i__ <= i__1; ++i__) {
*(unsigned char *)&line[i__ - 1] = '-';
/* L10: */
}
for (i__ = lll + 1; i__ <= 80; ++i__) {
*(unsigned char *)&line[i__ - 1] = ' ';
/* L20: */
}
io___5.ciunit = *lout;
s_wsfe(&io___5);
do_fio(&c__1, ifmt, ifmt_len);
do_fio(&c__1, line, lll);
e_wsfe();
if (*m <= 0 || *n <= 0 || *lda <= 0) {
return 0;
}
ndigit = *idigit;
if (*idigit == 0) {
ndigit = 4;
}
/* ======================================================================= */
/* CODE FOR OUTPUT USING 72 COLUMNS FORMAT */
/* ======================================================================= */
if (*idigit < 0) {
ndigit = -(*idigit);
if (ndigit <= 4) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 2) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 1;
k2 = min(i__2,i__3);
io___9.ciunit = *lout;
s_wsfe(&io___9);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
if (k1 != *n) {
io___10.ciunit = *lout;
s_wsfe(&io___10);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(doublereal));
}
e_wsfe();
} else {
io___12.ciunit = *lout;
s_wsfe(&io___12);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(doublereal));
}
e_wsfe();
}
/* L30: */
}
/* L40: */
}
} else if (ndigit <= 6) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 2) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 1;
k2 = min(i__2,i__3);
io___13.ciunit = *lout;
s_wsfe(&io___13);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
if (k1 != *n) {
io___14.ciunit = *lout;
s_wsfe(&io___14);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(doublereal));
}
e_wsfe();
} else {
io___15.ciunit = *lout;
s_wsfe(&io___15);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(doublereal));
}
e_wsfe();
}
/* L50: */
}
/* L60: */
}
} else if (ndigit <= 8) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 2) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 1;
k2 = min(i__2,i__3);
io___16.ciunit = *lout;
s_wsfe(&io___16);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
if (k1 != *n) {
io___17.ciunit = *lout;
s_wsfe(&io___17);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(doublereal));
}
e_wsfe();
} else {
io___18.ciunit = *lout;
s_wsfe(&io___18);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(doublereal));
}
e_wsfe();
}
/* L70: */
}
/* L80: */
}
} else {
i__1 = *n;
for (k1 = 1; k1 <= i__1; ++k1) {
io___19.ciunit = *lout;
s_wsfe(&io___19);
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
io___20.ciunit = *lout;
s_wsfe(&io___20);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__2, (char *)&a[i__ + k1 * a_dim1], (ftnlen)
sizeof(doublereal));
e_wsfe();
/* L90: */
}
/* L100: */
}
}
/* ======================================================================= */
/* CODE FOR OUTPUT USING 132 COLUMNS FORMAT */
/* ======================================================================= */
} else {
if (ndigit <= 4) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 4) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 3;
k2 = min(i__2,i__3);
io___21.ciunit = *lout;
s_wsfe(&io___21);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
if (k1 + 3 <= *n) {
io___22.ciunit = *lout;
s_wsfe(&io___22);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(doublereal));
}
e_wsfe();
} else if (k1 + 3 - *n == 1) {
io___23.ciunit = *lout;
s_wsfe(&io___23);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(doublereal));
}
e_wsfe();
} else if (k1 + 3 - *n == 2) {
io___24.ciunit = *lout;
s_wsfe(&io___24);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(doublereal));
}
e_wsfe();
} else if (k1 + 3 - *n == 3) {
io___25.ciunit = *lout;
s_wsfe(&io___25);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(doublereal));
}
e_wsfe();
}
/* L110: */
}
/* L120: */
}
} else if (ndigit <= 6) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 3) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 2;
k2 = min(i__2,i__3);
io___26.ciunit = *lout;
s_wsfe(&io___26);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
if (k1 + 2 <= *n) {
io___27.ciunit = *lout;
s_wsfe(&io___27);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(doublereal));
}
e_wsfe();
} else if (k1 + 2 - *n == 1) {
io___28.ciunit = *lout;
s_wsfe(&io___28);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(doublereal));
}
e_wsfe();
} else if (k1 + 2 - *n == 2) {
io___29.ciunit = *lout;
s_wsfe(&io___29);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(doublereal));
}
e_wsfe();
}
/* L130: */
}
/* L140: */
}
} else if (ndigit <= 8) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 3) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 2;
k2 = min(i__2,i__3);
io___30.ciunit = *lout;
s_wsfe(&io___30);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
if (k1 + 2 <= *n) {
io___31.ciunit = *lout;
s_wsfe(&io___31);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(doublereal));
}
e_wsfe();
} else if (k1 + 2 - *n == 1) {
io___32.ciunit = *lout;
s_wsfe(&io___32);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(doublereal));
}
e_wsfe();
} else if (k1 + 2 - *n == 2) {
io___33.ciunit = *lout;
s_wsfe(&io___33);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(doublereal));
}
e_wsfe();
}
/* L150: */
}
/* L160: */
}
} else {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 2) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 1;
k2 = min(i__2,i__3);
io___34.ciunit = *lout;
s_wsfe(&io___34);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
if (k1 + 1 <= *n) {
io___35.ciunit = *lout;
s_wsfe(&io___35);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(doublereal));
}
e_wsfe();
} else {
io___36.ciunit = *lout;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(doublereal));
}
e_wsfe();
}
/* L170: */
}
/* L180: */
}
}
}
io___37.ciunit = *lout;
s_wsfe(&io___37);
e_wsfe();
/* ======================================================== */
/* FORMAT FOR 72 COLUMN */
/* ======================================================== */
/* DISPLAY 4 SIGNIFICANT DIGITS */
/* DISPLAY 6 SIGNIFICANT DIGITS */
/* DISPLAY 8 SIGNIFICANT DIGITS */
/* DISPLAY 13 SIGNIFICANT DIGITS */
/* ======================================================== */
/* FORMAT FOR 132 COLUMN */
/* ======================================================== */
/* DISPLAY 4 SIGNIFICANT DIGIT */
/* DISPLAY 6 SIGNIFICANT DIGIT */
/* DISPLAY 8 SIGNIFICANT DIGIT */
/* DISPLAY 13 SIGNIFICANT DIGIT */
return 0;
} /* zmout_ */
/* $Procedure EXPFNM_1 ( Expand a filename ) */
/* Subroutine */ int expfnm_1__(char *infil, char *outfil, ftnlen infil_len,
ftnlen outfil_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen);
/* Local variables */
integer need, keep;
char word[255];
integer blank;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
integer inlen, slash;
extern integer rtrim_(char *, ftnlen);
integer dirlen;
extern /* Subroutine */ int getenv_(char *, char *, ftnlen, ftnlen);
integer wrdlen;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), repsub_(char *, integer *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen), setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen);
integer outlen;
extern logical return_(void);
char dir[255];
extern integer pos_(char *, char *, integer *, ftnlen, ftnlen);
/* $ Abstract */
/* Given a filename, expand it to be a full filename. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* FILES */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* INFIL I The filename to be expanded. */
/* OUTFIL O The expanded filename. */
/* $ Detailed_Input */
/* INFIL is the filename to be expanded. */
/* $ Detailed_Output */
/* OUTFIL is the expanded filename. If no expansion could be */
/* done, the value of OUTFIL is equal to the value of */
/* INFIL. OUTFIL may not overwrite INFIL. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the input filename is blank, begins with blank characters, */
/* or has embedded blanks in it, the error SPICE(BADFILENAME) */
/* is signalled. */
/* 2) If the expanded filename is too long to fit into the */
/* output string, the error SPICE(STRINGTOOSMALL) is signalled. */
/* 3) The output string may not overwrite the input string. */
/* 4) If no expansion of the input filename can be done, the */
/* output filename is assigned the value of the input filename. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The input filename may not be blank, begin with blank characters, */
/* nor may it it contain embedded blanks. As a general rule, */
/* SPICELIB routines do not allow blank characters as part of a */
/* filename. */
/* Unix platforms: */
/* On the Unix platforms, a filename containing an environment */
/* variable must be expanded completely before FORTRAN can do */
/* anything with it. FORTRAN interacts directly with the kernel, and */
/* as a result does not pass input filenames through the shell */
/* for expansion of environment variables. */
/* VAX/VMS, Alpha/OpenVMS platforms: */
/* The operating system does filname expansion itself, so this */
/* routine currently does not expand the name. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* Unix platforms: */
/* This routine cannot be used to expand a file name whose form */
/* is '~xxx', where xxx is an account name. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* $ Version */
/* - Beta Version 3.25.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - Beta Version 3.24.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - Beta Version 3.23.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - Beta Version 3.22.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - Beta Version 3.21.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - Beta Version 3.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - Beta Version 3.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - Beta Version 3.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - Beta Version 3.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - Beta Version 3.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - Beta Version 3.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - Beta Version 3.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - Beta Version 3.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - Beta Version 3.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - Beta Version 3.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - Beta Version 3.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - Beta Version 3.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - Beta Version 3.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - Beta Version 3.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - Beta Version 3.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - Beta Version 3.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - Beta Version 3.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - Beta Version 3.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - Beta Version 3.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - Beta Version 3.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - Beta Version 3.0.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - Beta Version 3.0.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are WIN-NT */
/* - Beta Version 3.0.3, 21-SEP-1999 (NJB) */
/* CSPICE environments were added. Some typos were corrected. */
/* - Beta Version 3.0.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - Beta Version 3.0.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - Beta Version 3.0.0, 05-APR-1998 (NJB) */
/* Added references to the PC-LINUX environment. */
/* - Beta Version 2.1.0, 5-JAN-1995 (HAN) */
/* Removed Sun Solaris environment since it is now the same */
/* as the Sun OS 4.1.x environment. */
/* Removed DEC Alpha/OpenVMS environment since it is now the */
/* same as the VAX environment. */
/* - Beta Version 2.0.0, 08-JUL-1994 (HAN) */
/* The capability of resolving a Unix filename that contains */
/* an environment variable directory specificiation plus a */
/* filename has been added. */
/* - Beta Version 1.0.0, 06-APR-1992 (HAN) */
/* -& */
/* $ Index_Entries */
/* expand a filename */
/* -& */
/* SPICELIB functions */
/* Parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("EXPFNM_1", (ftnlen)8);
}
/* If the input filename is blank, that's an error. */
if (s_cmp(infil, " ", infil_len, (ftnlen)1) == 0) {
setmsg_("The input filename '#' was blank.", (ftnlen)33);
errch_("#", infil, (ftnlen)1, infil_len);
sigerr_("SPICE(BADFILENAME)", (ftnlen)18);
chkout_("EXPFNM_1", (ftnlen)8);
return 0;
}
/* If there are blanks anywhere in the filename, SPICELIB */
/* considers the filename to be invalid. */
blank = pos_(infil, " ", &c__1, rtrim_(infil, infil_len), (ftnlen)1);
if (blank != 0) {
setmsg_("The input filename '#' had blank characters in it.", (ftnlen)
50);
errch_("#", infil, (ftnlen)1, infil_len);
sigerr_("SPICE(BADFILENAME)", (ftnlen)18);
chkout_("EXPFNM_1", (ftnlen)8);
return 0;
}
/* Look for a slash in the filename. */
slash = pos_(infil, "/", &c__1, infil_len, (ftnlen)1);
/* If we found a slash in a position other than the first */
/* character position, we want to examine the word that */
/* comes before it just in case it is an environment */
/* variable. */
if (slash > 1) {
s_copy(word, infil, (ftnlen)255, slash - 1);
getenv_(word, dir, (ftnlen)255, (ftnlen)255);
/* If the word was an environment variable, then construct */
/* the expanded filename. If it wasn't, just return the original */
/* input filename. */
if (s_cmp(dir, " ", (ftnlen)255, (ftnlen)1) != 0) {
s_copy(outfil, infil, outfil_len, infil_len);
inlen = rtrim_(infil, infil_len);
wrdlen = rtrim_(word, (ftnlen)255);
dirlen = rtrim_(dir, (ftnlen)255);
outlen = i_len(outfil, outfil_len);
keep = inlen - wrdlen;
need = keep + dirlen;
/* If the output filename length is not long enough for */
/* the substitution, signal an error. Otherwise, substitute */
/* in the new value. */
if (need > outlen) {
setmsg_("The expanded filename for the input filename '#' ex"
"ceeded the length of the output filename. The expand"
"ed name was # characters too long.", (ftnlen)137);
errch_("#", infil, (ftnlen)1, infil_len);
i__1 = need - outlen;
errint_("#", &i__1, (ftnlen)1);
sigerr_("SPICE(STRINGTOOSMALL)", (ftnlen)21);
chkout_("EXPFNM_1", (ftnlen)8);
return 0;
} else {
i__1 = slash - 1;
repsub_(infil, &c__1, &i__1, dir, outfil, infil_len, rtrim_(
dir, (ftnlen)255), outfil_len);
}
} else {
s_copy(outfil, infil, outfil_len, infil_len);
}
} else {
/* No slashes are in the filename, so it's just an easy case. */
/* It's possible that the entire filename is an environment */
/* variable. If it's not, then just return the input filename. */
getenv_(infil, outfil, infil_len, outfil_len);
if (s_cmp(outfil, " ", outfil_len, (ftnlen)1) == 0) {
s_copy(outfil, infil, outfil_len, infil_len);
}
}
chkout_("EXPFNM_1", (ftnlen)8);
return 0;
} /* expfnm_1__ */
/* Subroutine */ int sprtbg_(char *subnam, integer *ntypes, logical *dotype,
integer *nsizes, integer *nn, integer *inparm, char *pnames, integer *
nparms, integer *np1, integer *np2, integer *np3, integer *np4,
integer *np5, integer *np6, real *ops, integer *ldo1, integer *ldo2,
real *times, integer *ldt1, integer *ldt2, real *rwork, logical *
llwork, integer *nout, ftnlen subnam_len, ftnlen pnames_len)
{
/* Format strings */
static char fmt_9999[] = "(///\002 ****** Results for \002,a,\002 *****"
"*\002)";
static char fmt_9995[] = "(5x,:\002with \002,4(a,\002=\002,i5,:\002, "
"\002)/10x,2(a,\002=\002,i5,:\002, \002))";
static char fmt_9980[] = "(\002( 5X, : I5 , 6( \002,i2,\002X, I5, : ) "
")\002)";
static char fmt_9981[] = "(\002( 5X, : 'line ' , 6( \002,i2,\002X, A, : "
") )\002)";
static char fmt_9996[] = "(/\002 *** Time in seconds ***\002)";
static char fmt_9997[] = "(/\002 *** Number of floating-point operations"
" ***\002)";
static char fmt_9998[] = "(/\002 *** Speed in megaflops ***\002)";
/* System generated locals */
integer ops_dim1, ops_dim2, ops_offset, times_dim1, times_dim2,
times_offset, i__1, i__2, i__3;
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
i_len(char *, ftnlen), s_wsfi(icilist *), e_wsfi(void);
/* Local variables */
static integer ipar, i__, j, ipada, ipadi, iline, iinfo;
static logical ltemp;
static integer jp, js, jt;
static char frmata[40], frmati[40];
static integer ilines;
extern doublereal smflop_(real *, real *, integer *);
extern /* Subroutine */ int sprtbs_(char *, char *, integer *, logical *,
integer *, integer *, integer *, logical *, real *, integer *,
integer *, integer *, ftnlen, ftnlen);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___6 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___7 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___8 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___9 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___10 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___11 = { 0, 0, 0, fmt_9995, 0 };
static icilist io___15 = { 0, frmati, 0, fmt_9980, 40, 1 };
static icilist io___18 = { 0, frmata, 0, fmt_9981, 40, 1 };
static cilist io___19 = { 0, 0, 0, frmata, 0 };
static cilist io___20 = { 0, 0, 0, frmati, 0 };
static cilist io___21 = { 0, 0, 0, frmati, 0 };
static cilist io___22 = { 0, 0, 0, frmati, 0 };
static cilist io___23 = { 0, 0, 0, frmati, 0 };
static cilist io___24 = { 0, 0, 0, frmati, 0 };
static cilist io___25 = { 0, 0, 0, frmati, 0 };
static cilist io___26 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___27 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9998, 0 };
#define times_ref(a_1,a_2,a_3) times[((a_3)*times_dim2 + (a_2))*\
times_dim1 + a_1]
#define pnames_ref(a_0,a_1) &pnames[(a_1)*pnames_len + a_0]
#define ops_ref(a_1,a_2,a_3) ops[((a_3)*ops_dim2 + (a_2))*ops_dim1 + a_1]
/* -- LAPACK timing routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
SPRTBG prints out timing information for the eigenvalue routines.
The table has NTYPES block rows and NSIZES columns, with NPARMS
individual rows in each block row. There are INPARM quantities
which depend on rows (currently, INPARM <= 4).
Arguments (none are modified)
=========
SUBNAM - CHARACTER*(*)
The label for the output.
NTYPES - INTEGER
The number of values of DOTYPE, and also the
number of sets of rows of the table.
DOTYPE - LOGICAL array of dimension( NTYPES )
If DOTYPE(j) is .TRUE., then block row j (which includes
data from RESLTS( i, j, k ), for all i and k) will be
printed. If DOTYPE(j) is .FALSE., then block row j will
not be printed.
NSIZES - INTEGER
The number of values of NN, and also the
number of columns of the table.
NN - INTEGER array of dimension( NSIZES )
The values of N used to label each column.
INPARM - INTEGER
The number of different parameters which are functions of
the row number. At the moment, INPARM <= 4.
PNAMES - CHARACTER*(*) array of dimension( INPARM )
The label for the columns.
NPARMS - INTEGER
The number of values for each "parameter", i.e., the
number of rows for each value of DOTYPE.
NP1 - INTEGER array of dimension( NPARMS )
The first quantity which depends on row number.
NP2 - INTEGER array of dimension( NPARMS )
The second quantity which depends on row number.
NP3 - INTEGER array of dimension( NPARMS )
The third quantity which depends on row number.
NP4 - INTEGER array of dimension( NPARMS )
The fourth quantity which depends on row number.
NP5 - INTEGER array of dimension( NPARMS )
The fifth quantity which depends on row number.
NP6 - INTEGER array of dimension( NPARMS )
The sixth quantity which depends on row number.
OPS - REAL array of dimension( LDT1, LDT2, NSIZES )
The operation counts. The first index indicates the row,
the second index indicates the block row, and the last
indicates the column.
LDO1 - INTEGER
The first dimension of OPS. It must be at least
min( 1, NPARMS ).
LDO2 - INTEGER
The second dimension of OPS. It must be at least
min( 1, NTYPES ).
TIMES - REAL array of dimension( LDT1, LDT2, NSIZES )
The times (in seconds). The first index indicates the row,
the second index indicates the block row, and the last
indicates the column.
LDT1 - INTEGER
The first dimension of RESLTS. It must be at least
min( 1, NPARMS ).
LDT2 - INTEGER
The second dimension of RESLTS. It must be at least
min( 1, NTYPES ).
RWORK - REAL array of dimension( NSIZES*NTYPES*NPARMS )
Real workspace.
Modified.
LLWORK - LOGICAL array of dimension( NPARMS )
Logical workspace. It is used to turn on or off specific
lines in the output. If LLWORK(i) is .TRUE., then row i
(which includes data from OPS(i,j,k) or TIMES(i,j,k) for
all j and k) will be printed. If LLWORK(i) is
.FALSE., then row i will not be printed.
Modified.
NOUT - INTEGER
The output unit number on which the table
is to be printed. If NOUT <= 0, no output is printed.
=====================================================================
First line
Parameter adjustments */
--dotype;
--nn;
pnames -= pnames_len;
--llwork;
--np1;
--np2;
--np3;
--np4;
--np5;
--np6;
ops_dim1 = *ldo1;
ops_dim2 = *ldo2;
ops_offset = 1 + ops_dim1 * (1 + ops_dim2 * 1);
ops -= ops_offset;
times_dim1 = *ldt1;
times_dim2 = *ldt2;
times_offset = 1 + times_dim1 * (1 + times_dim2 * 1);
times -= times_offset;
--rwork;
/* Function Body */
io___1.ciunit = *nout;
s_wsfe(&io___1);
do_fio(&c__1, subnam, subnam_len);
e_wsfe();
/* Set up which lines are to be printed. */
llwork[1] = TRUE_;
ilines = 1;
i__1 = *nparms;
for (ipar = 2; ipar <= i__1; ++ipar) {
llwork[ipar] = TRUE_;
i__2 = ipar - 1;
for (j = 1; j <= i__2; ++j) {
ltemp = FALSE_;
if (*inparm >= 1 && np1[j] != np1[ipar]) {
ltemp = TRUE_;
}
if (*inparm >= 2 && np2[j] != np2[ipar]) {
ltemp = TRUE_;
}
if (*inparm >= 3 && np3[j] != np3[ipar]) {
ltemp = TRUE_;
}
if (*inparm >= 4 && np4[j] != np4[ipar]) {
ltemp = TRUE_;
}
if (*inparm >= 5 && np5[j] != np5[ipar]) {
ltemp = TRUE_;
}
if (*inparm >= 6 && np6[j] != np6[ipar]) {
ltemp = TRUE_;
}
if (! ltemp) {
llwork[ipar] = FALSE_;
}
/* L10: */
}
if (llwork[ipar]) {
++ilines;
}
/* L20: */
}
if (ilines == 1) {
if (*inparm == 1) {
io___6.ciunit = *nout;
s_wsfe(&io___6);
do_fio(&c__1, pnames_ref(0, 1), pnames_len);
do_fio(&c__1, (char *)&np1[1], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 2) {
io___7.ciunit = *nout;
s_wsfe(&io___7);
do_fio(&c__1, pnames_ref(0, 1), pnames_len);
do_fio(&c__1, (char *)&np1[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 2), pnames_len);
do_fio(&c__1, (char *)&np2[1], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 3) {
io___8.ciunit = *nout;
s_wsfe(&io___8);
do_fio(&c__1, pnames_ref(0, 1), pnames_len);
do_fio(&c__1, (char *)&np1[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 2), pnames_len);
do_fio(&c__1, (char *)&np2[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 3), pnames_len);
do_fio(&c__1, (char *)&np3[1], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 4) {
io___9.ciunit = *nout;
s_wsfe(&io___9);
do_fio(&c__1, pnames_ref(0, 1), pnames_len);
do_fio(&c__1, (char *)&np1[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 2), pnames_len);
do_fio(&c__1, (char *)&np2[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 3), pnames_len);
do_fio(&c__1, (char *)&np3[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 4), pnames_len);
do_fio(&c__1, (char *)&np4[1], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 5) {
io___10.ciunit = *nout;
s_wsfe(&io___10);
do_fio(&c__1, pnames_ref(0, 1), pnames_len);
do_fio(&c__1, (char *)&np1[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 2), pnames_len);
do_fio(&c__1, (char *)&np2[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 3), pnames_len);
do_fio(&c__1, (char *)&np3[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 4), pnames_len);
do_fio(&c__1, (char *)&np4[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 5), pnames_len);
do_fio(&c__1, (char *)&np5[1], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 6) {
io___11.ciunit = *nout;
s_wsfe(&io___11);
do_fio(&c__1, pnames_ref(0, 1), pnames_len);
do_fio(&c__1, (char *)&np1[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 2), pnames_len);
do_fio(&c__1, (char *)&np2[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 3), pnames_len);
do_fio(&c__1, (char *)&np3[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 4), pnames_len);
do_fio(&c__1, (char *)&np4[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 5), pnames_len);
do_fio(&c__1, (char *)&np5[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 6), pnames_len);
do_fio(&c__1, (char *)&np6[1], (ftnlen)sizeof(integer));
e_wsfe();
}
} else {
iline = 0;
/* Compute output format statement.
Computing MAX */
i__1 = i_len(pnames_ref(0, 1), pnames_len) - 3;
ipadi = max(i__1,1);
s_wsfi(&io___15);
do_fio(&c__1, (char *)&ipadi, (ftnlen)sizeof(integer));
e_wsfi();
ipada = ipadi + 5 - i_len(pnames_ref(0, 1), pnames_len);
s_wsfi(&io___18);
do_fio(&c__1, (char *)&ipada, (ftnlen)sizeof(integer));
e_wsfi();
io___19.ciunit = *nout;
s_wsfe(&io___19);
i__1 = min(6,*inparm);
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, pnames_ref(0, j), pnames_len);
}
e_wsfe();
i__1 = *nparms;
for (j = 1; j <= i__1; ++j) {
if (llwork[j]) {
++iline;
if (*inparm == 1) {
io___20.ciunit = *nout;
s_wsfe(&io___20);
do_fio(&c__1, (char *)&iline, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np1[j], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 2) {
io___21.ciunit = *nout;
s_wsfe(&io___21);
do_fio(&c__1, (char *)&iline, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np1[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np2[j], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 3) {
io___22.ciunit = *nout;
s_wsfe(&io___22);
do_fio(&c__1, (char *)&iline, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np1[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np2[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np3[j], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 4) {
io___23.ciunit = *nout;
s_wsfe(&io___23);
do_fio(&c__1, (char *)&iline, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np1[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np2[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np3[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np4[j], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 5) {
io___24.ciunit = *nout;
s_wsfe(&io___24);
do_fio(&c__1, (char *)&iline, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np1[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np2[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np3[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np4[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np5[j], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 6) {
io___25.ciunit = *nout;
s_wsfe(&io___25);
do_fio(&c__1, (char *)&iline, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np1[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np2[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np3[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np4[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np5[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np6[j], (ftnlen)sizeof(integer));
e_wsfe();
}
}
/* L30: */
}
}
/* Execution Times */
io___26.ciunit = *nout;
s_wsfe(&io___26);
e_wsfe();
sprtbs_("Type", "N ", ntypes, &dotype[1], nsizes, &nn[1], nparms, &llwork[
1], ×[times_offset], ldt1, ldt2, nout, (ftnlen)4, (ftnlen)2);
/* Operation Counts */
io___27.ciunit = *nout;
s_wsfe(&io___27);
e_wsfe();
sprtbs_("Type", "N ", ntypes, &dotype[1], nsizes, &nn[1], nparms, &llwork[
1], &ops[ops_offset], ldo1, ldo2, nout, (ftnlen)4, (ftnlen)2);
/* Megaflop Rates */
iinfo = 0;
i__1 = *nsizes;
for (js = 1; js <= i__1; ++js) {
i__2 = *ntypes;
for (jt = 1; jt <= i__2; ++jt) {
if (dotype[jt]) {
i__3 = *nparms;
for (jp = 1; jp <= i__3; ++jp) {
i__ = jp + *nparms * (jt - 1 + *ntypes * (js - 1));
rwork[i__] = smflop_(&ops_ref(jp, jt, js), ×_ref(jp,
jt, js), &iinfo);
/* L40: */
}
}
/* L50: */
}
/* L60: */
}
io___33.ciunit = *nout;
s_wsfe(&io___33);
e_wsfe();
sprtbs_("Type", "N ", ntypes, &dotype[1], nsizes, &nn[1], nparms, &llwork[
1], &rwork[1], nparms, ntypes, nout, (ftnlen)4, (ftnlen)2);
/* Format statements for generating format statements.
9981 generates a string 21+2+11=34 characters long.
9980 generates a string 16+2+12=30 characters long. */
return 0;
/* End of SPRTBG */
} /* sprtbg_ */
/* Subroutine */ int alarqg_(char *path, integer *nmats, logical *dotype,
integer *ntypes, integer *nin, integer *nout)
{
/* Initialized data */
static char intstr[10] = "0123456789";
/* Format strings */
static char fmt_9995[] = "(//\002 *** Not enough matrix types on input l"
"ine\002,/a79)";
static char fmt_9994[] = "(\002 ==> Specify \002,i4,\002 matrix types on"
" this line or \002,\002adjust NTYPES on previous line\002)";
static char fmt_9996[] = "(//\002 *** Invalid integer value in column"
" \002,i2,\002 of input\002,\002 line:\002,/a79)";
static char fmt_9997[] = "(\002 *** Warning: duplicate request of matri"
"x type \002,i2,\002 for \002,a3)";
static char fmt_9999[] = "(\002 *** Invalid type request for \002,a3,"
"\002, type \002,i4,\002: must satisfy 1 <= type <= \002,i2)";
static char fmt_9998[] = "(/\002 *** End of file reached when trying to "
"read matrix \002,\002types for \002,a3,/\002 *** Check that you "
"are requesting the\002,\002 right number of types for each pat"
"h\002,/)";
/* System generated locals */
integer i__1;
cilist ci__1;
/* Local variables */
integer i__, j, k;
char c1[1];
integer i1, ic, nt;
char line[80];
integer lenp, nreq[100];
logical firstt;
/* Fortran I/O blocks */
static cilist io___9 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___10 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___14 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___15 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___18 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___19 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___20 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___21 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ALARQG handles input for the LAPACK test program. It is called */
/* to evaluate the input line which requested NMATS matrix types for */
/* PATH. The flow of control is as follows: */
/* If NMATS = NTYPES then */
/* DOTYPE(1:NTYPES) = .TRUE. */
/* else */
/* Read the next input line for NMATS matrix types */
/* Set DOTYPE(I) = .TRUE. for each valid type I */
/* endif */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* An LAPACK path name for testing. */
/* NMATS (input) INTEGER */
/* The number of matrix types to be used in testing this path. */
/* DOTYPE (output) LOGICAL array, dimension (NTYPES) */
/* The vector of flags indicating if each type will be tested. */
/* NTYPES (input) INTEGER */
/* The maximum number of matrix types for this path. */
/* NIN (input) INTEGER */
/* The unit number for input. NIN >= 1. */
/* NOUT (input) INTEGER */
/* The unit number for output. NOUT >= 1. */
/* ====================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
if (*nmats >= *ntypes) {
/* Test everything if NMATS >= NTYPES. */
i__1 = *ntypes;
for (i__ = 1; i__ <= i__1; ++i__) {
dotype[i__] = TRUE_;
/* L10: */
}
} else {
i__1 = *ntypes;
for (i__ = 1; i__ <= i__1; ++i__) {
dotype[i__] = FALSE_;
/* L20: */
}
firstt = TRUE_;
/* Read a line of matrix types if 0 < NMATS < NTYPES. */
if (*nmats > 0) {
ci__1.cierr = 0;
ci__1.ciend = 1;
ci__1.ciunit = *nin;
ci__1.cifmt = "(A80)";
i__1 = s_rsfe(&ci__1);
if (i__1 != 0) {
goto L90;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L90;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L90;
}
lenp = i_len(line, (ftnlen)80);
i__ = 0;
i__1 = *nmats;
for (j = 1; j <= i__1; ++j) {
nreq[j - 1] = 0;
i1 = 0;
L30:
++i__;
if (i__ > lenp) {
if (j == *nmats && i1 > 0) {
goto L60;
} else {
io___9.ciunit = *nout;
s_wsfe(&io___9);
do_fio(&c__1, line, (ftnlen)80);
e_wsfe();
io___10.ciunit = *nout;
s_wsfe(&io___10);
do_fio(&c__1, (char *)&(*nmats), (ftnlen)sizeof(
integer));
e_wsfe();
goto L80;
}
}
if (*(unsigned char *)&line[i__ - 1] != ' ' && *(unsigned
char *)&line[i__ - 1] != ',') {
i1 = i__;
*(unsigned char *)c1 = *(unsigned char *)&line[i1 - 1];
/* Check that a valid integer was read */
for (k = 1; k <= 10; ++k) {
if (*(unsigned char *)c1 == *(unsigned char *)&intstr[
k - 1]) {
ic = k - 1;
goto L50;
}
/* L40: */
}
io___14.ciunit = *nout;
s_wsfe(&io___14);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, line, (ftnlen)80);
e_wsfe();
io___15.ciunit = *nout;
s_wsfe(&io___15);
do_fio(&c__1, (char *)&(*nmats), (ftnlen)sizeof(integer));
e_wsfe();
goto L80;
L50:
nreq[j - 1] = nreq[j - 1] * 10 + ic;
goto L30;
} else if (i1 > 0) {
goto L60;
} else {
goto L30;
}
L60:
;
}
}
i__1 = *nmats;
for (i__ = 1; i__ <= i__1; ++i__) {
nt = nreq[i__ - 1];
if (nt > 0 && nt <= *ntypes) {
if (dotype[nt]) {
if (firstt) {
io___17.ciunit = *nout;
s_wsle(&io___17);
e_wsle();
}
firstt = FALSE_;
io___18.ciunit = *nout;
s_wsfe(&io___18);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
dotype[nt] = TRUE_;
} else {
io___19.ciunit = *nout;
s_wsfe(&io___19);
do_fio(&c__1, path, (ftnlen)3);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*ntypes), (ftnlen)sizeof(integer));
e_wsfe();
}
/* L70: */
}
L80:
;
}
return 0;
L90:
io___20.ciunit = *nout;
s_wsfe(&io___20);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___21.ciunit = *nout;
s_wsle(&io___21);
e_wsle();
s_stop("", (ftnlen)0);
/* End of ALARQG */
return 0;
} /* alarqg_ */
/* $Procedure SCDECD ( Decode spacecraft clock ) */
/* Subroutine */ int scdecd_(integer *sc, doublereal *sclkdp, char *sclkch,
ftnlen sclkch_len)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1;
/* Builtin functions */
double d_nint(doublereal *);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer), i_len(char *, ftnlen);
/* Local variables */
integer part, i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), errdp_(char *,
doublereal *, ftnlen);
doublereal ticks;
extern /* Subroutine */ int scfmt_(integer *, doublereal *, char *,
ftnlen);
doublereal pstop[9999];
extern logical failed_(void);
extern integer lastnb_(char *, ftnlen);
integer prelen;
extern integer lstled_(doublereal *, integer *, doublereal *);
extern /* Subroutine */ int sigerr_(char *, ftnlen);
integer suflen;
extern /* Subroutine */ int scpart_(integer *, integer *, doublereal *,
doublereal *), chkout_(char *, ftnlen), prefix_(char *, integer *,
char *, ftnlen, ftnlen), setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen), suffix_(char *, integer *, char *, ftnlen,
ftnlen);
integer nparts;
doublereal pstart[9999];
extern logical return_(void);
extern /* Subroutine */ int intstr_(integer *, char *, ftnlen);
doublereal ptotls[9999];
char prtstr[5];
/* $ Abstract */
/* Convert double precision encoding of spacecraft clock time into */
/* a character representation. */
/* $ 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 */
/* SCLK */
/* $ Keywords */
/* CONVERSION */
/* TIME */
/* $ Declarations */
/* $ Abstract */
/* Include file sclk.inc */
/* SPICE private file intended solely for the support of SPICE */
/* routines. Users should not include this file directly due */
/* to the volatile nature of this file */
/* The parameters below define sizes and limits used by */
/* the SCLK system. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Parameters */
/* See the declaration section below. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 2.0.0, 24-MAY-2010 (NJB) */
/* Increased value of maximum coefficient record count */
/* parameter MXCOEF from 10K to 50K. */
/* - SPICELIB Version 1.0.0, 11-FEB-2008 (NJB) */
/* -& */
/* Number of supported SCLK field delimiters: */
/* Supported SCLK string field delimiters: */
/* Maximum number of partitions: */
/* Partition string length. */
/* Since the maximum number of partitions is given by MXPART is */
/* 9999, PRTSTR needs at most 4 characters for the partition number */
/* and one character for the slash. */
/* Maximum number of coefficient records: */
/* Maximum number of fields in an SCLK string: */
/* Length of strings used to represent D.P. */
/* numbers: */
/* Maximum number of supported parallel time systems: */
/* End of include file sclk.inc */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* SC I NAIF spacecraft identification code. */
/* SCLKDP I Encoded representation of a spacecraft clock count. */
/* SCLKCH O Character representation of a clock count. */
/* MXPART P Maximum number of spacecraft clock partitions. */
/* $ Detailed_Input */
/* SC is the NAIF integer code of the spacecraft whose */
/* clock's time is being decoded. */
/* SCLKDP is the double precision encoding of a clock time in */
/* units of ticks since the spacecraft clock start time. */
/* This value does reflect partition information. */
/* An analogy may be drawn between a spacecraft clock */
/* and a standard wall clock. The number of ticks */
/* corresponding to the wall clock string */
/* hh:mm:ss */
/* would be the number of seconds represented by that */
/* time. */
/* For example: */
/* Clock string Number of ticks */
/* ------------ --------------- */
/* 00:00:10 10 */
/* 00:01:00 60 */
/* 00:10:00 600 */
/* 01:00:00 3600 */
/* If SCLKDP contains a fractional part the result */
/* is the same as if SCLKDP had been rounded to the */
/* nearest whole number. */
/* $ Detailed_Output */
/* SCLKCH is the character representation of the clock count. */
/* The exact form that SCLKCH takes depends on the */
/* spacecraft. */
/* Nevertheless, SCLKCH will have the following general */
/* format: */
/* 'pp/sclk_string' */
/* 'pp' is an integer greater than or equal to one and */
/* represents a "partition number". */
/* Each mission is divided into some number of partitions. */
/* A new partition starts when the spacecraft clock */
/* resets, either to zero, or to some other */
/* value. Thus, the first partition for any mission */
/* starts with launch, and ends with the first clock */
/* reset. The second partition starts immediately when */
/* the first stopped, and so on. */
/* In order to be completely unambiguous about a */
/* particular time, you need to specify a partition number */
/* along with the standard clock string. */
/* Information about when partitions occur for different */
/* missions is contained in a spacecraft clock kernel */
/* file which needs to be loaded into the kernel pool */
/* before calling SCDECD. */
/* The routine SCPART may be used to read the partition */
/* start and stop times, in encoded units of ticks, from */
/* the kernel file. */
/* Since the end time of one partition is coincident with */
/* the begin time of the next, two different time strings */
/* with different partition numbers can encode into the */
/* same value. */
/* For example, if partition 1 ends at time t1, and */
/* partition 2 starts at time t2, then */
/* '1/t1' and '2/t2' */
/* will be encoded into the same value, say X. SCDECD */
/* always decodes such values into the latter of the */
/* two partitions. In this example, */
/* CALL SCDECD ( X, SC, CLKSTR ) */
/* will result in */
/* CLKSTR = '2/t2'. */
/* 'sclk_string' is a spacecraft specific clock string, */
/* typically consisting of a number of components */
/* separated by delimiters. */
/* Using Galileo as an example, the full format is */
/* wwwwwwww:xx:y:z */
/* where z is a mod-8 counter (values 0-7) which */
/* increments approximately once every 8 1/3 ms., y is a */
/* mod-10 counter (values 0-9) which increments once */
/* every time z turns over, i.e., approximately once every */
/* 66 2/3 ms., xx is a mod-91 (values 0-90) counter */
/* which increments once every time y turns over, i.e., */
/* once every 2/3 seconds. wwwwwwww is the Real-Time Image */
/* Count (RIM), which increments once every time xx turns */
/* over, i.e., once every 60 2/3 seconds. The roll-over */
/* expression for the RIM is 16777215, which corresponds */
/* to approximately 32 years. */
/* wwwwwwww, xx, y, and z are referred to interchangeably */
/* as the fields or components of the spacecraft clock. */
/* SCLK components may be separated by any of these five */
/* characters: ' ' ':' ',' '-' '.' */
/* The delimiter used is determined by a kernel pool */
/* variable and can be adjusted by the user. */
/* Some spacecraft clock components have offset, or */
/* starting, values different from zero. For example, */
/* with an offset value of 1, a mod 20 counter would */
/* cycle from 1 to 20 instead of from 0 to 19. */
/* See the SCLK required reading for a detailed */
/* description of the Voyager and Mars Observer clock */
/* formats. */
/* $ Parameters */
/* MXPART is the maximum number of spacecraft clock partitions */
/* expected in the kernel file for any one spacecraft. */
/* See the INCLUDE file sclk.inc for this parameter's */
/* value. */
/* $ Exceptions */
/* 1) If kernel variables required by this routine are unavailable, */
/* the error will be diagnosed by routines called by this routine. */
/* SCLKCH will be returned as a blank string in this case. */
/* 2) If the number of partitions in the kernel file for spacecraft */
/* SC exceeds the parameter MXPART, the error */
/* 'SPICE(TOOMANYPARTS)' is signaled. SCLKCH will be returned */
/* as a blank string in this case. */
/* 3) If the encoded value does not fall in the boundaries of the */
/* mission, the error 'SPICE(VALUEOUTOFRANGE)' is signaled. */
/* SCLKCH will be returned as a blank string in this case. */
/* 4) If the declared length of SCLKCH is not large enough to */
/* contain the output clock string the error */
/* 'SPICE(SCLKTRUNCATED)' is signaled either by this routine */
/* or by a routine called by this routine. On output SCLKCH */
/* will contain a portion of the truncated clock string. */
/* $ Files */
/* A kernel file containing spacecraft clock partition information */
/* for the desired spacecraft must be loaded, using the routine */
/* FURNSH, before calling this routine. */
/* $ Particulars */
/* In general, it is difficult to compare spacecraft clock counts */
/* numerically since there are too many clock components for a */
/* single comparison. The routine SCENCD provides a method of */
/* assigning a single double precision number to a spacecraft's */
/* clock count, given one of its character representations. */
/* This routine performs the inverse operation to SCENCD, converting */
/* an encoded double precision number to character format. */
/* To convert the number of ticks since the start of the mission to */
/* a clock format character string, SCDECD: */
/* 1) Determines the spacecraft clock partition that TICKS falls */
/* in. */
/* 2) Subtracts off the number of ticks occurring in previous */
/* partitions, to get the number of ticks since the beginning */
/* of the current partition. */
/* 3) Converts the resulting ticks to clock format and forms the */
/* string */
/* 'partition_number/clock_string' */
/* $ Examples */
/* Double precision encodings of spacecraft clock counts are used to */
/* tag pointing data in the C-kernel. */
/* In the following example, pointing for a sequence of images from */
/* the Voyager 2 narrow angle camera is requested from the C-kernel */
/* using an array of character spacecraft clock counts as input. */
/* The clock counts attached to the output are then decoded to */
/* character and compared with the input strings. */
/* CHARACTER*(25) CLKIN ( 4 ) */
/* CHARACTER*(25) CLKOUT */
/* CHARACTER*(25) CLKTOL */
/* DOUBLE PRECISION TIMEIN */
/* DOUBLE PRECISION TIMOUT */
/* DOUBLE PRECISION CMAT ( 3, 3 ) */
/* INTEGER NPICS */
/* INTEGER SC */
/* DATA NPICS / 4 / */
/* DATA CLKIN / '2/20538:39:768', */
/* . '2/20543:21:768', */
/* . '2/20550:37', */
/* . '2/20561:59' / */
/* DATA CLKTOL / ' 0:01:000' / */
/* C */
/* C The instrument we want pointing for is the Voyager 2 */
/* C narrow angle camera. The reference frame we want is */
/* C J2000. The spacecraft is Voyager 2. */
/* C */
/* INST = -32001 */
/* REF = 'J2000' */
/* SC = -32 */
/* C */
/* C Load the appropriate files. We need */
/* C */
/* C 1) CK file containing pointing data. */
/* C 2) Spacecraft clock kernel file, for SCENCD and SCDECD. */
/* C */
/* CALL CKLPF ( 'VGR2NA.CK' ) */
/* CALL FURNSH ( 'SCLK.KER' ) */
/* C */
/* C Convert the tolerance string to ticks. */
/* C */
/* CALL SCTIKS ( SC, CLKTOL, TOL ) */
/* DO I = 1, NPICS */
/* CALL SCENCD ( SC, CLKIN( I ), TIMEIN ) */
/* CALL CKGP ( INST, TIMEIN, TOL, REF, CMAT, TIMOUT, */
/* . FOUND ) */
/* CALL SCDECD ( SC, TIMOUT, CLKOUT ) */
/* WRITE (*,*) */
/* WRITE (*,*) 'Input s/c clock count: ', CLKIN( I ) */
/* WRITE (*,*) 'Output s/c clock count: ', CLKOUT */
/* WRITE (*,*) 'Output C-Matrix: ', CMAT */
/* END DO */
/* The output from such a program might look like: */
/* Input s/c clock count: 2/20538:39:768 */
/* Output s/c clock count: 2/20538:39:768 */
/* Output C-Matrix: 'first C-matrix' */
/* Input s/c clock count: 2/20543:21:768 */
/* Output s/c clock count: 2/20543:22:768 */
/* Output C-Matrix: 'second C-matrix' */
/* Input s/c clock count: 2/20550:37 */
/* Output s/c clock count: 2/20550:36:768 */
/* Output C-Matrix: 'third C-matrix' */
/* Input s/c clock count: 2/20561:59 */
/* Output s/c clock count: 2/20561:58:768 */
/* Output C-Matrix: 'fourth C-matrix' */
/* $ Restrictions */
/* 1) Assumes that an SCLK kernel file appropriate for the clock */
/* designated by SC is loaded in the kernel pool at the time */
/* this routine is called. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* J.M. Lynch (JPL) */
/* R.E. Thurman (JPL) */
/* $ Version */
/* - SPICELIB Version 2.1.0, 05-FEB-2008 (NJB) */
/* Values of parameter MXPART and PARTLN are now */
/* provided by the INCLUDE file sclk.inc. */
/* - SPICELIB Version 2.0.1, 22-AUG-2006 (EDW) */
/* Replaced references to LDPOOL with references */
/* to FURNSH. */
/* - SPICELIB Version 2.0.0, 17-APR-1992 (JML) (WLT) */
/* The routine was changed to signal an error when SCLKCH is */
/* not long enough to contain the output spacecraft clock */
/* string. */
/* FAILED is now checked after calling SCPART. */
/* References to CLPOOL were deleted. */
/* Miscellaneous minor updates to the header were performed. */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 06-SEP-1990 (JML) (RET) */
/* -& */
/* $ Index_Entries */
/* decode spacecraft_clock */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 10-APR-1992 (JML) (WLT) */
/* The routine was changed to signal an error when SCLKCH is */
/* not long enough to contain the output spacecraft clock */
/* string. Previously, the SCLK routines simply truncated */
/* the clock string on the right. It was determined that */
/* since this truncation could easily go undetected by the */
/* user ( only the leftmost field of a clock string is */
/* required when clock string is used as an input to a */
/* SCLK routine ), it would be better to signal an error */
/* when this happens. */
/* FAILED is checked after calling SCPART in case an */
/* error has occurred reading the kernel file and the */
/* error action is not set to 'abort'. */
/* References to CLPOOL were deleted. */
/* Miscellaneous minor updates to the header were performed. */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SCDECD", (ftnlen)6);
}
/* Use a working copy of the input. */
ticks = d_nint(sclkdp);
s_copy(sclkch, " ", sclkch_len, (ftnlen)1);
/* Read the partition start and stop times (in ticks) for this */
/* mission. Error if there are too many of them. Also need to */
/* check FAILED in case error handling is not in ABORT or */
/* DEFAULT mode. */
scpart_(sc, &nparts, pstart, pstop);
if (failed_()) {
chkout_("SCDECD", (ftnlen)6);
return 0;
}
if (nparts > 9999) {
setmsg_("The number of partitions, #, for spacecraft # exceeds the v"
"alue for parameter MXPART, #.", (ftnlen)88);
errint_("#", &nparts, (ftnlen)1);
errint_("#", sc, (ftnlen)1);
errint_("#", &c__9999, (ftnlen)1);
sigerr_("SPICE(TOOMANYPARTS)", (ftnlen)19);
chkout_("SCDECD", (ftnlen)6);
return 0;
}
/* For each partition, compute the total number of ticks in that */
/* partition plus all preceding partitions. */
d__1 = pstop[0] - pstart[0];
ptotls[0] = d_nint(&d__1);
i__1 = nparts;
for (i__ = 2; i__ <= i__1; ++i__) {
d__1 = ptotls[(i__3 = i__ - 2) < 9999 && 0 <= i__3 ? i__3 : s_rnge(
"ptotls", i__3, "scdecd_", (ftnlen)495)] + pstop[(i__4 = i__
- 1) < 9999 && 0 <= i__4 ? i__4 : s_rnge("pstop", i__4, "scd"
"ecd_", (ftnlen)495)] - pstart[(i__5 = i__ - 1) < 9999 && 0 <=
i__5 ? i__5 : s_rnge("pstart", i__5, "scdecd_", (ftnlen)495)];
ptotls[(i__2 = i__ - 1) < 9999 && 0 <= i__2 ? i__2 : s_rnge("ptotls",
i__2, "scdecd_", (ftnlen)495)] = d_nint(&d__1);
}
/* The partition corresponding to the input ticks is the first one */
/* whose tick total is greater than the input value. The one */
/* exception is when the input ticks is equal to the total number */
/* of ticks represented by all the partitions. In this case the */
/* partition number is the last one, i.e. NPARTS. */
/* Error if TICKS comes before the first partition (that is, if it's */
/* negative), or after the last one. */
if (ticks == ptotls[(i__1 = nparts - 1) < 9999 && 0 <= i__1 ? i__1 :
s_rnge("ptotls", i__1, "scdecd_", (ftnlen)510)]) {
part = nparts;
} else {
part = lstled_(&ticks, &nparts, ptotls) + 1;
}
if (ticks < 0. || part > nparts) {
setmsg_("Value for ticks, #, does not fall in any partition for spac"
"ecraft #.", (ftnlen)68);
errdp_("#", &ticks, (ftnlen)1);
errint_("#", sc, (ftnlen)1);
sigerr_("SPICE(VALUEOUTOFRANGE)", (ftnlen)22);
chkout_("SCDECD", (ftnlen)6);
return 0;
}
/* To get the count in this partition, subtract off the total of */
/* the preceding partition counts and add the beginning count for */
/* this partition. */
if (part == 1) {
ticks += pstart[(i__1 = part - 1) < 9999 && 0 <= i__1 ? i__1 : s_rnge(
"pstart", i__1, "scdecd_", (ftnlen)535)];
} else {
ticks = ticks + pstart[(i__1 = part - 1) < 9999 && 0 <= i__1 ? i__1 :
s_rnge("pstart", i__1, "scdecd_", (ftnlen)537)] - ptotls[(
i__2 = part - 2) < 9999 && 0 <= i__2 ? i__2 : s_rnge("ptotls",
i__2, "scdecd_", (ftnlen)537)];
}
/* Now create the output SCLK clock string. */
/* First convert from ticks to clock string format. */
scfmt_(sc, &ticks, sclkch, sclkch_len);
/* Now convert the partition number to a character string and prefix */
/* it to the output string. */
intstr_(&part, prtstr, (ftnlen)5);
suffix_("/", &c__0, prtstr, (ftnlen)1, (ftnlen)5);
prelen = lastnb_(prtstr, (ftnlen)5);
suflen = lastnb_(sclkch, sclkch_len);
if (i_len(sclkch, sclkch_len) - suflen < prelen) {
setmsg_("Output string too short to contain clock string. Input tick"
" value: #, requires string of length #, but declared length "
"is #.", (ftnlen)124);
errdp_("#", sclkdp, (ftnlen)1);
i__1 = prelen + suflen;
errint_("#", &i__1, (ftnlen)1);
i__1 = i_len(sclkch, sclkch_len);
errint_("#", &i__1, (ftnlen)1);
sigerr_("SPICE(SCLKTRUNCATED)", (ftnlen)20);
chkout_("SCDECD", (ftnlen)6);
return 0;
}
prefix_(prtstr, &c__0, sclkch, (ftnlen)5, sclkch_len);
chkout_("SCDECD", (ftnlen)6);
return 0;
} /* scdecd_ */
/* $Procedure LJUCRS ( Left-justify, Uppercase, Compress ) */
/* Subroutine */ int ljucrs_(integer *n, char *input, char *output, ftnlen
input_len, ftnlen output_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer i__1;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer lowa, lowz;
integer i__, j, inlen;
static integer shift;
integer count, outlen, ich;
/* $ Abstract */
/* Left-justify, uppercase, and space-compress a character 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. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* ASCII */
/* CHARACTER */
/* STRING */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* N I Maximum consecutive occurrences of space. */
/* INPUT I Input string. */
/* OUTPUT O Output string. */
/* $ Detailed_Input */
/* N is the maximum number of consecutive occurrences */
/* of space that will be allowed to remain in the */
/* output string. */
/* INPUT is the input string. */
/* $ Detailed_Output */
/* OUTPUT is the output string. This is the input string that */
/* left-justified and with all occurrences of more than */
/* N consecutive spaces removed. */
/* If OUTPUT is not large enough to hold the */
/* compressed string, it is truncated on the right. */
/* OUTPUT may overwrite INPUT. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The string is left-justified and uppercased. Occurrences of more */
/* than N consecutive spaces are removed from the input string as it */
/* is copied to the output string. If the output string is not large */
/* enough to hold the compressed string, it is truncated on the */
/* right. */
/* $ Examples */
/* Let N = 1. Then */
/* ' Abc DE F ', becomes 'ABC DE F', */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 29-JUL-2013 (BVS) */
/* -& */
/* $ Index_Entries */
/* compress uppercase left-justify a character_string */
/* -& */
/* Local Variables */
/* Saved variables */
/* Initial Data */
/* Do some set up stuff the first time through so that we do not */
/* need to reinitialize the boundary values used for comparisons */
/* and the shift on each call. */
if (first) {
first = FALSE_;
lowa = 'a';
lowz = 'z';
shift = 'A' - lowa;
}
/* Find out how much space there is in the INPUT and OUTPUT strings */
/* and initialize the space counter and output place holder. */
inlen = i_len(input, input_len);
outlen = i_len(output, output_len);
count = 0;
j = 0;
i__1 = inlen;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Skip leading spaces. */
if (j == 0 && *(unsigned char *)&input[i__ - 1] == ' ') {
/* Another leading space. Skip it. */
} else {
/* Check this character to see if it is a space or not. */
if (*(unsigned char *)&input[i__ - 1] == ' ') {
++count;
/* Copy spaces until enough consecutive spaces */
/* have been accumulated. When enough consecutive spaces */
/* have accumulated, we no longer copy them. */
if (count <= *n) {
++j;
*(unsigned char *)&output[j - 1] = *(unsigned char *)&
input[i__ - 1];
}
} else {
/* We don't have a space here. Set the space counter to */
/* zero. */
count = 0;
/* Copy this character while swapping lowercase with upper */
/* case along the way. */
++j;
ich = *(unsigned char *)&input[i__ - 1];
if (ich >= lowa && ich <= lowz) {
*(unsigned char *)&output[j - 1] = (char) (ich + shift);
} else {
*(unsigned char *)&output[j - 1] = *(unsigned char *)&
input[i__ - 1];
}
}
if (j == outlen) {
return 0;
}
}
}
/* Pad any left over space in the output string with blanks. Note */
/* that if the input string was blank, J will be zero at this */
/* point and the case below will set the whole output string to */
/* blank. */
if (j < outlen) {
i__1 = j;
s_copy(output + i__1, " ", output_len - i__1, (ftnlen)1);
}
return 0;
} /* ljucrs_ */
/* $Procedure CYCLEC ( Cycle a character string ) */
/* Subroutine */ int cyclec_(char *instr, char *dir, integer *ncycle, char *
outstr, ftnlen instr_len, ftnlen dir_len, ftnlen outstr_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Local variables */
char last[1], temp[1];
integer g, i__, j, k, l, m, n;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
integer limit;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen);
extern logical return_(void);
extern integer gcd_(integer *, integer *);
/* $ Abstract */
/* Cycle the contents of a character string to the left or right. */
/* $ 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, UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* INSTR I String to be cycled. */
/* DIR I Direction to cycle. */
/* NCYCLE I Number of times to cycle. */
/* OUTSTR O Cycled string. */
/* $ Detailed_Input */
/* DIR is the direction in which the characters in the */
/* string are to be cycled. */
/* 'L' or 'l' to cycle left. */
/* 'R' or 'r' to cycle right. */
/* NCYCLE is the number of times the characters in the string */
/* are to be cycled. */
/* INSTR is the string to be cycled. */
/* $ Detailed_Output */
/* OUTSTR the input string after it has been cycled. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* A string is cycled when its contents are shifted to the left */
/* or right by one place. A character pushed off one end of the */
/* string is brought around to the other end of the string instead */
/* of disappearing. */
/* Leading and trailing blanks are treated just like any other */
/* characters. */
/* If the output string is not large enough to contain the input */
/* string, the cycled string is truncated on the right. */
/* $ Examples */
/* 'abcde' cycled left twice becomes 'cdeab' */
/* 'abcde ' cycled left twice becomes 'cde ab' */
/* 'abcde' cycled right once becomes 'eabcd' */
/* 'Apple ' cycled left six times becomes 'Apple ' */
/* 'Apple ' cycled right twenty-four times becomes 'Apple ' */
/* $ Restrictions */
/* The memory used for the output string must be identical to that */
/* used for the input string or be disjoint from the input string */
/* memory. */
/* That is: */
/* CALL CYCLEN ( STRING, DIR, NCYCLE, STRING ) */
/* will produce correct results with output overwriting input. */
/* CALL CYCLEN ( STRING(4:20), DIR, NCYCLE, STRING(2:18) ) */
/* will produce garbage results. */
/* $ Exceptions */
/* 1) If the direction flag is not one of the acceptable values */
/* 'r', 'R', 'l', 'L', the error 'SPICE(INVALIDDIRECTION)' is */
/* signalled. */
/* $ Files */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.1.0, 18-JUN-1999 (WLT) */
/* Fixed problem with unbalanced CHKIN/CHKOUT calls. */
/* - 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 (IMU) (WLT) */
/* -& */
/* $ Index_Entries */
/* cycle a character_string */
/* -& */
/* $ Revisions */
/* - Beta Version 1.1.0, 6-FEB-1989 (WLT) */
/* Error handling for bad direction flag added. */
/* -& */
/* SPICELIB functions */
/* Local variables */
if (return_()) {
return 0;
} else {
chkin_("CYCLEC", (ftnlen)6);
}
/* Get the length of the input string. */
n = i_len(instr, instr_len);
limit = i_len(outstr, outstr_len);
/* A left cycle is the same as a right cycle by the opposite of */
/* NCYCLE. Moreover a cycle by K is the same as a cycle by */
/* K + m*N for any integer m. Thus we compute the value of the */
/* minimum positive right cycle that is equivalent to the inputs. */
if (*(unsigned char *)dir == 'L' || *(unsigned char *)dir == 'l') {
k = -(*ncycle) % n;
} else if (*(unsigned char *)dir == 'R' || *(unsigned char *)dir == 'r') {
k = *ncycle % n;
} else {
setmsg_("The direction flag should be one of the following: 'r', 'R'"
", 'l', 'L'. It was #.", (ftnlen)81);
errch_("#", dir, (ftnlen)1, (ftnlen)1);
sigerr_("SPICE(INVALIDDIRECTION)", (ftnlen)23);
chkout_("CYCLEC", (ftnlen)6);
return 0;
}
if (k < 0) {
k += n;
} else if (k == 0) {
chkout_("CYCLEC", (ftnlen)6);
return 0;
}
/* As to the method for performing the cycle in place, we need a */
/* few preliminaries. */
/* 1. Since we are performing a cycle on the input string we */
/* can regard the letters of the string as being attached */
/* to a circle at N equally spaced points. Thus a cycle */
/* by K has the effect of moving the position of each letter */
/* to the K'th point from its current position along the */
/* circle. (The first point from its position is the */
/* adjacent point.) */
/* 2. If we start at some point on the circle and begin moves to */
/* other points of the circle by always moving K points */
/* at a time, how long will it take until we get back to */
/* the starting point? Answer: N/gcd(K,N) */
/* Justification of the above answer. */
/* a. If we count all of the points that we move past or */
/* onto in such a trip (counting second, third, ... */
/* passes), we will find that we have */
/* moved past or onto i*K points after i steps. */
/* b. In order to get back to the starting point we will */
/* have to move past or onto a multiple of N points. */
/* c. The first time we will get back to the starting */
/* point is the smallest value of i such that i*K */
/* is a multiple of N. That value is N/g.c.d.(K,N) */
/* where g.c.d stands for the greatest common divisor */
/* of K and N. Lets call this number M. */
/* i. To see that this is the smallest number we */
/* first show that K*M is in fact a multiple of */
/* N. The product K*M = K * ( N / gcd(K,N) ) */
/* = N * ( K / gcd(K,N) ) */
/* Since gcd(K,N) evenly divides K, K/gcd(K,N) */
/* is an integer. Thus K*M = N*I for some */
/* integer I ( = K / gcd(K,N) ). */
/* ii. The least common multiple of K and N is: */
/* K*N / gcd(K,N) thus the first multiple */
/* of K that is also a multiple of N is the */
/* N/ gcd(K,N) 'th multiple of K. */
/* 3. The closest stopping point on the circle will be gcd(K,N) */
/* points away from our starting point. To see this recall */
/* that we make N/gcd(K,N) moves of size K inorder to get */
/* back to the starting point. The stopping points must */
/* be equally spaced around the circle since the set of */
/* points must look the same from any one of the points */
/* visited --- after all we could get the same set by just */
/* starting at one of those visited and making N/gcd(K,N) */
/* moves. But the set of N/gcd(K,N) equally space points */
/* out of the original N must be gcd(K,N) points apart. */
/* 4. To visit every point on the circle we could */
/* a. Pick a starting point */
/* b. Take N/gcd(K,N) steps of size K (bringing us back */
/* to our starting point. */
/* c. move forward 1 point */
/* d. repeat steps a. b. and c. gcd(K,N) times. */
/* 5. If in addition to moving around the circle by the */
/* prescription of 4. above we: */
/* a. pick up the letter at a position when we stop there */
/* (starting being the same as stopping) */
/* b. put down the letter we had picked up at a previous */
/* point. */
/* then we will cycle every letter by the prescribed value */
/* of K. */
/* In this case the code is much shorter than its explanation. */
g = gcd_(&k, &n);
m = n / g;
i__1 = g;
for (i__ = 1; i__ <= i__1; ++i__) {
l = i__;
*(unsigned char *)last = *(unsigned char *)&instr[l - 1];
i__2 = m;
for (j = 1; j <= i__2; ++j) {
l += k;
/* Compute L mod N. */
if (l > n) {
l -= n;
}
*(unsigned char *)temp = *(unsigned char *)&instr[l - 1];
/* Make sure there is someplace to put the letter picked up */
/* in the previous pass through the loop. */
if (l <= limit) {
*(unsigned char *)&outstr[l - 1] = *(unsigned char *)last;
}
*(unsigned char *)last = *(unsigned char *)temp;
}
}
chkout_("CYCLEC", (ftnlen)6);
return 0;
} /* cyclec_ */
/* $Procedure ZZASCII ( determine/verify EOL terminators in a text file ) */
/* Subroutine */ int zzascii_(char *file, char *line, logical *check, char *
termin, ftnlen file_len, ftnlen line_len, ftnlen termin_len)
{
/* System generated locals */
olist o__1;
cllist cl__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen), f_open(olist *), f_clos(cllist *), s_rdue(
cilist *), do_uio(integer *, char *, ftnlen), e_rdue(void);
/* Local variables */
extern /* Subroutine */ int zzplatfm_(char *, char *, ftnlen, ftnlen);
integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
extern integer rtrim_(char *, ftnlen);
extern logical eqstr_(char *, char *, ftnlen, ftnlen);
integer maccnt, reclen;
char native[5];
integer number, doscnt;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), getlun_(integer *), setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
extern logical return_(void);
integer unxcnt;
/* Fortran I/O blocks */
static cilist io___5 = { 1, 0, 1, 0, 1 };
/* $ Abstract */
/* Returns a string indicating the line terminators of an ASCII file */
/* and, if requested, stops execution if the terminator does match */
/* the one that is native to the platform on which the toolkit was */
/* compiled. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* FILE TYPE */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* FILE I Name of the text file to scan. */
/* LINE I The work string for file reads. */
/* CHECK I Flag directing to check for mismatched EOL. */
/* TERMIN 0 The deduced terminator ID. */
/* $ Detailed_Input */
/* FILE the name of the ASCII file to scan for a line */
/* terminator */
/* LINE a character string of sufficient length to perform the */
/* line reads from FILE. */
/* CHECK a logical flag that, if set to .TRUE., instructs this */
/* routine to check terminator that has been determined */
/* against the one that is native to the platform, on */
/* which the toolkit was compiled, and to generate error */
/* if it was not the case. If set to .FALSE., instructs */
/* the routine to bypass the check. */
/* $ Detailed_Output */
/* TERMIN the terminator ID extracted from FILE. The possible */
/* values: */
/* 'CR' - carriage return (Mac classic) */
/* 'LF' - line feed (Unix) */
/* 'CR-LF' - carriage return and line feed (DOS) */
/* '?' - unable to determine, possibly */
/* due to an error event */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) A SPICE(STRINGTOOSHORT) error signals if LINE has length less */
/* than 3. */
/* 2) A SPICE(FILEOPENFAILED) error signals if the file of interest */
/* fails to open, i.e. IOSTAT < 0. */
/* 3) A text kernel found to contain non-native line terminators */
/* and abort of the run was requested by causes this routine to */
/* signal the error SPICE(INCOMPATIBLEEOL). */
/* $ Files */
/* None. */
/* $ Particulars */
/* The function scans a string read from a text file to determine */
/* the native platform of the file. The functions response is */
/* unpredictable if it scans a binary file. */
/* $ Examples */
/* To return EOL terminator for a given file: */
/* CHARACTER*(5) TERMIN */
/* CHARACTER*(64) LINE */
/* ... given a file name */
/* ... and a line long enough to hold a text string */
/* from FILE */
/* CALL ZZASCII( FILE, LINE, .FALSE., TERMIN ) */
/* CALL TOSTDO( 'FOUND FILE TERMINATOR '//TERMIN ) */
/* To stop if EOL terminator for a given file, if detected */
/* successfully, is not native to this platform: */
/* CHARACTER*(5) TERMIN */
/* CHARACTER*(64) LINE */
/* ... given a file name */
/* ... and a line long enough to hold a text string */
/* from FILE */
/* CALL ZZASCII( FILE, LINE, .TRUE., TERMIN ) */
/* If the EOL terminator was not native, the call will generate */
/* SPICE(INCOMPATIBLEEOL) error. */
/* $ Restrictions */
/* 1) The terminator detection is not performed if the read from */
/* the file fails because the file is smaller than the allocated */
/* LINE size or for any other reason. */
/* 2) The terminator detection is not possible if the length of the */
/* first text line in the file exceeds the length of the LINE */
/* work space. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* E.D. Wright (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 1.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 1.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 1.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 1.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 1.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 1.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 1.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 1.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 1.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 1.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 1.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 1.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 1.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 1.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 1.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 1.3.1, 26-OCT-2006 (EDW) */
/* Expanded error message explanation the */
/* routine outputs when the file-of-interest */
/* includes non-native text line terminators. */
/* - SPICELIB Version 1.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 1.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 1.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 1.0.0, 17-FEB-2004 (EDW) (BVS) */
/* -& */
/* $ Index_Entries */
/* determine ascii text file end-of-line type */
/* -& */
/* SPICELIB functions. */
/* Local parameters. */
/* Local variables. */
/* Discovery check-in. Can't determine the terminator in RETURN */
/* mode. */
if (return_()) {
s_copy(termin, "?", termin_len, (ftnlen)1);
return 0;
}
/* Check-in to the error system. */
chkin_("ZZASCII", (ftnlen)7);
/* Retrieve the native line terminator. */
zzplatfm_("TEXT_FORMAT", native, (ftnlen)11, (ftnlen)5);
/* If it is VAX, return immediately with undefined terminator. */
if (eqstr_(native, "VAX", (ftnlen)5, (ftnlen)3)) {
s_copy(termin, "?", termin_len, (ftnlen)1);
chkout_("ZZASCII", (ftnlen)7);
return 0;
}
/* Set the record lenght that will be used to read data from */
/* the file. */
reclen = i_len(line, line_len);
/* Check the length of the work string is sufficient to perform the */
/* operations. Less than 3 is a no-op. */
if (i_len(line, line_len) < 3) {
s_copy(termin, "?", termin_len, (ftnlen)1);
setmsg_("Work string lacks sufficient length to perform operation.", (
ftnlen)57);
sigerr_("SPICE(STRINGTOOSHORT)", (ftnlen)21);
chkout_("ZZASCII", (ftnlen)7);
return 0;
}
/* Find a free logical unit for file access. */
getlun_(&number);
/* Open the file for DIRECT access. */
o__1.oerr = 1;
o__1.ounit = number;
o__1.ofnmlen = rtrim_(file, file_len);
o__1.ofnm = file;
o__1.orl = reclen;
o__1.osta = "OLD";
o__1.oacc = "DIRECT";
o__1.ofm = 0;
o__1.oblnk = 0;
iostat = f_open(&o__1);
if (iostat != 0) {
/* The open failed, can't determine the terminator if the routine */
/* can't open the file. */
s_copy(termin, "?", termin_len, (ftnlen)1);
/* Execute a close, J.I.C. */
cl__1.cerr = 0;
cl__1.cunit = number;
cl__1.csta = 0;
f_clos(&cl__1);
setmsg_("File open failed for file '$1'. IOSTAT value $2.", (ftnlen)
49);
errch_("$1", file, (ftnlen)2, file_len);
errint_("$2", &iostat, (ftnlen)2);
sigerr_("SPICE(FILEOPENFAIL)", (ftnlen)19);
chkout_("ZZASCII", (ftnlen)7);
return 0;
}
/* Read a line into the LINE variable assigned by the user. */
s_copy(line, " ", line_len, (ftnlen)1);
io___5.ciunit = number;
iostat = s_rdue(&io___5);
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, line, line_len);
if (iostat != 0) {
goto L100001;
}
iostat = e_rdue();
L100001:
if (iostat != 0) {
/* If something went wrong during this read, a part or the whole */
/* returned line may contain garbage. Instead of examining it and */
/* making wrong determination based on it, set terminator to */
/* undefined and return. */
s_copy(termin, "?", termin_len, (ftnlen)1);
/* Execute a close, J.I.C. */
cl__1.cerr = 0;
cl__1.cunit = number;
cl__1.csta = 0;
f_clos(&cl__1);
chkout_("ZZASCII", (ftnlen)7);
return 0;
}
/* We have a line of text data. Use ICHAR to scan for carriage */
/* returns and line feeds and count how may of various recognized */
/* line termination sequences are in this line. */
doscnt = 0;
unxcnt = 0;
maccnt = 0;
i__ = 1;
while(i__ < i_len(line, line_len)) {
/* Check for ICHAR values of 10 (LF) and 13 (CR). */
if (*(unsigned char *)&line[i__ - 1] == 10) {
/* Found a UNIX line terminator LF. */
++unxcnt;
} else if (*(unsigned char *)&line[i__ - 1] == 13) {
/* Found CR, increment character counter and check */
/* the next character. */
++i__;
if (*(unsigned char *)&line[i__ - 1] == 10) {
/* Found a DOS line terminator CR+LF. */
++doscnt;
} else {
/* Found a Classic Mac line terminator CR. */
++maccnt;
}
}
++i__;
}
/* Examine the counters. */
if (doscnt > 0 && unxcnt == 0 && maccnt == 0) {
/* Only DOS terminator counter is non-zero. ID the file as DOS. */
s_copy(termin, "CR-LF", termin_len, (ftnlen)5);
} else if (doscnt == 0 && unxcnt > 0 && maccnt == 0) {
/* Only Unix terminator counter is non-zero. ID the file as UNIX. */
s_copy(termin, "LF", termin_len, (ftnlen)2);
} else if (doscnt == 0 && unxcnt == 0 && maccnt > 0) {
/* Only Mac terminator counter is non-zero. ID the file as Mac */
/* Classic. */
s_copy(termin, "CR", termin_len, (ftnlen)2);
} else {
/* We can get here in two cases. First if the line did not */
/* contain any CRs or LFs. Second if the line contained more than */
/* one kind of terminators. In either case the format of the file */
/* is unclear. */
s_copy(termin, "?", termin_len, (ftnlen)1);
}
/* Close the file. */
cl__1.cerr = 0;
cl__1.cunit = number;
cl__1.csta = 0;
f_clos(&cl__1);
/* If we were told check the terminator against the native one, do */
/* it. */
if (*check) {
/* If the terminator was identified and does not match the native */
/* one, error out. */
if (! eqstr_(termin, native, termin_len, (ftnlen)5) && ! eqstr_(
termin, "?", termin_len, (ftnlen)1)) {
setmsg_("Text file '$1' contains lines terminated with '$2' whil"
"e the expected terminator for this platform is '$3'. SPI"
"CE cannot process the file in the current form. This pro"
"blem likely occurred because the file was copied in bina"
"ry mode between operating systems where the operating sy"
"stems use different text line terminators. Try convertin"
"g the file to native text form using a utility such as d"
"os2unix or unix2dos.", (ftnlen)411);
errch_("$1", file, (ftnlen)2, file_len);
errch_("$2", termin, (ftnlen)2, termin_len);
errch_("$3", native, (ftnlen)2, (ftnlen)5);
sigerr_("SPICE(INCOMPATIBLEEOL)", (ftnlen)22);
chkout_("ZZASCII", (ftnlen)7);
return 0;
}
}
chkout_("ZZASCII", (ftnlen)7);
return 0;
} /* zzascii_ */
/* $Procedure CYCLAC ( Cycle the elements of a character array ) */
/* Subroutine */ int cyclac_(char *array, integer *nelt, char *dir, integer *
ncycle, char *out, ftnlen array_len, ftnlen dir_len, ftnlen out_len)
{
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char last[1], temp[1];
integer c__, g, i__, j, k, l, m;
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern integer nbwid_(char *, integer *, ftnlen);
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen),
movec_(char *, integer *, char *, ftnlen, ftnlen);
integer limit;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen);
integer widest;
extern /* Subroutine */ int setmsg_(char *, ftnlen);
integer outlen;
extern logical return_(void);
extern integer gcd_(integer *, integer *);
/* $ Abstract */
/* Cycle the elements of a character array forward or backward. */
/* $ 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 */
/* ARRAY */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ARRAY I Input array. */
/* NELT I Number of elements. */
/* DIR I Direction to cycle: 'F' or 'B'. */
/* NCYCLE I Number of times to cycle. */
/* OUT O Cycled array. */
/* $ Detailed_Input */
/* ARRAY is the array to be cycled. */
/* NELT is the number of elements in the input array. */
/* DIR is the direction in which the elements in the */
/* array are to be cycled. */
/* 'F' or 'f' to cycle forward. */
/* 'B' or 'b' to cycle backward. */
/* NCYCLE is the number of times the elements in the array */
/* are to be cycled. */
/* $ Detailed_Output */
/* OUT is the input array after it has been cycled. */
/* OUT may overwrite ARRAY. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the value of DIR is not recognized, the error */
/* SPICE(INVALIDDIRECTION) is signalled. */
/* 2) If NELT is less than 1, the output array is not modified. */
/* 3) If NCYCLE is negative, the array is cycled NCYCLE times in */
/* the opposite direction of DIR. */
/* $ Files */
/* None. */
/* $ Particulars */
/* An array is cycled when its contents are shifted forward or */
/* backward by one place. An element pushed off one end of the */
/* array is brought around to the other end of the array instead */
/* of disappearing. */
/* $ Examples */
/* Let the integer array A contain the following elements. */
/* A(1) = 'apple' */
/* A(2) = 'bear' */
/* A(3) = 'cake' */
/* A(4) = 'dragon' */
/* Cycling A forward once yields the array */
/* A(1) = 'dragon' */
/* A(2) = 'apple' */
/* A(3) = 'bear' */
/* A(4) = 'cake' */
/* Cycling A backward once yields the array */
/* A(1) = 'bear' */
/* A(2) = 'cake' */
/* A(3) = 'dragon' */
/* A(4) = 'apple' */
/* Cycling by any multiple of the number of elements in the array */
/* yields the same array. */
/* $ Restrictions */
/* The memory used for the output array must be identical to or */
/* disjoint from the memory used for the input array. */
/* That is: */
/* CALL CYCLAC ( ARRAY, NELT, DIR, NCYCLE, ARRAY ) */
/* will produce correct results, while */
/* CALL CYCLAC ( ARRAY, NELT-3, DIR, NCYCLE, ARRAY(4) ) */
/* will produce garbage. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.2, 18-MAY-2010 (BVS) */
/* Removed "C$" marker from text in the header. */
/* - 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 (IMU) (WLT) */
/* -& */
/* $ Index_Entries */
/* cycle the elements of a character array */
/* -& */
/* $ Revisions */
/* - Beta Version 2.0.0, 16-JAN-1989 (HAN) */
/* Error handling was added to detect an invalid value for */
/* the cycling direction. If the direction is not recognized */
/* the error SPICE(INVALIDDIRECTION) is signalled and the */
/* output array is not modified. (The routine used to copy the */
/* input array into the output array if the direction was not */
/* recognized.) */
/* The "Exceptions" section was filled out in more detail. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("CYCLAC", (ftnlen)6);
}
/* Don't even screw around if there are no elements in the array. */
if (*nelt < 1) {
chkout_("CYCLAC", (ftnlen)6);
return 0;
}
/* A backward cycle is the same as a forward cycle by the opposite */
/* of NCYCLE. Moreover a cycle by K is the same as a cycle by */
/* K + m*N for any integer m. Thus we compute the value of the */
/* minimum forward right cycle that is equivalent to the inputs. */
/* If the cycling direction is not recognized, signal an error. */
if (*(unsigned char *)dir == 'B' || *(unsigned char *)dir == 'b') {
k = -(*ncycle) % *nelt;
} else if (*(unsigned char *)dir == 'F' || *(unsigned char *)dir == 'f') {
k = *ncycle % *nelt;
} else {
setmsg_("Cycling direction was *.", (ftnlen)24);
errch_("*", dir, (ftnlen)1, (ftnlen)1);
sigerr_("SPICE(INVALIDDIRECTION)", (ftnlen)23);
chkout_("CYCLAC", (ftnlen)6);
return 0;
}
if (k < 0) {
k += *nelt;
} else if (k == 0) {
movec_(array, nelt, out, array_len, out_len);
chkout_("CYCLAC", (ftnlen)6);
return 0;
}
/* The algorithm used to cycle arrays is identical to the one used */
/* to cycle character strings in CYCLEC. We won't repeat the (rather */
/* lengthy) description here. */
/* The character version of CYCLAx differs from the other */
/* versions in that a single character is cycled at a time. That */
/* is, the first trip through the outermost loop cycles the first */
/* characters of the array elements; the second trip cycles the */
/* second characters; and so on. This allows the same algorithm to */
/* be used for all the routines. The local storage required is just */
/* a couple of characters. */
/* Don't swap the ends of strings if they're just blank padded. */
/* And don't overwrite the elements of the output array, if they */
/* happen to be shorter thAn those in the input array. */
outlen = i_len(out, out_len);
widest = nbwid_(array, nelt, array_len);
limit = min(outlen,widest);
/* The greatest common divisor need only be computed once. */
g = gcd_(&k, nelt);
m = *nelt / g;
/* To make this a non-character routine, remove all references to C. */
i__1 = limit;
for (c__ = 1; c__ <= i__1; ++c__) {
i__2 = g;
for (i__ = 1; i__ <= i__2; ++i__) {
l = i__;
*(unsigned char *)last = *(unsigned char *)&array[(l - 1) *
array_len + (c__ - 1)];
i__3 = m;
for (j = 1; j <= i__3; ++j) {
l += k;
if (l > *nelt) {
l -= *nelt;
}
*(unsigned char *)temp = *(unsigned char *)&array[(l - 1) *
array_len + (c__ - 1)];
*(unsigned char *)&out[(l - 1) * out_len + (c__ - 1)] = *(
unsigned char *)last;
*(unsigned char *)last = *(unsigned char *)temp;
}
}
}
/* If needed, pad the output array with blanks. */
if (outlen > limit) {
i__1 = *nelt;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = limit;
s_copy(out + ((i__ - 1) * out_len + i__2), " ", out_len - i__2, (
ftnlen)1);
}
}
chkout_("CYCLAC", (ftnlen)6);
return 0;
} /* cyclac_ */
/* $Procedure PROMPT ( Prompt a user for a string ) */
/* Subroutine */ int prompt_(char *prmpt, char *string, ftnlen prmpt_len,
ftnlen string_len)
{
/* System generated locals */
integer i__1, i__2;
cilist ci__1;
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_rsfe(cilist *), e_rsfe(void), i_len(char *, ftnlen);
/* Local variables */
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen), sigerr_(char *, ftnlen), chkout_(char *, ftnlen)
, setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
/* $ Abstract */
/* This routine prompts a user for keyboard input. */
/* $ 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 input. */
/* STRING O The response typed by a user. */
/* $ Detailed_Input */
/* PRMPT is a character string that will be displayed from the */
/* current cursor position and describes the input that */
/* the user is expected to enter. The string PRMPT should */
/* be relatively short, i.e., 50 or fewer characters, so */
/* that a response may be typed on the line where the */
/* prompt appears. */
/* All characters (including trailing blanks) in PRMPT */
/* are considered significant and will be displayed. */
/* $ Detailed_Output */
/* STRING is a character string that contains the string */
/* entered by the user. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* This subroutine uses discovery check-in so that it may be called */
/* after an error has occurred. */
/* 1) If the attempt to write the prompt to the standard output */
/* device fails, returning an IOSTAT value not equal to zero, the */
/* error SPICE(WRITEFAILED) will be signalled. */
/* 2) If the attempt to read the response from the standard input */
/* device fails, returning an IOSTAT value not equal to zero, the */
/* error SPICE(READFAILED) will be signalled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This is a utility that allows you to "easily" request information */
/* from a program user. At a high level, it frees you from the */
/* peculiarities of a particular implementation of FORTRAN cursor */
/* control. */
/* $ Examples */
/* Suppose you wanted to ask a user to input an answer to */
/* a question such as "Do you want to try again? (Y/N) " */
/* and leave the cursor at the end of the question as shown here: */
/* Do you want to try again? (Y/N) _ */
/* (The underscore indicates the cursor position). */
/* The following line of code will do what you want. */
/* CALL PROMPT ( 'Do you want to try again? (Y/N) ', ANSWER ) */
/* $ Restrictions */
/* This routine is environment specific. Standard FORTRAN does not */
/* provide for user control of cursor position after write */
/* statements. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* W.L. Taber (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 explicitely 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 explicitely given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 3.0.0, 08-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 2.0.0, 20-JUL-1995 (WLT) (KRG) */
/* This routine now participates in error handling. It */
/* checks to make sure no I/O errors have occurred while */
/* attempting to write to standard output or read from standard */
/* input. It uses discovery checkin if an error is detected. */
/* Restructured the subroutine a little bit; the writing of the */
/* prompt is the only bit that is environment specific, so the */
/* code was rearranged to reflect this. There is now only a single */
/* READ statement. */
/* - SPICELIB Version 1.0.0, 15-OCT-1992 (WLT) */
/* -& */
/* $ Index_Entries */
/* Prompt for keyboard input */
/* Prompt for input with a user supplied message */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 3.0.0, 08-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 2.0.0, 20-JUL-1995 (WLT) (KRG) */
/* This routine now participates in error handling. It */
/* checks to make sure no I/O errors have occurred while */
/* attempting to write to standard output or read from standard */
/* input. It uses discovery checkin if an error is detected. */
/* Restructured the subroutine a little bit; the writing of the */
/* prompt is the only bit that is environment specific, so the */
/* code was rearranged to reflect this. There is now only a single */
/* READ statement. */
/* -& */
/* Local variables */
/* The code below should be used in the following environments: */
/* SUN/Fortran, */
/* HP/HP-Fortran, */
/* Silicon Graphics/Silicon Graphics Fortran, */
/* DEC Alpha-OSF/1--DEC Fortran, */
/* NeXT/Absoft Fortran */
/* PC Linux/Fort77 */
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, prmpt, prmpt_len);
if (iostat != 0) {
goto L100001;
}
iostat = e_wsfe();
L100001:
/* If none of the write statements above works on a particular */
/* unsupported platform, read on... */
/* Although, this isn't really what you want, if you need to port */
/* this quickly to an environment that does not support the format */
/* statement in any of the cases above, you can comment out the */
/* write statement above and un-comment the write statement below. */
/* In this way you can get a program working quickly in the new */
/* environment while you figure out how to control cursor */
/* positioning. */
/* WRITE (*,*, IOSTAT=IOSTAT ) PRMPT */
/* Check for a write error. It's not likely, but the standard output */
/* can be redirected. Better safe than confused later. */
if (iostat != 0) {
chkin_("PROMPT", (ftnlen)6);
setmsg_("An error occurred while attempting to write a prompt to the"
" standard output device, possibly because standard output ha"
"s been redirected to a file. There is not much that can be d"
"one about this if it happens. We do not try to determine whe"
"ther standard output has been redirected, so be sure that th"
"ere are sufficient resources available for the operation bei"
"ng performed.", (ftnlen)372);
sigerr_("SPICE(WRITEFAILED)", (ftnlen)18);
chkout_("PROMPT", (ftnlen)6);
return 0;
}
/* Now that we've written out the prompt and there was no error, we */
/* can read in the response. */
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = 5;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100002;
}
iostat = do_fio(&c__1, string, string_len);
if (iostat != 0) {
goto L100002;
}
iostat = e_rsfe();
L100002:
if (iostat != 0) {
chkin_("PROMPT", (ftnlen)6);
setmsg_("An error occurred while attempting to retrieve a reply to t"
"he prompt \"#\". A possible cause is that you have exhauste"
"d the input buffer while attempting to type your response. "
"It may help if you limit your response to # or fewer charact"
"ers. ", (ftnlen)242);
errch_("#", prmpt, (ftnlen)1, prmpt_len);
/* Computing MIN */
i__2 = i_len(string, string_len);
i__1 = min(i__2,131);
errint_("#", &i__1, (ftnlen)1);
sigerr_("SPICE(READFAILED)", (ftnlen)17);
chkout_("PROMPT", (ftnlen)6);
return 0;
}
return 0;
} /* prompt_ */
/* $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 FRSTNB ( First non-blank character ) */
integer frstnb_(char *string, ftnlen string_len)
{
/* System generated locals */
integer ret_val, i__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), i_len(char *, ftnlen);
/* Local variables */
integer i__;
/* $ Abstract */
/* Return the index of the first non-blank character in */
/* a character 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. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* ASCII, CHARACTER, SEARCH */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* STRING I Input character string. */
/* FRSTNB O Index of the first non-blank character in STRING. */
/* $ Detailed_Input */
/* STRING is the input character string. */
/* $ Detailed_Output */
/* FRSTNB is the index if the first non-blank character */
/* in the input string. If there are no non-blank */
/* characters in the string, FRSTNB is zero. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* If the string is blank, return zero. Otherwise, step through */
/* the string one character at a time until something other than */
/* a blank is found. Return the index of that something within */
/* the string. */
/* $ Examples */
/* The following examples illustrate the use of FRSTNB. */
/* FRSTNB ( 'ABCDE' ) = 1 */
/* FRSTNB ( 'AN EXAMPLE' ) = 1 */
/* FRSTNB ( ' AN EXAMPLE' ) = 4 */
/* FRSTNB ( ' ' ) = 0 */
/* $ Restrictions */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* I.M. Underwood (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 2.0.0, 12-MAR-1996 (KRG) */
/* Modified the comparison to use integer values and the ICHAR() */
/* function. This improves the performance of the subroutine. */
/* - 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 (IMU) */
/* -& */
/* $ Index_Entries */
/* first non-blank character */
/* -& */
/* Local parameters */
/* Local variables */
/* Just like it says in the header. */
if (s_cmp(string, " ", string_len, (ftnlen)1) == 0) {
ret_val = 0;
} else {
i__1 = i_len(string, string_len);
for (i__ = 1; i__ <= i__1; ++i__) {
if (*(unsigned char *)&string[i__ - 1] != 32) {
ret_val = i__;
return ret_val;
}
}
}
return ret_val;
} /* frstnb_ */
/* $Procedure ZZEKAC06 ( EK, add class 6 column to segment ) */
/* Subroutine */ int zzekac06_(integer *handle, integer *segdsc, integer *
coldsc, char *cvals, integer *entszs, logical *nlflgs, ftnlen
cvals_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen), s_rnge(char *, integer, char *, integer);
/* Local variables */
char page[1024];
integer from, size, room;
extern /* Subroutine */ int zzekcnam_(integer *, integer *, char *,
ftnlen), zzekpgwc_(integer *, integer *, char *, ftnlen),
zzeksfwd_(integer *, integer *, integer *, integer *), zzekspsh_(
integer *, integer *);
integer i__, l, n, p, ndata, pbase;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
integer class__, cvlen, nlink, p2, nrows, cp;
extern logical return_(void);
char column[32];
integer adrbuf[1014], bufptr, colidx, curchr, cursiz, nchars, nulptr, nw,
nwrite, padlen, remain, strlen, to;
logical cntinu, fixsiz, newent, newreq, nullok, pad;
extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen), sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), prtenc_(integer *, char *, ftnlen);
integer row;
extern /* Subroutine */ int zzekaps_(integer *, integer *, integer *,
logical *, integer *, integer *);
/* $ Abstract */
/* Add an entire class 6 column to an EK segment. */
/* $ 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 */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Boolean Enumerated Type */
/* ekbool.inc Version 1 21-DEC-1994 (NJB) */
/* Within the EK system, boolean values sometimes must be */
/* represented by integer or character codes. The codes and their */
/* meanings are listed below. */
/* Integer code indicating `true': */
/* Integer code indicating `false': */
/* Character code indicating `true': */
/* Character code indicating `false': */
/* End Include Section: EK Boolean Enumerated Type */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Column Descriptor Parameters */
/* ekcoldsc.inc Version 6 23-AUG-1995 (NJB) */
/* Note: The column descriptor size parameter CDSCSZ is */
/* declared separately in the include section CDSIZE$INC.FOR. */
/* Offset of column descriptors, relative to start of segment */
/* integer address range. This number, when added to the last */
/* integer address preceding the segment, yields the DAS integer */
/* base address of the first column descriptor. Currently, this */
/* offset is exactly the size of a segment descriptor. The */
/* parameter SDSCSZ, which defines the size of a segment descriptor, */
/* is declared in the include file eksegdsc.inc. */
/* Size of column descriptor */
/* Indices of various pieces of column descriptors: */
/* CLSIDX is the index of the column's class code. (We use the */
/* word `class' to distinguish this item from the column's data */
/* type.) */
/* TYPIDX is the index of the column's data type code (CHR, INT, DP, */
/* or TIME). The type is actually implied by the class, but it */
/* will frequently be convenient to look up the type directly. */
/* LENIDX is the index of the column's string length value, if the */
/* column has character type. A value of IFALSE in this element of */
/* the descriptor indicates that the strings have variable length. */
/* SIZIDX is the index of the column's element size value. This */
/* descriptor element is meaningful for columns with fixed-size */
/* entries. For variable-sized columns, this value is IFALSE. */
/* NAMIDX is the index of the base address of the column's name. */
/* IXTIDX is the data type of the column's index. IXTIDX */
/* contains a type value only if the column is indexed. For columns */
/* that are not indexed, the location IXTIDX contains the boolean */
/* value IFALSE. */
/* IXPIDX is a pointer to the column's index. IXTPDX contains a */
/* meaningful value only if the column is indexed. The */
/* interpretation of the pointer depends on the data type of the */
/* index. */
/* NFLIDX is the index of a flag indicating whether nulls are */
/* permitted in the column. The value at location NFLIDX is */
/* ITRUE if nulls are permitted and IFALSE otherwise. */
/* ORDIDX is the index of the column's ordinal position in the */
/* list of columns belonging to the column's parent segment. */
/* METIDX is the index of the column's integer metadata pointer. */
/* This pointer is a DAS integer address. */
/* The last position in the column descriptor is reserved. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Column Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Column Name Size */
/* ekcnamsz.inc Version 1 17-JAN-1995 (NJB) */
/* Size of column name, in characters. */
/* End Include Section: EK Column Name Size */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Data Page Parameters */
/* ekfilpar.inc Version 1 03-APR-1995 (NJB) */
/* These parameters apply to EK files using architecture 4. */
/* These files use a paged DAS file as their underlying file */
/* structure. */
/* In paged DAS EK files, data pages are structured: they contain */
/* metadata as well as data. The metadata is located in the last */
/* few addresses of each page, so as to interfere as little as */
/* possible with calculation of data addresses. */
/* Each data page belongs to exactly one segment. Some bookkeeping */
/* information, such as record pointers, is also stored in data */
/* pages. */
/* Each page contains a forward pointer that allows rapid lookup */
/* of data items that span multiple pages. Each page also keeps */
/* track of the current number of links from its parent segment */
/* to the page. Link counts enable pages to `know' when they */
/* are no longer in use by a segment; unused pages are deallocated */
/* and returned to the free list. */
/* The parameters in this include file depend on the parameters */
/* declared in the include file ekpage.inc. If those parameters */
/* change, this file must be updated. The specified parameter */
/* declarations we need from that file are: */
/* INTEGER PGSIZC */
/* PARAMETER ( PGSIZC = 1024 ) */
/* INTEGER PGSIZD */
/* PARAMETER ( PGSIZD = 128 ) */
/* INTEGER PGSIZI */
/* PARAMETER ( PGSIZI = 256 ) */
/* Character pages use an encoding mechanism to represent integer */
/* metadata. Each integer is encoded in five consecutive */
/* characters. */
/* Character data page parameters: */
/* Size of encoded integer: */
/* Usable page size: */
/* Location of character forward pointer: */
/* Location of character link count: */
/* Double precision data page parameters: */
/* Usable page size: */
/* Location of d.p. forward pointer: */
/* Location of d.p. link count: */
/* Integer data page parameters: */
/* Usable page size: */
/* Location of integer forward pointer: */
/* Location of integer link count: */
/* End Include Section: EK Data Page Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Das Paging Parameters */
/* ekpage.inc Version 4 25-AUG-1995 (NJB) */
/* The EK DAS paging system makes use of the integer portion */
/* of an EK file's DAS address space to store the few numbers */
/* required to describe the system's state. The allocation */
/* of DAS integer addresses is shown below. */
/* DAS integer array */
/* +--------------------------------------------+ */
/* | EK architecture code | Address = 1 */
/* +--------------------------------------------+ */
/* | Character page size (in DAS words) | */
/* +--------------------------------------------+ */
/* | Character page base address | */
/* +--------------------------------------------+ */
/* | Number of character pages in file | */
/* +--------------------------------------------+ */
/* | Number of character pages on free list | */
/* +--------------------------------------------+ */
/* | Character free list head pointer | Address = 6 */
/* +--------------------------------------------+ */
/* | | Addresses = */
/* | Metadata for d.p. pages | 7--11 */
/* | | */
/* +--------------------------------------------+ */
/* | | Addresses = */
/* | Metadata for integer pages | 12--16 */
/* | | */
/* +--------------------------------------------+ */
/* . */
/* . */
/* . */
/* +--------------------------------------------+ */
/* | | End Address = */
/* | Unused space | integer page */
/* | | end */
/* +--------------------------------------------+ */
/* | | Start Address = */
/* | First integer page | integer page */
/* | | base */
/* +--------------------------------------------+ */
/* . */
/* . */
/* . */
/* +--------------------------------------------+ */
/* | | */
/* | Last integer page | */
/* | | */
/* +--------------------------------------------+ */
/* The following parameters indicate positions of elements in the */
/* paging system metadata array: */
/* Number of metadata items per data type: */
/* Character metadata indices: */
/* Double precision metadata indices: */
/* Integer metadata indices: */
/* Size of metadata area: */
/* Page sizes, in units of DAS words of the appropriate type: */
/* Default page base addresses: */
/* End Include Section: EK Das Paging Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Record Pointer Parameters */
/* ekrecptr.inc Version 2 18-JUL-1995 (NJB) */
/* This file declares parameters used in EK record pointers. */
/* Each segment references data in a given record via two levels */
/* of indirection: a record number points to a record pointer, */
/* which is a structured array of metadata and data pointers. */
/* Record pointers always occupy contiguous ranges of integer */
/* addresses. */
/* The parameter declarations in this file depend on the assumption */
/* that integer pages contain 256 DAS integer words and that the */
/* maximum number of columns in a segment is 100. Record pointers */
/* are stored in integer data pages, so they must fit within the */
/* usable data area afforded by these pages. The size of the usable */
/* data area is given by the parameter IPSIZE which is declared in */
/* ekdatpag.inc. The assumed value of IPSIZE is 254. */
/* The first element of each record pointer is a status indicator. */
/* The meanings of status indicators depend on whether the parent EK */
/* is shadowed or not. For shadowed EKs, allowed status values and */
/* their meanings are: */
/* OLD The record has not been modified since */
/* the EK containing the record was opened. */
/* UPDATE The record is an update of a previously existing */
/* record. The original record is now on the */
/* modified record list. */
/* NEW The record has been added since the EK containing the */
/* record was opened. The record is not an update */
/* of a previously existing record. */
/* DELOLD This status applies only to a backup record. */
/* DELOLD status indicates that the record corresponds */
/* to a deleted OLD record in the source segment. */
/* DELNEW This status applies only to a backup record. */
/* DELNEW status indicates that the record corresponds */
/* to a deleted NEW record in the source segment. */
/* DELUPD This status applies only to a backup record. */
/* DELUPD status indicates that the record corresponds */
/* to a deleted UPDATEd record in the source segment. */
/* In EKs that are not shadowed, all records have status OLD. */
/* The following parameters refer to indices within the record */
/* pointer structure: */
/* Index of status indicator: */
/* Each record pointer contains a pointer to its companion: for a */
/* record belonging to a shadowed EK, this is the backup counterpart, */
/* or if the parent EK is itself a backup EK, a pointer to the */
/* record's source record. The pointer is UNINIT (see below) if the */
/* record is unmodified. */
/* Record companion pointers contain record numbers, not record */
/* base addresses. */
/* Index of record's companion pointer: */
/* Each data item is referenced by an integer. The meaning of */
/* this integer depends on the representation of data in the */
/* column to which the data item belongs. Actual lookup of a */
/* data item must be done by subroutines appropriate to the class of */
/* the column to which the item belongs. Note that data items don't */
/* necessarily occupy contiguous ranges of DAS addresses. */
/* Base address of data pointers: */
/* Maximum record pointer size: */
/* Data pointers are given the value UNINIT to start with; this */
/* indicates that the data item is uninitialized. UNINIT is */
/* distinct from the value NULL. NOBACK indicates an uninitialized */
/* backup column entry. */
/* End Include Section: EK Record Pointer Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Segment Descriptor Parameters */
/* eksegdsc.inc Version 8 06-NOV-1995 (NJB) */
/* All `base addresses' referred to below are the addresses */
/* *preceding* the item the base applies to. This convention */
/* enables simplied address calculations in many cases. */
/* Size of segment descriptor. Note: the include file ekcoldsc.inc */
/* must be updated if this parameter is changed. The parameter */
/* CDOFF in that file should be kept equal to SDSCSZ. */
/* Index of the segment type code: */
/* Index of the segment's number. This number is the segment's */
/* index in the list of segments contained in the EK to which */
/* the segment belongs. */
/* Index of the DAS integer base address of the segment's integer */
/* meta-data: */
/* Index of the DAS character base address of the table name: */
/* Index of the segment's column count: */
/* Index of the segment's record count: */
/* Index of the root page number of the record tree: */
/* Index of the root page number of the character data page tree: */
/* Index of the root page number of the double precision data page */
/* tree: */
/* Index of the root page number of the integer data page tree: */
/* Index of the `modified' flag: */
/* Index of the `initialized' flag: */
/* Index of the shadowing flag: */
/* Index of the companion file handle: */
/* Index of the companion segment number: */
/* The next three items are, respectively, the page numbers of the */
/* last character, d.p., and integer data pages allocated by the */
/* segment: */
/* The next three items are, respectively, the page-relative */
/* indices of the last DAS word in use in the segment's */
/* last character, d.p., and integer data pages: */
/* Index of the DAS character base address of the column name list: */
/* The last descriptor element is reserved for future use. No */
/* parameter is defined to point to this location. */
/* End Include Section: EK Segment Descriptor Parameters */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* Include Section: EK Data Types */
/* ektype.inc Version 1 27-DEC-1994 (NJB) */
/* Within the EK system, data types of EK column contents are */
/* represented by integer codes. The codes and their meanings */
/* are listed below. */
/* Integer codes are also used within the DAS system to indicate */
/* data types; the EK system makes no assumptions about compatibility */
/* between the codes used here and those used in the DAS system. */
/* Character type: */
/* Double precision type: */
/* Integer type: */
/* `Time' type: */
/* Within the EK system, time values are represented as ephemeris */
/* seconds past J2000 (TDB), and double precision numbers are used */
/* to store these values. However, since time values require special */
/* treatment both on input and output, and since the `TIME' column */
/* has a special role in the EK specification and code, time values */
/* are identified as a type distinct from double precision numbers. */
/* End Include Section: EK Data Types */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle attached to new EK file. */
/* SEGDSC I Segment descriptor. */
/* COLDSC I Column descriptor. */
/* CVALS I Character values to add to column. */
/* ENTSZS I Array of sizes of column entries. */
/* NLFLGS I Array of null flags for column entries. */
/* $ Detailed_Input */
/* HANDLE the handle of an EK file that is open for writing. */
/* A `begin segment for fast load' operation must */
/* have already been performed for the designated */
/* segment. */
/* SEGDSC is a descriptor for the segment to which data is */
/* to be added. The segment descriptor is not */
/* updated by this routine, but some fields in the */
/* descriptor will become invalid after this routine */
/* returns. */
/* COLDSC is a descriptor for the column to be added. The */
/* column attributes must be filled in, but any */
/* pointers may be uninitialized. */
/* ENTSZS is an array containing sizes of column entries. */
/* The Ith element of ENTSZS gives the size of the */
/* Ith column entry. ENTSZS is used only for columns */
/* having variable-size entries. For such columns, */
/* the dimension of ENTSZS must be at least NROWS. */
/* The size of null entries should be set to zero. */
/* For columns having fixed-size entries, the */
/* dimension of this array may be any positive value. */
/* CVALS is an array containing the entire set of column */
/* entries for the specified column. The entries */
/* are listed in row-order: the column entry for the */
/* first row of the segment is first, followed by the */
/* column entry for the second row, and so on. The */
/* number of column entries must match the declared */
/* number of rows in the segment. For columns having */
/* fixed-size entries, a null entry must be allocated */
/* the same amount of space occupied by a non-null */
/* entry in the array CVALS. For columns having */
/* variable-size entries, null entries do not require */
/* any space in the CVALS array, but in any case must */
/* have their allocated space described correctly by */
/* the corresponding element of the ENTSZS array */
/* (described below). */
/* ENTSZS is an array containing sizes of column entries. */
/* The Ith element of ENTSZS gives the size of the */
/* Ith column entry. ENTSZS is used only for columns */
/* having variable-size entries. For such columns, */
/* the dimension of ENTSZS must be at least NROWS. */
/* The size of null entries should be set to zero. */
/* For columns having fixed-size entries, the */
/* dimension of this array may be any positive value. */
/* NLFLGS is an array of logical flags indicating whether */
/* the corresponding entries are null. If the Ith */
/* element of NLFLGS is .FALSE., the Ith column entry */
/* defined by CVALS is added to the specified segment */
/* in the specified kernel file. */
/* If the Ith element of NLFGLS is .TRUE., the */
/* contents of the Ith column entry are undefined. */
/* NLFLGS is used only for columns that allow null */
/* values; it's ignored for other columns. */
/* $ Detailed_Output */
/* None. See $Particulars for a description of the effect of this */
/* routine. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If HANDLE is invalid, the error will be diagnosed by routines */
/* called by this routine. */
/* 2) If an I/O error occurs while reading or writing the indicated */
/* file, the error will be diagnosed by routines called by this */
/* routine. */
/* $ Files */
/* See the EK Required Reading for a discussion of the EK file */
/* format. */
/* $ Particulars */
/* This routine operates by side effects: it modifies the named */
/* EK file by adding data to the specified column. This routine */
/* writes the entire contents of the specified column in one shot. */
/* This routine creates columns much more efficiently than can be */
/* done by sequential calls to EKACEI, but has the drawback that */
/* the caller must use more memory for the routine's inputs. This */
/* routine cannot be used to add data to a partially completed */
/* column. */
/* $ Examples */
/* See EKACLC. */
/* $ Restrictions */
/* 1) This routine assumes the EK scratch area has been set up */
/* properly for a fast load operation. This routine writes */
/* to the EK scratch area as well. */
/* 2) Currently, the EK system can handle only one fast load */
/* at at time---one segment created by a fast load must be */
/* be completed by a call to EKFFLD before another segment */
/* can be created by a fast load, even if the two segments */
/* reside in different files. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.0, 22-JUL-1996 (NJB) */
/* Bug fix: case of 100% null data values is now handled */
/* correctly. Previous version line was changed from "Beta" */
/* to "SPICELIB." */
/* - SPICELIB Version 1.0.0, 26-SEP-1995 (NJB) */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.1.0, 22-JUL-1996 (NJB) */
/* Bug fix: case of 100% null data values is now handled */
/* correctly. The test to determine when to write a page */
/* was fixed to handle this case. */
/* Previous version line was changed from "Beta" */
/* to "SPICELIB." */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZEKAC06", (ftnlen)8);
}
/* Grab the column's attributes. */
class__ = coldsc[0];
nulptr = coldsc[7];
colidx = coldsc[8];
size = coldsc[3];
strlen = coldsc[2];
nullok = nulptr != -1;
fixsiz = size != -1;
/* This column had better be class 6. */
if (class__ != 6) {
zzekcnam_(handle, coldsc, column, (ftnlen)32);
setmsg_("Column class code # found in descriptor for column #. Clas"
"s should be 6.", (ftnlen)73);
errint_("#", &class__, (ftnlen)1);
errch_("#", column, (ftnlen)1, (ftnlen)32);
sigerr_("SPICE(NOCLASS)", (ftnlen)14);
chkout_("ZZEKAC06", (ftnlen)8);
return 0;
}
/* Push the column's ordinal index on the stack. This allows us */
/* to identify the column the addresses belong to. */
zzekspsh_(&c__1, &colidx);
/* Find the number of rows in the segment. */
nrows = segdsc[5];
/* Record the number of data values to write. */
if (nullok) {
/* Sum the sizes of the non-null column entries; these are the */
/* ones that will take up space. */
ndata = 0;
i__1 = nrows;
for (i__ = 1; i__ <= i__1; ++i__) {
if (! nlflgs[i__ - 1]) {
if (fixsiz) {
ndata += strlen * size;
} else {
ndata += strlen * entszs[i__ - 1];
}
}
}
} else {
if (fixsiz) {
ndata = nrows * strlen * size;
} else {
ndata = 0;
i__1 = nrows;
for (i__ = 1; i__ <= i__1; ++i__) {
ndata += strlen * entszs[i__ - 1];
}
}
}
if (ndata > 0) {
/* There's some data to write, so allocate a page. Also */
/* prepare a data buffer to be written out as a page. */
zzekaps_(handle, segdsc, &c__1, &c_false, &p, &pbase);
s_copy(page, " ", (ftnlen)1024, (ftnlen)1);
/* Decide now whether we will need to pad the input entry */
/* elements with trailing blanks, and if so how much padding */
/* we'll need. */
/* Computing MIN */
i__1 = i_len(cvals, cvals_len);
cvlen = min(i__1,strlen);
pad = cvlen < strlen;
if (pad) {
padlen = strlen - cvlen;
}
}
/* Write the input data out to the target file a page at a time. */
/* Null values don't get written. */
/* While we're at it, we'll push onto the EK stack the addresses */
/* of the column entries. We use the constant NULL rather than an */
/* address to represent null entries. */
/* We'll use FROM to indicate the element of CVALS we're */
/* considering, TO to indicate the element of PAGE to write */
/* to, and BUFPTR to indicate the element of ADRBUF to write */
/* addresses to. The variable N indicates the number of characters */
/* written to the current page. NCHARS is the number of characters */
/* written in the current column entry. CP is the position in the */
/* current input string of the character which we'll read next. */
remain = ndata;
from = 1;
to = 1;
bufptr = 1;
row = 1;
cp = 1;
n = 0;
nchars = 0;
nlink = 0;
newent = TRUE_;
while(row <= nrows) {
/* NEWREQ is set to TRUE if we discover that the next column */
/* entry must start on a new page. */
newreq = FALSE_;
/* FROM and TO are expected to be properly set at this point. */
if (nullok && nlflgs[row - 1]) {
if (fixsiz) {
cursiz = size;
} else {
cursiz = entszs[row - 1];
}
from += cursiz;
adrbuf[(i__1 = bufptr - 1) < 1014 && 0 <= i__1 ? i__1 : s_rnge(
"adrbuf", i__1, "zzekac06_", (ftnlen)442)] = -2;
++bufptr;
++row;
cntinu = FALSE_;
newent = TRUE_;
} else {
if (newent) {
/* We're about to write out a new column entry. We must */
/* insert the element count into the page before writing the */
/* data. The link count for the current page must be */
/* incremented to account for this new entry. */
/* At this point, we're guaranteed at least ENCSIZ+1 free */
/* spaces in the current page. */
if (fixsiz) {
cursiz = size;
} else {
cursiz = entszs[row - 1];
}
curchr = cursiz * strlen;
nchars = 0;
cp = 1;
adrbuf[(i__1 = bufptr - 1) < 1014 && 0 <= i__1 ? i__1 :
s_rnge("adrbuf", i__1, "zzekac06_", (ftnlen)472)] =
to + pbase;
++bufptr;
prtenc_(&cursiz, page + (to - 1), (ftnlen)5);
to += 5;
n += 5;
++nlink;
newent = FALSE_;
}
/* At this point, there's at least one free space in the */
/* current page. There's also at least one character to */
/* write. Transfer as much as possible of the current */
/* column entry to the current page. */
room = 1014 - n;
/* Computing MIN */
i__1 = curchr - nchars;
nwrite = min(i__1,room);
nw = nwrite;
while(nw > 0) {
/* At this point, we're guaranteed that */
/* CP <= STRLEN */
/* TO < CPSIZE */
/* FROM is set correctly. */
if (pad) {
/* The input strings must be padded with blanks up to */
/* a length of STRLEN characters. The number of blanks */
/* used to pad the input is PADLEN. */
if (cp < cvlen) {
/* Compute the number of `actual' characters of data */
/* left in the current input string. */
/* Transfer the characters we have room for from the */
/* current input string to the current page. */
l = cvlen - cp + 1;
l = min(l,nw);
s_copy(page + (to - 1), cvals + ((from - 1) *
cvals_len + (cp - 1)), to + l - 1 - (to - 1),
cp + l - 1 - (cp - 1));
cp += l;
nw -= l;
to += l;
} else {
/* The input character pointer is in the `pad' zone. */
/* Let L be the length of padding that is required */
/* and can fit in the page. */
l = strlen - cp + 1;
l = min(l,nw);
s_copy(page + (to - 1), " ", to + l - 1 - (to - 1), (
ftnlen)1);
cp += l;
nw -= l;
to += l;
}
} else {
/* The input data doesn't require padding. */
/* Compute the number of `actual' characters of data */
/* left in the current input string. */
/* Transfer the characters we have room for from the */
/* current input string to the current page. */
l = strlen - cp + 1;
l = min(l,nw);
s_copy(page + (to - 1), cvals + ((from - 1) * cvals_len +
(cp - 1)), to + l - 1 - (to - 1), cp + l - 1 - (
cp - 1));
cp += l;
nw -= l;
to += l;
}
/* If the input pointer is beyond the end of the declared */
/* length of the target column's strings STRLEN, it's time */
/* to look at the next input string. */
if (cp > strlen) {
++from;
cp = 1;
}
}
/* We've written NWRITE characters to the current page. FROM, */
/* TO, and CP are set. */
n += nwrite;
remain -= nwrite;
nchars += nwrite;
/* Decide whether we must continue the current entry on another */
/* data page. */
cntinu = nchars < curchr && n == 1014;
/* If we've finished writing out a column entry, get ready */
/* to write the next one. */
if (nchars == curchr) {
/* The current character is the last of the current column */
/* entry. */
/* Determine whether we must start the next column entry on */
/* a new page. To start a column entry on the current page, */
/* we must have enough room for the element count and at */
/* least one character of data. */
if (remain > 0) {
newreq = n > 1008;
}
++row;
newent = TRUE_;
}
}
/* At this point, CNTINU indicates whether we need to continue */
/* the current entry on another page. If we finished writing out */
/* the entry, CNTINU is .FALSE. */
if (bufptr > 1014 || row > nrows) {
/* The address buffer is full or we're out of input values */
/* to look at, so push the buffer contents on the stack. */
i__1 = bufptr - 1;
zzekspsh_(&i__1, adrbuf);
bufptr = 1;
}
if (cntinu || newreq || row > nrows && ndata > 0) {
/* It's time to write out the current page. First set the link */
/* count. */
prtenc_(&nlink, page + 1019, (ftnlen)5);
/* Write out the data page. */
zzekpgwc_(handle, &p, page, (ftnlen)1024);
/* If there's more data to write, allocate another page. */
if (remain > 0) {
zzekaps_(handle, segdsc, &c__1, &c_false, &p2, &pbase);
s_copy(page, " ", (ftnlen)1024, (ftnlen)1);
n = 0;
nlink = 0;
to = 1;
/* If we're continuing an element from the previous page, */
/* link the previous page to the current one. */
if (cntinu) {
zzeksfwd_(handle, &c__1, &p, &p2);
}
p = p2;
}
/* We've allocated a new data page if we needed one. */
}
/* We've written out the last completed data page. */
}
/* We've processed all entries of the input array. */
chkout_("ZZEKAC06", (ftnlen)8);
return 0;
} /* zzekac06_ */
/* $Procedure LBUILD ( Build a list in a character string ) */
/* Subroutine */ int lbuild_(char *items, integer *n, char *delim, char *list,
ftnlen items_len, ftnlen delim_len, ftnlen list_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen), s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer dlen, ilen, llen, last, lpos, i__, first;
extern integer lastnb_(char *, ftnlen), frstnb_(char *, ftnlen);
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen);
/* $ Abstract */
/* Build a list of items delimited by a character. */
/* $ 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, LIST, STRING */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ITEMS I Items in the list. */
/* N I Number of items in the list. */
/* DELIM I String used to delimit items. */
/* LIST O List of items delimited by DELIM. */
/* $ Detailed_Input */
/* ITEMS are the items to be combined to make the output */
/* list. Leading and trailing blanks are ignored. */
/* (Only the non-blank parts of the items are used.) */
/* N is the number of items. */
/* DELIM is the string used to delimit the items in the */
/* output list. DELIM may contain any number of */
/* characters, including blanks. */
/* $ Detailed_Output */
/* LIST is the output list, containing the N elements of */
/* ITEMS delimited by DELIM. If LIST is not long enough */
/* to contain the output list, it is truncated on the */
/* right. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* The non-blank parts of the elements of the ITEMS array are */
/* appended to the list, one at a time, separated by DELIM. */
/* $ Examples */
/* The following examples illustrate the operation of LBUILD. */
/* 1) Let */
/* DELIM = ' ' */
/* ITEMS(1) = 'A' */
/* ITEMS(2) = ' number' */
/* ITEMS(3) = 'of' */
/* ITEMS(4) = ' words' */
/* ITEMS(5) = 'separated' */
/* ITEMS(6) = ' by' */
/* ITEMS(7) = 'spaces' */
/* Then */
/* LIST = 'A number of words separated by spaces' */
/* 2) Let */
/* DELIM = '/' */
/* ITEMS(1) = ' ' */
/* ITEMS(2) = ' ' */
/* ITEMS(3) = 'option1' */
/* ITEMS(4) = ' ' */
/* ITEMS(5) = 'option2' */
/* ITEMS(6) = ' ' */
/* ITEMS(7) = ' ' */
/* ITEMS(8) = ' ' */
/* Then */
/* LIST = '//option1//option2///' */
/* 3) Let */
/* DELIM = ' and ' */
/* ITEMS(1) = 'Bob' */
/* ITEMS(2) = 'Carol' */
/* ITEMS(3) = 'Ted' */
/* ITEMS(4) = 'Alice' */
/* Then */
/* LIST = 'Bob and Carol and Ted and Alice' */
/* $ Restrictions */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Author_and_Institution */
/* I.M. Underwood (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) */
/* -& */
/* $ Index_Entries */
/* build a list in a character_string */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Find the non-blank part of each item. Move it to the */
/* end of the list, followed by a delimiter. If the item is */
/* blank, don't move anything but the delimiter. */
/* LPOS is the next position in the output list to be filled. */
/* LLEN is the length of the output list. */
/* DLEN is the length of DELIM. */
/* ILEN is the length of the next item in the list. */
s_copy(list, " ", list_len, (ftnlen)1);
lpos = 1;
llen = i_len(list, list_len);
dlen = i_len(delim, delim_len);
if (*n > 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (lpos <= llen) {
if (s_cmp(items + (i__ - 1) * items_len, " ", items_len, (
ftnlen)1) == 0) {
s_copy(list + (lpos - 1), delim, list_len - (lpos - 1),
delim_len);
lpos += dlen;
} else {
first = frstnb_(items + (i__ - 1) * items_len, items_len);
last = lastnb_(items + (i__ - 1) * items_len, items_len);
ilen = last - first + 1;
s_copy(list + (lpos - 1), items + ((i__ - 1) * items_len
+ (first - 1)), list_len - (lpos - 1), last - (
first - 1));
suffix_(delim, &c__0, list, delim_len, list_len);
lpos = lpos + ilen + dlen;
}
}
}
/* We're at the end of the list. Right now, the list ends in */
/* a delimiter. Drop it. */
if (lpos - dlen <= llen) {
i__1 = lpos - dlen - 1;
s_copy(list + i__1, " ", list_len - i__1, (ftnlen)1);
}
}
return 0;
} /* lbuild_ */
/* Subroutine */ int flgrpt_(integer *nitems, char *names, char *values, U_fp
myio, ftnlen names_len, ftnlen values_len)
{
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), i_len(char *, ftnlen),
s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char hard[1];
logical free[129];
integer i__, j, k, l;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer width;
extern integer rtrim_(char *, ftnlen);
char style[200];
extern /* Subroutine */ int chkout_(char *, ftnlen);
char letter[1];
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen), nspmrg_(char *, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int nicepr_1__(char *, char *, U_fp, ftnlen,
ftnlen);
/* This routine takes an array of names and an array of associated */
/* value strings and produces a flagged set of outputs. This */
/* routine signals no errors. */
/* The routine MYIO is a routine that is supplied by the user */
/* that can handle io of text lines without any action by the */
/* routine that calls it. */
/* $ Version */
/* Inspekt Routine version 2.0.0, 7-APR-1995 (WLT) */
/* Unused variables LEFT and RIGHT were removed. */
/* Spicelib functions */
if (return_()) {
return 0;
}
chkin_("FLGRPT", (ftnlen)6);
/* First find the widest of the names: */
width = 0;
i__1 = *nitems;
for (i__ = 1; i__ <= i__1; ++i__) {
if (rtrim_(names + (i__ - 1) * names_len, names_len) > width) {
width = rtrim_(names + (i__ - 1) * names_len, names_len);
}
}
/* Now for each of the NAME/VALUE pairs construct a style */
/* string using NAMES and run the VALUES through NICEPR_1. */
i__1 = *nitems;
for (i__ = 1; i__ <= i__1; ++i__) {
/* First we need to find a character that is not used */
/* in the NAMES(I)/VALUES(I) pair. We will use this as */
/* a hardspace in our style string. */
for (j = 33; j <= 127; ++j) {
free[(i__2 = j) < 129 && 0 <= i__2 ? i__2 : s_rnge("free", i__2,
"flgrpt_", (ftnlen)102)] = TRUE_;
}
i__2 = width;
for (j = 1; j <= i__2; ++j) {
free[(i__3 = *(unsigned char *)&names[(i__ - 1) * names_len + (j
- 1)]) < 129 && 0 <= i__3 ? i__3 : s_rnge("free", i__3,
"flgrpt_", (ftnlen)106)] = FALSE_;
}
i__2 = i_len(values, values_len);
for (j = 1; j <= i__2; ++j) {
free[(i__3 = *(unsigned char *)&values[(i__ - 1) * values_len + (
j - 1)]) < 129 && 0 <= i__3 ? i__3 : s_rnge("free", i__3,
"flgrpt_", (ftnlen)110)] = FALSE_;
}
j = 33;
while(! free[(i__2 = j) < 129 && 0 <= i__2 ? i__2 : s_rnge("free",
i__2, "flgrpt_", (ftnlen)114)] && j < 127) {
++j;
}
*(unsigned char *)hard = (char) j;
/* Set up the style we are going to use for this */
/* value */
nspmrg_(style, (ftnlen)200);
suffix_("HARDSPACE", &c__1, style, (ftnlen)9, (ftnlen)200);
suffix_(hard, &c__1, style, (ftnlen)1, (ftnlen)200);
suffix_("FLAG", &c__1, style, (ftnlen)4, (ftnlen)200);
l = rtrim_(style, (ftnlen)200) + 2;
i__2 = width;
for (k = 1; k <= i__2; ++k) {
*(unsigned char *)letter = *(unsigned char *)&names[(i__ - 1) *
names_len + (k - 1)];
if (*(unsigned char *)letter == ' ') {
*(unsigned char *)&style[l - 1] = *(unsigned char *)hard;
} else {
*(unsigned char *)&style[l - 1] = *(unsigned char *)letter;
}
++l;
}
*(unsigned char *)&style[l - 1] = ':';
++l;
*(unsigned char *)&style[l - 1] = *(unsigned char *)hard;
/* Ok. Now just ship the stuff to the output routines. */
if (s_cmp(names + (i__ - 1) * names_len, " ", names_len, (ftnlen)1) ==
0 && s_cmp(values + (i__ - 1) * values_len, " ", values_len,
(ftnlen)1) == 0) {
i__2 = l - 2;
s_copy(style + i__2, hard, l - 1 - i__2, (ftnlen)1);
nicepr_1__(hard, style, (U_fp)myio, (ftnlen)1, l);
} else if (s_cmp(values + (i__ - 1) * values_len, " ", values_len, (
ftnlen)1) == 0) {
i__2 = l - 2;
s_copy(style + i__2, hard, l - 1 - i__2, (ftnlen)1);
nicepr_1__(hard, style, (U_fp)myio, (ftnlen)1, l);
} else {
nicepr_1__(values + (i__ - 1) * values_len, style, (U_fp)myio,
values_len, l);
}
}
chkout_("FLGRPT", (ftnlen)6);
return 0;
} /* flgrpt_ */
/* $Procedure SEPOOL ( String from pool ) */
/* Subroutine */ int sepool_(char *item, integer *fidx, char *contin, char *
string, integer *size, integer *lidx, logical *found, ftnlen item_len,
ftnlen contin_len, ftnlen string_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen), s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer comp;
logical more;
char part[80];
integer room, n;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer clast, csize;
logical gotit;
extern integer rtrim_(char *, ftnlen);
integer putat;
extern /* Subroutine */ int gcpool_(char *, integer *, integer *, integer
*, char *, logical *, ftnlen, ftnlen);
integer cfirst;
extern /* Subroutine */ int chkout_(char *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Retrieve the string starting at the FIDX element of the kernel */
/* pool variable, where the string may be continued across several */
/* components of the kernel pool variable. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* POOL */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ITEM I name of the kernel pool variable */
/* FIDX I index of the first component of the string */
/* CONTIN I character sequence used to indicate continuation */
/* STRING O a full string concatenated across continuations */
/* SIZE O the number of character in the full string value */
/* LIDX O index of the last component of the string */
/* FOUND O flag indicating success or failure of request */
/* $ Detailed_Input */
/* ITEM is the name of a kernel pool variable for which */
/* the caller wants to retrieve a full (potentially */
/* continued) string. */
/* FIDX is the index of the first component (the start) of */
/* the string in ITEM. */
/* CONTIN is a sequence of characters which (if they appear as */
/* the last non-blank sequence of characters in a */
/* component of a value of a kernel pool variable) */
/* indicate that the string associated with the */
/* component is continued into the next literal */
/* component of the kernel pool variable. */
/* If CONTIN is blank, all of the components of ITEM */
/* will be retrieved as a single string. */
/* $ Detailed_Output */
/* STRING is the full string starting at the FIDX element of the */
/* kernel pool variable specified by ITEM. */
/* Note that if STRING is not sufficiently long to hold */
/* the fully continued string, the value will be */
/* truncated. You can determine if STRING has been */
/* truncated by examining the variable SIZE. */
/* SIZE is the index of last non-blank character of */
/* continued string as it is represented in the */
/* kernel pool. This is the actual number of characters */
/* needed to hold the requested string. If STRING */
/* contains a truncated portion of the full string, */
/* RTRIM(STRING) will be less than SIZE. */
/* If the value of STRING should be a blank, then */
/* SIZE will be set to 1. */
/* LIDX is the index of the last component (the end) of */
/* the retrieved string in ITEM. */
/* FOUND is a logical variable indicating success of the */
/* request to retrieve the string. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the variable specified by ITEM is not present in the */
/* kernel pool or is present but is not character valued, STRING */
/* will be returned as a blank, SIZE will be returned with the */
/* value 0 and FOUND will be set to .FALSE. In particular if NTH */
/* is less than 1, STRING will be returned as a blank, SIZE will */
/* be zero and FOUND will be FALSE. */
/* 2) If the variable specified has a blank string associated */
/* with its full string starting at FIDX, STRING will be blank, */
/* SIZE will be 1 and FOUND will be set to .TRUE. */
/* 3) If STRING is not long enough to hold all of the characters */
/* associated with the NTH string, it will be truncated on the */
/* right. */
/* 4) If the continuation character is a blank, every component */
/* of the variable specified by ITEM will be inserted into */
/* the output string. */
/* 5) If the continuation character is blank, then a blank component */
/* of a variable is treated as a component with no letters. */
/* For example: */
/* STRINGS = ( 'This is a variable' */
/* 'with a blank' */
/* ' ' */
/* 'component.' ) */
/* Is equivalent to */
/* STRINGS = ( 'This is a variable' */
/* 'with a blank' */
/* 'component.' ) */
/* from the point of view of SEPOOL if CONTIN is set to the */
/* blank character. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The SPICE Kernel Pool provides a very convenient interface */
/* for supplying both numeric and textual data to user application */
/* programs. However, any particular component of a character */
/* valued component of a kernel pool variable is limited to 80 */
/* or fewer characters in length. */
/* This routine allows you to overcome this limitation by */
/* "continuing" a character component of a kernel pool variable. */
/* To do this you need to select a continuation sequence */
/* of characters and then insert this sequence as the last non-blank */
/* set of characters that make up the portion of the component */
/* that should be continued. */
/* For example, you may decide to use the sequence '//' to indicate */
/* that a string should be continued to the next component of */
/* a kernel pool variable. Then set up the */
/* kernel pool variable as shown below */
/* LONG_STRINGS = ( 'This is part of the first component //' */
/* 'that needs more than one line when //' */
/* 'inserting it into the kernel pool.' */
/* 'This is the second string that is split //' */
/* 'up as several components of a kernel pool //' */
/* 'variable.' ) */
/* When loaded into the kernel pool, the variable LONG_STRINGS */
/* will have six literal components: */
/* COMPONENT (1) = 'This is part of the first component //' */
/* COMPONENT (2) = 'that needs more than one line when //' */
/* COMPONENT (3) = 'inserting it into the kernel pool.' */
/* COMPONENT (4) = 'This is the second string that is split //' */
/* COMPONENT (5) = 'up as several components of a kernel pool //' */
/* COMPONENT (6) = 'variable.' */
/* These are the components that would be retrieved by the call */
/* CALL GCPOOL ( 'LONG_STRINGS', 1, 6, N, COMPONENT, FOUND ) */
/* However, using the routine SEPOOL you can view the variable */
/* LONG_STRINGS as having two long components. */
/* STRING (1) = 'This is part of the first component that ' */
/* . // 'needs more than one line when inserting ' */
/* . // 'it into the kernel pool. ' */
/* STRING (2) = 'This is the second string that is split ' */
/* . // 'up as several components of a kernel pool ' */
/* . // 'variable. ' */
/* These string components would be retrieved by the following two */
/* calls. */
/* FIDX = 1 */
/* CALL SEPOOL ( 'LONG_STRINGS', FIDX, '//', */
/* . STRING(1), SIZE, LIDX, FOUND ) */
/* FIDX = LIDX+1 */
/* CALL SEPOOL ( 'LONG_STRINGS', FIDX, '//', */
/* . STRING(2), SIZE, LIDX, FOUND ) */
/* $ Examples */
/* Example 1. Retrieving file names. */
/* Suppose a you have used the kernel pool as a mechanism for */
/* specifying SPK files to load at startup but that the full */
/* names of the files are too long to be contained in a single */
/* text line of a kernel pool assignment. */
/* By selecting an appropriate continuation character ('*' for */
/* example) you can insert the full names of the SPK files */
/* into the kernel pool and then retrieve them using this */
/* routine. */
/* First set up the kernel pool specification of the strings */
/* as shown here: */
/* SPK_FILES = ( 'this_is_the_full_path_specification_*' */
/* 'of_a_file_with_a_long_name' */
/* 'this_is_the_full_path_specification_*' */
/* 'of_a_second_file_with_a_very_long_*' */
/* 'name' ) */
/* Now to retrieve and load the SPK_FILES one at a time, */
/* exercise the following loop. */
/* INTEGER FILSIZ */
/* PARAMETER ( FILSIZ = 255 ) */
/* CHARACTER*(FILSIZ) FILE */
/* INTEGER I */
/* INTEGER LIDX */
/* I = 1 */
/* CALL SEPOOL ( 'SPK_FILES', I, '*', FILE, SIZE, LIDX, FOUND ) */
/* DO WHILE ( FOUND .AND. RTRIM(FILE) .EQ. SIZE ) */
/* CALL SPKLEF ( FILE, HANDLE ) */
/* I = LIDX + 1 */
/* CALL SEPOOL ( 'SPK_FILES', I, '*', FILE, SIZE, LIDX, FOUND ) */
/* END DO */
/* IF ( FOUND .AND. RTRIM(FILE) .NE. SIZE ) THEN */
/* WRITE (*,*) 'The ', I, '''th file name was too long.' */
/* END IF */
/* Example 2. Retrieving all components as a string. */
/* Occasionally, it may be useful to retrieve the entire */
/* contents of a kernel pool variable as a single string. To */
/* do this you can use the blank character as the */
/* continuation character. For example if you place the */
/* following assignment in a text kernel */
/* COMMENT = ( 'This is a long note ' */
/* ' about the intended ' */
/* ' use of this text kernel that ' */
/* ' can be retrieved at run time.' ) */
/* you can retrieve COMMENT as single string via the call below. */
/* CALL SEPOOL ( 'COMMENT', 1, ' ', COMMNT, SIZE, LIDX, FOUND ) */
/* The result will be that COMMNT will have the following value. */
/* COMMNT = 'This is a long note about the intended use of ' */
/* . // 'this text kernel that can be retrieved at run ' */
/* . // 'time. ' */
/* Note that the leading blanks of each component of COMMENT are */
/* significant, trailing blanks are not significant. */
/* If COMMENT had been set as */
/* COMMENT = ( 'This is a long note ' */
/* 'about the intended ' */
/* 'use of this text kernel that ' */
/* 'can be retrieved at run time.' ) */
/* Then the call to SEPOOL above would have resulted in several */
/* words being run together as shown below. */
/* COMMNT = 'This is a long noteabout the intendeduse of ' */
/* . // 'this text kernel thatcan be retrieved at run ' */
/* . // 'time. ' */
/* resulted in several words being run together as shown below. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 12-APR-2012 (WLT)(BVS) */
/* -& */
/* $ Index_Entries */
/* Retrieve a continued string value from the kernel pool */
/* -& */
/* SPICELIB Variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
/* Return empty output if the input index is bad. */
if (*fidx < 1) {
*found = FALSE_;
s_copy(string, " ", string_len, (ftnlen)1);
*size = 0;
*lidx = 0;
return 0;
}
/* Check in. */
chkin_("SEPOOL", (ftnlen)6);
/* Check if the first component exists. Return empty output if not. */
gcpool_(item, fidx, &c__1, &n, part, &gotit, item_len, (ftnlen)80);
gotit = gotit && n > 0;
if (! gotit) {
*found = FALSE_;
s_copy(string, " ", string_len, (ftnlen)1);
*size = 0;
*lidx = 0;
chkout_("SEPOOL", (ftnlen)6);
return 0;
}
/* Fetch the string using Bill's algorithm from STPOOL 'as is'. */
room = i_len(string, string_len);
csize = rtrim_(contin, contin_len);
putat = 1;
comp = *fidx;
more = TRUE_;
s_copy(string, " ", string_len, (ftnlen)1);
n = 0;
while(more) {
gcpool_(item, &comp, &c__1, &n, part, &more, item_len, (ftnlen)80);
more = more && n > 0;
if (more) {
*found = TRUE_;
clast = rtrim_(part, (ftnlen)80);
cfirst = clast - csize + 1;
if (cfirst < 0) {
if (putat <= room) {
s_copy(string + (putat - 1), part, string_len - (putat -
1), clast);
}
putat += clast;
more = FALSE_;
} else if (s_cmp(part + (cfirst - 1), contin, clast - (cfirst - 1)
, contin_len) != 0) {
if (putat <= room) {
s_copy(string + (putat - 1), part, string_len - (putat -
1), clast);
}
putat += clast;
more = FALSE_;
} else if (cfirst > 1) {
if (putat <= room) {
s_copy(string + (putat - 1), part, string_len - (putat -
1), cfirst - 1);
}
putat = putat + cfirst - 1;
}
}
++comp;
}
/* We are done. Get the size of the full string and the index of its */
/* last component and checkout. */
*size = putat - 1;
*lidx = comp - 1;
chkout_("SEPOOL", (ftnlen)6);
return 0;
} /* sepool_ */
/* $Procedure M2TRIM ( META/2 trim the name portion from a word ) */
/* Subroutine */ int m2trim_(char *word, char *root, ftnlen word_len, ftnlen
root_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen);
/* Local variables */
static integer b, e, blank, lbrace, rbrace;
extern integer qrtrim_(char *, ftnlen);
/* $ Abstract */
/* Extract the "root" of a META/2 template word. That is trim off */
/* the name portion of a template word. */
/* $ 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 */
/* META/2 */
/* $ Keywords */
/* META1 */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* WORD I A word from a META/2 template. */
/* ROOT O The input word trimmed of any name specification. */
/* $ Detailed_Input */
/* WORD is a word from a META/2 template. It may or may not */
/* looklike ROOT // '[name]' */
/* $ Detailed_Output */
/* ROOT is the portion of the input word that precedes the */
/* name portion of the input WORD. ROOT may overwrite */
/* WORD. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* If ROOT is not sufficiently large to contain all of the output, */
/* it will be truncated on the right. */
/* $ Files */
/* None. */
/* $ Particulars */
/* META/2 template words can have appended to them "variable" names */
/* that will be used to store substring boundaries of STRINGS matched */
/* against META/2 templates. For example */
/* FIND @name[WINDOW] */
/* SEPARATION (2:2){ OF @int[BODY1] @int[BODY2] */
/* | FROM @int[OBSERVER] } */
/* the words */
/* @name[WINDOW], @int[BODY1], @int[BODY2], @int[OBSERVER] */
/* all have "varialbe" name substrings. They are: */
/* WINDOW, BODY1, BODY2, and OBSERVER respectively. */
/* The routine removes variable names and associated brackets in WORD */
/* if they exist. */
/* $ Examples */
/* Below is a table descibing sample inputs and outputs. */
/* WORD ROOT */
/* --------------- ------------------ */
/* @int[SPUD] @int */
/* @name[WINDOW] @name */
/* SEARCH[GET] SEARCH */
/* @name @name */
/* @body(2:4)[LIST] @body(2:4) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* 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, 21-NOV-1991 (WLT) */
/* -& */
/* $ Index_Entry */
/* Extract the root of a META/2 template word. */
/* -& */
/* SPICELIB functions */
/* Local variables */
s_copy(root, word, root_len, word_len);
lbrace = '[';
rbrace = ']';
blank = ' ';
e = i_len(word, word_len);
/* This loop is the same as RTRIM only faster. */
e = qrtrim_(word, word_len);
/* If the length is not at least 4 or the last character is not */
/* a right brace, there is no name associated with this word. */
if (*(unsigned char *)&word[e - 1] == rbrace && e >= 4) {
/* Ok. We have a chance at getting a name. Look for */
/* a left brace and if found blank out the end portion of */
/* ROOT. */
b = 2;
while(b < e - 1) {
if (*(unsigned char *)&word[b - 1] == lbrace) {
/* We've found the beginning of the name portion */
/* of the word. Record the end of the meta-2 */
/* word and then reset L so that we exit this loop. */
s_copy(root + (b - 1), " ", root_len - (b - 1), (ftnlen)1);
b = e;
}
++b;
}
}
return 0;
} /* m2trim_ */
/* $Procedure NBWID ( Non-blank width of a character array ) */
integer nbwid_(char *array, integer *nelt, ftnlen array_len)
{
/* System generated locals */
integer ret_val;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Local variables */
integer i__, j, strlen;
/* $ Abstract */
/* Determine the non-blank width of a character array---that is, */
/* the largest value of LASTNB for any element in the array. */
/* $ 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 */
/* ARRAY, CHARACTER */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ARRAY I Input array. */
/* NELT I Number of elements in the array. */
/* NBWID O Maximum value of LASTNB for the array. */
/* $ Detailed_Input */
/* ARRAY is the input array. */
/* NELT is the number of elements in the input array. */
/* $ Detailed_Output */
/* NBWID is the index of the rightmost non-blank character */
/* in the entire array. This is equivalent to the */
/* maximum value of LASTNB for the array, but somewhat */
/* more efficient to compute. If NELT is not greater */
/* than zero, NBWID is zero. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* Find the last non-blank character in the first element of the */
/* array. Search the rest of the elements, starting at the end of */
/* each string and moving back just far enough to determine if the */
/* current string is wider than any of the previous ones. (This */
/* makes NBWID somewhat more efficient than LASTNB.) */
/* If any of the strings is found to contain no trailing blanks, */
/* NBWID is just the length of the individual elements of the array, */
/* and the search is terminated immediately. */
/* $ Examples */
/* Let ARRAY contain the following strings. */
/* ARRAY(1) = 'A string of medium length ' */
/* ARRAY(2) = 'A very long string, much longer than the rest ' */
/* ARRAY(3) = 'Shorter ' */
/* ARRAY(4) = 'Short ' */
/* Then the value returned by */
/* WIDEST = NBWID ( ARRAY, 4 ) */
/* is 45. */
/* If the word 'rest' in the second element is changed to 'others', */
/* the value returned is 47, and the search is terminated after the */
/* second element. */
/* $ Restrictions */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Author_and_Institution */
/* I.M. Underwood (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) */
/* -& */
/* $ Index_Entries */
/* non-blank width of a character array */
/* -& */
/* Local variables */
/* Nonsense case: no elements. */
if (*nelt < 1) {
ret_val = 0;
/* Get the length of the individual elements of the string. */
/* So far, we have no maximum width, because we haven't examined */
/* any elements. */
} else {
strlen = i_len(array, array_len);
ret_val = 0;
i__ = 0;
/* Continue until the end of the array is reached, or until */
/* a string with no trailing blanks is found. */
while(i__ < *nelt && ret_val < strlen) {
/* Search no further than the current value of NBWID. */
++i__;
j = strlen;
while(j > ret_val && *(unsigned char *)&array[(i__ - 1) *
array_len + (j - 1)] == ' ') {
--j;
}
/* NBWID only increases if this string was wider than all */
/* previous strings. */
ret_val = max(ret_val,j);
}
}
return ret_val;
} /* nbwid_ */
/* $Procedure DASADC ( DAS, add data, character ) */
/* Subroutine */ int dasadc_(integer *handle, integer *n, integer *bpos,
integer *epos, char *data, ftnlen data_len)
{
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer free;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer ncomc, lastc, recno, ncomr, nmove, rcpos;
extern /* Subroutine */ int dasa2l_(integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
extern logical failed_(void);
integer clbase;
extern /* Subroutine */ int dascud_(integer *, integer *, integer *),
dashfs_(integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
char record[1024];
integer lastla[3];
extern /* Subroutine */ int dasurc_(integer *, integer *, integer *,
integer *, char *, ftnlen), daswrc_(integer *, integer *, char *,
ftnlen);
integer lastrc[3], clsize, nmoved;
extern /* Subroutine */ int sigerr_(char *, ftnlen);
integer numchr;
extern /* Subroutine */ int chkout_(char *, ftnlen);
integer lastwd[3], nresvc;
extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen);
integer wordno;
extern logical return_(void);
integer nresvr, nwritn, chr, elt;
/* $ Abstract */
/* Add character data to a DAS file. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* DAS */
/* $ Keywords */
/* ARRAY */
/* ASSIGNMENT */
/* DAS */
/* FILES */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I DAS file handle. */
/* N I Number of characters to add to file. */
/* BPOS, */
/* EPOS I Begin and end positions of substrings. */
/* DATA I Array of character strings. */
/* $ Detailed_Input */
/* HANDLE is a file handle of a DAS file opened for writing. */
/* N is the number of characters, in the specified set */
/* of substrings, to add to the specified DAS file. */
/* BPOS, */
/* EPOS are begin and end character positions that define */
/* a set of substrings in the input array. This */
/* routine writes characters from the specified set */
/* of substrings to the specified DAS file. */
/* DATA is an array of character strings, some portion of */
/* whose contents are to be added to the specified */
/* DAS file. Specifically, the first N characters of */
/* the substrings */
/* DATA(I) (BPOS:EPOS), I = 1, ... */
/* are appended to the character data in the file. */
/* The order of characters in the input substrings */
/* is considered to increase from left to right */
/* within each element of DATA, and to increase */
/* with the indices of the elements of DATA. */
/* $ Detailed_Output */
/* None. See $Particulars for a description of the effect of this */
/* routine. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the input file handle is invalid, the error will be */
/* diagnosed by routines called by this routine. */
/* 2) If EPOS or BPOS are outside of the range */
/* [ 1, LEN( DATA(1) ) ] */
/* or if EPOS < BPOS, the error SPICE(BADSUBSTRINGBOUNDS) will */
/* be signalled. */
/* 3) If the input count N is less than 1, no data will be */
/* added to the specified DAS file. */
/* 4) If an I/O error occurs during the data addition attempted */
/* by this routine, the error will be diagnosed by routines */
/* called by this routine. */
/* 5) If N is greater than the number of characters in the */
/* specified set of input substrings, the results of calling */
/* this routine are unpredictable. This routine cannot */
/* detect this error. */
/* $ Files */
/* See the description of the argument HANDLE in $Detailed_Input. */
/* $ Particulars */
/* This routine adds character data to a DAS file by `appending' it */
/* after any character data already in the file. The sense in which */
/* the data is `appended' is that the data will occupy a range of */
/* logical addresses for character data that immediately follow the */
/* last logical address of a character that is occupied at the time */
/* this routine is called. The diagram below illustrates this */
/* addition: */
/* +-------------------------+ */
/* | (already in use) | Character logical address 1 */
/* +-------------------------+ */
/* . */
/* . */
/* . */
/* +-------------------------+ Last character logical address */
/* | (already in use) | in use before call to DASADC */
/* +-------------------------+ */
/* | DATA(1) (BPOS:BPOS) | First added character */
/* +-------------------------+ */
/* | DATA(1) (BPOS+1:BPOS+1) | */
/* +-------------------------+ */
/* . */
/* . */
/* . */
/* +-------------------------+ */
/* | DATA(1) (EPOS:EPOS) | */
/* +-------------------------+ */
/* | DATA(2) (BPOS:BPOS) | */
/* +-------------------------+ */
/* . */
/* . */
/* . */
/* +-------------------------+ */
/* | DATA(R) (C:C) | Nth added character---here R is */
/* +-------------------------+ */
/* INT ( (N+L-1)/L ) */
/* where L = EPOS - BPOS + 1, and */
/* C is */
/* N - (R-1)*L */
/* The logical organization of the characters in the DAS file is */
/* independent of the order of addition to the file or physical */
/* location of any data of integer or double precision type. */
/* The actual physical write operations that add the input array */
/* DATA to the indicated DAS file may not take place before this */
/* routine returns, since the DAS system buffers data that is */
/* written as well as data that is read. In any case, the data */
/* will be flushed to the file at the time the file is closed, if */
/* not earlier. A physical write of all buffered records can be */
/* forced by calling the SPICELIB routine DASWUR ( DAS, write */
/* updated records ). */
/* In order to update character logical addresses that already */
/* contain data, the SPICELIB routine DASUDC (DAS, update data, */
/* character) should be used. */
/* $ Examples */
/* 1) Create the new DAS file TEST.DAS and add 120 characters to it. */
/* Close the file, then re-open it and read the data back out. */
/* PROGRAM TEST_ADD */
/* CHARACTER*(80) LINES ( 3 ) */
/* CHARACTER*(4) TYPE */
/* INTEGER HANDLE */
/* INTEGER I */
/* DATA LINES / 'Here is the first line.', */
/* . 'Here is the second line.', */
/* . 'Here is the third line.' / */
/* C */
/* C Open a new DAS file. Use the file name as */
/* C the internal file name. */
/* C */
/* TYPE = 'TEST' */
/* CALL DASONW ( 'TEST.DAS', TYPE, 'TEST.DAS', HANDLE ) */
/* C */
/* C Add the contents of the array LINES to the file. */
/* C Since the lines are short, just use the first 40 */
/* C characters of each one. */
/* C */
/* CALL DASADC ( HANDLE, 120, 1, 40, LINES ) */
/* C */
/* C Close the file. */
/* C */
/* CALL DASCLS ( HANDLE ) */
/* C */
/* C Now verify the addition of data by opening the */
/* C file for read access and retrieving the data. */
/* C */
/* CALL DASOPR ( 'TEST.DAS', HANDLE ) */
/* DO I = 1, 3 */
/* LINES(I) = ' ' */
/* END DO */
/* CALL DASRDC ( HANDLE, 1, 120, 1, 40, LINES ) */
/* C */
/* C Dump the data to the screen. We should see the */
/* C sequence */
/* C */
/* C Here is the first line. */
/* C Here is the second line. */
/* C Here is the third line. */
/* C */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Data from TEST.DAS: ' */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) LINES */
/* END */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.1 19-DEC-1995 (NJB) */
/* Corrected title of permuted index entry section. */
/* - SPICELIB Version 1.1.0 12-MAY-1994 (KRG) (NJB) */
/* Test of FAILED() added to loop termination condition. */
/* Removed references to specific DAS file open routines in the */
/* $ Detailed_Input section of the header. This was done in order */
/* to minimize documentation changes if the DAS open routines ever */
/* change. */
/* Modified the $ Examples section to demonstrate the new ID word */
/* format which includes a file type and to include a call to the */
/* new routine DASONW, open new, which makes use of the file */
/* type. Also, a variable for the type of the file to be created */
/* was added. */
/* - SPICELIB Version 1.0.0, 11-NOV-1992 (NJB) (WLT) */
/* -& */
/* $ Index_Entries */
/* add character data to a DAS file */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.1.0, 12-MAY-1994 (KRG) (NJB) */
/* Test of FAILED() added to loop termination condition. Without */
/* this test, an infinite loop could result if DASA2L, DASURC or */
/* DASWRC signaled an error inside the loop. */
/* Removed references to specific DAS file open routines in the */
/* $ Detailed_Input section of the header. This was done in order */
/* to minimize documentation changes if the DAS open routines ever */
/* change. */
/* Modified the $ Examples section to demonstrate the new ID word */
/* format which includes a file type and to include a call to the */
/* new routine DASONW, open new, which makes use of the file */
/* type. Also, a variable for the type of the file to be created */
/* was added. */
/* - SPICELIB Version 1.0.0, 11-NOV-1992 (NJB) (WLT) */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("DASADC", (ftnlen)6);
}
/* Make sure BPOS and EPOS are OK; stop here if not. */
if (*bpos < 1 || *epos < 1 || *bpos > i_len(data, data_len) || *epos >
i_len(data, data_len)) {
setmsg_("Substring bounds must be in range [1,#]. Actual range [BPOS"
",EPOS] was [#,#].", (ftnlen)76);
i__1 = i_len(data, data_len);
errint_("#", &i__1, (ftnlen)1);
errint_("#", bpos, (ftnlen)1);
errint_("#", epos, (ftnlen)1);
sigerr_("SPICE(BADSUBSTRINGBOUNDS)", (ftnlen)25);
chkout_("DASADC", (ftnlen)6);
return 0;
} else if (*epos < *bpos) {
setmsg_("Substring upper bound must not be less than lower bound. A"
"ctual range [BPOS,EPOS] was [#,#].", (ftnlen)93);
errint_("#", bpos, (ftnlen)1);
errint_("#", epos, (ftnlen)1);
sigerr_("SPICE(BADSUBSTRINGBOUNDS)", (ftnlen)25);
chkout_("DASADC", (ftnlen)6);
return 0;
}
/* Get the file summary for this DAS. */
dashfs_(handle, &nresvr, &nresvc, &ncomr, &ncomc, &free, lastla, lastrc,
lastwd);
lastc = lastla[0];
/* We will keep track of the location that we wish to write to */
/* with the variables RECNO and WORDNO. RECNO will be the record */
/* number of the record we'll write to; WORDNO will be the number */
/* preceding the word index, within record number RECNO, that we'll */
/* write to. For example, if we're about to write to the first */
/* character in record 10, RECNO will be 10 and WORDNO will be 0. Of */
/* course, when WORDNO reaches NWC, we'll have to find a free record */
/* before writing anything. */
/* Prepare the variables RECNO and WORDNO: use the physical location */
/* of the last character address, if there are any character data in */
/* the file. Otherwise, RECNO becomes the first record available for */
/* character data. */
if (lastc >= 1) {
dasa2l_(handle, &c__1, &lastc, &clbase, &clsize, &recno, &wordno);
} else {
recno = free;
wordno = 0;
}
/* Set the number of character words already written. Keep */
/* writing to the file until this number equals the number of */
/* elements in DATA. */
/* Note that if N is non-positive, the loop doesn't get */
/* exercised. */
/* Also initialize the array element index and position of the */
/* character to be moved next. */
nwritn = 0;
elt = 1;
chr = *bpos;
while(nwritn < *n && ! failed_()) {
/* Write as much data as we can (or need to) into the current */
/* record. We assume that RECNO, WORDNO, and NWRITN have */
/* been set correctly at this point. */
/* Find out how many words to write into the current record. */
/* There may be no space left in the current record. */
/* Computing MIN */
i__1 = *n - nwritn, i__2 = 1024 - wordno;
numchr = min(i__1,i__2);
if (numchr > 0) {
/* Write NUMCHR words into the current record. If the record */
/* is new, write the entire record. Otherwise, just update */
/* the part we're interested in. */
/* In either case, we'll first fill in characters WORDNO+1 */
/* through WORDNO + NUMCHR of the string RECORD. */
/* So far, we haven't moved any characters. */
nmoved = 0;
rcpos = wordno;
while(nmoved < numchr) {
/* Find out how many characters in the current array */
/* element we should move. */
if (chr > *epos) {
++elt;
chr = *bpos;
}
/* Computing MIN */
i__1 = numchr - nmoved, i__2 = *epos - chr + 1;
nmove = min(i__1,i__2);
i__1 = rcpos;
s_copy(record + i__1, data + ((elt - 1) * data_len + (chr - 1)
), rcpos + nmove - i__1, data_len - (chr - 1));
nmoved += nmove;
rcpos += nmove;
chr += nmove;
}
/* Now we can write or update the file with RECORD. */
if (wordno == 0) {
/* The record has not yet been written, so write out the */
/* entire record. */
daswrc_(handle, &recno, record, (ftnlen)1024);
} else {
/* Update elements WORDNO+1 through WORDNO+NUMCHR. */
i__1 = wordno;
i__2 = wordno + 1;
i__3 = wordno + numchr;
dasurc_(handle, &recno, &i__2, &i__3, record + i__1, wordno +
numchr - i__1);
}
nwritn += numchr;
wordno += numchr;
} else {
/* It's time to start on a new record. If the record we */
/* just finished writing to (or just attempted writing to, */
/* if it was full) was FREE or a higher-numbered record, */
/* then we are writing to a contiguous set of data records: */
/* the next record to write to is the immediate successor */
/* of the last one. Otherwise, FREE is the next record */
/* to write to. */
/* We intentionally leave FREE at the value it had before */
/* we starting adding data to the file. */
if (recno >= free) {
++recno;
} else {
recno = free;
}
wordno = 0;
}
}
/* Update the DAS file directories to reflect the addition of N */
/* character words. DASCUD will also update the file summary */
/* accordingly. */
dascud_(handle, &c__1, n);
chkout_("DASADC", (ftnlen)6);
return 0;
} /* dasadc_ */
/* $Procedure BEUNS ( Be an unsigned integer? ) */
logical beuns_(char *string, ftnlen string_len)
{
/* System generated locals */
logical ret_val;
/* Builtin functions */
integer i_len(char *, ftnlen), i_indx(char *, char *, ftnlen, ftnlen),
s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer i__, l;
logical ok;
extern integer frstnb_(char *, ftnlen);
/* $ Abstract */
/* Determine whether a string represents an unsigned 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 */
/* WORDS */
/* $ Keywords */
/* ALPHANUMERIC */
/* NUMBERS */
/* SCANNING */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* STRING I Character string. */
/* The function returns TRUE if the string represents an unsigned */
/* integer. Otherwise, it returns FALSE. */
/* $ Detailed_Input */
/* STRING is any string. */
/* $ Detailed_Output */
/* If STRING contains a single word made entirely from the */
/* characters '0' through '9', then the function returns TRUE. */
/* Otherwise, it returns FALSE. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Particulars */
/* By definition an unsigned integer is a word made exclusively */
/* from the characters '0', '1', '2', '3', '4', '5', '6', '7', '8', */
/* and '9'. */
/* $ Examples */
/* Four classes of numbers recognized by the various BE functions. */
/* UNS unsigned integer */
/* INT integer (includes INT) */
/* DEC decimal number (includes UNS, INT) */
/* NUM number (includes UNS, INT, NUM) */
/* The following table illustrates the differences between */
/* the classes. (Any number of leading and trailing blanks */
/* are acceptable.) */
/* String Accepted by */
/* ------------------ ------------------ */
/* 0 UNS, INT, DEC, NUM */
/* 21 */
/* 21994217453648 */
/* +0 INT, DEC, NUM */
/* -13 */
/* +21946 */
/* 1.23 DEC, NUM */
/* 12. */
/* .17 */
/* +4.1 */
/* -.25 */
/* 2.3e17 NUM */
/* 17.D-13275849 */
/* -.194265E+0004 */
/* Note that the functions don't take the magnitudes of the numbers */
/* into account. They may accept numbers that cannot be represented */
/* in Fortran variables. (For example, '2.19E999999999999' probably */
/* exceeds the maximum floating point number on any machine, but */
/* is perfectly acceptable to BENUM.) */
/* The following strings are not accepted by any of the functions. */
/* String Reason */
/* --------------- ---------------------------------------- */
/* 3/4 No implied operations (rational numbers) */
/* 37+14 No explicit operations */
/* E12 Must have mantissa */
/* 217,346.91 No commas */
/* 3.14 159 264 No embedded spaces */
/* PI No special numbers */
/* FIVE No textual numbers */
/* CXIV No roman numerals */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 01-DEC-1995 (WLT) */
/* -& */
/* $ Index_Entries */
/* determine if a string is an unsigned integer */
/* -& */
/* SPICE functions */
/* Local variables */
/* Get the length of the string and the position of its */
/* first non-blank character. */
l = i_len(string, string_len);
i__ = frstnb_(string, string_len);
/* If there isn't a non-blank character, this isn't an */
/* unsigned integer. */
if (i__ == 0) {
ret_val = FALSE_;
return ret_val;
}
/* As far as we know right now, everything is ok. Examine */
/* characters until we run out of string or until we */
/* hit a non-digit character. */
ok = TRUE_;
while(ok && i__ <= l) {
if (i_indx("0123456789", string + (i__ - 1), (ftnlen)10, (ftnlen)1) >
0) {
++i__;
} else {
ok = FALSE_;
}
}
/* If the string still is ok as an unsigned integer, it must be */
/* one... */
if (ok) {
ret_val = TRUE_;
} else {
/* ... otherwise, it's an unsigned integer if the remainder is blank. */
ret_val = s_cmp(string + (i__ - 1), " ", string_len - (i__ - 1), (
ftnlen)1) == 0;
}
return ret_val;
} /* beuns_ */
/* Subroutine */ int svout_(integer *lout, integer *n, real *sx, integer *
idigit, char *ifmt, ftnlen ifmt_len)
{
/* Format strings */
static char fmt_9999[] = "(/1x,a/1x,a)";
static char fmt_9998[] = "(1x,i4,\002 - \002,i4,\002:\002,1p10e12.3)";
static char fmt_9997[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p8e14.5)";
static char fmt_9996[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p6e18.9)";
static char fmt_9995[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p5e24.13)";
static char fmt_9994[] = "(1x,\002 \002)";
/* System generated locals */
integer i__1, i__2, i__3;
/* Local variables */
static integer i__, k1, k2, lll;
static char line[80];
static integer ndigit;
/* Fortran I/O blocks */
static cilist io___4 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___8 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___9 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___10 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___11 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___12 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___13 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___14 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___15 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___16 = { 0, 0, 0, fmt_9994, 0 };
/* ... */
/* ... SPECIFICATIONS FOR ARGUMENTS */
/* ... */
/* ... SPECIFICATIONS FOR LOCAL VARIABLES */
/* ... */
/* ... FIRST EXECUTABLE STATEMENT */
/* Parameter adjustments */
--sx;
/* Function Body */
/* Computing MIN */
i__1 = i_len(ifmt, ifmt_len);
lll = min(i__1,80);
i__1 = lll;
for (i__ = 1; i__ <= i__1; ++i__) {
*(unsigned char *)&line[i__ - 1] = '-';
/* L10: */
}
for (i__ = lll + 1; i__ <= 80; ++i__) {
*(unsigned char *)&line[i__ - 1] = ' ';
/* L20: */
}
io___4.ciunit = *lout;
s_wsfe(&io___4);
do_fio(&c__1, ifmt, ifmt_len);
do_fio(&c__1, line, lll);
e_wsfe();
if (*n <= 0) {
return 0;
}
ndigit = *idigit;
if (*idigit == 0) {
ndigit = 4;
}
/* ======================================================================= */
/* CODE FOR OUTPUT USING 72 COLUMNS FORMAT */
/* ======================================================================= */
if (*idigit < 0) {
ndigit = -(*idigit);
if (ndigit <= 4) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 5) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 4;
k2 = min(i__2,i__3);
io___8.ciunit = *lout;
s_wsfe(&io___8);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(real));
}
e_wsfe();
/* L30: */
}
} else if (ndigit <= 6) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 4) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 3;
k2 = min(i__2,i__3);
io___9.ciunit = *lout;
s_wsfe(&io___9);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(real));
}
e_wsfe();
/* L40: */
}
} else if (ndigit <= 10) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 3) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 2;
k2 = min(i__2,i__3);
io___10.ciunit = *lout;
s_wsfe(&io___10);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(real));
}
e_wsfe();
/* L50: */
}
} else {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 2) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 1;
k2 = min(i__2,i__3);
io___11.ciunit = *lout;
s_wsfe(&io___11);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(real));
}
e_wsfe();
/* L60: */
}
}
/* ======================================================================= */
/* CODE FOR OUTPUT USING 132 COLUMNS FORMAT */
/* ======================================================================= */
} else {
if (ndigit <= 4) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 10) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 9;
k2 = min(i__2,i__3);
io___12.ciunit = *lout;
s_wsfe(&io___12);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(real));
}
e_wsfe();
/* L70: */
}
} else if (ndigit <= 6) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 8) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 7;
k2 = min(i__2,i__3);
io___13.ciunit = *lout;
s_wsfe(&io___13);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(real));
}
e_wsfe();
/* L80: */
}
} else if (ndigit <= 10) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 6) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 5;
k2 = min(i__2,i__3);
io___14.ciunit = *lout;
s_wsfe(&io___14);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(real));
}
e_wsfe();
/* L90: */
}
} else {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 5) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 4;
k2 = min(i__2,i__3);
io___15.ciunit = *lout;
s_wsfe(&io___15);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(real));
}
e_wsfe();
/* L100: */
}
}
}
io___16.ciunit = *lout;
s_wsfe(&io___16);
e_wsfe();
return 0;
} /* svout_ */