/* $Procedure LSTLEC ( Last character element less than or equal to. ) */
integer lstlec_(char *string, integer *n, char *array, ftnlen string_len,
ftnlen array_len)
{
/* System generated locals */
integer ret_val;
/* Builtin functions */
logical l_lt(char *, char *, ftnlen, ftnlen), l_ge(char *, char *, ftnlen,
ftnlen), l_le(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer j, begin, items, middle, end;
/* $ Abstract */
/* Given a character string and an ordered array of character */
/* strings, find the index of the largest array element less than */
/* or equal to the given 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 */
/* SEARCH, ARRAY */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* STRING I Value to search against */
/* ARRAY I Array of possible lower bounds */
/* N I Number elements in ARRAY */
/* LSTLEC O the index of the last element of ARRAY <= STRING */
/* $ Detailed_Input */
/* STRING Character string for which one desires to find */
/* the last ARRAY element less than or equal (lexically) */
/* to string. */
/* ARRAY Ordered array of character strings. We will find the */
/* last element of the sequence that is less than or equal */
/* to STRING. */
/* N Total number of elements in ARRAY */
/* $ Detailed_Output */
/* LSTLEC Index of the last element of the ordered array */
/* {ARRAY(I) : 0 < I < N + 1} that is less than or equal */
/* to STRING. (Note that LSTLEC = I for some I in the */
/* range 1 to N unless STRING is less than all of these */
/* elements in which case LSTLEC = 0.) */
/* In the case that N is input with value less than or equal */
/* to zero, LSTLEC is returned as zero. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* An ordered array of character strings is given. */
/* Given a character string STRING, there will be a last one of */
/* these strings that is less than or equal to STRING. */
/* This routine finds the index LSTLEC such that ARRAY(LSTLEC) is */
/* that string. */
/* If STRING is not greater than ARRAY(1), LSTLEC will be set to */
/* zero. */
/* This routine uses a binary search algorithm and so requires */
/* at most LOG_2(N) steps to find the value of LSTLTI. */
/* Note: If you need to find the first element of the array that */
/* is greater than STRING, simply add 1 to the result */
/* returned by this function and check to see if the result */
/* is within the array bounds given by N. */
/* $ Examples */
/* Suppose that you have a long list of words, sorted alphabetically */
/* and entirely in upper case. Furthermore suppose you wished to */
/* find all words that begin the sequence of letters PLA, then */
/* you could execute the following code. */
/* START = 0 */
/* I = 1 */
/* DO I = 1, NWORDS */
/* IF ( WORD(I)(1:3) .EQ. 'PLA' ) THEN */
/* IF ( START .EQ. 0 ) THEN */
/* START = I */
/* END IF */
/* END = I */
/* END IF */
/* END DO */
/* This can of course be improved by stopping the loop once START */
/* is non-zero and END remains unchanged after a pass through the */
/* loop. However, this is a linear search and on average can be */
/* expected to take NWORDS/2 comparisons. The above algorithm */
/* fails to take advantage of the structure of the list of words */
/* (they are sorted). */
/* The code below is much simpler to code, simpler to check, and */
/* much faster than the code above. */
/* START = LSTLEC( 'PL ', NWORDS, WORDS ) + 1 */
/* END = LSTLEC( 'PLA', NWORDS, WORDS ) */
/* do something in case there are no such words. */
/* IF ( START .GT. END ) THEN */
/* START = 0 */
/* END = 0 */
/* END IF */
/* This code will never exceed 2 * LOG_2 ( NWORDS ) comparisons. */
/* For a large list of words (say 4096) the second method will */
/* take 24 comparisons the first method requires on average */
/* 2048 comparisons. About 200 times as much time. Its clear */
/* that if searches such as this must be performed often, that */
/* the second approach could make the difference between being */
/* able to perform the task in a few minutes as opposed to */
/* several hours. */
/* For more ideas regarding the use of this routine see LSTLEI */
/* and LSTLTI. */
/* $ Restrictions */
/* If the array is not ordered, the program will run */
/* to completion but the index found will not mean anything. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (WLT) */
/* -& */
/* $ Index_Entries */
/* last character element less_than_or_equal_to */
/* -& */
/* $ Revisions */
/* - Beta Version 1.1.0, 9-MAR-1989 (HAN) */
/* Declaration of the variable I was removed from the code. The */
/* variable was declared but not used. */
/* - Beta Version 1.0.1, 1-Feb-1989 (WLT) */
/* Example section of header upgraded. */
/* -& */
/* Local variables */
items = *n;
begin = 1;
end = *n;
if (*n <= 0) {
/* There's nobody home---that is there is nothing in the array */
/* to compare against. Zero is the only sensible thing to return. */
ret_val = 0;
} else if (l_lt(string, array + (begin - 1) * array_len, string_len,
array_len)) {
/* None of the array elements are less than or equal to STRING */
ret_val = 0;
} else if (l_ge(string, array + (end - 1) * array_len, string_len,
array_len)) {
/* STRING is greater than or equal to all elements of the array. */
/* Thus the last element of the array is the last item less than */
/* or equal to STRING. */
ret_val = end;
} else {
/* STRING lies between some pair of elements of the array */
while(items > 2) {
j = items / 2;
middle = begin + j;
if (l_le(array + (middle - 1) * array_len, string, array_len,
string_len)) {
begin = middle;
} else {
end = middle;
}
items = end - begin + 1;
}
ret_val = begin;
}
return ret_val;
} /* lstlec_ */
/* $Procedure M2ALPH ( Determine if a word starts with a letter) */
logical m2alph_(char *word, ftnlen word_len)
{
/* System generated locals */
logical ret_val;
/* Builtin functions */
logical l_le(char *, char *, ftnlen, ftnlen), l_ge(char *, char *, ftnlen,
ftnlen);
/* Local variables */
static integer i__;
extern integer ltrim_(char *, ftnlen);
/* $ Abstract */
/* This function is true if the input string begins with an */
/* alphabetic 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 */
/* META/2 a language specification language. */
/* $ Keywords */
/* ALPHANUMERIC */
/* ASCII */
/* PARSING */
/* UTILITY */
/* WORD */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* WORD I A character string word */
/* The function is returned as .TRUE. if word is an META/2 alpha */
/* word. */
/* $ Detailed_Input */
/* WORD is a character string that is assumed to have no */
/* spaces between the first and last non-blank characters. */
/* $ Detailed_Output */
/* M2ALPH returns as .TRUE. if WORD starts with an alphabetic */
/* character. Otherwise it is returned .FALSE. */
/* $ Error_Handling */
/* None. */
/* C */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Particulars */
/* This is a utility routine for the subroutine META2. It */
/* determines whether or not a word is an alpha word in the sense */
/* of the language META/2. */
/* $ Examples */
/* WORD M2ALPH */
/* ------- ------ */
/* SPAM .TRUE. */
/* _SPUD .FALSE. */
/* THE_QUICK_BROWN_FOX .TRUE. */
/* THE_FIRST_TIME_EVERY_I_SAW_YOUR_FACE .TRUE. */
/* WHO?_ME? .TRUE. */
/* D!#@!@#! .TRUE. */
/* $ 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 */
/* Version B1.0.0, 22-MAR-1988 (WLT) (IMU) */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Make sure the string has the right length. */
i__ = ltrim_(word, word_len);
ret_val = l_le("A", word + (i__ - 1), (ftnlen)1, (ftnlen)1) && l_ge("Z",
word + (i__ - 1), (ftnlen)1, (ftnlen)1) || l_le("a", word + (i__
- 1), (ftnlen)1, (ftnlen)1) && l_ge("z", word + (i__ - 1), (
ftnlen)1, (ftnlen)1);
return ret_val;
} /* m2alph_ */
/* $Procedure M2NUMB ( Determine whether or not a word is a number ) */
logical m2numb_(char *word, ftnlen word_len)
{
/* System generated locals */
logical ret_val;
/* Builtin functions */
logical l_le(char *, char *, ftnlen, ftnlen), l_ge(char *, char *, ftnlen,
ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static doublereal x;
extern integer ltrim_(char *, ftnlen);
static char error[80];
static integer start, length;
extern /* Subroutine */ int nparsd_(char *, doublereal *, char *, integer
*, ftnlen, ftnlen);
static integer pointr;
extern integer qrtrim_(char *, ftnlen);
static integer end;
/* $ Abstract */
/* This function is true if the input string is a number in the */
/* sense of META/2. */
/* $ 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 a language specification language. */
/* $ Keywords */
/* ALPHANUMERIC */
/* ASCII */
/* PARSING */
/* UTILITY */
/* WORD */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* WORD I A character string word */
/* The function is returned as .TRUE. if word is an META/2 number. */
/* $ Detailed_Input */
/* WORD is a character string that is assumed to have no */
/* spaces between the first and last non-blank characters. */
/* $ Detailed_Output */
/* M2NUMB returns as .TRUE. if WORD is a parsable number. */
/* Otherwise it is returned .FALSE. */
/* $ Error_Handling */
/* None. */
/* C */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Particulars */
/* This is a utility routine for the subroutine META2. It */
/* determines whether or not a word is a number in the sense */
/* of the language META/2. */
/* $ Examples */
/* WORD M2NUMB */
/* ------- ------ */
/* SPAM .FALSE. */
/* 1 .TRUE. */
/* 0.289E19 .TRUE. */
/* 0.2728D12 .TRUE. */
/* -12.1892e-5 .TRUE. */
/* 12.E29 .TRUE. */
/* 12.E291 .FALSE. */
/* .E12 .FALSE. */
/* 1.2E.12 .FALSE. */
/* $ 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 */
/* Version B1.0.0, 22-MAR-1988 (WLT) (IMU) */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Make sure the string has the right length. */
start = ltrim_(word, word_len);
end = qrtrim_(word, word_len);
length = end - start + 1;
/* Rule out the goofy cases that NPARSD will allow. */
if (length == 1) {
ret_val = l_le("0", word, (ftnlen)1, word_len) && l_ge("9", word, (
ftnlen)1, word_len);
return ret_val;
}
if (length >= 2) {
if (*(unsigned char *)&word[start - 1] == 'E' || *(unsigned char *)&
word[start - 1] == 'e' || *(unsigned char *)&word[start - 1]
== 'D' || *(unsigned char *)&word[start - 1] == 'd') {
ret_val = FALSE_;
return ret_val;
}
if (s_cmp(word + (start - 1), "+E", (ftnlen)2, (ftnlen)2) == 0 ||
s_cmp(word + (start - 1), "-E", (ftnlen)2, (ftnlen)2) == 0 ||
s_cmp(word + (start - 1), "+D", (ftnlen)2, (ftnlen)2) == 0 ||
s_cmp(word + (start - 1), "-D", (ftnlen)2, (ftnlen)2) == 0 ||
s_cmp(word + (start - 1), "-e", (ftnlen)2, (ftnlen)2) == 0 ||
s_cmp(word + (start - 1), "+e", (ftnlen)2, (ftnlen)2) == 0 ||
s_cmp(word + (start - 1), "-d", (ftnlen)2, (ftnlen)2) == 0 ||
s_cmp(word + (start - 1), "+d", (ftnlen)2, (ftnlen)2) == 0 ||
s_cmp(word + (start - 1), ".E", (ftnlen)2, (ftnlen)2) == 0 ||
s_cmp(word + (start - 1), ".D", (ftnlen)2, (ftnlen)2) == 0 ||
s_cmp(word + (start - 1), ".e", (ftnlen)2, (ftnlen)2) == 0 ||
s_cmp(word + (start - 1), ".d", (ftnlen)2, (ftnlen)2) == 0) {
ret_val = FALSE_;
return ret_val;
}
}
if (length >= 3) {
if (s_cmp(word + (start - 1), "+.E", (ftnlen)3, (ftnlen)3) == 0 ||
s_cmp(word + (start - 1), "-.E", (ftnlen)3, (ftnlen)3) == 0 ||
s_cmp(word + (start - 1), "+.D", (ftnlen)3, (ftnlen)3) == 0
|| s_cmp(word + (start - 1), "-.D", (ftnlen)3, (ftnlen)3) ==
0) {
ret_val = FALSE_;
return ret_val;
}
}
/* Ok. Now just hit the word with NPARSD. */
s_copy(error, " ", (ftnlen)80, (ftnlen)1);
nparsd_(word, &x, error, &pointr, word_len, (ftnlen)80);
/* Any errors indicate we don't have a number. */
if (s_cmp(error, " ", (ftnlen)80, (ftnlen)1) != 0) {
ret_val = FALSE_;
} else {
ret_val = TRUE_;
}
return ret_val;
} /* m2numb_ */
